{-# OPTIONS --cubical --safe --postfix-projections #-}

open import Prelude
open import Relation.Binary

module Relation.Binary.Construct.Bounded {e} {E : Type e} {r₁ r₂} (totalOrder : TotalOrder E r₁ r₂) where

open TotalOrder totalOrder renaming (refl to ≤-refl)
import Data.Unit.UniversePolymorphic as Poly
import Data.Empty.UniversePolymorphic as Poly

data [∙] : Type e where
  [⊥] [⊤] : [∙]
  [_] : E → [∙]

_[≤]_ : [∙] → [∙] → Type _
[⊥]   [≤] _     = Poly.⊤
_     [≤] [⊤]   = Poly.⊤
[⊤]   [≤] _     = Poly.⊥
_     [≤] [⊥]   = Poly.⊥
[ x ] [≤] [ y ] = x ≤ y

_[<]_ : [∙] → [∙] → Type _
[⊤]   [<] _     = Poly.⊥
_     [<] [⊥]   = Poly.⊥
[⊥]   [<] _     = Poly.⊤
_     [<] [⊤]   = Poly.⊤
[ x ] [<] [ y ] = x < y

b-pord : PartialOrder [∙] _
b-pord .PartialOrder.preorder .Preorder._≤_ = _[≤]_
b-pord .PartialOrder.preorder .Preorder.refl {[⊥]} = Poly.tt
b-pord .PartialOrder.preorder .Preorder.refl {[⊤]} = Poly.tt
b-pord .PartialOrder.preorder .Preorder.refl {[ x ]} = ≤-refl
b-pord .PartialOrder.preorder .Preorder.trans {[⊥]} {y} {z} x≤y y≤z = Poly.tt
b-pord .PartialOrder.preorder .Preorder.trans {[⊤]} {[⊤]} {[⊤]} x≤y y≤z = Poly.tt
b-pord .PartialOrder.preorder .Preorder.trans {[ x ]} {[⊤]} {[⊤]} x≤y y≤z = Poly.tt
b-pord .PartialOrder.preorder .Preorder.trans {[ x ]} {[ y ]} {[⊤]} x≤y y≤z = Poly.tt
b-pord .PartialOrder.preorder .Preorder.trans {[ x ]} {[ y ]} {[ z ]} x≤y y≤z = ≤-trans x≤y y≤z
b-pord .PartialOrder.antisym {[⊥]} {[⊥]} x≤y y≤x i = [⊥]
b-pord .PartialOrder.antisym {[⊤]} {[⊤]} x≤y y≤x i = [⊤]
b-pord .PartialOrder.antisym {[ x ]} {[ y ]} x≤y y≤x i = [ antisym x≤y y≤x i ]

b-sord : StrictPartialOrder [∙] _
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder._<_ = _[<]_
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder.trans {[⊥]} {[ x ]} {[⊤]} x<y y<z = Poly.tt
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder.trans {[⊥]} {[ x ]} {[ x₁ ]} x<y y<z = Poly.tt
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder.trans {[ x ]} {[ x₁ ]} {[⊤]} x<y y<z = Poly.tt
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder.trans {[ x ]} {[ x₁ ]} {[ x₂ ]} x<y y<z = <-trans x<y y<z
b-sord .StrictPartialOrder.strictPreorder .StrictPreorder.irrefl {[ x ]} x<x = irrefl x<x
b-sord .StrictPartialOrder.conn {[⊥]} {[⊥]} x≮y y≮x = refl
b-sord .StrictPartialOrder.conn {[⊥]} {[⊤]} x≮y y≮x = ⊥-elim (x≮y Poly.tt)
b-sord .StrictPartialOrder.conn {[⊥]} {[ x ]} x≮y y≮x = ⊥-elim (x≮y Poly.tt)
b-sord .StrictPartialOrder.conn {[⊤]} {[⊥]} x≮y y≮x = ⊥-elim (y≮x Poly.tt)
b-sord .StrictPartialOrder.conn {[⊤]} {[⊤]} x≮y y≮x = refl
b-sord .StrictPartialOrder.conn {[⊤]} {[ x ]} x≮y y≮x = ⊥-elim (y≮x Poly.tt)
b-sord .StrictPartialOrder.conn {[ x ]} {[⊥]} x≮y y≮x = ⊥-elim (y≮x Poly.tt)
b-sord .StrictPartialOrder.conn {[ x ]} {[⊤]} x≮y y≮x = ⊥-elim (x≮y Poly.tt)
b-sord .StrictPartialOrder.conn {[ x ]} {[ x₁ ]} x≮y y≮x = cong [_] (conn x≮y y≮x)

b-ord : TotalOrder [∙] _ _
b-ord .TotalOrder.strictPartialOrder = b-sord
b-ord .TotalOrder.partialOrder = b-pord
b-ord .TotalOrder._<?_ [⊥] [⊥] = no λ ()
b-ord .TotalOrder._<?_ [⊥] [⊤] = yes _
b-ord .TotalOrder._<?_ [⊥] [ y ] = yes _
b-ord .TotalOrder._<?_ [⊤] [⊥] = no λ ()
b-ord .TotalOrder._<?_ [⊤] [⊤] = no λ ()
b-ord .TotalOrder._<?_ [⊤] [ y ] = no λ ()
b-ord .TotalOrder._<?_ [ x ] [⊥] = no λ ()
b-ord .TotalOrder._<?_ [ x ] [⊤] = yes _
b-ord .TotalOrder._<?_ [ x ] [ y ] = x <? y
b-ord .TotalOrder.≰⇒> {[⊥]} {y} x≰y = ⊥-elim (x≰y Poly.tt)
b-ord .TotalOrder.≰⇒> {[⊤]} {[⊥]} x≰y = Poly.tt
b-ord .TotalOrder.≰⇒> {[⊤]} {[⊤]} x≰y = ⊥-elim (x≰y Poly.tt)
b-ord .TotalOrder.≰⇒> {[⊤]} {[ x ]} x≰y = Poly.tt
b-ord .TotalOrder.≰⇒> {[ x ]} {[⊥]} x≰y = Poly.tt
b-ord .TotalOrder.≰⇒> {[ x ]} {[⊤]} x≰y = ⊥-elim (x≰y Poly.tt)
b-ord .TotalOrder.≰⇒> {[ x ]} {[ x₁ ]} x≰y = ≰⇒> x≰y
b-ord .TotalOrder.≮⇒≥ {x} {[⊥]} x≮y = Poly.tt
b-ord .TotalOrder.≮⇒≥ {[⊥]} {[⊤]} x≮y = ⊥-elim (x≮y Poly.tt)
b-ord .TotalOrder.≮⇒≥ {[⊤]} {[⊤]} x≮y = Poly.tt
b-ord .TotalOrder.≮⇒≥ {[ x ]} {[⊤]} x≮y = ⊥-elim (x≮y Poly.tt)
b-ord .TotalOrder.≮⇒≥ {[⊥]} {[ x₁ ]} x≮y = ⊥-elim (x≮y Poly.tt)
b-ord .TotalOrder.≮⇒≥ {[⊤]} {[ x₁ ]} x≮y = Poly.tt
b-ord .TotalOrder.≮⇒≥ {[ x ]} {[ y ]} x≮y = ≮⇒≥ x≮y


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

-- The identity pseudofunctor

module Categories.Pseudofunctor.Identity where

open import Data.Product using (_,_)

open import Categories.Bicategory using (Bicategory)
import Categories.Bicategory.Extras as BicategoryExt
open import Categories.Category using (Category)
open import Categories.Category.Instance.One using (shift)
open import Categories.Category.Product using (_⁂_)
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
import Categories.Morphism.Reasoning as MorphismReasoning
open import Categories.NaturalTransformation using (NaturalTransformation)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; _≃_; niHelper)
open import Categories.Pseudofunctor using (Pseudofunctor)

open Category using (module HomReasoning)
open NaturalIsomorphism using (F⇒G; F⇐G)

-- The identity pseudofunctor

idP : ∀ {o ℓ e t} {C : Bicategory o ℓ e t} → Pseudofunctor C C
idP {o} {ℓ} {e} {t} {C = C} = record
  { P₀             = λ x → x
  ; P₁             = idF
  ; P-identity     = P-identity
  ; P-homomorphism = P-homomorphism
  ; unitaryˡ       = unitaryˡ
  ; unitaryʳ       = unitaryʳ
  ; assoc          = assoc
  }
  where
    open BicategoryExt C

    P-identity : ∀ {x} → id {x} ∘F shift o ℓ e ≃ idF ∘F id
    P-identity {x} = niHelper (record
      { η       = λ _ → id₂
      ; η⁻¹     = λ _ → id₂
      ; commute = λ _ → MorphismReasoning.id-comm-sym (hom x x)
      ; iso     = λ _ → record { isoˡ = hom.identity² ; isoʳ = hom.identity² }
      })

    P-homomorphism : ∀ {x y z} → ⊚ ∘F (idF ⁂ idF) ≃ idF ∘F ⊚ {x} {y} {z}
    P-homomorphism {x} {_} {z} = niHelper (record
      { η       = λ _ → id₂
      ; η⁻¹     = λ _ → id₂
      ; commute = λ _ → MorphismReasoning.id-comm-sym (hom x z)
      ; iso     = λ _ → record { isoˡ = hom.identity² ; isoʳ = hom.identity² }
      })

    Pid  = λ {A} → NaturalTransformation.η (F⇒G (P-identity {A})) _
    Phom = λ {x} {y} {z} f,g →
           NaturalTransformation.η (F⇒G (P-homomorphism {x} {y} {z})) f,g
    λ⇒   = unitorˡ.from
    ρ⇒   = unitorʳ.from
    α⇒   = associator.from

    unitaryˡ : ∀ {x y} {f : x ⇒₁ y} →
               let open ComHom in
               [ id₁ ⊚₀ f ⇒ f ]⟨
                 Pid ⊚₁ id₂      ⇒⟨ id₁ ⊚₀ f ⟩
                 Phom (id₁ , f)  ⇒⟨ id₁ ⊚₀ f ⟩
                 λ⇒
               ≈ λ⇒
               ⟩
    unitaryˡ {x} {y} {f} = begin
      λ⇒ ∘ᵥ Phom (id₁ , f) ∘ᵥ (Pid ⊚₁ id₂)  ≈⟨ refl⟩∘⟨ elimʳ ⊚.identity ⟩
      λ⇒ ∘ᵥ Phom (id₁ , f)                  ≈⟨ hom.identityʳ ⟩
      λ⇒                                    ∎
      where
        open HomReasoning (hom x y)
        open MorphismReasoning (hom x y)

    unitaryʳ : ∀ {x y} {f : x ⇒₁ y} →
               let open ComHom in
               [ f ⊚₀ id₁ ⇒ f ]⟨
                 id₂ ⊚₁ Pid      ⇒⟨ f ⊚₀ id₁ ⟩
                 Phom (f , id₁)  ⇒⟨ f ⊚₀ id₁ ⟩
                 ρ⇒
               ≈ ρ⇒
               ⟩
    unitaryʳ {x} {y} {f} = begin
      ρ⇒ ∘ᵥ Phom (f , id₁) ∘ᵥ (id₂ ⊚₁ Pid)  ≈⟨ refl⟩∘⟨ elimʳ ⊚.identity ⟩
      ρ⇒ ∘ᵥ Phom (f , id₁)                  ≈⟨ hom.identityʳ ⟩
      ρ⇒                                    ∎
      where
        open HomReasoning (hom x y)
        open MorphismReasoning (hom x y)

    assoc : ∀ {x y z w} {f : x ⇒₁ y} {g : y ⇒₁ z} {h : z ⇒₁ w} →
            let open ComHom in
            [ (h ⊚₀ g) ⊚₀ f ⇒ h ⊚₀ (g ⊚₀ f) ]⟨
              Phom (h , g) ⊚₁ id₂  ⇒⟨ (h ⊚₀ g) ⊚₀ f ⟩
              Phom (_ , f)         ⇒⟨ (h ⊚₀ g) ⊚₀ f ⟩
              α⇒
            ≈ α⇒                   ⇒⟨ h ⊚₀ (g ⊚₀ f) ⟩
              id₂ ⊚₁ Phom (g , f)  ⇒⟨ h ⊚₀ (g ⊚₀ f) ⟩
              Phom (h , _)
            ⟩
    assoc {x} {_} {_} {w} {f} {g} {h} = begin
      α⇒ ∘ᵥ Phom (_ , f) ∘ᵥ Phom (h , g) ⊚₁ id₂  ≈⟨ refl⟩∘⟨ elimʳ ⊚.identity ⟩
      α⇒ ∘ᵥ Phom (_ , f)                         ≈⟨ hom.identityʳ ⟩
      α⇒                                         ≈˘⟨ elimˡ ⊚.identity ⟩
      id₂ ⊚₁ Phom (g , f) ∘ᵥ α⇒                  ≈˘⟨ hom.identityˡ ⟩
      Phom (h , _) ∘ᵥ id₂ ⊚₁ Phom (g , f) ∘ᵥ α⇒  ∎
      where
        open HomReasoning (hom x w)
        open MorphismReasoning (hom x w)


open import Nat
open import Prelude
open import core
open import contexts
open import typed-elaboration
open import lemmas-gcomplete
open import lemmas-complete
open import progress-checks
open import finality

module cast-inert where
  -- if a term is compelete and well typed, then the casts inside are all
  -- identity casts and there are no failed casts
  cast-inert : ∀{Δ Γ d τ} →
                  d dcomplete →
                  Δ , Γ ⊢ d :: τ →
                  cast-id d
  cast-inert dc TAConst = CIConst
  cast-inert dc (TAVar x₁) = CIVar
  cast-inert (DCLam dc x₁) (TALam x₂ wt) = CILam (cast-inert dc wt)
  cast-inert (DCAp dc dc₁) (TAAp wt wt₁) = CIAp (cast-inert dc wt) (cast-inert dc₁ wt₁)
  cast-inert () (TAEHole x x₁)
  cast-inert () (TANEHole x wt x₁)
  cast-inert (DCCast dc x x₁) (TACast wt x₂)
    with complete-consistency x₂ x x₁
  ... | refl = CICast (cast-inert dc wt)
  cast-inert () (TAFailedCast wt x x₁ x₂)

  -- in a well typed complete internal expression, every cast is the
  -- identity cast.
  complete-casts : ∀{Γ Δ d τ1 τ2} →
                   Γ , Δ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2 →
                   d ⟨ τ1 ⇒ τ2 ⟩ dcomplete →
                   τ1 == τ2
  complete-casts wt comp with cast-inert comp wt
  complete-casts wt comp | CICast qq = refl

  -- relates expressions to the same thing with all identity casts
  -- removed. note that this is a syntactic rewrite and it goes under
  -- binders.
  data no-id-casts : ihexp → ihexp → Set where
    NICConst  : no-id-casts c c
    NICVar    : ∀{x} → no-id-casts (X x) (X x)
    NICLam    : ∀{x τ d d'} → no-id-casts d d' → no-id-casts (·λ x [ τ ] d) (·λ x [ τ ] d')
    NICHole   : ∀{u} → no-id-casts (⦇-⦈⟨ u ⟩) (⦇-⦈⟨ u ⟩)
    NICNEHole : ∀{d d' u} → no-id-casts d d' → no-id-casts (⦇⌜ d ⌟⦈⟨ u ⟩) (⦇⌜ d' ⌟⦈⟨ u ⟩)
    NICAp     : ∀{d1 d2 d1' d2'} → no-id-casts d1 d1' → no-id-casts d2 d2' → no-id-casts (d1 ∘ d2) (d1' ∘ d2')
    NICCast   : ∀{d d' τ} → no-id-casts d d' → no-id-casts (d ⟨ τ ⇒ τ ⟩) d'
    NICFailed : ∀{d d' τ1 τ2} → no-id-casts d d' → no-id-casts (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) (d' ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩)

  -- removing identity casts doesn't change the type
  no-id-casts-type : ∀{Γ Δ d τ d' } → Δ , Γ ⊢ d :: τ →
                                      no-id-casts d d' →
                                      Δ , Γ ⊢ d' :: τ
  no-id-casts-type TAConst NICConst = TAConst
  no-id-casts-type (TAVar x₁) NICVar = TAVar x₁
  no-id-casts-type (TALam x₁ wt) (NICLam nic) = TALam x₁ (no-id-casts-type wt nic)
  no-id-casts-type (TAAp wt wt₁) (NICAp nic nic₁) = TAAp (no-id-casts-type wt nic) (no-id-casts-type wt₁ nic₁)
  no-id-casts-type (TAEHole x x₁) NICHole = TAEHole x x₁
  no-id-casts-type (TANEHole x wt x₁) (NICNEHole nic) = TANEHole x (no-id-casts-type wt nic) x₁
  no-id-casts-type (TACast wt x) (NICCast nic) = no-id-casts-type wt nic
  no-id-casts-type (TAFailedCast wt x x₁ x₂) (NICFailed nic) = TAFailedCast (no-id-casts-type wt nic) x x₁ x₂


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Sn where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Groups.Prelims

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; elim2 to pElim2 ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁) hiding (map)

open import Cubical.Data.Bool
open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec)
open import Cubical.Data.Unit

open import Cubical.Homotopy.Connected

open import Cubical.Algebra.Group

infixr 31 _□_
_□_ : _
_□_ = compGroupIso

open GroupEquiv
open vSES
open GroupIso
open GroupHom
open BijectionIso

Sn-connected : (n : ℕ) (x : typ (S₊∙ (suc n))) → ∥ pt (S₊∙ (suc n)) ≡ x ∥₁
Sn-connected zero = toPropElim (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc zero) = suspToPropElim base (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc (suc n)) = suspToPropElim north (λ _ → propTruncIsProp) ∣ refl ∣₁

H⁰-Sⁿ≅ℤ : (n : ℕ) → GroupIso (coHomGr 0 (S₊ (suc n))) intGroup
H⁰-Sⁿ≅ℤ zero = H⁰-connected base (Sn-connected 0)
H⁰-Sⁿ≅ℤ (suc n) = H⁰-connected north (Sn-connected (suc n))

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

--- We will need to switch between Sⁿ defined using suspensions and using pushouts
--- in order to apply Mayer Vietoris.

S1Iso : Iso S¹ (Pushout {A = Bool} (λ _ → tt) λ _ → tt)
S1Iso = S¹IsoSuspBool ⋄ invIso PushoutSuspIsoSusp

coHomPushout≅coHomSn : (n m : ℕ) → GroupIso (coHomGr m (S₊ (suc n)))
                                             (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt))
coHomPushout≅coHomSn zero m =
  Iso+Hom→GrIso (setTruncIso (domIso S1Iso))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))
coHomPushout≅coHomSn (suc n) m =
  Iso+Hom→GrIso (setTruncIso (domIso (invIso PushoutSuspIsoSusp)))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))

-------------------------- H⁰(S⁰) -----------------------------
S0→Int : (a : Int × Int) → S₊ 0 → Int
S0→Int a true = fst a
S0→Int a false = snd a

H⁰-S⁰≅ℤ×ℤ : GroupIso (coHomGr 0 (S₊ 0)) (dirProd intGroup intGroup)
fun (map H⁰-S⁰≅ℤ×ℤ) = sRec (isSet× isSetInt isSetInt) λ f → (f true) , (f false)
isHom (map H⁰-S⁰≅ℤ×ℤ) = sElim2 (λ _ _ → isSet→isGroupoid (isSet× isSetInt isSetInt) _ _)
                                λ a b → refl
inv H⁰-S⁰≅ℤ×ℤ a = ∣ S0→Int a ∣₂
rightInv H⁰-S⁰≅ℤ×ℤ _ = refl
leftInv H⁰-S⁰≅ℤ×ℤ = sElim (λ _ → isSet→isGroupoid setTruncIsSet _ _)
                           λ f → cong ∣_∣₂ (funExt (λ {true → refl ; false → refl}))

------------------------- H¹(S⁰) ≅ 0 -------------------------------

private
  Hⁿ-S0≃Kₙ×Kₙ : (n : ℕ) → Iso (S₊ 0 → coHomK (suc n)) (coHomK (suc n) × coHomK (suc n))
  Iso.fun (Hⁿ-S0≃Kₙ×Kₙ n) f = (f true) , (f false)
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) true = a
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) false = b
  Iso.rightInv (Hⁿ-S0≃Kₙ×Kₙ n) a = refl
  Iso.leftInv (Hⁿ-S0≃Kₙ×Kₙ n) b = funExt λ {true → refl ; false → refl}

  isContrHⁿ-S0 : (n : ℕ) → isContr (coHom (suc n) (S₊ 0))
  isContrHⁿ-S0 n = isContrRetract (Iso.fun (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.inv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.leftInv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (isContrHelper n)
    where
    isContrHelper : (n : ℕ) → isContr (∥ (coHomK (suc n) × coHomK (suc n)) ∥₂)
    fst (isContrHelper zero) = ∣ (0₁ , 0₁) ∣₂
    snd (isContrHelper zero) = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₁ , 0₁) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 2 setTruncIsSet _ _)
                                  (toPropElim2 (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc zero) = ∣ (0₂ , 0₂) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₂ , 0₂) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 3 setTruncIsSet _ _)
                                  (suspToPropElim2 base (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc (suc n)) = ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isProp→isOfHLevelSuc (4 + n) (setTruncIsSet _ _))
                                  (suspToPropElim2 north (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)

H¹-S⁰≅0 : (n : ℕ) → GroupIso (coHomGr (suc n) (S₊ 0)) trivialGroup
H¹-S⁰≅0 n = IsoContrGroupTrivialGroup (isContrHⁿ-S0 n)

------------------------- H²(S¹) ≅ 0 -------------------------------

Hⁿ-S¹≅0 : (n : ℕ) → GroupIso (coHomGr (2 + n) (S₊ 1)) trivialGroup
Hⁿ-S¹≅0 n = IsoContrGroupTrivialGroup
            (isOfHLevelRetractFromIso 0 helper
              (_ , helper2))
  where
  helper : Iso ⟨ coHomGr (2 + n) (S₊ 1)⟩ ∥ Σ (hLevelTrunc (4 + n) (S₊ (2 + n))) (λ x → ∥ x ≡ x ∥₂) ∥₂
  helper = compIso (setTruncIso IsoFunSpaceS¹) IsoSetTruncateSndΣ

  helper2 : (x : ∥ Σ (hLevelTrunc (4 + n) (S₊ (2 + n))) (λ x → ∥ x ≡ x ∥₂) ∥₂) → ∣ ∣ north ∣ , ∣ refl ∣₂ ∣₂ ≡ x
  helper2 =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          (uncurry
            (trElim (λ _ → isOfHLevelΠ (4 + n) λ _ → isProp→isOfHLevelSuc (3 + n) (setTruncIsSet _ _))
              (suspToPropElim (ptSn (suc n)) (λ _ → isPropΠ λ _ → setTruncIsSet _ _)
                (sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                       λ p
                    → cong ∣_∣₂ (ΣPathP (refl , isContr→isProp helper3 _ _))))))
    where
    helper4 : isConnected (n + 3) (hLevelTrunc (4 + n) (S₊ (2 + n)))
    helper4 = subst (λ m → isConnected m (hLevelTrunc (4 + n) (S₊ (2 + n)))) (+-comm 3 n)
                    (isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (3 + n) 1)) (sphereConnected (2 + n)))

    helper3 : isContr ∥ ∣ north ∣ ≡ ∣ north ∣ ∥₂
    helper3 = isOfHLevelRetractFromIso 0 setTruncTrunc2Iso
                                         (isConnectedPath 2 (isConnectedSubtr 3 n helper4) _ _)

-- --------------- H¹(Sⁿ), n ≥ 1 --------------------------------------------

H¹-Sⁿ≅0 : (n : ℕ) → GroupIso (coHomGr 1 (S₊ (2 + n))) trivialGroup
H¹-Sⁿ≅0 zero = IsoContrGroupTrivialGroup isContrH¹S²
  where
  isContrH¹S² : isContr ⟨ coHomGr 1 (S₊ 2) ⟩
  isContrH¹S² = ∣ (λ _ → ∣ base ∣) ∣₂
              , coHomPointedElim 0 north (λ _ → setTruncIsSet _ _)
                   λ f p → cong ∣_∣₂ (funExt λ x → sym p ∙∙ sym (spoke f north) ∙∙ spoke f x)
H¹-Sⁿ≅0 (suc n) = IsoContrGroupTrivialGroup isContrH¹S³⁺ⁿ
  where
  anIso : Iso ⟨ coHomGr 1 (S₊ (3 + n)) ⟩ ∥ (S₊ (3 + n) → hLevelTrunc (4 + n) (coHomK 1)) ∥₂
  anIso =
    setTruncIso
      (codomainIso
        (invIso (truncIdempotentIso (4 + n) (isOfHLevelPlus' {n = 1 + n} 3 (isOfHLevelTrunc 3)))))

  isContrH¹S³⁺ⁿ-ish : (f : (S₊ (3 + n) → hLevelTrunc (4 + n) (coHomK 1)))
                   → ∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂ ≡ ∣ f ∣₂
  isContrH¹S³⁺ⁿ-ish f = ind (f north) refl
    where
    ind : (x : hLevelTrunc (4 + n) (coHomK 1))
       → x ≡ f north
       → ∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂ ≡ ∣ f ∣₂
    ind = trElim (λ _ → isOfHLevelΠ (4 + n) λ _ → isOfHLevelPlus' {n = (3 + n)} 1 (setTruncIsSet _ _))
              (trElim (λ _ → isOfHLevelΠ 3 λ _ → isOfHLevelPlus {n = 1} 2 (setTruncIsSet _ _))
              (toPropElim (λ _ → isPropΠ λ _ → setTruncIsSet _ _)
              λ p → cong ∣_∣₂ (funExt λ x → p ∙∙ sym (spoke f north) ∙∙ spoke f x)))
  isContrH¹S³⁺ⁿ : isContr ⟨ coHomGr 1 (S₊ (3 + n)) ⟩
  isContrH¹S³⁺ⁿ =
    isOfHLevelRetractFromIso 0
      anIso
      (∣ (λ _ → ∣ ∣ base ∣ ∣) ∣₂
      , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _) isContrH¹S³⁺ⁿ-ish)

--------- H¹(S¹) ≅ ℤ -------
{-
Idea :
H¹(S¹) := ∥ S¹ → K₁ ∥₂
        ≃ ∥ S¹ → S¹ ∥₂
        ≃ ∥ S¹ × ℤ ∥₂
        ≃ ∥ S¹ ∥₂ × ∥ ℤ ∥₂
        ≃ ℤ
-}
coHom1S1≃ℤ : GroupIso (coHomGr 1 (S₊ 1)) intGroup
coHom1S1≃ℤ = theIso
  where
  F = Iso.fun S¹→S¹≡S¹×Int
  F⁻ = Iso.inv S¹→S¹≡S¹×Int

  theIso : GroupIso (coHomGr 1 (S₊ 1)) intGroup
  fun (map theIso) = sRec isSetInt (λ f → snd (F f))
  isHom (map theIso) =
    coHomPointedElimS¹2 _ (λ _ _ → isSetInt _ _)
      λ p q → (λ i → winding (guy ∣ base ∣ (cong S¹map (help p q i))))
            ∙∙ (λ i → winding (guy ∣ base ∣ (congFunct S¹map p q i)))
            ∙∙ winding-hom (guy ∣ base ∣ (cong S¹map p))
                           (guy ∣ base ∣ (cong S¹map q))

    where
    guy = basechange2⁻ ∘ S¹map
    help : (p q : Path (coHomK 1) ∣ base ∣ ∣ base ∣) → cong₂ _+ₖ_ p q ≡ p ∙ q
    help p q = cong₂Funct _+ₖ_ p q ∙ (λ i → cong (λ x → rUnitₖ 1 x i) p ∙ cong (λ x → lUnitₖ 1 x i) q)
  inv theIso a = ∣ (F⁻ (base , a)) ∣₂
  rightInv theIso a = cong snd (Iso.rightInv S¹→S¹≡S¹×Int (base , a))
  leftInv theIso = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                          λ f → cong ((sRec setTruncIsSet ∣_∣₂)
                                        ∘ sRec setTruncIsSet λ x → ∣ F⁻ (x , (snd (F f))) ∣₂)
                                      (Iso.inv PathIdTrunc₀Iso (isConnectedS¹ (fst (F f))))
                              ∙ cong ∣_∣₂ (Iso.leftInv S¹→S¹≡S¹×Int f)

---------------------------- Hⁿ(Sⁿ) ≅ ℤ , n ≥ 1 -------------------
{-
The proof of the inductive step below is a compact version of the following equations. Let n ≥ 1.
Hⁿ⁺¹(Sⁿ⁺¹) := ∥ Sⁿ⁺¹ → Kₙ₊₁ ∥₂
           ≅ ∥ Σ[ (a , b) ∈ Kₙ₊₁ ] (Sⁿ → a ≡ b) ∥₂       (characterisation of functions from suspensions)
           ≅ ∥ Kₙ₊₁ × Kₙ₊₁ × (Sⁿ → ΩKₙ₊₁) ∥₂             (base change in ΩKₙ₊₁)
           ≅ ∥ Kₙ₊₁ ∥₂ × ∥ Kₙ₊₁ ∥₂ × ∥ (Sⁿ → ΩKₙ₊₁) ∥₂
           ≅ ∥ Sⁿ → ΩKₙ₊₁ ∥₂                             (connectivity of Kₙ₊₁)
           ≅ ∥ Sⁿ → Kₙ ∥₂                                (ΩKₙ₊₁ ≃ Kₙ)
          := Hⁿ(Sⁿ)
           ≅ ℤ                                           (ind. hyp)

The inverse function Hⁿ(Sⁿ) → Hⁿ⁺¹(Sⁿ⁺¹) is just the function d from Mayer-Vietoris.
However, we can construct d⁻¹ directly in this case, thus avoiding computationally
heavier proofs concerning exact sequences. -}

Hⁿ-Sⁿ≅ℤ : (n : ℕ) → GroupIso (coHomGr (suc n) (S₊ (suc n))) intGroup
Hⁿ-Sⁿ≅ℤ zero = coHom1S1≃ℤ
Hⁿ-Sⁿ≅ℤ (suc n) = invGroupIso helper □ invGroupIso (coHom≅coHomΩ (suc n) _) □ (Hⁿ-Sⁿ≅ℤ n)
  where
  basePointInd : (p : _) (a : _)
    → (p (ptSn (suc n)) ≡ refl) → sym (rCancelₖ (2 + n) ∣ north ∣)
                                 ∙∙ (λ i →  (elimFunSⁿ (suc n) n p) ((merid a ∙ sym (merid (ptSn (suc n)))) i) +ₖ ∣ north ∣)
                                 ∙∙ rCancelₖ (2 + n) ∣ north ∣
                               ≡ p a
  basePointInd p a prefl =
        cong (λ z → sym z ∙∙ ((λ i →  (elimFunSⁿ (suc n) n p) ((merid a ∙ sym (merid (ptSn (suc n)))) i) +ₖ ∣ north ∣)) ∙∙ z)
             (transportRefl refl)
     ∙∙ sym (rUnit _)
     ∙∙ (λ j i → rUnitₖ (2 + n) (elimFunSⁿ (suc n) n p ((merid a ∙ sym (merid (ptSn (suc n)))) i)) j)
     ∙∙ congFunct (elimFunSⁿ (suc n) n p) (merid a) (sym (merid (ptSn (suc n))))
     ∙∙ (cong (p a ∙_) (cong sym prefl)
     ∙ sym (rUnit (p a)))

  helper : GroupIso (coHomGrΩ (suc n) (S₊ (suc n))) (coHomGr (2 + n) (S₊ (2 + n)))
  fun (map helper) = sMap λ f → λ { north → ∣ north ∣
                                   ; south → ∣ north ∣
                                   ; (merid a i) → f a i}
  isHom (map helper) =
    sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
           λ f g → cong ∣_∣₂ (funExt λ { north → refl
                                       ; south → refl
                                       ; (merid a i) j → ∙≡+₂ n (f a) (g a) j i})
  inv helper = sMap λ f x → sym (rCancelₖ (2 + n) (f north))
                          ∙∙ (λ i → f ((merid x ∙ sym (merid (ptSn (suc n)))) i) -ₖ f north)
                          ∙∙ rCancelₖ (2 + n) (f north)
  rightInv helper =
    coHomPointedElimSⁿ (suc n) n (λ _ → setTruncIsSet _ _)
      λ p → trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                   (λ prefl → cong ∣_∣₂ (funExt λ {north → refl
                                                 ; south → refl
                                                 ; (merid a i) j → basePointInd p a prefl j i}))
                   (Iso.fun (PathIdTruncIso _)
                            (isOfHLevelSuc 0 (isConnectedPathKn _ ∣ north ∣ ∣ north ∣)
                            (∣ p (ptSn (suc n)) ∣) ∣ refl ∣))
  leftInv helper =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          λ f → (trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                        (λ frefl → cong ∣_∣₂ (funExt λ x → basePointInd f x frefl))
                        ((Iso.fun (PathIdTruncIso _)
                            (isOfHLevelSuc 0 (isConnectedPathKn _ ∣ north ∣ ∣ north ∣)
                            (∣ f (ptSn (suc n)) ∣) ∣ refl ∣))))


-- Saturated sets.

module SAT3 where

open import Library
open import Terms
open import Substitution
open import Reduction
open import SN
open import SN.AntiRename

-- Kripke predicates on well-typed terms.

TmSet : (a : Ty) → Set₁
TmSet a = {Γ : Cxt} (t : Tm Γ a) → Set

_⊆_ : ∀{a} (𝑨 𝑨′ : TmSet a) → Set
𝑨 ⊆ 𝑨′ = ∀{Γ}{t : Tm Γ _} → 𝑨 t → 𝑨′ t

-- Closure by strong head expansion

Closed : ∀ {a} (𝑨 : TmSet a) → Set
Closed 𝑨 = ∀{Γ}{t t' : Tm Γ _} → t ⟨ _ ⟩⇒ t' → 𝑨 t' → 𝑨 t

data Cl {a} (𝑨 : TmSet a) {Γ} (t : Tm Γ a) : Set where
  emb : 𝑨 t                             → Cl 𝑨 t
  exp : ∀{t'} → t ⟨ _ ⟩⇒ t' → Cl 𝑨 t' → Cl 𝑨 t

-- Function space.

_[→]_ : ∀{a b} → TmSet a → TmSet b → TmSet (a →̂ b)
(𝓐 [→] 𝓑) {Γ} t = ∀{Δ} (ρ : Δ ≤ Γ) → {u : Tm Δ _} → 𝓐 u → 𝓑 (app (rename ρ t) u)

-- Saturated term sets.

record IsSAT {a} (𝑨 : TmSet a) : Set where
  -- constructor isSat
  field
    satSNe  : SNe ⊆ 𝑨
    satSN   : 𝑨 ⊆ SN
    satExp  : Closed 𝑨
    satRename : ∀ {Γ Δ} → (ρ : Ren Γ Δ) → ∀ {t} → 𝑨 t → 𝑨 (subst ρ t)
--open IsSAT

record SAT (a : Ty) : Set₁ where
  -- constructor sat
  field
    satSet  : TmSet a
    satProp : IsSAT satSet

  open IsSAT satProp public
open SAT public

-- Elementhood for saturated sets.
-- We use a record to instead of just application to help Agda's unifier.
record _∈_ {a Γ} (t : Tm Γ a) (𝓐 : SAT a) : Set where
  constructor ↿_
  field       ⇃_ : satSet 𝓐 t
open _∈_ public

-- Variables inhabit saturated sets.

⟦var⟧ : ∀{a} (𝓐 : SAT a) {Γ} (x : Var Γ a) → var x ∈ 𝓐
⟦var⟧ 𝓐 x = ↿ (satSNe 𝓐 (var x))

-- Smallest semantic type.

⟦⊥⟧ : SAT base
⟦⊥⟧ = record
  { satSet  = SN
  ; satProp = record
    { satSNe    = ne
    ; satSN     = id
    ; satExp    = exp
    ; satRename = renameSN
    }
  }

-- Semantic function type.

_⟦→⟧_ : ∀ {a b} (𝓐 : SAT a) (𝓑 : SAT b) → SAT (a →̂ b)
𝓐 ⟦→⟧ 𝓑 = record
  { satSet  = 𝑪
  ; satProp = record
    { satSNe = CSNe
    ; satSN  = CSN
    ; satExp = CExp
    ; satRename = λ ρ {t} 𝒕 ρ₁ {u} 𝒖 → ≡.subst (λ t₁ → 𝑩 (app t₁ u)) (subst-∙ ρ₁ ρ t) (𝒕 (λ x₂ → ρ₁ (ρ x₂)) 𝒖)
    }
  }
  where
    module 𝓐 = SAT 𝓐
    module 𝓑 = SAT 𝓑
    𝑨 = 𝓐.satSet
    𝑩 = 𝓑.satSet
    𝑪 : TmSet (_ →̂ _)
    𝑪 t = (𝑨 [→] 𝑩) t

    CSNe : SNe ⊆ 𝑪
    CSNe 𝒏 ρ 𝒖 = 𝓑.satSNe (sneApp (renameSNe ρ 𝒏) (𝓐.satSN 𝒖))

    CSN : 𝑪 ⊆ SN
    CSN 𝒕 = unRenameSN (prop→Ind suc ≡.refl) (absVarSN (𝓑.satSN (𝒕 _ (𝓐.satSNe (var v₀)))))

    CExp : ∀{Γ}{t t' : Tm Γ _} → t ⟨ _ ⟩⇒ t' → 𝑪 t' → 𝑪 t
    CExp t⇒ 𝒕 ρ 𝒖 = 𝓑.satExp ((cong (appl _) (appl _) (subst⇒ (renSN ρ) t⇒))) (𝒕 ρ 𝒖)

-- Lemma: If 𝓐, 𝓑 ∈ SAT and t[u] ∈ 𝓑 for all a ∈ 𝓐, then λt ∈ 𝓐 ⟦→⟧ 𝓑

⟦abs⟧ : ∀{a b}{𝓐 : SAT a}{𝓑 : SAT b}{Γ}{t : Tm (a ∷ Γ) b} →
    (∀ {Δ} (ρ : Δ ≤ Γ) {u : Tm Δ a} →
      u ∈ 𝓐 → (subst0 u (subst (lifts ρ) t)) ∈ 𝓑 ) → abs t ∈ (𝓐 ⟦→⟧ 𝓑)
(⇃ ⟦abs⟧ {𝓐 = 𝓐}{𝓑 = 𝓑} 𝒕) ρ 𝒖 =
  SAT.satExp 𝓑 (β (SAT.satSN 𝓐 𝒖)) (⇃ 𝒕 ρ (↿ 𝒖))

-- Lemma: If 𝓐, 𝓑 ∈ SAT and t ∈ 𝓐 ⟦→⟧ 𝓑 and u ∈ 𝓐, then app t u ∈ 𝓑

⟦app⟧ : ∀ {a b} {𝓐 : SAT a} {𝓑 : SAT b} {Γ} {t : Tm Γ (a →̂ b)} {u : Tm Γ a} →
        t ∈ (𝓐 ⟦→⟧ 𝓑) → u ∈ 𝓐 → app t u ∈ 𝓑
⟦app⟧ {𝓑 = 𝓑} {u = u} (↿ 𝒕) (↿ 𝒖) = ≡.subst (λ t → app t u ∈ 𝓑) renId (↿ 𝒕 _ 𝒖)


module Data.FixedTree where

import      Lvl
open import Data hiding (empty)
open import Data.List
open import Data.Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Raise
open import Functional as Fn
open import Numeral.Natural
open import Type

private variable ℓ ℓᵢ ℓₗ ℓₙ ℓₒ : Lvl.Level
private variable n : ℕ
private variable N N₁ N₂ L T A B : Type{ℓ}

module _ {I : Type{ℓᵢ}} (children : I → ℕ) (step : I → I) (L : Type{ℓₗ}) (N : Type{ℓₙ}) where
  data Tree₊ : I → Type{ℓₗ Lvl.⊔ ℓₙ Lvl.⊔ ℓᵢ} where
    Leaf : ∀{i} → L → Tree₊(i)
    Node : ∀{i} → N → (Tree₊(step i) ^ children(step i)) → Tree₊(i)

  data Tree₋ : I → Type{ℓₗ Lvl.⊔ ℓₙ Lvl.⊔ ℓᵢ} where
    Leaf : ∀{i} → L → Tree₋(i)
    Node : ∀{i} → N → (Tree₋(i) ^ children(i)) → Tree₋(step i)

-- Alternative definition:
--   data FixedTree (n : ℕ) (L : Type{ℓₗ}) (N : Type{ℓₙ}) : Type{ℓₗ Lvl.⊔ ℓₙ} where
--     Leaf : L → FixedTree(n) L N
--     Node : N → ((FixedTree(n) L N) ^ n) → FixedTree(n) L N
FixedTree : ℕ → Type{ℓₗ} → Type{ℓₙ} → Type{ℓₗ Lvl.⊔ ℓₙ}
FixedTree(n) L N = Tree₊ id id L N n

open import Data using (Unit ; <>)
open import Data.Boolean
open import Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Data.Option
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Finite
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Natural.Function
open import Numeral.Natural.Oper hiding (_^_)

emptyTree : FixedTree{ℓₗ}(n) Unit N
emptyTree{n = n} = Leaf <>

singleton : N → FixedTree{ℓₗ}(n) Unit N
singleton{n = n} a = Node a (Raise.repeat n emptyTree)

isLeaf : FixedTree(n) L N → Bool
isLeaf (Leaf _)   = 𝑇
isLeaf (Node _ _) = 𝐹

isNode : FixedTree(n) L N → Bool
isNode (Leaf _)   = 𝐹
isNode (Node _ _) = 𝑇

root : FixedTree(n) L N → Option(N)
root (Leaf _)   = None
root (Node a _) = Some a

foldChildNodesᵣ : (((FixedTree(n) L N) ^ n) → N → T → T) → T → FixedTree(n) L N → T
foldChildNodesᵣ        join id (Leaf _)   = id
foldChildNodesᵣ{n = n} join id (Node _ c) = Raise.foldᵣ{n} (\{(Leaf _) → Fn.id ; (Node a c) → join c a}) id c

-- TODO: Is it correct? Also termination checker
{-
testfoldᵣ : ∀{n : ℕ}{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → B → B) → B → (FixedTree(n)(A) ^ n) → B
testfoldᵣ {0}       (_▫_) id _              = id
testfoldᵣ {1}       (_▫_) id Leaf           = id
testfoldᵣ {1}       (_▫_) id (Node a c)     = a ▫ testfoldᵣ {1} (_▫_) id c
-- x ▫ def
testfoldᵣ {𝐒(𝐒(n))} (_▫_) def (x , xs) = {!!}
-- x ▫ testfoldᵣ {𝐒(n)} (_▫_) def xs

fold : (A → B → B) → B → FixedTree(n)(A) → B
fold        (_▫_) id Leaf       = id
fold{n = n} (_▫_) id (Node a c) = a ▫ Raise.foldᵣ{n} (\{Leaf -> Fn.id ; node@(Node _ _) acc → fold{n = n} (_▫_) acc node}) id c

fold : (A → B → B) → B → FixedTree(n)(A) → B
fold{A = A}{B = B}{n = n} (_▫_) id tree = foldChildNodesᵣ ({!swap(fold{n = n} (_▫_))!}) id tree where
  f : ∀{n₁ n₂} → FixedTree(n₁)(A) ^ n₂ → A → B → B
  f {n₂ = 0}        <>           a acc = a ▫ acc
  f {n₂ = 1}        Leaf         a acc = a ▫ acc
  f {n₂ = 1}        (Node ca cc) a acc = f cc a (ca ▫ acc)
  -- ca ▫ (a ▫ acc)
  f {n₂ = 𝐒(𝐒(n₂))} c a acc = {!!}

testfoldDepthFirst : (A → B → B) → B → FixedTree(n)(A) → B
testfoldᵣ : ∀{n₁ n₂ : ℕ}{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → B → B) → B → (FixedTree(n₁)(A) ^ n₂) → B

testfoldDepthFirst        (_▫_) id Leaf       = id
testfoldDepthFirst{n = n} (_▫_) id (Node a c) = a ▫ testfoldᵣ{n} (_▫_) id c

testfoldᵣ          {n₂ = 0}        (_▫_) def _        = def
testfoldᵣ {n₁ = n₁}{n₂ = 1}        (_▫_) def x        = testfoldDepthFirst{n = n₁} (_▫_) def x
-- testfoldᵣ {n₂ = 𝐒(𝐒(n₂))} (_▫_) def (x , xs) = swap(testfoldDepthFirst{n = _} (_▫_)) x (testfoldᵣ {n₂ = 𝐒(n₂)} (_▫_) def xs)

testfoldᵣ : ∀{n₁ n₂ : ℕ}{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → B → B) → B → (FixedTree(n₁)(A) ^ n₂) → B
testfoldᵣ {n₂ = 0}       (_▫_) id <>              = id
testfoldᵣ {n₂ = 1}       (_▫_) id Leaf            = id
testfoldᵣ {n₂ = 1}       (_▫_) id (Node a c)      = a ▫ testfoldᵣ(_▫_) id c
testfoldᵣ {n₂ = 𝐒(𝐒(n))} (_▫_) id (Leaf     , xs) = testfoldᵣ(_▫_) id xs
testfoldᵣ {n₂ = 𝐒(𝐒(n))} (_▫_) id (Node a c , xs) = testfoldᵣ(_▫_) (a ▫ testfoldᵣ(_▫_) id xs) c
-}

{-# TERMINATING #-}
foldDepthFirst : (N → T → T) → T → FixedTree(n) L N → T
foldDepthFirst        (_▫_) id (Leaf _)   = id
foldDepthFirst{n = n} (_▫_) id (Node a c) = a ▫ Raise.foldᵣ{n} (swap(foldDepthFirst{n = n} (_▫_))) id c

import      Data.Tuple.RaiseTypeᵣ.Functions as RaiseType
open import Function.Multi
import      Function.Multi.Functions as Multi

{-# TERMINATING #-}
FixedTree-induction : ∀{P : FixedTree{ℓₗ}{ℓₙ}(n) L N → Type{ℓ}} → (∀{l} → P(Leaf l)) → ((a : N) → (c : (FixedTree(n) L N) ^ n) → (RaiseType.from-[^] (Raise.map P(c)) ⇉ P(Node a c))) → ((tree : FixedTree(n) L N) → P(tree))
FixedTree-induction                       base _    (Leaf l)   = base{l}
FixedTree-induction {n = 0}               _    step (Node a c) = step a c
FixedTree-induction {n = 1}               base step (Node a c) = step a c (FixedTree-induction{n = 1} base step c)
FixedTree-induction {n = 𝐒(𝐒(n))} {P = P} base step (Node a c) = recurseChildren{𝐒(𝐒(n))}(step a c) where
  recurseChildren : ∀{L}{l : _ ^ L} → (RaiseType.from-[^] (Raise.map P(l)) ⇉ P(Node a c)) → P(Node a c)
  recurseChildren {0}                 = id
  recurseChildren {1}       {l}     p = p(FixedTree-induction{n = 𝐒(𝐒(n))} base step l)
  recurseChildren {𝐒(𝐒(L))} {x , l} p = recurseChildren{𝐒(L)}{l} (p(FixedTree-induction{n = 𝐒(𝐒(n))} base step x))

-- The size is the number of nodes in the tree.
-- Alternative implementation:
--   size{n = n}{L = L}{N = N} = FixedTree-induction 𝟎 (rec{w = n}) where
--     rec : ∀{w} → (a : N) → (c : (FixedTree(n) L N) ^ w) → RaiseType.from-[^] (Raise.map{w} (const ℕ)(c)) ⇉ ℕ
--     rec {w = 0}       _  _         = 1
--     rec {w = 1}       _  _       n = 𝐒(n)
--     rec {w = 𝐒(𝐒(w))} a  (_ , c) n = Multi.compose(𝐒(w)) (n +_) (rec{w = 𝐒(w)} a c)
{-# TERMINATING #-}
size : FixedTree(n) L N → ℕ
size (Leaf _)   = 𝟎
size (Node _ c) = 𝐒(Raise.foldᵣ((_+_) ∘ size) 𝟎 c)

-- The height is the length of the longest path from the root node.
-- Alternative implementation:
--   height{n = n}{L = L}{N = N} = FixedTree-induction 𝟎 (rec{w = n}) where
--     -- Note: The return type is equal to `RaiseType.repeat(L) ℕ ⇉ ℕ`
--     rec : ∀{w} → (a : N) → (c : (FixedTree(n) L N) ^ w) → RaiseType.from-[^] (Raise.map{w} (const ℕ)(c)) ⇉ ℕ
--     rec {w = 0}       _  _         = 1
--     rec {w = 1}       _  _       n = 𝐒(n)
--     rec {w = 𝐒(𝐒(w))} a  (_ , c) n = Multi.compose(𝐒(w)) (max n) (rec{w = 𝐒(w)} a c)
{-# TERMINATING #-}
height : FixedTree(n) L N → ℕ
height (Leaf _)   = 𝟎
height (Node _ c) = 𝐒(Raise.foldᵣ(max ∘ height) 𝟎 c)

import Data.Tuple.Raiseᵣ.Functions as TupleRaiseᵣ
import Data.List.Functions as List

treesOfDepth : ℕ → FixedTree(n) L N → List(FixedTree(n) L N)
treesOfDepth 𝟎      tree       = tree ⊰ ∅
treesOfDepth (𝐒(_)) (Leaf _)   = ∅
treesOfDepth (𝐒(n)) (Node _ c) = TupleRaiseᵣ.foldᵣ((List._++_) ∘ treesOfDepth n) ∅ c


------------------------------------------------------------------------
-- The Agda standard library
--
-- Abstractions used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Abstraction where

open import Data.List.Base as List using (List)
open import Data.Product using (_×_; _,_; uncurry; <_,_>)
import Data.String as String
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

private
  variable
    A B : Set

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

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

-- Pattern synonyms

------------------------------------------------------------------------
-- Operations

map : (A → B) → Abs A → Abs B
map f (abs s x) = abs s (f x)

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

abs-injective₁ : ∀ {i i′} {a a′ : A} → abs i a ≡ abs i′ a′ → i ≡ i′
abs-injective₁ refl = refl

abs-injective₂ : ∀ {i i′} {a a′ : A} → abs i a ≡ abs i′ a′ → a ≡ a′
abs-injective₂ refl = refl

abs-injective : ∀ {i i′} {a a′ : A} → abs i a ≡ abs i′ a′ → i ≡ i′ × a ≡ a′
abs-injective = < abs-injective₁ , abs-injective₂ >

-- We often need decidability of equality for Abs A when implementing it
-- for A. Unfortunately ≡-dec makes the termination checker unhappy.
-- Instead, we can match on both Abs A and use unAbs-dec for an obviously
-- decreasing recursive call.

unAbs : Abs A → A
unAbs (abs s a) = a

unAbs-dec : {x y : Abs A} → Dec (unAbs x ≡ unAbs y) → Dec (x ≡ y)
unAbs-dec {x = abs i a} {abs i′ a′} a≟a′ =
  Dec.map′ (uncurry (cong₂ abs)) abs-injective ((i String.≟ i′) ×-dec a≟a′)

≡-dec : Decidable {A = A} _≡_ → Decidable {A = Abs A} _≡_
≡-dec _≟_ x y = unAbs-dec (unAbs x ≟ unAbs y)


-- Andreas, 2016-09-20 test whether --no-eta-equality is respected

{-# OPTIONS --no-eta-equality #-}

open import Common.Equality

data Wrap (A : Set) : Set where
  wrap : A → Wrap A

record R : Set where
  inductive
  constructor c
  field p : Wrap R
open R

test : ∀ (w : R) → w ≡ c (p w)
test w = refl  -- should fail


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

open import lib.Base
open import lib.PathGroupoid

open import lib.path-seq.Concat
open import lib.path-seq.Inversion
open import lib.path-seq.Reasoning

module lib.path-seq.Rotations {i} {A : Type i} where

{-
The order of the arguments p, q, r follows the occurrences
of these variables in the output type
-}

pre-rotate-in : {a a' a'' : A} {q : a' =-= a''} {p : a == a'} {r : a =-= a''}
  → p ◃∙ q =ₛ r
  → q =ₛ ! p ◃∙ r
pre-rotate-in {q = q} {p = idp} {r = r} e =
  q
    =ₛ⟨ =ₛ-in (! (↯-∙∙ (idp ◃∎) q)) ⟩
  idp ◃∙ q
    =ₛ⟨ e ⟩
  r
    =ₛ⟨ =ₛ-in (! (↯-∙∙ (idp ◃∎) r)) ⟩
  idp ◃∙ r ∎ₛ

pre-rotate-out : {a a' a'' : A} {p : a == a'} {q : a' =-= a''} {r : a =-= a''}
  → q =ₛ ! p ◃∙ r
  → p ◃∙ q =ₛ r
pre-rotate-out {p = idp} {q = q} {r = r} e =
  idp ◃∙ q
    =ₛ⟨ =ₛ-in (↯-∙∙ (idp ◃∎) q) ⟩
  q
    =ₛ⟨ e ⟩
  idp ◃∙ r
    =ₛ⟨ =ₛ-in (↯-∙∙ (idp ◃∎) r) ⟩
  r ∎ₛ

pre-rotate'-in : {a a' a'' : A} {p : a == a'} {r : a =-= a''} {q : a' =-= a''}
  → r =ₛ p ◃∙ q
  → ! p ◃∙ r =ₛ q
pre-rotate'-in e =
  !ₛ (pre-rotate-in (!ₛ e))

pre-rotate'-out : {a a' a'' : A} {r : a =-= a''} {p : a == a'} {q : a' =-= a''}
  → ! p ◃∙ r =ₛ q
  → r =ₛ p ◃∙ q
pre-rotate'-out e =
  !ₛ (pre-rotate-out (!ₛ e))

pre-rotate-seq-in : {a a' a'' : A} {q : a' =-= a''} {p : a =-= a'} {r : a =-= a''}
  → p ∙∙ q =ₛ r
  → q =ₛ seq-! p ∙∙ r
pre-rotate-seq-in {q = q} {p = []} {r = r} e = e
pre-rotate-seq-in {q = q} {p = p ◃∙ s} {r = r} e =
  q
    =ₛ⟨ pre-rotate-seq-in {q = q} {p = s} {r = ! p ◃∙ r} (pre-rotate-in e) ⟩
  seq-! s ∙∙ ! p ◃∙ r
    =ₛ⟨ =ₛ-in (ap ↯ (! (∙∙-assoc (seq-! s) (! p ◃∎) r))) ⟩
  seq-! (p ◃∙ s) ∙∙ r ∎ₛ

pre-rotate'-seq-in : {a a' a'' : A} {p : a =-= a'} {r : a =-= a''} {q : a' =-= a''}
  → r =ₛ p ∙∙ q
  → seq-! p ∙∙ r =ₛ q
pre-rotate'-seq-in {p = p} {r = r} {q = q} e =
  !ₛ (pre-rotate-seq-in {q = q} {p} {r} (!ₛ e))

post-rotate'-in : {a a' a'' : A}
  → {r : a =-= a''} {q : a' == a''} {p : a =-= a'}
  → r =ₛ p ∙▹ q
  → r ∙▹ ! q =ₛ p
post-rotate'-in {r = r} {q = idp} {p = p} e =
  r ∙▹ idp
    =ₛ⟨ =ₛ-in (↯-∙∙ r (idp ◃∎) ∙ ∙-unit-r (↯ r)) ⟩
  r
    =ₛ⟨ e ⟩
  p ∙▹ idp
    =ₛ⟨ =ₛ-in (↯-∙∙ p (idp ◃∎) ∙ ∙-unit-r (↯ p)) ⟩
  p ∎ₛ

post-rotate-in : {a a' a'' : A}
  → {p : a =-= a'} {r : a =-= a''} {q : a' == a''}
  → p ∙▹ q =ₛ r
  → p =ₛ r ∙▹ ! q
post-rotate-in {p = p} {r = r} {q = q} e =
  !ₛ (post-rotate'-in (!ₛ e))

post-rotate-out : {a a' a'' : A}
  → {p : a =-= a'} {q : a' == a''} {r : a =-= a''}
  → p =ₛ r ∙▹ ! q
  → p ∙▹ q =ₛ r
post-rotate-out {p = p} {q = q} {r = r} e = =ₛ-in $
  ↯ (p ∙▹ q)
    =⟨ ap (λ v → ↯ (p ∙▹ v)) (! (!-! q)) ⟩
  ↯ (p ∙▹ ! (! q))
    =⟨ =ₛ-out (post-rotate'-in {r = p} {q = ! q} {p = r} e) ⟩
  ↯ r =∎

post-rotate'-seq-in : {a a' a'' : A}
  → {r : a =-= a''} {q : a' =-= a''} {p : a =-= a'}
  → r =ₛ p ∙∙ q
  → r ∙∙ seq-! q =ₛ p
post-rotate'-seq-in {r = r} {q = []} {p = p} e =
  r ∙∙ []
    =ₛ⟨ =ₛ-in (ap ↯ (∙∙-unit-r r)) ⟩
  r
    =ₛ⟨ e ⟩
  p ∙∙ []
    =ₛ⟨ =ₛ-in (ap ↯ (∙∙-unit-r p)) ⟩
  p ∎ₛ
post-rotate'-seq-in {r = r} {q = q ◃∙ s} {p = p} e =
  r ∙∙ (seq-! s ∙▹ ! q)
    =ₛ⟨ =ₛ-in (ap ↯ (! (∙∙-assoc r (seq-! s) (! q ◃∎)))) ⟩
  (r ∙∙ seq-! s) ∙▹ ! q
    =ₛ⟨ post-rotate'-in {r = r ∙∙ seq-! s} {q = q} {p = p} $
        post-rotate'-seq-in {r = r} {s} {p ∙▹ q} $
        r
          =ₛ⟨ e ⟩
        p ∙∙ (q ◃∙ s)
          =ₛ⟨ =ₛ-in (ap ↯ (! (∙∙-assoc p (q ◃∎) s))) ⟩
        (p ∙▹ q) ∙∙ s ∎ₛ
      ⟩
  p ∎ₛ

post-rotate-seq-in : {a a' a'' : A}
  → {p : a =-= a'} {r : a =-= a''} {q : a' =-= a''}
  → p ∙∙ q =ₛ r
  → p =ₛ r ∙∙ (seq-! q)
post-rotate-seq-in {p = p} {r = r} {q = q} e =
  !ₛ (post-rotate'-seq-in {r = r} {q = q} {p = p} (!ₛ e))

post-rotate'-seq-out : {a a' a'' : A}
  → {r : a =-= a''} {p : a =-= a'} {q : a' =-= a''}
  → r ∙∙ seq-! q =ₛ p
  → r =ₛ p ∙∙ q
post-rotate'-seq-out {r = r} {p = p} {q = q} e =
  r
    =ₛ⟨ post-rotate-seq-in {p = r} {r = p} {q = seq-! q} e ⟩
  p ∙∙ seq-! (seq-! q)
    =ₛ⟨ =ₛ-in (ap (λ v → ↯ (p ∙∙ v)) (seq-!-seq-! q)) ⟩
  p ∙∙ q ∎ₛ

post-rotate-seq-out : {a a' a'' : A}
  → {p : a =-= a'} {q : a' =-= a''} {r : a =-= a''}
  → p =ₛ r ∙∙ seq-! q
  → p ∙∙ q =ₛ r
post-rotate-seq-out e =
  !ₛ (post-rotate'-seq-out (!ₛ e))


module IncompletePatternMatching where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data True : Set where
  tt : True

data False : Set where

_==_ : Nat -> Nat -> Set
zero  == zero  = True
suc n == suc m = n == m

thm : zero == suc zero
thm = tt


{-# OPTIONS --sized-types #-}
module GiveSize where

postulate Size : Set
{-# BUILTIN SIZE Size #-}

id : Size → Size
id i = {!i!}


open import Coinduction using ( ∞ ; ♭ ; ♯_ )
open import Data.Bool using ( Bool ; true ; false )
open import Data.Empty using ( ⊥ ; ⊥-elim )
open import Data.Unit using ( ⊤ ; tt )
open import System.IO.Transducers.Lazy using
  ( _⇒_ ; inp ; out ; done ; choice ) renaming
  ( ⟦_⟧ to ⟦_⟧' ; _⟫_ to _⟫'_
  ; _[&]_ to _[&]'_ ; _⟨&⟩_ to _⟨&⟩'_ ; assoc to assoc' )
open import System.IO.Transducers.Session using ( Session ; I ; Σ ; Γ ; _/_ ; IsΣ ; ⟨_⟩ ; _&_ ; ¿ ; _⊕_ )
open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ )

module System.IO.Transducers.Strict where

infixr 4 _⇛_
infixr 6 _⟫_
infixr 8 _[&]_ _⟨&⟩_

-- Strict tranducers are ones which perform input before any output

data Strict : ∀ {S T} → (S ⇒ T) → Set₁ where
  inp : ∀ {A V F T} P → (Strict (inp {A} {V} {F} {T} P))
  done : ∀ {S} → (Strict (done {S}))

-- Slightly annoyingly, _≡_ has different cardinalities
-- in different versions of the standard library.
-- Until 1.4 of agda-stdlib is more widely distributed,
-- we define a specialized version of _≡_ here.

data _≡_ (S : Session) : Session → Set₁ where
  refl : S ≡ S

-- S ⇛ T is the type of strict transducers regarded as functions

_⇛_ : Session → Session → Set₁
I     ⇛ T = I ≡ T
Σ V F ⇛ T = ∀ a → (♭ F a) ⇒ T

-- Identity transducer

id : ∀ {S} → S ⇛ S
id {I}     = refl
id {Σ V F} = λ a → out a done

-- Inclusion of strict in lazy transducers

ι : ∀ {S T} → (S ⇛ T) → (S ⇒ T)
ι {I}     refl = done
ι {Σ V F} P    = inp (♯ P)

-- Composition

_⟫_ : ∀ {S T U} → (S ⇛ T) → (T ⇛ U) → (S ⇛ U)
_⟫_ {I}             refl refl = refl
_⟫_ {Σ V F} {I}     P    refl = P
_⟫_ {Σ V F} {Σ W G} P    Q    = λ a → (P a ⟫' ι Q)

-- & on transducers

_[&]_ : ∀ {S T U V} → (S ⇛ T) → (U ⇛ V) → ((S & U) ⇛ (T & V))
_[&]_ {I}     refl Q = Q
_[&]_ {Σ V F} P    Q = λ a → (P a [&]' ι Q)

-- Associativity of &

assoc : ∀ {S T U} → ((S & (T & U)) ⇛ ((S & T) & U))
assoc {I}     {T} {U} = id {T & U}
assoc {Σ V F} {T} {U} = λ a → out a (assoc' {♭ F a})

-- Mediating morphism for &

_⟨&⟩_ : ∀ {S T U} → (S ⇛ T) → (S ⇛ U) → (S ⇛ T & U)
_⟨&⟩_ {I}     refl refl = refl
_⟨&⟩_ {Σ V F} P    Q    = λ a → (P a ⟨&⟩' Q a)


-- Andreas, 2011-09-12
-- eta for records in unifier

-- {-# OPTIONS -v tc.lhs.unify:25 #-}

module Issue455 where

postulate
  A : Set
  a : A

record Fork : Set where
  constructor pair
  field fst : A
        snd : A
open Fork

data D : Fork -> Set where
  c : (x y : A) -> D (pair x y)

postulate p : Fork

f : D p -> Set
f (c .(fst p) .(snd p)) = A  -- should work!

{- Unifier gives up on:
f z = {!z!}
Cannot decide whether there should be a case for the constructor c,
since the unification gets stuck on unifying the inferred indices
[pair x y] with the expected indices [p]
-}

record ⊤ : Set where
  constructor tt

data E : ⊤ -> Set where
  e : E tt

postulate q : ⊤

g : E q -> Set
g e = ⊤


{-# OPTIONS --safe #-}
module Cubical.Data.FinData.Properties where

open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Sum
open import Cubical.Data.Sigma
open import Cubical.Data.FinData.Base as Fin
open import Cubical.Data.Nat renaming (zero to ℕzero ; suc to ℕsuc
                                      ;znots to ℕznots ; snotz to  ℕsnotz)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty as Empty
open import Cubical.Relation.Nullary

private
 variable
   ℓ ℓ' : Level
   A : Type ℓ
   m n k : ℕ

znots : ∀{k} {m : Fin k} → ¬ (zero ≡ (suc m))
znots {k} {m} x = subst (Fin.rec (Fin k) ⊥) x m

snotz : ∀{k} {m : Fin k} → ¬ ((suc m) ≡ zero)
snotz {k} {m} x = subst (Fin.rec ⊥ (Fin k)) x m

isPropFin0 : isProp (Fin 0)
isPropFin0 = Empty.rec ∘ ¬Fin0

isContrFin1 : isContr (Fin 1)
isContrFin1 .fst = zero
isContrFin1 .snd zero = refl

injSucFin : ∀ {n} {p q : Fin n} → suc p ≡ suc q → p ≡ q
injSucFin {ℕsuc ℕzero} {zero} {zero} pf = refl
injSucFin {ℕsuc (ℕsuc n)} pf = cong predFin pf

discreteFin : ∀{k} → Discrete (Fin k)
discreteFin zero zero = yes refl
discreteFin zero (suc y) = no znots
discreteFin (suc x) zero = no snotz
discreteFin (suc x) (suc y) with discreteFin x y
... | yes p = yes (cong suc p)
... | no ¬p = no (λ q → ¬p (injSucFin q))

isSetFin : ∀{k} → isSet (Fin k)
isSetFin = Discrete→isSet discreteFin

data biEq {n : ℕ} (i j : Fin n) : Type where
  eq  :   i ≡ j → biEq i j
  ¬eq : ¬ i ≡ j → biEq i j

data triEq {n : ℕ} (i j a : Fin n) : Type where
  leq : a ≡ i → triEq i j a
  req : a ≡ j → triEq i j a
  ¬eq : (¬ a ≡ i) × (¬ a ≡ j) → triEq i j a

biEq? : (i j : Fin n) → biEq i j
biEq? i j = case (discreteFin i j) return (λ _ → biEq i j)
              of λ { (yes p) → eq p ; (no ¬p) → ¬eq ¬p }

triEq? : (i j a : Fin n) → triEq i j a
triEq? i j a =
  case (discreteFin a i) return (λ _ → triEq i j a) of
    λ { (yes p) → leq p
      ; (no ¬p) →
          case (discreteFin a j) return (λ _ → triEq i j a) of
            λ { (yes q) → req q
              ; (no ¬q) → ¬eq (¬p , ¬q) }}

weakenRespToℕ : ∀ {n} (i : Fin n) → toℕ (weakenFin i) ≡ toℕ i
weakenRespToℕ zero = refl
weakenRespToℕ (suc i) = cong ℕsuc (weakenRespToℕ i)

toℕ<n : ∀ {n} (i : Fin n) → toℕ i < n
toℕ<n {n = ℕsuc n} zero = n , +-comm n 1
toℕ<n {n = ℕsuc n} (suc i) = toℕ<n i .fst , +-suc _ _ ∙ cong ℕsuc (toℕ<n i .snd)

toFin : {n : ℕ} (m : ℕ) → m < n → Fin n
toFin {n = ℕzero} _ m<0 = Empty.rec (¬-<-zero m<0)
toFin {n = ℕsuc n} _ (ℕzero , _) = fromℕ n --in this case we have m≡n
toFin {n = ℕsuc n} m (ℕsuc k , p) = weakenFin (toFin m (k , cong predℕ p))

toFin0≡0 : {n : ℕ} (p : 0 < ℕsuc n) → toFin 0 p ≡ zero
toFin0≡0 (ℕzero , p) = subst (λ x → fromℕ x ≡ zero) (cong predℕ p) refl
toFin0≡0 {ℕzero} (ℕsuc k , p) = Empty.rec (ℕsnotz (+-comm 1 k ∙ (cong predℕ p)))
toFin0≡0 {ℕsuc n} (ℕsuc k , p) =
         subst (λ x → weakenFin x ≡ zero) (sym (toFin0≡0 (k , cong predℕ p))) refl

-- doing induction on toFin is awkward, so the following alternative
enum : (m : ℕ) → m < n → Fin n
enum {n = ℕzero} _ m<0 = Empty.rec (¬-<-zero m<0)
enum {n = ℕsuc n} 0 _ = zero
enum {n = ℕsuc n} (ℕsuc m) p = suc (enum m (pred-≤-pred p))

enum∘toℕ : (i : Fin n)(p : toℕ i < n) → enum (toℕ i) p ≡ i
enum∘toℕ {n = ℕsuc n} zero _ = refl
enum∘toℕ {n = ℕsuc n} (suc i) p t = suc (enum∘toℕ i (pred-≤-pred p) t)

toℕ∘enum : (m : ℕ)(p : m < n) → toℕ (enum m p) ≡ m
toℕ∘enum {n = ℕzero} _ m<0 = Empty.rec (¬-<-zero m<0)
toℕ∘enum {n = ℕsuc n} 0 _ = refl
toℕ∘enum {n = ℕsuc n} (ℕsuc m) p i = ℕsuc (toℕ∘enum m (pred-≤-pred p) i)

enumExt : {m m' : ℕ}(p : m < n)(p' : m' < n) → m ≡ m' → enum m p ≡ enum m' p'
enumExt p p' q i = enum (q i) (isProp→PathP (λ i → m≤n-isProp {m = ℕsuc (q i)}) p p' i)

enumInj : {p : m < k}{q : n < k} → enum m p ≡ enum n q → m ≡ n
enumInj p = sym (toℕ∘enum _ _) ∙ cong toℕ p ∙ toℕ∘enum _ _

enumIndStep :
    (P : Fin n → Type ℓ)
  → (k : ℕ)(p : ℕsuc k < n)
  → ((m : ℕ)(q : m < n)(q' : m ≤ k )     → P (enum m q))
  → P (enum (ℕsuc k) p)
  → ((m : ℕ)(q : m < n)(q' : m ≤ ℕsuc k) → P (enum m q))
enumIndStep P k p f x m q q' =
  case (≤-split q') return (λ _ → P (enum m q)) of
    λ { (inl r') → f m q (pred-≤-pred r')
      ; (inr r') → subst P (enumExt p q (sym r')) x }

enumElim :
    (P : Fin n → Type ℓ)
  → (k : ℕ)(p : k < n)(h : ℕsuc k ≡ n)
  → ((m : ℕ)(q : m < n)(q' : m ≤ k) → P (enum m q))
  → (i : Fin n) → P i
enumElim P k p h f i =
  subst P (enum∘toℕ i (toℕ<n i)) (f (toℕ i) (toℕ<n i)
    (pred-≤-pred (subst (λ a → toℕ i < a) (sym h) (toℕ<n i))))

++FinAssoc : {n m k : ℕ} (U : FinVec A n) (V : FinVec A m) (W : FinVec A k)
           → PathP (λ i → FinVec A (+-assoc n m k i)) (U ++Fin (V ++Fin W)) ((U ++Fin V) ++Fin W)
++FinAssoc {n = ℕzero} _ _ _ = refl
++FinAssoc {n = ℕsuc n} U V W i zero = U zero
++FinAssoc {n = ℕsuc n} U V W i (suc ind) = ++FinAssoc (U ∘ suc) V W i ind

++FinRid : {n : ℕ} (U : FinVec A n) (V : FinVec A 0)
         → PathP (λ i → FinVec A (+-zero n i)) (U ++Fin V) U
++FinRid {n = ℕzero} U V = funExt λ i → Empty.rec (¬Fin0 i)
++FinRid {n = ℕsuc n} U V i zero = U zero
++FinRid {n = ℕsuc n} U V i (suc ind) = ++FinRid (U ∘ suc) V i ind

++FinElim : {P : A → Type ℓ'} {n m : ℕ} (U : FinVec A n) (V : FinVec A m)
          → (∀ i → P (U i)) → (∀ i → P (V i)) → ∀ i → P ((U ++Fin V) i)
++FinElim {n = ℕzero} _ _ _ PVHyp i = PVHyp i
++FinElim {n = ℕsuc n} _ _ PUHyp _ zero = PUHyp zero
++FinElim {P = P} {n = ℕsuc n} U V PUHyp PVHyp (suc i) =
          ++FinElim {P = P} (U ∘ suc) V (λ i → PUHyp (suc i)) PVHyp i

++FinPres∈ : {n m : ℕ} {α : FinVec A n} {β : FinVec A m} (S : ℙ A)
           → (∀ i → α i ∈ S) → (∀ i → β i ∈ S) → ∀ i → (α ++Fin β) i ∈ S
++FinPres∈ {n = ℕzero} S hα hβ i = hβ i
++FinPres∈ {n = ℕsuc n} S hα hβ zero = hα zero
++FinPres∈ {n = ℕsuc n} S hα hβ (suc i) = ++FinPres∈ S (hα ∘ suc) hβ i

-- sends i to n+i if toℕ i < m and to i∸n otherwise
-- then +Shuffle²≡id and over the induced path (i.e. in PathP (ua +ShuffleEquiv))
-- ++Fin is commutative, but how to go from there?
+Shuffle : (m n : ℕ) → Fin (m + n) → Fin (n + m)
+Shuffle m n i with <Dec (toℕ i) m
... | yes i<m = toFin (n + (toℕ i)) (<-k+ i<m)
... | no ¬i<m = toFin (toℕ i ∸ m)
                  (subst (λ x → toℕ i ∸ m < x) (+-comm m n) (≤<-trans (∸-≤ (toℕ i) m) (toℕ<n i)))

-- Proof that Fin n ⊎ Fin m ≃ Fin (n+m)
module FinSumChar where

 fun : (n m : ℕ) → Fin n ⊎ Fin m → Fin (n + m)
 fun ℕzero m (inr i) = i
 fun (ℕsuc n) m (inl zero) = zero
 fun (ℕsuc n) m (inl (suc i)) = suc (fun n m (inl i))
 fun (ℕsuc n) m (inr i) = suc (fun n m (inr i))

 invSucAux : (n m : ℕ) → Fin n ⊎ Fin m → Fin (ℕsuc n) ⊎ Fin m
 invSucAux n m (inl i) = inl (suc i)
 invSucAux n m (inr i) = inr i

 inv : (n m : ℕ) → Fin (n + m) → Fin n ⊎ Fin m
 inv ℕzero m i = inr i
 inv (ℕsuc n) m zero = inl zero
 inv (ℕsuc n) m (suc i) = invSucAux n m (inv n m i)

 ret : (n m : ℕ) (i : Fin n ⊎ Fin m) → inv n m (fun n m i) ≡ i
 ret ℕzero m (inr i) = refl
 ret (ℕsuc n) m (inl zero) = refl
 ret (ℕsuc n) m (inl (suc i)) = subst (λ x → invSucAux n m x ≡ inl (suc i))
                                       (sym (ret n m (inl i))) refl
 ret (ℕsuc n) m (inr i) = subst (λ x → invSucAux n m x ≡ inr i) (sym (ret n m (inr i))) refl

 sec : (n m : ℕ) (i : Fin (n + m)) → fun n m (inv n m i) ≡ i
 sec ℕzero m i = refl
 sec (ℕsuc n) m zero = refl
 sec (ℕsuc n) m (suc i) = helperPath (inv n m i) ∙ cong suc (sec n m i)
  where
  helperPath : ∀ x → fun (ℕsuc n) m (invSucAux n m x) ≡ suc (fun n m x)
  helperPath (inl _) = refl
  helperPath (inr _) = refl

 Equiv : (n m : ℕ) → Fin n ⊎ Fin m ≃ Fin (n + m)
 Equiv n m = isoToEquiv (iso (fun n m) (inv n m) (sec n m) (ret n m))

 ++FinInl : (n m : ℕ) (U : FinVec A n) (W : FinVec A m) (i : Fin n)
          → U i ≡ (U ++Fin W) (fun n m (inl i))
 ++FinInl (ℕsuc n) m U W zero = refl
 ++FinInl (ℕsuc n) m U W (suc i) = ++FinInl n m (U ∘ suc) W i

 ++FinInr : (n m : ℕ) (U : FinVec A n) (W : FinVec A m) (i : Fin m)
          → W i ≡ (U ++Fin W) (fun n m (inr i))
 ++FinInr ℕzero (ℕsuc m) U W i = refl
 ++FinInr (ℕsuc n) m U W i = ++FinInr n m (U ∘ suc) W i

-- Proof that Fin n × Fin m ≃ Fin nm
module FinProdChar where

 open Iso
 sucProdToSumIso : (n m : ℕ) → Iso (Fin (ℕsuc n) × Fin m) (Fin m ⊎ (Fin n × Fin m))
 fun (sucProdToSumIso n m) (zero , j) = inl j
 fun (sucProdToSumIso n m) (suc i , j) = inr (i , j)
 inv (sucProdToSumIso n m) (inl j) = zero , j
 inv (sucProdToSumIso n m) (inr (i , j)) = suc i , j
 rightInv (sucProdToSumIso n m) (inl j) = refl
 rightInv (sucProdToSumIso n m) (inr (i , j)) = refl
 leftInv (sucProdToSumIso n m) (zero , j) = refl
 leftInv (sucProdToSumIso n m) (suc i , j) = refl

 Equiv : (n m : ℕ) → (Fin n × Fin m) ≃ Fin (n · m)
 Equiv ℕzero m = uninhabEquiv (λ x → ¬Fin0 (fst x)) ¬Fin0
 Equiv (ℕsuc n) m = Fin (ℕsuc n) × Fin m    ≃⟨ isoToEquiv (sucProdToSumIso n m) ⟩
                    Fin m ⊎ (Fin n × Fin m) ≃⟨ isoToEquiv (⊎Iso idIso (equivToIso (Equiv n m))) ⟩
                    Fin m ⊎ Fin (n · m)     ≃⟨ FinSumChar.Equiv m (n · m) ⟩
                    Fin (m + n · m)         ■

-- Exhaustion of decidable predicate

∀Dec :
    (P : Fin m → Type ℓ)
  → (dec : (i : Fin m) → Dec (P i))
  → ((i : Fin m) → P i) ⊎ (Σ[ i ∈ Fin m ] ¬ P i)
∀Dec {m = 0} _ _ = inl λ ()
∀Dec {m = ℕsuc m} P dec = helper (dec zero) (∀Dec _ (dec ∘ suc))
  where
    helper :
        Dec (P zero)
      → ((i : Fin m) → P (suc i))  ⊎ (Σ[ i ∈ Fin m ] ¬ P (suc i))
      → ((i : Fin (ℕsuc m)) → P i) ⊎ (Σ[ i ∈ Fin (ℕsuc m) ] ¬ P i)
    helper (yes p) (inl q) = inl λ { zero → p ; (suc i) → q i }
    helper (yes _) (inr q) = inr (suc (q .fst) , q .snd)
    helper (no ¬p) _ = inr (zero , ¬p)

∀Dec2 :
    (P : Fin m → Fin n → Type ℓ)
  → (dec : (i : Fin m)(j : Fin n) → Dec (P i j))
  → ((i : Fin m)(j : Fin n) → P i j) ⊎ (Σ[ i ∈ Fin m ] Σ[ j ∈ Fin n ] ¬ P i j)
∀Dec2 {m = 0} {n = n} _ _ = inl λ ()
∀Dec2 {m = ℕsuc m} {n = n} P dec = helper (∀Dec (P zero) (dec zero)) (∀Dec2 (P ∘ suc) (dec ∘ suc))
  where
    helper :
        ((j : Fin n) → P zero j) ⊎ (Σ[ j ∈ Fin n ] ¬ P zero j)
      → ((i : Fin m)(j : Fin n) → P (suc i) j)  ⊎ (Σ[ i ∈ Fin m ] Σ[ j ∈ Fin n ] ¬ P (suc i) j)
      → ((i : Fin (ℕsuc m))(j : Fin n) → P i j) ⊎ (Σ[ i ∈ Fin (ℕsuc m) ] Σ[ j ∈ Fin n ] ¬ P i j)
    helper (inl p) (inl q) = inl λ { zero j → p j ; (suc i) j → q i j }
    helper (inl _) (inr q) = inr (suc (q .fst) , q .snd .fst , q .snd .snd)
    helper (inr p) _ = inr (zero , p)


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

module PointedTypes where

open import Agda.Prim
open import Data.Unit
open import Data.Bool
open import Data.Nat hiding (_⊔_)
open import Data.Sum
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- Pointed types

-- We need pointed types because paths are ultimately between points. A path
-- between false and 0 for example would be expressed as a path between
-- (pt false) and (pt 0) which expand to •[ Bool , false ] and •[ ℕ , 0 ]

-- First we define a pointed set as a carrier with a distinguished point

record Set• (ℓ : Level) : Set (lsuc ℓ) where
  constructor •[_,_]
  field
    ∣_∣ : Set ℓ
    • : ∣_∣

open Set• public

⊤• : Set• lzero
⊤• = •[ ⊤ , tt ]

_⊎•₁_ : {ℓ ℓ' : Level} → (A• : Set• ℓ) → (B• : Set• ℓ') → Set• (ℓ ⊔ ℓ')
A• ⊎•₁ B• = •[ ∣ A• ∣ ⊎ ∣ B• ∣ , inj₁ (• A•) ]

_⊎•₂_ : {ℓ ℓ' : Level} → (A• : Set• ℓ) → (B• : Set• ℓ') → Set• (ℓ ⊔ ℓ')
A• ⊎•₂ B• = •[ ∣ A• ∣ ⊎ ∣ B• ∣ , inj₂ (• B•) ]

_×•_ : {ℓ ℓ' : Level} → (A• : Set• ℓ) → (B• : Set• ℓ') → Set• (ℓ ⊔ ℓ')
A• ×• B• = •[ ∣ A• ∣ × ∣ B• ∣ , (• A• , • B•) ]

test0 : Set• lzero
test0 = •[ ℕ , 3 ]

test1 : Set• (lsuc lzero)
test1 = •[ Set , ℕ ]

test2 : {ℓ ℓ' : Level} {A : Set ℓ} {B : Set ℓ'} {a : A} → Set• (ℓ ⊔ ℓ')
test2 {ℓ} {ℓ'} {A} {B} {a} = •[ A ⊎ B , inj₁ a ]

test3 : ∀ {ℓ} → Set• (lsuc (lsuc ℓ))
test3 {ℓ} = •[ Set (lsuc ℓ) , Set ℓ ]

test4 : Set• lzero
test4 = •[ (Bool → Bool) , not ]

-- Now we focus on the points and move the carriers to the background

pt : {ℓ : Level} {A : Set ℓ} → (a : A) → Set• ℓ
pt {ℓ} {A} a = •[ A , a ]

test5 : Set• lzero
test5 = pt 3

test6 : Set• (lsuc lzero)
test6 = pt ℕ

test7 : {ℓ : Level} → Set• (lsuc (lsuc ℓ))
test7 {ℓ} = pt (Set ℓ)

-- See:
-- http://homotopytypetheory.org/2012/11/21/on-heterogeneous-equality/

beta : {ℓ : Level} {A : Set ℓ} {a : A} → • •[ A , a ] ≡ a
beta {ℓ} {A} {a} = refl

eta : {ℓ : Level} → (A• : Set• ℓ) → •[ ∣ A• ∣ , • A• ] ≡ A•
eta {ℓ} A• = refl

------------------------------------------------------------------------------
-- Functions between pointed types; our focus is on how the functions affect
-- the basepoint. We don't care what the functions do on the rest of the type.

record _→•_ {ℓ ℓ' : Level} (A• : Set• ℓ) (B• : Set• ℓ') : Set (ℓ ⊔ ℓ') where
  field
    fun   : ∣ A• ∣ → ∣ B• ∣
    resp• : fun (• A•) ≡ • B•

open _→•_ public

id• : {ℓ : Level} {A• : Set• ℓ} → (A• →• A•)
id• = record { fun = id ; resp• = refl }

f1 : pt 2 →• pt 4
f1 = record { fun = suc ∘ suc ; resp• = refl }

f2 : pt 2 →• pt 4
f2 = record { fun = λ x → 2 * x ; resp• = refl }

-- composition of functions between pointed types
_⊚_ : {ℓ₁ ℓ₂ ℓ₃ : Level} {A• : Set• ℓ₁} {B• : Set• ℓ₂} {C• : Set• ℓ₃} →
      (B• →• C•) → (A• →• B•) → (A• →• C•)
h ⊚ g = record {
          fun   = fun h ∘ fun g ;
          resp• = trans (cong (fun h) (resp• g)) (resp• h)
        }

f3 : pt 4 →• pt 2
f3 = record { fun = pred ∘ pred ; resp• = refl }

f1∘f3 : pt 4 →• pt 4
f1∘f3 = f1 ⊚ f3

-- two pointed functions are ∼ if they agree on the basepoints; we DON'T CARE
-- what they do on the rest of the type.

_∼•_ : {ℓ ℓ' : Level} {A• : Set• ℓ} {B• : Set• ℓ'} →
       (f• g• : A• →• B•) → Set ℓ'
_∼•_ {ℓ} {ℓ'} {A•} {B•} f• g• = fun f• (• A•) ≡ fun g• (• A•)

f1∼f2 : f1 ∼• f2
f1∼f2 = refl

f1∘f3∼id : f1∘f3 ∼• id•
f1∘f3∼id = refl

-- quasi-inverses

record qinv• {ℓ ℓ'} {A• : Set• ℓ} {B• : Set• ℓ'} (f• : A• →• B•) :
  Set (ℓ ⊔ ℓ') where
  constructor mkqinv•
  field
    g• : B• →• A•
    α• : (f• ⊚ g•) ∼• id•
    β• : (g• ⊚ f•) ∼• id•

idqinv• : ∀ {ℓ} → {A• : Set• ℓ} → qinv• {ℓ} {ℓ} {A•} {A•} id•
idqinv• = record { g• = id• ; α• = refl ; β• = refl }

f1qinv : qinv• f1
f1qinv = record { g• = f3 ; α• = refl ; β• = refl }

-- equivalences

record isequiv• {ℓ ℓ'} {A• : Set• ℓ} {B• : Set• ℓ'} (f• : A• →• B•) :
  Set (ℓ ⊔ ℓ') where
  constructor mkisequiv•
  field
    g• : B• →• A•
    α• : (f• ⊚ g•) ∼• id•
    h• : B• →• A•
    β• : (h• ⊚ f•) ∼• id•

equiv•₁ : ∀ {ℓ ℓ'} {A• : Set• ℓ} {B• : Set• ℓ'} {f• : A• →• B•} →
          qinv• f• → isequiv• f•
equiv•₁ (mkqinv• qg qα qβ) = mkisequiv• qg qα qg qβ

f1equiv : isequiv• f1
f1equiv = equiv•₁ f1qinv

_≃•_ : ∀ {ℓ ℓ'} (A• : Set• ℓ) (B• : Set• ℓ') → Set (ℓ ⊔ ℓ')
A ≃• B = Σ (A →• B) isequiv•

idequiv• : ∀ {ℓ} {A• : Set• ℓ} → A• ≃• A•
idequiv• = ( id• , equiv•₁ idqinv•)

pt24equiv : pt 2 ≃• pt 4
pt24equiv = (f1 , f1equiv)

------------------------------------------------------------------------------
{-- old stuff which we might need again

idright : {A B : Set} {a : A} {b : B} {p : •[ A , a ] ⇛ •[ B , b ]} →
          (trans⇛ p (id⇛ {B} {b})) 2⇛ p
idright = 2Path id⇛ id⇛

idleft : {A B : Set} {a : A} {b : B} {p : •[ A , a ] ⇛ •[ B , b ]} →
         (trans⇛ (id⇛ {A} {a}) p) 2⇛ p
idleft = 2Path id⇛ id⇛

assoc  : {A B C D : Set} {a : A} {b : B} {c : C} {d : D}
         {p : •[ A , a ] ⇛ •[ B , b ]}
         {q : •[ B , b ] ⇛ •[ C , c ]}
         {r : •[ C , c ] ⇛ •[ D , d ]} →
         (trans⇛ p (trans⇛ q r)) 2⇛ (trans⇛ (trans⇛ p q) r)
assoc = 2Path id⇛ id⇛

bifunctorid⋆ : {A B : Set} {a : A} {b : B} →
  (times⇛ (id⇛ {A} {a}) (id⇛ {B} {b})) 2⇛ (id⇛ {A × B} {(a , b)})
bifunctorid⋆ = 2Path id⇛ id⇛

bifunctorid₊₁ : {A B : Set} {a : A} →
  (plus₁⇛ {A} {B} {A} {B} (id⇛ {A} {a})) 2⇛ (id⇛ {A ⊎ B} {inj₁ a})
bifunctorid₊₁ = 2Path id⇛ id⇛

bifunctorid₊₂ : {A B : Set} {b : B} →
  (plus₂⇛ {A} {B} {A} {B} (id⇛ {B} {b})) 2⇛ (id⇛ {A ⊎ B} {inj₂ b})
bifunctorid₊₂ = 2Path id⇛ id⇛

bifunctorC⋆ : {A B C D E F : Set}
              {a : A} {b : B} {c : C} {d : D} {e : E} {f : F}
              {p : •[ A , a ] ⇛ •[ B , b ]}
              {q : •[ B , b ] ⇛ •[ C , c ]}
              {r : •[ D , d ] ⇛ •[ E , e ]}
              {s : •[ E , e ] ⇛ •[ F , f ]} →
  (trans⇛ (times⇛ p r) (times⇛ q s)) 2⇛ (times⇛ (trans⇛ p q) (trans⇛ r s))
bifunctorC⋆ = 2Path id⇛ id⇛

bifunctorC₊₁₁ : {A B C D E F : Set}
                {a : A} {b : B} {c : C}
                {p : •[ A , a ] ⇛ •[ B , b ]}
                {q : •[ B , b ] ⇛ •[ C , c ]} →
  (trans⇛ (plus₁⇛ {A} {D} {B} {E} p) (plus₁⇛ {B} {E} {C} {F} q)) 2⇛
  (plus₁⇛ {A} {D} {C} {F} (trans⇛ p q))
bifunctorC₊₁₁ = 2Path id⇛ id⇛

bifunctorC₊₂₂ : {A B C D E F : Set}
                {d : D} {e : E} {f : F}
                {r : •[ D , d ] ⇛ •[ E , e ]}
                {s : •[ E , e ] ⇛ •[ F , f ]} →
  (trans⇛ (plus₂⇛ {A} {D} {B} {E} r) (plus₂⇛ {B} {E} {C} {F} s)) 2⇛
  (plus₂⇛ {A} {D} {C} {F} (trans⇛ r s))
bifunctorC₊₂₂ = 2Path id⇛ id⇛

triangle : {A B : Set} {a : A} {b : B} →
  (trans⇛ (assocr⋆⇛ {A} {⊤} {B} {a} {tt} {b}) (times⇛ id⇛ unite⋆⇛)) 2⇛
  (times⇛ (trans⇛ swap⋆⇛ unite⋆⇛) id⇛)
triangle = 2Path id⇛ id⇛

-- Now interpret a path (x ⇛ y) as a value of type (1/x , y)

Recip : {A : Set} → (x : • A) → Set₁
Recip {A} x = (x ⇛ x)

η : {A : Set} {x : • A} → ⊤ → Recip x × • A
η {A} {x} tt = (id⇛ x , x)

lower : {A : Set} {x : • A} → x ⇛ x -> ⊤
lower c = tt

-- The problem here is that we can't assert that y == x.
ε : {A : Set} {x : • A} → Recip x × • A → ⊤
ε {A} {x} (rx , y) = lower (id⇛ ( ↑ (fun (ap rx) (focus y)) )) -- makes insufficient sense

apr : {A B : Set} {x : • A} {y : • B} → (x ⇛ y) → Recip y → Recip x
apr {A} {B} {x} {y} q ry = trans⇛ q (trans⇛ ry (sym⇛ q))
  x
    ≡⟨ q ⟩
  y
    ≡⟨ ry ⟩
  y
    ≡⟨ sym⇛ q ⟩
  x ∎

ε : {A B : Set} {x : A} {y : B} → Recip x → Singleton y → x ⇛ y
ε rx (singleton y) = rx y

pathV : {A B : Set} {x : A} {y : B} → (x ⇛ y) → Recip x × Singleton y
pathV unite₊⇛ = {!!}
pathV uniti₊⇛ = {!!}
--  swap₁₊⇛ : {A B : Set} {x : A} → _⇛_ {A ⊎ B} {B ⊎ A} (inj₁ x) (inj₂ x)
pathV (swap₁₊⇛ {A} {B} {x}) = ((λ x' → {!!}) , singleton (inj₂ x))
pathV swap₂₊⇛ = {!!}
pathV assocl₁₊⇛ = {!!}
pathV assocl₂₁₊⇛ = {!!}
pathV assocl₂₂₊⇛ = {!!}
pathV assocr₁₁₊⇛ = {!!}
pathV assocr₁₂₊⇛ = {!!}
pathV assocr₂₊⇛ = {!!}
pathV unite⋆⇛ = {!!}
pathV uniti⋆⇛ = {!!}
pathV swap⋆⇛ = {!!}
pathV assocl⋆⇛ = {!!}
pathV assocr⋆⇛ = {!!}
pathV dist₁⇛ = {!!}
pathV dist₂⇛ = {!!}
pathV factor₁⇛ = {!!}
pathV factor₂⇛ = {!!}
pathV dist0⇛ = {!!}
pathV factor0⇛ = {!!}
pathV {A} {.A} {x} (id⇛ .x) = {!!}
pathV (sym⇛ p) = {!!}
pathV (trans⇛ p p₁) = {!!}
pathV (plus₁⇛ p) = {!!}
pathV (plus₂⇛ p) = {!!}
pathV (times⇛ p p₁) = {!!}

-- these are individual paths so to speak
-- should we represent a path like swap+ as a family explicitly:
-- swap+ : (x : A) -> x ⇛ swapF x
-- I guess we can: swap+ : (x : A) -> case x of inj1 -> swap1 x else swap2 x

If A={x0,x1,x2}, 1/A has three values:
(x0<-x0, x0<-x1, x0<-x2)
(x1<-x0, x1<-x1, x1<-x2)
(x2<-x0, x2<-x1, x2<-x2)
It is a fake choice between x0, x1, and x2 (some negative information). You base
yourself at x0 for example and enforce that any other value can be mapped to x0.
So think of a value of type 1/A as an uncertainty about which value of A we
have. It could be x0, x1, or x2 but at the end it makes no difference. There is
no choice.

You can manipulate a value of type 1/A (x0<-x0, x0<-x1, x0<-x2) by with a
path to some arbitrary path to b0 for example:

(b0<-x0<-x0, b0<-x0<-x1, b0<-x0<-x2)

eta_3 will give (x0<-x0, x0<-x1, x0<-x2, x0) for example but any other
combination is equivalent.

epsilon_3 will take (x0<-x0, x0<-x1, x0<-x2) and one actual xi which is now
certain; we can resolve our previous uncertainty by following the path from
xi to x0 thus eliminating the fake choice we seemed to have.

Explain connection to negative information.

Knowing head or tails is 1 bits. Giving you a choice between heads and tails
and then cooking this so that heads=tails takes away your choice.

-- transp⇛ : {A B : Set} {x y : • A} →
-- (f : A → B) → x ⇛ y → ↑ (f (focus x)) ⇛ ↑ (f (focus y))

-- Morphism of pointed space: contains a path!
record _⟶_ {A B : Set} (pA : • A) (pB : • B) : Set₁ where
  field
    fun : A → B
    eq : ↑ (fun (focus pA)) ⇛ pB

open _⟶_

_○_ : {A B C : Set} {pA : • A} {pB : • B} {pC : • C} → pA ⟶ pB → pB ⟶ pC → pA ⟶ pC
f ○ g = record { fun = λ x → (fun g) ((fun f) x) ; eq = trans⇛ (transp⇛ (fun g) (eq f)) (eq g)}

mutual

  ap : {A B : Set} {x : • A} {y : • B} → x ⇛ y → x ⟶ y
  ap {y = y} unite₊⇛ = record { fun = λ { (inj₁ ())
                                        ; (inj₂ x) → x } ; eq = id⇛ y }
  ap uniti₊⇛ (singleton x) = singleton (inj₂ x)
  ap (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₁ x)) = singleton (inj₂ x)
  ap (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₂ y)) = singleton (inj₁ y)
  ap (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  ap (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  ap (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  ap (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  ap (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  ap (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  ap {.(⊤ × A)} {A} {.(tt , x)} {x} unite⋆⇛ (singleton .(tt , x)) =
    singleton x
  ap uniti⋆⇛ (singleton x) = singleton (tt , x)
  ap (swap⋆⇛ {A} {B} {x} {y}) (singleton .(x , y)) = singleton (y , x)
  ap (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  ap (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  ap (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  ap (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  ap (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  ap (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  ap {.(⊥ × A)} {.⊥} {.(• , x)} {•} (dist0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •
  ap factor0⇛ (singleton ())
  ap {x = x} (id⇛ .x) = record { fun = λ x → x; eq = id⇛ x }
  ap (sym⇛ c) = apI c
  ap (trans⇛ c₁ c₂) = (ap c₁) ○ (ap c₂)
  ap (transp⇛ f a) = record { fun = λ x → x; eq = transp⇛ f a }

  ap (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ x))
    with ap c (singleton x)
  ... | singleton .z = singleton (inj₁ z)
  ap (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ y))
    with ap c (singleton y)
  ... | singleton .w = singleton (inj₂ w)
  ap (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(x , y))
    with ap c₁ (singleton x) | ap c₂ (singleton y)
  ... | singleton .z | singleton .w = singleton (z , w)

  apI : {A B : Set} {x : • A} {y : • B} → x ⇛ y → y ⟶ x
  apI {y = y} unite₊⇛ = record { fun = inj₂; eq = id⇛ (↑ (inj₂ (focus y))) }

 apI {A} {.(⊥ ⊎ A)} {x} uniti₊⇛ (singleton .(inj₂ x)) = singleton x
  apI (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₂ x)) = singleton (inj₁ x)
  apI (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₁ y)) = singleton (inj₂ y)
  apI (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  apI (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  apI (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  apI (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  apI (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  apI (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  apI unite⋆⇛ (singleton x) = singleton (tt , x)
  apI {A} {.(⊤ × A)} {x} uniti⋆⇛ (singleton .(tt , x)) = singleton x
  apI (swap⋆⇛ {A} {B} {x} {y}) (singleton .(y , x)) = singleton (x , y)
  apI (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  apI (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  apI (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  apI (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  apI (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  apI (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  apI dist0⇛ (singleton ())
  apI {.⊥} {.(⊥ × A)} {•} (factor0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •

  apI {x = x} (id⇛ .x) = record { fun = λ x → x; eq = id⇛ x }
  apI (sym⇛ c) = ap c
  apI (trans⇛ c₁ c₂) = (apI c₂) ○ (apI c₁)
  apI (transp⇛ f a) = record { fun = λ x → x; eq = transp⇛ f (sym⇛ a) }

  apI (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ z))
    with apI c (singleton z)
  ... | singleton .x = singleton (inj₁ x)
  apI (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ w))
    with apI c (singleton w)
  ... | singleton .y = singleton (inj₂ y)
  apI (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(z , w))
    with apI c₁ (singleton z) | apI c₂ (singleton w)
  ... | singleton .x | singleton .y = singleton (x , y)

--}


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

module Container where

open import Prelude

Container : (s p : Level) → Type (ℓsuc (s ℓ⊔ p))
Container s p = Σ[ Shape ⦂ Type s ] × (Shape → Type p)

⟦_⟧ : ∀ {s p ℓ} → Container s p → Set ℓ → Set (s ℓ⊔ p ℓ⊔ ℓ)
⟦ S , P ⟧ X = Σ[ s ⦂ S ] × (P s → X)

cmap : ∀ {s p} {C : Container s p} → (A → B) → ⟦ C ⟧ A → ⟦ C ⟧ B
cmap f xs = xs .fst , λ i → f (xs .snd i)
{-# INLINE cmap #-}


-- Andreas, 2017-08-14, issue #2682, test case by Ulf

-- WAS: CheckInternal treats abstract projections as not in scope,
-- while the type checker allows them.

-- Adapted solution: allow also in CheckInternal

-- {-# OPTIONS -v tc.rec.proj:20 #-}
-- {-# OPTIONS -v tc.deftype:25 #-}
-- {-# OPTIONS -v tc:20 #-}

abstract
  record R : Set₁ where
    field X : Set

works : R → Set
works r = R.X r

test : R → Set
test r = {!R.X r!}

-- WAS: On give:
-- Expected non-abstract record type, found R
-- when checking that the expression R.X r has type Set

test2 : R → Set
test2 r = {! r .X !}
  where open R


------------------------------------------------------------------------
-- A definitional interpreter that is instrumented with information
-- about the stack size of the compiled program
------------------------------------------------------------------------

open import Prelude

import Lambda.Syntax

module Lambda.Interpreter.Stack-sizes
  {Name : Type}
  (open Lambda.Syntax Name)
  (def : Name → Tm 1)
  where

import Equality.Propositional as E
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Colist E.equality-with-J as C
open import Conat E.equality-with-J as Conat using (infinity)
open import Function-universe E.equality-with-J hiding (id; _∘_)
open import Monad E.equality-with-J
open import Nat E.equality-with-J
open import Vec.Data E.equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity as D using (later; force)

open import Upper-bounds

open import Lambda.Compiler def
open import Lambda.Delay-crash as DC hiding (crash)
open import Lambda.Delay-crash-trace as DCT hiding (tell)
import Lambda.Interpreter def as I

open Closure Tm
open Delay-crash-trace using (tell)

------------------------------------------------------------------------
-- The interpreter

-- A stack size change function used in the interpreter's call case.

δ : In-tail-context → ℕ → ℕ
δ tc = if tc then pred else id

infix 10 [_,_]_∙_

mutual

  -- The semantics instrumented with stack size changes (functions of
  -- type ℕ → ℕ). The semantics takes an argument of type
  -- In-tail-context, so that it can produce annotations matching
  -- those produced by the compiler + virtual machine.

  ⟦_⟧ :
    ∀ {i n} →
    Tm n → Env n → In-tail-context →
    Delay-crash-trace (ℕ → ℕ) Value i
  ⟦ var x ⟧       ρ _  = tell suc (return (index ρ x))
  ⟦ lam t ⟧       ρ _  = tell suc (return (lam t ρ))
  ⟦ t₁ · t₂ ⟧     ρ _  = do v₁ ← ⟦ t₁ ⟧ ρ false
                            v₂ ← ⟦ t₂ ⟧ ρ false
                            [ pred , pred ] v₁ ∙ v₂
  ⟦ call f t ⟧    ρ tc = do v ← ⟦ t ⟧ ρ false
                            [ δ tc , δ (not tc) ] lam (def f) [] ∙ v
  ⟦ con b ⟧       ρ _  = tell suc (return (con b))
  ⟦ if t₁ t₂ t₃ ⟧ ρ tc = do v₁ ← ⟦ t₁ ⟧ ρ false
                            ⟦if⟧ v₁ t₂ t₃ ρ tc

  [_,_]_∙_ :
    ∀ {i} →
    (ℕ → ℕ) → (ℕ → ℕ) →
    Value → Value → Delay-crash-trace (ℕ → ℕ) Value i
  [ f₁ , f₂ ] lam t₁ ρ ∙ v₂ = later f₁ λ { .force → do
                                v ← ⟦ t₁ ⟧ (v₂ ∷ ρ) true
                                tell f₂ (return v) }
  [ _  , _  ] con _    ∙ _  = crash

  ⟦if⟧ :
    ∀ {i n} →
    Value → Tm n → Tm n → Env n → In-tail-context →
    Delay-crash-trace (ℕ → ℕ) Value i
  ⟦if⟧ (lam _ _)   _  _  _ _  = crash
  ⟦if⟧ (con true)  t₂ t₃ ρ tc = tell pred (⟦ t₂ ⟧ ρ tc)
  ⟦if⟧ (con false) t₂ t₃ ρ tc = tell pred (⟦ t₃ ⟧ ρ tc)

-- The numbers produced by a given computation, for a given initial
-- number. The initial number is the first element in the output.

numbers : ∀ {A i} → Delay-crash-trace (ℕ → ℕ) A i → ℕ → Colist ℕ i
numbers x n = scanl (λ m f → f m) n (trace x)

-- The stack sizes, for an empty initial stack, with false as the
-- In-tail-context argument.
--
-- Note that this colist is not guaranteed to match the one generated
-- by the virtual machine exactly. However, they are guaranteed to
-- have the same least upper bound.

stack-sizes : ∀ {i} → Tm 0 → Colist ℕ i
stack-sizes t = numbers (⟦ t ⟧ [] false) 0

------------------------------------------------------------------------
-- The semantics given above gives the same (uninstrumented) result as
-- the one in Lambda.Interpreter

mutual

  -- The instrumented and the uninstrumented semantics yield strongly
  -- bisimilar results.

  ⟦⟧∼⟦⟧ :
    ∀ {i n} (t : Tm n) {ρ : Env n} tc →
    D.[ i ] delay-crash (⟦ t ⟧ ρ tc) ∼ I.⟦ t ⟧ ρ
  ⟦⟧∼⟦⟧ (var x) _ = D.reflexive _

  ⟦⟧∼⟦⟧ (lam t) _ = D.reflexive _

  ⟦⟧∼⟦⟧ (t₁ · t₂) {ρ} _ =
    delay-crash
      (⟦ t₁ ⟧ ρ false >>= λ v₁ → ⟦ t₂ ⟧ ρ false >>= λ v₂ →
       [ pred , pred ] v₁ ∙ v₂)                              D.∼⟨ delay-crash->>= (⟦ t₁ ⟧ _ _) ⟩

    (delay-crash (⟦ t₁ ⟧ ρ false) >>= λ v₁ →
     delay-crash (⟦ t₂ ⟧ ρ false >>= λ v₂ →
                  [ pred , pred ] v₁ ∙ v₂))                  D.∼⟨ ((delay-crash (⟦ t₁ ⟧ _ _) D.∎) DC.>>=-cong λ _ →
                                                                   delay-crash->>= (⟦ t₂ ⟧ _ _)) ⟩
    (delay-crash (⟦ t₁ ⟧ ρ false) >>= λ v₁ →
     delay-crash (⟦ t₂ ⟧ ρ false) >>= λ v₂ →
     delay-crash ([ pred , pred ] v₁ ∙ v₂))                  D.∼⟨ (⟦⟧∼⟦⟧ t₁ _ DC.>>=-cong λ v₁ → ⟦⟧∼⟦⟧ t₂ _ DC.>>=-cong λ _ → ∙∼∙ pred v₁) ⟩∼

    (I.⟦ t₁ ⟧ ρ >>= λ v₁ → I.⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ I.∙ v₂)  D.∎

  ⟦⟧∼⟦⟧ (call f t) {ρ} tc =
    delay-crash (⟦ t ⟧ ρ false >>= λ v →
                 [ _ , _ ] lam (def f) [] ∙ v)       D.∼⟨ delay-crash->>= (⟦ t ⟧ _ _) ⟩

    (delay-crash (⟦ t ⟧ ρ false) >>= λ v →
     delay-crash ([ δ tc , _ ] lam (def f) [] ∙ v))  D.∼⟨ (⟦⟧∼⟦⟧ t _ DC.>>=-cong λ _ → ∙∼∙ (δ tc) (lam (def f) [])) ⟩∼

    (I.⟦ t ⟧ ρ >>= λ v → lam (def f) [] I.∙ v)       D.∎

  ⟦⟧∼⟦⟧ (con b) _ = D.reflexive _

  ⟦⟧∼⟦⟧ (if t₁ t₂ t₃) {ρ} tc =
    (delay-crash (⟦ t₁ ⟧ ρ false >>= λ v₁ → ⟦if⟧ v₁ t₂ t₃ ρ tc))  D.∼⟨ delay-crash->>= (⟦ t₁ ⟧ _ _) ⟩

    (delay-crash (⟦ t₁ ⟧ ρ false) >>= λ v₁ →
     delay-crash (⟦if⟧ v₁ t₂ t₃ ρ tc))                            D.∼⟨ (⟦⟧∼⟦⟧ t₁ _ DC.>>=-cong λ v₁ → ⟦if⟧∼⟦if⟧ v₁ t₂ t₃ _) ⟩∼

    (I.⟦ t₁ ⟧ ρ >>= λ v₁ → I.⟦if⟧ v₁ t₂ t₃ ρ)                     D.∎

  ∙∼∙ :
    ∀ {i} f₁ {f₂} (v₁ {v₂} : Value) →
    D.[ i ] delay-crash ([ f₁ , f₂ ] v₁ ∙ v₂) ∼ v₁ I.∙ v₂
  ∙∼∙ f₁ {f₂} (lam t₁ ρ) {v₂} = later λ { .force →
    delay-crash (⟦ t₁ ⟧ (v₂ ∷ ρ) true >>= tell f₂ ∘ return)  D.∼⟨ delay-crash->>= (⟦ t₁ ⟧ _ _) ⟩

    delay-crash (⟦ t₁ ⟧ (v₂ ∷ ρ) true) >>=
    delay-crash ∘ tell f₂ ∘ return                           D.∼⟨ ((delay-crash (⟦ t₁ ⟧ _ _) D.∎) DC.>>=-cong λ _ → D.reflexive _) ⟩

    delay-crash (⟦ t₁ ⟧ (v₂ ∷ ρ) true) >>= return            D.∼⟨ DC.right-identity _ ⟩

    delay-crash (⟦ t₁ ⟧ (v₂ ∷ ρ) true)                       D.∼⟨ ⟦⟧∼⟦⟧ t₁ _ ⟩∼

    I.⟦ t₁ ⟧ (v₂ ∷ ρ)                                        D.∎ }

  ∙∼∙ _ (con _) = D.reflexive _

  ⟦if⟧∼⟦if⟧ :
    ∀ {i n} v₁ (t₂ t₃ : Tm n) {ρ} tc →
    D.[ i ] delay-crash (⟦if⟧ v₁ t₂ t₃ ρ tc) ∼ I.⟦if⟧ v₁ t₂ t₃ ρ
  ⟦if⟧∼⟦if⟧ (lam _ _)   _  _  _ = D.reflexive _
  ⟦if⟧∼⟦if⟧ (con true)  t₂ t₃ _ = ⟦⟧∼⟦⟧ t₂ _
  ⟦if⟧∼⟦if⟧ (con false) t₂ t₃ _ = ⟦⟧∼⟦⟧ t₃ _

------------------------------------------------------------------------
-- A lemma

-- The function numbers preserves strong bisimilarity.

numbers-cong :
  ∀ {i A} {x y : Delay-crash-trace (ℕ → ℕ) A ∞} {n} →
  DCT.[ i ] x ∼ y → C.[ i ] numbers x n ∼ numbers y n
numbers-cong = scanl-cong ∘ trace-cong

------------------------------------------------------------------------
-- An example: An analysis of the semantics of Ω

-- The semantics of Ω is the non-terminating computation never.

Ω-loops : ∀ {i} → D.[ i ] delay-crash (⟦ Ω ⟧ [] false) ∼ never
Ω-loops =
  delay-crash (⟦ Ω ⟧ [] false)  D.∼⟨ ⟦⟧∼⟦⟧ Ω false ⟩
  I.⟦ Ω ⟧ []                    D.∼⟨ I.Ω-loops ⟩
  never                         D.∎

-- A colist used in an analysis of the stack space usage of Ω.

Ω-sizes : ∀ {i} → ℕ → Colist ℕ i
Ω-sizes n =
  n ∷′ 1 + n ∷′ 2 + n ∷ λ { .force → Ω-sizes (1 + n) }

private

  -- An abbreviation.

  cong₃ :
    ∀ {i x y z} {xs ys : Colist′ ℕ ∞} →
    C.[ i ] force xs ∼′ force ys →
    C.[ i ] x ∷′ y ∷′ z ∷ xs ∼ x ∷′ y ∷′ z ∷ ys
  cong₃ p = E.refl ∷ λ { .force → E.refl ∷ λ { .force → E.refl ∷ p }}

-- The colist Ω-sizes n has the same upper bounds as nats-from n.

Ω-sizes≂nats-from : ∀ {i} n → [ i ] Ω-sizes n ≂ nats-from n
Ω-sizes≂nats-from n =
  Ω-sizes n                               ∼⟨ (cong₃ λ { .force → C.reflexive-∼ _ }) ⟩≂
  n ∷′ 1 + n ∷′ 2 + n ∷′ Ω-sizes (suc n)  ≂⟨ cons′-≂ (_⇔_.from ≂′⇔≂″ λ { .force →
                                             consˡ-≂ (inj₁ (here ≤-refl)) (
                                             consˡ-≂ (inj₁ (there (here ≤-refl))) (
                                             Ω-sizes≂nats-from (suc n))) }) ⟩∼
  n ∷′ nats-from (suc n)                  C.∼⟨ C.symmetric-∼ ∷∼∷′ ⟩
  nats-from n                             C.∎

-- The least upper bound of Ω-sizes 0 is infinity.

lub-Ω-sizes-0-infinity :
  LUB (Ω-sizes 0) infinity
lub-Ω-sizes-0-infinity =      $⟨ lub-nats-infinity ⟩
  LUB nats          infinity  ↝⟨ LUB-∼ nats∼nats-from-0 (Conat.reflexive-∼ _) ⟩
  LUB (nats-from 0) infinity  ↝⟨ LUB-≂ (symmetric-≂ (Ω-sizes≂nats-from 0)) ⟩□
  LUB (Ω-sizes 0)   infinity  □

-- When Ω is interpreted (starting with an empty stack) the stack
-- sizes that are encountered match the sizes in the colist Ω-sizes 0.

stack-sizes-Ω∼Ω-sizes-0 :
  ∀ {i} → C.[ i ] stack-sizes Ω ∼ Ω-sizes 0
stack-sizes-Ω∼Ω-sizes-0 =
  stack-sizes Ω                                                     C.∼⟨⟩

  numbers (⟦ Ω ⟧ [] false) 0                                        C.∼⟨ (E.refl ∷ λ { .force → E.refl ∷ λ { .force → E.refl ∷ λ { .force →
                                                                          C.reflexive-∼ _ }}}) ⟩
  0 ∷′ 1 ∷′ 2 ∷′ numbers (⟦ ω-body ⟧ (lam ω-body [] ∷ []) true >>=
                          tell pred ∘ return) 1                     C.∼⟨ (cong₃ λ { .force → lemma 1 }) ⟩

  0 ∷′ 1 ∷′ 2 ∷′ Ω-sizes 1                                          C.∼⟨ (cong₃ λ { .force → C.reflexive-∼ _ }) ⟩

  Ω-sizes 0                                                         C.∎
  where
  lemma :
    ∀ {i} n {k : Value → Delay-crash-trace (ℕ → ℕ) Value ∞} →
    C.[ i ] numbers (⟦ ω-body ⟧ (lam ω-body [] ∷ []) true >>= k) n ∼
            Ω-sizes n
  lemma n {k} =
    numbers (⟦ ω-body ⟧ (lam ω-body [] ∷ []) true >>= k) n                C.∼⟨⟩

    numbers (tell suc (tell suc
               ([ pred , pred ] lam ω-body [] ∙ lam ω-body []) >>= k)) n  C.∼⟨ (E.refl ∷ λ { .force → E.refl ∷ λ { .force → E.refl ∷ λ { .force →
                                                                                C.reflexive-∼ _ }}}) ⟩
    n ∷′ 1 + n ∷′ 2 + n ∷′
    numbers (⟦ ω-body ⟧ (lam ω-body [] ∷ []) true >>=
             tell pred ∘ return >>= k) (1 + n)                            C.∼⟨ (cong₃ λ { .force → C.symmetric-∼ $ numbers-cong $
                                                                                DCT.associativity (⟦ ω-body ⟧ (lam _ _ ∷ []) true) _ _ }) ⟩
    n ∷′ 1 + n ∷′ 2 + n ∷′
    numbers (⟦ ω-body ⟧ (lam ω-body [] ∷ []) true >>= λ v →
             tell pred (return v) >>= k) (1 + n)                          C.∼⟨ (cong₃ λ { .force → lemma (1 + n) }) ⟩

    n ∷′ 1 + n ∷′ 2 + n ∷′ Ω-sizes (1 + n)                                C.∼⟨ (cong₃ λ { .force → C.reflexive-∼ _ }) ⟩

    Ω-sizes n                                                             C.∎

-- The computation Ω requires unbounded space.

Ω-requires-unbounded-space : LUB (stack-sizes Ω) infinity
Ω-requires-unbounded-space =
  LUB-∼ (C.symmetric-∼ stack-sizes-Ω∼Ω-sizes-0)
        (Conat.reflexive-∼ _)
        lub-Ω-sizes-0-infinity


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Binary.Equality.Setoid directly.
------------------------------------------------------------------------

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

open import Relation.Binary using (Setoid)

module Data.List.Relation.Equality.Setoid {a ℓ} (S : Setoid a ℓ) where

open import Data.List.Relation.Binary.Equality.Setoid S public

{-# WARNING_ON_IMPORT
"Data.List.Relation.Equality.Setoid was deprecated in v1.0.
Use Data.List.Relation.Binary.Equality.Setoid instead."
#-}


module Base.Ascription where

-- Encode infix ascription.
as' : ∀ {ℓ} (A : Set ℓ) (a : A) → A
as' _ a = a
syntax as' A a = a as A


------------------------------------------------------------------------
-- The Agda standard library
--
-- Operations on nullary relations (like negation and decidability)
------------------------------------------------------------------------

-- Some operations on/properties of nullary relations, i.e. sets.

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

module Relation.Nullary where

open import Agda.Builtin.Equality

open import Data.Bool.Base
open import Data.Empty hiding (⊥-elim)
open import Data.Empty.Irrelevant
open import Level

------------------------------------------------------------------------
-- Negation.

infix 3 ¬_
infix 2 _because_

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ P = P → ⊥

------------------------------------------------------------------------
-- `Reflects` idiom.

-- The truth value of P is reflected by a boolean value.

data Reflects {p} (P : Set p) : Bool → Set p where
  ofʸ : ( p :   P) → Reflects P true
  ofⁿ : (¬p : ¬ P) → Reflects P false

------------------------------------------------------------------------
-- Decidability.

-- Decidability proofs have two parts: the `does` term which contains
-- the boolean result and the `proof` term which contains a proof that
-- reflects the boolean result. This definition allows the boolean
-- part of the decision procedure to compute independently from the
-- proof. This leads to better computational behaviour when we only care
-- about the result and not the proof. See README.Decidability for
-- further details.

record Dec {p} (P : Set p) : Set p where
  constructor _because_
  field
    does  : Bool
    proof : Reflects P does

open Dec public

pattern yes p =  true because ofʸ  p
pattern no ¬p = false because ofⁿ ¬p

-- Given an irrelevant proof of a decidable type, a proof can
-- be recomputed and subsequently used in relevant contexts.
recompute : ∀ {a} {A : Set a} → Dec A → .A → A
recompute (yes x) _ = x
recompute (no ¬p) x = ⊥-elim (¬p x)

------------------------------------------------------------------------
-- Irrelevant types

Irrelevant : ∀ {p} → Set p → Set p
Irrelevant P = ∀ (p₁ p₂ : P) → p₁ ≡ p₂


module Thesis.Changes where

open import Data.Product
open import Data.Sum
open import Data.Unit
open import Relation.Binary.PropositionalEquality

record IsChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  infixl 6 _⊕_ _⊝_
  field
    _⊕_ : A → ChA → A
    fromto→⊕ : ∀ dv v1 v2 →
      ch dv from v1 to v2 →
      v1 ⊕ dv ≡ v2
    _⊝_ : A → A → ChA
    ⊝-fromto : ∀ (a b : A) → ch (b ⊝ a) from a to b

  update-diff : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  update-diff b a = fromto→⊕ (b ⊝ a) a b (⊝-fromto a b)
  nil : A → ChA
  nil a = a ⊝ a
  nil-fromto : (a : A) → ch (nil a) from a to a
  nil-fromto a = ⊝-fromto a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  valid : ∀ (a : A) (da : ChA) → Set
  valid a da = ch da from a to (a ⊕ da)
  Δ₁ : (a : A) → Set
  Δ₁ a = Σ[ da ∈ ChA ] valid a da
  Δ₂ : (a1 : A) (a2 : A) → Set
  Δ₂ a1 a2 = Σ[ da ∈ ChA ] ch da from a1 to a2

  _⊕'_ : (a1 : A) -> {a2 : A} -> (da : Δ₂ a1 a2) -> A
  a1 ⊕' (da , daa) = a1 ⊕ da

record IsCompChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  field
    isChangeStructure : IsChangeStructure A ChA ch_from_to_
    _⊚_ : ChA → ChA → ChA
    ⊚-fromto : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
      ch da1 from a1 to a2 → ch da2 from a2 to a3 → ch da1 ⊚ da2 from a1 to a3

  open IsChangeStructure isChangeStructure public
  ⊚-correct : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
    ch da1 from a1 to a2 → ch da2 from a2 to a3 →
    a1 ⊕ (da1 ⊚ da2) ≡ a3
  ⊚-correct a1 a2 a3 da1 da2 daa1 daa2 = fromto→⊕ _ _ _ (⊚-fromto _ _ _ da1 da2 daa1 daa2)

record ChangeStructure (A : Set) : Set₁ where
  field
    Ch : Set
    ch_from_to_ : (dv : Ch) → (v1 v2 : A) → Set
    isCompChangeStructure : IsCompChangeStructure A Ch ch_from_to_
  open IsCompChangeStructure isCompChangeStructure public

open ChangeStructure {{...}} public hiding (Ch)
Ch : ∀ (A : Set) → {{CA : ChangeStructure A}} → Set
Ch A {{CA}} = ChangeStructure.Ch CA

-- infix 2 Σ-syntax

-- Σ-syntax : ∀ {a b} (A : Set a) → (A → Set b) → Set (a ⊔ b)
-- Σ-syntax = Σ

-- syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

⊚-syntax : ∀ (A : Set) → {{CA : ChangeStructure A}} → Ch A → Ch A → Ch A
⊚-syntax A {{CA}} da1 da2 = _⊚_ {{CA}} da1 da2
syntax ⊚-syntax A da1 da2 = da1 ⊚[ A ] da2

{-# DISPLAY IsChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY ChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY ChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY IsChangeStructure.nil x = nil #-}
{-# DISPLAY ChangeStructure.nil x = nil #-}
{-# DISPLAY IsCompChangeStructure._⊚_ x = _⊚_ #-}
{-# DISPLAY ChangeStructure._⊚_ x = _⊚_ #-}
{-# DISPLAY ChangeStructure.ch_from_to_ x = ch_from_to_ #-}

module _ {A B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  -- In this module, given change structures CA and CB for A and B, we define
  -- change structures for A → B, A × B and A ⊎ B.

  open import Postulate.Extensionality

  -- Functions
  instance
    funCS : ChangeStructure (A → B)

  infixl 6 _f⊕_ _f⊝_
  private
    fCh = A → Ch A → Ch B

    fCh_from_to_ : (df : fCh) → (f1 f2 : A → B) → Set
    fCh_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2

    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)

    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

    f⊝-fromto : ∀ (f1 f2 : A → B) → fCh (f2 f⊝ f1) from f1 to f2
    f⊝-fromto f1 f2 da a1 a2 daa
      rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))

    _f⊚_ : fCh → fCh → fCh
    _f⊚_ df1 df2 = λ a da → df1 a (nil a) ⊚[ B ] df2 a da

    _f2⊚_ : fCh → fCh → fCh
    _f2⊚_ df1 df2 = λ a da → df1 a da ⊚[ B ] df2 (a ⊕ da) (nil (a ⊕ da))

    f⊚-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f⊚ df2 from f1 to f3
    f⊚-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a1) (f3 a2)
        (df1 a1 (nil a1))
        (df2 a1 da)
        (dff1 (nil a1) a1 a1 (nil-fromto a1))
        (dff2 da a1 a2 daa)

    f⊚2-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f2⊚ df2 from f1 to f3
    f⊚2-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa rewrite fromto→⊕ da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a2) (f3 a2)
        (df1 a1 da)
        (df2 a2 (nil a2))
        (dff1 da a1 a2 daa)
        (dff2 (nil a2) a2 a2 (nil-fromto a2))

  funCS = record
    { Ch = fCh
    ; ch_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _f⊕_
        ; fromto→⊕ = λ df f1 f2 dff →
          ext (λ v →
            fromto→⊕ (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
        ; _⊝_ = _f⊝_
        ; ⊝-fromto = f⊝-fromto
        }
      ; _⊚_ = _f⊚_
      ; ⊚-fromto = f⊚-fromto
      }
    }

  -- Products
  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pch_from_to_ : pCh → A × B → A × B → Set
    pch (da , db) from (a1 , b1) to (a2 , b2) = ch da from a1 to a2 × ch db from b1 to b2
    _p⊚_ : pCh → pCh → pCh
    (da1 , db1) p⊚ (da2 , db2) = da1 ⊚[ A ] da2 , db1 ⊚[ B ] db2
    pfromto→⊕ : ∀ dp p1 p2 →
      pch dp from p1 to p2 → p1 p⊕ dp ≡ p2
    pfromto→⊕ (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
      cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
    p⊝-fromto : ∀ (p1 p2 : A × B) → pch p2 p⊝ p1 from p1 to p2
    p⊝-fromto (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
    p⊚-fromto : ∀ p1 p2 p3 dp1 dp2 →
      pch dp1 from p1 to p2 → (pch dp2 from p2 to p3) → pch dp1 p⊚ dp2 from p1 to p3
    p⊚-fromto (a1 , b1) (a2 , b2) (a3 , b3) (da1 , db1) (da2 , db2)
      (daa1 , dbb1) (daa2 , dbb2) =
        ⊚-fromto a1 a2 a3 da1 da2 daa1 daa2 , ⊚-fromto b1 b2 b3 db1 db2 dbb1 dbb2

  instance
    pairCS : ChangeStructure (A × B)
  pairCS = record
    { Ch = pCh
    ; ch_from_to_ = pch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _p⊕_
        ; fromto→⊕ = pfromto→⊕
        ; _⊝_ = _p⊝_
        ; ⊝-fromto = p⊝-fromto
        }
      ; _⊚_ = _p⊚_
      ; ⊚-fromto = p⊚-fromto
      }
    }

  -- Sums
  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    _s⊕2_ : A ⊎ B → SumChange2 → A ⊎ B
    _s⊕2_ s (rp s₁) = s₁
    _s⊕2_ (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    _s⊕2_ (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    _s⊕2_ (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    _s⊕2_ (inj₁ a) (ch₂ db) = inj₁ a -- invalid

    _s⊕_ : A ⊎ B → SumChange → A ⊎ B
    s s⊕ ds = s s⊕2 (convert ds)

    _s⊝2_ : A ⊎ B → A ⊎ B → SumChange2
    _s⊝2_ (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    _s⊝2_ (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    _s⊝2_ s2 s1 = rp s2

    _s⊝_ : A ⊎ B → A ⊎ B → SumChange
    s2 s⊝ s1 = convert₁ (s2 s⊝2 s1)

  data sch_from_to_ : SumChange → A ⊎ B → A ⊎ B → Set where
    -- sft = Sum From To
    sft₁ : ∀ {da a1 a2} (daa : ch da from a1 to a2) → sch (convert₁ (ch₁ da)) from (inj₁ a1) to (inj₁ a2)
    sft₂ : ∀ {db b1 b2} (dbb : ch db from b1 to b2) → sch (convert₁ (ch₂ db)) from (inj₂ b1) to (inj₂ b2)
    sftrp : ∀ s1 s2 → sch (convert₁ (rp s2)) from s1 to s2

  sfromto→⊕2 : (ds : SumChange2) (s1 s2 : A ⊎ B) →
    sch convert₁ ds from s1 to s2 → s1 s⊕2 ds ≡ s2
  sfromto→⊕2 (ch₁ da) (inj₁ a1) (inj₁ a2) (sft₁ daa) = cong inj₁ (fromto→⊕ _ _ _ daa)
  sfromto→⊕2 (ch₂ db) (inj₂ b1) (inj₂ b2) (sft₂ dbb) = cong inj₂ (fromto→⊕ _ _ _ dbb)
  sfromto→⊕2 (rp .s2) .s1 .s2 (sftrp s1 s2) = refl

  sfromto→⊕ : (ds : SumChange) (s1 s2 : A ⊎ B) →
    sch ds from s1 to s2 → s1 s⊕ ds ≡ s2
  sfromto→⊕ ds s1 s2 dss =
    sfromto→⊕2 (convert ds) s1 s2
      (subst (sch_from s1 to s2) (sym (inv1 ds))
        dss)
  s⊝-fromto : (s1 s2 : A ⊎ B) → sch s2 s⊝ s1 from s1 to s2
  s⊝-fromto (inj₁ a1) (inj₁ a2) = sft₁ (⊝-fromto a1 a2)
  s⊝-fromto (inj₂ b1) (inj₂ b2) = sft₂ (⊝-fromto b1 b2)
  s⊝-fromto s1@(inj₁ a1) s2@(inj₂ b2) = sftrp s1 s2
  s⊝-fromto s1@(inj₂ b1) s2@(inj₁ a2) = sftrp s1 s2

  _s⊚2_ : SumChange2 → SumChange2 → SumChange2
  ds1 s⊚2 rp s3 = rp s3
  ch₁ da1 s⊚2 ch₁ da2 = ch₁ (da1 ⊚[ A ] da2)
  rp (inj₁ a2) s⊚2 ch₁ da2 = rp (inj₁ (a2 ⊕ da2))
  ch₂ db1 s⊚2 ch₂ db2 = ch₂ (db1 ⊚[ B ] db2)
  rp (inj₂ b2) s⊚2 ch₂ db2 = rp (inj₂ (b2 ⊕ db2))
  -- Cases for invalid combinations of input changes.
  --
  -- That is, whenever ds2 is a non-replacement change for outputs that ds1
  -- can't produce.
  --
  -- We can prove validity preservation *without* filling this in.
  ds1 s⊚2 ds2 = ds1

  _s⊚_ : SumChange → SumChange → SumChange
  ds1 s⊚ ds2 = convert₁ (convert ds1 s⊚2 convert ds2)

  s⊚-fromto : (s1 s2 s3 : A ⊎ B) (ds1 ds2 : SumChange) →
      sch ds1 from s1 to s2 →
      sch ds2 from s2 to s3 → sch ds1 s⊚ ds2 from s1 to s3

  s⊚-fromto (inj₁ a1) (inj₁ a2) (inj₁ a3) (inj₁ (inj₁ da1)) (inj₁ (inj₁ da2)) (sft₁ daa1) (sft₁ daa2) = sft₁ (⊚-fromto a1 a2 a3 _ _ daa1 daa2)
  s⊚-fromto (inj₂ b1) (inj₂ b2) (inj₂ b3) (inj₁ (inj₂ db1)) (inj₁ (inj₂ db2)) (sft₂ dbb1) (sft₂ dbb2) = sft₂ (⊚-fromto b1 b2 b3 _ _ dbb1 dbb2)
  s⊚-fromto s1 (inj₁ a2) (inj₁ a3) .(inj₂ (inj₁ _)) .(inj₁ (inj₁ _)) (sftrp .s1 .(inj₁ _)) (sft₁ daa) rewrite fromto→⊕ _ a2 a3 daa = sftrp _ _
  s⊚-fromto s1 (inj₂ b2) (inj₂ b3) .(inj₂ (inj₂ _)) .(inj₁ (inj₂ _)) (sftrp .s1 .(inj₂ _)) (sft₂ dbb) rewrite fromto→⊕ _ b2 b3 dbb = sftrp _ _
  s⊚-fromto s1 s2 s3 _ _ _ (sftrp .s2 .s3) = sftrp s1 s3

  -- s⊚-fromto .(inj₂ b1) .(inj₁ a2) (inj₁ a3) .(inj₂ (inj₁ a2)) (inj₁ (inj₁ da2)) (sftrp (inj₂ b1) (inj₁ a2)) (sft₁ daa2) with sfromto→⊕ (inj₁ (inj₁ da2)) _ _ (sft₁ daa2)
  -- s⊚-fromto .(inj₂ b1) .(inj₁ a2) (inj₁ .(a2 ⊕ da2)) .(inj₂ (inj₁ a2)) (inj₁ (inj₁ da2)) (sftrp (inj₂ b1) (inj₁ a2)) (sft₁ daa2) | refl = sftrp (inj₂ b1) (inj₁ (a2 ⊕ da2))
  -- s⊚-fromto .(inj₁ a1) .(inj₂ b2) (inj₂ b3) .(inj₂ (inj₂ b2)) (inj₁ (inj₂ db2)) (sftrp (inj₁ a1) (inj₂ b2)) (sft₂ dbb2) with sfromto→⊕ (inj₁ (inj₂ db2)) _ _ (sft₂ dbb2)
  -- s⊚-fromto .(inj₁ a1) .(inj₂ b2) (inj₂ .(b2 ⊕ db2)) .(inj₂ (inj₂ b2)) (inj₁ (inj₂ db2)) (sftrp (inj₁ a1) (inj₂ b2)) (sft₂ dbb2) | refl = sftrp (inj₁ a1) (inj₂ (b2 ⊕ db2))

  instance
    sumCS : ChangeStructure (A ⊎ B)
  sumCS = record
    { Ch = SumChange
    ; ch_from_to_ = sch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = _s⊕_
      ; fromto→⊕ = sfromto→⊕
      ; _⊝_ = _s⊝_
      ; ⊝-fromto = s⊝-fromto
      }
      ; _⊚_ = _s⊚_
      ; ⊚-fromto = s⊚-fromto
      }
    }

instance
  unitCS : ChangeStructure ⊤

  unitCS = record
    { Ch = ⊤
    ; ch_from_to_ = λ dv v1 v2 → ⊤
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = λ _ _ → tt
      ; fromto→⊕ = λ { _ _ tt _ → refl }
      ; _⊝_ = λ _ _ → tt
      ; ⊝-fromto = λ a b → tt
      }
      ; _⊚_ = λ da1 da2 → tt
      ; ⊚-fromto = λ a1 a2 a3 da1 da2 daa1 daa2 → tt
      }
    }