open import Level
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using (Setoid)
import Function.Equality
import Relation.Binary.Reasoning.Setoid as SetoidR

import Categories.Category
import Categories.Functor
import Categories.NaturalTransformation
import Categories.Category.Instance.Setoids

import Categories.Category.Cocartesian

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.Term
import SecondOrder.VRenaming

module SecondOrder.MRenaming
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ
  open SecondOrder.Term Σ
  open SecondOrder.VRenaming Σ

  -- a metarenaming maps metavariables between contexts in an arity-preserving way
  _⇒ᵐ_ : ∀ (Θ ψ : MContext) → Set ℓ
  Θ ⇒ᵐ ψ = ∀ {Δ A} → [ Δ , A ]∈ Θ → [ Δ , A ]∈ ψ

  infix 4 _⇒ᵐ_

  -- equality of metarenamings

  _≡ᵐ_ : ∀ {Θ ψ} (ι μ : Θ ⇒ᵐ ψ) → Set ℓ
  _≡ᵐ_ {Θ} ι μ = ∀ {Δ A} (M : [ Δ , A ]∈ Θ) → ι M ≡ μ M

  infixl 3 _≡ᵐ_

  ≡ᵐ-refl : ∀ {Θ ψ} {ι : Θ ⇒ᵐ ψ} → ι ≡ᵐ ι
  ≡ᵐ-refl = λ M → refl

  ≡ᵐ-sym : ∀ {Θ ψ} {ι μ : Θ ⇒ᵐ ψ}
          → ι ≡ᵐ μ
          → μ ≡ᵐ ι
  ≡ᵐ-sym eq M = sym (eq M)

  ≡ᵐ-trans : ∀ {Θ ψ} {ι μ δ : Θ ⇒ᵐ ψ}
           → ι ≡ᵐ μ
           → μ ≡ᵐ δ
           → ι ≡ᵐ δ
  ≡ᵐ-trans eq1 eq2 M = trans (eq1 M) (eq2 M)

  -- meta-variable renamings form a setoid

  Mrenaming-setoid : ∀ (Θ ψ : MContext) → Setoid ℓ ℓ
  Mrenaming-setoid Θ ψ =
    record
      { Carrier = Θ ⇒ᵐ ψ
      ;  _≈_ = λ ι μ → ι ≡ᵐ μ
      ; isEquivalence =
                      record
                        { refl = λ {ι} M → ≡ᵐ-refl {Θ} {ψ} {ι} M
                        ; sym = ≡ᵐ-sym
                        ; trans = ≡ᵐ-trans
                        }
      }

  -- the identity renaming

  idᵐ : ∀ {Θ : MContext} → Θ ⇒ᵐ Θ
  idᵐ M = M

  -- equal metavariable renaming act the same on metavariables

  -- composition of renamings
  _∘ᵐ_ : ∀ {Θ ψ Ω} → ψ ⇒ᵐ Ω → Θ ⇒ᵐ ψ → Θ ⇒ᵐ Ω
  (ι ∘ᵐ μ) M = ι (μ M)

  infix 7 _∘ᵐ_

  -- composition respects equality
  ∘ᵐ-resp-≡ᵐ : ∀ {Γ Δ Ξ} {τ₁ τ₂ : Δ ⇒ᵐ Ξ} {σ₁ σ₂ : Γ ⇒ᵐ Δ} →
                 τ₁ ≡ᵐ τ₂ → σ₁ ≡ᵐ σ₂ → τ₁ ∘ᵐ σ₁ ≡ᵐ τ₂ ∘ᵐ σ₂
  ∘ᵐ-resp-≡ᵐ {τ₁ = τ₁} {σ₂ = σ₂} ζ ξ x = trans (cong τ₁ (ξ x)) (ζ (σ₂ x))

  -- the identity is the unit

  identity-leftᵐ : ∀ {Γ Δ} {ρ : Γ ⇒ᵐ Δ} → idᵐ ∘ᵐ ρ ≡ᵐ ρ
  identity-leftᵐ ρ = refl

  identity-rightᵐ : ∀ {Γ Δ} {ρ : Γ ⇒ᵐ Δ} → ρ ∘ᵐ idᵐ ≡ᵐ ρ
  identity-rightᵐ ρ = refl

  -- composition is associative

  assocᵐ : ∀ {Γ Δ Ξ Ψ} {τ : Γ ⇒ᵐ Δ} {ρ : Δ ⇒ᵐ Ξ} {σ : Ξ ⇒ᵐ Ψ} →
             (σ ∘ᵐ ρ) ∘ᵐ τ ≡ᵐ σ ∘ᵐ (ρ ∘ᵐ τ)
  assocᵐ x = refl

  sym-assocᵐ : ∀ {Γ Δ Ξ Ψ} {τ : Γ ⇒ᵐ Δ} {ρ : Δ ⇒ᵐ Ξ} {σ : Ξ ⇒ᵐ Ψ} →
             σ ∘ᵐ (ρ ∘ᵐ τ) ≡ᵐ (σ ∘ᵐ ρ) ∘ᵐ τ
  sym-assocᵐ x = refl

  -- contexts and renamings form a category
  module _ where
    open Categories.Category

    MContexts : Category ℓ ℓ ℓ
    MContexts =
      record
        { Obj = MContext
        ; _⇒_ = _⇒ᵐ_
        ; _≈_ = _≡ᵐ_
        ; id = idᵐ
        ; _∘_ = _∘ᵐ_
        ; assoc = λ {_} {_} {_} {_} {f} {g} {h} {_} → assocᵐ {τ = f} {ρ = g} {σ = h}
        ; sym-assoc = λ {_} {_} {_} {_} {f} {g} {h} {_} → sym-assocᵐ {τ = f} {ρ = g} {σ = h}
        ; identityˡ = λ x → refl
        ; identityʳ = λ x → refl
        ; identity² = λ x → refl
        ; equiv = record { refl = λ {ι} {_} → ≡ᵐ-refl {ι = ι} ; sym = ≡ᵐ-sym ; trans = ≡ᵐ-trans }
        ; ∘-resp-≈ = ∘ᵐ-resp-≡ᵐ
        }

  -- the coproduct structure of the category
  module _ where

    infixl 7 [_,_]ᵐ

    [_,_]ᵐ : ∀ {Γ Δ Ξ} → Γ ⇒ᵐ Ξ → Δ ⇒ᵐ Ξ → Γ ,, Δ ⇒ᵐ Ξ
    [ σ , τ ]ᵐ (var-inl x) = σ x
    [ σ , τ ]ᵐ (var-inr y) = τ y

    inlᵐ : ∀ {Γ Δ} → Γ ⇒ᵐ Γ ,, Δ
    inlᵐ = var-inl

    inrᵐ : ∀ {Γ Δ} → Δ ⇒ᵐ Γ ,, Δ
    inrᵐ = var-inr

    uniqueᵐ : ∀ {Γ Δ Ξ} {τ : Γ ,, Δ ⇒ᵐ Ξ} {ρ : Γ ⇒ᵐ Ξ} {σ : Δ ⇒ᵐ Ξ}
              → τ ∘ᵐ inlᵐ ≡ᵐ ρ
              → τ ∘ᵐ inrᵐ ≡ᵐ σ
              → [ ρ , σ ]ᵐ ≡ᵐ τ
    uniqueᵐ ξ ζ (var-inl x) = sym (ξ x)
    uniqueᵐ ξ ζ (var-inr y) = sym (ζ y)

    MContext-+ : Categories.Category.Cocartesian.BinaryCoproducts MContexts
    MContext-+ =
      record {
        coproduct =
          λ {Γ Δ} →
          record
            { A+B = Γ ,, Δ
            ; i₁ = inlᵐ
            ; i₂ = inrᵐ
            ; [_,_] = [_,_]ᵐ
            ; inject₁ = λ x → refl
            ; inject₂ = λ x → refl
            ; unique = uniqueᵐ
            }
      }

  open Categories.Category.Cocartesian.BinaryCoproducts MContext-+

  -- the renaming from the empty context

  inᵐ : ∀ {Γ} → ctx-empty ⇒ᵐ Γ
  inᵐ ()

  -- extension of a renaming is summing with identity
  ⇑ᵐ : ∀ {Θ Ψ Ω} → Θ ⇒ᵐ Ψ → Θ ,, Ω ⇒ᵐ Ψ ,, Ω
  ⇑ᵐ ρ = ρ +₁ idᵐ

  -- a renaming can also be extended on the right
  ᵐ⇑ᵐ : ∀ {Θ Ψ} → Θ ⇒ᵐ Ψ → ∀ {Ω} → Ω ,, Θ ⇒ᵐ Ω ,, Ψ
  ᵐ⇑ᵐ ρ = idᵐ +₁ ρ

  -- the action of a metavariable renaming on terms
  infix 6 [_]ᵐ_

  [_]ᵐ_ : ∀ {Θ Ψ Γ A} → Θ ⇒ᵐ Ψ → Term Θ Γ A → Term Ψ Γ A
  [ ι ]ᵐ (tm-var x) = tm-var x
  [ ι ]ᵐ (tm-meta M ts) = tm-meta (ι M) (λ i → [ ι ]ᵐ ts i)
  [ ι ]ᵐ (tm-oper f es) = tm-oper f (λ i → [ ι ]ᵐ es i)

  -- The sum of identities is an identity
  idᵐ+idᵐ : ∀ {Θ Ψ} → idᵐ {Θ = Θ} +₁ idᵐ {Θ = Ψ} ≡ᵐ idᵐ {Θ = Θ ,, Ψ}
  idᵐ+idᵐ (var-inl x) = refl
  idᵐ+idᵐ (var-inr y) = refl

  -- The action of a renaming respects equality of terms
  []ᵐ-resp-≈ : ∀ {Θ Ψ Γ A} {s t : Term Θ Γ A} {ι : Θ ⇒ᵐ Ψ} → s ≈ t → [ ι ]ᵐ s ≈ [ ι ]ᵐ t
  []ᵐ-resp-≈ (≈-≡ refl) = ≈-≡ refl
  []ᵐ-resp-≈ (≈-meta ξ) = ≈-meta (λ i → []ᵐ-resp-≈ (ξ i))
  []ᵐ-resp-≈ (≈-oper ξ) = ≈-oper (λ i → []ᵐ-resp-≈ (ξ i))

  -- The action of a renaming respects equality of renamings
  []ᵐ-resp-≡ᵐ : ∀ {Θ Ψ Γ A} {ι μ : Θ ⇒ᵐ Ψ} {t : Term Θ Γ A} → ι ≡ᵐ μ → [ ι ]ᵐ t ≈ [ μ ]ᵐ t
  []ᵐ-resp-≡ᵐ {t = tm-var x} ξ = ≈-≡ refl
  []ᵐ-resp-≡ᵐ {Θ} {Ψ} {Γ} {A} {ι = ι} {μ = μ} {t = tm-meta M ts} ξ =
    let open SetoidR (Term-setoid Ψ Γ A) in
    begin
    tm-meta (ι M) (λ i → [ ι ]ᵐ ts i) ≈⟨ ≈-meta (λ i → []ᵐ-resp-≡ᵐ ξ) ⟩
    tm-meta (ι M) (λ i → [ μ ]ᵐ ts i) ≈⟨ ≈-≡ ((cong λ N → tm-meta N (λ i → [ μ ]ᵐ ts i)) (ξ M)) ⟩
    tm-meta (μ M) (λ i → [ μ ]ᵐ ts i) ≈⟨ ≈-≡ refl ⟩
    tm-meta (μ M) (λ i → [ μ ]ᵐ ts i)
    ∎
  []ᵐ-resp-≡ᵐ {t = tm-oper f es} ξ = ≈-oper λ i → []ᵐ-resp-≡ᵐ ξ

  -- The action of the identity is trival
  [idᵐ] : ∀ {Θ Γ A} {t : Term Θ Γ A} → [ idᵐ ]ᵐ t ≈ t
  [idᵐ] {t = tm-var x} = ≈-refl
  [idᵐ] {t = tm-meta M ts} = ≈-meta λ i → [idᵐ]
  [idᵐ] {t = tm-oper f es} = ≈-oper λ i → [idᵐ]

  -- Extension respects composition
  ⇑ᵐ-resp-∘ᵐ : ∀ {Γ Δ Ξ Ψ} {ρ : Γ ⇒ᵐ Δ} {τ : Δ ⇒ᵐ Ξ} → ⇑ᵐ {Ω = Ψ} (τ ∘ᵐ ρ) ≡ᵐ (⇑ᵐ τ) ∘ᵐ (⇑ᵐ ρ)
  ⇑ᵐ-resp-∘ᵐ (var-inl x) = refl
  ⇑ᵐ-resp-∘ᵐ (var-inr y) = refl

  ᵐ⇑ᵐ-resp-∘ᵐ : ∀ {Θ Ψ Ω Ξ} {ρ : Θ ⇒ᵐ Ψ} {τ : Ψ ⇒ᵐ Ω}
    → ᵐ⇑ᵐ {Θ} {Ω} (τ ∘ᵐ ρ) {Ξ} ≡ᵐ (ᵐ⇑ᵐ τ) ∘ᵐ (ᵐ⇑ᵐ ρ)
  ᵐ⇑ᵐ-resp-∘ᵐ (var-inl M) = refl
  ᵐ⇑ᵐ-resp-∘ᵐ (var-inr N) = refl

  -- Extension of the identity renaming is the identity
  ⇑ᵐ-resp-idᵐ : ∀ {Θ Ψ} → (⇑ᵐ {Θ} {Θ} {Ψ}) (idᵐ {Θ}) ≡ᵐ idᵐ
  ⇑ᵐ-resp-idᵐ (var-inl M) = refl
  ⇑ᵐ-resp-idᵐ (var-inr N) = refl

  ᵐ⇑ᵐ-resp-idᵐ : ∀ {Θ Ψ} → (ᵐ⇑ᵐ {Θ} {Θ}) (idᵐ {Θ}) {Ψ} ≡ᵐ idᵐ
  ᵐ⇑ᵐ-resp-idᵐ (var-inl M) = refl
  ᵐ⇑ᵐ-resp-idᵐ (var-inr N) = refl

  -- Extension preserves equality of metavariable renamings
  ᵐ⇑ᵐ-resp-≡ᵐ : ∀ {Θ Ψ Ω} {ι μ : Θ ⇒ᵐ Ψ} → ι ≡ᵐ μ → ᵐ⇑ᵐ ι {Ω} ≡ᵐ ᵐ⇑ᵐ μ
  ᵐ⇑ᵐ-resp-≡ᵐ ι≡μ (var-inl M) = refl
  ᵐ⇑ᵐ-resp-≡ᵐ {ι = ι} ι≡μ (var-inr N) = cong (inrᵐ) (ι≡μ N)

  ⇑ᵐ-resp-≡ᵐ : ∀ {Θ Ψ Ω} {ι μ : Θ ⇒ᵐ Ψ} → ι ≡ᵐ μ → ⇑ᵐ {Ω = Ω} ι ≡ᵐ ⇑ᵐ μ
  ⇑ᵐ-resp-≡ᵐ ι≡μ (var-inl M) = cong var-inl (ι≡μ M)
  ⇑ᵐ-resp-≡ᵐ {ι = ι} ι≡μ (var-inr N) = refl

  -- The action of a renaming is functorial
  [∘ᵐ] : ∀ {Θ Ψ Ω Γ} {ι : Θ ⇒ᵐ Ψ} {μ : Ψ ⇒ᵐ Ω} {A} {t : Term Θ Γ A}
    → [ μ ∘ᵐ ι ]ᵐ t ≈ [ μ ]ᵐ ([ ι ]ᵐ t)
  [∘ᵐ] {t = tm-var x} = ≈-refl
  [∘ᵐ] {t = tm-meta M ts} = ≈-meta (λ i → [∘ᵐ])
  [∘ᵐ] {t = tm-oper f es} = ≈-oper (λ i → [∘ᵐ])

  ᵐ∘ᵛ≈ᵛ∘ᵐ : ∀ {Θ Ψ Γ Δ A} {ρ : Γ ⇒ᵛ Δ} {ι : Θ ⇒ᵐ Ψ} {t : Term Θ Γ A}
    → [ ι ]ᵐ ([ ρ ]ᵛ t) ≈ [ ρ ]ᵛ ([ ι ]ᵐ t)
  ᵐ∘ᵛ≈ᵛ∘ᵐ {t = tm-var x} = ≈-refl
  ᵐ∘ᵛ≈ᵛ∘ᵐ {t = tm-meta M ts} = ≈-meta (λ i → ᵐ∘ᵛ≈ᵛ∘ᵐ {t = ts i})
  ᵐ∘ᵛ≈ᵛ∘ᵐ {t = tm-oper f es} = ≈-oper (λ i → ᵐ∘ᵛ≈ᵛ∘ᵐ {t = es i})

  split-sum : ∀ {Θ Ψ Ξ Ω} {ι : Θ ⇒ᵐ Ψ} {μ : Ξ ⇒ᵐ Ω}
    → (μ +₁ ι) ≡ᵐ (⇑ᵐ μ) ∘ᵐ (ᵐ⇑ᵐ ι)
  split-sum (var-inl M) = refl
  split-sum (var-inr N) = refl

  split-sum2 : ∀ {Θ Ψ Ξ Ω} {ι : Θ ⇒ᵐ Ψ} {μ : Ξ ⇒ᵐ Ω}
    → (μ +₁ ι) ≡ᵐ (ᵐ⇑ᵐ ι) ∘ᵐ (⇑ᵐ μ)
  split-sum2 (var-inl M) = refl
  split-sum2 (var-inr N) = refl

  ⇑-resp-+ : ∀ {Θ Ψ Ξ Ω Γ A} {ι : Θ ⇒ᵐ Ψ} {μ : Ξ ⇒ᵐ Ω} {t : Term (Ξ + Θ) Γ A}
    → [ (⇑ᵐ μ) ]ᵐ ([ (ᵐ⇑ᵐ ι) ]ᵐ t) ≈ [ (ᵐ⇑ᵐ ι) ]ᵐ ([ (⇑ᵐ μ) ]ᵐ t)
  ⇑-resp-+ {Θ} {Ψ} {Ξ} {Ω} {Γ} {A} {ι} {μ} {t = t} =
    let open SetoidR (Term-setoid (Ω ,, Ψ) Γ A) in
    begin
    [ ⇑ᵐ μ ]ᵐ ([ ᵐ⇑ᵐ ι ]ᵐ t) ≈⟨ ≈-sym [∘ᵐ] ⟩
    [ (⇑ᵐ μ) ∘ᵐ (ᵐ⇑ᵐ ι) ]ᵐ t  ≈⟨ ≈-sym ([]ᵐ-resp-≡ᵐ split-sum) ⟩
    [ (μ +₁ ι) ]ᵐ t ≈⟨ []ᵐ-resp-≡ᵐ split-sum2 ⟩
    [(ᵐ⇑ᵐ ι) ∘ᵐ (⇑ᵐ μ)  ]ᵐ t ≈⟨ [∘ᵐ] ⟩
    [ ᵐ⇑ᵐ ι ]ᵐ ([ ⇑ᵐ μ ]ᵐ t)
    ∎

  ∘ᵐ-resp-⇑ : ∀ {Θ Ψ Ξ Ω} {ι : Θ ⇒ᵐ Ψ} {μ : Ψ ⇒ᵐ Ω}
    → ⇑ᵐ {Ω = Ξ}  (μ ∘ᵐ ι) ≡ᵐ ⇑ᵐ μ ∘ᵐ ⇑ᵐ ι
  ∘ᵐ-resp-⇑ (var-inl M) = refl
  ∘ᵐ-resp-⇑ (var-inr N) = refl

  ∘ᵐ-resp-⇑-term : ∀ {Θ Ψ Ξ Ω Γ A} {ι : Θ ⇒ᵐ Ψ} {μ : Ψ ⇒ᵐ Ω} {t : Term (Θ ,, Ξ) Γ A}
    → [ ⇑ᵐ {Ω = Ξ} (μ ∘ᵐ ι) ]ᵐ t ≈  [ ⇑ᵐ μ ]ᵐ ([ ⇑ᵐ ι ]ᵐ t)
  ∘ᵐ-resp-⇑-term {Θ} {Ψ} {Ξ} {Ω} {Γ} {A} {ι} {μ} {t = t} =
      let open SetoidR (Term-setoid (Ω ,, Ξ) Γ A) in
      begin
      [ ⇑ᵐ {Ω = Ξ} (μ ∘ᵐ ι) ]ᵐ t ≈⟨ []ᵐ-resp-≡ᵐ ∘ᵐ-resp-⇑ ⟩
      [ ⇑ᵐ μ ∘ᵐ ⇑ᵐ ι ]ᵐ t ≈⟨ [∘ᵐ] ⟩
      [ ⇑ᵐ μ ]ᵐ ([ ⇑ᵐ ι ]ᵐ t)
      ∎

  ∘ᵐ-resp-ᵐ⇑ : ∀ {Θ Ψ Ξ Ω} {ι : Θ ⇒ᵐ Ψ} {μ : Ψ ⇒ᵐ Ω}
    → ᵐ⇑ᵐ (μ ∘ᵐ ι) {Ω = Ξ} ≡ᵐ ᵐ⇑ᵐ μ ∘ᵐ ᵐ⇑ᵐ ι
  ∘ᵐ-resp-ᵐ⇑ (var-inl M) = refl
  ∘ᵐ-resp-ᵐ⇑ (var-inr N) = refl

  ∘ᵐ-resp-ᵐ⇑-term : ∀ {Θ Ψ Ξ Ω Γ A} {ι : Θ ⇒ᵐ Ψ} {μ : Ψ ⇒ᵐ Ω} {t : Term (Ξ ,, Θ) Γ A}
    → [ ᵐ⇑ᵐ  (μ ∘ᵐ ι) {Ω = Ξ} ]ᵐ t ≈  [ ᵐ⇑ᵐ μ ]ᵐ ([ ᵐ⇑ᵐ ι ]ᵐ t)
  ∘ᵐ-resp-ᵐ⇑-term {Θ} {Ψ} {Ξ} {Ω} {Γ} {A} {ι} {μ} {t = t} =
      let open SetoidR (Term-setoid (Ξ ,, Ω) Γ A) in
      begin
      [ ᵐ⇑ᵐ (μ ∘ᵐ ι) {Ω = Ξ} ]ᵐ t ≈⟨ []ᵐ-resp-≡ᵐ ∘ᵐ-resp-ᵐ⇑ ⟩
      [ ᵐ⇑ᵐ μ ∘ᵐ ᵐ⇑ᵐ ι ]ᵐ t ≈⟨ [∘ᵐ] ⟩
      [ ᵐ⇑ᵐ μ ]ᵐ ([ ᵐ⇑ᵐ ι ]ᵐ t)
      ∎

  vr-comm-mr : ∀ {Θ Ψ Γ Δ A} {ρ : Γ ⇒ᵛ Δ} {ι : Θ ⇒ᵐ Ψ} {t : Term Θ Γ A}
    → [ ι ]ᵐ ([ ρ ]ᵛ t) ≈ [ ρ ]ᵛ ([ ι ]ᵐ t)
  vr-comm-mr {t = tm-var x} = ≈-refl
  vr-comm-mr {t = tm-meta M ts} = ≈-meta (λ i → vr-comm-mr)
  vr-comm-mr {t = tm-oper f es} = ≈-oper (λ i → vr-comm-mr)

  mr-comm-vr : ∀ {Θ Ψ Γ Δ A} {ρ : Γ ⇒ᵛ Δ} {ι : Θ ⇒ᵐ Ψ} {t : Term Θ Γ A}
    → [ ρ ]ᵛ ([ ι ]ᵐ t) ≈  [ ι ]ᵐ ([ ρ ]ᵛ t)
  mr-comm-vr {t = tm-var x} = ≈-refl
  mr-comm-vr {t = tm-meta M ts} = ≈-meta (λ i → mr-comm-vr)
  mr-comm-vr {t = tm-oper f es} = ≈-oper (λ i → mr-comm-vr)

  module _ {Θ Ψ : MContext} {A : sort} where
    open Categories.Category
    open Categories.Category.Instance.Setoids
    open Categories.Functor
    open Categories.NaturalTransformation

    MRenaming-NT : ∀ (ι : Θ ⇒ᵐ Ψ) → NaturalTransformation (Term-Functor {Θ} {A}) (Term-Functor {Ψ} {A})
    MRenaming-NT ι =
      record
      { η = λ Γ → record { _⟨$⟩_ = [ ι ]ᵐ_ ; cong = []ᵐ-resp-≈ }
      ; commute = λ ρ t≈s → ≈-trans ([]ᵐ-resp-≈ ([]ᵛ-resp-≈ t≈s)) (ᵐ∘ᵛ≈ᵛ∘ᵐ)
      ; sym-commute = λ ρ t≈s → ≈-trans (≈-sym ᵐ∘ᵛ≈ᵛ∘ᵐ) ([]ᵐ-resp-≈ ([]ᵛ-resp-≈ t≈s))
      }


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

module homotopy.3x3.Common where

open import HoTT public hiding (↓-='-in; ↓-='-out; ↓-=-in; ↓-=-out; ↓-∘=idf-in)

!-∘-ap-inv : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) (g : A → B) {a b : A}
  (p : a == b)
  → ap-∘ f g p == ! (∘-ap f g p)
!-∘-ap-inv f g idp = idp

!-ap-∘-inv : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) (g : A → B) {a b : A}
  (p : a == b)
  → ∘-ap f g p == ! (ap-∘ f g p)
!-ap-∘-inv f g idp = idp

!-∘-ap : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) (g : A → B) {a b : A}
  (p : a == b)
  → ! (∘-ap f g p) == ap-∘ f g p
!-∘-ap f g idp = idp

!-ap-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : B → C) (g : A → B) {a b : A}
  (p : a == b)
  → ! (ap-∘ f g p) == ∘-ap f g p
!-ap-∘ f g idp = idp

module _ {i} {A : Type i} where

  _,_=□_,_ : {a b b' c : A} (p : a == b) (q : b == c)
             (r : a == b') (s : b' == c) → Type i
  (idp , q =□ r , idp) = (q == r)

  idp□ : {a b : A} {p : a == b} → idp , p =□ idp , p
  idp□ {p = idp} = idp

  idp□-i : {a b : A} {p : a == b} → p , idp =□ idp , p
  idp□-i {p = idp} = idp

  idp,=□idp,-in : {a b : A} {p q : a == b}
                → p == q → idp , p =□ idp , q
  idp,=□idp,-in {q = idp} α = α

  idp,=□idp,-out : {a b : A} {p q : a == b}
                 → idp , p =□ idp , q → p == q
  idp,=□idp,-out {q = idp} α = α

  idp,=□idp,-β : {a b : A} {p q : a == b}
                 (α : p == q) → idp,=□idp,-out (idp,=□idp,-in α) == α
  idp,=□idp,-β {q = idp} α = idp

  idp,=□idp,-η : {a b : A} {p q : a == b}
                  (α : idp , p =□ idp , q) → idp,=□idp,-in (idp,=□idp,-out α) == α
  idp,=□idp,-η {q = idp} α = idp

  ,idp=□,idp-in : {a b : A} {p q : a == b}
                → p == q → p , idp =□ q , idp
  ,idp=□,idp-in {p = idp} α = α

  ,idp=□,idp-out : {a b : A} {p q : a == b}
                 → p , idp =□ q , idp → p == q
  ,idp=□,idp-out {p = idp} α = α

  ,idp=□,idp-β : {a b : A} {p q : a == b}
                 (α : p == q) → ,idp=□,idp-out (,idp=□,idp-in α) == α
  ,idp=□,idp-β {p = idp} α = idp

  ,idp=□,idp-η : {a b : A} {p q : a == b}
                 (α : p , idp =□ q , idp) → ,idp=□,idp-in (,idp=□,idp-out α) == α
  ,idp=□,idp-η {p = idp} α = idp

  ,idp=□idp,-in : {a b : A} {p q : a == b}
                → p == q → p , idp =□ idp , q
  ,idp=□idp,-in {p = idp} = idp,=□idp,-in

  ,idp=□idp,-out : {a b : A} {p q : a == b}
                 → p , idp =□ idp , q → p == q
  ,idp=□idp,-out {p = idp} {q} α = idp,=□idp,-out α

  ,idp=□idp,-β : {a b : A} {p q : a == b}
                 (α : p == q) → ,idp=□idp,-out (,idp=□idp,-in α) == α
  ,idp=□idp,-β {p = idp} α = idp,=□idp,-β α

  ,idp=□idp,-η : {a b : A} {p q : a == b}
                 (α : p , idp =□ idp , q) → ,idp=□idp,-in (,idp=□idp,-out α) == α
  ,idp=□idp,-η {p = idp} α = idp,=□idp,-η α

  _∙□-i/_/_/ : {a b b' c : A} {p : a == b} {q q' : b == c}
         {r r' : a == b'} {s : b' == c}
         → (p , q =□ r , s) → (q' == q) → (r == r')
         → (p , q' =□ r' , s)
  α ∙□-i/ idp / idp / = α

  _∙□-o/_/_/ : {a b b' c : A} {p p' : a == b} {q : b == c}
         {r : a == b'} {s s' : b' == c}
         → (p , q =□ r , s) → (p' == p) → (s == s')
         → (p' , q =□ r , s')
  α ∙□-o/ idp / idp / = α

  _∙□h_ : {a b b' c c' d : A} {p : a == b} {q : b == c} {r : a == b'}
    {s : b' == c} {t : c == d} {u : b' == c'} {v : c' == d}
    → (p , q =□ r , s) → (s , t =□ u , v) → (p , q ∙ t =□ r ∙ u , v)
  _∙□h_ {p = idp} {s = idp} {v = idp} idp idp = idp

module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  ap□ : {a b b' c : A} {p : a == b} {q : b == c} {r : a == b'} {s : b' == c}
    → (p , q =□ r , s) → (ap f p , ap f q =□ ap f r , ap f s)
  ap□ {p = idp} {s = idp} α = ap (ap f) α

module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  ap□-,idp=□idp,-in :  {a b : A} {p q : a == b}
                (α : p == q) → ap□ f (,idp=□idp,-in α) == ,idp=□idp,-in (ap (ap f) α)
  ap□-,idp=□idp,-in {p = idp} idp = idp

module _ {i j} {A : Type i} {B : A → Type j} where

  _,_=□d-i_,_ : {a b : A} {p : a == b} {u v : B a} {w x : B b}
           → (u == v) → (v == w [ B ↓ p ])
           → (u == x [ B ↓ p ]) → (x == w)
           → Type j
  _,_=□d-i_,_ idp α β idp = (α == β)
  -- _,_=□d-i_,_ {p = idp} = _,_=□_,_

  idp,=□d-iidp,-out : {a : A} {u w : B a} {α β : u == w}
    → (idp , α =□d-i idp , β) → α == β
  idp,=□d-iidp,-out {β = idp} x = x

  ,idp=□d-iidp,-out : {a : A} {u w : B a} {α β : u == w}
    → (α , idp =□d-i idp , β) → α == β
  ,idp=□d-iidp,-out {α = idp} x = idp,=□d-iidp,-out x

  idp,=□d-iidp,-in : {a : A} {u w : B a} {α β : u == w}
    → α == β → (idp , α =□d-i idp , β)
  idp,=□d-iidp,-in {β = idp} x = x

  ,idp=□d-iidp,-in : {a : A} {u w : B a} {α β : u == w}
    → α == β → (α , idp =□d-i idp , β)
  ,idp=□d-iidp,-in {α = idp} x = idp,=□d-iidp,-in x

  _◃/_/_/ : {a b : A} {p : a == b} {u v : B a} {w x : B b}
          → (v == w [ B ↓ p ]) → (u == v) → (w == x)
          → (u == x [ B ↓ p ])
  α ◃/ idp / idp / = α

module _ {i} {A : Type i} where

  _,_,_=□□_,_,_ : {a0 b0 b'0 c0 a1 b1 b'1 c1 : A}
    {p0 : a0 == b0} {q0 : b0 == c0} {r0 : a0 == b'0} {s0 : b'0 == c0}
    {p1 : a1 == b1} {q1 : b1 == c1} {r1 : a1 == b'1} {s1 : b'1 == c1}
    {a* : a0 == a1} {b* : b0 == b1} {b'* : b'0 == b'1} {c* : c0 == c1}
    → (p0 , q0 =□ r0 , s0) → (s0 , c* =□ b'* , s1) → (r0 , b'* =□ a* , r1)
    → (q0 , c* =□ b* , q1) → (p0 , b* =□ a* , p1) → (p1 , q1 =□ r1 , s1)
    → Type i
  _,_,_=□□_,_,_ {p0 = idp} {s0 = idp} {p1 = idp} {s1 = idp} idp idp β γ idp idp = β == γ

{- Nondependent identity type -}

module _ {i j} {A : Type i} {B : Type j} {f g : A → B} where

  ↓-='-in : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → (u , ap g p =□ ap f p , v)
    → (u == v [ (λ x → f x == g x) ↓ p ])
  ↓-='-in {p = idp} α = ,idp=□idp,-out α

  ↓-='-out : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → (u == v [ (λ x → f x == g x) ↓ p ])
    → (u , ap g p =□ ap f p , v)
  ↓-='-out {p = idp} α = ,idp=□idp,-in α

↓-='-β : ∀ {i j} {A : Type i} {B : Type j} {f g : A → B}
  {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
  (α : (u , ap g p =□ ap f p , v))
  → ↓-='-out (↓-='-in α) == α
↓-='-β {p = idp} α = ,idp=□idp,-η α

module _ {i j k} {A : Type i} {B : Type j} (C : Type k) {g h : B → C} (f : A → B) where

  lemma-a : {x y : A} (p : x == y) {u : g (f x) == h (f x)} {v : g (f y) == h (f y)} {q : f x == f y} (r : ap f p == q)
    (α : u == v [ (λ z → g z == h z) ↓ q ])
    → ↓-='-out (↓-ap-out= (λ z → g z == h z) f p r α) == ↓-='-out α ∙□-i/ ap-∘ h f p ∙ ap (ap h) r / ! (ap (ap g) r) ∙ ∘-ap g f p /
  lemma-a idp idp idp = idp

{- Dependent identity type -}

↓-=-in : ∀ {i j} {A : Type i} {B : A → Type j} {f g : Π A B}
  {x y : A} {p : x == y} {u : g x == f x} {v : g y == f y}
  → (u , apd f p =□d-i apd g p , v)
  → (u == v [ (λ x → g x == f x) ↓ p ])
↓-=-in {B = B} {p = idp} {u} {v} α = ,idp=□d-iidp,-out α

↓-=-out : ∀ {i j} {A : Type i} {B : A → Type j} {f g : Π A B}
  {x y : A} {p : x == y} {u : g x == f x} {v : g y == f y}
  → (u == v [ (λ x → g x == f x) ↓ p ])
  → (u , apd f p =□d-i apd g p , v)
↓-=-out {B = B} {p = idp} {u} {v} α = ,idp=□d-iidp,-in α

↓-=□-in : ∀ {i j} {A : Type i} {B : Type j} {f g g' h : A → B}
  {x y : A} {α : x == y} {p : (x : A) → f x == g x} {q : (x : A) → g x == h x}
  {r : (x : A) → f x == g' x} {s : (x : A) → g' x == h x}
  {u : (p x , q x =□ r x , s x)} {v : (p y , q y =□ r y , s y)}
  → (u , ↓-='-out (apd s α) , ↓-='-out (apd r α) =□□ ↓-='-out (apd q α) , ↓-='-out (apd p α) , v)
  → (u == v [ (λ x → (p x , q x =□ r x , s x)) ↓ α ])
↓-=□-in {α = idp} = ch _ _ where

  ch : ∀ {j} {B : Type j} {f g g' h : B} {p : f == g} {q : g == h}
       {r : f == g'} {s : g' == h} (u v : p , q =□ r , s)
       → u , ,idp=□idp,-in idp , ,idp=□idp,-in idp =□□ ,idp=□idp,-in idp , ,idp=□idp,-in idp , v
       → u == v
  ch {p = idp} {s = idp} u v = ,idp=□idp,-out ∘ ch2 u idp idp v   where

    ch2 : ∀ {i} {A : Type i} {a b : A}
          {q q' r r' : a == b}
          (p : q == r) (p' : r == r')
          (s' : q == q') (s : q' == r')
          → (p , idp , ,idp=□idp,-in p' =□□ ,idp=□idp,-in s' , idp , s) → (p , p' =□ s' , s)
    ch2 idp p' s' idp α = ! (,idp=□idp,-β p') ∙ ap ,idp=□idp,-out α ∙ ,idp=□idp,-β s'

-- Dependent path in a type of the form [λ x → x ≡ g (f x)]
module _ {i j} {A : Type i} {B : Type j} (g : B → A) (f : A → B) where
  ↓-idf=∘-in : {x y : A} {p : x == y} {u : x == g (f x)} {v : y == g (f y)}
    → (u , ap g (ap f p) =□ p , v)
    → (u == v [ (λ x → x == g (f x)) ↓ p ])
  ↓-idf=∘-in {p = idp} q = ,idp=□idp,-out q

  ↓-∘=idf-in : {x y : A} {p : x == y} {u : g (f x) == x} {v : g (f y) == y}
    → (u , p =□ ap g (ap f p) , v)
    → (u == v [ (λ x → g (f x) == x) ↓ p ])
  ↓-∘=idf-in {p = idp} q = ,idp=□idp,-out q

module _ {i i' j k} {A : Type i} {A' : Type i'} {B : Type j} {C : Type k}
  (f : B → C) (g : A → B) (h : A' → B) where

  ap-∙∙`∘`∘ : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : c == d)
    → ap f (ap g p ∙ q ∙ ap h r) == ap (f ∘ g) p ∙ ap f q ∙ ap (f ∘ h) r
  ap-∙∙`∘`∘ idp q idp = ap-∙ f q idp

  ap-∙∙!`∘`∘ : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : d == c)
    → ap f (ap g p ∙ q ∙ ap h (! r)) == ap (f ∘ g) p ∙ ap f q ∙ ! (ap (f ∘ h) r)
  ap-∙∙!`∘`∘ idp q idp = ap-∙ f q idp

  ap-∙∙!'`∘`∘ : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : d == c)
    → ap f (ap g p ∙ q ∙ ! (ap h r)) == ap (f ∘ g) p ∙ ap f q ∙ ! (ap (f ∘ h) r)
  ap-∙∙!'`∘`∘ idp q idp = ap-∙ f q idp

  ap-!∙∙`∘`∘ : {a b : A} {c d : A'} (p : b == a) (q : g b == h c) (r : c == d)
    → ap f (ap g (! p) ∙ q ∙ ap h r) == ! (ap (f ∘ g) p) ∙ ap f q ∙ ap (f ∘ h) r
  ap-!∙∙`∘`∘ idp q idp = ap-∙ f q idp

  ap-!'∙∙`∘`∘ : {a b : A} {c d : A'} (p : b == a) (q : g b == h c) (r : c == d)
    → ap f (! (ap g p) ∙ q ∙ ap h r) == ! (ap (f ∘ g) p) ∙ ap f q ∙ ap (f ∘ h) r
  ap-!'∙∙`∘`∘ idp q idp = ap-∙ f q idp

module _ {i i' j k} {A : Type i} {A' : Type i'} {B : Type j} {C : B → Type k}
  (f : Π B C) (g : A → B) (h : A' → B) where

  apd-∙∙`∘`∘ : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : c == d)
    → apd f (ap g p ∙ q ∙ ap h r) == ↓-ap-in _ _ (apd (f ∘ g) p) ∙ᵈ apd f q ∙ᵈ ↓-ap-in _ _ (apd (f ∘ h) r)
  apd-∙∙`∘`∘ idp q idp = ch q  where

    ch : {a b : B} (q : a == b)
         → apd f (q ∙ idp) == idp ∙ᵈ apd f q ∙ᵈ idp
    ch idp = idp

module _ {i i' j k} {A : Type i} {A' : Type i'} {B : Type j} {C : Type k} {f : A → B} {f' : A' → B} {g h : B → C} where

  lemma-b : {x y : A} {z t : A'} {p : x == y} {q : z == t} (r : f y == f' z)
    {a : g (f x) == h (f x)} {b : g (f y) == h (f y)}
    {c : g (f' z) == h (f' z)} {d : g (f' t) == h (f' t)}
    (u : a == b [ (λ x → g (f x) == h (f x)) ↓ p ]) (v : (b , ap h r =□ ap g r , c))
    (w : c == d [ (λ x → g (f' x) == h (f' x)) ↓ q ])
    → ↓-='-out (↓-ap-in _ f u ∙ᵈ ↓-='-in v ∙ᵈ ↓-ap-in _ f' w) == (↓-='-out u ∙□h (v ∙□h ↓-='-out w))  ∙□-i/ ap-∙∙`∘`∘ h f f' p r q / ! (ap-∙∙`∘`∘ g f f' p r q) /
  lemma-b {p = idp} {q = idp} r idp v idp = ch r v  where

    ch : ∀ {a b : B} (r : a == b) {p : g a == h a} {q : g b == h b} (v : (p , ap h r =□ ap g r , q))
         → ↓-='-out (idp ∙ᵈ ↓-='-in v ∙ᵈ idp)
           == (,idp=□idp,-in idp ∙□h (v ∙□h ,idp=□idp,-in idp))
              ∙□-i/ ap-∙ h r idp / ! (ap-∙ g r idp) /
    ch idp v = ch2 (,idp=□idp,-out v) ∙ (,idp=□idp,-η v |in-ctx (λ u → ,idp=□idp,-in idp ∙□h (u ∙□h ,idp=□idp,-in idp)))  where

      ch2 : ∀ {i} {A : Type i} {a b : A} {p q : a == b} (v' : p == q)
            → ,idp=□idp,-in (v' ∙ idp) == ,idp=□idp,-in idp ∙□h (,idp=□idp,-in v' ∙□h ,idp=□idp,-in idp)
      ch2 {p = idp} v' = ch3 v'  where

        ch3 : ∀ {i} {A : Type i} {a : A} {q : a == a} (v' : idp == q)
              → idp,=□idp,-in (v' ∙ idp) == (,idp=□idp,-in idp ∙□h (idp,=□idp,-in v' ∙□h ,idp=□idp,-in idp))
        ch3 idp = idp

module _ {i} {A : Type i} where

  pp-coh : {a b b' c c' d d' e : A}
           {p : a == b}  {q : b == c}   {r : c == d}   {s : e == d}
           {t : b' == a} {u : b' == c'} {v : c' == d'} {w : d' == e}
    → (p , (q ∙ r ∙ (! s)) =□ (! t ∙ u ∙ v) , w) → (u , (v ∙ w ∙ s) =□ (t ∙ p ∙ q) , r)
  pp-coh {p = idp} {q} {idp} {idp} {idp} {idp} {idp} {idp} α = (! α) ∙ (∙-unit-r q)

  pp-coh! : {a b b' c c' d d' e : A}
            {u : b' == c'} {v : c' == d'} {w : d' == e} {s : e == d}
            {t : b' == a}  {p : a == b}   {q : b == c}  {r : c == d}
    → (u , (v ∙ w ∙ s) =□ (t ∙ p ∙ q) , r) → (p , (q ∙ r ∙ (! s)) =□ ((! t) ∙ u ∙ v) , w)
  pp-coh! {u = idp} {idp} {idp} {idp} {idp} {idp} {q} {idp} α = ∙-unit-r q ∙ (! α)

  pp-coh-β : {a b b' c c' d d' e : A}
             {u : b' == c'} {v : c' == d'} {w : d' == e} {s : e == d}
             {t : b' == a}  {p : a == b}   {q : b == c}  {r : c == d}
             (α : (u , (v ∙ w ∙ s) =□ (t ∙ p ∙ q) , r))
             → pp-coh {p = p} {q = q} {r = r} {s = s} {t = t} {u = u} {v = v} {w = w}
               (pp-coh! {u = u} {v = v} {w = w} {s = s} {t = t} {p = p} {q = q} {r = r} α) == α
  pp-coh-β {u = idp} {idp} {idp} {idp} {idp} {idp} {.idp} {idp} idp = idp

  pp-coh!-β : {a b b' c c' d d' e : A}
              {p : a == b}  {q : b == c}   {r : c == d}   {s : e == d}
              {t : b' == a} {u : b' == c'} {v : c' == d'} {w : d' == e}
              (α : (p , (q ∙ r ∙ (! s)) =□ (! t ∙ u ∙ v) , w))
              → pp-coh! {u = u} {v} {w} {s} {t} {p} {q} {r}
                (pp-coh {p = p} {q} {r} {s} {t} {u} {v} {w} α) == α
  pp-coh!-β {p = idp} {idp} {idp} {idp} {idp} {idp} {.idp} {idp} idp = idp

module _ {i j} {A : Type i} {B : Type j} where

  ap-∙∙ : (f : A → B) {x y z t : A} (p : x == y) (q : y == z) (r : z == t) → ap f (p ∙ q ∙ r) == ap f p ∙ ap f q ∙ ap f r
  ap-∙∙ f idp q idp = ap-∙ f q idp

  ap-∙∙! : (f : A → B) {x y z t : A} (p : x == y) (q : y == z) (r : t == z) → ap f (p ∙ q ∙ ! r) == ap f p ∙ ap f q ∙ ! (ap f r)
  ap-∙∙! f idp q idp = ap-∙ f q idp

  ap-!∙∙ : (f : A → B) {x y z t : A} (p : y == x) (q : y == z) (r : z == t) → ap f (! p ∙ q ∙ r) == ! (ap f p) ∙ ap f q ∙ ap f r
  ap-!∙∙ f idp q idp = ap-∙ f q idp

module _ {i j k} {A : Type i} {B : Type j} {C₁ C₂ C₃ C₄ : Type k} {g₁ : C₁ → A} {g₂ : C₂ → A} {g₃ : C₃ → A} {g₄ : C₄ → A} (f : A → B) where

  ap□-pp-coh : {a b b' c c' d d' e : A}
               {p : a == b}  {q : b == c}   {r : c == d}   {s : e == d}
               {t : b' == a} {u : b' == c'} {v : c' == d'} {w : d' == e}
               (α : (p , (q ∙ r ∙ (! s)) =□ (! t ∙ u ∙ v) , w))
               → ap□ f (pp-coh {p = p} {q} {r} {s} {t} {u} {v} {w} α) ==
                 pp-coh {p = ap f p} {ap f q} {ap f r} {ap f s} {ap f t} {ap f u} {ap f v} {ap f w}
                   (ap□ f α ∙□-i/ ! (ap-∙∙! f q r s) / ap-!∙∙ f t u v /)
                 ∙□-i/ ap-∙∙ f v w s / ! (ap-∙∙ f t p q) /
  ap□-pp-coh {p = idp} {q} {idp} {idp} {idp} {idp} {idp} {idp} α = c q idp α  where

    c : {a b : A} (q q' : a == b) (α : q ∙ idp == q')
        → ap (ap f) (! α ∙ ∙-unit-r q) ==
          (! (ap (ap f) α ∙□-i/ ! (ap-∙∙! f q idp idp) / idp /) ∙
          ∙-unit-r (ap f q))
          ∙□-i/ idp / ! (ap-∙∙ f idp idp q) /
    c idp q' α = d α  where

      d : {a b : A} {q q' : a == b} (α : q == q')
          → ap (ap f) (! α ∙ idp) == ! (ap (ap f) α) ∙ idp
      d idp = idp

  ap□-coh : {a₁ b₁ : C₁} {a₂ b₂ : C₂} {a₃ b₃ : C₃} {a₄ b₄ : C₄}
               {p : g₃ b₃ == g₁ a₁} {q : a₁ == b₁}       {r : g₁ b₁ == g₂ b₂} {s : a₂ == b₂}
               {t : a₃ == b₃}       {u : g₃ a₃ == g₄ a₄} {v : a₄ == b₄}       {w : g₄ b₄ == g₂ a₂}
               (α : (p , (ap g₁ q ∙ r ∙ (! (ap g₂ s))) =□ (! (ap g₃ t) ∙ u ∙ ap g₄ v) , w))
               → ap□ f (pp-coh {p = p} {ap g₁ q} {r} {ap g₂ s} {ap g₃ t} {u} {ap g₄ v} {w} α) ==
                 pp-coh {p = ap f p} {ap (f ∘ g₁) q} {ap f r} {ap (f ∘ g₂) s} {ap (f ∘ g₃) t} {ap f u} {ap (f ∘ g₄) v} {ap f w}
                   (ap□ f α ∙□-i/ ! (ap-∙∙!'`∘`∘ f g₁ g₂ q r s) / ap-!'∙∙`∘`∘ f g₃ g₄ t u v /)
                 ∙□-i/ ap-∙∙`∘`∘ f g₄ g₂ v w s / ! (ap-∙∙`∘`∘ f g₃ g₁ t p q) /
  ap□-coh {p = p} {idp} {r} {idp} {idp} {u} {idp} {w} α = ap□-pp-coh {p = p} {idp} {r} {idp} {idp} {u} {idp} {w} α

module _ {i j k} {A : Type i} {B : Type j} {C₁ C₂ C₃ C₄ : Type k} {g₁ : C₁ → A} {g₂ : C₂ → A} {g₃ : C₃ → A} {g₄ : C₄ → A} (f : A → B) where

  ap□-pp-coh! : {a b b' c c' d d' e : A}
               {u : b' == c'} {v : c' == d'} {w : d' == e} {s : e == d}
               {t : b' == a}  {p : a == b}   {q : b == c}  {r : c == d}
               (α : (u , (v ∙ w ∙ s) =□ (t ∙ p ∙ q) , r))
               → ap□ f (pp-coh! {u = u} {v} {w} {s} {t} {p} {q} {r} α) ==
                 pp-coh! {u = ap f u} {ap f v} {ap f w} {ap f s} {ap f t} {ap f p} {ap f q} {ap f r}
                   (ap□ f α ∙□-i/ ! (ap-∙∙ f v w s) / ap-∙∙ f t p q /)
                 ∙□-i/ ap-∙∙! f q r s / ! (ap-!∙∙ f t u v) /
  ap□-pp-coh! {u = idp} {idp} {idp} {idp} {idp} {idp} {.idp} {idp} idp = idp

  ap□-coh! : {a₁ b₁ : C₁} {a₂ b₂ : C₂} {a₃ b₃ : C₃} {a₄ b₄ : C₄}
               {u : g₃ a₃ == g₄ a₄} {v : a₄ == b₄}       {w : g₄ b₄ == g₂ a₂} {s : a₂ == b₂}
               {t : a₃ == b₃}       {p : g₃ b₃ == g₁ a₁} {q : a₁ == b₁}       {r : g₁ b₁ == g₂ b₂}
               (α : (u , (ap g₄ v ∙ w ∙ ap g₂ s) =□ (ap g₃ t ∙ p ∙ ap g₁ q) , r))
               → ap□ f (pp-coh! {u = u} {ap g₄ v} {w} {ap g₂ s} {ap g₃ t} {p} {ap g₁ q} {r} α) ==
                 pp-coh! {u = ap f u} {ap (f ∘ g₄) v} {ap f w} {ap (f ∘ g₂) s} {ap (f ∘ g₃) t} {ap f p} {ap (f ∘ g₁) q} {ap f r}
                   (ap□ f α ∙□-i/ ! (ap-∙∙`∘`∘ f g₄ g₂ v w s) / ap-∙∙`∘`∘ f g₃ g₁ t p q /)
                 ∙□-i/ ap-∙∙!'`∘`∘ f g₁ g₂ q r s / ! (ap-!'∙∙`∘`∘ f g₃ g₄ t u v) /
  ap□-coh! {u = u} {idp} {w} {idp} {idp} {p} {idp} {r} α = ap□-pp-coh! {u = u} {idp} {w} {idp} {idp} {p} {idp} {r} α

module _ {i} {A : Type i} where

  lemma : {a b b' c c' d d' e : A}
          {u u' : b' == c'} {v : c' == d'} {w w' : d' == e} {s : e == d}
          {t : b' == a}  {p p' : a == b}   {q : b == c}  {r r' : c == d}
          (β : u' == u) (γ : w' == w) (δ : p' == p) (ε : r' == r)
          (α : (u , (v ∙ w ∙ s) =□ (t ∙ p ∙ q) , r))
          → pp-coh {p = p'} {q} {r'} {s} {t} {u'} {v} {w'}
             (pp-coh! {u = u} {v} {w} {s} {t} {p} {q} {r} α
              ∙□-o/ δ / ! γ /
              ∙□-i/ ε |in-ctx (λ x → q ∙ x ∙ ! s) / (! β) |in-ctx (λ x → ! t ∙ x ∙ v) /) == α ∙□-o/ β / ! ε / ∙□-i/ γ |in-ctx (λ x → v ∙ x ∙ s) / (! δ) |in-ctx (λ x → t ∙ x ∙ q) /
  lemma {u = u} {v = v} {w = w} {s = s} {t = t} {p = p} {q = q} {r = r} idp idp idp idp α = pp-coh-β {u = u} {v = v} {w = w} {s = s} {t = t} {p = p} {q = q} {r = r} α

  lemma! : {a b b' c c' d d' e : A}
           {p p' : a == b} {q : b == c}      {r r' : c == d} {s : e == d}
           {t : b' == a}   {u u' : b' == c'} {v : c' == d'}  {w w' : d' == e}
           (β : p' == p) (γ : r' == r) (δ : u' == u) (ε : w' == w)
           (α : (p , (q ∙ r ∙ (! s)) =□ (! t ∙ u ∙ v) , w))
           → pp-coh! {u = u'} {v} {w'} {s} {t} {p'} {q} {r'}
               (pp-coh {p = p} {q} {r} {s} {t} {u} {v} {w} α
                ∙□-o/ δ / ! γ /
                ∙□-i/ ε |in-ctx (λ w → v ∙ w ∙ s) / (! β) |in-ctx (λ p → t ∙ p ∙ q) /) == α ∙□-o/ β / ! ε / ∙□-i/ γ |in-ctx (λ r → q ∙ r ∙ ! s) / (! δ) |in-ctx (λ u → ! t ∙ u ∙ v) /
  lemma! {p = p} {q = q} {r = r} {s = s} {t = t} {u = u} {v = v} {w = w} idp idp idp idp α = pp-coh!-β {p = p} {q} {r} {s} {t} {u} {v} {w} α

module _ {i j} {A : Type i} {B : A → Type j} where

  coh1 : {a b : A} {α : a == b} {u v : B a} {w x : B b}
         {p : u == w [ B ↓ α ]} {q : w == x} {r : u == v} {s : v == x [ B ↓ α ]}
         → (r , s =□d-i p , q) → p == s ◃/ r / ! q /
  coh1 {α = idp} {p = idp} {idp} {idp} {s} β = ! β

module _ {i j k} {A : Type i} {B : Type j} {C : Type k} (f g : A → B) (h : B → C) where

  ap↓-↓-='-in-β : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    (α : (u , ap g p =□ ap f p , v))
    → ap↓ (ap h) {p = p} {u = u} {v = v} (↓-='-in {p = p} α)
    == ↓-='-in ((ap□ h α) ∙□-i/ (ap-∘ h g p) / (∘-ap h f p) /)
  ap↓-↓-='-in-β {p = idp} = t  where

    t : {x y : B} {u v : x == y} (α : (u , idp =□ idp , v))
        → ap (ap h) (,idp=□idp,-out α) == ,idp=□idp,-out (ap□ h α)
    t {u = idp} {v} = t'  where

      t' : {x y : B} {u v : x == y} (α : (idp , u =□ idp , v))
         → ap (ap h) (idp,=□idp,-out α) == idp,=□idp,-out (ap□ h α)
      t' {u} {v = idp} α = idp

  ap□-↓-='-out-β : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    (α : u == v [ (λ x → f x == g x) ↓ p ])
    → ap□ h (↓-='-out α) == ↓-='-out (ap↓ (ap h) α) ∙□-i/ ∘-ap h g p / ap-∘ h f p /
  ap□-↓-='-out-β {p = idp} idp = ap□-,idp=□idp,-in h idp

thing : ∀ {i j} {A : Type i} {B : Type j} {f g : A → B}
        {x y : A} {p : x == y} {u u' : f x == g x} {v v' : f y == g y}
        (α : (u , ap g p =□ ap f p , v)) (r : u' == u) (s : v == v')
        → ↓-='-out (↓-='-in α ◃/ r / s /) == α ∙□-o/ r / s /
thing α idp idp = ↓-='-β α

ap↓-∘ : ∀ {i j k l} {A : Type i} {B : A → Type j} {C : A → Type k} {D : A → Type l}
  (f : {a : A} → C a → D a) (g : {a : A} → B a → C a)
  {x y : A} {p : x == y} {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → ap↓ (f ∘ g) q == ap↓ f (ap↓ g q)
ap↓-∘ f g {p = idp} idp = idp

ap↓-◃/ : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  (f : {a : A} → B a → C a) {x y : A} {p : x == y} {u u' : B x} {v v' : B y}
  (q : u == v [ B ↓ p ]) (r : u' == u) (s : v == v')
  → ap↓ f (q ◃/ r / s /) == ap↓ f q ◃/ ap f r / ap f s /
ap↓-◃/ f {p = idp} idp idp idp = idp

ap□-∙□-i/ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a b b' c : A} {p : a == b} {q q' : b == c} {r r' : a == b'} {s : b' == c}
  (α : (p , q =□ r , s)) (t : q' == q) (u : r == r')
  → ap□ f (α ∙□-i/ t / u /) == ap□ f α ∙□-i/ ap (ap f) t / ap (ap f) u /
ap□-∙□-i/ f {p = idp} {s = idp} idp idp idp = idp

ap-∘^3-coh : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
  (h : C → D) (g : B → C) (f : A → B) {a b : A} (p : a == b)
  → ap (ap h) (∘-ap g f p) ∙ ∘-ap h (g ∘ f) p ∙ ap-∘ (h ∘ g) f p == ∘-ap h g (ap f p)
ap-∘^3-coh h g f idp = idp

ap-∘^3-coh' : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
  (h : C → D) (g : B → C) (f : A → B) {a b : A} (p : a == b)
  → ∘-ap (h ∘ g) f p ∙ ap-∘ h (g ∘ f) p ∙ ap (ap h) (ap-∘ g f p) == ap-∘ h g (ap f p)
ap-∘^3-coh' h g f idp = idp

ap-∘-ap-coh : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  (g : B → C) (f : A → B) {a b : A} {p q : a == b} (α : p == q)
  → ap (ap g) (! α |in-ctx (ap f)) ∙ ∘-ap g f p ∙ (α |in-ctx (ap (g ∘ f)))
  == ∘-ap g f q
ap-∘-ap-coh g f idp = ∙-unit-r _

ap-∘-ap-coh' : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  (g : B → C) (f : A → B) {a b : A} {p q : a == b} (α : p == q)
  → (! α |in-ctx (ap (g ∘ f))) ∙ ap-∘ g f p ∙ ap (ap g) (α |in-ctx (ap f))
  == ap-∘ g f q
ap-∘-ap-coh' g f idp = ∙-unit-r _

ap-∘-ap-coh'2 : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  (g : B → C) (f : A → B) {a b : A} {p q : a == b} (α : p == q)
  → (! (α |in-ctx (ap (g ∘ f)))) ∙ ap-∘ g f p ∙ ap (ap g) (α |in-ctx (ap f))
  == ap-∘ g f q
ap-∘-ap-coh'2 g f {p = idp} idp = idp

module _ {i i' j k l} {A : Type i} {A' : Type i'} {B : Type j} {C : Type k} {D : Type l}
  (f2 : C → D) (f1 : B → C) (g : A → B) (h : A' → B) where

  ap-∘-ap-∙∙!`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : d == c)
    → ! (ap-∙∙!'`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p (ap f1 q) r)
      ∙ ap (ap f2) (! (ap-∙∙!`∘`∘ f1 g h p q r))
      ∙ ∘-ap f2 f1 (ap g p ∙ q ∙ ap h (! r))
      ∙ ap-∙∙!`∘`∘ (f2 ∘ f1) g h p q r
      == ((∘-ap f2 f1 q) |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ! (ap (f2 ∘ f1 ∘ h) r)))
  ap-∘-ap-∙∙!`∘`∘-coh idp q idp = coh q  where

    coh : {a b : B} (q : a == b) →
          ! (ap-∙ f2 (ap f1 q) idp)
          ∙ ap (ap f2) (! (ap-∙ f1 q idp))
          ∙ ∘-ap f2 f1 (q ∙ idp)
          ∙ ap-∙ (f2 ∘ f1) q idp
          == ap (λ u → u ∙ idp) (∘-ap f2 f1 q)
    coh idp = idp

  ap-∘-ap-!∙∙`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) (q : g a == h c) (r : c == d)
    → ! (ap-!∙∙`∘`∘ (f2 ∘ f1) g h p q r)
      ∙ ap-∘ f2 f1 (ap g (! p) ∙ q ∙ ap h r)
      ∙ ap (ap f2) (ap-!∙∙`∘`∘ f1 g h p q r)
      ∙ ap-!'∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p (ap f1 q) r
      == ((ap-∘ f2 f1 q) |in-ctx (λ u → ! (ap (f2 ∘ f1 ∘ g) p) ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-!∙∙`∘`∘-coh idp q idp = coh q where

    coh : {a b : B} (q : a == b)
          → ! (ap-∙ (f2 ∘ f1) q idp) ∙ ap-∘ f2 f1 (q ∙ idp) ∙ ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ap (λ u → u ∙ idp) (ap-∘ f2 f1 q)
    coh idp = idp

  ap-∘-ap-∙∙2`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : c == d)
    → ! (ap-∙∙`∘`∘ (f2 ∘ f1) g h p q r)
      ∙ ap-∘ f2 f1 (ap g p ∙ q ∙ ap h r)
      ∙ ap (ap f2) (ap-∙∙`∘`∘ f1 g h p q r)
      ∙ ap-∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p (ap f1 q) r
      == ((ap-∘ f2 f1 q) |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-∙∙2`∘`∘-coh idp q idp = coh q where

    coh : {a b : B} (q : a == b)
          → ! (ap-∙ (f2 ∘ f1) q idp) ∙ ap-∘ f2 f1 (q ∙ idp) ∙ ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ap (λ u → u ∙ idp) (ap-∘ f2 f1 q)
    coh idp = idp

  ap-∘-ap-∙∙3`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) (q : g b == h c) (r : c == d)
    → ! (ap-∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p (ap f1 q) r)
      ∙ ap (ap f2) (! (ap-∙∙`∘`∘ f1 g h p q r))
      ∙ ∘-ap f2 f1 (ap g p ∙ q ∙ ap h r)
      ∙ ap-∙∙`∘`∘ (f2 ∘ f1) g h p q r
      == ((∘-ap f2 f1 q) |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-∙∙3`∘`∘-coh idp q idp = coh q  where

    coh : {a b : B} (q : a == b) →
          ! (ap-∙ f2 (ap f1 q) idp)
          ∙ ap (ap f2) (! (ap-∙ f1 q idp))
          ∙ ∘-ap f2 f1 (q ∙ idp)
          ∙ ap-∙ (f2 ∘ f1) q idp
          == ap (λ u → u ∙ idp) (∘-ap f2 f1 q)
    coh idp = idp

  ap-∘-ap-∙∙4`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} {q' : f1 (g b) == f1 (h c)} (α : ap f1 q == q') (r : c == d)
    → ap-∘ f2 f1 (ap g p ∙ q ∙ ap h r)
      ∙ ap (ap f2) (ap-∙∙`∘`∘ f1 g h p q r)
      ∙ ap (ap f2) (α |in-ctx (λ u → ap (f1 ∘ g) p ∙ u ∙ ap (f1 ∘ h) r))
      ∙ ap-∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
      ==
      ap-∙∙`∘`∘ (f2 ∘ f1) g h p q r
      ∙ (ap-∘ f2 f1 q |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
      ∙ (ap (ap f2) α |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-∙∙4`∘`∘-coh idp {q = q} idp idp = coh q  where

    coh : {a b : B} (q : a == b)
          → ap-∘ f2 f1 (q ∙ idp) ∙ ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ap-∙ (f2 ∘ f1) q idp ∙ ap (λ u → u ∙ idp) (ap-∘ f2 f1 q) ∙ idp
    coh idp = idp

  ap-∘-ap-∙∙5`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) {q : g a == h c} {q' : f1 (g a) == f1 (h c)} (α : ap f1 q == q') (r : c == d)
    → ap-∘ f2 f1 (ap g (! p) ∙ q ∙ ap h r)
      ∙ ap (ap f2) (ap-!∙∙`∘`∘ f1 g h p q r)
      ∙ ap (ap f2) (α |in-ctx (λ u → ! (ap (f1 ∘ g) p) ∙ u ∙ ap (f1 ∘ h) r))
      ∙ ap-!'∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
      ==
      ap-∙∙`∘`∘ (f2 ∘ f1) g h (! p) q r
      ∙ (ap-∘ f2 f1 q |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) (! p) ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
      ∙ (ap (ap f2) α |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) (! p) ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
      ∙ (ap-! (f2 ∘ f1 ∘ g) p |in-ctx (λ u → u ∙ ap f2 q' ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-∙∙5`∘`∘-coh idp {q = q} idp idp = coh q  where

    coh : {a b : B} (q : a == b)
          → ap-∘ f2 f1 (q ∙ idp) ∙ ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ap-∙ (f2 ∘ f1) q idp ∙ ap (λ u → u ∙ idp) (ap-∘ f2 f1 q) ∙ idp
    coh idp = idp

  ap-∘-ap-∙∙`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} {q' : f1 (g b) == f1 (h c)} (α : ap f1 q == q') (r : c == d)
    → ap (ap f2) (ap-∙∙`∘`∘ f1 g h p q r)
      ∙ ap (ap f2) (α |in-ctx (λ u → ap (f1 ∘ g) p ∙ u ∙ ap (f1 ∘ h) r))
      ∙ ap-∙∙`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
      ==
      ∘-ap f2 f1 (ap g p ∙ q ∙ ap h r)
      ∙ ap-∙∙`∘`∘ (f2 ∘ f1) g h p q r
      ∙ (ap-∘ f2 f1 q |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
      ∙ (ap (ap f2) α |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ap (f2 ∘ f1 ∘ h) r))
  ap-∘-ap-∙∙`∘`∘-coh idp {q = q} idp idp = coh q  where

    coh : {a b : B} (q : a == b)
          → ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ∘-ap f2 f1 (q ∙ idp) ∙ ap-∙ (f2 ∘ f1) q idp ∙ ap (λ u → u ∙ idp) (ap-∘ f2 f1 q) ∙ idp
    coh idp = idp

  ap-∘-ap-∙∙!'`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} {q' : f1 (g b) == f1 (h c)} (α : ap f1 q == q') (r : d == c)
    → ap (ap f2) (ap-∙∙!`∘`∘ f1 g h p q r)
      ∙ ap (ap f2) (α |in-ctx (λ u → ap (f1 ∘ g) p ∙ u ∙ ! (ap (f1 ∘ h) r)))
      ∙ ap-∙∙!'`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
      ==
      ∘-ap f2 f1 (ap g p ∙ q ∙ ap h (! r))
      ∙ ap-∙∙!`∘`∘ (f2 ∘ f1) g h p q r
      ∙ (ap-∘ f2 f1 q |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ! (ap (f2 ∘ f1 ∘ h) r)))
      ∙ (ap (ap f2) α |in-ctx (λ u → ap (f2 ∘ f1 ∘ g) p ∙ u ∙ ! (ap (f2 ∘ f1 ∘ h) r)))
  ap-∘-ap-∙∙!'`∘`∘-coh idp {q = q} idp idp = coh q  where

    coh : {a b : B} (q : a == b)
          → ap (ap f2) (ap-∙ f1 q idp) ∙ ap-∙ f2 (ap f1 q) idp
          == ∘-ap f2 f1 (q ∙ idp) ∙ ap-∙ (f2 ∘ f1) q idp ∙ ap (λ u → u ∙ idp) (ap-∘ f2 f1 q) ∙ idp
    coh idp = idp

  ap-∘-ap-∙∙!'2`∘`∘-coh : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} {q' : f1 (g b) == f1 (h c)} (α : ap f1 q == q') (r : d == c)
    → ap (ap f2) (ap-∙∙!`∘`∘ f1 g h p q r)
      ∙ ap (ap f2) (α |in-ctx (λ u → ap (f1 ∘ g) p ∙ u ∙ ! (ap (f1 ∘ h) r)))
      ∙ ap-∙∙!'`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
      ==
      ap (ap f2) (ap-∙∙`∘`∘ f1 g h p q (! r))
      ∙ ap (ap f2) (α |in-ctx (λ u → ap (f1 ∘ g) p ∙ u ∙ ap (f1 ∘ h) (! r)))
      ∙ ap-∙∙!`∘`∘ f2 (f1 ∘ g) (f1 ∘ h) p q' r
  ap-∘-ap-∙∙!'2`∘`∘-coh idp {q = q} idp idp = idp

module _ {i i' j k} {A : Type i} {A' : Type i'} {B : Type j} {C : Type k}
  (f : B → C) (g : A → B) (h : A' → B) where

  ap-!∙∙`∘`∘-coh : {a b : A} {c d : A'} (p : b == a) {q : g b == h c} {q' : f (g b) == f (h c)} (α : ap f q == q') (r : c == d)
    → ap-!∙∙`∘`∘ f g h p q r
      ∙ ap (λ u → ! (ap (f ∘ g) p) ∙ u ∙ ap (f ∘ h) r) α
      ∙ ! (ap-! (f ∘ g) p |in-ctx (λ u → u ∙ q' ∙ ap (f ∘ h) r))
      ==
      ap-∙∙`∘`∘ f g h (! p) q r
      ∙' ap (λ u → ap (f ∘ g) (! p) ∙ u ∙ ap (f ∘ h) r) α
  ap-!∙∙`∘`∘-coh idp {q = q} idp idp = ∙-unit-r (ap-∙ f q idp)

  ap-∙∙!`∘`∘-coh1 : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} {q' : f (g b) == f (h c)} (α : ap f q == q') (r : d == c)
    → ap-∙∙!`∘`∘ f g h p q r
      ∙ ap (λ u → ap (f ∘ g) p ∙ u ∙ ! (ap (f ∘ h) r)) α
      ==
      ap-∙∙`∘`∘ f g h p q (! r)
      ∙ ap (λ u → ap (f ∘ g) p ∙ u ∙ ap (f ∘ h) (! r)) α
      ∙ (ap-! (f ∘ h) r |in-ctx (λ u → ap (f ∘ g) p ∙ q' ∙ u))
  ap-∙∙!`∘`∘-coh1 idp {q = q} idp idp = idp

  ap-∙∙!`∘`∘-coh2 : {a b : A} {c d : A'} (p : a == b) {q : g b == h c} (r : d == c)
      → (ap-! (f ∘ h) r |in-ctx (λ u → ap (f ∘ g) p ∙ ap f q ∙ u))
        ∙ ! (ap-∙∙!`∘`∘ f g h p q r)
        ==
        ! (ap-∙∙`∘`∘ f g h p q (! r))
  ap-∙∙!`∘`∘-coh2 idp {q} idp = idp

ap-∘-coh : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
  (f : C → D) (g : B → C) (h : A → B) {a b : A} (p : a == b) {p' : h a == h b} (α : ap h p == p')
  → ap-∘ f (g ∘ h) p ∙ ap (ap f) (ap-∘ g h p) ∙ ap (ap f) (α |in-ctx (ap g)) ∙ ∘-ap f g p'
    == ap-∘ (f ∘ g) h p ∙ ap (ap (f ∘ g)) α
ap-∘-coh f g h idp idp = idp

ap-∘-coh2 : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
  (f : C → D) (g : B → C) (h : A → B) {a b : A} (p : a == b) {p' : h a == h b} (α : ap h p == p')
  → ap-∘ f (g ∘ h) p ∙ ap (ap f) (ap-∘ g h p) ∙ ap (ap f) (α |in-ctx (ap g))
    == ap-∘ (f ∘ g) h p ∙ ap (ap (f ∘ g)) α ∙ ap-∘ f g p'
ap-∘-coh2 f g h idp idp = idp

∙-|in-ctx : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a b c : A}
  (p : a == b) (q : b == c)
  → (p |in-ctx f) ∙ (q |in-ctx f) == ((p ∙ q) |in-ctx f)
∙-|in-ctx f idp idp = idp

∙□-i/-rewrite : ∀ {i} {A : Type i} {a b b' c : A} {p : a == b} {q q' : b == c}
  {r r' : a == b'} {s : b' == c}
  (α : (p , q =□ r , s)) {β β' : q' == q} (eqβ : β == β') {γ γ' : r == r'}
  (eqγ : γ == γ')
  → (α ∙□-i/ β / γ / == α ∙□-i/ β' / γ' /)
∙□-i/-rewrite α idp idp = idp


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

module Dodo.Unary.Union where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; cong)
open import Level using (Level; _⊔_)
open import Function using (_∘_; _∘₂_)
open import Data.Sum using (_⊎_; inj₁; inj₂; swap)
open import Data.Product using (_,_)
open import Data.Empty using (⊥-elim)
open import Relation.Unary using (Pred)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Unary.Unique
open import Dodo.Unary.Disjoint

-- # Definitions

infixl 30 _∪₁_

_∪₁_ : {a ℓ₁ ℓ₂ : Level} {A : Set a}
  → Pred A ℓ₁
  → Pred A ℓ₂
  → Pred A (ℓ₁ ⊔ ℓ₂)
_∪₁_ p q x = p x ⊎ q x

-- # Properties

module _ {a ℓ : Level} {A : Set a} {R : Pred A ℓ} where

  ∪₁-idem : (R ∪₁ R) ⇔₁ R
  ∪₁-idem = ⇔: ⊆-proof (λ _ → inj₁)
    where
    ⊆-proof : (R ∪₁ R) ⊆₁' R
    ⊆-proof _ (inj₁ Rx) = Rx
    ⊆-proof _ (inj₂ Rx) = Rx

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {Q : Pred A ℓ₂} where

  ∪₁-comm : (P ∪₁ Q) ⇔₁ (Q ∪₁ P)
  ∪₁-comm = ⇔: (λ _ → swap) (λ _ → swap)

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∪₁-assoc : (P ∪₁ Q) ∪₁ R ⇔₁ P ∪₁ (Q ∪₁ R)
  ∪₁-assoc = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : ((P ∪₁ Q) ∪₁ R) ⊆₁' (P ∪₁ (Q ∪₁ R))
    ⊆-proof _ (inj₁ (inj₁ Px)) = inj₁ Px
    ⊆-proof _ (inj₁ (inj₂ Qx)) = inj₂ (inj₁ Qx)
    ⊆-proof _ (inj₂ Rx)        = inj₂ (inj₂ Rx)
    ⊇-proof : (P ∪₁ (Q ∪₁ R)) ⊆₁' ((P ∪₁ Q) ∪₁ R)
    ⊇-proof _ (inj₁ Px)        = inj₁ (inj₁ Px)
    ⊇-proof _ (inj₂ (inj₁ Qx)) = inj₁ (inj₂ Qx)
    ⊇-proof _ (inj₂ (inj₂ Rx)) = inj₂ Rx

-- # Operations

-- ## Operations: General

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {Q : Pred A ℓ₂} where

  ∪₁-unique-pred :
      Disjoint₁ P Q
    → UniquePred P
    → UniquePred Q
    → UniquePred (P ∪₁ Q)
  ∪₁-unique-pred _     uniqueP _       x (inj₁ Px₁) (inj₁ Px₂) = cong inj₁ (uniqueP x Px₁ Px₂)
  ∪₁-unique-pred disPQ _       _       x (inj₁ Px)  (inj₂ Qx)  = ⊥-elim (disPQ x (Px , Qx))
  ∪₁-unique-pred disPQ _       _       x (inj₂ Qx)  (inj₁ Px)  = ⊥-elim (disPQ x (Px , Qx))
  ∪₁-unique-pred _     _       uniqueQ x (inj₂ Qx₁) (inj₂ Qx₂) = cong inj₂ (uniqueQ x Qx₁ Qx₂)

-- ## Operations: ⊆₁

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∪₁-combine-⊆₁ : P ⊆₁ Q → R ⊆₁ Q → (P ∪₁ R) ⊆₁ Q
  ∪₁-combine-⊆₁ (⊆: P⊆Q) (⊆: R⊆Q) = ⊆: lemma
    where
    lemma : (P ∪₁ R) ⊆₁' Q
    lemma x (inj₁ Px) = P⊆Q x Px
    lemma x (inj₂ Rx) = R⊆Q x Rx

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {Q : Pred A ℓ₂} where

  ∪₁-introˡ : P ⊆₁ (Q ∪₁ P)
  ∪₁-introˡ = ⊆: λ{_ → inj₂}

  ∪₁-introʳ : P ⊆₁ (P ∪₁ Q)
  ∪₁-introʳ = ⊆: λ{_ → inj₁}

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∪₁-introˡ-⊆₁ : P ⊆₁ R → P ⊆₁ (Q ∪₁ R)
  ∪₁-introˡ-⊆₁ (⊆: P⊆R) = ⊆: (inj₂ ∘₂ P⊆R)

  ∪₁-introʳ-⊆₁ : P ⊆₁ Q → P ⊆₁ (Q ∪₁ R)
  ∪₁-introʳ-⊆₁ (⊆: P⊆Q) = ⊆: (inj₁ ∘₂ P⊆Q)

  ∪₁-elimˡ-⊆₁ : (P ∪₁ Q) ⊆₁ R → Q ⊆₁ R
  ∪₁-elimˡ-⊆₁ (⊆: [P∪Q]⊆R) = ⊆: (λ x → [P∪Q]⊆R x ∘ inj₂)

  ∪₁-elimʳ-⊆₁ : (P ∪₁ Q) ⊆₁ R → P ⊆₁ R
  ∪₁-elimʳ-⊆₁ (⊆: [P∪Q]⊆R) = ⊆: (λ x → [P∪Q]⊆R x ∘ inj₁)

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∪₁-substˡ-⊆₁ : P ⊆₁ Q → (P ∪₁ R) ⊆₁ (Q ∪₁ R)
  ∪₁-substˡ-⊆₁ (⊆: P⊆Q) = ⊆: lemma
    where
    lemma : (P ∪₁ R) ⊆₁' (Q ∪₁ R)
    lemma x (inj₁ Px) = inj₁ (P⊆Q x Px)
    lemma x (inj₂ Rx) = inj₂ Rx

  ∪₁-substʳ-⊆₁ : P ⊆₁ Q → (R ∪₁ P) ⊆₁ (R ∪₁ Q)
  ∪₁-substʳ-⊆₁ (⊆: P⊆Q) = ⊆: lemma
    where
    lemma : (R ∪₁ P) ⊆₁' (R ∪₁ Q)
    lemma x (inj₁ Rx) = inj₁ Rx
    lemma x (inj₂ Px) = inj₂ (P⊆Q x Px)

-- ## Operations: ⇔₂

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a}
    {P : Pred A ℓ₁} {Q : Pred A ℓ₂} {R : Pred A ℓ₃} where

  ∪₁-substˡ : P ⇔₁ Q → (P ∪₁ R) ⇔₁ (Q ∪₁ R)
  ∪₁-substˡ = ⇔₁-compose ∪₁-substˡ-⊆₁ ∪₁-substˡ-⊆₁

  ∪₁-substʳ : P ⇔₁ Q → (R ∪₁ P) ⇔₁ (R ∪₁ Q)
  ∪₁-substʳ = ⇔₁-compose ∪₁-substʳ-⊆₁ ∪₁-substʳ-⊆₁


------------------------------------------------------------------------
-- The Agda standard library
--
-- Argument visibility used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Argument.Visibility where

open import Data.String as String using (String)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Re-exporting the builtins publically

open import Agda.Builtin.Reflection public using (Visibility)
open Visibility public

------------------------------------------------------------------------
-- Decidable equality

_≟_ : DecidableEquality Visibility
visible   ≟ visible   = yes refl
hidden    ≟ hidden    = yes refl
instance′ ≟ instance′ = yes refl
visible   ≟ hidden    = no λ()
visible   ≟ instance′ = no λ()
hidden    ≟ visible   = no λ()
hidden    ≟ instance′ = no λ()
instance′ ≟ visible   = no λ()
instance′ ≟ hidden    = no λ()


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Reduction {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Universe
open import Definition.LogicalRelation.Properties.Escape

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

-- Weak head expansion of reducible types.
redSubst* : ∀ {A B l Γ}
          → Γ ⊢ A ⇒* B
          → Γ ⊩⟨ l ⟩ B
          → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A)
          → Γ ⊩⟨ l ⟩ A ≡ B / [A]
redSubst* D (Uᵣ′ l′ l< ⊢Γ) rewrite redU* D =
  Uᵣ′ l′ l< ⊢Γ , U₌ PE.refl
redSubst* D (ℕᵣ [ ⊢B , ⊢ℕ , D′ ]) =
  let ⊢A = redFirst* D
  in  ℕᵣ ([ ⊢A , ⊢ℕ , D ⇨* D′ ]) , ιx (ℕ₌ D′)
redSubst* D (ne′ K [ ⊢B , ⊢K , D′ ] neK K≡K) =
  let ⊢A = redFirst* D
  in  (ne′ K [ ⊢A , ⊢K , D ⇨* D′ ] neK K≡K)
  ,  ιx (ne₌ _ [ ⊢B , ⊢K , D′ ] neK K≡K)
redSubst* D (Πᵣ′ F G [ ⊢B , ⊢ΠFG , D′ ] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (Πᵣ′ F G [ ⊢A , ⊢ΠFG , D ⇨* D′ ] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (Π₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* D (emb′ 0<1 x) with redSubst* D x
redSubst* D (emb′ 0<1 x) | y , y₁ = emb′ 0<1 y , ιx y₁

-- Weak head expansion of reducible terms.
redSubst*Term : ∀ {A t u l Γ}
              → Γ ⊢ t ⇒* u ∷ A
              → ([A] : Γ ⊩⟨ l ⟩ A)
              → Γ ⊩⟨ l ⟩ u ∷ A / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A / [A]
redSubst*Term t⇒u (Uᵣ′ .⁰ 0<1 ⊢Γ) (Uₜ A [ ⊢t , ⊢u , d ] typeA A≡A [u]) =
  let [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ redFirst*Term t⇒u , ⊢u , t⇒u ⇨∷* d ]
      q = redSubst* (univ* t⇒u) (univEq (Uᵣ′ ⁰ 0<1 ⊢Γ) (Uₜ A [d] typeA A≡A [u]))
  in Uₜ A [d′] typeA A≡A (proj₁ q)
  ,  Uₜ₌ A A [d′] [d] typeA typeA A≡A (proj₁ q) [u] (proj₂ q)
redSubst*Term t⇒u (ℕᵣ D) (ιx (ℕₜ n [ ⊢u , ⊢n , d ] n≡n prop)) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in ιx (ℕₜ n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] n≡n prop)
  , ιx (ℕₜ₌ n n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] [ ⊢u , ⊢n , d ]
          n≡n (reflNatural-prop prop))
redSubst*Term t⇒u (ne′ K D neK K≡K) (ιx (neₜ k [ ⊢t , ⊢u , d ] (neNfₜ neK₁ ⊢k k≡k))) =
  let A≡K  = subset* (red D)
      [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]
  in ιx (neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k)) , ιx (neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k))
redSubst*Term {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  (Πₜ f [ ⊢t , ⊢u , d ] funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]
  in  Πₜ f [d′] funcF f≡f [f] [f]₁
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f
          (Πₜ f [d′] funcF f≡f [f] [f]₁)
          (Πₜ f [d] funcF f≡f [f] [f]₁)
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))
redSubst*Term t⇒u (emb′ 0<1 x) (ιx [u]) =
  let x = redSubst*Term t⇒u x [u] in
  ιx (proj₁ x) , ιx (proj₂ x)

-- Weak head expansion of reducible types with single reduction step.
redSubst : ∀ {A B l Γ}
         → Γ ⊢ A ⇒ B
         → Γ ⊩⟨ l ⟩ B
         → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A)
         → Γ ⊩⟨ l ⟩ A ≡ B / [A]
redSubst A⇒B [B] = redSubst* (A⇒B ⇨ id (escape [B])) [B]

-- Weak head expansion of reducible terms with single reduction step.
redSubstTerm : ∀ {A t u l Γ}
             → Γ ⊢ t ⇒ u ∷ A
             → ([A] : Γ ⊩⟨ l ⟩ A)
             → Γ ⊩⟨ l ⟩ u ∷ A / [A]
             → Γ ⊩⟨ l ⟩ t ∷ A / [A]
             × Γ ⊩⟨ l ⟩ t ≡ u ∷ A / [A]
redSubstTerm t⇒u [A] [u] = redSubst*Term (t⇒u ⇨ id (escapeTerm [A] [u])) [A] [u]


{-# OPTIONS --without-K --exact-split #-}

module integers where

import rings-with-properties
open rings-with-properties public

--------------------------------------------------------------------------------

{- We give a self-contained proof that ℤ is the initial pointed type with an
   automorphism. -}

-- We first introduce the type of pointed types with an automorphism

UU-Pointed-Type-With-Aut :
  (l : Level) → UU (lsuc l)
UU-Pointed-Type-With-Aut l =
  Σ (UU l) (λ X → X × (X ≃ X))

-- Some trivial bureaucracy for the type of pointed types with an automorphism

type-Pointed-Type-With-Aut :
  {l : Level} → UU-Pointed-Type-With-Aut l → UU l
type-Pointed-Type-With-Aut X = pr1 X

point-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) → type-Pointed-Type-With-Aut X
point-Pointed-Type-With-Aut X = pr1 (pr2 X)

aut-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  type-Pointed-Type-With-Aut X ≃ type-Pointed-Type-With-Aut X
aut-Pointed-Type-With-Aut X = pr2 (pr2 X)

map-aut-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  type-Pointed-Type-With-Aut X → type-Pointed-Type-With-Aut X
map-aut-Pointed-Type-With-Aut X =
  map-equiv (aut-Pointed-Type-With-Aut X)

inv-map-aut-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  type-Pointed-Type-With-Aut X → type-Pointed-Type-With-Aut X
inv-map-aut-Pointed-Type-With-Aut X =
  inv-map-equiv (aut-Pointed-Type-With-Aut X)

issec-inv-map-aut-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  ((map-aut-Pointed-Type-With-Aut X) ∘ (inv-map-aut-Pointed-Type-With-Aut X))
  ~ id
issec-inv-map-aut-Pointed-Type-With-Aut X =
  issec-inv-map-equiv (aut-Pointed-Type-With-Aut X)

isretr-inv-map-aut-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  ((inv-map-aut-Pointed-Type-With-Aut X) ∘ (map-aut-Pointed-Type-With-Aut X))
  ~ id
isretr-inv-map-aut-Pointed-Type-With-Aut X =
  isretr-inv-map-equiv (aut-Pointed-Type-With-Aut X)

-- ℤ is a pointed type with an automorphism

ℤ-Pointed-Type-With-Aut : UU-Pointed-Type-With-Aut lzero
ℤ-Pointed-Type-With-Aut =
  pair ℤ (pair zero-ℤ equiv-succ-ℤ)

-- We introduce the type of morphisms of pointed types with an automorphism

hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} →
  UU-Pointed-Type-With-Aut l1 → UU-Pointed-Type-With-Aut l2 → UU (l1 ⊔ l2)
hom-Pointed-Type-With-Aut {l1} {l2} X Y =
  Σ ( type-Pointed-Type-With-Aut X → type-Pointed-Type-With-Aut Y)
    ( λ f →
      Id (f (point-Pointed-Type-With-Aut X)) (point-Pointed-Type-With-Aut Y)
      ×
      ( ( f ∘ (map-aut-Pointed-Type-With-Aut X)) ~
        ( (map-aut-Pointed-Type-With-Aut Y) ∘ f)))

-- Some trivial bureaucracy about morphisms of pointed types with an
-- automorphism

map-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) → hom-Pointed-Type-With-Aut X Y →
  type-Pointed-Type-With-Aut X → type-Pointed-Type-With-Aut Y
map-hom-Pointed-Type-With-Aut X Y f = pr1 f

preserves-point-map-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (f : hom-Pointed-Type-With-Aut X Y) →
  Id ( map-hom-Pointed-Type-With-Aut X Y f (point-Pointed-Type-With-Aut X))
     ( point-Pointed-Type-With-Aut Y)
preserves-point-map-hom-Pointed-Type-With-Aut X Y f = pr1 (pr2 f)

preserves-aut-map-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (f : hom-Pointed-Type-With-Aut X Y) →
  ( ( map-hom-Pointed-Type-With-Aut X Y f) ∘ (map-aut-Pointed-Type-With-Aut X))
    ~
  ( ( map-aut-Pointed-Type-With-Aut Y) ∘ (map-hom-Pointed-Type-With-Aut X Y f))
preserves-aut-map-hom-Pointed-Type-With-Aut X Y f = pr2 (pr2 f)

-- We characterize the identity type of hom-Pointed-Type-With-Aut

htpy-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h1 h2 : hom-Pointed-Type-With-Aut X Y) →
  UU (l1 ⊔ l2)
htpy-hom-Pointed-Type-With-Aut X Y h1 h2 =
  Σ ( map-hom-Pointed-Type-With-Aut X Y h1
      ~ map-hom-Pointed-Type-With-Aut X Y h2)
    ( λ H →
      ( Id ( preserves-point-map-hom-Pointed-Type-With-Aut X Y h1)
           ( ( H (point-Pointed-Type-With-Aut X)) ∙
             ( preserves-point-map-hom-Pointed-Type-With-Aut X Y h2)))
      ×
      ( ( x : type-Pointed-Type-With-Aut X) →
        ( Id ( ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h1 x) ∙
               ( ap (map-aut-Pointed-Type-With-Aut Y) (H x)))
             ( ( H (map-aut-Pointed-Type-With-Aut X x)) ∙
               ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h2 x)))))

refl-htpy-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h : hom-Pointed-Type-With-Aut X Y) →
  htpy-hom-Pointed-Type-With-Aut X Y h h
refl-htpy-hom-Pointed-Type-With-Aut X Y h =
  pair refl-htpy (pair refl (λ x → right-unit))

htpy-hom-Pointed-Type-With-Aut-eq :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h1 h2 : hom-Pointed-Type-With-Aut X Y) →
  Id h1 h2 → htpy-hom-Pointed-Type-With-Aut X Y h1 h2
htpy-hom-Pointed-Type-With-Aut-eq X Y h1 .h1 refl =
  refl-htpy-hom-Pointed-Type-With-Aut X Y h1

-- This is the meat of the characterization of the type of morphisms of pointed
-- types with an equivalence. The only hard part is feeding the families
-- explicitly to Agda over and over again, because Agda is apparently not that
-- good at figuring out what the correct family is.

is-contr-total-htpy-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h1 : hom-Pointed-Type-With-Aut X Y) →
  is-contr
    ( Σ ( hom-Pointed-Type-With-Aut X Y)
        ( htpy-hom-Pointed-Type-With-Aut X Y h1))
is-contr-total-htpy-hom-Pointed-Type-With-Aut X Y h1 =
  is-contr-total-Eq-structure
    ( λ ( map-h2 : type-Pointed-Type-With-Aut X → type-Pointed-Type-With-Aut Y)
        ( str-h2 : ( Id ( map-h2 (point-Pointed-Type-With-Aut X))
                        ( point-Pointed-Type-With-Aut Y)) ×
                   ( ( x : type-Pointed-Type-With-Aut X) →
                     Id ( map-h2 (map-aut-Pointed-Type-With-Aut X x))
                        ( map-aut-Pointed-Type-With-Aut Y (map-h2 x))))
        ( H : map-hom-Pointed-Type-With-Aut X Y h1 ~ map-h2)
      → ( Id ( preserves-point-map-hom-Pointed-Type-With-Aut X Y h1)
             ( ( H (point-Pointed-Type-With-Aut X)) ∙
               ( pr1 str-h2)))
        ×
        ( ( x : type-Pointed-Type-With-Aut X) →
          ( Id ( ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h1 x) ∙
                 ( ap (map-aut-Pointed-Type-With-Aut Y) (H x)))
               ( ( H (map-aut-Pointed-Type-With-Aut X x)) ∙
                 ( pr2 str-h2 x)))))
    ( is-contr-total-htpy (map-hom-Pointed-Type-With-Aut X Y h1))
    ( pair (map-hom-Pointed-Type-With-Aut X Y h1) refl-htpy)
    ( is-contr-total-Eq-structure
      ( λ ( pt-h2 : Id ( map-hom-Pointed-Type-With-Aut X Y h1
                         ( point-Pointed-Type-With-Aut X))
                       ( point-Pointed-Type-With-Aut Y))
          ( aut-h2 : ( x : type-Pointed-Type-With-Aut X) →
                     Id ( map-hom-Pointed-Type-With-Aut X Y h1
                          ( map-aut-Pointed-Type-With-Aut X x))
                        ( map-aut-Pointed-Type-With-Aut Y
                          ( map-hom-Pointed-Type-With-Aut X Y h1 x)))
          ( α : Id ( preserves-point-map-hom-Pointed-Type-With-Aut X Y h1)
                   ( pt-h2))
        → ( ( x : type-Pointed-Type-With-Aut X) →
            Id ( ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h1 x) ∙
                 ( refl))
               ( aut-h2 x)))
      ( is-contr-total-path
        ( preserves-point-map-hom-Pointed-Type-With-Aut X Y h1))
      ( pair (preserves-point-map-hom-Pointed-Type-With-Aut X Y h1) refl)
      ( is-contr-equiv'
        ( Σ ( ( x : type-Pointed-Type-With-Aut X) →
              Id ( map-hom-Pointed-Type-With-Aut X Y h1
                   ( map-aut-Pointed-Type-With-Aut X x))
                 ( map-aut-Pointed-Type-With-Aut Y
                   ( map-hom-Pointed-Type-With-Aut X Y h1 x)))
            ( λ aut-h2 →
              ( x : type-Pointed-Type-With-Aut X) →
              Id ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h1 x)
                 ( aut-h2 x)))
        ( equiv-tot (equiv-htpy-concat htpy-right-unit))
        ( is-contr-total-htpy
          ( preserves-aut-map-hom-Pointed-Type-With-Aut X Y h1))))

-- We complete the characterization of the identity type of the type of
-- morphisms of types with a point and an automorphism

is-equiv-htpy-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h1 h2 : hom-Pointed-Type-With-Aut X Y) →
  is-equiv (htpy-hom-Pointed-Type-With-Aut-eq X Y h1 h2)
is-equiv-htpy-hom-Pointed-Type-With-Aut X Y h1 =
  fundamental-theorem-id h1
    ( refl-htpy-hom-Pointed-Type-With-Aut X Y h1)
    ( is-contr-total-htpy-hom-Pointed-Type-With-Aut X Y h1)
    ( htpy-hom-Pointed-Type-With-Aut-eq X Y h1)

eq-htpy-hom-Pointed-Type-With-Aut :
  {l1 l2 : Level} (X : UU-Pointed-Type-With-Aut l1)
  (Y : UU-Pointed-Type-With-Aut l2) (h1 h2 : hom-Pointed-Type-With-Aut X Y) →
  htpy-hom-Pointed-Type-With-Aut X Y h1 h2 → Id h1 h2
eq-htpy-hom-Pointed-Type-With-Aut X Y h1 h2 =
  inv-is-equiv (is-equiv-htpy-hom-Pointed-Type-With-Aut X Y h1 h2)

-- We show that from ℤ there is a morphism of pointed types with automorphism
-- to any pointed type with automorphisms

map-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  ℤ → type-Pointed-Type-With-Aut X
map-initial-Pointed-Type-With-Aut X (inl zero-ℕ) =
  inv-map-aut-Pointed-Type-With-Aut X (point-Pointed-Type-With-Aut X)
map-initial-Pointed-Type-With-Aut X (inl (succ-ℕ k)) =
  inv-map-aut-Pointed-Type-With-Aut X
    ( map-initial-Pointed-Type-With-Aut X (inl k))
map-initial-Pointed-Type-With-Aut X (inr (inl star)) =
  point-Pointed-Type-With-Aut X
map-initial-Pointed-Type-With-Aut X (inr (inr zero-ℕ)) =
  map-aut-Pointed-Type-With-Aut X (point-Pointed-Type-With-Aut X)
map-initial-Pointed-Type-With-Aut X (inr (inr (succ-ℕ k))) =
  map-aut-Pointed-Type-With-Aut X
    ( map-initial-Pointed-Type-With-Aut X (inr (inr k)))

preserves-point-map-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  Id ( map-initial-Pointed-Type-With-Aut X zero-ℤ)
     ( point-Pointed-Type-With-Aut X)
preserves-point-map-initial-Pointed-Type-With-Aut X = refl

preserves-aut-map-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) (k : ℤ) →
  Id ( map-initial-Pointed-Type-With-Aut X (succ-ℤ k))
     ( map-aut-Pointed-Type-With-Aut X
       ( map-initial-Pointed-Type-With-Aut X k))
preserves-aut-map-initial-Pointed-Type-With-Aut X (inl zero-ℕ) =
  inv
    ( issec-inv-map-aut-Pointed-Type-With-Aut X (point-Pointed-Type-With-Aut X))
preserves-aut-map-initial-Pointed-Type-With-Aut X (inl (succ-ℕ k)) =
  inv
    ( issec-inv-map-aut-Pointed-Type-With-Aut X
      ( map-initial-Pointed-Type-With-Aut X (inl k)))
preserves-aut-map-initial-Pointed-Type-With-Aut X (inr (inl star)) =
  refl
preserves-aut-map-initial-Pointed-Type-With-Aut X (inr (inr zero-ℕ)) =
  refl
preserves-aut-map-initial-Pointed-Type-With-Aut X (inr (inr (succ-ℕ x))) =
  refl

hom-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X
hom-initial-Pointed-Type-With-Aut X =
  pair
    ( map-initial-Pointed-Type-With-Aut X)
    ( pair
      ( preserves-point-map-initial-Pointed-Type-With-Aut X)
      ( preserves-aut-map-initial-Pointed-Type-With-Aut X))

-- We now show that the morphism from ℤ to a pointed type with an automorphism
-- is unique, using our characterization of the identity type of the type of
-- morphisms of pointed types with an automorphism

htpy-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l)
  (h : hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X) →
  map-initial-Pointed-Type-With-Aut X ~
  map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X h
htpy-initial-Pointed-Type-With-Aut X h (inl zero-ℕ) =
  map-eq-transpose-equiv'
    ( aut-Pointed-Type-With-Aut X)
    ( ( inv
        ( preserves-point-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut
          X h)) ∙
      ( preserves-aut-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut
        X h neg-one-ℤ))
htpy-initial-Pointed-Type-With-Aut X h (inl (succ-ℕ k)) =
  map-eq-transpose-equiv'
    ( aut-Pointed-Type-With-Aut X)
    ( ( htpy-initial-Pointed-Type-With-Aut X h (inl k)) ∙
      ( preserves-aut-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut
        X h (inl (succ-ℕ k))))
htpy-initial-Pointed-Type-With-Aut X h (inr (inl star)) =
  inv
    ( preserves-point-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X h)
htpy-initial-Pointed-Type-With-Aut X h (inr (inr zero-ℕ)) =
  ( ap ( map-aut-Pointed-Type-With-Aut X)
       ( htpy-initial-Pointed-Type-With-Aut X h (inr (inl star)))) ∙
  ( inv
    ( preserves-aut-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut
      X h (inr (inl star))))
htpy-initial-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k))) =
  ( ap ( map-aut-Pointed-Type-With-Aut X)
       ( htpy-initial-Pointed-Type-With-Aut X h (inr (inr k)))) ∙
  ( inv
    ( preserves-aut-map-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut
      X h (inr (inr k))))

-- The following two steps become trivial if X is a set

coh-point-htpy-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l)
  (h : hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X) →
  Id ( preserves-point-map-initial-Pointed-Type-With-Aut X)
     ( ( htpy-initial-Pointed-Type-With-Aut X h zero-ℤ) ∙
       ( preserves-point-map-hom-Pointed-Type-With-Aut
         ℤ-Pointed-Type-With-Aut X h))
coh-point-htpy-initial-Pointed-Type-With-Aut X h =
  inv
    ( left-inv
      ( preserves-point-map-hom-Pointed-Type-With-Aut
        ℤ-Pointed-Type-With-Aut X h))

coh-aut-htpy-initial-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l)
  (h : hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X)
  (k : ℤ) →
  Id ( ( preserves-aut-map-initial-Pointed-Type-With-Aut X k) ∙
       ( ap ( map-aut-Pointed-Type-With-Aut X)
            ( htpy-initial-Pointed-Type-With-Aut X h k)))
     ( ( htpy-initial-Pointed-Type-With-Aut X h (succ-ℤ k)) ∙
       ( preserves-aut-map-hom-Pointed-Type-With-Aut
         ℤ-Pointed-Type-With-Aut X h k))
coh-aut-htpy-initial-Pointed-Type-With-Aut X h (inl zero-ℕ) =
  inv
    ( inv-con
      ( issec-inv-map-equiv
        ( aut-Pointed-Type-With-Aut X)
        ( point-Pointed-Type-With-Aut X))
      ( ( htpy-initial-Pointed-Type-With-Aut X h zero-ℤ) ∙
        ( preserves-aut-map-hom-Pointed-Type-With-Aut
          ℤ-Pointed-Type-With-Aut X h neg-one-ℤ))
      ( ap ( map-equiv (aut-Pointed-Type-With-Aut X))
           ( htpy-initial-Pointed-Type-With-Aut X h neg-one-ℤ))
      ( triangle-eq-transpose-equiv'
        ( aut-Pointed-Type-With-Aut X)
        ( ( inv
            ( preserves-point-map-hom-Pointed-Type-With-Aut
              ℤ-Pointed-Type-With-Aut X h)) ∙
          ( preserves-aut-map-hom-Pointed-Type-With-Aut
            ℤ-Pointed-Type-With-Aut X h neg-one-ℤ))))
coh-aut-htpy-initial-Pointed-Type-With-Aut X h (inl (succ-ℕ k)) =
  inv
    ( inv-con
      ( issec-inv-map-equiv
        ( aut-Pointed-Type-With-Aut X)
        ( map-initial-Pointed-Type-With-Aut X (inl k)))
      ( ( htpy-initial-Pointed-Type-With-Aut X h (inl k)) ∙
        ( preserves-aut-map-hom-Pointed-Type-With-Aut
          ℤ-Pointed-Type-With-Aut X h (inl (succ-ℕ k))))
      ( ap ( map-equiv (aut-Pointed-Type-With-Aut X))
           ( htpy-initial-Pointed-Type-With-Aut X h (inl (succ-ℕ k))))
      ( triangle-eq-transpose-equiv'
        ( aut-Pointed-Type-With-Aut X)
        ( ( htpy-initial-Pointed-Type-With-Aut X h (inl k)) ∙
          ( preserves-aut-map-hom-Pointed-Type-With-Aut
            ℤ-Pointed-Type-With-Aut X h (inl (succ-ℕ k))))))
coh-aut-htpy-initial-Pointed-Type-With-Aut X h (inr (inl star)) =
  ( inv right-unit) ∙
  ( ( ap ( concat
           ( ap
             ( map-aut-Pointed-Type-With-Aut X)
             ( htpy-initial-Pointed-Type-With-Aut X h zero-ℤ))
           ( map-aut-Pointed-Type-With-Aut X
             ( map-hom-Pointed-Type-With-Aut
               ℤ-Pointed-Type-With-Aut X h zero-ℤ)))
         ( inv (left-inv
           ( preserves-aut-map-hom-Pointed-Type-With-Aut
             ℤ-Pointed-Type-With-Aut X h zero-ℤ)))) ∙
    ( inv
      ( assoc
        ( ap
          ( map-aut-Pointed-Type-With-Aut X)
          ( htpy-initial-Pointed-Type-With-Aut X h zero-ℤ))
        ( inv
          ( preserves-aut-map-hom-Pointed-Type-With-Aut
            ℤ-Pointed-Type-With-Aut X h zero-ℤ))
        ( preserves-aut-map-hom-Pointed-Type-With-Aut
          ℤ-Pointed-Type-With-Aut X h zero-ℤ))))
coh-aut-htpy-initial-Pointed-Type-With-Aut X h (inr (inr zero-ℕ)) =
  ( inv right-unit) ∙
  ( ( ap ( concat
           ( ap
             ( map-aut-Pointed-Type-With-Aut X)
             ( htpy-initial-Pointed-Type-With-Aut X h one-ℤ))
           ( map-aut-Pointed-Type-With-Aut X
             ( map-hom-Pointed-Type-With-Aut
               ℤ-Pointed-Type-With-Aut X h one-ℤ)))
         ( inv (left-inv
           ( preserves-aut-map-hom-Pointed-Type-With-Aut
             ℤ-Pointed-Type-With-Aut X h one-ℤ)))) ∙
    ( inv
      ( assoc
        ( ap
          ( map-aut-Pointed-Type-With-Aut X)
          ( htpy-initial-Pointed-Type-With-Aut X h one-ℤ))
        ( inv
          ( preserves-aut-map-hom-Pointed-Type-With-Aut
            ℤ-Pointed-Type-With-Aut X h one-ℤ))
        ( preserves-aut-map-hom-Pointed-Type-With-Aut
          ℤ-Pointed-Type-With-Aut X h one-ℤ))))
coh-aut-htpy-initial-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k))) =
  ( inv right-unit) ∙
  ( ( ap ( concat
           ( ap
             ( map-aut-Pointed-Type-With-Aut X)
             ( htpy-initial-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k)))))
           ( map-aut-Pointed-Type-With-Aut X
             ( map-hom-Pointed-Type-With-Aut
               ℤ-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k))))))
         ( inv (left-inv
           ( preserves-aut-map-hom-Pointed-Type-With-Aut
             ℤ-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k))))))) ∙
    ( inv
      ( assoc
        ( ap
          ( map-aut-Pointed-Type-With-Aut X)
          ( htpy-initial-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k)))))
        ( inv
          ( preserves-aut-map-hom-Pointed-Type-With-Aut
            ℤ-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k)))))
        ( preserves-aut-map-hom-Pointed-Type-With-Aut
          ℤ-Pointed-Type-With-Aut X h (inr (inr (succ-ℕ k)))))))

is-initial-ℤ-Pointed-Type-With-Aut :
  {l : Level} (X : UU-Pointed-Type-With-Aut l) →
  is-contr (hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X)
is-initial-ℤ-Pointed-Type-With-Aut X =
  pair
    ( hom-initial-Pointed-Type-With-Aut X)
    ( λ h →
      eq-htpy-hom-Pointed-Type-With-Aut ℤ-Pointed-Type-With-Aut X
        ( hom-initial-Pointed-Type-With-Aut X)
        ( h)
        ( pair
          ( htpy-initial-Pointed-Type-With-Aut X h)
          ( pair
            ( coh-point-htpy-initial-Pointed-Type-With-Aut X h)
            ( coh-aut-htpy-initial-Pointed-Type-With-Aut X h))))

--------------------------------------------------------------------------------

{- We exhibit ℤ as an abelian group, and as a ring. -}

add-ℤ-Semi-Group : Semi-Group lzero
add-ℤ-Semi-Group = pair ℤ-Set (pair add-ℤ associative-add-ℤ)

is-unital-add-ℤ-Semi-Group : is-unital add-ℤ-Semi-Group
is-unital-add-ℤ-Semi-Group = pair zero-ℤ (pair left-unit-law-add-ℤ right-unit-law-add-ℤ)

add-ℤ-Monoid : Monoid lzero
add-ℤ-Monoid = pair add-ℤ-Semi-Group is-unital-add-ℤ-Semi-Group

has-inverses-add-ℤ-Monoid : is-group' add-ℤ-Semi-Group is-unital-add-ℤ-Semi-Group
has-inverses-add-ℤ-Monoid = pair neg-ℤ (pair left-inverse-law-add-ℤ right-inverse-law-add-ℤ)

is-group-add-ℤ-Semi-Group : is-group add-ℤ-Semi-Group
is-group-add-ℤ-Semi-Group = pair is-unital-add-ℤ-Semi-Group has-inverses-add-ℤ-Monoid

ℤ-Group : Group lzero
ℤ-Group = pair add-ℤ-Semi-Group is-group-add-ℤ-Semi-Group

ℤ-Ab : Ab lzero
ℤ-Ab = pair ℤ-Group commutative-add-ℤ

has-mul-ℤ-Ab : has-mul-Ab ℤ-Ab
has-mul-ℤ-Ab =
  pair
    ( pair mul-ℤ associative-mul-ℤ)
    ( pair
      ( pair one-ℤ (pair left-unit-law-mul-ℤ right-unit-law-mul-ℤ))
      ( pair left-distributive-mul-add-ℤ right-distributive-mul-add-ℤ))

ℤ-Ring : Ring lzero
ℤ-Ring = pair ℤ-Ab has-mul-ℤ-Ab

ℤ-Comm-Ring : Comm-Ring lzero
ℤ-Comm-Ring = pair ℤ-Ring commutative-mul-ℤ

mul-ℤ-Semi-Group : Semi-Group lzero
mul-ℤ-Semi-Group = pair ℤ-Set (pair mul-ℤ associative-mul-ℤ)

mul-ℤ-Monoid : Monoid lzero
mul-ℤ-Monoid =
  pair
    ( mul-ℤ-Semi-Group)
    ( pair one-ℤ (pair left-unit-law-mul-ℤ right-unit-law-mul-ℤ))

--------------------------------------------------------------------------------

{- We characterize the identity type of ℤ. -}

Eq-ℤ : ℤ → ℤ → UU lzero
Eq-ℤ (inl x) (inl y) = Eq-ℕ x y
Eq-ℤ (inl x) (inr y) = empty
Eq-ℤ (inr x) (inl x₁) = empty
Eq-ℤ (inr (inl x)) (inr (inl y)) = unit
Eq-ℤ (inr (inl x)) (inr (inr y)) = empty
Eq-ℤ (inr (inr x)) (inr (inl y)) = empty
Eq-ℤ (inr (inr x)) (inr (inr y)) = Eq-ℕ x y

is-prop-Eq-ℤ :
  (x y : ℤ) → is-prop (Eq-ℤ x y)
is-prop-Eq-ℤ (inl x) (inl y) = is-prop-Eq-ℕ x y
is-prop-Eq-ℤ (inl x) (inr y) = is-prop-empty
is-prop-Eq-ℤ (inr x) (inl x₁) = is-prop-empty
is-prop-Eq-ℤ (inr (inl x)) (inr (inl y)) = is-prop-unit
is-prop-Eq-ℤ (inr (inl x)) (inr (inr y)) = is-prop-empty
is-prop-Eq-ℤ (inr (inr x)) (inr (inl y)) = is-prop-empty
is-prop-Eq-ℤ (inr (inr x)) (inr (inr y)) = is-prop-Eq-ℕ x y

refl-Eq-ℤ :
  (x : ℤ) → Eq-ℤ x x
refl-Eq-ℤ (inl x) = refl-Eq-ℕ x
refl-Eq-ℤ (inr (inl x)) = star
refl-Eq-ℤ (inr (inr x)) = refl-Eq-ℕ x

Eq-ℤ-eq :
  {x y : ℤ} → Id x y → Eq-ℤ x y
Eq-ℤ-eq {x} {.x} refl = refl-Eq-ℤ x

contraction-total-Eq-ℤ :
  (x : ℤ) (y : Σ ℤ (Eq-ℤ x)) → Id (pair x (refl-Eq-ℤ x)) y
contraction-total-Eq-ℤ (inl x) (pair (inl y) e) =
  eq-pair
    ( ap inl (eq-Eq-ℕ x y e))
    ( is-prop'-is-prop
      ( is-prop-Eq-ℕ x y)
      ( tr
        ( Eq-ℤ (inl x))
        ( ap inl (eq-Eq-ℕ x y e))
        ( refl-Eq-ℤ (inl x)))
      ( e))
contraction-total-Eq-ℤ (inr (inl star)) (pair (inr (inl star)) e) =
  eq-pair refl (is-prop'-is-prop is-prop-unit (refl-Eq-ℤ zero-ℤ) e)
contraction-total-Eq-ℤ (inr (inr x)) (pair (inr (inr y)) e) =
  eq-pair
    ( ap (inr ∘ inr) (eq-Eq-ℕ x y e))
    ( is-prop'-is-prop
      ( is-prop-Eq-ℕ x y)
      ( tr
        ( Eq-ℤ (inr (inr x)))
        ( ap (inr ∘ inr) (eq-Eq-ℕ x y e))
        ( refl-Eq-ℤ (inr (inr x))))
      ( e))

is-contr-total-Eq-ℤ :
  (x : ℤ) → is-contr (Σ ℤ (Eq-ℤ x))
is-contr-total-Eq-ℤ x =
  pair (pair x (refl-Eq-ℤ x)) (contraction-total-Eq-ℤ x)

is-equiv-Eq-ℤ-eq :
  (x y : ℤ) → is-equiv (Eq-ℤ-eq {x} {y})
is-equiv-Eq-ℤ-eq x =
  fundamental-theorem-id x
    ( refl-Eq-ℤ x)
    ( is-contr-total-Eq-ℤ x)
    ( λ y → Eq-ℤ-eq {x} {y})

eq-Eq-ℤ :
  {x y : ℤ} → Eq-ℤ x y → Id x y
eq-Eq-ℤ {x} {y} = inv-is-equiv (is-equiv-Eq-ℤ-eq x y)

--------------------------------------------------------------------------------

{- We prove some basic arithmetic properties of the integers. -}

--------------------------------------------------------------------------------

{- We show that addition from the left and from the right are both equivalences.
   We conclude that they are both injective maps. -}

is-emb-add-ℤ :
  (x : ℤ) → is-emb (add-ℤ x)
is-emb-add-ℤ x =
  is-emb-is-equiv (add-ℤ x) (is-equiv-add-ℤ x)

is-injective-add-ℤ :
  (x y z : ℤ) → Id (add-ℤ x y) (add-ℤ x z) → Id y z
is-injective-add-ℤ x y z = inv-is-equiv (is-emb-add-ℤ x y z)

is-emb-add-ℤ' :
  (y : ℤ) → is-emb (add-ℤ' y)
is-emb-add-ℤ' y = is-emb-is-equiv (add-ℤ' y) (is-equiv-add-ℤ' y)

is-injective-add-ℤ' :
  (y x w : ℤ) → Id (add-ℤ x y) (add-ℤ w y) → Id x w
is-injective-add-ℤ' y x w = inv-is-equiv (is-emb-add-ℤ' y x w)

--------------------------------------------------------------------------------

{- We show that multiplication by neg-one-ℤ is an equivalence. -}

is-emb-neg-ℤ : is-emb neg-ℤ
is-emb-neg-ℤ = is-emb-is-equiv neg-ℤ is-equiv-neg-ℤ

is-injective-neg-ℤ :
  (x y : ℤ) → Id (neg-ℤ x) (neg-ℤ y) → Id x y
is-injective-neg-ℤ x y = inv-is-equiv (is-emb-neg-ℤ x y)

--------------------------------------------------------------------------------

{- We show that if x = mul-ℤ x y for some non-zero integer x, then y = 1. -}

--------------------------------------------------------------------------------

{- We show that multiplication by a non-zero integer is an embedding. -}

{-
is-injective-mul-ℤ :
  (x y z : ℤ) → ¬ (Id zero-ℤ x) → Id (mul-ℤ x y) (mul-ℤ x z) → Id y z
is-injective-mul-ℤ (inl zero-ℕ) y z p q = is-injective-neg-ℤ y z q
is-injective-mul-ℤ (inl (succ-ℕ x)) y z p q = {!!}
is-injective-mul-ℤ (inr x) y z p q = {!x!}

neq-zero-mul-ℤ :
  (x y : ℤ) → ¬ (Id zero-ℤ x) → ¬ (Id zero-ℤ y) → ¬ (Id zero-ℤ (mul-ℤ x y))
neq-zero-mul-ℤ x y Hx Hy = {!!}
-}

--------------------------------------------------------------------------------

{- We prove some interchange laws and moves on iterated multiplications. -}

interchange-2-3-mul-ℤ :
  {a b c d : ℤ} →
  Id (mul-ℤ (mul-ℤ a b) (mul-ℤ c d)) (mul-ℤ (mul-ℤ a c) (mul-ℤ b d))
interchange-2-3-mul-ℤ {a} {b} {c} {d} =
  ( associative-mul-ℤ a b (mul-ℤ c d)) ∙
  ( ( ap ( mul-ℤ a)
         ( ( inv (associative-mul-ℤ b c d)) ∙
           ( ( ap (λ t → mul-ℤ t d) (commutative-mul-ℤ b c)) ∙
             ( associative-mul-ℤ c b d)))) ∙
    ( inv (associative-mul-ℤ a c (mul-ℤ b d))))

interchange-1-3-mul-ℤ :
  {a b c d : ℤ} →
  Id (mul-ℤ (mul-ℤ a b) (mul-ℤ c d)) (mul-ℤ (mul-ℤ c b) (mul-ℤ a d))
interchange-1-3-mul-ℤ {a} {b} {c} {d} =
  ( ap (λ t → mul-ℤ t (mul-ℤ c d)) (commutative-mul-ℤ a b)) ∙
  ( ( interchange-2-3-mul-ℤ {b}) ∙
    ( ap (λ t → mul-ℤ t (mul-ℤ a d)) (commutative-mul-ℤ b c)))

move-four-mul-ℤ :
  {a b c d : ℤ} →
  Id (mul-ℤ (mul-ℤ a b) (mul-ℤ c d)) (mul-ℤ (mul-ℤ a d) (mul-ℤ b c))
move-four-mul-ℤ {a} {b} {c} {d} =
   ( associative-mul-ℤ a b (mul-ℤ c d)) ∙
   ( ( ap ( mul-ℤ a)
          ( ( inv (associative-mul-ℤ b c d)) ∙
            ( commutative-mul-ℤ (mul-ℤ b c) d))) ∙
     ( inv (associative-mul-ℤ a d (mul-ℤ b c))))

move-five-mul-ℤ :
  {a b c d : ℤ} →
  Id (mul-ℤ (mul-ℤ a b) (mul-ℤ c d)) (mul-ℤ (mul-ℤ b c) (mul-ℤ a d))
move-five-mul-ℤ {a} {b} {c} {d} =
  ( interchange-2-3-mul-ℤ {a} {b} {c} {d}) ∙
  ( ( ap (λ t → mul-ℤ t (mul-ℤ b d)) (commutative-mul-ℤ a c)) ∙
    ( ( interchange-2-3-mul-ℤ {c}) ∙
      ( ap (λ t → mul-ℤ t (mul-ℤ a d)) (commutative-mul-ℤ c b))))


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

module Hmm where

  -- using the HoTT-Agda library leads to highlighting error (missing metadata)
  -- open import lib.Base
  -- open import lib.types.Nat

  -- using this library does not, yet the code is copied/pasted from HoTT-Agda
  open import Base

  S= : {m n : ℕ} → m == n → S m == S n
  S= idp = idp


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

module Reader where

-- The reader monad (mainly used for nice syntax with idiom brackets)

open import Level

Reader : ∀ {r a} → Set r → Set a → Set (a ⊔ r)
Reader R A = R → A

module _ {r} {R′ : Set r} where
  R : ∀ {a} → Set a → Set (a ⊔ r)
  R = Reader R′

  pure : ∀ {a} {A : Set a} → A → R A
  pure x = λ _ → x
  {-# INLINE pure #-}

  _<*>_ : ∀ {a b} {A : Set a} {B : Set b}
        → R (A → B) → R A → R B
  f <*> g = λ x → f x (g x)
  {-# INLINE _<*>_ #-}

  _>>=_ : ∀ {a b} {A : Set a} {B : Set b}
        → R A → (A → R B) → R B
  f >>= k = λ x → k (f x) x
  {-# INLINE _>>=_ #-}


{-# OPTIONS --without-K #-}
-- Large indices are not allowed --without-K

data Singleton {a} {A : Set a} : A → Set where
  [_] : ∀ x → Singleton x


{- 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.Hash

open import LibraBFT.Abstract.Types

open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Consensus.Types

open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Concrete.Obligations
import LibraBFT.Concrete.Properties.VotesOnce   as VO
import LibraBFT.Concrete.Properties.LockedRound as LR

open import LibraBFT.Yasm.System     ConcSysParms
open import LibraBFT.Yasm.Properties ConcSysParms

-- In this module, we assume that the implementation meets its
-- obligations, and use this assumption to prove that the
-- implementatioon enjoys one of the per-epoch correctness conditions
-- proved in Abstract.Properties.  It can be extended to other
-- properties later.

module LibraBFT.Concrete.Properties (impl-correct : ImplObligations) where
  open ImplObligations impl-correct

  -- For any reachable state,
  module _ {e}(st : SystemState e)(r : ReachableSystemState st)(eid : Fin e) where
   open import LibraBFT.Concrete.System sps-cor
   open PerState st r
   open PerEpoch eid

   import LibraBFT.Abstract.Records 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔) as Abs
   open import LibraBFT.Abstract.RecordChain 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Abstract.System 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Abstract.Properties 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)

   open import LibraBFT.Abstract.Obligations.VotesOnce 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Abstract.Obligations.LockedRound 𝓔 Hash _≟Hash_ (ConcreteVoteEvidence 𝓔)

   validState : ValidSysState ConcSystemState
   validState = record
     { vss-votes-once   = VO.Proof.voo sps-cor vo₁ vo₂ st r eid
     ; vss-locked-round = LR.Proof.lrr sps-cor lr₁ st r eid
     }

   open All-InSys-props (AbsSystemState.InSys ConcSystemState)

   -- commited blocks do not conflict.
   S5 : ∀{q q'}
      → {rc  : RecordChain (Abs.Q q)}  → All-InSys rc
      → {rc' : RecordChain (Abs.Q q')} → All-InSys rc'
      → {b b' : Abs.Block}
      → CommitRule rc  b
      → CommitRule rc' b'
      → NonInjective-≡ Abs.bId ⊎ ((Abs.B b) ∈RC rc' ⊎ (Abs.B b') ∈RC rc)
   S5 = CommitsDoNotConflict ConcSystemState validState


-- It seems as if our fix for singleton records was not good enough;
-- the following code was accepted by Agda 2.2.6.
-- Fixed now.
module Issue245 where

record ⊤ : Set where

postulate
  A : Set
  x : A

record R₁ (P : A → Set) : Set where
  field
    f : P x

record R₂ : Set₁ where
  field
    F : A → Set
    f : R₁ F

record R₃ (R : R₂) : Set where
  field
    f : A

R : R₂
R = record
  { F = λ (x : A) → ⊤
  ; f = record {}
  }

foo : R₃ R → A
foo = R₃.f {_}

-- No unsolved metas at the following locations:
--   /home/nad/research/dtp/lib/Bug.agda:32,13-14


-- Andreas, 2018-09-07 issue #3217 reported by Nisse
--
-- Missing range for cubical error

{-# OPTIONS --cubical #-}

-- {-# OPTIONS -v tc.term.lambda:100 -v tc.term:10 #-}

open import Agda.Builtin.Cubical.Path

data Bool : Set where
  true false : Bool

eq : true ≡ false
eq = λ i → true

-- Expected error
-- Issue3217.agda:15,12-16
-- true != false of type Bool
-- when checking that the expression λ i → true has type true ≡ false


{-# OPTIONS --prop --rewriting #-}

module index where

-- Calf language implementation:
import Calf

-- Case studies:
import Examples


{-# OPTIONS --cubical --safe #-}

module Data.Empty where

open import Data.Empty.Base public


{-# OPTIONS --rewriting --confluence-check #-}

data _==_ {i} {A : Set i} : (x y : A) → Set i where
  refl : {a : A} → a == a

{-# BUILTIN REWRITE _==_ #-}

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

module Test (p : ⊥ == ⊤) where
  abstract
    A : Set
    A = ⊥

    q : A == ⊤
    q = p

    {-# REWRITE q #-}

  f : A
  f = tt

  abstract
    g : ⊥
    g = f
    -- g reduces to tt, which does not have type ⊥.


open import Data.Product using ( _,_ )
open import Relation.Nullary using ( yes ; no )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox.Interp using
  ( Interp ; _,_ ; ⌊_⌋ ; ind ; ind² ; Surjective ; surj ; ind⁻¹ ; surj✓ )
open import Web.Semantic.DL.ABox.Interp.Morphism using ( _≲_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind ; _≋_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox.Interp using ( interp ; _⊨_≈_ ; ≈-refl ; ≈-sym ; ≈-trans ; con ; rol ; con-≈ ; rol-≈ )
open import Web.Semantic.DL.TBox.Interp.Morphism using ( morph ; ≲-image ; ≲-resp-≈ ; ≲-resp-con ; ≲-resp-rol )
open import Web.Semantic.Util using ( _∘_ ; ExclMiddle₁ ; ExclMiddle ; smaller-excl-middle ; id ; □ ; is ; is! ; is✓ )

-- Note that this construction uses excluded middle
-- (for cardinality reasons, to embed a large set in a small set).

module Web.Semantic.DL.ABox.Interp.Meet ( excl-middle₁ : ExclMiddle₁ ) { Σ : Signature } { X : Set } where

-- This constructs the meet of a set of interpretations,
-- which is the greatest lower bound on surjective interpretations

meet : (Interp Σ X → Set) → Interp Σ X
meet Is =
  ( interp X
    (λ x y → □ (is (excl-middle₁ (∀ I → (I ∈ Is) →
      (⌊ I ⌋ ⊨ ind I x ≈ ind I y)))))
    (λ {x} → is! (λ I I∈Is →
      ≈-refl ⌊ I ⌋))
    (λ {x} {y} x≈y → is! (λ I I∈Is →
      ≈-sym ⌊ I ⌋ (is✓ x≈y I I∈Is)))
    (λ {x} {y} {z} x≈y y≈z → is! (λ I I∈Is →
      ≈-trans ⌊ I ⌋ (is✓ x≈y I I∈Is) (is✓ y≈z I I∈Is)))
    (λ c x → □ (is (excl-middle₁ (∀ I → (I ∈ Is) →
      (ind I x ∈ con ⌊ I ⌋ c)))))
    (λ r xy → □ (is (excl-middle₁ (∀ I → (I ∈ Is) →
      ind² I xy ∈ rol ⌊ I ⌋ r))))
    (λ {x} {y} c x∈c x≈y → is! (λ I I∈Is →
      con-≈ ⌊ I ⌋ c (is✓ x∈c I I∈Is) (is✓ x≈y I I∈Is)))
    (λ {w} {x} {y} {z} r w≈x xy∈r y≈z → is! (λ I I∈Is →
      rol-≈ ⌊ I ⌋ r (is✓ w≈x I I∈Is) (is✓ xy∈r I I∈Is) (is✓ y≈z I I∈Is)))
  , id )

-- meets are surjective

meet-surj : ∀ Is → (meet Is ∈ Surjective)
meet-surj Is = surj (λ x → (x , ≈-refl ⌊ meet Is ⌋))

-- meets are lower bounds

meet-lb : ∀ Is I → (I ∈ Is) → (meet Is ≲ I)
meet-lb Is I I∈Is =
  ( morph (ind I)
      (λ x≈y → is✓ x≈y I I∈Is)
      (λ x∈⟦c⟧ → is✓ x∈⟦c⟧ I I∈Is)
      (λ xy∈⟦r⟧ → is✓ xy∈⟦r⟧ I I∈Is)
  , λ x → ≈-refl ⌊ I ⌋ )

-- meets are greatest lower bounds on surjective interpretations

meet-glb : ∀ Is J → (J ∈ Surjective) → (∀ I → (I ∈ Is) → (J ≲ I)) → (J ≲ meet Is)
meet-glb Is J J∈Surj J≲Is =
  ( morph (ind⁻¹ J∈Surj)
      (λ {x} {y} x≈y → is! (λ I I∈Is →
        ≈-trans ⌊ I ⌋ (≈-sym ⌊ I ⌋ (lemma I I∈Is x)) (≈-trans ⌊ I ⌋ (≲-resp-≈ ≲⌊ J≲Is I I∈Is ⌋ x≈y) (lemma I I∈Is y))))
      (λ {c} {x} x∈⟦c⟧ → is! (λ I I∈Is →
        con-≈ ⌊ I ⌋ c (≲-resp-con ≲⌊ J≲Is I I∈Is ⌋ x∈⟦c⟧) (lemma I I∈Is x)))
      (λ {r} {x} {y} xy∈⟦r⟧ → is! (λ I I∈Is →
        rol-≈ ⌊ I ⌋ r (≈-sym ⌊ I ⌋ (lemma I I∈Is x)) (≲-resp-rol ≲⌊ J≲Is I I∈Is ⌋ xy∈⟦r⟧) (lemma I I∈Is y)))
  , λ x → is! (λ I I∈Is →
      ≈-trans ⌊ I ⌋ (≈-sym ⌊ I ⌋ (lemma I I∈Is (ind J x))) (≲-resp-ind (J≲Is I I∈Is) x)) ) where

  lemma : ∀ I I∈Is x → ⌊ I ⌋ ⊨ ≲-image ≲⌊ J≲Is I I∈Is ⌋ x ≈ ind I (ind⁻¹ J∈Surj x)
  lemma I I∈Is x =
    ≈-trans ⌊ I ⌋ (≲-resp-≈ ≲⌊ J≲Is I I∈Is ⌋ (surj✓ J∈Surj x))
      (≲-resp-ind (J≲Is I I∈Is) (ind⁻¹ J∈Surj x))

-- Mediating morphisms for meets are unique

meet-uniq : ∀ Is (I : Interp Σ X) → (I ∈ Is) → (J≲₁I J≲₂I : meet Is ≲ I) → (J≲₁I ≋ J≲₂I)
meet-uniq Is I I∈Is J≲₁I J≲₂I x = ≈-trans ⌊ I ⌋ (≲-resp-ind J≲₁I x) (≈-sym ⌊ I ⌋ (≲-resp-ind J≲₂I x))


open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

@0 A : Set₁
A = Set

macro

  @0 m : Term → TC ⊤
  m B =
    bindTC (quoteTC A) λ A →
    unify A B

B : Set₁
B = m


-- {-# OPTIONS -v tc.term.exlam:100 -v extendedlambda:100 -v int2abs.reifyterm:100 -v tc.with:100 -v tc.mod.apply:100 #-}
module Issue778b (Param : Set) where

open import Issue778M Param

data D : (Nat → Nat) → Set where
  d : D pred → D pred

test : (f : Nat → Nat) → D f → Nat
test .pred (d x) = bla
  where bla : Nat
        bla with x
        ... | (d y) = test pred y


module Lec5 where

open import Lec1Done
open import Lec2Done
open import Lec3Done

data List (X : Set) : Set where -- BUILTIN insists on level polymorphism
  []   : List X
  _,-_ : (x : X)(xs : List X) -> List X
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL [] #-}
{-# BUILTIN CONS _,-_ #-}
{-# COMPILE GHC List = data [] ([] | (:)) #-}

list : {X Y : Set} -> (X -> Y) -> List X -> List Y
list f []         = []
list f (x ,- xs)  = f x ,- list f xs

data Two : Set where ff tt : Two
{-# BUILTIN BOOL Two #-}
{-# BUILTIN FALSE ff #-}
{-# BUILTIN TRUE tt #-}

----------------------------------------------------------------------------
-- chars and strings
----------------------------------------------------------------------------

postulate       -- this means that we just suppose the following things exist...
  Char : Set
  String : Set
{-# BUILTIN CHAR Char #-}
{-# BUILTIN STRING String #-}

primitive       -- these are baked in; they even work!
  primCharEquality    : Char -> Char -> Two
  primStringAppend    : String -> String -> String
  primStringToList    : String -> List Char
  primStringFromList  : List Char -> String

---------------------------------------------------------------------------
-- COLOURS
---------------------------------------------------------------------------

-- We're going to be making displays from coloured text.

data Colour : Set where
  black red green yellow blue magenta cyan white : Colour
{-# COMPILE GHC Colour = data HaskellSetup.Colour (HaskellSetup.Black | HaskellSetup.Red | HaskellSetup.Green | HaskellSetup.Yellow | HaskellSetup.Blue | HaskellSetup.Magenta | HaskellSetup.Cyan | HaskellSetup.White) #-}

record _**_ (S T : Set) : Set where
  constructor _,_
  field
    outl : S
    outr : T
open _**_
{-# COMPILE GHC _**_ = data (,) ((,)) #-}
infixr 4 _**_ _,_

{- Here's the characterization of keys I give you -}
data Direction : Set where up down left right : Direction
data Modifier : Set where normal shift control : Modifier
data Key : Set where
  char       : Char -> Key
  arrow      : Modifier -> Direction -> Key
  enter      : Key
  backspace  : Key
  delete     : Key
  escape     : Key
  tab        : Key
data Event : Set where
  key     : (k : Key) -> Event
  resize  : (w h : Nat) -> Event

{- This type collects the things you're allowed to do with the text window. -}
data Action : Set where
  goRowCol : Nat -> Nat -> Action    -- send the cursor somewhere
  sendText : List Char -> Action     -- send some text
  move     : Direction -> Nat -> Action  -- which way and how much
  fgText   : Colour -> Action
  bgText   : Colour -> Action

{- I wire all of that stuff up to its Haskell counterpart. -}
{-# FOREIGN GHC import qualified ANSIEscapes #-}
{-# FOREIGN GHC import qualified HaskellSetup #-}
{-# COMPILE GHC Direction = data ANSIEscapes.Dir (ANSIEscapes.DU | ANSIEscapes.DD | ANSIEscapes.DL | ANSIEscapes.DR) #-}
{-# COMPILE GHC Modifier = data HaskellSetup.Modifier (HaskellSetup.Normal | HaskellSetup.Shift | HaskellSetup.Control) #-}
{-# COMPILE GHC Key = data HaskellSetup.Key (HaskellSetup.Char | HaskellSetup.Arrow | HaskellSetup.Enter | HaskellSetup.Backspace | HaskellSetup.Delete | HaskellSetup.Escape | HaskellSetup.Tab) #-}
{-# COMPILE GHC Event = data HaskellSetup.Event (HaskellSetup.Key | HaskellSetup.Resize) #-}
{-# COMPILE GHC Action = data HaskellSetup.Action (HaskellSetup.GoRowCol | HaskellSetup.SendText | HaskellSetup.Move | HaskellSetup.FgText | HaskellSetup.BgText) #-}

data ColourChar : Set where
  _-_/_ : (fg : Colour)(c : Char)(bg : Colour) -> ColourChar

-- ... e.g.     green - '*' / black    for a green * on black.

Matrix : Set -> Nat * Nat -> Set
Matrix C (w , h) = Vec (Vec C w) h

Painting : Nat * Nat -> Set
Painting = Matrix ColourChar

vecFoldR : {X Y : Set} -> (X -> Y -> Y) -> Y -> {n : Nat} -> Vec X n -> Y
vecFoldR c n [] = n
vecFoldR c n (x ,- xs) = c x (vecFoldR c n xs)

paintAction : {wh : Nat * Nat} -> Matrix ColourChar wh -> List Action
paintAction = vecFoldR (vecFoldR (\ {(f - c / b) k -> \ as ->
  fgText f ,- bgText b ,- sendText (c ,- []) ,- k as}) id) []

postulate       -- Haskell has a monad for doing IO, which we use at the top level
  IO      : Set -> Set
  return  : {A : Set} -> A -> IO A
  _>>=_   : {A B : Set} -> IO A -> (A -> IO B) -> IO B
infixl 1 _>>=_
{-# BUILTIN IO IO #-}
{-# COMPILE GHC IO = type IO #-}
{-# COMPILE GHC return = (\ _ -> return) #-}
{-# COMPILE GHC _>>=_ = (\ _ _ -> (>>=)) #-}

---------------------------------------------------------------------------
-- APPLICATIONS                                                          --
---------------------------------------------------------------------------

-- Here's a general idea of what it means to be an "application".
-- You need to choose some sort of size-dependent state, then provide these
-- bits and pieces. We need to know how the state is updated according to
-- events, with resizing potentially affecting the state's type. We must
-- be able to paint the state. The state should propose a cursor position.
-- (Keen students may modify this definition to ensure the cursor must be
-- within the bounds of the application.)

record Application (wh : Nat * Nat) : Set where
  coinductive
  field
    handleKey     : Key -> Application wh
    handleResize  : (wh' : Nat * Nat) -> Application wh'
    paintMe       : Painting wh
    cursorMe      : Nat * Nat  -- x,y coords
open Application public

-- Now your turn. Build the appropriate handler to connect these
-- applications with mainAppLoop. Again, work in two stages, first
-- figuring out how to do the right actions, then managing the
-- state properly. (1 mark)

_+L_ : {X : Set} -> List X -> List X -> List X
[] +L ys = ys
(x ,- xs) +L ys = x ,- (xs +L ys)
infixr 3 _+L_

APP : Set
APP = Sg (Nat * Nat) Application

appPaint : APP -> List Action
appPaint (_ , app) =
  goRowCol 0 0 ,- paintAction p
     -- must have composition here, to work around compiler bug
     -- paintAction (paintMatrix p)
     -- segfaults, because p is erased
  +L (goRowCol (snd xy) (fst xy) ,- [])
  where
    p  = paintMe app
    xy = cursorMe app

appHandler : Event -> APP -> APP ** List Action
appHandler (key k) (wh , app) = app' , appPaint app'
  where
    app' : APP
    app' = _ , handleKey app k
appHandler (resize w h) (wh , app) = app' , appPaint app'
  where
    app' : APP
    app' = _ , handleResize app (w , h)

{- This is the bit of code I wrote in Haskell to animate your code. -}
postulate
  mainAppLoop : {S : Set} ->             -- program state
    -- INITIALIZER
    S ->                              -- initial state
    -- EVENT HANDLER
    (Event -> S ->                    -- event and state in
     S ** List Action) ->              -- new state and screen actions out
    -- PUT 'EM TOGETHER AND YOU'VE GOT AN APPLICATION!
    IO One
{-# COMPILE GHC mainAppLoop = (\ _ -> HaskellSetup.mainAppLoop) #-}

appMain : (forall wh -> Application wh) -> IO One
appMain app = mainAppLoop ((0 , 0) , app (0 , 0)) appHandler
  -- will get resized dynamically to size of terminal, first thing

vPure : {n : Nat}{X : Set} -> X -> Vec X n
vPure {zero} x = []
vPure {suc n} x = x ,- vPure x

rectApp : Char -> forall wh -> Application wh
handleKey (rectApp c wh) (char x) = rectApp x wh
handleKey (rectApp c wh) _ = rectApp c wh
handleResize (rectApp c _)  wh = rectApp c wh
paintMe      (rectApp c wh)    = vPure (vPure (green - c / black))
cursorMe     (rectApp c wh)    = wh

main : IO One
main = appMain (rectApp '*')

--  agda --compile --ghc-flag "-lncurses" Lec5.agda


module _ where

module M where

record S : Set₁ where
  open M
  field
    F1 : Set
    F2 : {!!}


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

data Unit : Set where
  unit : Unit

Foo : Unit → Set
Foo unit = Unit

Bar : Unit → Unit → Set
Bar unit = Foo

bar : ∀ x y → Bar x y ≡ Unit
bar unit unit = refl

{-# REWRITE bar #-}

test : ∀ x y → Bar x y
test _ _ = unit

works : ∀ x → Foo x
works x = test unit x