module SubstTheory where

open import Prelude
open import T

-- I originally used postulated extensional equality to reason about
-- identical substitutions. As it turns out, it's actually somewhat
-- cleaner to appeal to a proof that using identically performing subst
-- functions produce the same outputs.

---- (Lots of theory. *Lots*. Too much. Sigh.)

module SubstTheory where

  Ren≡ : ∀ {Γ Γ'}(f g : TRen Γ Γ') → Set
  Ren≡ f g = ∀ {A} x → f {A} x ≡ g {A} x

  -- Some theorems about renamings
  wkeq : ∀{Γ Γ' A} {f g : TRen Γ Γ'} → Ren≡ f g → Ren≡ (wk {A = A} f) (wk g)
  wkeq eq Z = Refl
  wkeq eq (S n) = resp S (eq n)

  -- Prove that applying equal renamings produces equal outputs
  reneq : ∀{Γ Γ' A} {f g : TRen Γ Γ'} → Ren≡ f g → (e : TExp Γ A) → ren f e ≡ ren g e
  reneq eq (var x) = resp var (eq x)
  reneq eq (Λ e) = resp Λ (reneq (wkeq eq) e)
  reneq eq (e₁ $ e₂) = resp2 _$_ (reneq eq e₁) (reneq eq e₂)
  reneq eq zero = Refl
  reneq eq (suc e) = resp suc (reneq eq e)
  reneq eq (rec e e₀ es) = resp3 rec (reneq eq e) (reneq eq e₀) (reneq (wkeq eq) es)

  wkid : ∀{Γ A C} (x : A ∈ C :: Γ) → wk renId x ≡ renId x
  wkid Z = Refl
  wkid (S n) = Refl

  renid : ∀{Γ A} (e : TExp Γ A) → ren renId e ≡ id _ e
  renid (var x) = Refl
  renid (Λ e) = resp Λ (reneq wkid e ≡≡ renid e)
  renid (e₁ $ e₂) = resp2 _$_ (renid e₁) (renid e₂)
  renid zero = Refl
  renid (suc e) = resp suc (renid e)
  renid (rec e e₀ es) = resp3 rec (renid e) (renid e₀)
                        (reneq wkid es ≡≡ renid es)

  wkcomp : ∀ {B Γ Γ'}(f : TRen Γ Γ')(g : TRen B Γ) {C A} (x : A ∈ (C :: B)) →
             wk (renComp f g) x ≡ (wk f o wk g) x
  wkcomp f g Z = Refl
  wkcomp f g (S n) = Refl

  rencomp : ∀ {B Γ Γ'}(f : TRen Γ Γ')(g : TRen B Γ) {A} (e : TExp B A) →
             ren (renComp f g) e ≡ (ren f o ren g) e
  rencomp f g (var x) = Refl
  rencomp f g (Λ e) = resp Λ (reneq (wkcomp f g) e
                              ≡≡ (rencomp (wk f) (wk g) e))
  rencomp f g (e₁ $ e₂) = resp2 _$_ (rencomp f g e₁) (rencomp f g e₂)
  rencomp f g zero = Refl
  rencomp f g (suc e) = resp suc (rencomp f g e)
  rencomp f g (rec e e₀ es) = resp3 rec (rencomp f g e) (rencomp f g e₀)
                              (reneq (wkcomp f g) es
                               ≡≡ (rencomp (wk f) (wk g) es))

  Sub≡ : ∀ {Γ Γ'}(f g : TSubst Γ Γ') → Set
  Sub≡ f g = ∀ {A} x → f {A} x ≡ g {A} x

  lifteq : ∀{Γ Γ' A} {f g : TSubst Γ Γ'} → Sub≡ f g → Sub≡ (liftγ {A = A} f) (liftγ g)
  lifteq eq Z = Refl
  lifteq eq (S n) = resp (λ x → ren S x) (eq n)

  -- Prove that applying equal substs produces equal outputs
  subeq : ∀{Γ Γ' A} {f g : TSubst Γ Γ'} → Sub≡ f g → (e : TExp Γ A) → ssubst f e ≡ ssubst g e
  subeq eq (var x) = eq x
  subeq eq (Λ e) = resp Λ (subeq (lifteq eq) e)
  subeq eq (e₁ $ e₂) = resp2 _$_ (subeq eq e₁) (subeq eq e₂)
  subeq eq zero = Refl
  subeq eq (suc e) = resp suc (subeq eq e)
  subeq eq (rec e e₀ es) = resp3 rec (subeq eq e) (subeq eq e₀) (subeq (lifteq eq) es)

  -- Theorems about renaming and substitution
  renwklift : ∀{K Γ Δ C}(f : TRen Γ Δ)(g : TSubst K Γ){A}(x : A ∈ (C :: K)) →
          (ren (wk f) o (liftγ g)) x ≡ liftγ (ren f o g) x
  renwklift f g Z = Refl
  renwklift f g (S n) = symm (rencomp (wk f) S (g n)) ≡≡ rencomp S f (g n)

  rensub : ∀{B Γ Δ}(f : TRen Γ Δ)(g : TSubst B Γ){A}(e : TExp B A) →
          (ren f o ssubst g) e ≡ ssubst (ren f o g) e
  rensub f g (var x) = Refl
  rensub f g (Λ e) = resp Λ ((rensub (wk f) (liftγ g) e) ≡≡
                             subeq (renwklift f g) e)
  rensub f g (e₁ $ e₂) = resp2 _$_ (rensub f g e₁) (rensub f g e₂)
  rensub f g zero = Refl
  rensub f g (suc e) = resp suc (rensub f g e)
  rensub f g (rec e e₀ es) = resp3 rec (rensub f g e) (rensub f g e₀)
                              ((rensub (wk f) (liftγ g) es) ≡≡
                               subeq (renwklift f g) es)

  liftwk : ∀{K Γ Δ C}(f : TSubst Γ Δ)(g : TRen K Γ){A}(x : A ∈ (C :: K)) →
                     (liftγ f o wk g) x ≡ liftγ (f o g) x
  liftwk f g Z = Refl
  liftwk f g (S n) = Refl

  subren : ∀{B Γ Δ}(f : TSubst Γ Δ)(g : TRen B Γ){A}(e : TExp B A) →
          (ssubst f o ren g) e ≡ ssubst (f o g) e
  subren f g (var x) = Refl
  subren f g (Λ e) = resp Λ ((subren (liftγ f) (wk g) e) ≡≡
                             subeq (liftwk f g) e)
  subren f g (e₁ $ e₂) = resp2 _$_ (subren f g e₁) (subren f g e₂)
  subren f g zero = Refl
  subren f g (suc e) = resp suc (subren f g e)
  subren f g (rec e e₀ es) = resp3 rec (subren f g e) (subren f g e₀)
                             ((subren (liftγ f) (wk g) es) ≡≡
                              subeq (liftwk f g) es)

  -- first monad law, the second holds definitionally
  liftid : ∀{Γ A C} (x : A ∈ C :: Γ) → liftγ emptyγ x ≡ emptyγ x
  liftid Z = Refl
  liftid (S n) = Refl

  subid : ∀{Γ}{A} (e : TExp Γ A) → ssubst emptyγ e ≡ id _ e
  subid (var x) = Refl
  subid (Λ e) = resp Λ (subeq liftid e ≡≡ subid e)
  subid (e₁ $ e₂) = resp2 _$_ (subid e₁) (subid e₂)
  subid zero = Refl
  subid (suc e) = resp suc (subid e)
  subid (rec e e₀ es) = resp3 rec (subid e) (subid e₀)
                        (subeq liftid es ≡≡ subid es)

  -- third monad law
  liftcomp : ∀ {B Γ Γ'}(f : TSubst Γ Γ')(g : TSubst B Γ) {C A} (x : A ∈ (C :: B)) →
             liftγ (subComp f g) x ≡ (ssubst (liftγ f) o liftγ g) x
  liftcomp f g Z = Refl
  liftcomp f g (S n) = rensub S f (g n) ≡≡ symm (subren (liftγ f) S (g n))

  subcomp : ∀{B Γ Γ'}(f : TSubst Γ Γ')(g : TSubst B Γ){A}(t : TExp B A) →
         ssubst (subComp f g) t ≡ (ssubst f o ssubst g) t
  subcomp f g (var x) = Refl
  subcomp f g (Λ e) = resp Λ (subeq (liftcomp f g) e
                              ≡≡ (subcomp (liftγ f) (liftγ g) e))
  subcomp f g (e₁ $ e₂) = resp2 _$_ (subcomp f g e₁) (subcomp f g e₂)
  subcomp f g zero = Refl
  subcomp f g (suc e) = resp suc (subcomp f g e)
  subcomp f g (rec e e₀ es) = resp3 rec (subcomp f g e) (subcomp f g e₀)
                              (subeq (liftcomp f g) es
                               ≡≡ (subcomp (liftγ f) (liftγ g) es))

  -- The lemma about combining substitutions that we are actually
  -- going to need. Being able to prove this lemma was the cause
  -- of most of the grief during this proof.
  combine-subst-noob : ∀ {Γ A C} → (γ : TSubst Γ []) →
                    (e : TExp (A :: Γ) C) →
                    (e' : TCExp A) →
                    ssubst (extendγ γ e') e ≡
                    ssubst (singγ e') (ssubst (liftγ γ) e)
  combine-subst-noob γ e e' = subcomp (singγ e') (liftγ γ) e

  -- A lemma we need to define our relations on substs that respect relns
  extend-nofail-s : ∀{Γ Γ' A B} → (γ : TSubst Γ Γ') → (e : TExp Γ' A) → (n : B ∈ Γ) →
                    γ n ≡ (extendγ γ e) (S n)
  extend-nofail-s γ e n = symm (subren (singγ e) S (γ n) ≡≡ subid (γ n))

  -- A closed subst is the identity
  closed-is-empty-ren : (γ : TRen [] []) → Ren≡ γ renId
  closed-is-empty-ren γ ()
  closed-is-empty : (γ : TSubst [] []) → Sub≡ γ emptyγ
  closed-is-empty γ ()

  -- A substitution made on a closed term is the identity substitution
  closed-ren : ∀{A} → (γ : TRen [] []) → (e : TCExp A) → ren γ e ≡ e
  closed-ren γ e = reneq (closed-is-empty-ren γ) e ≡≡ renid e
  closed-subst : ∀{A} → (γ : TSubst [] []) → (e : TCExp A) → ssubst γ e ≡ e
  closed-subst γ e = subeq (closed-is-empty γ) e ≡≡ subid e

  -- lift of a closed subst, also identity - feel like there is a nicer way to do this
  lift-closed-is-empty : ∀{A} (γ : TSubst [] []) → Sub≡ (liftγ {A = A} γ) emptyγ
  lift-closed-is-empty γ Z = Refl
  lift-closed-is-empty γ (S x) = resp (ren _) (closed-is-empty γ x)
  lift-closed-subst : ∀{A B} → (γ : TSubst [] []) → (e : TExp (B :: []) A) → ssubst (liftγ γ) e ≡ e
  lift-closed-subst γ e = subeq (lift-closed-is-empty γ) e ≡≡ subid e

  compose-subst-noob : ∀{Γ} {C} → (γ : TSubst Γ []) →
                        (e : TExp Γ C) →
                        {A : TTp} → (x : A ∈ C :: Γ) →
                        subComp (singγ (ssubst γ e)) (liftγ γ) x ≡
                        subComp γ (singγ e) x
  compose-subst-noob γ e Z = Refl
  compose-subst-noob γ e (S x) = subren (singγ (ssubst γ e)) (λ y → S y) (γ x) ≡≡ subid (γ x)

  drop-fix : ∀{Γ A} → (γ : TSubst (A :: Γ) []) → Sub≡ γ (subComp (singγ (γ Z)) (liftγ (dropγ γ)))
  drop-fix γ Z = Refl
  drop-fix γ (S x) = symm (subren (singγ (γ Z)) S (γ (S x)) ≡≡ subid (γ (S x)))

open SubstTheory public


------------------------------------------------------------------------
-- Values
------------------------------------------------------------------------

open import Atom

module Values (atoms : χ-atoms) where

open import Equality.Propositional
open import Prelude hiding (const)

open import Chi atoms
open import Deterministic atoms

open χ-atoms atoms

-- Values.

mutual

  infixr 5 _∷_

  data Value : Exp → Type where
    lambda : ∀ x e → Value (lambda x e)
    const  : ∀ c {es} → Values es → Value (const c es)

  data Values : List Exp → Type where
    []  : Values []
    _∷_ : ∀ {e es} → Value e → Values es → Values (e ∷ es)

-- Constructor applications.

data Consts : Type where
  const : Const → List Consts → Consts

mutual

  data Constructor-application : Exp → Type where
    const : ∀ c {es} →
            Constructor-applications es →
            Constructor-application (const c es)

  data Constructor-applications : List Exp → Type where
    []  : Constructor-applications []
    _∷_ : ∀ {e es} →
          Constructor-application e → Constructor-applications es →
          Constructor-applications (e ∷ es)

-- Constructor applications are values.

mutual

  const→value : ∀ {e} → Constructor-application e → Value e
  const→value (const c cs) = const c (consts→values cs)

  consts→values : ∀ {es} → Constructor-applications es → Values es
  consts→values []       = []
  consts→values (c ∷ cs) = const→value c ∷ consts→values cs

-- The second argument of _⇓_ is always a Value.

mutual

  ⇓-Value : ∀ {e v} → e ⇓ v → Value v
  ⇓-Value (apply _ _ p)  = ⇓-Value p
  ⇓-Value (case _ _ _ p) = ⇓-Value p
  ⇓-Value (rec p)        = ⇓-Value p
  ⇓-Value lambda         = lambda _ _
  ⇓-Value (const ps)     = const _ (⇓⋆-Values ps)

  ⇓⋆-Values : ∀ {es vs} → es ⇓⋆ vs → Values vs
  ⇓⋆-Values []       = []
  ⇓⋆-Values (p ∷ ps) = ⇓-Value p ∷ ⇓⋆-Values ps

mutual

  values-compute-to-themselves : ∀ {v} → Value v → v ⇓ v
  values-compute-to-themselves (lambda _ _) = lambda
  values-compute-to-themselves (const _ ps) =
    const (values-compute-to-themselves⋆ ps)

  values-compute-to-themselves⋆ : ∀ {vs} → Values vs → vs ⇓⋆ vs
  values-compute-to-themselves⋆ []       = []
  values-compute-to-themselves⋆ (p ∷ ps) =
    values-compute-to-themselves p ∷ values-compute-to-themselves⋆ ps

values-only-compute-to-themselves :
  ∀ {v₁ v₂} → Value v₁ → v₁ ⇓ v₂ → v₁ ≡ v₂
values-only-compute-to-themselves p q =
  ⇓-deterministic (values-compute-to-themselves p) q

values-only-compute-to-themselves⋆ :
  ∀ {vs₁ vs₂} → Values vs₁ → vs₁ ⇓⋆ vs₂ → vs₁ ≡ vs₂
values-only-compute-to-themselves⋆ ps qs =
  ⇓⋆-deterministic (values-compute-to-themselves⋆ ps) qs


module NF {A : Set} where

open import Relation.Binary.PropositionalEquality

record Sing (a : A) : Set where
  field
    unpack : A
    eq : unpack ≡ a

{-# INLINE Sing.unpack #-}

record NF (v : A) : Set where
  field !! : Sing v

{-# INLINE NF.!! #-}

open NF {{...}}

open import Function.Reasoning

nf : (v : A){{nfv : NF v}} -> A
nf v = Sing.unpack (!! ∶ Sing v)

{-# INLINE nf #-}

nf≡ : {v : A}{{nfv : NF v}} -> nf v ≡ v
nf≡ = Sing.eq !!


{-# OPTIONS --allow-unsolved-metas #-}

module AgdaFeatureNoInstanceFromHidden where

postulate
  A : Set
  R : A → A → Set

Alrighty : A → Set₁
Alrighty l = ∀ {r} → R l r → Set

record Foo (Q : A → Set₁) : Set₁ where field foo : ∀ {x y} → R x y → Q x → Q y

open Foo {{...}}

postulate
  instance theInstance : Foo Alrighty

works1 : ∀ {x y} → R x y → Alrighty x → Alrighty y
works1 r = foo r

works2 : ∀ {x y} → R x y → Alrighty x → Alrighty y
works2 r ax = works1 r ax

works3 : ∀ {x y} → R x y → Alrighty x → Alrighty y
works3 r ax = foo {{theInstance}} r ax

works4 : ∀ {x y} → R x y → Alrighty x → Alrighty y
works4 r ax = foo r (λ {v} → ax {v})

fails : ∀ {x y} → R x y → Alrighty x → Alrighty y
fails r ax = {!foo r ax!}
{-
No instance of type Foo (λ v → R v _r_81 → Set) was found in scope.
when checking that r ax are valid arguments to a function of type
{Q : A → Set₁} {{r = r₁ : Foo Q}} {x y : A} → R x y → Q x → Q y
-}


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.ZariskiLattice.BasicOpens where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Structure
open import Cubical.Functions.FunExtEquiv

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Bool
open import Cubical.Data.Nat renaming ( _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; +-comm to +ℕ-comm ; +-assoc to +ℕ-assoc
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm)
open import Cubical.Data.Sigma.Base
open import Cubical.Data.Sigma.Properties
open import Cubical.Data.FinData
open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary
open import Cubical.Relation.Binary.Poset

open import Cubical.Algebra.Ring
open import Cubical.Algebra.Algebra
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Localisation.Base
open import Cubical.Algebra.CommRing.Localisation.UniversalProperty
open import Cubical.Algebra.CommRing.Localisation.InvertingElements
open import Cubical.Algebra.CommAlgebra.Base
open import Cubical.Algebra.CommAlgebra.Properties
open import Cubical.Algebra.CommAlgebra.Localisation
open import Cubical.Algebra.RingSolver.ReflectionSolving
open import Cubical.Algebra.Semilattice

open import Cubical.HITs.SetQuotients as SQ
open import Cubical.HITs.PropositionalTruncation as PT

open Iso
open BinaryRelation
open isEquivRel

private
  variable
    ℓ ℓ' : Level

module Presheaf (A' : CommRing ℓ) where
 open CommRingStr (snd A') renaming (_·_ to _·r_ ; ·-comm to ·r-comm ; ·Assoc to ·rAssoc
                                                 ; ·Lid to ·rLid ; ·Rid to ·rRid)
 open Exponentiation A'
 open CommRingTheory A'
 open isMultClosedSubset
 open CommAlgebraStr ⦃...⦄
 private
  A = fst A'

  A[1/_] : A → CommAlgebra A' ℓ
  A[1/ x ] = AlgLoc.S⁻¹RAsCommAlg A' ([_ⁿ|n≥0] A' x) (powersFormMultClosedSubset _ _)

  A[1/_]ˣ : (x : A) → ℙ (fst A[1/ x ])
  A[1/ x ]ˣ = (CommAlgebra→CommRing A[1/ x ]) ˣ

 _≼_ : A → A → Type ℓ
 x ≼ y = ∃[ n ∈ ℕ ] Σ[ z ∈ A ] x ^ n ≡ z ·r y -- rad(x) ⊆ rad(y)

-- ≼ is a pre-order:
 Refl≼ : isRefl _≼_
 Refl≼ x = PT.∣ 1 , 1r , ·r-comm _ _ ∣

 Trans≼ : isTrans _≼_
 Trans≼ x y z = map2 Trans≼Σ
  where
  Trans≼Σ : Σ[ n ∈ ℕ ] Σ[ a ∈ A ] x ^ n ≡ a ·r y
          → Σ[ n ∈ ℕ ] Σ[ a ∈ A ] y ^ n ≡ a ·r z
          → Σ[ n ∈ ℕ ] Σ[ a ∈ A ] x ^ n ≡ a ·r z
  Trans≼Σ (n , a , p) (m , b , q) = n ·ℕ m , (a ^ m ·r b) , path
   where
   path : x ^ (n ·ℕ m) ≡ a ^ m ·r b ·r z
   path = x ^ (n ·ℕ m)    ≡⟨ ^-rdist-·ℕ x n m ⟩
          (x ^ n) ^ m     ≡⟨ cong (_^ m) p ⟩
          (a ·r y) ^ m     ≡⟨ ^-ldist-· a y m ⟩
          a ^ m ·r y ^ m   ≡⟨ cong (a ^ m ·r_) q ⟩
          a ^ m ·r (b ·r z) ≡⟨ ·rAssoc _ _ _ ⟩
          a ^ m ·r b ·r z   ∎

 R : A → A → Type ℓ
 R x y = x ≼ y × y ≼ x -- rad(x) ≡ rad(y)

 RequivRel : isEquivRel R
 RequivRel .reflexive x = Refl≼ x , Refl≼ x
 RequivRel .symmetric _ _ Rxy = (Rxy .snd) , (Rxy .fst)
 RequivRel .transitive _ _ _ Rxy Ryz = Trans≼ _ _ _ (Rxy .fst) (Ryz .fst)
                                     , Trans≼ _ _ _  (Ryz .snd) (Rxy .snd)

 RpropValued : isPropValued R
 RpropValued x y = isProp× isPropPropTrunc isPropPropTrunc

 powerIs≽ : (x a : A) → x ∈ ([_ⁿ|n≥0] A' a) → a ≼ x
 powerIs≽ x a = map powerIs≽Σ
  where
  powerIs≽Σ : Σ[ n ∈ ℕ ] (x ≡ a ^ n) → Σ[ n ∈ ℕ ] Σ[ z ∈ A ] (a ^ n ≡ z ·r x)
  powerIs≽Σ (n , p) = n , 1r , sym p ∙ sym (·rLid _)

 module ≼ToLoc (x y : A) where
  private
   instance
    _ = snd A[1/ x ]

  lemma : x ≼ y → y ⋆ 1a ∈ A[1/ x ]ˣ -- y/1 ∈ A[1/x]ˣ
  lemma = PT.rec (A[1/ x ]ˣ (y ⋆ 1a) .snd) lemmaΣ
   where
   path1 : (y z : A) → 1r ·r (y ·r 1r ·r z) ·r 1r ≡ z ·r y
   path1 = solve A'
   path2 : (xn : A) → xn ≡ 1r ·r 1r ·r (1r ·r 1r ·r xn)
   path2 = solve A'

   lemmaΣ : Σ[ n ∈ ℕ ] Σ[ a ∈ A ] x ^ n ≡ a ·r y → y ⋆ 1a ∈ A[1/ x ]ˣ
   lemmaΣ (n , z , p) = [ z , (x ^ n) ,  PT.∣ n , refl ∣ ] -- xⁿ≡zy → y⁻¹ ≡ z/xⁿ
                      , eq/ _ _ ((1r , powersFormMultClosedSubset _ _ .containsOne)
                      , (path1 _ _ ∙∙ sym p ∙∙ path2 _))

 module ≼PowerToLoc (x y : A) (x≼y : x ≼ y) where
  private
   [yⁿ|n≥0] = [_ⁿ|n≥0] A' y
   instance
    _ = snd A[1/ x ]
  lemma : ∀ (s : A) → s ∈ [yⁿ|n≥0] → s ⋆ 1a ∈ A[1/ x ]ˣ
  lemma _ s∈[yⁿ|n≥0] = ≼ToLoc.lemma _ _ (Trans≼ _ y _ x≼y (powerIs≽ _ _ s∈[yⁿ|n≥0]))

 𝓞ᴰ : A / R → CommAlgebra A' ℓ
 𝓞ᴰ = rec→Gpd.fun isGroupoidCommAlgebra (λ a → A[1/ a ]) RCoh LocPathProp
    where
    RCoh : ∀ a b → R a b → A[1/ a ] ≡ A[1/ b ]
    RCoh a b (a≼b , b≼a) = fst (isContrS₁⁻¹R≡S₂⁻¹R (≼PowerToLoc.lemma _ _ b≼a)
                                                   (≼PowerToLoc.lemma _ _ a≼b))
     where
     open AlgLocTwoSubsets A' ([_ⁿ|n≥0] A' a) (powersFormMultClosedSubset _ _)
                              ([_ⁿ|n≥0] A' b) (powersFormMultClosedSubset _ _)

    LocPathProp : ∀ a b → isProp (A[1/ a ] ≡ A[1/ b ])
    LocPathProp a b = isPropS₁⁻¹R≡S₂⁻¹R
     where
     open AlgLocTwoSubsets A' ([_ⁿ|n≥0] A' a) (powersFormMultClosedSubset _ _)
                              ([_ⁿ|n≥0] A' b) (powersFormMultClosedSubset _ _)

 -- The quotient A/R corresponds to the basic opens of the Zariski topology.
 -- Multiplication lifts to the quotient and corresponds to intersection
 -- of basic opens, i.e. we get a meet-semilattice with:
 _∧/_ : A / R → A / R → A / R
 _∧/_ = setQuotSymmBinOp (RequivRel .reflexive) (RequivRel .transitive) _·r_
          (λ a b → subst (λ x → R (a ·r b) x) (·r-comm a b) (RequivRel .reflexive (a ·r b))) ·r-lcoh
  where
  ·r-lcoh-≼ : (x y z : A) → x ≼ y → (x ·r z) ≼ (y ·r z)
  ·r-lcoh-≼ x y z = map ·r-lcoh-≼Σ
   where
   path : (x z a y zn : A) →  x ·r z ·r (a ·r y ·r zn) ≡ x ·r zn ·r a ·r (y ·r z)
   path = solve A'

   ·r-lcoh-≼Σ : Σ[ n ∈ ℕ ] Σ[ a ∈ A ] x ^ n ≡ a ·r y
              → Σ[ n ∈ ℕ ] Σ[ a ∈ A ] (x ·r z) ^ n ≡ a ·r (y ·r z)
   ·r-lcoh-≼Σ  (n , a , p) = suc n , (x ·r z ^ n ·r a) , (cong (x ·r z ·r_) (^-ldist-· _ _ _)
                                                       ∙∙ cong (λ v → x ·r z ·r (v ·r z ^ n)) p
                                                       ∙∙ path _ _ _ _ _)

  ·r-lcoh : (x y z : A) → R x y → R (x ·r z) (y ·r z)
  ·r-lcoh x y z Rxy = ·r-lcoh-≼ x y z (Rxy .fst) , ·r-lcoh-≼ y x z (Rxy .snd)

 BasicOpens : Semilattice ℓ
 BasicOpens = makeSemilattice [ 1r ] _∧/_ squash/
   (elimProp3 (λ _ _ _ → squash/ _ _) λ _ _ _ → cong [_] (·rAssoc _ _ _))
     (elimProp (λ _ → squash/ _ _) λ _ → cong [_] (·rRid _))
       (elimProp (λ _ → squash/ _ _) λ _ → cong [_] (·rLid _))
         (elimProp2 (λ _ _ → squash/ _ _) λ _ _ → cong [_] (·r-comm _ _))
           (elimProp (λ _ → squash/ _ _) λ a → eq/ _ _ -- R a a²
              (∣ 1 , a , ·rRid _ ∣ , ∣ 2 , 1r , cong (a ·r_) (·rRid a) ∙ sym (·rLid _) ∣))

 -- The induced partial order
 open MeetSemilattice BasicOpens renaming (_≤_ to _≼/_ ; IndPoset to BasicOpensAsPoset)

 -- coincides with our ≼
 ≼/CoincidesWith≼ : ∀ (x y : A) → ([ x ] ≼/ [ y ]) ≡ (x ≼ y)
 ≼/CoincidesWith≼ x y = [ x ] ≼/ [ y ] -- ≡⟨ refl ⟩ [ x ·r y ] ≡ [ x ]
                      ≡⟨ isoToPath (isEquivRel→effectiveIso RpropValued RequivRel _ _) ⟩
                        R (x ·r y) x
                      ≡⟨ isoToPath Σ-swap-Iso ⟩
                        R x (x ·r y)
                      ≡⟨ hPropExt (RpropValued _ _) isPropPropTrunc ·To≼ ≼To· ⟩
                        x ≼ y ∎
  where
  x≼xy→x≼yΣ : Σ[ n ∈ ℕ ] Σ[ z ∈ A ] x ^ n ≡ z ·r (x ·r y)
            → Σ[ n ∈ ℕ ] Σ[ z ∈ A ] x ^ n ≡ z ·r y
  x≼xy→x≼yΣ (n , z , p) =  n , (z ·r x) , p ∙ ·rAssoc _ _ _

  ·To≼ : R x (x ·r y) → x ≼ y
  ·To≼ (x≼xy , _) = PT.map x≼xy→x≼yΣ x≼xy

  x≼y→x≼xyΣ : Σ[ n ∈ ℕ ] Σ[ z ∈ A ] x ^ n ≡ z ·r y
            → Σ[ n ∈ ℕ ] Σ[ z ∈ A ] x ^ n ≡ z ·r (x ·r y)
  x≼y→x≼xyΣ (n , z , p) = suc n , z , cong (x ·r_) p ∙ ·-commAssocl _ _ _

  ≼To· : x ≼ y → R x ( x ·r y)
  ≼To· x≼y = PT.map x≼y→x≼xyΣ x≼y , PT.∣ 1 , y , ·rRid _ ∙ ·r-comm _ _ ∣

 open IsPoset
 open PosetStr
 Refl≼/ : isRefl _≼/_
 Refl≼/ = BasicOpensAsPoset .snd .isPoset .is-refl

 Trans≼/ : isTrans _≼/_
 Trans≼/ = BasicOpensAsPoset .snd .isPoset .is-trans

 -- The restrictions:
 ρᴰᴬ : (a b : A) → a ≼ b → isContr (CommAlgebraHom A[1/ b ] A[1/ a ])
 ρᴰᴬ _ b a≼b = A[1/b]HasUniversalProp _ (≼PowerToLoc.lemma _ _ a≼b)
  where
  open AlgLoc A' ([_ⁿ|n≥0] A' b) (powersFormMultClosedSubset _ _)
       renaming (S⁻¹RHasAlgUniversalProp to A[1/b]HasUniversalProp)

 ρᴰᴬId : ∀ (a : A) (r : a ≼ a) → ρᴰᴬ a a r .fst ≡ idAlgHom
 ρᴰᴬId a r = ρᴰᴬ a a r .snd _

 ρᴰᴬComp : ∀ (a b c : A) (l : a ≼ b) (m : b ≼ c)
         → ρᴰᴬ a c (Trans≼ _ _ _ l m) .fst ≡ ρᴰᴬ a b l .fst ∘a ρᴰᴬ b c m .fst
 ρᴰᴬComp a _ c l m = ρᴰᴬ a c (Trans≼ _ _ _ l m) .snd _

 ρᴰ : (x y : A / R) → x ≼/ y → CommAlgebraHom (𝓞ᴰ y) (𝓞ᴰ x)
 ρᴰ = elimContr2 λ _ _ → isContrΠ
                 λ [a]≼/[b] → ρᴰᴬ _ _ (transport (≼/CoincidesWith≼ _ _) [a]≼/[b])

 ρᴰId : ∀ (x : A / R) (r : x ≼/ x) → ρᴰ x x r ≡ idAlgHom
 ρᴰId = SQ.elimProp (λ _ → isPropΠ (λ _ → isSetAlgebraHom _ _ _ _))
                     λ a r → ρᴰᴬId  a (transport (≼/CoincidesWith≼ _ _) r)

 ρᴰComp : ∀ (x y z : A / R) (l : x ≼/ y) (m : y ≼/ z)
        → ρᴰ x z (Trans≼/ _ _ _ l m) ≡ ρᴰ x y l ∘a ρᴰ y z m
 ρᴰComp = SQ.elimProp3 (λ _ _ _ → isPropΠ2 (λ _ _ → isSetAlgebraHom _ _ _ _))
                        λ a b c _ _ → sym (ρᴰᴬ a c _ .snd _) ∙ ρᴰᴬComp a b c _ _


-- Hilbert-style formalisation of closed syntax.
-- Nested terms.

module OldBasicILP.UntypedSyntax.ClosedHilbert where

open import OldBasicILP.UntypedSyntax.Common public

-- Closed, untyped representations.

data Rep : Set where
  APP   : Rep → Rep → Rep
  CI    : Rep
  CK    : Rep
  CS    : Rep
  BOX   : Rep → Rep
  CDIST : Rep
  CUP   : Rep
  CDOWN : Rep
  CPAIR : Rep
  CFST  : Rep
  CSND  : Rep
  UNIT  : Rep

-- Anti-bug wrappers.

record Proof : Set where
  constructor [_]
  field
    rep : Rep

open ClosedSyntax (Proof) public

-- Derivations using representations in types.

mutual
  infix 3 ⊢_
  data ⊢_ : Ty → Set where
    app   : ∀ {A B}   → ⊢ A ▻ B → ⊢ A → ⊢ B
    ci    : ∀ {A}     → ⊢ A ▻ A
    ck    : ∀ {A B}   → ⊢ A ▻ B ▻ A
    cs    : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C

    box   : ∀ {A}     → (d : ⊢ A)
                      → ⊢ [ ᴿ⌊ d ⌋ ] ⦂ A

    cdist : ∀ {A B}   → {r₁ r₂ : Rep}
                      → ⊢ [ r₁ ] ⦂ (A ▻ B) ▻ [ r₂ ] ⦂ A ▻ [ APP r₁ r₂ ] ⦂ B

    cup   : ∀ {A}     → {r : Rep}
                      → ⊢ [ r ] ⦂ A ▻ [ BOX r ] ⦂ [ r ] ⦂ A

    cdown : ∀ {A}     → {r : Rep}
                      → ⊢ [ r ] ⦂ A ▻ A

    cpair : ∀ {A B}   → ⊢ A ▻ B ▻ A ∧ B
    cfst  : ∀ {A B}   → ⊢ A ∧ B ▻ A
    csnd  : ∀ {A B}   → ⊢ A ∧ B ▻ B
    unit  : ⊢ ⊤

  -- Projection from derivations to representations.

  ᴿ⌊_⌋ : ∀ {A} → ⊢ A → Rep
  ᴿ⌊ app d₁ d₂ ⌋ = APP ᴿ⌊ d₁ ⌋ ᴿ⌊ d₂ ⌋
  ᴿ⌊ ci ⌋        = CI
  ᴿ⌊ ck ⌋        = CK
  ᴿ⌊ cs ⌋        = CS
  ᴿ⌊ box d ⌋     = BOX ᴿ⌊ d ⌋
  ᴿ⌊ cdist ⌋     = CDIST
  ᴿ⌊ cup ⌋       = CUP
  ᴿ⌊ cdown ⌋     = CDOWN
  ᴿ⌊ cpair ⌋     = CPAIR
  ᴿ⌊ cfst ⌋      = CFST
  ᴿ⌊ csnd ⌋      = CSND
  ᴿ⌊ unit ⌋      = UNIT

infix 3 ⊢⋆_
⊢⋆_ : Cx Ty → Set
⊢⋆ ∅     = 𝟙
⊢⋆ Ξ , A = ⊢⋆ Ξ × ⊢ A

-- Cut and multicut.

cut : ∀ {A B} → ⊢ A → ⊢ A ▻ B → ⊢ B
cut d₁ d₂ = app d₂ d₁

multicut : ∀ {Ξ A} → ⊢⋆ Ξ → ⊢ Ξ ▻⋯▻ A → ⊢ A
multicut {∅}     ∙         d₂ = d₂
multicut {Ξ , B} (ds , d₁) d₂ = app (multicut ds d₂) d₁

-- Contraction.

ccont : ∀ {A B} → ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = app (app cs cs) (app ck ci)

cont : ∀ {A B} → ⊢ A ▻ A ▻ B → ⊢ A ▻ B
cont d = app ccont d

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = app (app cs (app (app cs (app ck cs))
                         (app (app cs (app ck ck)) cs)))
            (app ck ck)

exch : ∀ {A B C} → ⊢ A ▻ B ▻ C → ⊢ B ▻ A ▻ C
exch d = app cexch d

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C} → ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = app (app cs (app ck cs)) ck

comp : ∀ {A B C} → ⊢ B ▻ C → ⊢ A ▻ B → ⊢ A ▻ C
comp d₁ d₂ = app (app ccomp d₁) d₂

-- Useful theorems in functional form.

dist : ∀ {A B r₁ r₂} → ⊢ [ r₁ ] ⦂ (A ▻ B) → ⊢ [ r₂ ] ⦂ A → ⊢ [ APP r₁ r₂ ] ⦂ B
dist d₁ d₂ = app (app cdist d₁) d₂

up : ∀ {A r} → ⊢ [ r ] ⦂ A → ⊢ [ BOX r ] ⦂ [ r ] ⦂ A
up d = app cup d

down : ∀ {A r} → ⊢ [ r ] ⦂ A → ⊢ A
down d = app cdown d

distup : ∀ {A B r₀ r₁} → ⊢ [ r₁ ] ⦂ ([ r₀ ] ⦂ A ▻ B) → ⊢ [ r₀ ] ⦂ A → ⊢ [ APP r₁ (BOX r₀) ] ⦂ B
distup d₁ d₂ = dist d₁ (up d₂)

pair : ∀ {A B} → ⊢ A → ⊢ B → ⊢ A ∧ B
pair d₁ d₂ = app (app cpair d₁) d₂

fst : ∀ {A B} → ⊢ A ∧ B → ⊢ A
fst d = app cfst d

snd : ∀ {A B} → ⊢ A ∧ B → ⊢ B
snd d = app csnd d


open import Type
open import Logic.Classical as Logic using (Classical)
open import Logic.Predicate as Logic using ()

module Formalization.ClassicalPropositionalLogic.SequentCalculus ⦃ classical : ∀{ℓ} → Logic.∀ₗ(Classical{ℓ}) ⦄ where

import      Lvl
open import Data
open import Data.Boolean
import      Data.Boolean.Operators
open import Data.Boolean.Stmt
open import Data.Either as Either using (_‖_ ; Left ; Right)
open import Data.List
open import Data.List.Functions using () renaming (singleton to · ; _++_ to _∪_)
open import Data.List.Relation.Permutation
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
private module BoolOp = Data.Boolean.Operators.Logic
open import Functional as Fn
open import Function.Names using (_⊜_)
open import Logic
open import Logic.Propositional as Logic using (_←_)
open import Logic.Propositional.Theorems as Logic using ()
open import Logic.Predicate.Theorems as Logic using ()
open import Relator.Equals renaming (_≡_ to _≡ₑ_)
open import Relator.Equals.Proofs
open import Relator.Equals.Proofs.Equiv
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Type
open import Syntax.Implication hiding (_⇒_)
open import Type.Size.Countable

private variable ℓₚ ℓ ℓ₁ ℓ₂ : Lvl.Level

open import Formalization.ClassicalPropositionalLogic.Syntax
open import Formalization.ClassicalPropositionalLogic.Syntax.Proofs
open import Formalization.ClassicalPropositionalLogic.Semantics
open import Formalization.ClassicalPropositionalLogic.Semantics.Proofs
import      Formalization.ClassicalPropositionalLogic.TruthTable as TruthTable

_∪·_ : ∀{T : Type{ℓ}} → List(T) → T → List(T)
_∪·_ = Fn.swap(_⊰_)
infixl 1000 _∪·_

module _ {ℓₚ} {P : Type{ℓₚ}} where
  private variable Γ Γ₁ Γ₂ Γ₃ Δ Δ₁ Δ₂ Δ₃ : List(Formula(P))
  private variable φ φ₁ φ₂ ψ A B C : Formula(P)
  private variable p : P

  data _⇒_ : List(Formula(P)) → List(Formula(P)) → Stmt{Lvl.𝐒(ℓₚ)} where
    axiom : ((·(• p)) ⇒ (·(• p)))

    weakenₗ : (Γ ⇒ Δ) → ((Γ ∪· A) ⇒ Δ)
    permuteₗ : .(Γ₁ permutes Γ₂) → (Γ₁ ⇒ Δ) → (Γ₂ ⇒ Δ)
    contractₗ : ((Γ ∪· A ∪· A) ⇒ Δ) → ((Γ ∪· A) ⇒ Δ)
    ⊥ₗ : (Γ ∪· ⊥) ⇒ ∅
    ∧ₗₗ : ((Γ ∪· A) ⇒ Δ) → ((Γ ∪· (A ∧ B)) ⇒ Δ)
    ∧ₗᵣ : ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ∧ B)) ⇒ Δ)
    ∨ₗ : ((Γ ∪· A) ⇒ Δ) → ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ∨ B)) ⇒ Δ)
    ⟶ₗ : (Γ ⇒ (Δ ∪· A)) → ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ⟶ B)) ⇒ Δ)
    ¬ₗ : (Γ ⇒ (Δ ∪· A)) → ((Γ ∪· (¬ A)) ⇒ Δ)

    weakenᵣ : (Γ ⇒ Δ) → (Γ ⇒ (Δ ∪· A))
    permuteᵣ : .(Δ₁ permutes Δ₂) → (Γ ⇒ Δ₁) → (Γ ⇒ Δ₂)
    contractᵣ : (Γ ⇒ (Δ ∪· A ∪· A)) → (Γ ⇒ (Δ ∪· A))
    ⊤ᵣ : ∅ ⇒ (Δ ∪· ⊤)
    ∧ᵣ : (Γ ⇒ (Δ ∪· A)) → (Γ ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ∧ B)))
    ∨ᵣₗ : (Γ ⇒ (Δ ∪· A)) → (Γ ⇒ (Δ ∪· (A ∨ B)))
    ∨ᵣᵣ : (Γ ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ∨ B)))
    ⟶ᵣ : ((Γ ∪· A) ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ⟶ B)))
    ¬ᵣ : ((Γ ∪· A) ⇒ Δ) → (Γ ⇒ (Δ ∪· (¬ A)))

  permute : .(Γ₁ permutes Γ₂) → .(Δ₁ permutes Δ₂) → (Γ₁ ⇒ Δ₁) → (Γ₂ ⇒ Δ₂)
  permute permΓ permΔ ΓΔ = permuteₗ permΓ (permuteᵣ permΔ ΓΔ)

  open import Data.List.Equiv.Id
  open import Data.List.Relation.Membership
  open import Data.List.Proofs
  open import Structure.Operator.Properties

  refl : (· A) ⇒ (· A)
  refl {• x} = axiom
  refl {⊤} = weakenₗ ⊤ᵣ
  refl {⊥} = weakenᵣ ⊥ₗ
  refl {¬ A} = ¬ᵣ (permuteₗ(_permutes_.swap) (¬ₗ refl))
  refl {A ∧ B} = ∧ᵣ (∧ₗₗ refl) (∧ₗᵣ refl)
  refl {A ∨ B} = ∨ₗ (∨ᵣₗ refl) (∨ᵣᵣ refl)
  refl {A ⟶ B} = ⟶ᵣ (permuteₗ(_permutes_.swap) (⟶ₗ (permuteᵣ(_permutes_.swap) (weakenᵣ refl)) (permuteₗ(_permutes_.swap) (weakenₗ refl))))
  refl {A ⟷ B} = {!!}

  --[⇒]-trans : (Γ₁ ⇒ Γ₂) → (Γ₂ ⇒ Γ₃) → (Γ₁ ⇒ Γ₃)
  --[⇒]-trans p12 p23 = {!-c -t 10!}

  [⇒][++]ᵣ-weakenₗ : (Γ₂ ⇒ Δ) → ((Γ₁ ∪ Γ₂) ⇒ Δ)
  [⇒][++]ᵣ-weakenₗ {Γ₁ = ∅}       p = p
  [⇒][++]ᵣ-weakenₗ {Γ₁ = φ₁ ⊰ Γ₁} p = weakenₗ([⇒][++]ᵣ-weakenₗ {Γ₁ = Γ₁} p)

  [⇒][++]ₗ-weakenₗ : (Γ₁ ⇒ Δ) → ((Γ₁ ∪ Γ₂) ⇒ Δ)
  [⇒][++]ₗ-weakenₗ {Γ₁ = Γ₁}{Δ = Δ}{Γ₂ = Γ₂} Γ₁Δ = permuteₗ (sub₂(_≡ₑ_)(_permutes_) (commutativity(_∪_) ⦃ {!!} ⦄ {Γ₂}{Γ₁})) ([⇒][++]ᵣ-weakenₗ {Γ₁ = Γ₂} Γ₁Δ)

  [⇒][++]-weakenᵣ : (Γ ⇒ Δ₂) → (Γ ⇒ (Δ₁ ∪ Δ₂))
  [⇒][++]-weakenᵣ {Δ₁ = ∅}       p = p
  [⇒][++]-weakenᵣ {Δ₁ = φ₁ ⊰ Δ₁} p = weakenᵣ([⇒][++]-weakenᵣ {Δ₁ = Δ₁} p)

  [⇒][⊥]-arbitrary : ((Γ ∪· ⊥) ⇒ Δ)
  [⇒][⊥]-arbitrary {Γ = Γ}{Δ = Δ} = permuteᵣ (sub₂(_≡ₑ_)(_permutes_) (identityᵣ(_∪_)(∅))) ([⇒][++]-weakenᵣ{Δ₂ = ∅}{Δ} ⊥ₗ)

  [⇒]-nonempty-reflexivity : ((φ ⊰ Γ) ⇒ (φ ⊰ Γ))
  [⇒]-nonempty-reflexivity {Γ = ∅}     = refl
  [⇒]-nonempty-reflexivity {Γ = φ ⊰ Γ} = weakenₗ (weakenᵣ ([⇒]-nonempty-reflexivity {Γ = Γ}))

  {- TODO: Maybe not
  [⇒]-symmetric-by-side : ((Γ₁ ⇒ Δ) → (Γ₂ ⇒ Δ)) → ((Δ ⇒ Γ₂) → (Δ ⇒ Γ₁))
  [⇒]-symmetric-by-side p axiom = {!!}
  [⇒]-symmetric-by-side p (weakenₗ q) = {!!}
  [⇒]-symmetric-by-side p (permuteₗ x q) = {!!}
  [⇒]-symmetric-by-side p (contractₗ q) = {!!}
  [⇒]-symmetric-by-side p ⊥ₗ = [⇒][⊥]-arbitrary
  [⇒]-symmetric-by-side p (∧ₗₗ q) = {!!}
  [⇒]-symmetric-by-side p (∧ₗᵣ q) = {!!}
  [⇒]-symmetric-by-side p (∨ₗ q q₁) = {!!}
  [⇒]-symmetric-by-side p (⟶ₗ q q₁) = {!!}
  [⇒]-symmetric-by-side p (weakenᵣ q) = {!!}
  [⇒]-symmetric-by-side p (permuteᵣ x q) = {!!}
  [⇒]-symmetric-by-side p (contractᵣ q) = [⇒]-symmetric-by-side (weakenₗ ∘ p) q
  [⇒]-symmetric-by-side p (∧ᵣ q q₁) = {!!}
  [⇒]-symmetric-by-side p (∨ᵣₗ q) = {!!}
  [⇒]-symmetric-by-side p (∨ᵣᵣ q) = {!!}
  [⇒]-symmetric-by-side p (⟶ᵣ q) = {!!}
  -}

  open import Structure.Function

  [⇒]-super : ((Γ₁ ∪· φ₁) ⊇ (Γ₂ ∪· φ₂)) → ((Γ₁ ∪· φ₁) ⇒ (Γ₂ ∪· φ₂))
  [⇒]-super {Γ₁ = Γ₁}      {Γ₂ = φ₂ ⊰ Γ₂}    p = weakenᵣ ([⇒]-super {Γ₁ = Γ₁} {Γ₂ = Γ₂} (p ∘ skip))
  [⇒]-super {Γ₁ = ∅}       {Γ₂ = ∅}          p with use [≡]-intro ← p (use [≡]-intro) = refl
  [⇒]-super {Γ₁ = φ₁ ⊰ Γ₁} {Γ₂ = ∅}{φ₂ = φ₂} p with p (use [≡]-intro)
  ... | use [≡]-intro = permuteₗ Proofs.postpend-prepend-permutes (permuteₗ(sub₂(_≡ₑ_)(_permutes_) (symmetry(_≡ₑ_) (congruence₁(φ₁ ⊰_) (postpend-[++] {a = φ₂}{l = Γ₁})))) (weakenₗ ([⇒][++]ᵣ-weakenₗ{Γ₁ = Γ₁} refl)))
  ... | skip q = weakenₗ([⇒]-super {Γ₁ = Γ₁} {Γ₂ = ∅} \{(use [≡]-intro) → q ; (skip ())})

  [⇒]-membership : (φ ∈ Γ) → (Γ ⇒ (· φ))
  [⇒]-membership (use [≡]-intro) = [⇒][++]ₗ-weakenₗ refl
  [⇒]-membership (skip p) = weakenₗ([⇒]-membership p)

  Inconsistent : List(Formula(P)) → Type
  Inconsistent(Γ) = Γ ⇒ ∅

  test : ∅ ⇒ ·((A ∧ B) ⟶ A)
  test {A = A}{B = B} =
    refl                ⇒-start
    ((· A) ⇒ (· A))      ⇒-[ ∧ₗₗ ]
    (·(A ∧ B) ⇒ (· A))   ⇒-[ ⟶ᵣ ]
    (∅ ⇒ ·((A ∧ B) ⟶ A)) ⇒-end

  --test2 : ∅ ⇒ ·(A ∨ (¬ A))

  test3 : ∅ ⇒ ·(((¬ ¬ A) ⟶ (¬ ¬ B)) ⟶ (¬ ¬(A ⟶ B)))
  test3{A = A}{B = B} =
    • (
      refl                                     ⇒-start
      ((· A)                  ⇒ (· A))          ⇒-[ weakenᵣ ]
      ((· A)                  ⇒ ((· A) ∪· B))   ⇒-[ permuteᵣ _permutes_.swap ]
      ((· A)                  ⇒ ((· B) ∪· A))   ⇒-[ ¬ₗ ]
      (((· A) ∪· (¬ A))       ⇒ (· B))          ⇒-[ permuteₗ _permutes_.swap ]
      ((·(¬ A) ∪· A)          ⇒ (· B))          ⇒-[ ⟶ᵣ ]
      (·(¬ A)                 ⇒ ·(A ⟶ B))       ⇒-[ ¬ₗ ]
      ((·(¬ A) ∪· ¬(A ⟶ B))   ⇒ ∅)              ⇒-[ permuteₗ _permutes_.swap ]
      ((·(¬(A ⟶ B)) ∪· (¬ A)) ⇒ ∅)              ⇒-[ ¬ᵣ ]
      (·(¬(A ⟶ B))            ⇒ (∅ ∪· (¬ ¬ A))) ⇒-end
    )
    • (
      refl ⇒-start
      ((· B)                    ⇒ (· B))    ⇒-[ weakenₗ ]
      (((· B) ∪· A)             ⇒ (· B))    ⇒-[ ⟶ᵣ ]
      ((· B)                    ⇒ ·(A ⟶ B)) ⇒-[ ¬ₗ ]
      (((· B) ∪· ¬(A ⟶ B))      ⇒ ∅)        ⇒-[ permuteₗ _permutes_.swap ]
      ((·(¬(A ⟶ B)) ∪· B)       ⇒ ∅)        ⇒-[ ¬ᵣ ]
      (·(¬(A ⟶ B))              ⇒ ·(¬ B))   ⇒-[ ¬ₗ ]
      ((·(¬(A ⟶ B)) ∪· (¬ ¬ B)) ⇒ ∅)        ⇒-end
    )
    ⇒₂-[ ⟶ₗ ]
    ((·(¬(A ⟶ B)) ∪· ((¬ ¬ A) ⟶ (¬ ¬ B))) ⇒ ∅)                                     ⇒-[ permuteₗ _permutes_.swap ]
    ((·((¬ ¬ A) ⟶ (¬ ¬ B)) ∪· ¬(A ⟶ B))   ⇒ ∅)                                     ⇒-[ ¬ᵣ ]
    (·((¬ ¬ A) ⟶ (¬ ¬ B))                 ⇒ ·(¬ ¬(A ⟶ B)))                         ⇒-[ ⟶ᵣ ]
    (∅                                    ⇒ ·(((¬ ¬ A) ⟶ (¬ ¬ B)) ⟶ (¬ ¬(A ⟶ B)))) ⇒-end

  test4 : (∅ ⇒ ·(((A ⟶ B) ⟶ A) ⟶ A))
  test4 {A = A}{B = B} =
    • (
      refl ⇒-start
      ((· A) ⇒ (· A))              ⇒-[ weakenᵣ ]
      ((· A) ⇒ ((· A) ∪· B))       ⇒-[ ⟶ᵣ ]
      (∅     ⇒ ((· A) ∪· (A ⟶ B))) ⇒-end
    )
    • ((· A) ⇒ (· A))              :-[ refl ]
    ⇒₂-[ ⟶ₗ ]
    ((∅ ∪· ((A ⟶ B) ⟶ A)) ⇒ (∅ ∪· A))             ⇒-[ ⟶ᵣ ]
    (∅                    ⇒ ·(((A ⟶ B) ⟶ A) ⟶ A)) ⇒-end

  -- ⟶ᵣ (¬ᵣ (permuteₗ _permutes_.swap (⟶ₗ (¬ᵣ (permuteₗ _permutes_.swap (¬ₗ (⟶ᵣ (permuteₗ _permutes_.swap (¬ₗ (permuteᵣ _permutes_.swap (weakenᵣ axiom)))))))) (¬ₗ (¬ᵣ (permuteₗ _permutes_.swap (¬ₗ (⟶ᵣ (weakenₗ axiom)))))))))

  {-
  [∧]-intro : ((Γ ∪· A ∪· B) ⇒ (Γ ∪· (A ∧ B)))
  [∧]-intro = ∧ᵣ ([⇒]-super skip) ([⇒]-super (p ↦ {!!}))

  [∧]-elimₗ : ((Γ ∪· (A ∧ B)) ⇒ (Γ ∪· A))
  [∧]-elimₗ = {!!}
  -}

  {-
  test : (Γ ⇒ Δ₁) → .(Δ₁ permutes Δ₂) → (Δ₂ ⇒ Δ₃) → (Γ ⇒ Δ₃)

  [∧]-intro : (Γ ⇒ ·(A)) → (Γ ⇒ ·(B)) → (Γ ⇒ ·(A ∧ B))
  [∧]-intro = ∧ᵣ

  [∧]-elimₗ : (Γ ⇒ Δ ∪· (A ∧ B)) → (Γ ⇒ (Δ ∪· A))
  [∧]-elimₗ axiom = ∧ₗₗ axiom
  [∧]-elimₗ (weakenₗ p) = weakenₗ ([∧]-elimₗ p)
  [∧]-elimₗ (permuteₗ x p) = permuteₗ x ([∧]-elimₗ p)
  [∧]-elimₗ (contractₗ p) = contractₗ ([∧]-elimₗ p)
  [∧]-elimₗ (∧ₗₗ p) = ∧ₗₗ ([∧]-elimₗ p)
  [∧]-elimₗ (∧ₗᵣ p) = ∧ₗᵣ ([∧]-elimₗ p)
  [∧]-elimₗ (∨ₗ p q) = ∨ₗ ([∧]-elimₗ p) ([∧]-elimₗ q)
  [∧]-elimₗ (⟶ₗ p q) = ⟶ₗ (permuteᵣ _permutes_.swap ([∧]-elimₗ(permuteᵣ _permutes_.swap p))) ([∧]-elimₗ q)
  [∧]-elimₗ (weakenᵣ p) = weakenᵣ p
  [∧]-elimₗ (permuteᵣ x p) = test p x {!!}
  [∧]-elimₗ (contractᵣ p) = contractᵣ([∧]-elimₗ(permuteᵣ _permutes_.swap ([∧]-elimₗ p)))
  [∧]-elimₗ (∧ᵣ p q) = p
  -}

  {-
  soundness : (Γ ⇒ Δ) → ((_∈ Γ) ⊨₊ (_∈ Δ))
  soundness axiom          𝔐Γ = 𝔐Γ
  soundness (weakenₗ p)    𝔐Γ = soundness p (𝔐Γ ∘ skip)
  soundness (permuteₗ x p) 𝔐Γ = {!!}
  soundness (contractₗ p)  𝔐Γ = {!!}
  soundness ⊥ₗ             𝔐Γ ()
  soundness (∧ₗₗ p) 𝔐Γ {elem} (use [≡]-intro) = soundness p (q ↦ 𝔐Γ {!!}) (use [≡]-intro)
  -- 𝔐Γ{elem} {!soundness p ? ?!}
  -- soundness p {!!} (use {!!})
  soundness (∧ₗₗ p) 𝔐Γ (skip q) = {!!}
  soundness (∧ₗᵣ p)        𝔐Γ = {!!}
  soundness (∨ₗ p q)       𝔐Γ = {!!}
  soundness (⟶ₗ p q)       𝔐Γ = soundness p (𝔐Γ ∘ skip) ∘ skip
  soundness (weakenᵣ p)    𝔐Γ = {!!}
  soundness (permuteᵣ x p) 𝔐Γ = {!!}
  soundness (contractᵣ p)  𝔐Γ = soundness p 𝔐Γ ∘ skip
  soundness (∧ᵣ p q)       𝔐Γ = {!!}
  soundness (∨ᵣₗ p)        𝔐Γ = {!!}
  soundness (∨ᵣᵣ p)        𝔐Γ = {!!}
  soundness (⟶ᵣ p)         𝔐Γ = {!!}
  -}

{-
  excluded-middle : Γ ⇒ (Δ ∪ ·(A ∨ (¬ A)))
  excluded-middle = ∨ᵣₗ {!!}

  soundness : (Γ ⇒ Δ) → (Γ ⊨₊ Δ)
  soundness axiom = id
  soundness (weakenₗ p) 𝔐Γ = soundness p (𝔐Γ ∘ Left)
  soundness (∧ₗₗ p) 𝔐Γ e = soundness p (\{(Left Γelem) → 𝔐Γ(Left Γelem) ; (Right [≡]-intro) → 𝔐Γ (Right {!!})}) e
  soundness (∧ₗᵣ p) 𝔐Γ e = soundness p (\{(Left Γelem) → 𝔐Γ (Left Γelem) ; (Right [≡]-intro) → 𝔐Γ (Right {!!})}) e
  soundness (∨ₗ p q) 𝔐Γ e = soundness p (\{(Left r) → 𝔐Γ (Left r) ; (Right r) → {!!}}) e
  soundness (⟶ₗ p q) 𝔐Γ = soundness p (𝔐Γ ∘ Left) ∘ Left
  soundness (weakenᵣ p) 𝔐Γ (Left Δelem)      = soundness p 𝔐Γ Δelem
  soundness (weakenᵣ p) 𝔐Γ (Right [≡]-intro) = {!!}
  soundness (∧ᵣ p q) 𝔐Γ (Left Δelem)      = soundness p 𝔐Γ (Left Δelem)
  soundness (∧ᵣ p q) 𝔐Γ (Right [≡]-intro) = Logic.[∧]-intro (soundness p 𝔐Γ (Right [≡]-intro)) (soundness q 𝔐Γ (Right [≡]-intro))
  soundness (∨ᵣₗ p) 𝔐Γ e = {!!}
  soundness (∨ᵣᵣ p) 𝔐Γ e = {!!}
  soundness (⟶ᵣ p) 𝔐Γ (Left x) = {!!}
  soundness (⟶ᵣ p) 𝔐Γ (Right [≡]-intro) = {!soundness p ? ?!}
-}

  module _ (cut : ∀{Γ₁ Γ₂ Δ₁ Δ₂}{φ} → (Γ₁ ⇒ (Δ₁ ∪· φ)) → ((Γ₂ ∪· φ) ⇒ Δ₂) → ((Γ₁ ∪ Γ₂) ⇒ (Δ₁ ∪ Δ₂))) where
    open import Formalization.ClassicalPropositionalLogic.NaturalDeduction

    open import Data.List.Relation.Quantification
    open import Lang.Instance
    open import Sets.PredicateSet as PredSet using (PredSet)
    open import Sets.PredicateSet.Listable
    open import Type.Properties.MereProposition

    ¬ᵣ-⊥ : ((Γ ∪· A) ⇒ (· ⊥)) → (Γ ⇒ (Δ ∪· (¬ A)))
    ¬ᵣ-⊥ {Γ = Γ}{A = A}{Δ = Δ} p = permute{Γ₁ = Γ ∪ Γ}{Γ₂ = Γ} {!!} {!!} (cut{Γ₁ = Γ}{Γ₂ = Γ}{Δ₁ = Δ}{Δ₂ = ·(¬ A)} {!!} {!!})

    from-naturalDeduction : ∀{Γ} ⦃ _ : Listable{ℓ}(Γ) ⦄ → (Γ ⊢ φ) → (list(Γ) ⇒ (· φ))
    to-naturalDeduction : (Γ ⇒ (· φ)) → ((_∈ Γ) ⊢ φ)

    from-naturalDeduction (direct x) = [⇒]-membership(Listable.proof infer x)
    from-naturalDeduction [⊤]-intro          = [⇒][++]ₗ-weakenₗ ⊤ᵣ
    from-naturalDeduction ([⊥]-intro  p q)   = {!!}
    from-naturalDeduction ([⊥]-elim   p)     = {!from-naturalDeduction p!}
    from-naturalDeduction {Γ = Γ} ([¬]-intro  p)     = {!(permuteₗ (list-[∪·] {Γ = Γ}) (from-naturalDeduction ⦃ ? ⦄ p))!}
    from-naturalDeduction ([¬]-elim   p)     = {!!}
    from-naturalDeduction ([∧]-intro  p q)   = ∧ᵣ (from-naturalDeduction p) (from-naturalDeduction q)
    from-naturalDeduction ([∧]-elimₗ  p)     = permute permₗ permᵣ (cut (from-naturalDeduction p) (∧ₗₗ refl)) where
      permₗ = sub₂(_≡ₑ_)(_permutes_) (identityᵣ(_∪_)(∅))
      permᵣ = sub₂(_≡ₑ_)(_permutes_) (identityₗ(_∪_)(∅))
    from-naturalDeduction ([∧]-elimᵣ  p)     = permute permₗ permᵣ (cut (from-naturalDeduction p) (∧ₗᵣ refl)) where
      permₗ = sub₂(_≡ₑ_)(_permutes_) (identityᵣ(_∪_)(∅))
      permᵣ = sub₂(_≡ₑ_)(_permutes_) (identityₗ(_∪_)(∅))
    from-naturalDeduction ([∨]-introₗ p)     = ∨ᵣₗ (from-naturalDeduction p)
    from-naturalDeduction ([∨]-introᵣ p)     = ∨ᵣᵣ (from-naturalDeduction p)
    from-naturalDeduction ([∨]-elim   p q r) = {!!}
    from-naturalDeduction {Γ = Γ} ([⟶]-intro  p)     = ⟶ᵣ (permuteₗ (list-[∪·] {S = Γ}) (from-naturalDeduction ⦃ {!!} ⦄ p))
    from-naturalDeduction ([⟶]-elim   p q)   = {!!} -- permute {!!} {!!} (cut (from-naturalDeduction p) {!cut (from-naturalDeduction q) ?!})
    from-naturalDeduction ([⟷]-intro  p q)   = {!!}
    from-naturalDeduction ([⟷]-elimₗ  p q)   = {!!}
    from-naturalDeduction ([⟷]-elimᵣ  p q)   = {!!}

    {-
    from-naturalDeduction : ((_∈ Γ) ⊢ φ) → (Γ ⇒ (· φ))
    from-naturalDeduction (direct (use {x = x}{l = l} [≡]-intro)) = [⇒][++]ₗ-weakenₗ {Γ₁ = · x}{Γ₂ = l} axiom
    from-naturalDeduction (direct (skip x)) = weakenₗ(from-naturalDeduction (direct x))
    from-naturalDeduction [⊤]-intro = [⇒][++]ₗ-weakenₗ ⊤ᵣ
    from-naturalDeduction ([⊥]-intro p q) = {!!}
    from-naturalDeduction ([⊥]-elim p) = {!!}
    from-naturalDeduction ([¬]-intro p) = {!!}
    from-naturalDeduction ([¬]-elim p) = {!!}
    from-naturalDeduction ([∧]-intro p q) = ∧ᵣ (from-naturalDeduction p) (from-naturalDeduction q)
    from-naturalDeduction ([∧]-elimₗ p) = permute permₗ permᵣ (cut (from-naturalDeduction p) (∧ₗₗ axiom)) where
      permₗ = sub₂(_≡ₑ_)(_permutes_) (identityᵣ(_∪_)(∅))
      permᵣ = sub₂(_≡ₑ_)(_permutes_) (identityₗ(_∪_)(∅))
    from-naturalDeduction ([∧]-elimᵣ p) = permute permₗ permᵣ (cut (from-naturalDeduction p) (∧ₗᵣ axiom)) where
      permₗ = sub₂(_≡ₑ_)(_permutes_) (identityᵣ(_∪_)(∅))
      permᵣ = sub₂(_≡ₑ_)(_permutes_) (identityₗ(_∪_)(∅))
    from-naturalDeduction ([∨]-introₗ p) = ∨ᵣₗ (from-naturalDeduction p)
    from-naturalDeduction ([∨]-introᵣ p) = ∨ᵣᵣ (from-naturalDeduction p)
    from-naturalDeduction ([∨]-elim p q r) = {!!}
    from-naturalDeduction ([⟶]-intro p) = ⟶ᵣ {!from-naturalDeduction p!}
    from-naturalDeduction ([⟶]-elim p q) = {!!}
    from-naturalDeduction ([⟷]-intro p q) = {!!}
    from-naturalDeduction ([⟷]-elimₗ p q) = {!!}
    from-naturalDeduction ([⟷]-elimᵣ p q) = {!!}
    -}

{-    to-naturalDeduction axiom = direct (use [≡]-intro)
    to-naturalDeduction (weakenₗ p) = {!!}
    to-naturalDeduction (permuteₗ x p) = {!!}
    to-naturalDeduction (contractₗ p) = {!!}
    to-naturalDeduction (∧ₗₗ p) = {!!}
    to-naturalDeduction (∧ₗᵣ p) = {!!}
    to-naturalDeduction (∨ₗ p p₁) = {!!}
    to-naturalDeduction (⟶ₗ p p₁) = {!!}
    to-naturalDeduction (weakenᵣ p) = {!!}
    to-naturalDeduction (permuteᵣ x p) = {!!}
    to-naturalDeduction (contractᵣ p) = {!!}
    to-naturalDeduction (∧ᵣ p p₁) = [∧]-intro (to-naturalDeduction p) (to-naturalDeduction p₁)
    to-naturalDeduction (∨ᵣₗ p) = [∨]-introₗ (to-naturalDeduction p)
    to-naturalDeduction (∨ᵣᵣ p) = [∨]-introᵣ (to-naturalDeduction p)
    to-naturalDeduction (⟶ᵣ p) = [⟶]-intro {!to-naturalDeduction p!}
-}


-- A term model à la Beth

open import Library hiding (_∈_)

module TermModel (Base : Set) where

import Formulas   ; open module Form = Formulas    Base
import Derivations; open module Der  = Derivations Base

-- Beth model

data Cover (Δ : Cxt) : Set where
  idc  : Cover Δ
  bot  : (t : Δ ⊢ False) → Cover Δ
  node : ∀{A B} (t : Δ ⊢ A ∨ B) (C : Cover (Δ ∙ A)) (D : Cover (Δ ∙ B)) → Cover Δ

data _∈_ Γ : ({Δ} : Cxt) (C : Cover Δ) → Set where
  here  : Γ ∈ idc {Γ}
  left  : ∀{Δ A B C D}{t : Δ ⊢ A ∨ B} (e : Γ ∈ C) → Γ ∈ node t C D
  right : ∀{Δ A B C D}{t : Δ ⊢ A ∨ B} (e : Γ ∈ D) → Γ ∈ node t C D

coverWk : ∀{Γ Δ} {C : Cover Δ} (e : Γ ∈ C) → Γ ≤ Δ
coverWk here      = id≤
coverWk (left  e) = coverWk e • weak id≤
coverWk (right e) = coverWk e • weak id≤

transC : ∀{Γ} (C : Cover Γ) (f : ∀{Δ} → Δ ∈ C → Cover Δ) → Cover Γ
transC idc f = f here
transC (bot t) f = bot t
transC (node t C D) f = node t (transC C (f ∘ left)) (transC D (f ∘ right))

-- UNUSED:
trans∈ : ∀{Γ} (C : Cover Γ) (f : ∀{Δ} → Δ ∈ C → Cover Δ) →
  ∀ {Φ} {Δ} (e : Δ ∈ C) → Φ ∈ f e → Φ ∈ transC C f
trans∈ idc f here = id
trans∈ (bot t) f ()
trans∈ (node t C D) f (left  e) = left  ∘ trans∈ C (f ∘ left ) e
trans∈ (node t C D) f (right e) = right ∘ trans∈ D (f ∘ right) e

split∈ : ∀{Γ} (C : Cover Γ) (f : ∀{Δ} → Δ ∈ C → Cover Δ) {Φ} (e : Φ ∈ transC C f)
  → ∃ λ Δ → ∃ λ (e : Δ ∈ C) → Φ ∈ f e
split∈ idc f e = _ , _ , e
split∈ (bot t) f ()
split∈ (node t C D) f (left e) with split∈ C (f ∘ left) e
... | Δ , e₁ , e₂ = Δ , left e₁ , e₂
split∈ (node t C D) f (right e) with split∈ D (f ∘ right) e
... | Δ , e₁ , e₂ = Δ , right e₁ , e₂

-- Empty cover

EmptyCover : (Γ : Cxt) → Set
EmptyCover Γ = Σ (Cover Γ) λ C → ∀{Δ} → Δ ∈ C → ⊥

-- Empty cover is isomorphic to a witness of inconsistency

toEmptyCover : ∀{Γ} (t : Γ ⊢ False) → EmptyCover Γ
toEmptyCover t = bot t , λ()

fromEmptyCover : ∀{Γ} (ec : EmptyCover Γ) → Γ ⊢ False
fromEmptyCover (C , f) = reifyF C f
  where
  reifyF : ∀ {Γ} (C : Cover Γ) (f : ∀ {Δ} → Δ ∈ C → ⊥) → Γ ⊢ False
  reifyF idc          f = ⊥-elim (f here)
  reifyF (bot t)      f = t
  reifyF (node t C D) f = orE t (reifyF C (f ∘ left)) (reifyF D (f ∘ right))

transE : ∀{Γ} (C : Cover Γ) (f : ∀{Δ} → Δ ∈ C → EmptyCover Δ) → EmptyCover Γ
transE C f = transC C (proj₁ ∘ f) , λ e → let _ , e₁ , e₂ = split∈ C (proj₁ ∘ f) e in f e₁ .proj₂ e₂

-- Paste (from Thorsten)

paste' : ∀{A Γ} (C : Cover Γ) (f : ∀{Δ} (e : Δ ∈ C) → Δ ⊢ A) → Γ ⊢ A
paste' idc          f = f here
paste' (bot t)      f = falseE t
paste' (node t C D) f = orE t (paste' C (f ∘ left)) (paste' D (f ∘ right))

-- Weakening Covers

monC : ∀{Γ Δ} (τ : Δ ≤ Γ) (C : Cover Γ) → Cover Δ
monC τ idc = idc
monC τ (bot t) = bot (monD τ t)
monC τ (node t C D) = node (monD τ t) (monC (lift τ) C) (monC (lift τ) D)

mon∈ : ∀{Γ Δ Φ} (C : Cover Γ) (τ : Δ ≤ Γ) (e : Φ ∈ monC τ C) → ∃ λ Ψ → Ψ ∈ C × Φ ≤ Ψ
mon∈ {Γ} {Δ} {.Δ} idc τ here = _ , here , τ
mon∈ {Γ} {Δ} {Φ} (bot t) τ ()
mon∈ {Γ} {Δ} {Φ} (node t C D) τ (left e) with mon∈ C (lift τ) e
... | Ψ , e' , σ = Ψ , left e' , σ
mon∈ {Γ} {Δ} {Φ} (node t C D) τ (right e) with mon∈ D (lift τ) e
... | Ψ , e' , σ = Ψ , right e' , σ

-- The syntactic Beth model

T⟦_⟧ : (A : Form) (Γ : Cxt) → Set
T⟦ Atom P ⟧ Γ = Γ ⊢ Atom P
T⟦ True ⟧ Γ = ⊤
T⟦ False ⟧ Γ = EmptyCover Γ
T⟦ A ∨ B ⟧ Γ = ∃ λ (C : Cover Γ) → ∀{Δ} → Δ ∈ C → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ
T⟦ A ∧ B ⟧ Γ = T⟦ A ⟧ Γ × T⟦ B ⟧ Γ
T⟦ A ⇒ B ⟧ Γ = ∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ B ⟧ Δ

monT : ∀ A {Γ Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ → T⟦ A ⟧ Δ
monT (Atom P) τ t = monD τ t
monT True τ _ = _
monT False τ (C , f) = monC τ C , λ {Φ} e → f (proj₁ (proj₂ (mon∈ C τ e)))
monT (A ∨ B) {Γ} {Δ} τ (C , f) = monC τ C ,  λ {Φ} e →
  let Ψ , e' , σ = mon∈ C τ e
  in  map-⊎ (monT A σ) (monT B σ) (f {Ψ} e')
monT (A ∧ B) τ (a , b) = monT A τ a , monT B τ b
monT (A ⇒ B) τ f σ = f (σ • τ)

-- Reflection / reification

mutual

  reflect : ∀{Γ} A (t : Γ ⊢ A) → T⟦ A ⟧ Γ
  reflect (Atom P) t = t
  reflect True t = _
  reflect False = toEmptyCover
  reflect (A ∨ B) t = node t idc idc , aux
    where
    aux : ∀{Δ} → Δ ∈ node t idc idc → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ
    aux (left  here) = inj₁ (reflect A (hyp top))
    aux (right here) = inj₂ (reflect B (hyp top))

  reflect (A ∧ B) t = reflect A (andE₁ t) , reflect B (andE₂ t)
  reflect (A ⇒ B) t τ a = reflect B (impE (monD τ t) (reify A a))

  reify : ∀{Γ} A (⟦f⟧ :  T⟦ A ⟧ Γ) → Γ ⊢ A
  reify (Atom P) t      = t
  reify True _          = trueI
  reify False           = fromEmptyCover
  reify (A ∨ B) (C , f) = paste' C ([ orI₁ ∘ reify A , orI₂ ∘ reify B ] ∘ f)
  reify (A ∧ B) (a , b) = andI (reify A a) (reify B b)
  reify (A ⇒ B) ⟦f⟧     = impI (reify B (⟦f⟧ (weak id≤) (reflect A (hyp top))))

-- In the absurd world, every proposition holds.

absurd : ∀{Γ A} (t : Γ ⊢ False) → T⟦ A ⟧ Γ
absurd t = reflect _ (falseE t)

-- We can paste in the model thanks to reflection and reification.
-- (However, this does not look nice, since it goes through terms.)

-- paste : ∀ {A Γ} (C : Cover Γ) (f : ∀{Δ} (e : Δ ∈ C) → T⟦ A ⟧ Δ) → T⟦ A ⟧ Γ
-- paste C f = reflect _ (paste' C (reify _ ∘ f))

-- Semantic paste:

paste : ∀ A {Γ} (C : Cover Γ) (f : ∀{Δ} (e : Δ ∈ C) → T⟦ A ⟧ Δ) → T⟦ A ⟧ Γ
paste (Atom P) = paste'
paste True C f = _
paste False C f = transE C f
paste (A ∨ B) C f = transC C (proj₁ ∘ f) , λ e → let _ , e₁ , e₂ = split∈ C (proj₁ ∘ f) e in f e₁ .proj₂ e₂
paste (A ∧ B) C f = paste A C (proj₁ ∘ f) , paste B C (proj₂ ∘ f)
paste (A ⇒ B) C f τ a = paste B (monC τ C) λ {Δ} e → let Ψ , e' , σ  = mon∈ C τ e in f e' σ (monT A (coverWk e) a)

-- Fundamental theorem

-- Extension of T⟦_⟧ to contexts

G⟦_⟧ : ∀ (Γ Δ : Cxt) → Set
G⟦ ε     ⟧ Δ = ⊤
G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × T⟦ A ⟧ Δ

monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ
monG {ε} τ _ = _
monG {Γ ∙ A} τ (γ , a) = monG τ γ , monT A τ a

-- Variable case

fundH : ∀{Γ Δ A} (x : Hyp A Γ) (γ : G⟦ Γ ⟧ Δ) → T⟦ A ⟧ Δ
fundH top     = proj₂
fundH (pop x) = fundH x ∘ proj₁

-- A lemma for the orElim case.

orElim : ∀ {Γ A B X} (C : Cover Γ) (f : {Δ : Cxt} → Δ ∈ C → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ) →
         (∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ X ⟧ Δ) →
         (∀{Δ} (τ : Δ ≤ Γ) → T⟦ B ⟧ Δ → T⟦ X ⟧ Δ) →
         T⟦ X ⟧ Γ
orElim C f g h = paste _ C λ e → [ g (coverWk e) , h (coverWk e) ] (f e)

-- falseElim :
falseElim : ∀{Γ A} (C : Cover Γ) (f : ∀{Δ} → Δ ∈ C → ⊥) → T⟦ A ⟧ Γ
falseElim C f = paste _ C (⊥-elim ∘ f)

-- The fundamental theorem

fund :  ∀{Γ A} (t : Γ ⊢ A) {Δ} (γ : G⟦ Γ ⟧ Δ) → T⟦ A ⟧ Δ
fund (hyp x) = fundH x
fund (impI t) γ τ a = fund t (monG τ γ , a)
fund (impE t u) γ = fund t γ id≤ (fund u γ)
fund (andI t u) γ = fund t γ , fund u γ
fund (andE₁ t) = proj₁ ∘ fund t
fund (andE₂ t) = proj₂ ∘ fund t
fund (orI₁ t) γ = idc , inj₁ ∘ λ{ here → fund t γ }
fund (orI₂ t) γ = idc , inj₂ ∘ λ{ here → fund t γ }
fund (orE t u v) γ = uncurry orElim (fund t γ)
  (λ τ a → fund u (monG τ γ , a))
  (λ τ b → fund v (monG τ γ , b))
fund (falseE t) γ = uncurry falseElim (fund t γ)
fund trueI γ = _

-- -}
-- -}

-- Example:


------------------------------------------------------------------------
-- Typing of pure type systems (PTS)
------------------------------------------------------------------------

module Pts.Typing where

open import Data.Fin using (Fin; zero)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Typed
open import Data.Nat using (ℕ; _+_)
open import Data.Product using (_,_; ∃; _×_; proj₂)
open import Data.Star using (ε; _◅_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Vec.All using (lookup₂)
open import Function using (flip)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as PropEq

open import Pts.Core public
open import Pts.Syntax using (module SubstApp)
open import Pts.Reduction.Full

------------------------------------------------------------------------
-- Typing derivations.
--
-- The presentation of the typing rules below follows that of Pollak
-- (1994) rather than that of Barendregt (1992) in that it uses a
-- separate well-formedness judgment "Γ wf" for contexts in favor of
-- an explicit weakening rule.  The well-formedness judgment is used
-- to strengthen the variable and sort typing rules.  For the
-- remaining rules, well-formedness of contexts is an invariant (as e
-- witnessed by the "wt-wf" Lemma below).
--
-- References:
--
--  * H. P. Barendregt, Lambda Calculi with Types, chapter 2 of the
--    Handbook of Logic in Computer Science (vol. 2), Oxford
--    University Press, 1992.
--
--  * R. Pollack, The Theory of LEGO: A Proof Checker for the Extended
--    Calculus of Constructions, Ph.D. thesis, University of
--    Edinburgh, 1994

-- Definitions and lemmas are parametrized by a given PTS instance.
module Typing (pts : PTS) where
  open PTS pts
  open Ctx
  open Syntax
  open Substitution using (_[_])

  infixl 9 _·_
  infix  4 _wf _⊢_∈_

  mutual

    -- Well-formed contexts.
    _wf : ∀ {n} → Ctx n → Set
    Γ wf = WfCtx._wf _⊢_∈_ Γ

    -- Typing derivations.
    data _⊢_∈_ {n} (Γ : Ctx n) : Term n → Term n → Set where
      var    : ∀ x                         → Γ wf → Γ ⊢ var x   ∈ lookup x Γ
      axiom  : ∀ {s₁ s₂} (a : Axiom s₁ s₂) → Γ wf → Γ ⊢ sort s₁ ∈ sort s₂
      Π      : ∀ {s₁ s₂ s₃ a b} (r : Rule s₁ s₂ s₃)  →
               Γ ⊢ a ∈ sort s₁  → a ∷ Γ ⊢ b ∈ sort s₂ → Γ ⊢ Π a b ∈ sort s₃
      ƛ      : ∀ {a t b s}      →
               a ∷ Γ ⊢ t ∈ b    → Γ ⊢ Π a b ∈ sort s  → Γ ⊢ ƛ a t ∈ Π a b
      _·_    : ∀ {f a b t}      →
               Γ ⊢ f ∈ Π a b    → Γ ⊢ t ∈ a  → Γ ⊢ f · t ∈ b [ t ]
      conv   : ∀ {t a b s}      → Γ ⊢ t ∈ a  →
               Γ ⊢ b ∈ sort s   → a ≡β b     → Γ ⊢ t ∈ b

  open WfCtx _⊢_∈_ public hiding (_wf; _⊢_wf)

------------------------------------------------------------------------
-- Properties of typings

module _ {pts} where
  open PTS    pts
  open Syntax
  open Ctx
  open Typing pts

  -- Contexts of typings are well-formed.
  wt-wf : ∀ {n} {Γ : Ctx n} {t a} → Γ ⊢ t ∈ a → Γ wf
  wt-wf (var x Γ-wf)       = Γ-wf
  wt-wf (axiom a Γ-wf)     = Γ-wf
  wt-wf (Π r a∈s₁ b∈s₂)    = wt-wf a∈s₁
  wt-wf (ƛ t∈b Πab∈s)      = wt-wf Πab∈s
  wt-wf (f∈Πab · t∈a)      = wt-wf f∈Πab
  wt-wf (conv t∈a b∈s a≡b) = wt-wf t∈a

  -- Contexts of well-formed types are well-formed.
  wf-wf : ∀ {n} {Γ : Ctx n} {a} → (∃ λ s → Γ ⊢ a ∈ sort s) → Γ wf
  wf-wf (_ , a∈s) = wt-wf a∈s

  private
    module Sβ {n} where
      open Setoid (≡β-setoid {Sort} {n}) public using (refl; trans; sym)

  -- A generation lemma for sorts.
  sort-gen : ∀ {n} {Γ : Ctx n} {s a} → Γ ⊢ sort s ∈ a →
             ∃ λ s′ →  Axiom s s′ × a ≡β sort s′
  sort-gen (axiom ax Γ-wf)      = _ , ax , Sβ.refl
  sort-gen (conv s∈a b∈s₁ a≡b) =
    let s₂ , ax , a≡s₂ = sort-gen s∈a
    in s₂ , ax , Sβ.trans (Sβ.sym a≡b) a≡s₂

  -- A generation lemma for product typings.
  Π-gen : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢ Π a b ∈ c →
          ∃ λ s₁ → ∃ λ s₂ → ∃ λ s₃ → Rule s₁ s₂ s₃ ×
            Γ ⊢ a ∈ sort s₁ × a ∷ Γ ⊢ b ∈ sort s₂ × c ≡β sort s₃
  Π-gen (Π r a∈s₁ b∈s₂)          = _ , _ , _ , r , a∈s₁ , b∈s₂ , Sβ.refl
  Π-gen (conv Πab∈c₁ c₂∈s c₁≡c₂) =
    let s₁ , s₂ , s₃ , r , a∈s₁ , b∈s₂ , c₁≡s₃ = Π-gen Πab∈c₁
    in s₁ , s₂ , s₃ , r , a∈s₁ , b∈s₂ , Sβ.trans (Sβ.sym c₁≡c₂) c₁≡s₃

  -- A generation lemma for abstractions.
  ƛ-gen : ∀ {n} {Γ : Ctx n} {a t c} → Γ ⊢ ƛ a t ∈ c →
          ∃ λ s → ∃ λ b → Γ ⊢ Π a b ∈ sort s × a ∷ Γ ⊢ t ∈ b × c ≡β Π a b
  ƛ-gen (ƛ t∈b Πab∈s)            = _ , _ , Πab∈s , t∈b , Sβ.refl
  ƛ-gen (conv λat∈c₁ c₂∈s c₁≡c₂) =
    let s , b , Πab∈s , t∈b , c₁≡Πab = ƛ-gen λat∈c₁
    in s , b , Πab∈s , t∈b , Sβ.trans (Sβ.sym c₁≡c₂) c₁≡Πab

  ----------------------------------------------------------------------
  -- Well-typed substitutions (i.e. substitution lemmas)

  -- A shorthand for typings of Ts.
  TermTyping : (ℕ → Set) → Set₁
  TermTyping T = Typing Term T Term

  -- Term-typed substitutions.
  module TermTypedSub {T} (l : Lift T Term) (_⊢T_∈_ : TermTyping T) where
    typedSub : TypedSub Term Term T
    typedSub = record
      { _⊢_∈_       = _⊢T_∈_
      ; _⊢_wf       = WfCtx._⊢_wf _⊢_∈_
      ; application = record { _/_    = SubstApp._/_ Sort l }
      ; weakenOps   = record { weaken = Substitution.weaken }
      }

    open TypedSub typedSub public hiding (_⊢_∈_)

  -- Typed liftings from Ts to Terms.
  LiftToTermTyped : ∀ {T} → Lift T Term → TermTyping T → Set
  LiftToTermTyped l _⊢T_∈_ = LiftTyped l typedSub _⊢_∈_
    where open TermTypedSub l _⊢T_∈_ using (typedSub)

  -- Application of well-typed substitutions to terms.
  record TypedSubstApp {T} l {_⊢T_∈_ : TermTyping T}
                       (lt : LiftToTermTyped l _⊢T_∈_) : Set where
    open LiftTyped lt
    open Substitution using (_[_])
    open PropEq hiding ([_])
    private
      module A = SubstApp Sort l
      module L = Lift l

    -- Substitutions commute.
    field /-sub-↑ : ∀ {m n} a b (σ : Sub T m n) →
                    a [ b ] A./ σ ≡ (a A./ σ L.↑) [ b A./ σ ]

    open BetaSubstApp (record { /-sub-↑ = /-sub-↑ }) hiding (/-sub-↑)
    open TermTypedSub l _⊢T_∈_ hiding (_/_)

    infixl 8 _/_

    -- Substitutions preserve well-typedness of terms.
    _/_ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {t a σ} →
          Γ ⊢ t ∈ a → Γ ⇒ Δ ⊢ σ → Δ ⊢ t A./ σ ∈ a A./ σ
    var x Γ-wf            / (σ-wt , _) = lift (lookup₂ x σ-wt)
    axiom a Γ-wf          / (_ , Δ-wf) = axiom a Δ-wf
    Π r a∈s₁ b∈s₂         / σ-wt =
      Π r (a∈s₁ / σ-wt) (b∈s₂ / σ-wt ↑ (_ , a∈s₁ / σ-wt))
    ƛ t∈b Πab∈s           / σ-wt =
      let _ , _ , _ , _ , a/σ∈s , _ = Π-gen (Πab∈s / σ-wt) in
      ƛ (t∈b / σ-wt ↑ (_ , a/σ∈s)) (Πab∈s / σ-wt)
    _·_ {b = b} f∈Πab t∈a / σ-wt =
      subst (_⊢_∈_ _ _) (sym (/-sub-↑ b _ _)) ((f∈Πab / σ-wt) · (t∈a / σ-wt))
    conv t∈a b∈s a≡b      / σ-wt = conv (t∈a / σ-wt) (b∈s / σ-wt) (a≡b /≡β _)

  -- Typed variable substitutions (renamings).
  module TypedRenaming where
    open Substitution
      using (termSubst; varLiftAppLemmas; varLiftSubLemmas)
    open TermSubst     termSubst        using  (varLift)
    open LiftAppLemmas varLiftAppLemmas hiding (lift)

    typedVarSubst : TypedVarSubst (WfCtx._⊢_wf _⊢_∈_)
    typedVarSubst = record
      { application = AppLemmas.application appLemmas
      ; weakenOps   = Ctx.weakenOps
      ; id-vanishes = id-vanishes
      ; /-⊙         = /-⊙
      ; /-wk        = PropEq.refl
      ; wf-wf       = wf-wf
      }
    open TypedVarSubst typedVarSubst public

    -- Liftings from variables to typed terms.
    liftTyped : LiftTyped varLift typedSub _⊢_∈_
    liftTyped = record
      { simpleTyped  = simpleTyped
      ; lift         = lift
      }
      where
        lift : ∀ {n} {Γ : Ctx n} {x a} → Γ ⊢Var x ∈ a → Γ ⊢ var x ∈ a
        lift (var x Γ-wf) = var x Γ-wf

    open LiftSubLemmas varLiftSubLemmas

    typedSubstApp : TypedSubstApp varLift liftTyped
    typedSubstApp = record { /-sub-↑ = /-sub-↑ }

  -- Typed term substitutions in terms.
  module TypedSubstitution where
    open Substitution using (simple; termSubst)
    open SimpleExt simple using (extension)
    open TermSubst termSubst using (termLift)
    open TermTypedSub termLift _⊢_∈_ public using (typedSub; _⇒_⊢_)
    open TypedRenaming using (_⇒_⊢Var_)
    private
      module U = Substitution
      module V = TypedRenaming
      module L = ExtAppLemmas U.appLemmas

    infixl 8 _/Var_ _/_

    -- Renaming preserves well-typedness.
    _/Var_ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a b σ} →
             Γ ⊢ a ∈ b → Γ ⇒ Δ ⊢Var σ → Δ ⊢ a U./Var σ ∈ b U./Var σ
    _/Var_ = TypedSubstApp._/_ V.typedSubstApp

    -- Weakening preserves well-typedness.
    weaken : ∀ {n} {Γ : Ctx n} {a b c s} → Γ ⊢ a ∈ b → Γ ⊢ c ∈ sort s →
             (c ∷ Γ) ⊢ (U.weaken a) ∈ (U.weaken b)
    weaken a∈b c∈s = a∈b /Var V.wk (_ , c∈s)

    -- Extensions of typed term substitutions.
    extensionTyped : ExtensionTyped extension typedSub
    extensionTyped = record
      { weaken   = λ { (_ , c∈s) a∈b → weaken a∈b c∈s }
      ; weaken-/ = ExtLemmas₄.weaken-/ L.lemmas₄
      ; wt-wf    = wt-wf
      }

    -- Simple typed term substitutions.
    simpleTyped : SimpleTyped simple typedSub
    simpleTyped = record
      { extensionTyped  = extensionTyped
      ; var             = var
      ; id-vanishes     = L.id-vanishes
      ; /-wk            = λ {_ a} → L./-wk {t = a}
      ; wk-sub-vanishes = L.wk-sub-vanishes
      ; wf-wf           = wf-wf
      }

    -- Liftings from terms to terms.
    liftTyped : LiftTyped termLift typedSub _⊢_∈_
    liftTyped = record
      { simpleTyped  = simpleTyped
      ; lift         = Function.id
      }

    open LiftTyped liftTyped public
      hiding (var; weaken; extensionTyped; simpleTyped; wt-wf; wf-wf)

    typedSubstApp : TypedSubstApp termLift liftTyped
    typedSubstApp = record { /-sub-↑ = λ a _ _ → L.sub-commutes a }

    -- Substitutions preserve well-typedness.
    _/_ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a b σ} →
          Γ ⊢ a ∈ b → Γ ⇒ Δ ⊢ σ → Δ ⊢ a U./ σ ∈ b U./ σ
    _/_ = TypedSubstApp._/_ typedSubstApp

    infix 10 _[_]

    -- Single-variable substitutions preserve well-typedness.
    _[_] : ∀ {n} {Γ : Ctx n} {t a u b} →
           b ∷ Γ ⊢ t ∈ a → Γ ⊢ u ∈ b → Γ ⊢ t U.[ u ] ∈ a U.[ u ]
    t∈a [ u∈b ] = t∈a / sub u∈b

    -- Conversion of the first type in a context preserves
    -- well-typedness.
    conv-⊢ : ∀ {n} {Γ : Ctx n} {a₁ a₂ t b s} →
             a₁ ∷ Γ ⊢ t ∈ b → Γ ⊢ a₂ ∈ sort s → a₁ ≡β a₂ → a₂ ∷ Γ ⊢ t ∈ b
    conv-⊢ t∈b a₂∈s a₁≡a₂ =
      subst₂ (_⊢_∈_ _) (L.id-vanishes _) (L.id-vanishes _) (t∈b / csub)
      where
        open PropEq using (subst₂)
        open BetaSubstitution using (weaken-≡β)
        open Setoid ≡β-setoid using (sym)

        a₁∷Γ-wf = wt-wf t∈b
        a₁∈s′   = proj₂ (wf-∷₁ a₁∷Γ-wf)
        a₂∷Γ-wf = (_ , a₂∈s) ∷ (wf-∷₂ a₁∷Γ-wf)

        csub = tsub (conv (var zero a₂∷Γ-wf) (weaken a₁∈s′ a₂∈s)
                          (weaken-≡β (sym a₁≡a₂)))

  open TypedSubstitution

  -- Operations on well-formed contexts that require weakening of
  -- well-formedness judgments.
  module WfCtxOps where
    private module E = ExtensionTyped extensionTyped

    wfWeakenOps : WfWeakenOps weakenOps
    wfWeakenOps = record
      { weaken = λ { a-wk (_ , b∈s) → (_ , E.weaken a-wk b∈s) }
      }

    open WfWeakenOps wfWeakenOps public

  ----------------------------------------------------------------------
  -- Preservation of types under reduction (aka subject reduction)

  open Sβ
  open PropEq using (_≡_)

  -- Every well-typed term is either a type or an element.
  tp-or-el : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ∈ b →
             ∃ λ s → b ≡ sort s ⊎ Γ ⊢ b ∈ sort s
  tp-or-el (var x Γ-wf)    = _ , inj₂ (proj₂ (WfCtxOps.lookup x Γ-wf))
  tp-or-el (axiom a Γ-wf)  = _ , inj₁ PropEq.refl
  tp-or-el (Π r a∈s₁ b∈s₂) = _ , inj₁ PropEq.refl
  tp-or-el (ƛ t∈b Πab∈s)   = _ , inj₂ Πab∈s
  tp-or-el (f∈Πab · t∈a)   with tp-or-el f∈Πab
  tp-or-el (f∈Πab · t∈a)   | _ , inj₁ ()
  tp-or-el (f∈Πab · t∈a)   | _ , inj₂ Πab∈s =
    let _ , s , _ , _ , _ , b∈s , _ = Π-gen Πab∈s
    in s , inj₂ (b∈s [ t∈a ])
  tp-or-el (conv t∈a b∈s a≡b) = _ , inj₂ b∈s

  -- An inversion lemma for product typings.
  Π-inv : ∀ {n} {Γ : Ctx n} {f a b} → Γ ⊢ f ∈ Π a b →
           ∃ λ s₁ → ∃ λ s₂ → Γ ⊢ a ∈ sort s₁ × a ∷ Γ ⊢ b ∈ sort s₂
  Π-inv f∈Πab with tp-or-el f∈Πab
  Π-inv f∈Πab | _ , inj₁ ()
  Π-inv f∈Πab | _ , inj₂ Πab∈s =
    let s₁ , s₂ , _ , _ , a∈s₁ , b∈s₂ , _ = Π-gen Πab∈s
    in s₁ , s₂ , a∈s₁ , b∈s₂

  -- An inversion lemma for abstractions.
  ƛ-inv : ∀ {n} {Γ : Ctx n} {a t b c} → Γ ⊢ ƛ a t ∈ Π b c →
           ∃ λ s → Γ ⊢ a ∈ sort s × b ≡β a × a ∷ Γ ⊢ t ∈ c
  ƛ-inv λat∈Πbc =
    let _ , _ , Πad∈s , t∈d , Πbc≡Πad = ƛ-gen λat∈Πbc
        s₁ , _ , _ , _ , a∈s₁ , _     = Π-gen Πad∈s
        _ , _ , _ , c∈s₂              = Π-inv λat∈Πbc
        b≡a , c≡d                     = Π-inj Πbc≡Πad
    in s₁ , a∈s₁ , b≡a , conv t∈d (conv-⊢ c∈s₂ a∈s₁ b≡a) (sym c≡d)

  -- Preservation of types under one-step reduction.
  pres : ∀ {n} {Γ : Ctx n} {a a′ b} → Γ ⊢ a ∈ b → a →β a′ → Γ ⊢ a′ ∈ b
  pres (var _ _)   ()
  pres (axiom _ _) ()
  pres (Π r a∈s₁ b∈s₂) (Π₁ a→a′ b) =
    Π r a′∈s₂ (conv-⊢ b∈s₂ a′∈s₂ (→β⇒≡β a→a′))
    where a′∈s₂ = pres a∈s₁ a→a′
  pres (Π r a∈s₁ b∈s₂) (Π₂ a b→b′) = Π r a∈s₁ (pres b∈s₂ b→b′)
  pres (ƛ t∈b Πab∈s) (ƛ₁ a→a′ t)   =
    let _ , _ , _ , _ , a′∈s , _ = Π-gen (pres Πab∈s (Π₁ a→a′ _))
        Πab→Πa′b                 = Π₁ a→a′ _
    in conv (ƛ (conv-⊢ t∈b a′∈s (→β⇒≡β a→a′)) (pres Πab∈s Πab→Πa′b))
            Πab∈s (sym (→β⇒≡β Πab→Πa′b))
  pres (ƛ t∈b Πab∈s) (ƛ₂ a t→t′)    = ƛ (pres t∈b t→t′) Πab∈s
  pres (λat∈Πbc · u∈b) (cont a t u) =
    let _ , a∈s , b≡a , t∈c = ƛ-inv λat∈Πbc
    in t∈c [ conv u∈b a∈s b≡a ]
  pres (f∈Πab · t∈a) (f→f′ ·₁ t) = pres f∈Πab f→f′ · t∈a
  pres (_·_ {b = b} f∈Πab t∈a) (f ·₂ t→t′) =
    let _ , _ , _ , b∈s = Π-inv f∈Πab
    in conv (f∈Πab · pres t∈a t→t′) (b∈s [ t∈a ])
            (sym (→β*⇒≡β (b [→β t→t′ ])))
  pres (conv a∈b₁ b₂∈s b₁≡b₂) a→a′ = conv (pres a∈b₁ a→a′) b₂∈s b₁≡b₂

  -- Preservation of types under reduction (aka subject reduction).
  pres* : ∀ {n} {Γ : Ctx n} {a a′ b} → Γ ⊢ a ∈ b → a →β* a′ → Γ ⊢ a′ ∈ b
  pres* a∈b  ε                = a∈b
  pres* a₁∈b (a₁→a₂ ◅ a₂→*a₃) = pres* (pres a₁∈b a₁→a₂) a₂→*a₃


module ChainRule where

  import Sets
  import Functor
  import Logic.ChainReasoning.Poly as CR
  import Isomorphism
  import Derivative

  open Derivative
  open Sets
  open Functor
  open Semantics
  open Isomorphism
  module Chain = CR _==_ (\x -> refl{x = x}) (\x y z -> trans{x = x}{y}{z})
  open Chain

  chain-rule : (F G : U)(X : Set) -> ⟦ ∂ (F [ G ]) ⟧ X ≅ ⟦ ∂ F [ G ] × ∂ G ⟧ X
  chain-rule F G X = iso (i F) (j F) (ji F) (ij F)
    where
      i : (F : U) -> ⟦ ∂ (F [ G ]) ⟧ X -> ⟦ ∂ F [ G ] × ∂ G ⟧ X
      i (K A)	  ()
      i Id	  x		    = < <> , x >
      i (F₁ + F₂) (inl c)	    = (inl <×> id) (i F₁ c)
      i (F₁ + F₂) (inr c)	    = (inr <×> id) (i F₂ c)
      i (F₁ × F₂) (inl < c  , f₂ >) = (inl ∘ <∙, f₂ > <×> id) (i F₁ c)
      i (F₁ × F₂) (inr < f₁ , c  >) = (inr ∘ < f₁ ,∙> <×> id) (i F₂ c)

      j : (F : U) -> ⟦ ∂ F [ G ] × ∂ G ⟧ X -> ⟦ ∂ (F [ G ]) ⟧ X
      j (K A)	  < () , _ >
      j Id	  < <> , x > = x
      j (F₁ + F₂) < inl x , y > = inl (j F₁ < x , y >)
      j (F₁ + F₂) < inr x , y > = inr (j F₂ < x , y >)
      j (F₁ × F₂) < inl < x , y > , z > = inl < j F₁ < x , z > , y >
      j (F₁ × F₂) < inr < x , y > , z > = inr < x , j F₂ < y , z > >

      ij : (F : U)(x : _) -> i F (j F x) == x
      ij (K A)	   < () , _ >
      ij Id	   < <> , x > = refl
      ij (F₁ + F₂) < lx@(inl x) , y > =
	subst (\ ∙ -> (inl <×> id) ∙ == < lx , y >)
	      (ij F₁ < x , y >) refl
      ij (F₁ + F₂) < rx@(inr x) , y > =
	subst (\ ∙ -> (inr <×> id) ∙ == < rx , y >)
	      (ij F₂ < x , y >) refl
      ij (F₁ × F₂) < xy@(inl < x , y >) , z > =
	subst (\ ∙ -> (inl ∘ <∙, y > <×> id) ∙ == < xy , z >)
	      (ij F₁ < x , z >) refl
      ij (F₁ × F₂) < xy@(inr < x , y >) , z > =
	subst (\ ∙ -> (inr ∘ < x ,∙> <×> id) ∙ == < xy , z >)
	      (ij F₂ < y , z >) refl

      ji : (F : U)(y : _) -> j F (i F y) == y
      ji (K A) ()
      ji Id x = refl
      ji (F₁ + F₂) (inl c) =
	chain> j (F₁ + F₂) ((inl <×> id) (i F₁ c))
	   === inl (j F₁ _)	    by cong (j (F₁ + F₂) ∘ (inl <×> id)) (η-[×] (i F₁ c))
	   === inl (j F₁ (i F₁ c))  by cong (inl ∘ j F₁) (sym $ η-[×] (i F₁ c))
	   === inl c		    by cong inl (ji F₁ c)
      ji (F₁ + F₂) rc @ (inr c) =
	subst (\ ∙ -> j (F₁ + F₂) ((inr <×> id) ∙) == rc) (η-[×] (i F₂ c))
	$ subst (\ ∙ -> inr (j F₂ ∙) == rc) (sym $ η-[×] (i F₂ c))
	$ subst (\ ∙ -> inr ∙ == rc) (ji F₂ c) refl
      ji (F₁ × F₂) l @ (inl < c , f₂ >) =
	subst (\ ∙ -> j (F₁ × F₂) ((inl ∘ <∙, f₂ > <×> id) ∙) == l) (η-[×] (i F₁ c))
	$ subst (\ ∙ -> inl < j F₁ ∙ , f₂ > == l) (sym $ η-[×] (i F₁ c))
	$ subst (\ ∙ -> inl < ∙ , f₂ > == l) (ji F₁ c) refl
      ji (F₁ × F₂) r @ (inr < f₁ , c >) =
	subst (\ ∙ -> j (F₁ × F₂) ((inr ∘ < f₁ ,∙> <×> id) ∙) == r) (η-[×] (i F₂ c))
	$ subst (\ ∙ -> inr < f₁ , j F₂ ∙ > == r) (sym $ η-[×] (i F₂ c))
	$ subst (\ ∙ -> inr < f₁ , ∙ > == r) (ji F₂ c) refl


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

open import lib.Basics
open import lib.types.Paths

module lib.types.Torus where

{-
data Torus : Type₀ where
  baseT : Torus
  loopT1 : baseT == baseT
  loopT2 : baseT == baseT
  surfT : loopT1 ∙ loopT2 == loopT2 ∙ loopT1
-}

module _ where
  private
    data #Torus-aux : Type₀ where
      #baseT : #Torus-aux

    data #Torus : Type₀ where
      #torus : #Torus-aux → (Unit → Unit) → #Torus

  Torus : Type₀
  Torus = #Torus

  baseT : Torus
  baseT = #torus #baseT _

  postulate  -- HIT
    loopT1 : baseT == baseT
    loopT2 : baseT == baseT
    surfT : loopT1 ∙ loopT2 == loopT2 ∙ loopT1

  {- Dependent elimination and computation rules -}
  module TorusElim {i} {P : Torus → Type i} (baseT* : P baseT)
    (loopT1* : baseT* == baseT* [ P ↓ loopT1 ])
    (loopT2* : baseT* == baseT* [ P ↓ loopT2 ])
    (surfT* : loopT1* ∙ᵈ loopT2* == loopT2* ∙ᵈ loopT1*
              [ (λ p → baseT* == baseT* [ P ↓ p ]) ↓ surfT ]) where

    f : Π Torus P
    f = f-aux phantom  where

      f-aux : Phantom surfT* → Π Torus P
      f-aux phantom (#torus #baseT _) = baseT*

    postulate  -- HIT
      loopT1-β : apd f loopT1 == loopT1*
      loopT2-β : apd f loopT2 == loopT2*

    private
      lhs : apd f (loopT1 ∙ loopT2) == loopT1* ∙ᵈ loopT2*
      lhs =
        apd f (loopT1 ∙ loopT2)                   =⟨ apd-∙ f loopT1 loopT2 ⟩
        apd f loopT1 ∙ᵈ apd f loopT2            =⟨ loopT1-β |in-ctx (λ u → u ∙ᵈ apd f loopT2) ⟩
        loopT1* ∙ᵈ apd f loopT2                 =⟨ loopT2-β |in-ctx (λ u → loopT1* ∙ᵈ u) ⟩
        loopT1* ∙ᵈ loopT2* ∎

      rhs : apd f (loopT2 ∙ loopT1) == loopT2* ∙ᵈ loopT1*
      rhs =
        apd f (loopT2 ∙ loopT1)                   =⟨ apd-∙ f loopT2 loopT1 ⟩
        apd f loopT2 ∙ᵈ apd f loopT1            =⟨ loopT2-β |in-ctx (λ u → u ∙ᵈ apd f loopT1) ⟩
        loopT2* ∙ᵈ apd f loopT1                 =⟨ loopT1-β |in-ctx (λ u → loopT2* ∙ᵈ u) ⟩
        loopT2* ∙ᵈ loopT1* ∎

    postulate  -- HIT
      surfT-β : apd (apd f) surfT == lhs ◃ (surfT* ▹! rhs)

module TorusRec {i} {A : Type i} (baseT* : A) (loopT1* loopT2* : baseT* == baseT*)
  (surfT* : loopT1* ∙ loopT2* == loopT2* ∙ loopT1*) where

  private
    module M = TorusElim {P = λ _ → A} baseT* (↓-cst-in loopT1*) (↓-cst-in loopT2*)
                         (↓-cst-in-∙ loopT1 loopT2 loopT1* loopT2*
                         !◃ (↓-cst-in2 surfT* ▹ (↓-cst-in-∙ loopT2 loopT1 loopT2* loopT1*)))

  f : Torus → A
  f = M.f

  loopT1-β : ap f loopT1 == loopT1*
  loopT1-β = apd=cst-in {f = f} M.loopT1-β

  loopT2-β : ap f loopT2 == loopT2*
  loopT2-β = apd=cst-in {f = f} M.loopT2-β

  private
    lhs : ap f (loopT1 ∙ loopT2) == loopT1* ∙ loopT2*
    lhs =
      ap f (loopT1 ∙ loopT2)      =⟨ ap-∙ f loopT1 loopT2 ⟩
      ap f loopT1 ∙ ap f loopT2   =⟨ loopT1-β |in-ctx (λ u → u ∙ ap f loopT2) ⟩
      loopT1* ∙ ap f loopT2       =⟨ loopT2-β |in-ctx (λ u → loopT1* ∙ u) ⟩
      loopT1* ∙ loopT2* ∎

    rhs : ap f (loopT2 ∙ loopT1) == loopT2* ∙ loopT1*
    rhs =
      ap f (loopT2 ∙ loopT1)      =⟨ ap-∙ f loopT2 loopT1 ⟩
      ap f loopT2 ∙ ap f loopT1   =⟨ loopT2-β |in-ctx (λ u → u ∙ ap f loopT1) ⟩
      loopT2* ∙ ap f loopT1       =⟨ loopT1-β |in-ctx (λ u → loopT2* ∙ u) ⟩
      loopT2* ∙ loopT1* ∎

  postulate  -- Does not look easy
    surfT-β : ap (ap f) surfT == (lhs ∙ surfT*) ∙ (! rhs)
--  surfT-β = {!M.surfT-β!}

-- module TorusRecType {i} (baseT* : Type i) (loopT1* loopT2* : baseT* ≃ baseT*)
--   (surfT* : (x : baseT*) → –> loopT2* (–> loopT2* x) == –> loopT1* (–> loopT2* x)) where

--   open TorusRec baseT* (ua loopT1*) (ua loopT2*) {!!} public
--   -- TODO


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

module function.isomorphism.utils where

open import sum
open import equality.core
open import equality.calculus
open import function.core
open import function.overloading
open import function.isomorphism.core
open import function.isomorphism.coherent
open import function.extensionality.proof
open import sets.unit
open import sets.empty
open import sets.fin.core
open import hott.level.core

Σ-split-iso : ∀ {i j}{X : Set i}{Y : X → Set j}
            → {a a' : X}{b : Y a}{b' : Y a'}
            → (Σ (a ≡ a') λ q → subst Y q b ≡ b')
            ≅ ((a , b) ≡ (a' , b'))
Σ-split-iso {Y = Y}{a}{a'}{b}{b'} = iso unapΣ apΣ H K
  where
    H : ∀ {a a'}{b : Y a}{b' : Y a'}
      → (p : Σ (a ≡ a') λ q → subst Y q b ≡ b')
      → apΣ (unapΣ {a = a}{a' = a'}{b = b}{b' = b'} p) ≡ p
    H (refl , refl) = refl

    K : (p : (a , b) ≡ (a' , b')) → unapΣ (apΣ p) ≡ p
    K = J (λ u v p → unapΣ (apΣ p) ≡ p)
          (λ {(a , b) → refl })
          (a , b) (a' , b')

×-split-iso : ∀ {i j}{X : Set i}{Y : Set j}
            → {a a' : X}{b b' : Y}
            → ((a ≡ a') × (b ≡ b'))
            ≅ ((a , b) ≡ (a' , b'))
×-split-iso {X = X}{Y} = record
  { to = λ { (p , q) → ap₂ _,_ p q }
  ; from = λ { p → (ap proj₁ p , ap proj₂ p) }
  ; iso₁ = λ { (p , q) → H p q }
  ; iso₂ = K }
  where
    H : {a a' : X}{b b' : Y}(p : a ≡ a')(q : b ≡ b')
      → (ap proj₁ (ap₂ _,_ p q), ap proj₂ (ap₂ _,_ p q)) ≡ (p , q)
    H refl refl = refl

    K : {a a' : X}{b b' : Y}(p : (a , b) ≡ (a' , b'))
      → ap₂ _,_ (ap proj₁ p) (ap proj₂ p) ≡ p
    K refl = refl

×-ap-iso : ∀ {i i' j j'}{X : Set i}{X' : Set i'}
             {Y : Set j}{Y' : Set j'}
           → (isom : X ≅ X')
           → (isom' : Y ≅ Y')
           → (X × Y) ≅ (X' × Y')
×-ap-iso isom isom' = record
  { to = λ { (x , y) → (apply isom x , apply isom' y) }
  ; from = λ { (x' , y') → (invert isom x' , invert isom' y') }
  ; iso₁ = λ { (x , y) → pair≡ (_≅_.iso₁ isom x) (_≅_.iso₁ isom' y) }
  ; iso₂ = λ { (x' , y') → pair≡ (_≅_.iso₂ isom x') (_≅_.iso₂ isom' y') } }

Σ-ap-iso₂ : ∀ {i j j'}{X : Set i}
          → {Y : X → Set j}{Y' : X → Set j'}
          → ((x : X) → Y x ≅ Y' x)
          → Σ X Y ≅ Σ X Y'
Σ-ap-iso₂ {X = X}{Y}{Y'} isom = record
  { to = λ { (x , y) → (x , apply (isom x) y) }
  ; from = λ { (x , y') → (x , invert (isom x) y') }
  ; iso₁ = λ { (x , y) → unapΣ (refl , _≅_.iso₁ (isom x) y) }
  ; iso₂ = λ { (x , y') → unapΣ (refl , _≅_.iso₂ (isom x) y') } }

Σ-ap-iso₁ : ∀ {i i' j}{X : Set i}{X' : Set i'}{Y : X' → Set j}
          → (isom : X ≅ X')
          → Σ X (Y ∘ apply isom) ≅ Σ X' Y
Σ-ap-iso₁ {X = X}{X'}{Y} isom = record
  { to = λ { (x , y) → (f x , y) }
  ; from = λ { (x , y) → (g x , subst Y (sym (K x)) y) }
  ; iso₁ = λ { (x , y) → unapΣ (H x ,
           subst-naturality Y f (H x) _
         · (subst-hom Y (sym (K (f x))) (ap f (H x)) y
         · ap (λ p → subst Y p y) (lem x) ) ) }
  ; iso₂ = λ { (x , y) → unapΣ (K x ,
           subst-hom Y (sym (K x)) (K x) y
         · ap (λ p → subst Y p y) (right-inverse (K x)) ) } }
  where
    isom-c = ≅⇒≅' isom
    γ = proj₂ isom-c
    open _≅_ (proj₁ isom-c)
      renaming ( to to f ; from to g
               ; iso₁ to H; iso₂ to K )

    lem : (x : X) → sym (K (f x)) · ap f (H x) ≡ refl
    lem x = ap (λ z → sym (K (f x)) · z) (γ x)
          · right-inverse (K (f x))

Σ-ap-iso : ∀ {i i' j j'}{X : Set i}{X' : Set i'}
           {Y : X → Set j}{Y' : X' → Set j'}
         → (isom : X ≅ X')
         → ((x : X) → Y x ≅ Y' (apply isom x))
         → Σ X Y ≅ Σ X' Y'
Σ-ap-iso {X = X}{X'}{Y}{Y'} isom isom' = trans≅
  (Σ-ap-iso₂ isom') (Σ-ap-iso₁ isom)

Σ-ap-iso' : ∀ {i i' j j'}{X : Set i}{X' : Set i'}
            {Y : X → Set j}{Y' : X' → Set j'}
          → (isom : X ≅ X')
          → ((x : X') → Y (invert isom x) ≅ Y' x)
          → Σ X Y ≅ Σ X' Y'
Σ-ap-iso' {X = X}{X'}{Y}{Y'} isom isom'
  = sym≅ (Σ-ap-iso (sym≅ isom) (λ x → sym≅ (isom' x)))

Π-ap-iso : ∀ {i i' j j'}{X : Set i}{X' : Set i'}
             {Y : X → Set j}{Y' : X' → Set j'}
           → (isom : X ≅ X')
           → ((x' : X') → Y (invert isom x') ≅ Y' x')
           → ((x : X) → Y x)
           ≅ ((x' : X') → Y' x')
Π-ap-iso {X = X}{X'}{Y}{Y'} isom isom' =
  trans≅ (Π-iso (≅⇒≅' isom)) (Π-iso' isom')
  where
    Π-iso : (isom : X ≅' X')
          → ((x : X) → Y x)
          ≅ ((x' : X') → Y (invert (proj₁ isom) x'))
    Π-iso (iso f g H K , γ) = record
      { to = λ h x' → h (g x')
      ; from = λ h' x → subst Y (H x) (h' (f x))
      ; iso₁ = λ h → funext λ x → ap' h (H x)
      ; iso₂ = λ h' → funext λ x' →
              ap (λ p → subst Y p _) (sym (γ' x'))
            · sym (subst-naturality Y g (K x') _)
            · ap' h' (K x') }
      where γ' = co-coherence (iso f g H K) γ

    Π-iso' : ∀ {i j j'}{X : Set i}
             {Y : X → Set j}{Y' : X → Set j'}
           → ((x : X) → Y x ≅ Y' x)
           → ((x : X) → Y x)
           ≅ ((x : X) → Y' x)
    Π-iso' isom = record
      { to = λ h x → apply (isom x) (h x)
      ; from = λ h' x → invert (isom x) (h' x)
      ; iso₁ = λ h → funext λ x → _≅_.iso₁ (isom x) _
      ; iso₂ = λ h' → funext λ x → _≅_.iso₂ (isom x) _ }

ΠΣ-swap-iso : ∀ {i j k}{X : Set i}{Y : X → Set j}
            → {Z : (x : X) → Y x → Set k}
            → ((x : X) → Σ (Y x) λ y → Z x y)
            ≅ (Σ ((x : X) → Y x) λ f → ((x : X) → Z x (f x)))
ΠΣ-swap-iso = record
  { to = λ f → (proj₁ ∘' f , proj₂ ∘' f)
  ; from = λ { (f , g) x → (f x , g x) }
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

curry-iso : ∀ {i j k}{X : Set i}{Y : X → Set j}
            (Z : (x : X) → Y x → Set k)
          → ((xy : Σ X Y) → Z (proj₁ xy) (proj₂ xy))
          ≅ ((x : X) → (y : Y x) → Z x y)
curry-iso _ = record
  { to = λ f x y → f (x , y)
  ; from = λ { f (x , y) → f x y }
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

Π-comm-iso : ∀ {i j k}{X : Set i}{Y : Set j}{Z : X → Y → Set k}
           → ((x : X)(y : Y) → Z x y)
           ≅ ((y : Y)(x : X) → Z x y)
Π-comm-iso = record
  { to = λ f y x → f x y
  ; from = λ f x y → f y x
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

Σ-comm-iso : ∀ {i j k}{X : Set i}{Y : Set j}{Z : X → Y → Set k}
           → (Σ X λ x → Σ Y λ y → Z x y)
           ≅ (Σ Y λ y → Σ X λ x → Z x y)
Σ-comm-iso = record
  { to = λ { (x , y , z) → (y , x , z) }
  ; from = λ { (y , x , z) → (x , y , z) }
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

impl-iso : ∀ {i j}{X : Set i}{Y : X → Set j}
         → ((x : X) → Y x) ≅ ({x : X} → Y x)
impl-iso = record
  { to = λ f → f _
  ; from = λ f _ → f
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

Σ-assoc-iso : ∀ {i j k}
              {X : Set i}{Y : X → Set j}
              {Z : (x : X) → Y x → Set k}
            → Σ (Σ X Y) (λ {(x , y) → Z x y})
            ≅ Σ X λ x → Σ (Y x) (Z x)
Σ-assoc-iso = record
  { to = λ {((x , y) , z) → (x , y , z) }
  ; from = λ {(x , y , z) → ((x , y) , z) }
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

⊎-Σ-iso : ∀ {i}(X : Fin 2 → Set i)
        → (X zero ⊎ X (suc zero))
        ≅ Σ (Fin 2) X
⊎-Σ-iso X = record
  { to = λ { (inj₁ x) → zero , x
           ; (inj₂ x) → suc zero , x }
  ; from = λ { (zero , x) → inj₁ x
             ; (suc zero , x) → inj₂ x
             ; (suc (suc ()) , _) }
  ; iso₁ = λ { (inj₁ x) → refl
             ; (inj₂ x) → refl }
  ; iso₂ = λ { (zero , x) → refl
             ; (suc zero , x) → refl
             ; (suc (suc ()) , _) } }

⊎-ap-iso : ∀ {i j i' j'}
         → {X : Set i}{X' : Set i'}
         → {Y : Set j}{Y' : Set j'}
         → X ≅ X'
         → Y ≅ Y'
         → (X ⊎ Y) ≅ (X' ⊎ Y')
⊎-ap-iso (iso f g α β) (iso f' g' α' β') = record
  { to = λ { (inj₁ x) → inj₁ (f x) ; (inj₂ y) → inj₂ (f' y) }
  ; from = λ { (inj₁ x) → inj₁ (g x) ; (inj₂ y) → inj₂ (g' y) }
  ; iso₁ = λ { (inj₁ x) → ap inj₁ (α x) ; (inj₂ y) → ap inj₂ (α' y) }
  ; iso₂ = λ { (inj₁ x) → ap inj₁ (β x) ; (inj₂ y) → ap inj₂ (β' y) } }

⊎-assoc-iso : ∀ {i j k}
            → {X : Set i}{Y : Set j}{Z : Set k}
            → ((X ⊎ Y) ⊎ Z)
            ≅ (X ⊎ (Y ⊎ Z))
⊎-assoc-iso = record
  { to = λ { (inj₁ (inj₁ x)) → inj₁ x
           ; (inj₁ (inj₂ y)) → inj₂ (inj₁ y)
           ; (inj₂ z) → inj₂ (inj₂ z) }
  ; from = λ { (inj₁ x) → inj₁ (inj₁ x)
             ; (inj₂ (inj₁ y)) → inj₁ (inj₂ y)
             ; (inj₂ (inj₂ z)) → inj₂ z }
  ; iso₁ = λ { (inj₁ (inj₁ x)) → refl
             ; (inj₁ (inj₂ y)) → refl
             ; (inj₂ z) → refl }
  ; iso₂ = λ { (inj₁ x) → refl
             ; (inj₂ (inj₁ y)) → refl
             ; (inj₂ (inj₂ z)) → refl } }

⊎×-distr-iso : ∀ {i j k}
             → {X : Set i}{Y : Set j}{Z : Set k}
             → ((X ⊎ Y) × Z)
             ≅ ((X × Z) ⊎ (Y × Z))
⊎×-distr-iso = record
  { to = λ { (inj₁ x , z) → inj₁ (x , z)
           ; (inj₂ y , z) → inj₂ (y , z) }
  ; from = λ { (inj₁ (x , z)) → inj₁ x , z
             ; (inj₂ (y , z)) → inj₂ y , z }
  ; iso₁ = λ { (inj₁ x , z) → refl
             ; (inj₂ y , z) → refl }
  ; iso₂ = λ { (inj₁ (x , z)) → refl
             ; (inj₂ (y , z)) → refl } }

⊎-universal : ∀ {i j k}{X : Set i}{Y : Set j}
            → {Z : X ⊎ Y → Set k}
            → ((u : X ⊎ Y) → Z u)
            ≅ (((x : X) → Z (inj₁ x)) × ((y : Y) → Z (inj₂ y)))
⊎-universal = record
  { to = λ f → (f ∘' inj₁ , f ∘' inj₂)
  ; from = λ { (g₁ , g₂) (inj₁ x) → g₁ x
             ; (g₁ , g₂) (inj₂ y) → g₂ y }
  ; iso₁ = λ f → funext λ
      { (inj₁ x) → refl
      ; (inj₂ x) → refl }
  ; iso₂ = λ { (g₁ , g₂) → refl } }

×-left-unit : ∀ {i}{X : Set i} → (⊤ × X) ≅ X
×-left-unit = record
  { to = λ {(tt , x) → x }
  ; from = λ x → tt , x
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

×-right-unit : ∀ {i}{X : Set i} → (X × ⊤) ≅ X
×-right-unit = record
  { to = λ {(x , tt) → x }
  ; from = λ x → x , tt
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

contr-⊤-iso : ∀ {i}{X : Set i}
            → contr X → X ≅ ⊤
contr-⊤-iso hX = record
  { to = λ x → tt
  ; from = λ { tt → proj₁ hX }
  ; iso₁ = λ x → proj₂ hX x
  ; iso₂ = λ { tt → refl } }

empty-⊥-iso : ∀ {i}{X : Set i}
            → (X → ⊥) → X ≅ ⊥
empty-⊥-iso u = record
  { to = u
  ; from = ⊥-elim
  ; iso₁ = λ x → ⊥-elim (u x)
  ; iso₂ = λ () }

×-comm : ∀ {i j}{X : Set i}{Y : Set j}
       → (X × Y) ≅ (Y × X)
×-comm = record
  { to = λ {(x , y) → (y , x)}
  ; from = λ {(y , x) → (x , y)}
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl }

Π-left-unit : ∀ {i}{X : Set i}
            → (⊤ → X) ≅ X
Π-left-unit = record
  { to = λ f → f tt
  ; from = λ x _ → x
  ; iso₁ = λ _ → refl
  ; iso₂ = λ f → refl }

-- rewriting lemmas for equations on equalities
sym≡-iso : ∀ {i}{X : Set i}(x y : X)
         → (x ≡ y)
         ≅ (y ≡ x)
sym≡-iso _ _ = iso sym sym double-inverse double-inverse

trans≡-iso : ∀ {i}{X : Set i}{x y z : X}
           → (x ≡ y)
           → (y ≡ z) ≅ (x ≡ z)
trans≡-iso p = record
  { to = λ q → p · q
  ; from = λ q → sym p · q
  ; iso₁ = λ q → sym (associativity (sym p) p q)
                · ap (λ z → z · q) (right-inverse p)
  ; iso₂ = λ q → sym (associativity p (sym p) q)
                · ap (λ z → z · q) (left-inverse p) }

trans≡-iso' : ∀ {i}{X : Set i}{x y z : X}
            → (y ≡ z)
            → (x ≡ y) ≅ (x ≡ z)
trans≡-iso' q = record
  { to = λ p → p · q
  ; from = λ p → p · sym q
  ; iso₁ = λ p → associativity p q (sym q)
               · ap (_·_ p) (left-inverse q)
               · left-unit p
  ; iso₂ = λ p → associativity p (sym q) q
               · (ap (_·_ p) (right-inverse q)
               · left-unit p) }

move-≡-iso : ∀ {i}{X : Set i}{x y z : X}
           → (p : x ≡ y)(q : y ≡ z)(r : x ≡ z)
           → (p · q ≡ r)
           ≅ (sym p · r ≡ q)
move-≡-iso refl = sym≡-iso

J-iso : ∀ {i j}{X : Set i}{x : X}
      → {P : (y : X) → x ≡ y → Set j}
      → P x refl
      ≅ ((y : X)(p : x ≡ y) → P y p)
J-iso {X = X}{x}{P} = record
  { to = J' P
  ; from = λ u → u x refl
  ; iso₁ = λ _ → refl
  ; iso₂ = λ u → funext λ y → funext λ p → β u y p }
  where
    β : (u : (y : X)(p : x ≡ y) → P y p)
      → (y : X)(p : x ≡ y)
      → J' P (u x refl) y p ≡ u y p
    β u .x refl = refl


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

module Data.Maybe.Base where

open import Level

data Maybe (A : Type a) : Type a where
  nothing : Maybe A
  just : A → Maybe A

maybe : {B : Maybe A → Type b} → B nothing → ((x : A) → B (just x)) → (x : Maybe A) → B x
maybe b f nothing = b
maybe b f (just x) = f x


open import Nat
open import Prelude
open import dynamics-core
open import contexts

open import progress
open import htype-decidable
open import lemmas-complete

module complete-progress where

  -- as in progress, we define a datatype for the possible outcomes of
  -- progress for readability.
  data okc : (d : ihexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → okc d Δ
    S : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → okc d Δ

  complete-progress : {Δ : hctx} {d : ihexp} {τ : htyp} →
                       Δ , ∅ ⊢ d :: τ →
                       d dcomplete →
                       okc d Δ
  complete-progress wt comp with progress wt
  complete-progress wt comp | I x = abort (lem-ind-comp comp x)
  complete-progress wt comp | S x = S x
  complete-progress wt comp | BV (BVVal x) = V x
  complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁)
  complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (x₁ (complete-consistency x x₃ x₄))
  complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVSumCast x₁ x₂) = abort (x₁ (complete-consistency x x₃ x₄))
  complete-progress (TAInl wt) (DCInl x₁ comp) | BV (BVInl x)
    with complete-progress wt comp
  ... | V v = V (VInl v)
  ... | S (_ , Step x₂ x₃ x₄) = S (_ , Step (FHInl x₂) x₃ (FHInl x₄))
  complete-progress (TAInr wt) (DCInr x₁ comp) | BV (BVInr x)
    with complete-progress wt comp
  ... | V v = V (VInr v)
  ... | S (_ , Step x₂ x₃ x₄) = S (_ , Step (FHInr x₂) x₃ (FHInr x₄))
  complete-progress (TAPair wt wt₁) (DCPair comp comp₁) | BV (BVPair x x₁)
    with complete-progress wt comp | complete-progress wt₁ comp₁
  ... | V v | V v₁ = V (VPair v v₁)
  ... | V v | S (_ , Step x₁ x₂ x₃) = S (_ , Step (FHPair2 x₁) x₂ (FHPair2 x₃))
  ... | S (_ , Step x₁ x₂ x₃) | V v = S (_ , Step (FHPair1 x₁) x₂ (FHPair1 x₃))
  ... | S (_ , Step x₁ x₂ x₃) | S (_ , Step x₄ x₅ x₆) = S (_ , Step (FHPair1 x₁) x₂ (FHPair1 x₃))
  complete-progress (TACast wt x₁) (DCCast comp x₂ x₃) | BV (BVProdCast x x₄) = abort (x (complete-consistency x₁ x₂ x₃))


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

module Categories.Diagram.Limit.Ran where

open import Level
open import Data.Product using (Σ)

open import Categories.Category
open import Categories.Category.Complete
open import Categories.Category.Construction.Cones
open import Categories.Category.Construction.Comma
open import Categories.Category.Construction.Properties.Comma
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Limit.Properties
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.Functor.Construction.Constant
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.Equivalence using () renaming (_≃_ to _≊_)
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism; _≃_; module ≃; _ⓘˡ_)
open import Categories.Kan
open import Categories.Diagram.Limit

import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D E : Category o ℓ e

-- construct a Ran from a limit
module _ {o ℓ e o′ ℓ′ e′} {C : Category o′ ℓ′ e′} {D : Category o ℓ e}
         (F : Functor C D) (X : Functor C E) (Com : Complete (o′ ⊔ ℓ) (ℓ′ ⊔ e) e′ E) where
  private
    module C = Category C
    module D = Category D
    module E = Category E
    module F = Functor F
    module X = Functor X
    open Limit
    open Cone renaming (commute to K-commute)
    open Cone⇒ renaming (commute to ⇒-commute)
    open Mor E

    G   : (d : D.Obj) → Functor (d ↙ F) E
    G d   = X ∘F Cod (const! d) F
    ⊤Gd : ∀ d → Limit (G d)
    ⊤Gd d = Com (G d)
    module ⊤Gd d = Limit (⊤Gd d)
    f↙F : ∀ {Y Z} (f : Y D.⇒ Z) → Functor (Z ↙ F) (Y ↙ F)
    f↙F   = along-natˡ′ F

    Gf≃ : ∀ {Y Z} (f : Y D.⇒ Z) → G Z ≃ G Y ∘F f↙F f
    Gf≃ f = record
      { F⇒G = ntHelper record
        { η       = λ _ → X.F₁ C.id
        ; commute = λ _ → [ X ]-resp-square id-comm-sym
        }
      ; F⇐G = ntHelper record
        { η       = λ _ → X.F₁ C.id
        ; commute = λ _ → [ X ]-resp-square id-comm-sym
        }
      ; iso = λ _ → record
        { isoˡ = [ X ]-resp-∘ C.identity² ○ X.identity
        ; isoʳ = [ X ]-resp-∘ C.identity² ○ X.identity
        }
      }
      where open MR C
            open E.HomReasoning

    limY⇒limZ∘ : ∀ {Y Z} (f : Y D.⇒ Z) → Cones (G Y ∘F f↙F f) [ F-map-Coneʳ (f↙F f) (limit (Com (G Y))) , limit (Com (G Y ∘F f↙F f)) ]
    limY⇒limZ∘ {Y} f     = F⇒arr Com (f↙F f) (G Y)
    limZ∘≅limZ : ∀ {Y Z} (f : Y D.⇒ Z) → apex (⊤Gd Z) ≅ apex (Com (G Y ∘F f↙F f))
    limZ∘≅limZ {Y} {Z} f = ≃⇒lim≅ (Gf≃ f) (⊤Gd Z) (Com _)

  limit-is-ran : Ran F X
  limit-is-ran = record
    { R        = R
    ; ε        = ε
    ; δ        = δ
    ; δ-unique = λ {M γ} δ′ eq → δ-unique {M} {γ} δ′ eq
    ; commutes = commutes
    }
    where open MR E
          open E.HomReasoning
          open D.HomReasoning using () renaming (_○_ to _●_ ; ⟺ to ⟷)

          R₀ : D.Obj → E.Obj
          R₀ d = apex (⊤Gd d)
          R₁ : ∀ {A B} → D [ A , B ] → E [ R₀ A , R₀ B ]
          R₁ {A} f = _≅_.to (limZ∘≅limZ f) E.∘ arr (limY⇒limZ∘ f)

          proj-red : ∀ {Y Z} K (f : Y D.⇒ Z) → ⊤Gd.proj Z K E.∘ R₁ f E.≈ ⊤Gd.proj Y (record { f = D.id D.∘ CommaObj.f K D.∘ f })
          proj-red {Y} {Z} K f = begin
            ⊤Gd.proj Z K E.∘ R₁ f                                 ≈⟨ pullˡ (⇒-commute (≃⇒Cone⇒ (≃.sym (Gf≃ f)) (Com _) (⊤Gd Z))) ⟩
            (X.F₁ C.id E.∘ proj (Com _) K) E.∘ arr (limY⇒limZ∘ f) ≈⟨ pullʳ (⇒-commute (limY⇒limZ∘ f)) ⟩
            X.F₁ C.id E.∘ ⊤Gd.proj Y _                            ≈⟨ elimˡ X.identity ⟩
            ⊤Gd.proj Y _                                          ∎

          proj≈ : ∀ {d b} {f g : d D.⇒ F.F₀ b} → f D.≈ g → ⊤Gd.proj d record { f = f } E.≈ ⊤Gd.proj d record { f = g }
          proj≈ {d} {b} {f} {g} eq = begin
            ⊤Gd.proj d _               ≈⟨ introˡ X.identity ⟩
            X.F₁ C.id E.∘ ⊤Gd.proj d _ ≈⟨ K-commute _ (⊤Gd.limit d) (record { h = C.id ; commute = D.∘-resp-≈ F.identity eq ● MR.id-comm-sym D }) ⟩
            ⊤Gd.proj d _               ∎

          R : Functor D E
          R = record
            { F₀           = R₀
            ; F₁           = R₁
            ; identity     = λ {d} → terminal.⊤-id (⊤Gd d) record
              { commute = λ {Z} → begin
                ⊤Gd.proj d Z ∘ R₁ D.id                                   ≈⟨ proj-red Z D.id ⟩
                ⊤Gd.proj d record { f = D.id D.∘ CommaObj.f Z D.∘ D.id } ≈⟨ proj≈ (D.identityˡ ● D.identityʳ) ⟩
                ⊤Gd.proj d Z                                             ∎
              }
            ; homomorphism = λ {Y Z W} {f g} →
              terminal.!-unique₂ (⊤Gd W)
                {let module ⊤GY = Cone _ (⊤Gd.limit Y)
                     module H   = Functor (f↙F (g D.∘ f))
                 in record
                 { apex = record
                   { ψ       = λ K → ⊤GY.ψ (H.F₀ K)
                   ; commute = λ h → ⊤GY.commute (H.F₁ h)
                   }
                 }}
                {record
                  { arr     = R₁ (g D.∘ f)
                  ; commute = λ {K} → proj-red K (g D.∘ f)
                  }}
                {record
                  { arr     = R₁ g ∘ R₁ f
                  ; commute = λ {K} → begin
                    ⊤Gd.proj W K ∘ R₁ g ∘ R₁ f
                      ≈⟨ sym-assoc ⟩
                    (⊤Gd.proj W K ∘ R₁ g) ∘ R₁ f
                      ≈⟨ proj-red K g ⟩∘⟨refl ⟩
                    ⊤Gd.proj Z record { f = D.id D.∘ CommaObj.f K D.∘ g } ∘ R₁ f
                      ≈⟨ proj-red _ f ⟩
                    ⊤Gd.proj Y record { f = D.id D.∘ (D.id D.∘ CommaObj.f K D.∘ g) D.∘ f }
                      ≈⟨ proj≈ (D.identityˡ ● (MR.assoc²' D)) ⟩
                    ⊤Gd.proj Y record { f = D.id D.∘ CommaObj.f K D.∘ g D.∘ f }
                      ∎
                  }}
            ; F-resp-≈     = λ {Y Z} {f g} eq →
              terminal.!-unique₂ (⊤Gd Z)
                {let module ⊤GY = Cone _ (⊤Gd.limit Y)
                     module H = Functor (f↙F f)
                 in record
                    { apex = record
                      { ψ       = λ K → ⊤GY.ψ (H.F₀ K)
                      ; commute = λ h → ⊤GY.commute (H.F₁ h)
                      }
                    }}
                {record
                  { arr     = R₁ f
                  ; commute = F-resp-≈-commute D.Equiv.refl
                  }}
                {record
                  { arr     = R₁ g
                  ; commute = F-resp-≈-commute eq
                  }}
            }
            where open E
                  F-resp-≈-commute : ∀ {Y Z} {K : Category.Obj (Z ↙ F)} {f g : Y D.⇒ Z} → f D.≈ g →
                                       ⊤Gd.proj Z K ∘ R₁ g ≈ ⊤Gd.proj Y record { f = D.id D.∘ CommaObj.f K D.∘ f }
                  F-resp-≈-commute {Y} {Z} {K} {f} {g} eq = begin
                    ⊤Gd.proj Z K ∘ R₁ g ≈⟨ proj-red K g ⟩
                    ⊤Gd.proj Y _        ≈⟨ proj≈ (D.∘-resp-≈ʳ (D.∘-resp-≈ʳ (D.Equiv.sym eq))) ⟩
                    ⊤Gd.proj Y _        ∎

          ε : NaturalTransformation (R ∘F F) X
          ε = ntHelper record
            { η       = λ c → ⊤Gd.proj (F.F₀ c) record { f = D.id }
            ; commute = λ {Y Z} f → begin
              ⊤Gd.proj (F.F₀ Z) _ ∘ Functor.F₁ (R ∘F F) f ≈⟨ proj-red _ (F.F₁ f) ⟩
              ⊤Gd.proj (F.F₀ Y) _                         ≈˘⟨ K-commute _ (⊤Gd.limit (F.F₀ Y)) record { h = f ; commute = ⟷ (D.∘-resp-≈ˡ D.identityˡ ● D.∘-resp-≈ˡ D.identityˡ) } ⟩
              X.F₁ f ∘ ⊤Gd.proj (F.F₀ Y) _                ∎
            }
            where open E

          δ-Cone : ∀ d (M : Functor D E) → NaturalTransformation (M ∘F F) X → Cone (G d)
          δ-Cone d M γ = record
            { apex = record
              { ψ       = λ K → γ.η (CommaObj.β K) E.∘ M.F₁ (CommaObj.f K)
              ; commute = λ {Y Z} f → begin
                X.F₁ (Comma⇒.h f) E.∘ γ.η (CommaObj.β Y) E.∘ M.F₁ (CommaObj.f Y)
                  ≈˘⟨ pushˡ (γ.commute (Comma⇒.h f)) ⟩
                (γ.η (CommaObj.β Z) E.∘ M.F₁ (F.F₁ (Comma⇒.h f))) E.∘ M.F₁ (CommaObj.f Y)
                  ≈⟨ pullʳ ([ M ]-resp-∘ (Comma⇒.commute f ● D.identityʳ)) ⟩
                γ.η (CommaObj.β Z) E.∘ M.F₁ (CommaObj.f Z)
                  ∎
              }
            }
            where module M = Functor M
                  module γ = NaturalTransformation γ

          δ : (M : Functor D E) → NaturalTransformation (M ∘F F) X → NaturalTransformation M R
          δ M γ = ntHelper record
            { η       = λ d → ⊤Gd.rep d (δ-Cone d M γ)
            ; commute = λ {Y Z} f →
              terminal.!-unique₂ (⊤Gd Z)
                {record
                  { apex = record
                    { ψ       = λ W → δ-Cone.ψ Z W E.∘ M.F₁ f
                    ; commute = λ {W V} g → begin
                      X.F₁ (Comma⇒.h g) E.∘ (γ.η (CommaObj.β W) E.∘ M.F₁ (CommaObj.f W)) E.∘ M.F₁ f
                        ≈⟨ E.sym-assoc ⟩
                      (X.F₁ (Comma⇒.h g) E.∘ γ.η (CommaObj.β W) E.∘ M.F₁ (CommaObj.f W)) E.∘ M.F₁ f
                        ≈⟨ δ-Cone.commute Z g ⟩∘⟨refl ⟩
                      (γ.η (CommaObj.β V) E.∘ M.F₁ (CommaObj.f V)) E.∘ M.F₁ f
                        ∎
                    }
                  }}
                {record
                  { arr     = ⊤Gd.rep Z (δ-Cone Z M γ) E.∘ M.F₁ f
                  ; commute = pullˡ (⇒-commute (⊤Gd.rep-cone Z (δ-Cone Z M γ)))
                  }}
                {record
                  { arr     = R₁ f E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)
                  ; commute = λ {W} → begin
                    ⊤Gd.proj Z W E.∘ R₁ f E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)
                      ≈⟨ pullˡ (proj-red W f) ⟩
                    ⊤Gd.proj Y (record { f = D.id D.∘ CommaObj.f W D.∘ f }) E.∘ ⊤Gd.rep Y (δ-Cone Y M γ)
                      ≈⟨ ⇒-commute (⊤Gd.rep-cone Y (δ-Cone Y M γ)) ⟩
                    γ.η (CommaObj.β W) E.∘ M.F₁ (D.id D.∘ CommaObj.f W D.∘ f)
                      ≈˘⟨ refl⟩∘⟨ [ M ]-resp-∘ (⟷ D.identityˡ) ⟩
                    γ.η (CommaObj.β W) E.∘ M.F₁ (CommaObj.f W) E.∘ M.F₁ f
                      ≈⟨ E.sym-assoc ⟩
                    (γ.η (CommaObj.β W) E.∘ M.F₁ (CommaObj.f W)) E.∘ M.F₁ f
                      ∎
                  }}
            }
            where module M        = Functor M
                  module γ        = NaturalTransformation γ
                  module δ-Cone d = Cone _ (δ-Cone d M γ)

          δ-unique : ∀ {M : Functor D E} {α : NaturalTransformation (M ∘F F) X}
                       (δ′ : NaturalTransformation M R) → α ≊ ε ∘ᵥ δ′ ∘ʳ F → δ′ ≊ δ M α
          δ-unique {M} {γ} δ′ eq {d} = ⟺ (⊤Gd.terminal.!-unique d record
            { arr     = δ′.η d
            ; commute = λ {W} → begin
              ⊤Gd.proj d W E.∘ δ′.η d
                ≈˘⟨ proj≈ (D.identityˡ ● D.identityˡ) ⟩∘⟨refl ⟩
              ⊤Gd.proj d (record { f = D.id D.∘ D.id D.∘ CommaObj.f W }) E.∘ δ′.η d
                ≈˘⟨ pullˡ (proj-red _ (CommaObj.f W)) ⟩
              ⊤Gd.proj (F.F₀ (CommaObj.β W)) _ E.∘ R₁ (CommaObj.f W) E.∘ δ′.η d
                ≈˘⟨ pullʳ (δ′.commute (CommaObj.f W)) ⟩
              (⊤Gd.proj (F.F₀ (CommaObj.β W)) (record { f = D.id}) E.∘ δ′.η (F.F₀ (CommaObj.β W))) E.∘ M.F₁ (CommaObj.f W)
                ≈˘⟨ eq ⟩∘⟨refl ⟩
              γ.η (CommaObj.β W) E.∘ M.F₁ (CommaObj.f W)
                ∎
            })
            where module M  = Functor M
                  module γ  = NaturalTransformation γ
                  module δ′ = NaturalTransformation δ′

          commutes : (M : Functor D E) (α : NaturalTransformation (M ∘F F) X) → α ≊ ε ∘ᵥ δ M α ∘ʳ F
          commutes M γ {c} = ⟺ (⇒-commute (⊤Gd.rep-cone (F.F₀ c) (δ-Cone (F.F₀ c) M γ)) ○ elimʳ M.identity)
            where module M  = Functor M
                  module γ  = NaturalTransformation γ