{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Identity
open import HoTT.Homotopy

module HoTT.Equivalence where

open variables
private variable C : 𝒰 i

module _ (f : A → B) where
  qinv = Σ[ g ∶ (B → A) ] (g ∘ f ~ id) × (f ∘ g ~ id)

  -- Bi-invertible map
  linv = Σ[ g ∶ (B → A) ] g ∘ f ~ id
  rinv = Σ[ g ∶ (B → A) ] f ∘ g ~ id
  -- The book uses a flipped version rinv × linv for the definition in §2.4.
  biinv = linv × rinv

  -- Half-adjoint equivalence
  ishae = Σ[ g ∶ (B → A) ] Σ[ η ∶ g ∘ f ~ id ] Σ[ ε ∶ f ∘ g ~ id ] ap f ∘ η ~ ε ∘ f

module _ {f : A → B} where
  module qinv (e : qinv f) where
    g = pr₁ e
    η = pr₁ (pr₂ e)
    ε = pr₂ (pr₂ e)

  qinv→linv : qinv f → linv f
  qinv→linv e = g , η
    where open qinv e

  qinv→rinv : qinv f → rinv f
  qinv→rinv e = g , ε
    where open qinv e

  module ishae (e : ishae f) where
    g = pr₁ e
    η = pr₁ (pr₂ e)
    ε = pr₁ (pr₂ (pr₂ e))
    τ = pr₂ (pr₂ (pr₂ e))

  ishae→qinv : ishae f → qinv f
  ishae→qinv e = g , η , ε
    where open ishae e

  qinv→ishae : qinv f → ishae f
  qinv→ishae e = g , η , ε' , τ
    where
    open qinv e
    ε' : f ∘ g ~ id
    ε' b = ε (f (g b)) ⁻¹ ∙ (ap f (η (g b)) ∙ ε b)
    τ : ap f ∘ η ~ ε' ∘ f
    τ a =
      ap f (η a)                        =⟨ unitₗ ⟩
      refl ∙ ap f (η a)                 =⟨ invₗ ⁻¹ ∙ᵣ _ ⟩
      _ ∙ ε (f (g (f a))) ∙ ap f (η a)  =⟨ assoc ⁻¹ ⟩
      _ ∙ (_ ∙ ap f (η a))              =⟨ _ ∙ₗ (_ ∙ₗ ap-id (ap f (η a)) ⁻¹) ⟩
      _ ∙ (ε (f (g (f a))) ∙ ap id _)   =⟨ _ ∙ₗ ~-natural ε (ap f (η a)) ⟩
      _ ∙ (ap (f ∘ g) (ap f (η a)) ∙ _) =⟨ _ ∙ₗ (ap-∘ (f ∘ g) f (η a) ⁻¹ ∙ᵣ _) ⟩
      _ ∙ (ap (f ∘ g ∘ f) (η a) ∙ _)    =⟨ _ ∙ₗ (ap-∘ f (g ∘ f) (η a) ∙ᵣ _) ⟩
      _ ∙ (ap f (ap (g ∘ f) (η a)) ∙ _) =⟨ _ ∙ₗ (ap (ap f) (~-natural-comm η a ⁻¹) ∙ᵣ _) ⟩
      ε' (f a)                          ∎
      where open =-Reasoning

  module biinv (e : biinv f) where
    h = pr₁ (pr₁ e)
    β = pr₂ (pr₁ e)
    g = pr₁ (pr₂ e)
    α = pr₂ (pr₂ e)

  biinv→qinv : biinv f → qinv f
  biinv→qinv e = g , β' , α
    where
    open biinv e
    γ : g ~ h
    γ x = β (g x) ⁻¹ ∙ ap h (α x)
    β' : g ∘ f ~ id
    β' x = γ (f x) ∙ β x

  qinv→biinv : qinv f → biinv f
  qinv→biinv e = (g , η) , (g , ε)
    where open qinv e

module _ {f₁ : B → C} {f₂ : A → B} where
  ishae-∘ : ishae f₁ → ishae f₂ → ishae (f₁ ∘ f₂)
  ishae-∘ e₁ e₂ = g , η , ε , τ
    where
    open ishae e₁ renaming (g to g₁ ; η to η₁ ; ε to ε₁ ; τ to τ₁)
    open ishae e₂ renaming (g to g₂ ; η to η₂ ; ε to ε₂ ; τ to τ₂)
    f = f₁ ∘ f₂
    g = g₂ ∘ g₁
    η : g ∘ f ~ id
    η x = ap g₂ (η₁ (f₂ x)) ∙ η₂ x
    ε : f ∘ g ~ id
    ε x = ap f₁ (ε₂ (g₁ x)) ∙ ε₁ x
    τ : ap f ∘ η ~ ε ∘ f
    τ x =
      ap f (η x)                                       =⟨ ap-∘ f₁ f₂ (ap g₂ (η₁ (f₂ x)) ∙ η₂ x) ⟩
      ap f₁ (ap f₂ (η x))                              =⟨ ap (ap f₁) (ap-∙ f₂ (ap g₂ (η₁ (f₂ x))) (η₂ x)) ⟩
      ap f₁ (ap f₂ (ap g₂ (η₁ (f₂ x))) ∙ ap f₂ (η₂ x)) =⟨ ap (ap f₁) (ap f₂ _ ∙ₗ τ₂ x) ⟩
      ap f₁ (ap f₂ (ap g₂ (η₁ (f₂ x))) ∙ ε₂ (f₂ x))    =⟨ ap (ap f₁) (ap-∘ f₂ g₂ _ ⁻¹ ∙ᵣ ε₂ (f₂ x)) ⟩
      ap f₁ (ap (f₂ ∘ g₂) (η₁ (f₂ x)) ∙ ε₂ (f₂ x))     =⟨ ap (ap f₁) (~-natural ε₂ (η₁ (f₂ x))) ⁻¹ ⟩
      ap f₁ (ε₂ (g₁ (f x)) ∙ ap id (η₁ (f₂ x)))        =⟨ ap (ap f₁) (ε₂ (g₁ (f x)) ∙ₗ ap-id (η₁ (f₂ x))) ⟩
      ap f₁ (ε₂ (g₁ (f x)) ∙ η₁ (f₂ x))                =⟨ ap-∙ f₁ (ε₂ (g₁ (f x))) (η₁ (f₂ x)) ⟩
      ap f₁ (ε₂ (g₁ (f x))) ∙ ap f₁ (η₁ (f₂ x))        =⟨ _ ∙ₗ τ₁ (f₂ x) ⟩
      ε (f x)                                          ∎
      where open =-Reasoning

  biinv-∘ : biinv f₁ → biinv f₂ → biinv (f₁ ∘ f₂)
  biinv-∘ e₁ e₂ = (h , β) , (g , α)
    where
    open biinv e₁ renaming (h to h₁ ; β to β₁ ; g to g₁ ; α to α₁)
    open biinv e₂ renaming (h to h₂ ; β to β₂ ; g to g₂ ; α to α₂)
    f = f₁ ∘ f₂
    h = h₂ ∘ h₁
    β : h ∘ f ~ id
    β x = ap h₂ (β₁ (f₂ x)) ∙ β₂ x
    g = g₂ ∘ g₁
    α : f ∘ g ~ id
    α x = ap f₁ (α₂ (g₁ x)) ∙ α₁ x

-- Choose isequiv :≡ biinv since it is quicker to compute.
isequiv = biinv
qinv→isequiv = qinv→biinv
isequiv→qinv = biinv→qinv
isequiv-∘ = biinv-∘

_≃_ : 𝒰 i → 𝒰 j → 𝒰 (i ⊔ j)
A ≃ B = Σ (A → B) isequiv
infixr 5 _≃_

record Iso (A : 𝒰 i) (B : 𝒰 j) : 𝒰 (i ⊔ j) where
  field
    f : A → B
    g : B → A
    η : g ∘ f ~ id
    ε : f ∘ g ~ id

iso→eqv : Iso A B → A ≃ B
iso→eqv iso = f , qinv→isequiv (g , η , ε)
  where open Iso iso

eqv→iso : A ≃ B → Iso A B
eqv→iso e = record { f = pr₁ e ; g = g ; η = η ; ε = ε }
  where open qinv (isequiv→qinv (pr₂ e))

module Eqv {i} {j} {A : 𝒰 i} {B : 𝒰 j} (e : A ≃ B) = Iso (eqv→iso e)

-- Lemma 2.4.12
--  (i)
reflₑ : A ≃ A
reflₑ = id , qinv→isequiv (id , (λ _ → refl) , (λ _ → refl))

--  (ii)
_⁻¹ₑ : A ≃ B → B ≃ A
e ⁻¹ₑ = g , qinv→isequiv (pr₁ e , ε , η)
  where
  open qinv (isequiv→qinv (pr₂ e))
infix 30 _⁻¹ₑ

--  (iii)
_∙ₑ_ : A ≃ B → B ≃ C → A ≃ C
e₁ ∙ₑ e₂ = pr₁ e₂ ∘ pr₁ e₁ , isequiv-∘ (pr₂ e₂) (pr₂ e₁)
infixl 20 _∙ₑ_

idtoeqv : A == B → A ≃ B
idtoeqv p = transport id p , e
  where
  e : isequiv (transport id p)
  e rewrite p = pr₂ reflₑ

module ≃-Reasoning
  where
  _≃⟨_⟩_ : (A : 𝒰 i) → A ≃ B → B ≃ C → A ≃ C
  x ≃⟨ e₁ ⟩ e₂ = e₁ ∙ₑ e₂
  infixr 2 _≃⟨_⟩_

  _∎ : (A : 𝒰 i) → A ≃ A
  _ ∎ = reflₑ
  infix 3 _∎


module SimpleTT where

  data 𝟘 : Set where

  absurd : ∀ {ℓ} {A : Set ℓ} → 𝟘 → A
  absurd ()

  data _⁺ (A : Set) : Set where
     Z : A ⁺
     S : A → A ⁺

  record Signature : Set₁ where
    field
      ty-op : Set
      tm-op : Set
      ty-ty-arg : ty-op → Set
      -- ty-tm-arg : ty-op → Set
      -- tm-ty-arg : tm-op → Set
      tm-tm-arg : tm-op → Set

  open Signature

  data Theory : Set₁
  thy-signature : Theory → Signature
  data Ty (T : Theory) : Set
  data Tm (T : Theory) (A : Ty T) : Set

  data Theory where
    thy-empty : Theory
    th-type : ∀ (T : Theory) → (α : Set) → (α → Ty T) → Theory
    th-term : ∀ (T : Theory) → (α : Set) → (α → Ty T) → Ty T → Theory

  thy-signature thy-empty =
    record { ty-op = 𝟘
           ; tm-op = 𝟘
           ; ty-ty-arg = absurd
           ; tm-tm-arg = absurd
           }

  thy-signature (th-type T α x) =
    record { ty-op = (ty-op Σ) ⁺
           ; tm-op = tm-op Σ
           ; ty-ty-arg = t
           ; tm-tm-arg = tm-tm-arg Σ
           }
    where
      Σ = thy-signature T
      t : ∀ (f : (ty-op Σ) ⁺) → Set
      t Z = α
      t (S f) = ty-ty-arg (thy-signature T) f

  thy-signature (th-term T α ts t) =
    record { ty-op = ty-op Σ
           ; tm-op = (tm-op Σ) ⁺
           ; ty-ty-arg = ty-ty-arg Σ
           ; tm-tm-arg = tm
           }
    where
      Σ = thy-signature T
      tm : ∀ (f : (tm-op Σ) ⁺) → Set
      tm Z = {!!}
      tm (S x) = {!!}

  data Ty T where
    ty-expr : ∀ (f : ty-op (thy-signature T)) → (ty-ty-arg (thy-signature T) f → Ty T) → Ty T

  data Tm T A where


postulate
  A : Set

open import Agda.Builtin.Equality

-- here the solution g := (\ (@0 x) (@0 y) → f y x) is not well-typed
-- in a non-erased context, which is how `g` is declared.
bar : (f : A → A → A) (g : @0 A → @0 A → A)
    → @0 _≡_ {A = @0 A → @0 A → A} g (\ (@0 x) (@0 y) → f y x)
    → @0 A → @0 A → A
bar f g refl = g


-- Andreas, 2016-12-20, issue #2350
-- Agda ignores a wrong instance parameter to a constructor

data D {{a}} (A : Set a) : Set a where
  c : A → D A

test : ∀ ℓ {ℓ'} (A : Set ℓ') {B : Set ℓ} (a : A) → D A
test ℓ A a = c {{ℓ}} a

-- Expected Error:
-- .ℓ' != ℓ of type .Agda.Primitive.Level
-- when checking that the expression a has type A


module ProjectionLikeAndMatching where

data Unit : Set where
  * : Unit

data Box A : Set where
  [_] : A → Box A

-- Unbox should not be considered projection-like since it's matching on more than
-- the eliminatee.
unbox : ∀ {A} → Box A → Unit → A
unbox [ x ] * = x

postulate
  Thm : {A : Set} → A → Set
  prf : {A : Set}(x : A) → Thm x

-- If unbox was projection-like we would end up with
--   [_] (apply x) (elim unbox) (apply u) : A
-- and we wouldn't be able to reconstruct the parameter
-- argument to [_].
lem : ∀ {A} (x : A) u → Thm (unbox [ x ] u)
lem x u = prf (unbox [ x ] u)


{-# OPTIONS --safe #-}
module Cubical.Algebra.OrderedCommMonoid where

open import Cubical.Algebra.OrderedCommMonoid.Base public
open import Cubical.Algebra.OrderedCommMonoid.Properties public


{-# OPTIONS --cubical --safe #-}
module CubicalAbsurd where

open import Cubical.Core.Everything
open import Cubical.Data.Nat
open import Cubical.Data.Empty

theWrongThing : 1 + 1 ≡ 3 → ⊥
theWrongThing thatMoney = znots (injSuc (injSuc thatMoney))


{-# OPTIONS --cubical #-}
module _ where

open import Agda.Builtin.Equality

uip : ∀ {a} {A : Set a} {x y : A} (p q : x ≡ y) → p ≡ q
uip refl refl = refl


{-# OPTIONS -v tc.lhs.shadow:30 #-}

{-# OPTIONS --copatterns #-}

module PatternShadowsConstructor4 where

module A where

  data B : Set where
    x : B

  data C : Set where
    c : B → C

open A using (C; c)

record R : Set where
  field
    fst : C → C
    snd : A.B
open R

r : R
fst r (c x) = x
snd r       = A.B.x


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Categories.Instances.EilenbergMoore where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism renaming (Iso to _≅_)
open import Cubical.Foundations.Univalence

open import Cubical.Categories.Category
open import Cubical.Categories.Functor renaming (𝟙⟨_⟩ to funcId)
open import Cubical.Categories.NaturalTransformation.Base
open import Cubical.Categories.Monad.Base
open import Cubical.Categories.Instances.FunctorAlgebras
open import Cubical.Categories.Constructions.FullSubcategory
open import Cubical.Categories.Adjoint

private
  variable
    ℓC ℓC' : Level

module _ {C : Category ℓC ℓC'} (monadM : Monad C) where

  private
    M : Functor C C
    M = fst monadM

  --open Category
  private
    module C = Category C
  open Functor
  open NatTrans

  open IsMonad (snd monadM)

  record IsEMAlgebra (algA : Algebra M) : Type ℓC' where
    constructor proveEMAlgebra
    open Algebra algA
    field
      str-η : str C.∘ N-ob η carrier ≡ C.id
      str-μ : str C.∘ N-ob μ carrier ≡ str C.∘ F-hom M str

  open IsEMAlgebra

  isPropIsEMAlgebra : ∀ {algA} → isProp (IsEMAlgebra algA)
  isPropIsEMAlgebra {algA} isalg isalg' = cong₂ proveEMAlgebra
    (C.isSetHom _ _ (str-η isalg) (str-η isalg'))
    (C.isSetHom _ _ (str-μ isalg) (str-μ isalg'))

  EMAlgebra : Type (ℓ-max ℓC ℓC')
  EMAlgebra = Σ[ algA ∈ Algebra M ] IsEMAlgebra algA

  EMCategory : Category (ℓ-max (ℓ-max ℓC ℓC') ℓC') ℓC'
    -- cannot simplify level: --experimental-lossy-unification won't allow it.
  EMCategory = FullSubcategory (AlgebrasCategory M) IsEMAlgebra

  ForgetEM : Functor EMCategory (AlgebrasCategory M)
  ForgetEM = FullInclusion (AlgebrasCategory M) IsEMAlgebra

  ForgetEMAlgebra : Functor EMCategory C
  ForgetEMAlgebra = funcComp (ForgetAlgebra M) ForgetEM

  open Algebra
  freeEMAlgebra : C.ob → EMAlgebra
  carrier (fst (freeEMAlgebra x)) = F-ob M x
  str (fst (freeEMAlgebra x)) = N-ob μ x
  str-η (snd (freeEMAlgebra x)) = lemma
    where lemma : N-ob η (F-ob M x) C.⋆ N-ob μ x ≡ C.id
          lemma = funExt⁻ (congP (λ i → N-ob) idl-μ) x
  str-μ (snd (freeEMAlgebra x)) = lemma
    where lemma : N-ob μ (F-ob M x) C.⋆ N-ob μ x ≡ F-hom M (N-ob μ x) C.⋆ N-ob μ x
          lemma = funExt⁻ (congP (λ i → N-ob) (symP-fromGoal assoc-μ)) x

  open AlgebraHom
  FreeEMAlgebra : Functor C EMCategory
  F-ob FreeEMAlgebra x = freeEMAlgebra x
  carrierHom (F-hom FreeEMAlgebra {x} {y} φ) = F-hom M φ
  strHom (F-hom FreeEMAlgebra {x} {y} φ) = sym (N-hom μ φ)
  F-id FreeEMAlgebra = AlgebraHom≡ M (F-id M)
  F-seq FreeEMAlgebra {x} {y} {z} φ ψ = AlgebraHom≡ M (F-seq M φ ψ)

  ForgetFreeEMAlgebra : funcComp ForgetEMAlgebra FreeEMAlgebra ≡ M
  ForgetFreeEMAlgebra = Functor≡ (λ x → refl) (λ f → refl)

  emCounit : NatTrans (funcComp FreeEMAlgebra ForgetEMAlgebra) (funcId EMCategory)
  carrierHom (N-ob emCounit (algebra A α , isEMA)) = α
  strHom (N-ob emCounit (algebra A α , isEMA)) = str-μ isEMA
  N-hom emCounit {algebra A α , isEMA} {algebra B β , isEMB} (algebraHom f isalgF) =
    AlgebraHom≡ M (sym (isalgF))

  open NaturalBijection
  open _⊣_
  open _≅_

  emBijection : ∀ a emB →
    (EMCategory [ FreeEMAlgebra ⟅ a ⟆ , emB ]) ≅ (C [ a , ForgetEMAlgebra ⟅ emB ⟆ ])
  fun (emBijection a (algebra b β , isEMB)) (algebraHom f isalgF) = f C.∘ N-ob η a
  carrierHom (inv (emBijection a (algebra b β , isEMB)) f) = β C.∘ F-hom M f
  strHom (inv (emBijection a (algebra b β , isEMB)) f) =
    (N-ob μ a C.⋆ (F-hom M f C.⋆ β))
      ≡⟨ sym (C.⋆Assoc _ _ _) ⟩
    ((N-ob μ a C.⋆ F-hom M f) C.⋆ β)
      ≡⟨ cong (C._⋆ β) (sym (N-hom μ f)) ⟩
    ((F-hom M (F-hom M f) C.⋆ N-ob μ b) C.⋆ β)
      ≡⟨ C.⋆Assoc _ _ _ ⟩
    (F-hom M (F-hom M f) C.⋆ (N-ob μ b C.⋆ β))
      ≡⟨ cong (F-hom M (F-hom M f) C.⋆_) (str-μ isEMB) ⟩
    (F-hom M (F-hom M f) C.⋆ (F-hom M β C.⋆ β))
      ≡⟨ sym (C.⋆Assoc _ _ _) ⟩
    ((F-hom M (F-hom M f) C.⋆ F-hom M β) C.⋆ β)
      ≡⟨ cong (C._⋆ β) (sym (F-seq M _ _)) ⟩
    (F-hom M (F-hom M f C.⋆ β) C.⋆ β) ∎
  rightInv (emBijection a (algebra b β , isEMB)) f =
    (N-ob η a C.⋆ (F-hom M f C.⋆ β))
      ≡⟨ sym (C.⋆Assoc _ _ _) ⟩
    ((N-ob η a C.⋆ F-hom M f) C.⋆ β)
      ≡⟨ cong (C._⋆ β) (sym (N-hom η f)) ⟩
    ((f C.⋆ N-ob η b) C.⋆ β)
      ≡⟨ C.⋆Assoc _ _ _ ⟩
    (f C.⋆ (N-ob η b C.⋆ β))
      ≡⟨ cong (f C.⋆_) (str-η isEMB) ⟩
    (f C.⋆ C.id)
      ≡⟨ C.⋆IdR _ ⟩
    f ∎
  leftInv (emBijection a (algebra b β , isEMB)) (algebraHom f isalgF) = AlgebraHom≡ M (
    (F-hom M (N-ob η a C.⋆ f) C.⋆ β)
      ≡⟨ cong (C._⋆ β) (F-seq M _ _) ⟩
    ((F-hom M (N-ob η a) C.⋆ F-hom M f) C.⋆ β)
      ≡⟨ C.⋆Assoc _ _ _ ⟩
    (F-hom M (N-ob η a) C.⋆ (F-hom M f C.⋆ β))
      ≡⟨ cong (F-hom M (N-ob η a) C.⋆_) (sym isalgF) ⟩
    (F-hom M (N-ob η a) C.⋆ (N-ob μ a C.⋆ f))
      ≡⟨ sym (C.⋆Assoc _ _ _) ⟩
    ((F-hom M (N-ob η a) C.⋆ N-ob μ a) C.⋆ f)
      ≡⟨ cong (C._⋆ f) (funExt⁻ (congP (λ i → N-ob) idr-μ) a) ⟩
    (C.id C.⋆ f)
      ≡⟨ C.⋆IdL f ⟩
    f ∎
    )

  emAdjunction : FreeEMAlgebra ⊣ ForgetEMAlgebra
  adjIso emAdjunction {a} {algebra b β , isEMB} = emBijection a (algebra b β , isEMB)
  adjNatInD emAdjunction {a} {algebra b β , isEMB} {algebra c γ , isEMC}
    (algebraHom f isalgF) (algebraHom g isalgG) =
    sym (C.⋆Assoc _ _ _)
  adjNatInC emAdjunction {a} {b} {algebra c γ , isEMC} f g = AlgebraHom≡ M (
    (F-hom M (g C.⋆ f) C.⋆ γ)
      ≡⟨ cong (C._⋆ γ) (F-seq M _ _) ⟩
    ((F-hom M g C.⋆ F-hom M f) C.⋆ γ)
      ≡⟨ C.⋆Assoc _ _ _ ⟩
    (F-hom M g C.⋆ (F-hom M f C.⋆ γ)) ∎
    )

module _ {C : Category ℓC ℓC'} {monadM monadN : Monad C} (monadν : MonadHom monadM monadN) where

  open Category C
  open Functor
  open IsEMAlgebra
  open NatTrans

  private
    M N : Functor C C
    M = fst monadM
    N = fst monadN
    module M = IsMonad (snd monadM)
    module N = IsMonad (snd monadN)
    ν : NatTrans M N
    ν = fst monadν
    module ν = IsMonadHom (snd monadν)

  mapIsEMAlgebra : (algA : Algebra N) → IsEMAlgebra monadN algA → IsEMAlgebra monadM (F-ob (AlgebrasFunctor ν) algA)
  str-η (mapIsEMAlgebra (algebra a αN) isEMA) =
    N-ob M.η a ⋆ (N-ob ν a ⋆ αN)
      ≡⟨ sym (⋆Assoc _ _ _) ⟩
    (N-ob M.η a ⋆ N-ob ν a) ⋆ αN
      ≡⟨ cong (_⋆ αN) (cong (λ θ → N-ob θ a) ν.N-η) ⟩
    N-ob N.η a ⋆ αN
      ≡⟨ isEMA .str-η ⟩
    id ∎
  str-μ (mapIsEMAlgebra (algebra a αN) isEMA) =
    N-ob M.μ a ⋆ (N-ob ν a ⋆ αN)
      ≡⟨ sym (⋆Assoc _ _ _) ⟩
    (N-ob M.μ a ⋆ N-ob ν a) ⋆ αN
      ≡⟨ cong (_⋆ αN) (cong (λ θ → N-ob θ a) ν.N-μ) ⟩
    ((F-hom M (N-ob ν a) ⋆ N-ob ν (F-ob N a)) ⋆ N-ob N.μ a) ⋆ αN
      ≡⟨ ⋆Assoc _ _ _ ⟩
    (F-hom M (N-ob ν a) ⋆ N-ob ν (F-ob N a)) ⋆ (N-ob N.μ a ⋆ αN)
      ≡⟨ cong ((F-hom M (N-ob ν a) ⋆ N-ob ν (F-ob N a)) ⋆_) (isEMA .str-μ) ⟩
    (F-hom M (N-ob ν a) ⋆ N-ob ν (F-ob N a)) ⋆ (F-hom N αN ⋆ αN)
      ≡⟨ sym (⋆Assoc _ _ _) ⟩
    ((F-hom M (N-ob ν a) ⋆ N-ob ν (F-ob N a)) ⋆ F-hom N αN) ⋆ αN
      ≡⟨ cong (_⋆ αN) (⋆Assoc _ _ _) ⟩
    (F-hom M (N-ob ν a) ⋆ (N-ob ν (F-ob N a) ⋆ F-hom N αN)) ⋆ αN
      ≡⟨ cong (_⋆ αN) (cong (F-hom M (N-ob ν a) ⋆_) (sym (N-hom ν αN))) ⟩
    (F-hom M (N-ob ν a) ⋆ (F-hom M αN ⋆ N-ob ν a)) ⋆ αN
      ≡⟨ cong (_⋆ αN) (sym (⋆Assoc _ _ _)) ⟩
    ((F-hom M (N-ob ν a) ⋆ F-hom M αN) ⋆ N-ob ν a) ⋆ αN
      ≡⟨ cong (_⋆ αN) (cong (_⋆ N-ob ν a) (sym (F-seq M _ _))) ⟩
    (F-hom M (N-ob ν a ⋆ αN) ⋆ N-ob ν a) ⋆ αN
      ≡⟨ ⋆Assoc _ _ _ ⟩
    F-hom M (N-ob ν a ⋆ αN) ⋆ (N-ob ν a ⋆ αN) ∎

  EMFunctor : Functor (EMCategory monadN) (EMCategory monadM)
  EMFunctor = MapFullSubcategory
    (AlgebrasCategory N) (IsEMAlgebra monadN)
    (AlgebrasCategory M) (IsEMAlgebra monadM)
    (AlgebrasFunctor ν) mapIsEMAlgebra


open import Prelude
open import core

module lemmas-consistency where
  -- type consistency is symmetric
  ~sym : {t1 t2 : typ} → t1 ~ t2 → t2 ~ t1
  ~sym TCRefl = TCRefl
  ~sym TCHole1 = TCHole2
  ~sym TCHole2 = TCHole1
  ~sym (TCArr p1 p2) = TCArr (~sym p1) (~sym p2)
  ~sym (TCProd h h₁) = TCProd (~sym h) (~sym h₁)

  -- type consistency isn't transitive
  not-trans : ((t1 t2 t3 : typ) → t1 ~ t2 → t2 ~ t3 → t1 ~ t3) → ⊥
  not-trans t with t (b ==> b) ⦇·⦈ b TCHole1 TCHole2
  ... | ()

  --  every pair of types is either consistent or not consistent
  ~dec : (t1 t2 : typ) → ((t1 ~ t2) + (t1 ~̸ t2))
    -- this takes care of all hole cases, so we don't consider them below
  ~dec _ ⦇·⦈ = Inl TCHole1
  ~dec ⦇·⦈ b = Inl TCHole2
  ~dec ⦇·⦈ (q ==> q₁) = Inl TCHole2
  ~dec ⦇·⦈ (q ⊗ q₁) = Inl TCHole2
    -- num cases
  ~dec b b = Inl TCRefl
  ~dec b (t2 ==> t3) = Inr ICBaseArr1
    -- arrow cases
  ~dec (t1 ==> t2) b = Inr ICBaseArr2
  ~dec (t1 ==> t2) (t3 ==> t4) with ~dec t1 t3 | ~dec t2 t4
  ... | Inl x | Inl y = Inl (TCArr x y)
  ... | Inl _ | Inr y = Inr (ICArr2 y)
  ... | Inr x | _     = Inr (ICArr1 x)
  ~dec b (t2 ⊗ t3) = Inr ICBaseProd1
  ~dec (t1 ==> t2) (t3 ⊗ t4) = Inr ICProdArr1
  ~dec (t1 ⊗ t2) b = Inr ICBaseProd2
  ~dec (t1 ⊗ t2) (t3 ==> t4) = Inr ICProdArr2
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) with ~dec t1 t3 | ~dec t2 t4
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) | Inl x | Inl x₁ = Inl (TCProd x x₁)
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) | Inl x | Inr x₁ = Inr (ICProd2 x₁)
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) | Inr x | Inl x₁ = Inr (ICProd1 x)
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) | Inr x | Inr x₁ = Inr (ICProd1 x)

  -- no pair of types is both consistent and not consistent
  ~apart : {t1 t2 : typ} → (t1 ~̸ t2) → (t1 ~ t2) → ⊥
  ~apart ICBaseArr1 ()
  ~apart ICBaseArr2 ()
  ~apart (ICArr1 x) TCRefl = ~apart x TCRefl
  ~apart (ICArr1 x) (TCArr y y₁) = ~apart x y
  ~apart (ICArr2 x) TCRefl = ~apart x TCRefl
  ~apart (ICArr2 x) (TCArr y y₁) = ~apart x y₁
  ~apart ICBaseProd1 ()
  ~apart ICBaseProd2 ()
  ~apart ICProdArr1 ()
  ~apart ICProdArr2 ()
  ~apart (ICProd1 h) TCRefl = ~apart h TCRefl
  ~apart (ICProd1 h) (TCProd h₁ h₂) = ~apart h h₁
  ~apart (ICProd2 h) TCRefl = ~apart h TCRefl
  ~apart (ICProd2 h) (TCProd h₁ h₂) = ~apart h h₂

  ~apart-converse : (τ1 τ2 : typ) → (τ1 ~ τ2 → ⊥) → τ1 ~̸ τ2
  ~apart-converse τ1 τ2 ne with ~dec τ1 τ2
  ~apart-converse τ1 τ2 ne    | Inl h      = abort (ne h)
  ~apart-converse τ1 τ2 ne    | Inr h      = h

  ~decPair : (τ1 τ2 τ3 τ4 : typ) → ((τ1 ⊗ τ2) ~ (τ3 ⊗ τ4) → ⊥) → (τ1 ~ τ3 → ⊥) + (τ2 ~ τ4 → ⊥)
  ~decPair τ1 τ2 τ3 τ4 inc with ~apart-converse (τ1 ⊗ τ2) (τ3 ⊗ τ4) inc
  ~decPair τ1 τ2 τ3 τ4 inc    | ICProd1 h                                = Inl (~apart h)
  ~decPair τ1 τ2 τ3 τ4 inc    | ICProd2 h                                = Inr (~apart h)

  ~prod1 : ∀{τ1 τ2 τ3 τ4} → (τ1 ⊗ τ2) ~ (τ3 ⊗ τ4) → τ1 ~ τ3
  ~prod1 TCRefl = TCRefl
  ~prod1 (TCProd h1 h2) = h1

  ~prod2 : ∀{τ1 τ2 τ3 τ4} → (τ1 ⊗ τ2) ~ (τ3 ⊗ τ4) → τ2 ~ τ4
  ~prod2 TCRefl = TCRefl
  ~prod2 (TCProd h1 h2) = h2


{-# OPTIONS --safe #-}

module README where

-- Formalization for "Decidability of Conversion for Setoid Type Theory"
-- Git repository: https://github.com/CoqHott/logrel-mltt/

------------------
-- INTRODUCTION --
------------------

-- A minimal library necessary for formalization:

-- The empty type and its elimination rule.
import Tools.Empty

-- The unit type.
import Tools.Unit

-- Sum type.
import Tools.Sum

-- Product type.
import Tools.Product

-- Identity function and composition.
import Tools.Function

-- Negation and decidability type.
import Tools.Nullary

-- Propositional equality and its properties.
import Tools.PropositionalEquality

-- Natural numbers and decidability of equality.
import Tools.Nat

-- Lists definition
import Tools.List

---------------------------
-- LANGUAGE INTRODUCTION --
---------------------------

-- Syntax and semantics of weakening and substitution.
import Definition.Untyped

-- Propositional equality properties: Equalities between expressions,
-- weakenings, substitutions and their combined composition.
-- (These lemmas are not in the paper.)
import Definition.Untyped.Properties

-- Judgements: Typing rules, conversion, reduction rules
-- and well-formed substitutions and respective equality.
import Definition.Typed

-- Well-formed context extraction and reduction properties.
import Definition.Typed.Properties

-- Well-formed weakening and its properties.
import Definition.Typed.Weakening

------------------------------
-- KRIPKE LOGICAL RELATIONS --
------------------------------

-- Generic equality relation definition.
import Definition.Typed.EqualityRelation

-- The judgemental instance of the generic equality.
import Definition.Typed.EqRelInstance

-- Logical relations definitions.
import Definition.LogicalRelation

-- Properties of logical relation:

-- Reflexivity of the logical relation.
import Definition.LogicalRelation.Properties.Reflexivity

-- Escape lemma for the logical relation.
import Definition.LogicalRelation.Properties.Escape

-- Shape view of two or more types.
import Definition.LogicalRelation.ShapeView

-- Proof irrelevance for the logical relation.
import Definition.LogicalRelation.Irrelevance

-- Weakening of logical relation judgements.
import Definition.LogicalRelation.Weakening

-- Conversion of the logical relation.
import Definition.LogicalRelation.Properties.Conversion

-- Symmetry of the logical relation.
import Definition.LogicalRelation.Properties.Symmetry

-- Transitvity of the logical relation.
import Definition.LogicalRelation.Properties.Transitivity

-- Neutral introduction in the logical relation.
import Definition.LogicalRelation.Properties.Neutral

-- Weak head expansion of the logical relation.
import Definition.LogicalRelation.Properties.Reduction

-- Application in the logical relation.
import Definition.LogicalRelation.Application

-- Validity judgements definitions
import Definition.LogicalRelation.Substitution

-- Properties of validity judgements:

-- Proof irrelevance for the validity judgements.
import Definition.LogicalRelation.Substitution.Irrelevance

-- Properties about valid substitutions:
-- * Substitution well-formedness.
-- * Substitution weakening.
-- * Substitution lifting.
-- * Identity substitution.
-- * Reflexivity, symmetry and transitivity of substitution equality.
import Definition.LogicalRelation.Substitution.Properties

-- Single term substitution of validity judgements.
import Definition.LogicalRelation.Substitution.Introductions.SingleSubst

-- The fundamental theorem.
import Definition.LogicalRelation.Fundamental

-- Certain cases of the fundamental theorem

-- Validity of the universes
import Definition.LogicalRelation.Substitution.Introductions.Universe

-- Validity of the empty type and its eliminator
import Definition.LogicalRelation.Substitution.Introductions.Empty
import Definition.LogicalRelation.Substitution.Introductions.Emptyrec

-- Validity of natural numbers and its eliminator
import Definition.LogicalRelation.Substitution.Introductions.Nat
import Definition.LogicalRelation.Substitution.Introductions.Natrec

-- Validity of Π-types, abstractions and applications
import Definition.LogicalRelation.Substitution.Introductions.Pi
import Definition.LogicalRelation.Substitution.Introductions.Application
import Definition.LogicalRelation.Substitution.Introductions.Lambda

-- Validity of ∃-types, pairs and projections
import Definition.LogicalRelation.Substitution.Introductions.Sigma
import Definition.LogicalRelation.Substitution.Introductions.Pair
import Definition.LogicalRelation.Substitution.Introductions.Fst
import Definition.LogicalRelation.Substitution.Introductions.Snd

-- Validity of type casting and proof-irrelevant transport
import Definition.LogicalRelation.Substitution.Introductions.Castlemmas
import Definition.LogicalRelation.Substitution.Introductions.Cast
import Definition.LogicalRelation.Substitution.Introductions.CastPi
import Definition.LogicalRelation.Substitution.Introductions.Transp

-- Validity of identity types, and reflexivity
import Definition.LogicalRelation.Substitution.Introductions.Idlemmas
import Definition.LogicalRelation.Substitution.Introductions.IdUniv
import Definition.LogicalRelation.Substitution.Introductions.IdNat
import Definition.LogicalRelation.Substitution.Introductions.IdPi
import Definition.LogicalRelation.Substitution.Introductions.IdUPiPi
import Definition.LogicalRelation.Substitution.Introductions.IdRefl

-- Reducibility of well-formedness.
import Definition.LogicalRelation.Fundamental.Reducibility

-- Consequences of the fundamental theorem:

-- Consistency (no proof of False in the empty context) implies
-- canonicity of the system.
import Definition.Typed.Consequences.Canonicity

-- Injectivity of Π-types.
import Definition.Typed.Consequences.Injectivity

-- Syntactic validitiy of the system.
import Definition.Typed.Consequences.Syntactic

-- All types and terms fully reduce to WHNF.
import Definition.Typed.Consequences.Reduction

-- Strong equality of types.
import Definition.Typed.Consequences.Equality

-- Syntactic inequality of types.
import Definition.Typed.Consequences.Inequality

-- Substitution in judgements and substitution composition.
import Definition.Typed.Consequences.Substitution

-- Uniqueness of the types of neutral terms.
import Definition.Typed.Consequences.NeTypeEq

-- Consistency (0 is not judgementally equal to 1) of the type theory.
import Definition.Typed.Consequences.Consistency

-- Types can only belong to one universe (because of annotations)
-- also various inequalities for conversion
import Definition.Typed.Consequences.PiNorm
import Definition.Typed.Consequences.RelevanceUnicity

-- Terms can only admit one type
import Definition.Typed.Consequences.TypeUnicity

-- Various inversion results
import Definition.Typed.Consequences.TypeUnicity

------------------
-- DECIDABILITY --
------------------

-- Conversion algorithm definition.
import Definition.Conversion

-- Properties of conversion algorithm:

-- Context equality and its properties:
-- * Context conversion of typing judgements.
-- * Context conversion of reductions and algorithmic equality.
-- * Reflexivity and symmetry of context equality.
import Definition.Conversion.Stability

-- Soundness of the conversion algorithm.
import Definition.Conversion.Soundness

-- Results around normalisation of reflexive terms
import Definition.Conversion.FullReduction

-- Conversion property of algorithmic equality.
import Definition.Conversion.Conversion

-- Decidability of the conversion algorithm.
import Definition.Conversion.Decidable

-- Symmetry of the conversion algorithm.
import Definition.Conversion.Symmetry

-- Transitivity of the conversion algorithm.
import Definition.Conversion.Transitivity

-- Weakening of the conversion algorithm.
import Definition.Conversion.Weakening

-- WHNF and neutral lifting of the conversion algorithm.
import Definition.Conversion.Lift

-- Generic equality relation instance for the conversion algorithm.
import Definition.Conversion.EqRelInstance

-- Completeness of conversion algorithm.
import Definition.Conversion.Consequences.Completeness

-- Decidability of judgemental conversion.
import Definition.Conversion.HelperDecidable
import Definition.Typed.Decidable


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties about subsets
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Fin.Subset.Properties where

open import Algebra
import Algebra.FunctionProperties as AlgebraicProperties
import Algebra.Structures as AlgebraicStructures
import Algebra.Properties.Lattice as L
import Algebra.Properties.DistributiveLattice as DL
import Algebra.Properties.BooleanAlgebra as BA
open import Data.Bool.Properties
open import Data.Fin using (Fin; suc; zero)
open import Data.Fin.Subset
open import Data.Fin.Properties using (any?; decFinSubset)
open import Data.Nat.Base using (ℕ; zero; suc; z≤n; s≤s; _≤_)
open import Data.Nat.Properties using (≤-step)
open import Data.Product as Product using (∃; ∄; _×_; _,_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Data.Vec
open import Data.Vec.Properties
open import Function using (_∘_; const; id; case_of_)
open import Function.Equivalence using (_⇔_; equivalence)
open import Relation.Binary as B hiding (Decidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; cong; cong₂; subst; isEquivalence)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Unary using (Pred; Decidable)

------------------------------------------------------------------------
-- Constructor mangling

drop-there : ∀ {s n x} {p : Subset n} → suc x ∈ s ∷ p → x ∈ p
drop-there (there x∈p) = x∈p

drop-∷-⊆ : ∀ {n s₁ s₂} {p₁ p₂ : Subset n} → s₁ ∷ p₁ ⊆ s₂ ∷ p₂ → p₁ ⊆ p₂
drop-∷-⊆ p₁s₁⊆p₂s₂ x∈p₁ = drop-there (p₁s₁⊆p₂s₂ (there x∈p₁))

------------------------------------------------------------------------
-- _∈_

infix 4 _∈?_
_∈?_ : ∀ {n} x (p : Subset n) → Dec (x ∈ p)
zero  ∈? inside  ∷ p = yes here
zero  ∈? outside ∷ p = no  λ()
suc n ∈? s       ∷ p with n ∈? p
... | yes n∈p = yes (there n∈p)
... | no  n∉p = no  (n∉p ∘ drop-there)

------------------------------------------------------------------------
-- Empty

drop-∷-Empty : ∀ {n s} {p : Subset n} → Empty (s ∷ p) → Empty p
drop-∷-Empty ¬∃∈ (x , x∈p) = ¬∃∈ (suc x , there x∈p)

Empty-unique : ∀ {n} {p : Subset n} → Empty p → p ≡ ⊥
Empty-unique {_} {[]}          ¬∃∈ = refl
Empty-unique {_} {inside  ∷ p} ¬∃∈ = contradiction (zero , here) ¬∃∈
Empty-unique {_} {outside ∷ p} ¬∃∈ =
  cong (outside ∷_) (Empty-unique (drop-∷-Empty ¬∃∈))

nonempty? : ∀ {n} → Decidable (Nonempty {n})
nonempty? p = any? (_∈? p)

------------------------------------------------------------------------
-- ∣_∣

∣p∣≤n : ∀ {n} (p : Subset n) → ∣ p ∣ ≤ n
∣p∣≤n = count≤n (_≟ inside)

------------------------------------------------------------------------
-- ⊥

∉⊥ : ∀ {n} {x : Fin n} → x ∉ ⊥
∉⊥ (there p) = ∉⊥ p

⊥⊆ : ∀ {n} {p : Subset n} → ⊥ ⊆ p
⊥⊆ x∈⊥ = contradiction x∈⊥ ∉⊥

∣⊥∣≡0 : ∀ n → ∣ ⊥ {n = n} ∣ ≡ 0
∣⊥∣≡0 zero    = refl
∣⊥∣≡0 (suc n) = ∣⊥∣≡0 n

------------------------------------------------------------------------
-- ⊤

∈⊤ : ∀ {n} {x : Fin n} → x ∈ ⊤
∈⊤ {x = zero}  = here
∈⊤ {x = suc x} = there ∈⊤

⊆⊤ : ∀ {n} {p : Subset n} → p ⊆ ⊤
⊆⊤ = const ∈⊤

∣⊤∣≡n : ∀ n → ∣ ⊤ {n = n} ∣ ≡ n
∣⊤∣≡n zero    = refl
∣⊤∣≡n (suc n) = cong suc (∣⊤∣≡n n)

------------------------------------------------------------------------
-- ⁅_⁆

x∈⁅x⁆ : ∀ {n} (x : Fin n) → x ∈ ⁅ x ⁆
x∈⁅x⁆ zero    = here
x∈⁅x⁆ (suc x) = there (x∈⁅x⁆ x)

x∈⁅y⁆⇒x≡y : ∀ {n x} (y : Fin n) → x ∈ ⁅ y ⁆ → x ≡ y
x∈⁅y⁆⇒x≡y zero    here      = refl
x∈⁅y⁆⇒x≡y zero    (there p) = contradiction p ∉⊥
x∈⁅y⁆⇒x≡y (suc y) (there p) = cong suc (x∈⁅y⁆⇒x≡y y p)

x∈⁅y⁆⇔x≡y : ∀ {n} {x y : Fin n} → x ∈ ⁅ y ⁆ ⇔ x ≡ y
x∈⁅y⁆⇔x≡y {_} {x} {y} = equivalence
  (x∈⁅y⁆⇒x≡y y)
  (λ x≡y → subst (λ y → x ∈ ⁅ y ⁆) x≡y (x∈⁅x⁆ x))

∣⁅x⁆∣≡1 : ∀ {n} (i : Fin n) → ∣ ⁅ i ⁆ ∣ ≡ 1
∣⁅x⁆∣≡1 {suc n} zero    = cong suc (∣⊥∣≡0 n)
∣⁅x⁆∣≡1 {_}     (suc i) = ∣⁅x⁆∣≡1 i

------------------------------------------------------------------------
-- _⊆_

⊆-refl : ∀ {n} → Reflexive (_⊆_ {n})
⊆-refl = id

⊆-reflexive : ∀ {n} → _≡_ ⇒ (_⊆_ {n})
⊆-reflexive refl = ⊆-refl

⊆-trans : ∀ {n} → Transitive (_⊆_ {n})
⊆-trans p⊆q q⊆r x∈p = q⊆r (p⊆q x∈p)

⊆-antisym : ∀ {n} → Antisymmetric _≡_ (_⊆_ {n})
⊆-antisym {i = []}     {[]}     p⊆q q⊆p = refl
⊆-antisym {i = x ∷ xs} {y ∷ ys} p⊆q q⊆p with x | y
... | inside  | inside  = cong₂ _∷_ refl (⊆-antisym (drop-∷-⊆ p⊆q) (drop-∷-⊆ q⊆p))
... | inside  | outside = contradiction (p⊆q here) λ()
... | outside | inside  = contradiction (q⊆p here) λ()
... | outside | outside = cong₂ _∷_ refl (⊆-antisym (drop-∷-⊆ p⊆q) (drop-∷-⊆ q⊆p))

⊆-min : ∀ {n} → Minimum (_⊆_ {n}) ⊥
⊆-min []       ()
⊆-min (x ∷ xs) (there v∈⊥) = there (⊆-min xs v∈⊥)

⊆-max : ∀ {n} → Maximum (_⊆_ {n}) ⊤
⊆-max []            ()
⊆-max (inside ∷ xs) here         = here
⊆-max (x      ∷ xs) (there v∈xs) = there (⊆-max xs v∈xs)

infix 4 _⊆?_
_⊆?_ : ∀ {n} → B.Decidable (_⊆_ {n = n})
[]          ⊆? []          = yes id
outside ∷ p ⊆? y ∷ q with p ⊆? q
... | yes p⊆q = yes λ { (there v∈p) → there (p⊆q v∈p)}
... | no  p⊈q = no (p⊈q ∘ drop-∷-⊆)
inside  ∷ p ⊆? outside ∷ q = no (λ p⊆q → case (p⊆q here) of λ())
inside  ∷ p ⊆? inside  ∷ q with p ⊆? q
... | yes p⊆q = yes λ { here → here ; (there v) → there (p⊆q v)}
... | no  p⊈q = no (p⊈q ∘ drop-∷-⊆)

module _ (n : ℕ) where

  ⊆-isPreorder : IsPreorder _≡_ (_⊆_ {n})
  ⊆-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive     = ⊆-reflexive
    ; trans         = ⊆-trans
    }

  ⊆-preorder : Preorder _ _ _
  ⊆-preorder = record
    { isPreorder = ⊆-isPreorder
    }

  ⊆-isPartialOrder : IsPartialOrder _≡_ (_⊆_ {n})
  ⊆-isPartialOrder = record
    { isPreorder = ⊆-isPreorder
    ; antisym    = ⊆-antisym
    }

  ⊆-poset : Poset _ _ _
  ⊆-poset = record
    { isPartialOrder = ⊆-isPartialOrder
    }

p⊆q⇒∣p∣<∣q∣ : ∀ {n} {p q : Subset n} → p ⊆ q → ∣ p ∣ ≤ ∣ q ∣
p⊆q⇒∣p∣<∣q∣ {p = []}          {[]}          p⊆q = z≤n
p⊆q⇒∣p∣<∣q∣ {p = outside ∷ p} {outside ∷ q} p⊆q = p⊆q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q)
p⊆q⇒∣p∣<∣q∣ {p = outside ∷ p} {inside  ∷ q} p⊆q = ≤-step (p⊆q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q))
p⊆q⇒∣p∣<∣q∣ {p = inside  ∷ p} {outside ∷ q} p⊆q = contradiction (p⊆q here) λ()
p⊆q⇒∣p∣<∣q∣ {p = inside  ∷ p} {inside  ∷ q} p⊆q = s≤s (p⊆q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q))

------------------------------------------------------------------------
-- _∩_

module _ {n : ℕ} where

  open AlgebraicProperties {A = Subset n} _≡_

  ∩-assoc : Associative _∩_
  ∩-assoc = zipWith-assoc ∧-assoc

  ∩-comm : Commutative _∩_
  ∩-comm = zipWith-comm ∧-comm

  ∩-idem : Idempotent _∩_
  ∩-idem = zipWith-idem ∧-idem

  ∩-identityˡ : LeftIdentity ⊤ _∩_
  ∩-identityˡ = zipWith-identityˡ ∧-identityˡ

  ∩-identityʳ : RightIdentity ⊤ _∩_
  ∩-identityʳ = zipWith-identityʳ ∧-identityʳ

  ∩-identity : Identity ⊤ _∩_
  ∩-identity = ∩-identityˡ , ∩-identityʳ

  ∩-zeroˡ : LeftZero ⊥ _∩_
  ∩-zeroˡ = zipWith-zeroˡ ∧-zeroˡ

  ∩-zeroʳ : RightZero ⊥ _∩_
  ∩-zeroʳ = zipWith-zeroʳ ∧-zeroʳ

  ∩-zero : Zero ⊥ _∩_
  ∩-zero = ∩-zeroˡ , ∩-zeroʳ

  ∩-inverseˡ : LeftInverse ⊥ ∁ _∩_
  ∩-inverseˡ = zipWith-inverseˡ ∧-inverseˡ

  ∩-inverseʳ : RightInverse ⊥ ∁ _∩_
  ∩-inverseʳ = zipWith-inverseʳ ∧-inverseʳ

  ∩-inverse : Inverse ⊥ ∁ _∩_
  ∩-inverse = ∩-inverseˡ , ∩-inverseʳ

module _ (n : ℕ) where

  open AlgebraicStructures {A = Subset n} _≡_

  ∩-isMagma : IsMagma _∩_
  ∩-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = cong₂ _∩_
    }

  ∩-magma : Magma _ _
  ∩-magma = record
    { isMagma = ∩-isMagma
    }

  ∩-isSemigroup : IsSemigroup _∩_
  ∩-isSemigroup = record
    { isMagma = ∩-isMagma
    ; assoc   = ∩-assoc
    }

  ∩-semigroup : Semigroup _ _
  ∩-semigroup = record
    { isSemigroup = ∩-isSemigroup
    }

  ∩-isBand : IsBand _∩_
  ∩-isBand = record
    { isSemigroup = ∩-isSemigroup
    ; idem        = ∩-idem
    }

  ∩-band : Band _ _
  ∩-band = record
    { isBand = ∩-isBand
    }

  ∩-isSemilattice : IsSemilattice _∩_
  ∩-isSemilattice = record
    { isBand = ∩-isBand
    ; comm   = ∩-comm
    }

  ∩-semilattice : Semilattice _ _
  ∩-semilattice = record
    { isSemilattice = ∩-isSemilattice
    }

  ∩-isMonoid : IsMonoid _∩_ ⊤
  ∩-isMonoid = record
    { isSemigroup = ∩-isSemigroup
    ; identity    = ∩-identity
    }

  ∩-monoid : Monoid _ _
  ∩-monoid = record
    { isMonoid = ∩-isMonoid
    }

  ∩-isCommutativeMonoid : IsCommutativeMonoid _∩_ ⊤
  ∩-isCommutativeMonoid = record
    { isSemigroup = ∩-isSemigroup
    ; identityˡ   = ∩-identityˡ
    ; comm        = ∩-comm
    }

  ∩-commutativeMonoid : CommutativeMonoid _ _
  ∩-commutativeMonoid = record
    { isCommutativeMonoid = ∩-isCommutativeMonoid
    }

  ∩-isIdempotentCommutativeMonoid : IsIdempotentCommutativeMonoid _∩_ ⊤
  ∩-isIdempotentCommutativeMonoid = record
    { isCommutativeMonoid = ∩-isCommutativeMonoid
    ; idem                = ∩-idem
    }

  ∩-idempotentCommutativeMonoid : IdempotentCommutativeMonoid _ _
  ∩-idempotentCommutativeMonoid = record
    { isIdempotentCommutativeMonoid = ∩-isIdempotentCommutativeMonoid
    }

p∩q⊆p : ∀ {n} (p q : Subset n) → p ∩ q ⊆ p
p∩q⊆p []            []           x∈p∩q        = x∈p∩q
p∩q⊆p (inside  ∷ p) (inside ∷ q) here         = here
p∩q⊆p (inside  ∷ p) (_      ∷ q) (there ∈p∩q) = there (p∩q⊆p p q ∈p∩q)
p∩q⊆p (outside ∷ p) (_      ∷ q) (there ∈p∩q) = there (p∩q⊆p p q ∈p∩q)

p∩q⊆q : ∀ {n} (p q : Subset n) → p ∩ q ⊆ q
p∩q⊆q p q rewrite ∩-comm p q = p∩q⊆p q p

x∈p∩q⁺ : ∀ {n} {p q : Subset n} {x} → x ∈ p × x ∈ q → x ∈ p ∩ q
x∈p∩q⁺ (here      , here)      = here
x∈p∩q⁺ (there x∈p , there x∈q) = there (x∈p∩q⁺ (x∈p , x∈q))

x∈p∩q⁻ : ∀ {n} (p q : Subset n) {x} → x ∈ p ∩ q → x ∈ p × x ∈ q
x∈p∩q⁻ []           []           ()
x∈p∩q⁻ (inside ∷ p) (inside ∷ q) here          = here , here
x∈p∩q⁻ (s      ∷ p) (t      ∷ q) (there x∈p∩q) =
  Product.map there there (x∈p∩q⁻ p q x∈p∩q)

∩⇔× : ∀ {n} {p q : Subset n} {x} → x ∈ p ∩ q ⇔ (x ∈ p × x ∈ q)
∩⇔× = equivalence (x∈p∩q⁻ _ _) x∈p∩q⁺

------------------------------------------------------------------------
-- _∪_

module _ {n : ℕ} where

  open AlgebraicProperties {A = Subset n} _≡_

  ∪-assoc : Associative _∪_
  ∪-assoc = zipWith-assoc ∨-assoc

  ∪-comm : Commutative _∪_
  ∪-comm = zipWith-comm ∨-comm

  ∪-idem : Idempotent _∪_
  ∪-idem = zipWith-idem ∨-idem

  ∪-identityˡ : LeftIdentity ⊥ _∪_
  ∪-identityˡ = zipWith-identityˡ ∨-identityˡ

  ∪-identityʳ : RightIdentity ⊥ _∪_
  ∪-identityʳ = zipWith-identityʳ ∨-identityʳ

  ∪-identity : Identity ⊥ _∪_
  ∪-identity = ∪-identityˡ , ∪-identityʳ

  ∪-zeroˡ : LeftZero ⊤ _∪_
  ∪-zeroˡ = zipWith-zeroˡ ∨-zeroˡ

  ∪-zeroʳ : RightZero ⊤ _∪_
  ∪-zeroʳ = zipWith-zeroʳ ∨-zeroʳ

  ∪-zero : Zero ⊤ _∪_
  ∪-zero = ∪-zeroˡ , ∪-zeroʳ

  ∪-inverseˡ : LeftInverse ⊤ ∁ _∪_
  ∪-inverseˡ = zipWith-inverseˡ ∨-inverseˡ

  ∪-inverseʳ : RightInverse ⊤ ∁ _∪_
  ∪-inverseʳ = zipWith-inverseʳ ∨-inverseʳ

  ∪-inverse : Inverse ⊤ ∁ _∪_
  ∪-inverse = ∪-inverseˡ , ∪-inverseʳ

  ∪-distribˡ-∩ : _∪_ DistributesOverˡ _∩_
  ∪-distribˡ-∩ = zipWith-distribˡ ∨-distribˡ-∧

  ∪-distribʳ-∩ : _∪_ DistributesOverʳ _∩_
  ∪-distribʳ-∩ = zipWith-distribʳ ∨-distribʳ-∧

  ∪-distrib-∩ : _∪_ DistributesOver _∩_
  ∪-distrib-∩ = ∪-distribˡ-∩ , ∪-distribʳ-∩

  ∩-distribˡ-∪ : _∩_ DistributesOverˡ _∪_
  ∩-distribˡ-∪ = zipWith-distribˡ ∧-distribˡ-∨

  ∩-distribʳ-∪ : _∩_ DistributesOverʳ _∪_
  ∩-distribʳ-∪ = zipWith-distribʳ ∧-distribʳ-∨

  ∩-distrib-∪ : _∩_ DistributesOver _∪_
  ∩-distrib-∪ = ∩-distribˡ-∪ , ∩-distribʳ-∪

  ∪-abs-∩ : _∪_ Absorbs _∩_
  ∪-abs-∩ = zipWith-absorbs ∨-abs-∧

  ∩-abs-∪ : _∩_ Absorbs _∪_
  ∩-abs-∪ = zipWith-absorbs ∧-abs-∨

module _ (n : ℕ) where

  open AlgebraicStructures {A = Subset n} _≡_

  ∪-isMagma : IsMagma _∪_
  ∪-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = cong₂ _∪_
    }

  ∪-magma : Magma _ _
  ∪-magma = record
    { isMagma = ∪-isMagma
    }

  ∪-isSemigroup : IsSemigroup _∪_
  ∪-isSemigroup = record
    { isMagma = ∪-isMagma
    ; assoc   = ∪-assoc
    }

  ∪-semigroup : Semigroup _ _
  ∪-semigroup = record
    { isSemigroup = ∪-isSemigroup
    }

  ∪-isBand : IsBand _∪_
  ∪-isBand = record
    { isSemigroup = ∪-isSemigroup
    ; idem        = ∪-idem
    }

  ∪-band : Band _ _
  ∪-band = record
    { isBand = ∪-isBand
    }

  ∪-isSemilattice : IsSemilattice _∪_
  ∪-isSemilattice = record
    { isBand = ∪-isBand
    ; comm   = ∪-comm
    }

  ∪-semilattice : Semilattice _ _
  ∪-semilattice = record
    { isSemilattice = ∪-isSemilattice
    }

  ∪-isMonoid : IsMonoid _∪_ ⊥
  ∪-isMonoid = record
    { isSemigroup = ∪-isSemigroup
    ; identity    = ∪-identity
    }

  ∪-monoid : Monoid _ _
  ∪-monoid = record
    { isMonoid = ∪-isMonoid
    }

  ∪-isCommutativeMonoid : IsCommutativeMonoid _∪_ ⊥
  ∪-isCommutativeMonoid = record
    { isSemigroup = ∪-isSemigroup
    ; identityˡ   = ∪-identityˡ
    ; comm        = ∪-comm
    }

  ∪-commutativeMonoid : CommutativeMonoid _ _
  ∪-commutativeMonoid = record
    { isCommutativeMonoid = ∪-isCommutativeMonoid
    }

  ∪-isIdempotentCommutativeMonoid : IsIdempotentCommutativeMonoid _∪_ ⊥
  ∪-isIdempotentCommutativeMonoid = record
    { isCommutativeMonoid = ∪-isCommutativeMonoid
    ; idem                = ∪-idem
    }

  ∪-idempotentCommutativeMonoid : IdempotentCommutativeMonoid _ _
  ∪-idempotentCommutativeMonoid = record
    { isIdempotentCommutativeMonoid = ∪-isIdempotentCommutativeMonoid
    }

  ∪-∩-isLattice : IsLattice _∪_ _∩_
  ∪-∩-isLattice = record
    { isEquivalence = isEquivalence
    ; ∨-comm        = ∪-comm
    ; ∨-assoc       = ∪-assoc
    ; ∨-cong        = cong₂ _∪_
    ; ∧-comm        = ∩-comm
    ; ∧-assoc       = ∩-assoc
    ; ∧-cong        = cong₂ _∩_
    ; absorptive    = ∪-abs-∩ , ∩-abs-∪
    }

  ∪-∩-lattice : Lattice _ _
  ∪-∩-lattice = record
    { isLattice = ∪-∩-isLattice
    }

  ∪-∩-isDistributiveLattice : IsDistributiveLattice _∪_ _∩_
  ∪-∩-isDistributiveLattice = record
    { isLattice    = ∪-∩-isLattice
    ; ∨-∧-distribʳ = ∪-distribʳ-∩
    }

  ∪-∩-distributiveLattice : DistributiveLattice _ _
  ∪-∩-distributiveLattice = record
    { isDistributiveLattice = ∪-∩-isDistributiveLattice
    }

  ∪-∩-isBooleanAlgebra : IsBooleanAlgebra _∪_ _∩_ ∁ ⊤ ⊥
  ∪-∩-isBooleanAlgebra = record
    { isDistributiveLattice = ∪-∩-isDistributiveLattice
    ; ∨-complementʳ         = ∪-inverseʳ
    ; ∧-complementʳ         = ∩-inverseʳ
    ; ¬-cong                = cong ∁
    }

  ∪-∩-booleanAlgebra : BooleanAlgebra _ _
  ∪-∩-booleanAlgebra = record
    { isBooleanAlgebra = ∪-∩-isBooleanAlgebra
    }

  ∩-∪-isLattice : IsLattice _∩_ _∪_
  ∩-∪-isLattice = L.∧-∨-isLattice ∪-∩-lattice

  ∩-∪-lattice : Lattice _ _
  ∩-∪-lattice = L.∧-∨-lattice ∪-∩-lattice

  ∩-∪-isDistributiveLattice : IsDistributiveLattice _∩_ _∪_
  ∩-∪-isDistributiveLattice = DL.∧-∨-isDistributiveLattice ∪-∩-distributiveLattice

  ∩-∪-distributiveLattice : DistributiveLattice _ _
  ∩-∪-distributiveLattice = DL.∧-∨-distributiveLattice ∪-∩-distributiveLattice

  ∩-∪-isBooleanAlgebra : IsBooleanAlgebra _∩_ _∪_ ∁ ⊥ ⊤
  ∩-∪-isBooleanAlgebra = BA.∧-∨-isBooleanAlgebra ∪-∩-booleanAlgebra

  ∩-∪-booleanAlgebra : BooleanAlgebra _ _
  ∩-∪-booleanAlgebra = BA.∧-∨-booleanAlgebra ∪-∩-booleanAlgebra

p⊆p∪q : ∀ {n p} (q : Subset n) → p ⊆ p ∪ q
p⊆p∪q []      ()
p⊆p∪q (s ∷ q) here        = here
p⊆p∪q (s ∷ q) (there x∈p) = there (p⊆p∪q q x∈p)

q⊆p∪q : ∀ {n} (p q : Subset n) → q ⊆ p ∪ q
q⊆p∪q p q rewrite ∪-comm p q = p⊆p∪q p

x∈p∪q⁻ :  ∀ {n} (p q : Subset n) {x} → x ∈ p ∪ q → x ∈ p ⊎ x ∈ q
x∈p∪q⁻ []            []            ()
x∈p∪q⁻ (inside  ∷ p) (t       ∷ q) here          = inj₁ here
x∈p∪q⁻ (outside ∷ p) (inside  ∷ q) here          = inj₂ here
x∈p∪q⁻ (s       ∷ p) (t       ∷ q) (there x∈p∪q) =
  Sum.map there there (x∈p∪q⁻ p q x∈p∪q)

x∈p∪q⁺ : ∀ {n} {p q : Subset n} {x} → x ∈ p ⊎ x ∈ q → x ∈ p ∪ q
x∈p∪q⁺ (inj₁ x∈p) = p⊆p∪q _   x∈p
x∈p∪q⁺ (inj₂ x∈q) = q⊆p∪q _ _ x∈q

∪⇔⊎ : ∀ {n} {p q : Subset n} {x} → x ∈ p ∪ q ⇔ (x ∈ p ⊎ x ∈ q)
∪⇔⊎ = equivalence (x∈p∪q⁻ _ _) x∈p∪q⁺

------------------------------------------------------------------------
-- Lift

Lift? : ∀ {n p} {P : Pred (Fin n) p} → Decidable P → Decidable (Lift P)
Lift? P? p = decFinSubset (_∈? p) (λ {x} _ → P? x)

------------------------------------------------------------------------
-- Other

anySubset? : ∀ {n} {P : Subset n → Set} → Decidable P → Dec (∃ P)
anySubset? {zero}  P? with P? []
... | yes P[] = yes (_ , P[])
... | no ¬P[] = no (λ {([] , P[]) → ¬P[] P[]})
anySubset? {suc n} P? with anySubset? (P? ∘ (inside ∷_))
... | yes (_ , Pp) = yes (_ , Pp)
... | no  ¬Pp      with anySubset? (P? ∘ (outside ∷_))
...   | yes (_ , Pp) = yes (_ , Pp)
...   | no ¬Pp'      = no λ
  { (inside  ∷ p , Pp)  → ¬Pp  (_ , Pp)
  ; (outside ∷ p , Pp') → ¬Pp' (_ , Pp')
  }


module Data.DynamicTree where

import      Lvl
open import Data.List
open import Data.Option
open import Functional as Fn
open import Type

private variable ℓ ℓᵢ : Lvl.Level
private variable T A B : Type{ℓ}

data Node (T : Type{ℓ}) : Type{ℓ} where
  node : T → List(Node(T)) → Node(T)

DynamicTree : Type{ℓ} → Type{ℓ}
DynamicTree(T) = Option(Node(T))


------------------------------------------------------------------------
-- Logical equivalences
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Logical-equivalence where

open import Prelude as P hiding (id) renaming (_∘_ to _⊚_)

private
  variable
    a b p      : Level
    @0 A B C D : Type a
    @0 P Q     : A → Type p

------------------------------------------------------------------------
-- Logical equivalence

-- A ⇔ B means that A and B are logically equivalent.

infix 0 _⇔_

record _⇔_ {f t} (From : Type f) (To : Type t) : Type (f ⊔ t) where
  field
    to   : From → To
    from : To → From

------------------------------------------------------------------------
-- Equivalence relation

-- _⇔_ is an equivalence relation.

id : A ⇔ A
id = record
  { to   = P.id
  ; from = P.id
  }

inverse : A ⇔ B → B ⇔ A
inverse A⇔B ._⇔_.to   = let record { from = from } = A⇔B in from
inverse A⇔B ._⇔_.from = let record { to   = to   } = A⇔B in to

infixr 9 _∘_

_∘_ : B ⇔ C → A ⇔ B → A ⇔ C
(f ∘ g) ._⇔_.to =
  let record { to = f-to } = f
      record { to = g-to } = g
  in f-to ⊚ g-to
(f ∘ g) ._⇔_.from =
  let record { from = f-from } = f
      record { from = g-from } = g
  in g-from ⊚ f-from

-- "Equational" reasoning combinators.

infix  -1 finally-⇔
infixr -2 step-⇔

-- For an explanation of why step-⇔ is defined in this way, see
-- Equality.step-≡.

step-⇔ : (@0 A : Type a) → B ⇔ C → A ⇔ B → A ⇔ C
step-⇔ _ = _∘_

syntax step-⇔ A B⇔C A⇔B = A ⇔⟨ A⇔B ⟩ B⇔C

finally-⇔ : (@0 A : Type a) (@0 B : Type b) → A ⇔ B → A ⇔ B
finally-⇔ _ _ A⇔B = A⇔B

syntax finally-⇔ A B A⇔B = A ⇔⟨ A⇔B ⟩□ B □

------------------------------------------------------------------------
-- Preservation lemmas

-- Note that all of the type arguments of these lemmas are erased.

-- _⊎_ preserves logical equivalences.

infixr 2 _×-cong_

_×-cong_ : A ⇔ C → B ⇔ D → A × B ⇔ C × D
A⇔C ×-cong B⇔D =
  let record { to = to₁; from = from₁ } = A⇔C
      record { to = to₂; from = from₂ } = B⇔D
  in
  record
    { to   = Σ-map to₁   to₂
    ; from = Σ-map from₁ from₂
    }

-- ∃ preserves logical equivalences.

∃-cong : (∀ x → P x ⇔ Q x) → ∃ P ⇔ ∃ Q
∃-cong P⇔Q = record
  { to   = λ (x , y) → x , let record { to   = to   } = P⇔Q x in to   y
  ; from = λ (x , y) → x , let record { from = from } = P⇔Q x in from y
  }

-- _⊎_ preserves logical equivalences.

infixr 1 _⊎-cong_

_⊎-cong_ : A ⇔ C → B ⇔ D → A ⊎ B ⇔ C ⊎ D
A⇔C ⊎-cong B⇔D =
  let record { to = to₁; from = from₁ } = A⇔C
      record { to = to₂; from = from₂ } = B⇔D
  in
  record
    { to   = ⊎-map to₁   to₂
    ; from = ⊎-map from₁ from₂
    }

-- The non-dependent function space preserves logical equivalences.

→-cong : A ⇔ C → B ⇔ D → (A → B) ⇔ (C → D)
→-cong A⇔C B⇔D =
  let record { to = to₁; from = from₁ } = A⇔C
      record { to = to₂; from = from₂ } = B⇔D
  in
  record
    { to   = (to₂   ⊚_) ⊚ (_⊚ from₁)
    ; from = (from₂ ⊚_) ⊚ (_⊚ to₁)
    }

-- Π preserves logical equivalences in its second argument.

∀-cong :
  ((x : A) → P x ⇔ Q x) →
  ((x : A) → P x) ⇔ ((x : A) → Q x)
∀-cong P⇔Q = record
  { to   = λ f x → let record { to   = to   } = P⇔Q x in to   (f x)
  ; from = λ f x → let record { from = from } = P⇔Q x in from (f x)
  }

-- The implicit variant of Π preserves logical equivalences in its
-- second argument.

implicit-∀-cong :
  ({x : A} → P x ⇔ Q x) →
  ({x : A} → P x) ⇔ ({x : A} → Q x)
implicit-∀-cong P⇔Q = record
  { to   = λ f → let record { to   = to   } = P⇔Q in to   f
  ; from = λ f → let record { from = from } = P⇔Q in from f
  }

-- ↑ preserves logical equivalences.

↑-cong : B ⇔ C → ↑ a B ⇔ ↑ a C
↑-cong B⇔C =
  let record { to = to; from = from } = B⇔C in
  record
    { to   = λ (lift x) → lift (to   x)
    ; from = λ (lift x) → lift (from x)
    }

-- _⇔_ preserves logical equivalences.

⇔-cong : A ⇔ B → C ⇔ D → (A ⇔ C) ⇔ (B ⇔ D)
⇔-cong {A = A} {B = B} {C = C} {D = D} A⇔B C⇔D = record
  { to   = λ A⇔C →
             B  ⇔⟨ inverse A⇔B ⟩
             A  ⇔⟨ A⇔C ⟩
             C  ⇔⟨ C⇔D ⟩□
             D  □
  ; from = λ B⇔D →
             A  ⇔⟨ A⇔B ⟩
             B  ⇔⟨ B⇔D ⟩
             D  ⇔⟨ inverse C⇔D ⟩□
             C  □
  }


{-# OPTIONS --rewriting #-}

open import Agda.Primitive

postulate
  _↦_ : ∀ {i} {A : Set i} → A → A → Set i
  idr : ∀ {i} {A : Set i} {a : A} → a ↦ a
{-# BUILTIN REWRITE _↦_ #-}

postulate
  _==_ : ∀ {i} {A : Set i} → A → A → Set i
  idp : ∀ {i} {A : Set i} {a : A} → a == a

postulate
  HetEq : ∀ {i} {A B : Set i} (e : A == B) (a : A) (b : B) → Set i
  HetEq↦ : ∀ {i} {A : Set i} (a b : A) → HetEq idp a b ↦ (a == b)
  {-# REWRITE HetEq↦ #-}

HetEq↦2 : ∀ {i j} {A : Set i} {B : Set j} (u v : A → B) → HetEq idp u v ↦ (u == v)
HetEq↦2 u v = idr


-- This file tests that implicit record fields are not printed out (by
-- default).

-- Andreas, 2016-07-20 Repaired this long disfunctional test case.

module ImplicitRecordFields where

record R : Set₁ where
  field
    {A}         : Set
    f           : A → A
    {B C} D {E} : Set
    g           : B → C → E

postulate
  A : Set
  r : R

data _≡_ {A : Set₁} (x : A) : A → Set where
  refl : x ≡ x

foo : r ≡ record
  { A = A
  ; f = λ x → x
  ; B = A
  ; C = A
  ; D = A
  ; g = λ x _ → x
  }
foo = refl

-- EXPECTED ERROR:
-- .R.A r != A of type Set
-- when checking that the expression refl has type
-- r ≡ record { f = λ x → x ; D = A ; g = λ x _ → x }


module BasicIPC.Metatheory.ClosedHilbert-TarskiGluedClosedImplicit where

open import BasicIPC.Syntax.ClosedHilbert public
open import BasicIPC.Semantics.TarskiGluedClosedImplicit public

open ImplicitSyntax (⊢_) public

-- Completeness with respect to a particular model.

module _ {{_ : Model}} where
  reify : ∀ {A} → ⊩ A → ⊢ A
  reify {α P}   s = syn s
  reify {A ▻ B} s = syn s
  reify {A ∧ B} s = pair (reify (π₁ s)) (reify (π₂ s))
  reify {⊤}    s = unit

-- Additional useful equipment.

module _ {{_ : Model}} where
  ⟪K⟫ : ∀ {A B} → ⊩ A → ⊩ B ▻ A
  ⟪K⟫ a = app ck (reify a) ⅋ K a

  ⟪S⟫′ : ∀ {A B C} → ⊩ A ▻ B ▻ C → ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ s₁ = app cs (reify s₁) ⅋ λ s₂ →
              app (app cs (reify s₁)) (reify s₂) ⅋ ⟪S⟫ s₁ s₂

  _⟪,⟫′_ : ∀ {A B} → ⊩ A → ⊩ B ▻ A ∧ B
  _⟪,⟫′_ a = app cpair (reify a) ⅋ _,_ a

-- Soundness with respect to all models, or evaluation, for closed terms only.

eval₀ : ∀ {A} → ⊢ A → ⊨ A
eval₀ (app t u) = eval₀ t ⟪$⟫ eval₀ u
eval₀ ci        = ci ⅋ I
eval₀ ck        = ck ⅋ ⟪K⟫
eval₀ cs        = cs ⅋ ⟪S⟫′
eval₀ cpair     = cpair ⅋ _⟪,⟫′_
eval₀ cfst      = cfst ⅋ π₁
eval₀ csnd      = csnd ⅋ π₂
eval₀ unit      = ∙

-- Correctness of evaluation with respect to conversion.

eval₀✓ : ∀ {{_ : Model}} {A} {t t′ : ⊢ A} → t ⋙ t′ → eval₀ t ≡ eval₀ t′
eval₀✓ refl⋙           = refl
eval₀✓ (trans⋙ p q)    = trans (eval₀✓ p) (eval₀✓ q)
eval₀✓ (sym⋙ p)        = sym (eval₀✓ p)
eval₀✓ (congapp⋙ p q)  = cong² _⟪$⟫_ (eval₀✓ p) (eval₀✓ q)
eval₀✓ (congi⋙ p)      = cong I (eval₀✓ p)
eval₀✓ (congk⋙ p q)    = cong² K (eval₀✓ p) (eval₀✓ q)
eval₀✓ (congs⋙ p q r)  = cong³ ⟪S⟫ (eval₀✓ p) (eval₀✓ q) (eval₀✓ r)
eval₀✓ (congpair⋙ p q) = cong² _,_ (eval₀✓ p) (eval₀✓ q)
eval₀✓ (congfst⋙ p)    = cong π₁ (eval₀✓ p)
eval₀✓ (congsnd⋙ p)    = cong π₂ (eval₀✓ p)
eval₀✓ beta▻ₖ⋙         = refl
eval₀✓ beta▻ₛ⋙         = refl
eval₀✓ beta∧₁⋙         = refl
eval₀✓ beta∧₂⋙         = refl
eval₀✓ eta∧⋙           = refl
eval₀✓ eta⊤⋙          = refl

-- The canonical model.

private
  instance
    canon : Model
    canon = record
      { ⊩ᵅ_ = λ P → ⊢ α P
      }

-- Completeness with respect to all models, or quotation, for closed terms only.

quot₀ : ∀ {A} → ⊨ A → ⊢ A
quot₀ s = reify s

-- Normalisation by evaluation, for closed terms only.

norm₀ : ∀ {A} → ⊢ A → ⊢ A
norm₀ = quot₀ ∘ eval₀

-- Correctness of normalisation with respect to conversion.

norm₀✓ : ∀ {{_ : Model}} {A} {t t′ : ⊢ A} → t ⋙ t′ → norm₀ t ≡ norm₀ t′
norm₀✓ p = cong reify (eval₀✓ p)


id : Set → Set
id A = A

F : Set → Set → Set
F _*_ = G
  where
  G : Set → Set
  G _*_ = id _*_

G : Set → Set → Set
G _*_ = λ _*_ → id _*_

H : Set → Set → Set
H = λ _*_ _*_ → id _*_


------------------------------------------------------------------------
-- Abstract grammars
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Grammar.Abstract where

open import Data.Bool
open import Data.Char
open import Data.Empty
open import Data.List
open import Data.Product
open import Data.Sum
open import Function
open import Relation.Binary.PropositionalEquality using (_≡_)

------------------------------------------------------------------------
-- Grammars

-- I use an abstract and general definition of grammars: a grammar is
-- a predicate that relates strings with parse results.

Grammar : Set → Set₁
Grammar A = A → List Char → Set

------------------------------------------------------------------------
-- Grammar combinators

-- A grammar for no strings.

fail : ∀ {A} → Grammar A
fail = λ _ _ → ⊥

-- Symmetric choice.

infixl 10 _∣_

_∣_ : ∀ {A} → Grammar A → Grammar A → Grammar A
g₁ ∣ g₂ = λ x s → g₁ x s ⊎ g₂ x s

-- Grammars for the empty string.

return : ∀ {A} → A → Grammar A
return x = λ y s → y ≡ x × s ≡ []

-- Map.

infixl 20 _<$>_ _<$_

_<$>_ : ∀ {A B} → (A → B) → Grammar A → Grammar B
f <$> g = λ x s → ∃ λ y → g y s × x ≡ f y

_<$_ : ∀ {A B} → A → Grammar B → Grammar A
x <$ g = const x <$> g

-- A sequencing combinator for partially applied grammars.

seq : (List Char → Set) → (List Char → Set) → (List Char → Set)
seq p₁ p₂ = λ s → ∃₂ λ s₁ s₂ → p₁ s₁ × p₂ s₂ × s ≡ s₁ ++ s₂

-- Monadic bind.

infixl 15 _>>=_ _>>_

_>>=_ : ∀ {A B} → Grammar A → (A → Grammar B) → Grammar B
g₁ >>= g₂ = λ y s → ∃ λ x → seq (g₁ x) (g₂ x y) s

_>>_ : ∀ {A B} → Grammar A → Grammar B → Grammar B
g₁ >> g₂ = g₁ >>= λ _ → g₂

-- "Applicative" sequencing.

infixl 20 _⊛_ _<⊛_ _⊛>_

_⊛_ : ∀ {A B} → Grammar (A → B) → Grammar A → Grammar B
g₁ ⊛ g₂ = g₁ >>= λ f → f <$> g₂

_<⊛_ : ∀ {A B} → Grammar A → Grammar B → Grammar A
g₁ <⊛ g₂ = λ x s → ∃ λ y → seq (g₁ x) (g₂ y) s

_⊛>_ : ∀ {A B} → Grammar A → Grammar B → Grammar B
_⊛>_ = _>>_

-- Kleene star.

infix 30 _⋆ _+

_⋆ : ∀ {A} → Grammar A → Grammar (List A)
(g ⋆) []       s = s ≡ []
(g ⋆) (x ∷ xs) s = seq (g x) ((g ⋆) xs) s

_+ : ∀ {A} → Grammar A → Grammar (List A)
(g +) []       s = ⊥
(g +) (x ∷ xs) s = (g ⋆) (x ∷ xs) s

-- Elements separated by something.

infixl 18 _sep-by_

_sep-by_ : ∀ {A B} → Grammar A → Grammar B → Grammar (List A)
g sep-by sep = _∷_ <$> g ⊛ (sep >> g) ⋆

-- A grammar for an arbitrary token.

token : Grammar Char
token = λ c s → s ≡ [ c ]

-- A grammar for a given token.

tok : Char → Grammar Char
tok c = λ c′ s → c′ ≡ c × token c′ s

-- A grammar for tokens satisfying a given predicate.

sat : (p : Char → Bool) → Grammar (∃ λ t → T (p t))
sat _ = λ { (c , _) s → token c s }

-- A grammar for whitespace.

whitespace : Grammar Char
whitespace = tok ' ' ∣ tok '\n'

-- A grammar for a given string.

string : List Char → Grammar (List Char)
string s = λ s′ s″ → s′ ≡ s × s″ ≡ s

-- A grammar for the given string, possibly followed by some
-- whitespace.

symbol : List Char → Grammar (List Char)
symbol s = string s <⊛ whitespace ⋆


import Nat
open   Nat using (Nat)

module TopLevelImport (n : Nat) where

  it : Nat
  it = n


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.Encode
open import LibraBFT.Base.ByteString

-- This module defines Hash functions, and related properties

module LibraBFT.Hash where

 -------------------------------------------------
 -- Hash function postulates
 --
 -- We are now assuming that our 'auth' function is collision
 -- resistant. We might be able to carry the full proof in agda,
 -- but that can take place on another module.

 Hash : Set
 Hash = Σ ByteString (λ bs → length bs ≡ 4)

 hashLen-pi : ∀ {bs : ByteString} {n : ℕ } → (p1 p2 : length bs ≡ n) → p1 ≡ p2
 hashLen-pi {[]}    {.0} refl refl = refl
 hashLen-pi {h ∷ t} {.(suc (length t))} refl refl = refl

 sameBS⇒sameHash : ∀ {h1 h2 : Hash}
         → proj₁ h1 ≡ proj₁ h2
         → h1 ≡ h2
 sameBS⇒sameHash { h1a , h1b } { h2a , h2b } refl rewrite hashLen-pi {h2a} h1b h2b = refl

 _≟Hash_ : (h₁ h₂ : Hash) → Dec (h₁ ≡ h₂)
 (l , pl) ≟Hash (m , pm) with List-≡-dec (Vec-≡-dec _≟Bool_) l m
 ...| yes refl = yes (cong (_,_ l) (≡-pi pl pm))
 ...| no  abs  = no (abs ∘ ,-injectiveˡ)

 encodeH : Hash → ByteString
 encodeH (bs , _) = bs

 encodeH-inj : ∀ i j → encodeH i ≡ encodeH j → i ≡ j
 encodeH-inj (i , pi) (j , pj) refl = cong (_,_ i) (≡-pi pi pj)

 encodeH-len : ∀{h} → length (encodeH h) ≡ 4
 encodeH-len { bs , p } = p

 encodeH-len-lemma : ∀ i j → length (encodeH i) ≡ length (encodeH j)
 encodeH-len-lemma i j = trans (encodeH-len {i}) (sym (encodeH-len {j}))

 -- Which means that we can make a helper function that combines
 -- the necessary injections into one big injection
 ++b-2-inj : (h₁ h₂ : Hash){l₁ l₂ : Hash}
           → encodeH h₁ ++ encodeH l₁ ≡ encodeH h₂ ++ encodeH l₂
           → h₁ ≡ h₂ × l₁ ≡ l₂
 ++b-2-inj h₁ h₂ {l₁} {l₂} hip
   with ++-inj {m = encodeH h₁} {n = encodeH h₂} (encodeH-len-lemma h₁ h₂) hip
 ...| hh , ll = encodeH-inj h₁ h₂ hh , encodeH-inj l₁ l₂ ll

 Collision : {A B : Set}(f : A → B)(a₁ a₂ : A) → Set
 Collision f a₁ a₂ = a₁ ≢ a₂ × f a₁ ≡ f a₂

 instance
   enc-Hash : Encoder Hash
   enc-Hash = record
     { encode     = encodeH
     ; encode-inj = encodeH-inj _ _
     }

 module WithCryptoHash
   -- A Hash function maps a bytestring into a hash.
   (hash    : BitString → Hash)
   (hash-cr : ∀{x y} → hash x ≡ hash y → Collision hash x y ⊎ x ≡ y) where

  -- We define the concatenation of hashes like one would expect
  hash-concat : List Hash  → Hash
  hash-concat l = hash (bs-concat (List-map encodeH l))

  -- And voila, it is either injective ot we broke the hash function!
  hash-concat-inj : ∀{l₁ l₂} → hash-concat l₁ ≡ hash-concat l₂ → NonInjective-≡ hash ⊎ l₁ ≡ l₂
  hash-concat-inj {l₁} {l₂} hyp with hash-cr hyp
  ...| inj₁ col  = inj₁ ((_ , _) , col)
  ...| inj₂ same with bs-concat-inj (List-map encodeH l₁) (List-map encodeH l₂) same
  ...| res = inj₂ (map-inj encodeH (encodeH-inj _ _) res)
    where
      map-inj : ∀{a b}{A : Set a}{B : Set b}(f : A → B)
              → (f-injective : ∀{a₁ a₂} → f a₁ ≡ f a₂ → a₁ ≡ a₂)
              → ∀{xs ys} → List-map f xs ≡ List-map f ys → xs ≡ ys
      map-inj f finj {[]} {[]} hyp = refl
      map-inj f finj {x ∷ xs} {y ∷ ys} hyp
        = cong₂ _∷_ (finj (proj₁ (∷-injective hyp)))
                    (map-inj f finj (proj₂ (∷-injective hyp)))


module UnifyTermL (A : Set) where

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
open import Function using (_∘_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (∃; _,_; _×_)
open import Data.Empty using (⊥-elim)

data Term (n : ℕ) : Set where
  i : (x : Fin n) -> Term n
  leaf : A → Term n
  _fork_ : (s t : Term n) -> Term n

Term-leaf-inj : ∀ {n l₁ l₂} → leaf {n} l₁ ≡ leaf l₂ → l₁ ≡ l₂
Term-leaf-inj refl = refl

_~>_ : (m n : ℕ) -> Set
m ~> n = Fin m -> Term n

▹ : ∀ {m n} -> (r : Fin m -> Fin n) -> Fin m -> Term n
▹ r = i ∘ r

_◃_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
f ◃ i x = f x
f ◃ (leaf l) = leaf l
f ◃ (s fork t) = (f ◃ s) fork (f ◃ t)

_≐_ : {m n : ℕ} -> (Fin m -> Term n) -> (Fin m -> Term n) -> Set
f ≐ g = ∀ x -> f x ≡ g x

◃ext : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ t -> f ◃ t ≡ g ◃ t
◃ext p (i x) = p x
◃ext p (leaf l) = refl
◃ext p (s fork t) = cong₂ _fork_ (◃ext p s) (◃ext p t)

_◇_ : ∀ {l m n : ℕ } -> (f : Fin m -> Term n) (g : Fin l -> Term m) -> Fin l -> Term n
f ◇ g = (f ◃_) ∘ g

≐-cong : ∀ {m n o} {f : m ~> n} {g} (h : _ ~> o) -> f ≐ g -> (h ◇ f) ≐ (h ◇ g)
≐-cong h f≐g t = cong (h ◃_) (f≐g t)

≐-sym : ∀ {m n} {f : m ~> n} {g} -> f ≐ g -> g ≐ f
≐-sym f≐g = sym ∘ f≐g

module Sub where
  fact1 : ∀ {n} -> (t : Term n) -> i ◃ t ≡ t
  fact1 (i x) = refl
  fact1 (leaf l) = refl
  fact1 (s fork t) = cong₂ _fork_ (fact1 s) (fact1 t)

  fact2 : ∀ {l m n} -> (f : Fin m -> Term n) (g : _) (t : Term l)
    -> (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
  fact2 f g (i x) = refl
  fact2 f g (leaf l) = refl
  fact2 f g (s fork t) = cong₂ _fork_ (fact2 f g s) (fact2 f g t)

  fact3 : ∀ {l m n} (f : Fin m -> Term n) (r : Fin l -> Fin m) -> (f ◇ (▹ r)) ≡ (f ∘ r)
  fact3 f r = refl -- ext (λ _ -> refl)

◃ext' : ∀ {m n o} {f : Fin m -> Term n}{g : Fin m -> Term o}{h} -> f ≐ (h ◇ g) -> ∀ t -> f ◃ t ≡ h ◃ (g ◃ t)
◃ext' p t = trans (◃ext p t) (Sub.fact2 _ _ t)

open import Data.Maybe
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

open import UnifyFin

check : ∀{n} (x : Fin (suc n)) (t : Term (suc n)) -> Maybe (Term n)
check x (i y) = i <$> thick x y
check x (leaf l) = just (leaf l)
check x (s fork t) = _fork_ <$> check x s ⊛ check x t

_for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) -> Fin (suc n) -> Term n
(t' for x) y = maybe′ i t' (thick x y)

data AList : ℕ -> ℕ -> Set where
  anil : ∀ {n} -> AList n n
  _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
               -> AList (suc m) n

sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
sub anil = i
sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

_++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
ρ ++ anil = ρ
ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
++-assoc ρ σ anil = refl
++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

module SubList where
  anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
  anil-id-l anil = refl
  anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = ◃ext (fact1 r s) t
      ◃-assoc = Sub.fact2 (sub r) (sub s) t

_∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
  -> ∃ (AList (suc m))
(n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
flexFlex {suc m} x y with thick x y
...              | just y' = m , anil asnoc i y' / x
...              | nothing = suc m , anil
flexFlex {zero} () _

flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
flexRigid {suc m} x t with check x t
...                   | just t' = just (m , anil asnoc t' / x)
...                   | nothing = nothing
flexRigid {zero} () _


{-# OPTIONS --rewriting #-}

-- {-# OPTIONS -v rewriting:100 -v tc.conv.atom:30 -v tc.inj.use:30 #-}

open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

_+_ : Nat → Nat → Nat
zero + n = n
(suc m) + n = suc (m + n)

postulate
  plus-zero : ∀ x → (x + zero) ≡ x

{-# REWRITE plus-zero #-}

mutual
  secret-number : Nat
  secret-number = _

  test : ∀ x → (x + secret-number) ≡ x
  test x = refl

  reveal : secret-number ≡ zero
  reveal = refl


{-# OPTIONS --experimental-irrelevance #-}
module ShapeIrrelevantIndexNoBecauseOfRecursion where

data ⊥ : Set where

record ⊤ : Set where
  constructor trivial

data Bool : Set where
  true false : Bool

True : Bool → Set
True false = ⊥
True true  = ⊤

data D : ..(b : Bool) → Set where
  c : {b : Bool} → True b → D b
-- because  of the irrelevant index,
-- D is in essence an existental type D : Set
-- with constructor c : {b : Bool} → True b → D

fromD : {b : Bool} → D b → True b
fromD (c p) = p -- should fail

cast : .(a b : Bool) → D a → D b
cast _ _ x = x

bot : ⊥
bot = fromD (cast true false (c trivial))


{-
This second-order term syntax was created from the following second-order syntax description:

syntax CommMonoid | CM

type
  * : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊕C) a b |> add(a, b) = add(b, a)
-}

module CommMonoid.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import CommMonoid.Signature

private
  variable
    Γ Δ Π : Ctx
    α : *T
    𝔛 : Familyₛ

-- Inductive term declaration
module CM:Terms (𝔛 : Familyₛ) where

  data CM : Familyₛ where
    var  : ℐ ⇾̣ CM
    mvar : 𝔛 α Π → Sub CM Π Γ → CM α Γ

    ε   : CM * Γ
    _⊕_ : CM * Γ → CM * Γ → CM * Γ

  infixl 20 _⊕_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  CMᵃ : MetaAlg CM
  CMᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (unitₒ ⋮ _)     → ε
      (addₒ  ⋮ a , b) → _⊕_ a b
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module CMᵃ = MetaAlg CMᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : CM ⇾̣ 𝒜
    𝕊 : Sub CM Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞  ε        = 𝑎𝑙𝑔 (unitₒ ⋮ tt)
    𝕤𝕖𝕞 (_⊕_ a b) = 𝑎𝑙𝑔 (addₒ  ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ CMᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ CM α Γ) → 𝕤𝕖𝕞 (CMᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (unitₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (addₒ  ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ CM ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : CM ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ CMᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : CM α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub CM Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! ε = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (_⊕_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
CM:Syn : Syntax
CM:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = CM:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open CM:Terms 𝔛 in record
    { ⊥ = CM ⋉ CMᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax CM:Syn public
open CM:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands CMᵃ public
open import SOAS.Metatheory CM:Syn public


------------------------------------------------------------------------
-- Some decision procedures for equality
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Equality

module Equality.Decision-procedures
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq
open import Equality.Decidable-UIP eq
open import Prelude
  hiding (module ⊤; module ⊥; module ↑; module ℕ; module Σ; module List)

------------------------------------------------------------------------
-- The unit type

module ⊤ where

  -- Equality of values of the unit type is decidable.

  infix 4 _≟_

  _≟_ : Decidable-equality ⊤
  _ ≟ _ = yes (refl _)

------------------------------------------------------------------------
-- The empty type

module ⊥ {ℓ} where

  -- Equality of values of the empty type is decidable.

  infix 4 _≟_

  _≟_ : Decidable-equality (⊥ {ℓ = ℓ})
  () ≟ ()

------------------------------------------------------------------------
-- Lifting

module ↑ {a ℓ} {A : Type a} where

  -- ↑ preserves decidability of equality.

  module Dec (dec : Decidable-equality A) where

    infix 4 _≟_

    _≟_ : Decidable-equality (↑ ℓ A)
    lift x ≟ lift y = ⊎-map (cong lift) (_∘ cong lower) (dec x y)

------------------------------------------------------------------------
-- Booleans

module Bool where

  -- The values true and false are distinct.

  abstract

    true≢false : true ≢ false
    true≢false true≡false = subst T true≡false _

  -- Equality of booleans is decidable.

  infix 4 _≟_

  _≟_ : Decidable-equality Bool
  true  ≟ true  = yes (refl _)
  false ≟ false = yes (refl _)
  true  ≟ false = no true≢false
  false ≟ true  = no (true≢false ∘ sym)

------------------------------------------------------------------------
-- Σ-types

module Σ {a b} {A : Type a} {B : A → Type b} where

  -- Two variants of Dec._≟_ (which is defined below).

  set⇒dec⇒dec⇒dec :
    {x₁ x₂ : A} {y₁ : B x₁} {y₂ : B x₂} →
    Is-set A →
    Dec (x₁ ≡ x₂) →
    (∀ eq → Dec (subst B eq y₁ ≡ y₂)) →
    Dec ((x₁ , y₁) ≡ (x₂ , y₂))
  set⇒dec⇒dec⇒dec set₁ (no  x₁≢x₂) dec₂ = no (x₁≢x₂ ∘ cong proj₁)
  set⇒dec⇒dec⇒dec set₁ (yes x₁≡x₂) dec₂ with dec₂ x₁≡x₂
  … | yes cast-y₁≡y₂ = yes (Σ-≡,≡→≡ x₁≡x₂ cast-y₁≡y₂)
  … | no  cast-y₁≢y₂ =
    no (cast-y₁≢y₂ ∘
        subst (λ p → subst B p _ ≡ _) (set₁ _ _) ∘
        proj₂ ∘ Σ-≡,≡←≡)

  decidable⇒dec⇒dec :
    {x₁ x₂ : A} {y₁ : B x₁} {y₂ : B x₂} →
    Decidable-equality A →
    (∀ eq → Dec (subst B eq y₁ ≡ y₂)) →
    Dec ((x₁ , y₁) ≡ (x₂ , y₂))
  decidable⇒dec⇒dec dec =
    set⇒dec⇒dec⇒dec (decidable⇒set dec) (dec _ _)

  -- Σ preserves decidability of equality.

  module Dec (_≟A_ : Decidable-equality A)
             (_≟B_ : {x : A} → Decidable-equality (B x)) where

    infix 4 _≟_

    _≟_ : Decidable-equality (Σ A B)
    _ ≟ _ = decidable⇒dec⇒dec _≟A_ (λ _ → _ ≟B _)

------------------------------------------------------------------------
-- Binary products

module × {a b} {A : Type a} {B : Type b} where

  -- _,_ preserves decided equality.

  dec⇒dec⇒dec :
    {x₁ x₂ : A} {y₁ y₂ : B} →
    Dec (x₁ ≡ x₂) →
    Dec (y₁ ≡ y₂) →
    Dec ((x₁ , y₁) ≡ (x₂ , y₂))
  dec⇒dec⇒dec (no  x₁≢x₂) _           = no (x₁≢x₂ ∘ cong proj₁)
  dec⇒dec⇒dec _           (no  y₁≢y₂) = no (y₁≢y₂ ∘ cong proj₂)
  dec⇒dec⇒dec (yes x₁≡x₂) (yes y₁≡y₂) = yes (cong₂ _,_ x₁≡x₂ y₁≡y₂)

  -- _×_ preserves decidability of equality.

  module Dec (_≟A_ : Decidable-equality A)
             (_≟B_ : Decidable-equality B) where

    infix 4 _≟_

    _≟_ : Decidable-equality (A × B)
    _ ≟ _ = dec⇒dec⇒dec (_ ≟A _) (_ ≟B _)

------------------------------------------------------------------------
-- Binary sums

module ⊎ {a b} {A : Type a} {B : Type b} where

  abstract

    -- The values inj₁ x and inj₂ y are never equal.

    inj₁≢inj₂ : {x : A} {y : B} → inj₁ x ≢ inj₂ y
    inj₁≢inj₂ = Bool.true≢false ∘ cong (if_then true else false)

  -- The inj₁ and inj₂ constructors are cancellative.

  cancel-inj₁ : {x y : A} → _≡_ {A = A ⊎ B} (inj₁ x) (inj₁ y) → x ≡ y
  cancel-inj₁ {x = x} = cong {A = A ⊎ B} {B = A} [ id , const x ]

  cancel-inj₂ : {x y : B} → _≡_ {A = A ⊎ B} (inj₂ x) (inj₂ y) → x ≡ y
  cancel-inj₂ {x = x} = cong {A = A ⊎ B} {B = B} [ const x , id ]

  -- _⊎_ preserves decidability of equality.

  module Dec (_≟A_ : Decidable-equality A)
             (_≟B_ : Decidable-equality B) where

    infix 4 _≟_

    _≟_ : Decidable-equality (A ⊎ B)
    inj₁ x ≟ inj₁ y = ⊎-map (cong (inj₁ {B = B})) (λ x≢y → x≢y ∘ cancel-inj₁) (x ≟A y)
    inj₂ x ≟ inj₂ y = ⊎-map (cong (inj₂ {A = A})) (λ x≢y → x≢y ∘ cancel-inj₂) (x ≟B y)
    inj₁ x ≟ inj₂ y = no inj₁≢inj₂
    inj₂ x ≟ inj₁ y = no (inj₁≢inj₂ ∘ sym)

------------------------------------------------------------------------
-- Lists

module List {a} {A : Type a} where

  abstract

    -- The values [] and x ∷ xs are never equal.

    []≢∷ : ∀ {x : A} {xs} → [] ≢ x ∷ xs
    []≢∷ = Bool.true≢false ∘
             cong (λ { [] → true; (_ ∷ _) → false })

  -- The _∷_ constructor is cancellative in both arguments.

  private

    head? : A → List A → A
    head? x []      = x
    head? _ (x ∷ _) = x

    tail? : List A → List A
    tail? []       = []
    tail? (_ ∷ xs) = xs

  cancel-∷-head : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y
  cancel-∷-head {x} = cong (head? x)

  cancel-∷-tail : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → xs ≡ ys
  cancel-∷-tail = cong tail?

  abstract

    -- An η-like result for the cancellation lemmas.

    unfold-∷ : ∀ {x y : A} {xs ys} (eq : x ∷ xs ≡ y ∷ ys) →
               eq ≡ cong₂ _∷_ (cancel-∷-head eq) (cancel-∷-tail eq)
    unfold-∷ {x} eq =
      eq                                             ≡⟨ sym $ trans-reflʳ eq ⟩
      trans eq (refl _)                              ≡⟨ sym $ cong (trans eq) sym-refl ⟩
      trans eq (sym (refl _))                        ≡⟨ sym $ trans-reflˡ _ ⟩
      trans (refl _) (trans eq (sym (refl _)))       ≡⟨ sym $ cong-roughly-id (λ xs → head? x xs ∷ tail? xs)
                                                                              non-empty eq tt tt lemma₁ ⟩
      cong (λ xs → head? x xs ∷ tail? xs) eq         ≡⟨ lemma₂ _∷_ (head? x) tail? eq ⟩∎
      cong₂ _∷_ (cong (head? x) eq) (cong tail? eq)  ∎
      where
      non-empty : List A → Bool
      non-empty []      = false
      non-empty (_ ∷ _) = true

      lemma₁ : (xs : List A) →
               if non-empty xs then ⊤ else ⊥ →
               head? x xs ∷ tail? xs ≡ xs
      lemma₁ []      ()
      lemma₁ (_ ∷ _) _ = refl _

      lemma₂ : {A B C D : Type a} {x y : A}
               (f : B → C → D) (g : A → B) (h : A → C) →
               (eq : x ≡ y) →
               cong (λ x → f (g x) (h x)) eq ≡
               cong₂ f (cong g eq) (cong h eq)
      lemma₂ f g h =
        elim (λ eq → cong (λ x → f (g x) (h x)) eq ≡
                     cong₂ f (cong g eq) (cong h eq))
             (λ x → cong (λ x → f (g x) (h x)) (refl x)          ≡⟨ cong-refl (λ x → f (g x) (h x)) ⟩
                    refl (f (g x) (h x))                         ≡⟨ sym $ cong₂-refl f ⟩
                    cong₂ f (refl (g x)) (refl (h x))            ≡⟨ sym $ cong₂ (cong₂ f) (cong-refl g) (cong-refl h) ⟩∎
                    cong₂ f (cong g (refl x)) (cong h (refl x))  ∎)

  -- List preserves decidability of equality.

  module Dec (_≟A_ : Decidable-equality A) where

    infix 4 _≟_

    _≟_ : Decidable-equality (List A)
    []       ≟ []       = yes (refl [])
    []       ≟ (_ ∷ _)  = no []≢∷
    (_ ∷ _)  ≟ []       = no ([]≢∷ ∘ sym)
    (x ∷ xs) ≟ (y ∷ ys) with x ≟A y
    ... | no  x≢y = no (x≢y ∘ cancel-∷-head)
    ... | yes x≡y with xs ≟ ys
    ...   | yes xs≡ys = yes (cong₂ _∷_ x≡y xs≡ys)
    ...   | no  xs≢ys = no  (xs≢ys ∘ cancel-∷-tail)

------------------------------------------------------------------------
-- Finite sets

module Fin where

  -- Equality of finite numbers is decidable.

  infix 4 _≟_

  _≟_ : ∀ {n} → Decidable-equality (Fin n)
  _≟_ {zero}  = λ ()
  _≟_ {suc n} = ⊎.Dec._≟_ (λ _ _ → yes (refl tt)) (_≟_ {n})


{-# OPTIONS --without-K --safe #-}

open import Categories.Category

module Categories.Diagram.Equalizer.Limit {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Data.Nat.Base using (ℕ)
open import Data.Fin.Base hiding (lift)
open import Data.Fin.Patterns

open import Categories.Category.Lift
open import Categories.Category.Finite.Fin
open import Categories.Category.Finite.Fin.Instance.Parallel
open import Categories.Diagram.Equalizer C
open import Categories.Diagram.Limit
open import Categories.Functor.Core

import Categories.Category.Construction.Cones as Co
import Categories.Morphism.Reasoning as MR

private
  module C = Category C
  open C
  open MR C
  open HomReasoning
  open Equiv

module _ {o′ ℓ′ e′} {F : Functor (liftC o′ ℓ′ e′ Parallel) C} where
  private
    module F = Functor F
    open F

  limit⇒equalizer : Limit F → Equalizer {B = F₀ (lift 1F)} (F₁ (lift 0F)) (F₁ (lift 1F))
  limit⇒equalizer L = record
    { obj       = apex
    ; arr       = proj (lift 0F)
    ; equality  = limit-commute (lift 0F) ○ ⟺ (limit-commute (lift 1F))
    ; equalize  = λ {_} {h} eq → rep record
      { apex = record
        { ψ       = λ { (lift 0F) → h
                      ; (lift 1F) → F₁ (lift 1F) ∘ h }
        ; commute = λ { {lift 0F} {lift 0F} (lift 0F) → elimˡ identity
                      ; {lift 0F} {lift 1F} (lift 0F) → eq
                      ; {lift 0F} {lift 1F} (lift 1F) → refl
                      ; {lift 1F} {lift 1F} (lift 0F) → elimˡ identity }
        }
      }
    ; universal = ⟺ commute
    ; unique    = λ {_} {h i} eq → ⟺ (terminal.!-unique record
      { arr = i
      ; commute = λ { {lift 0F} → ⟺ eq
                    ; {lift 1F} → begin
                      proj (lift 1F) ∘ i                ≈˘⟨ pullˡ (limit-commute (lift 1F)) ⟩
                      F₁ (lift 1F) ∘ proj (lift 0F) ∘ i ≈˘⟨ refl⟩∘⟨ eq ⟩
                      F₁ (lift 1F) ∘ h                  ∎ }
      })
    }
    where open Limit L

module _ o′ ℓ′ e′ {X Y} (f g : X ⇒ Y) where

  equalizer⇒limit-F : Functor (liftC o′ ℓ′ e′ Parallel) C
  equalizer⇒limit-F = record
    { F₀           = λ { (lift 0F) → X
                       ; (lift 1F) → Y }
    ; F₁           = λ { {lift 0F} {lift 0F} (lift 0F) → C.id
                       ; {lift 0F} {lift 1F} (lift 0F) → f
                       ; {lift 0F} {lift 1F} (lift 1F) → g
                       ; {lift 1F} {lift 1F} (lift 0F) → C.id }
    ; identity     = λ { {lift 0F} → refl
                       ; {lift 1F} → refl }
    ; homomorphism = λ { {lift 0F} {lift 0F} {lift 0F} {lift 0F} {lift 0F} → ⟺ identity²
                       ; {lift 0F} {lift 0F} {lift 1F} {lift 0F} {lift 0F} → ⟺ identityʳ
                       ; {lift 0F} {lift 0F} {lift 1F} {lift 0F} {lift 1F} → ⟺ identityʳ
                       ; {lift 0F} {lift 1F} {lift 1F} {lift 0F} {lift 0F} → ⟺ identityˡ
                       ; {lift 0F} {lift 1F} {lift 1F} {lift 1F} {lift 0F} → ⟺ identityˡ
                       ; {lift 1F} {lift 1F} {lift 1F} {lift 0F} {lift 0F} → ⟺ identity² }
    ; F-resp-≈     = λ { {lift 0F} {lift 0F} {lift 0F} {lift 0F} _ → refl
                       ; {lift 0F} {lift 1F} {lift 0F} {lift 0F} _ → refl
                       ; {lift 0F} {lift 1F} {lift 1F} {lift 1F} _ → refl
                       ; {lift 1F} {lift 1F} {lift 0F} {lift 0F} _ → refl }
    }

module _ o′ ℓ′ e′ {X Y} {f g : X ⇒ Y} (e : Equalizer f g) where
  open Equalizer e
  private
    F = equalizer⇒limit-F o′ ℓ′ e′ f g

  equalizer⇒limit : Limit F
  equalizer⇒limit = record
    { terminal = record
      { ⊤        = record
        { N    = obj
        ; apex = record
          { ψ       = λ { (lift 0F) → arr
                        ; (lift 1F) → g ∘ arr }
          ; commute = λ { {lift 0F} {lift 0F} (lift 0F) → identityˡ
                        ; {lift 0F} {lift 1F} (lift 0F) → equality
                        ; {lift 0F} {lift 1F} (lift 1F) → refl
                        ; {lift 1F} {lift 1F} (lift 0F) → identityˡ }
          }
        }
      ; !        = λ {K} →
        let open Co.Cone F K
        in record
        { arr     = equalize (commute (lift 0F) ○ ⟺ (commute (lift 1F)))
        ; commute = λ { {lift 0F} → ⟺ universal
                      ; {lift 1F} → pullʳ (⟺ universal) ○ commute (lift 1F) }
        }
      ; !-unique = λ f →
        let open Co.Cone⇒ F f
        in ⟺ (unique (⟺ commute))
      }
    }


module Derivative where

  open import Sets
  open import Functor
  import Isomorphism

  ∂ : U -> U
  ∂ (K A)   = K [0]
  ∂ Id	    = K [1]
  ∂ (F + G) = ∂ F + ∂ G
  ∂ (F × G) = ∂ F × G + F × ∂ G

  open Semantics

  -- Plugging a hole
  plug-∂ : {X : Set}(F : U) -> ⟦ ∂ F ⟧ X -> X -> ⟦ F ⟧ X
  plug-∂ (K _)	()		 x
  plug-∂ Id	<>		 x = x
  plug-∂ (F + G) (inl c)	 x = inl (plug-∂ F c x)
  plug-∂ (F + G) (inr c)	 x = inr (plug-∂ G c x)
  plug-∂ (F × G) (inl < c , g >) x = < plug-∂ F c x , g >
  plug-∂ (F × G) (inr < f , c >) x = < f , plug-∂ G c x >


{-# OPTIONS --experimental-irrelevance #-}
{-# OPTIONS --universe-polymorphism #-}
module IrrelevantLevelToSet where

open import Imports.Level

-- should fail, because Set i /= Set j for i /= j, so i is not irrelevant in Set i
MySet : .(i : Level) -> Set (suc i)
MySet i = Set i


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Maybe type
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Maybe where

open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Bool.Base using (T)
open import Data.Maybe.Relation.Unary.All
open import Data.Maybe.Relation.Unary.Any

------------------------------------------------------------------------
-- The base type and some operations

open import Data.Maybe.Base public

------------------------------------------------------------------------
-- Using Any and All to define Is-just and Is-nothing

Is-just : ∀ {a} {A : Set a} → Maybe A → Set a
Is-just = Any (λ _ → ⊤)

Is-nothing : ∀ {a} {A : Set a} → Maybe A → Set a
Is-nothing = All (λ _ → ⊥)

to-witness : ∀ {p} {P : Set p} {m : Maybe P} → Is-just m → P
to-witness (just {x = p} _) = p

to-witness-T : ∀ {p} {P : Set p} (m : Maybe P) → T (is-just m) → P
to-witness-T (just p) _  = p
to-witness-T nothing  ()


-- Andreas, 2017-04-10, issue #2537 reported by xekoukou
-- Preserve named args when splitting in a where clause.

-- {-# OPTIONS -v reify:100 #-}

data Bool : Set where
  true false : Bool

fun : {a b c d e f g : Bool} → Bool → Bool
fun {g = g} x with x
... | r = {!g!} -- C-c C-c g

-- Expected result:
-- fun {g = true} x | r = ?
-- fun {g = false} x | r = ?


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Monoid.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Record
open import Cubical.Algebra.Semigroup

open import Cubical.Reflection.StrictEquiv

open Iso

private
  variable
    ℓ : Level

record IsMonoid {A : Type ℓ} (ε : A) (_·_ : A → A → A) : Type ℓ where
  constructor ismonoid

  field
    isSemigroup : IsSemigroup _·_
    identity    : (x : A) → (x · ε ≡ x) × (ε · x ≡ x)

  open IsSemigroup isSemigroup public

  lid : (x : A) → ε · x ≡ x
  lid x = identity x .snd

  rid : (x : A) → x · ε ≡ x
  rid x = identity x .fst

record MonoidStr (A : Type ℓ) : Type (ℓ-suc ℓ) where
  constructor monoidstr

  field
    ε        : A
    _·_      : A → A → A
    isMonoid : IsMonoid ε _·_

  infixl 7 _·_

  open IsMonoid isMonoid public

  -- semigrp : Semigroup
  -- semigrp = record { isSemigroup = isSemigroup }

  -- open Semigroup semigrp public

Monoid : Type (ℓ-suc ℓ)
Monoid = TypeWithStr _ MonoidStr

monoid : (A : Type ℓ) (ε : A) (_·_ : A → A → A) (h : IsMonoid ε _·_) → Monoid
monoid A ε _·_ h = A , monoidstr ε _·_ h

-- Easier to use constructors

makeIsMonoid : {M : Type ℓ} {ε : M} {_·_ : M → M → M}
               (is-setM : isSet M)
               (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
               (rid : (x : M) → x · ε ≡ x)
               (lid : (x : M) → ε · x ≡ x)
             → IsMonoid ε _·_
IsMonoid.isSemigroup (makeIsMonoid is-setM assoc rid lid) = issemigroup is-setM assoc
IsMonoid.identity (makeIsMonoid is-setM assoc rid lid) = λ x → rid x , lid x

makeMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
             (is-setM : isSet M)
             (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
             (rid : (x : M) → x · ε ≡ x)
             (lid : (x : M) → ε · x ≡ x)
           → Monoid
makeMonoid ε _·_ is-setM assoc rid lid =
  monoid _ ε _·_ (makeIsMonoid is-setM assoc rid lid)

record MonoidEquiv (M N : Monoid {ℓ}) (e : ⟨ M ⟩ ≃ ⟨ N ⟩) : Type ℓ where

  constructor monoidiso

  private
    module M = MonoidStr (snd M)
    module N = MonoidStr (snd N)

  field
    presε : equivFun e M.ε ≡ N.ε
    isHom : (x y : ⟨ M ⟩) → equivFun e (x M.· y) ≡ equivFun e x N.· equivFun e y

module MonoidΣTheory {ℓ} where

  RawMonoidStructure : Type ℓ → Type ℓ
  RawMonoidStructure X = X × (X → X → X)

  RawMonoidEquivStr = AutoEquivStr RawMonoidStructure

  rawMonoidUnivalentStr : UnivalentStr _ RawMonoidEquivStr
  rawMonoidUnivalentStr = autoUnivalentStr RawMonoidStructure

  MonoidAxioms : (M : Type ℓ) → RawMonoidStructure M → Type ℓ
  MonoidAxioms M (e , _·_) = IsSemigroup _·_
                            × ((x : M) → (x · e ≡ x) × (e · x ≡ x))

  MonoidStructure : Type ℓ → Type ℓ
  MonoidStructure = AxiomsStructure RawMonoidStructure MonoidAxioms

  MonoidΣ : Type (ℓ-suc ℓ)
  MonoidΣ = TypeWithStr ℓ MonoidStructure

  isPropMonoidAxioms : (M : Type ℓ) (s : RawMonoidStructure M) → isProp (MonoidAxioms M s)
  isPropMonoidAxioms M (e , _·_) =
    isPropΣ (isPropIsSemigroup _·_)
            λ α → isPropΠ λ _ → isProp× (IsSemigroup.is-set α _ _) (IsSemigroup.is-set α _ _)

  MonoidEquivStr : StrEquiv MonoidStructure ℓ
  MonoidEquivStr = AxiomsEquivStr RawMonoidEquivStr MonoidAxioms

  MonoidAxiomsIsoIsMonoid : {M : Type ℓ} (s : RawMonoidStructure M)
    → Iso (MonoidAxioms M s) (IsMonoid (s .fst) (s .snd))
  fun (MonoidAxiomsIsoIsMonoid s) (x , y)        = ismonoid x y
  inv (MonoidAxiomsIsoIsMonoid s) a = (IsMonoid.isSemigroup a) , IsMonoid.identity a
  rightInv (MonoidAxiomsIsoIsMonoid s) _         = refl
  leftInv (MonoidAxiomsIsoIsMonoid s) _          = refl

  MonoidAxioms≡IsMonoid : {M : Type ℓ} (s : RawMonoidStructure M)
    → MonoidAxioms M s ≡ IsMonoid (s .fst) (s .snd)
  MonoidAxioms≡IsMonoid s = ua (strictIsoToEquiv (MonoidAxiomsIsoIsMonoid s))

  open MonoidStr

  Monoid→MonoidΣ : Monoid → MonoidΣ
  Monoid→MonoidΣ (A , M) =
    A , (ε M , _·_ M) , MonoidAxiomsIsoIsMonoid (ε M , _·_ M) .inv (isMonoid M)

  MonoidΣ→Monoid : MonoidΣ → Monoid
  MonoidΣ→Monoid (M , (ε , _·_) , isMonoidΣ) =
    monoid M ε _·_ (MonoidAxiomsIsoIsMonoid (ε , _·_) .fun isMonoidΣ)

  MonoidIsoMonoidΣ : Iso Monoid MonoidΣ
  MonoidIsoMonoidΣ =
    iso Monoid→MonoidΣ MonoidΣ→Monoid (λ _ → refl) (λ _ → refl)

  monoidUnivalentStr : UnivalentStr MonoidStructure MonoidEquivStr
  monoidUnivalentStr = axiomsUnivalentStr _ isPropMonoidAxioms rawMonoidUnivalentStr

  MonoidΣPath : (M N : MonoidΣ) → (M ≃[ MonoidEquivStr ] N) ≃ (M ≡ N)
  MonoidΣPath = SIP monoidUnivalentStr

  MonoidEquivΣ : (M N : Monoid) → Type ℓ
  MonoidEquivΣ M N = Monoid→MonoidΣ M ≃[ MonoidEquivStr ] Monoid→MonoidΣ N

  MonoidIsoΣPath : {M N : Monoid} → Iso (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] (MonoidEquiv M N e)) (MonoidEquivΣ M N)
  fun MonoidIsoΣPath (e , monoidiso h1 h2) = (e , h1 , h2)
  inv MonoidIsoΣPath (e , h1 , h2)         = (e , monoidiso h1 h2)
  rightInv MonoidIsoΣPath _                = refl
  leftInv MonoidIsoΣPath _                 = refl

  MonoidPath : (M N : Monoid {ℓ}) → (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] (MonoidEquiv M N e)) ≃ (M ≡ N)
  MonoidPath M N =
    Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] MonoidEquiv M N e ≃⟨ isoToEquiv MonoidIsoΣPath ⟩
    MonoidEquivΣ M N                      ≃⟨ MonoidΣPath _ _ ⟩
    Monoid→MonoidΣ M ≡ Monoid→MonoidΣ N ≃⟨ isoToEquiv (invIso (congIso MonoidIsoMonoidΣ)) ⟩
    M ≡ N ■

  RawMonoidΣ : Type (ℓ-suc ℓ)
  RawMonoidΣ = TypeWithStr ℓ RawMonoidStructure

  Monoid→RawMonoidΣ : Monoid → RawMonoidΣ
  Monoid→RawMonoidΣ (A , M) = A , (ε M) , (_·_ M)

  InducedMonoid : (M : Monoid) (N : RawMonoidΣ) (e : M .fst ≃ N .fst)
                 → RawMonoidEquivStr (Monoid→RawMonoidΣ M) N e → Monoid
  InducedMonoid M N e r =
    MonoidΣ→Monoid (inducedStructure rawMonoidUnivalentStr (Monoid→MonoidΣ M) N (e , r))

  InducedMonoidPath : (M : Monoid {ℓ}) (N : RawMonoidΣ) (e : M .fst ≃ N .fst)
                      (E : RawMonoidEquivStr (Monoid→RawMonoidΣ M) N e)
                    → M ≡ InducedMonoid M N e E
  InducedMonoidPath M N e E =
    MonoidPath M (InducedMonoid M N e E) .fst (e , monoidiso (E .fst) (E .snd))

-- We now extract the important results from the above module

isPropIsMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M) → isProp (IsMonoid ε _·_)
isPropIsMonoid ε _·_ =
  subst isProp (MonoidΣTheory.MonoidAxioms≡IsMonoid (ε , _·_))
        (MonoidΣTheory.isPropMonoidAxioms _ (ε , _·_))

MonoidPath : (M N : Monoid {ℓ}) → (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] MonoidEquiv M N e) ≃ (M ≡ N)
MonoidPath {ℓ = ℓ} =
  SIP
    (autoUnivalentRecord
      (autoRecordSpec (MonoidStr {ℓ}) MonoidEquiv
        (fields:
          data[ ε ∣ presε ]
          data[ _·_ ∣ isHom ]
          prop[ isMonoid ∣ (λ _ → isPropIsMonoid _ _) ]))
      _ _)
  where
  open MonoidStr
  open MonoidEquiv

InducedMonoid : (M : Monoid {ℓ}) (N : MonoidΣTheory.RawMonoidΣ) (e : M .fst ≃ N .fst)
              → MonoidΣTheory.RawMonoidEquivStr (MonoidΣTheory.Monoid→RawMonoidΣ M) N e
              → Monoid
InducedMonoid = MonoidΣTheory.InducedMonoid

InducedMonoidPath : (M : Monoid {ℓ}) (N : MonoidΣTheory.RawMonoidΣ) (e : M .fst ≃ N .fst)
                    (E : MonoidΣTheory.RawMonoidEquivStr (MonoidΣTheory.Monoid→RawMonoidΣ M) N e)
                  → M ≡ InducedMonoid M N e E
InducedMonoidPath = MonoidΣTheory.InducedMonoidPath

module MonoidTheory {ℓ} (M : Monoid {ℓ}) where

  open MonoidStr (snd M)

  -- Added for its use in groups
  -- If there exists a inverse of an element it is unique
  inv-lemma : (x y z : ⟨ M ⟩) → y · x ≡ ε → x · z ≡ ε → y ≡ z
  inv-lemma x y z left-inverse right-inverse =
    y           ≡⟨ sym (rid y) ⟩
    y · ε       ≡⟨ cong (λ - → y · -) (sym right-inverse) ⟩
    y · (x · z) ≡⟨ assoc y x z ⟩
    (y · x) · z ≡⟨ cong (λ - → - · z) left-inverse ⟩
    ε · z       ≡⟨ lid z ⟩
    z ∎


module Numeral.Rational.SternBrocot where


module RationalUtils where

open import Algebra
import Algebra.Morphism.RingMonomorphism as RingMonomorphisms
open import Data.Rational
open import Data.Rational.Properties
open import Data.Nat using (z≤n; s≤s)
open import Data.Integer using (+≤+; +<+; +_; -[1+_])
open import Data.Product using (_×_; _,_)
open import Data.Sum
open import Function.Base using (_∘_; _∘′_)
open import Level using (0ℓ)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Negation using (contradiction)

open import Vehicle.Data.Tensor

open ≤-Reasoning

private
  variable
    p q : ℚ

private
  module +-*-Monomorphism = RingMonomorphisms toℚᵘ-isRingMonomorphism-+-*

------------------------------------------------------------------------
-- Things to work out how to put in standard library

2ℚ = + 2 / 1
3ℚ = + 3 / 1

≰⇒≥ : _≰_ ⇒ _≥_
≰⇒≥ = <⇒≤ ∘′ ≰⇒>

p≤0⇒∣p∣≡-p : p ≤ 0ℚ → ∣ p ∣ ≡ - p
p≤0⇒∣p∣≡-p {mkℚ +[1+ n ] _ _} p≤0 = contradiction (nonPositive p≤0) λ()
p≤0⇒∣p∣≡-p {mkℚ +0       _ _} _   = refl
p≤0⇒∣p∣≡-p {mkℚ -[1+ n ] _ _} _   = refl

neg-involutive : Involutive _≡_ (-_)
neg-involutive (mkℚ +[1+ n ] _ _) = refl
neg-involutive (mkℚ +0       _ _) = refl
neg-involutive (mkℚ -[1+ n ] _ _) = refl

p≤∣p∣ : ∀ p → p ≤ ∣ p ∣
p≤∣p∣ p with 0ℚ ≤? p
... | yes 0≤p = ≤-reflexive (sym (0≤p⇒∣p∣≡p 0≤p))
... | no  0≰p = ≤-trans (≰⇒≥ 0≰p) (0≤∣p∣ p)

-p≤∣p∣ : ∀ p → - p ≤ ∣ p ∣
-p≤∣p∣ p with 0ℚ ≤? p
... | yes 0≤p = ≤-trans (neg-antimono-≤ 0≤p) (0≤∣p∣ p)
... | no  0≰p = ≤-reflexive (sym (p≤0⇒∣p∣≡-p (≰⇒≥ 0≰p)))

-p≤q⇒-q≤p : - p ≤ q → - q ≤ p
-p≤q⇒-q≤p {p} {q} = subst (- q ≤_) (neg-involutive p) ∘ neg-antimono-≤

p≤-q⇒q≤-p : p ≤ - q → q ≤ - p
p≤-q⇒q≤-p {p} {q} = subst (_≤ - p) (neg-involutive q) ∘ neg-antimono-≤

-p<q⇒-q<p : - p < q → - q < p
-p<q⇒-q<p {p} {q} = subst (- q <_) (neg-involutive p) ∘ neg-antimono-<

p<-q⇒q<-p : p < - q → q < - p
p<-q⇒q<-p {p} {q} = subst (_< - p) (neg-involutive q) ∘ neg-antimono-<

postulate p-[p+q]≡q : ∀ p q → p - (p + q) ≡ q

postulate p+q-p≡q : ∀ p q → p + q - p ≡ q

postulate p-q+q≡p : ∀ p q → p - q + q ≡ p

postulate *-monoʳ-≤ : ∀ r → Positive r → (r *_) Preserves _≤_ ⟶ _≤_

postulate p<r-q⇒p+q<r : ∀ p q r → p < r - q → p + q < r

∣p∣≤q⇒-q≤p≤q : ∀ p → ∣ p ∣ ≤ q → - q ≤ p × p ≤ q
∣p∣≤q⇒-q≤p≤q p ∣p∣≤q =
  -p≤q⇒-q≤p (≤-trans (-p≤∣p∣ p) ∣p∣≤q)
  , ≤-trans (p≤∣p∣ p) ∣p∣≤q

-p≤q≤p⇒∣q∣≤p : - p ≤ q → q ≤ p → ∣ q ∣ ≤ p
-p≤q≤p⇒∣q∣≤p {p} {q} -q≤p q≤p with ∣p∣≡p∨∣p∣≡-p q
... | inj₁ ∣q∣≡q  = subst (_≤ p) (sym ∣q∣≡q) q≤p
... | inj₂ ∣q∣≡-q = subst (_≤ p) (sym ∣q∣≡-q) (-p≤q⇒-q≤p -q≤p)

∣p∣<q⇒-q<p<q : ∀ p → ∣ p ∣ < q → - q < p × p < q
∣p∣<q⇒-q<p<q p ∣p∣<q =
  -p<q⇒-q<p (≤-<-trans (-p≤∣p∣ p) ∣p∣<q)
  , ≤-<-trans (p≤∣p∣ p) ∣p∣<q

-p<q<p⇒∣q∣<p : - p < q → q < p → ∣ q ∣ < p
-p<q<p⇒∣q∣<p {p} {q} -p<q q<p with ∣p∣≡p∨∣p∣≡-p q
... | inj₁ ∣q∣≡q  = subst (_< p) (sym ∣q∣≡q) q<p
... | inj₂ ∣q∣≡-q = subst (_< p) (sym ∣q∣≡-q) (-p<q⇒-q<p -p<q)

p+q-q≡p : ∀ p q → p + q - q ≡ p
p+q-q≡p p q = begin-equality
  p + q - q   ≡⟨ +-assoc p q (- q) ⟩
  p + (q - q) ≡⟨ cong (λ v → p + v) (+-inverseʳ q) ⟩
  p + 0ℚ      ≡⟨ +-identityʳ p ⟩
  p           ∎

+-isCommutativeSemigroup : IsCommutativeSemigroup _≡_ _+_
+-isCommutativeSemigroup = isCommutativeSemigroup
  where open IsCommutativeMonoid +-0-isCommutativeMonoid

+-commutativeSemigroup : CommutativeSemigroup 0ℓ 0ℓ
+-commutativeSemigroup = record
  { isCommutativeSemigroup = +-isCommutativeSemigroup
  }

2*p≡p+p : ∀ p → 2ℚ * p ≡ p + p
2*p≡p+p p = begin-equality
  2ℚ * p          ≡⟨⟩
  (1ℚ + 1ℚ) * p   ≡⟨ *-distribʳ-+ p 1ℚ 1ℚ ⟩
  1ℚ * p + 1ℚ * p ≡⟨ cong₂ _+_ (*-identityˡ p) (*-identityˡ p) ⟩
  p + p           ∎