open import Mockingbird.Forest using (Forest)

-- To Mock a Mockingbird
module Mockingbird.Problems.Chapter09 {b ℓ} (forest : Forest {b} {ℓ}) where

open import Data.Product using (_,_; proj₁; proj₂; ∃-syntax)
open import Function using (_$_)
open import Level using (_⊔_)
open import Relation.Nullary using (¬_)

open import Mockingbird.Forest.Birds forest

open Forest forest

module _ ⦃ _ : HasComposition ⦄ ⦃ _ : HasMockingbird ⦄ where
  problem₁ : ∀ A → ∃[ B ] A IsFondOf B
  problem₁ A =
    let C = A ∘ M

        isFond : A IsFondOf (C ∙ C)
        isFond = sym $ begin
          C ∙ C        ≈⟨ isComposition A M C ⟩
          A ∙ (M ∙ C)  ≈⟨ congˡ (isMockingbird C) ⟩
          A ∙ (C ∙ C)  ∎

    in (C ∙ C , isFond)

module _ ⦃ _ : HasComposition ⦄ ⦃ _ : HasMockingbird ⦄ where
  problem₂ : ∃[ E ] IsEgocentric E
  problem₂ =
    let (E , isFond) = problem₁ M

        isEgocentric : IsEgocentric E
        isEgocentric = begin
          E ∙ E  ≈˘⟨ isMockingbird E ⟩
          M ∙ E  ≈⟨ isFond ⟩
          E      ∎

    in (E , isEgocentric)

module _ ⦃ _ : HasComposition ⦄ (hasAgreeable : ∃[ A ] IsAgreeable A) where
  A = proj₁ hasAgreeable
  isAgreeable = proj₂ hasAgreeable

  problem₃ : ∀ B → ∃[ C ] B IsFondOf C
  problem₃ B =
    let D = B ∘ A
        (x , Ax≈Dx) = isAgreeable D

        isFond : B IsFondOf (A ∙ x)
        isFond = begin
          B ∙ (A ∙ x)  ≈˘⟨ isComposition B A x ⟩
          D ∙ x        ≈˘⟨ Ax≈Dx ⟩
          A ∙ x        ∎

    in (A ∙ x , isFond)

-- Bonus question of Problem 3.
C₂→HasAgreeable : ⦃ _ : HasMockingbird ⦄ → ∃[ A ] IsAgreeable A
C₂→HasAgreeable = (M , λ B → (B , isMockingbird B))

module _ ⦃ _ : HasComposition ⦄ (A B C : Bird) (Cx≈A[Bx] : IsComposition A B C) where
  problem₄ : IsAgreeable C → IsAgreeable A
  problem₄ C-isAgreeable D =
    let E = D ∘ B
        (x , Cx≈Ex) = C-isAgreeable E

        agree : Agree A D (B ∙ x)
        agree = begin
          A ∙ (B ∙ x)  ≈˘⟨ Cx≈A[Bx] x ⟩
          C ∙ x        ≈⟨ Cx≈Ex ⟩
          E ∙ x        ≈⟨ isComposition D B x ⟩
          D ∙ (B ∙ x)  ∎

    in (B ∙ x , agree)

module _ ⦃ _ : HasComposition ⦄ where
  problem₅ : ∀ A B C → ∃[ D ] (∀ x → D ∙ x ≈ A ∙ (B ∙ (C ∙ x)))
  problem₅ A B C =
    let E = B ∘ C
        D = A ∘ E
    in (D , λ x → trans (isComposition A E x) $ congˡ (isComposition B C x))

module _ ⦃ _ : HasComposition ⦄ ⦃ _ : HasMockingbird ⦄ where
  problem₆ : ∀ A B → Compatible A B
  problem₆ A B =
    let C = A ∘ B
        (y , Cy≈y) = problem₁ C
        x = B ∙ y
    in (x , y , trans (sym (isComposition A B y)) Cy≈y , refl)

problem₇ : ∀ A → ∃[ B ] A IsFondOf B → IsHappy A
problem₇ A (B , AB≈B) = (B , B , AB≈B , AB≈B)
-- problem₇ : ∀ A → IsNormal A → IsHappy A

module _ ⦃ _ : HasComposition ⦄ where
  problem₈ : ∃[ H ] IsHappy H → ∃[ N ] IsNormal N
  problem₈ (H , x , y , Hx≈y , Hy≈x) =
    let N = H ∘ H

        isFond : N IsFondOf x
        isFond = begin
          N ∙ x        ≈⟨ isComposition H H x ⟩
          H ∙ (H ∙ x)  ≈⟨ congˡ Hx≈y ⟩
          H ∙ y        ≈⟨ Hy≈x ⟩
          x            ∎

    in (N , x , isFond)

module _ ⦃ _ : HasComposition ⦄ ⦃ _ : HasMockingbird ⦄ ⦃ _ : HasKestrel ⦄ where
  problem₉ : ∃[ A ] IsHopelesslyEgocentric A
  problem₉ =
    let (A , KA≈A) = problem₁ K

        isHopelesslyEgocentric : IsHopelesslyEgocentric A
        isHopelesslyEgocentric x = begin
          A ∙ x        ≈˘⟨ congʳ KA≈A ⟩
          (K ∙ A) ∙ x  ≈⟨ isKestrel A x ⟩
          A            ∎

    in (A , isHopelesslyEgocentric)

problem₁₀ : ∀ x y → x IsFixatedOn y → x IsFondOf y
problem₁₀ x y xz≈y = xz≈y y

problem₁₁ : ∀ K → IsKestrel K → IsEgocentric K → IsHopelesslyEgocentric K
problem₁₁ K isKestrel KK≈K x = begin
  K ∙ x        ≈˘⟨ congʳ KK≈K ⟩
  (K ∙ K) ∙ x  ≈⟨ isKestrel K x ⟩
  K            ∎

problem₁₂ : ⦃ _ : HasKestrel ⦄ → ∀ x → IsEgocentric (K ∙ x) → K IsFondOf x
problem₁₂ x [Kx][Kx]≈Kx = begin
  K ∙ x              ≈˘⟨ [Kx][Kx]≈Kx ⟩
  (K ∙ x) ∙ (K ∙ x)  ≈⟨ isKestrel x (K ∙ x) ⟩
  x                  ∎

problem₁₃ : ∀ A x y → IsHopelesslyEgocentric A → A ∙ x ≈ A ∙ y
problem₁₃ A x y Az≈A = begin
  A ∙ x  ≈⟨ Az≈A x ⟩
  A      ≈˘⟨ Az≈A y ⟩
  A ∙ y  ∎

problem₁₄ : ∀ A x y → IsHopelesslyEgocentric A → (A ∙ x) ∙ y ≈ A
problem₁₄ A x y Az≈A = begin
  (A ∙ x) ∙ y  ≈⟨ congʳ (Az≈A x) ⟩
  A ∙ y        ≈⟨ Az≈A y ⟩
  A            ∎

problem₁₅ : ∀ A x → IsHopelesslyEgocentric A → IsHopelesslyEgocentric (A ∙ x)
problem₁₅ A x Az≈A y = begin
  (A ∙ x) ∙ y  ≈⟨ congʳ (Az≈A x) ⟩
  A ∙ y        ≈⟨ Az≈A y ⟩
  A            ≈˘⟨ Az≈A x ⟩
  A ∙ x        ∎

problem₁₆ : ∀ K → IsKestrel K → ∀ x y → K ∙ x ≈ K ∙ y → x ≈ y
problem₁₆ K isKestrel x y Kx≈Ky = begin
  x            ≈˘⟨ isKestrel x K ⟩
  -- NOTE: for the right-most kestrel, we can choose any bird. (Since we know
  -- only of three birds to exist here, the only option is a combination of
  -- {K, x, y}).
  (K ∙ x) ∙ K  ≈⟨ congʳ Kx≈Ky ⟩
  (K ∙ y) ∙ K  ≈⟨ isKestrel y K ⟩
  y            ∎

problem₁₇ : ∀ A x y → A IsFixatedOn x → A IsFixatedOn y → x ≈ y
problem₁₇ A x y Az≈x Az≈y = begin
  x      ≈˘⟨ Az≈x A ⟩
  -- NOTE: for the right-most A, we can choose any bird. (In this case a
  -- combination of {A, B, C}).
  A ∙ A  ≈⟨ Az≈y A ⟩
  y      ∎

problem₁₈ : ⦃ _ : HasKestrel ⦄ → ∀ x → K IsFondOf K ∙ x → K IsFondOf x
problem₁₈ x K[Kx]≈Kx = begin
  K ∙ x              ≈˘⟨ isKestrel (K ∙ x) x ⟩
  -- NOTE: for the right-most x, we can choose any bird.
  (K ∙ (K ∙ x)) ∙ x  ≈⟨ congʳ K[Kx]≈Kx ⟩
  (K ∙ x) ∙ x        ≈⟨ isKestrel x x ⟩
  x                  ∎

-- In the circumstances of Problem 19, the only bird in the forest is the
-- kestrel.
problem₁₉ : ∀ K → IsKestrel K → IsEgocentric K → ∀ x → x ≈ K
problem₁₉ K isKestrel KK≈K x = begin
  x            ≈⟨ lemma x x ⟩
  K ∙ x        ≈˘⟨ congʳ KK≈K ⟩
  (K ∙ K) ∙ x  ≈⟨ isKestrel K x ⟩
  K            ∎
  where
    lemma : ∀ y z → y ≈ K ∙ z
    lemma y z = begin
      y                  ≈˘⟨ isKestrel y z ⟩
      (K ∙ y) ∙ z        ≈˘⟨ congʳ (congʳ KK≈K) ⟩
      ((K ∙ K) ∙ y) ∙ z  ≈⟨ congʳ (isKestrel K y) ⟩
      K ∙ z              ∎

module _ ⦃ _ : HasIdentity ⦄ where
  problem₂₀ : IsAgreeable I → ∀ A → ∃[ B ] A IsFondOf B
  problem₂₀ isAgreeable A =
    let (B , IB≈AB) = isAgreeable A

        isFond : A IsFondOf B
        isFond = begin
          A ∙ B  ≈˘⟨ IB≈AB ⟩
          I ∙ B  ≈⟨ isIdentity B ⟩
          B      ∎

    in (B , isFond)

  problem₂₁ : (∀ A → ∃[ B ] A IsFondOf B) → IsAgreeable I
  problem₂₁ isFond A =
    let (B , AB≈B) = isFond A

        agree : I ∙ B ≈ A ∙ B
        agree = begin
          I ∙ B  ≈⟨ isIdentity B ⟩
          B      ≈˘⟨ AB≈B ⟩
          A ∙ B  ∎

    in (B , agree)

  problem₂₂-1 : (∀ A B → Compatible A B) → ∀ A → IsNormal A
  problem₂₂-1 compatible A =
    let (x , y , Ix≈y , Ay≈x) = compatible I A

        isFond : A IsFondOf y
        isFond = begin
          A ∙ y  ≈⟨ Ay≈x ⟩
          x      ≈˘⟨ isIdentity x ⟩
          I ∙ x  ≈⟨ Ix≈y ⟩
          y      ∎
    in (y , isFond)

  problem₂₂-2 : (∀ A B → Compatible A B) → IsAgreeable I
  problem₂₂-2 compatible A =
    let (x , y , Ix≈y , Ay≈x) = compatible I A

        agree : Agree I A y
        agree = begin
          I ∙ y  ≈⟨ isIdentity y ⟩
          y      ≈˘⟨ Ix≈y ⟩
          I ∙ x  ≈⟨ isIdentity x ⟩
          x      ≈˘⟨ Ay≈x ⟩
          A ∙ y  ∎

    in (y , agree)

  problem₂₃ : IsHopelesslyEgocentric I → ∀ x → I ≈ x
  problem₂₃ isHopelesslyEgocentric x = begin
    I      ≈˘⟨ isHopelesslyEgocentric x ⟩
    I ∙ x  ≈⟨ isIdentity x ⟩
    x      ∎

module _ ⦃ _ : HasLark ⦄ ⦃ _ : HasIdentity ⦄ where
  problem₂₄ : HasMockingbird
  problem₂₄ = record
    { M = L ∙ I
    ; isMockingbird = λ x → begin
        (L ∙ I) ∙ x  ≈⟨ isLark I x ⟩
        I ∙ (x ∙ x)  ≈⟨ isIdentity (x ∙ x) ⟩
        x ∙ x        ∎
    }

module _ ⦃ _ : HasLark ⦄ where
  problem₂₅ : ∀ x → IsNormal x
  problem₂₅ x =
    let isFond : x IsFondOf (L ∙ x) ∙ (L ∙ x)
        isFond = begin
          x ∙ ((L ∙ x) ∙ (L ∙ x))  ≈˘⟨ isLark x (L ∙ x) ⟩
          (L ∙ x) ∙ (L ∙ x)        ∎
    in ((L ∙ x) ∙ (L ∙ x) , isFond)

  problem₂₆ : IsHopelesslyEgocentric L → ∀ x → x IsFondOf L
  problem₂₆ isHopelesslyEgocentric x = begin
    x ∙ L        ≈˘⟨ congˡ $ isHopelesslyEgocentric L ⟩
    x ∙ (L ∙ L)  ≈˘⟨ isLark x L ⟩
    (L ∙ x) ∙ L  ≈⟨ congʳ $ isHopelesslyEgocentric x ⟩
    L ∙ L        ≈⟨ isHopelesslyEgocentric L ⟩
    L            ∎

module _ ⦃ _ : HasLark ⦄ ⦃ _ : HasKestrel ⦄ where
  problem₂₇ : L ≉ K → ¬ L IsFondOf K
  problem₂₇ L≉K isFond =
    let K-fondOf-KK : K IsFondOf K ∙ K
        K-fondOf-KK = begin
          K ∙ (K ∙ K)              ≈˘⟨ congʳ isFond ⟩
          (L ∙ K) ∙ (K ∙ K)        ≈⟨ isLark K (K ∙ K) ⟩
          K ∙ ((K ∙ K) ∙ (K ∙ K))  ≈⟨ congˡ $ isKestrel K (K ∙ K) ⟩
          K ∙ K                    ∎

        isEgocentric : IsEgocentric K
        isEgocentric = problem₁₈ K K-fondOf-KK

        L≈K : L ≈ K
        L≈K = problem₁₉ K isKestrel isEgocentric L

    in L≉K L≈K

  problem₂₈ : K IsFondOf L → ∀ x → x IsFondOf L
  problem₂₈ KL≈L =
    let isHopelesslyEgocentric : IsHopelesslyEgocentric L
        isHopelesslyEgocentric y = begin
          L ∙ y        ≈˘⟨ congʳ KL≈L ⟩
          (K ∙ L) ∙ y  ≈⟨ isKestrel L y ⟩
          L            ∎
    in problem₂₆ isHopelesslyEgocentric

module _ ⦃ _ : HasLark ⦄ where
  problem₂₉ : ∃[ x ] IsEgocentric x
  problem₂₉ =
    let (y , [LL]y≈y) = problem₂₅ (L ∙ L)

        isEgocentric : IsEgocentric (y ∙ y)
        isEgocentric = begin
          (y ∙ y) ∙ (y ∙ y)  ≈˘⟨ isLark (y ∙ y) y ⟩
          (L ∙ (y ∙ y)) ∙ y  ≈˘⟨ congʳ (isLark L y) ⟩
          ((L ∙ L) ∙ y) ∙ y  ≈⟨ congʳ [LL]y≈y ⟩
          y ∙ y              ∎

        -- The expression of yy in terms of L and brackets.
        _  : y ∙ y ≈ ((L ∙ (L ∙ L)) ∙ (L ∙ (L ∙ L))) ∙ ((L ∙ (L ∙ L)) ∙ (L ∙ (L ∙ L)))
        _ = refl

    in (y ∙ y , isEgocentric)


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

open import Agda.Primitive
open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules

{- Decidability of type cheking for the type theory for globular sets -}
module GSeTT.Dec-Type-Checking where

  dec-⊢C : ∀ Γ → dec (Γ ⊢C)
  dec-⊢T : ∀ Γ A → dec (Γ ⊢T A)
  dec-⊢t : ∀ Γ A t → dec (Γ ⊢t t # A)
  dec-⊢S : ∀ Δ Γ γ → dec (Δ ⊢S γ > Γ)

  private
    Γ+⊢→Γ⊢ : ∀ {Γ x A} → (Γ :: (x , A)) ⊢C → Γ ⊢C
    Γ+⊢→Γ⊢ (cc Γ⊢ _ idp) = Γ⊢

    Γ+⊢→x=l : ∀ {Γ x A} → (Γ :: (x , A)) ⊢C → x == length Γ
    Γ+⊢→x=l (cc _ _ idp) = idp

    Γ+⊢→Γ⊢A : ∀ {Γ x A} → (Γ :: (x , A)) ⊢C → Γ ⊢T A
    Γ+⊢→Γ⊢A (cc _ Γ⊢A _) = Γ⊢A

    Γ⊢t⇒u→Γ⊢A : ∀ {Γ A t u} → Γ ⊢T ⇒ A t u → Γ ⊢T A
    Γ⊢t⇒u→Γ⊢A (ar Γ⊢t:A Γ⊢u:A) = Γ⊢t:A→Γ⊢A Γ⊢t:A

    Γ⊢t⇒u→Γ⊢t : ∀ {Γ A t u} → Γ ⊢T ⇒ A t u → Γ ⊢t t # A
    Γ⊢t⇒u→Γ⊢t (ar Γ⊢t:A Γ⊢u:A) = Γ⊢t:A

    Γ⊢t⇒u→Γ⊢u : ∀ {Γ A t u} → Γ ⊢T ⇒ A t u → Γ ⊢t u # A
    Γ⊢t⇒u→Γ⊢u (ar Γ⊢t:A Γ⊢u:A) = Γ⊢u:A

    Γ⊢x:A→x∈Γ : ∀ {Γ x A} → Γ ⊢t Var x # A → x # A ∈ Γ
    Γ⊢x:A→x∈Γ (var _ x∈Γ) = x∈Γ

    Δ⊢<>:Γ→Γ=nil : ∀ {Δ Γ} → Δ ⊢S nil > Γ → Γ == nil
    Δ⊢<>:Γ→Γ=nil (es _) = idp

    Δ⊢γ:⊘→γ=nil : ∀ {Δ γ} → Δ ⊢S γ > nil → γ == nil
    Δ⊢γ:⊘→γ=nil (es _) = idp

    Δ⊢γ+:Γ+→x=y : ∀ {Δ Γ x A γ y t} → Δ ⊢S (γ :: (y , t)) > (Γ :: (x , A)) → x == y
    Δ⊢γ+:Γ+→x=y (sc _ _ _ idp) = idp

    Δ⊢γ+:Γ+→Δ⊢t : ∀ {Δ Γ x A γ y t} → Δ ⊢S (γ :: (y , t)) > (Γ :: (x , A)) → Δ ⊢t t # (A [ γ ]Pre-Ty)
    Δ⊢γ+:Γ+→Δ⊢t (sc _ _ Δ⊢t idp) = Δ⊢t

    Δ⊢γ+:Γ+→Δ⊢γ : ∀ {Δ Γ x A γ y t} → Δ ⊢S (γ :: (y , t)) > (Γ :: (x , A)) → Δ ⊢S γ > Γ
    Δ⊢γ+:Γ+→Δ⊢γ (sc Δ⊢γ:Γ _ _ idp) = Δ⊢γ:Γ

  eqdec-Ty : eqdec Pre-Ty
  eqdec-Tm : eqdec Pre-Tm

  eqdec-Ty ∗ ∗ = inl idp
  eqdec-Ty ∗ (⇒ _ _ _) = inr λ{()}
  eqdec-Ty (⇒ _ _ _) ∗ = inr λ{()}
  eqdec-Ty (⇒ A t u) (⇒ B t' u') with eqdec-Ty A B | eqdec-Tm t t' | eqdec-Tm u u'
  ...                                      | inl idp       | inl idp       | inl idp      = inl idp
  ...                                      | inl idp       | inl idp       | inr u≠u'     = inr λ p → u≠u' (snd (=⇒ p))
  ...                                      | inl idp       | inr t≠t'      | _            = inr λ p → t≠t' (snd (fst (=⇒ p)))
  ...                                      | inr A≠B       | _             | _            = inr λ p → A≠B (fst (fst (=⇒ p)))
  eqdec-Tm (Var x) (Var y) with eqdecℕ x y
  ...                               | inl idp = inl idp
  ...                               | inr x≠y = inr λ p → x≠y (=Var p)

  dec-∈ : ∀ Γ x A → dec (x # A ∈ Γ)
  dec-∈ nil x A = inr λ x → x
  dec-∈ (Γ :: (y , B)) x A with (eqdecℕ y x) | (eqdec-Ty B A)
  ...                       | inl idp         | inl idp = inl (inr (idp , idp))
  ...                       | inl idp         | inr B≠A       with dec-∈ Γ x A
  ...                                                         | inl x∈Γ = inl (inl x∈Γ)
  ...                                                         | inr x∉Γ = inr λ {(inl x∈Γ) → x∉Γ x∈Γ ; (inr (_ , A=B)) → B≠A (A=B ^)}
  dec-∈ (Γ :: (y , B)) x A | inr y≠x         | _   with dec-∈ Γ x A
  ...                                               | inl x∈Γ = inl (inl x∈Γ)
  ...                                               | inr x∉Γ = inr λ{ (inl x∈Γ) → x∉Γ x∈Γ ; (inr (x=y , _)) → y≠x (x=y ^)}

  dec-⊢C nil = inl ec
  dec-⊢C (Γ :: (x , A)) with dec-⊢C Γ | eqdecℕ x (length Γ) | dec-⊢T Γ A
  ...                        | inl Γ⊢ | inl idp              | inl Γ⊢A      = inl (cc Γ⊢ Γ⊢A idp)
  ...                        | inl  _ | inl idp              | inr Γ⊬A      = inr λ Γ+⊢ → Γ⊬A (Γ+⊢→Γ⊢A Γ+⊢)
  ...                        | inl Γ⊢ | inr n≠l              | _            = inr λ Γ+⊢ → n≠l (Γ+⊢→x=l Γ+⊢)
  ...                        | inr Γ⊬ | _                    | _            = inr λ Γ+⊢ → Γ⊬ (Γ+⊢→Γ⊢ Γ+⊢)
  dec-⊢T Γ ∗ with dec-⊢C Γ
  ...             | inl Γ⊢ = inl (ob Γ⊢)
  ...             | inr Γ⊬ = inr λ Γ⊢* → Γ⊬ (Γ⊢A→Γ⊢ Γ⊢*)
  dec-⊢T Γ (⇒ A t u) with dec-⊢t Γ A t | dec-⊢t Γ A u
  ...                     | inl Γ⊢t:A    | inl Γ⊢u:A = inl (ar Γ⊢t:A Γ⊢u:A)
  ...                     | inl _        | inr Γ⊬u:A = inr λ Γ⊢t⇒u → Γ⊬u:A (Γ⊢t⇒u→Γ⊢u Γ⊢t⇒u)
  ...                     | inr Γ⊬t:A    | _         = inr λ Γ⊢t⇒u → Γ⊬t:A (Γ⊢t⇒u→Γ⊢t Γ⊢t⇒u)

  dec-⊢t Γ A (Var x) with dec-⊢C Γ       | dec-∈ Γ x A
  ...                     | inl Γ⊢          | inl x∈Γ      = inl (var Γ⊢ x∈Γ)
  ...                     | inl _           | inr x∉Γ      = inr λ Γ⊢x:A → x∉Γ (Γ⊢x:A→x∈Γ Γ⊢x:A)
  ...                     | inr Γ⊬          | _            = inr λ Γ⊢x:A → Γ⊬ (Γ⊢t:A→Γ⊢ Γ⊢x:A)
  dec-⊢S Δ nil nil with dec-⊢C Δ
  ...              | inl Δ⊢ = inl (es Δ⊢)
  ...              | inr Δ⊬ = inr λ Δ⊢<>:⊘ → Δ⊬ (Δ⊢γ:Γ→Δ⊢ Δ⊢<>:⊘)
  dec-⊢S Δ (Γ :: _) nil = inr λ Δ⊢<>:Γ → cons≠nil (Δ⊢<>:Γ→Γ=nil Δ⊢<>:Γ)
  dec-⊢S Δ nil (γ :: a) = inr λ Δ⊢γ:⊘ → cons≠nil (Δ⊢γ:⊘→γ=nil Δ⊢γ:⊘)
  dec-⊢S Δ (Γ :: (x , A)) (γ :: (y , t)) with dec-⊢S Δ Γ γ | dec-⊢C (Γ :: (x , A)) | dec-⊢t Δ (A [ γ ]Pre-Ty) t | eqdecℕ x y
  ...                                    | inl Δ⊢γ:Γ       | inl Γ+⊢               | inl Δ⊢t                    | inl idp    = inl (sc Δ⊢γ:Γ Γ+⊢ Δ⊢t idp)
  ...                                    | inl _           | inl _                 | inl _                      | inr x≠y    = inr λ Δ⊢γ+:Γ+ → x≠y (Δ⊢γ+:Γ+→x=y Δ⊢γ+:Γ+)
  ...                                    | inl _           | inl _                 | inr Δ⊬t                    | _          = inr λ Δ⊢γ+:Γ+ → Δ⊬t (Δ⊢γ+:Γ+→Δ⊢t Δ⊢γ+:Γ+)
  ...                                    | inl _           | inr Γ+⊬               | _                          | _          = inr λ Δ⊢γ+:Γ+ → Γ+⊬ (Δ⊢γ:Γ→Γ⊢ Δ⊢γ+:Γ+)
  ...                                    | inr Δ⊬γ         | _                     | _                          | _          = inr λ Δ⊢γ+:Γ+ → Δ⊬γ (Δ⊢γ+:Γ+→Δ⊢γ Δ⊢γ+:Γ+)


module BTA9 where

----------------------------------------------
-- Preliminaries: Imports and List-utilities
----------------------------------------------

open import Data.Nat hiding  (_<_;_⊔_;_*_;equal)
open import Data.Bool hiding (_∧_;_∨_)
open import Function using (_∘_)
open import Data.List
open import Data.Nat.Properties
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Empty

open import Lib

---------------------------------------
-- Start of the development:
---------------------------------------

-- Intro/Objective:
-------------------
-- The following development defines a (verified) specializer/partial
-- evaluator for a simply typed lambda calculus embedded in Agda using
-- deBruijn indices.

-- The residual language.
-------------------------

-- The residual language is a standard simply typed λ-calculus.  The
-- types are integers,functions,pairs,and sums.
data Type : Set where
  Int : Type
  Fun : Type → Type → Type
    --pair type on the residual type level
  _•_ : Type  → Type  → Type
  --sum type on the residual type level
  _⊎_ : Type → Type → Type

Ctx = List Type

-- The type Exp describes the typed residual expressions. Variables
-- are represented by deBruijn indices that form references into the
-- typing context. The constructors and typing constraints are
-- standard.

-- TODO: citations for ``as usual'' and ``standard''
-- what?
data Exp (Γ : Ctx) : Type → Set where
  EVar : ∀ {τ} → τ ∈ Γ → Exp Γ τ
  EInt : ℕ → Exp Γ Int
  EAdd : Exp Γ Int → Exp Γ Int -> Exp Γ Int
  ELam : ∀ {τ τ'} → Exp (τ ∷ Γ) τ' → Exp Γ (Fun τ τ')
  EApp : ∀ {τ τ'} → Exp Γ (Fun τ τ')  → Exp Γ τ → Exp Γ τ'
  _,_  : ∀ {τ τ'} → Exp Γ τ → Exp Γ τ' → Exp Γ (τ • τ')
  Tl   : ∀ {τ τ'} → Exp Γ τ → Exp Γ (τ ⊎ τ')
  Tr   : ∀ {τ τ'} → Exp Γ τ' → Exp Γ (τ ⊎ τ')
  EFst : ∀ {τ τ'} → Exp Γ (τ • τ') → Exp Γ τ
  ESnd : ∀ {τ τ'} → Exp Γ (τ • τ') → Exp Γ τ'
  ECase : ∀ {τ τ' τ''} → Exp Γ (τ ⊎ τ') → Exp (τ ∷ Γ) τ'' → Exp (τ' ∷ Γ) τ'' → Exp Γ τ''

-- The standard functional semantics of the residual expressions.
-- TODO: citations for ``as usual'' and ``standard''
-- what?
module Exp-Eval where
  -- interpretation of Exp types
  EImp : Type → Set
  EImp Int = ℕ
  EImp (Fun ty ty₁) = EImp ty → EImp ty₁
  EImp (ty • ty₁) = EImp ty * EImp ty₁
  EImp (ty ⊎ ty₁) = EImp ty ⨄ EImp ty₁

  -- Environments containing values for free variables. An environment
  -- is indexed by a typing context that provides the types for the
  -- contained values.
  data Env : Ctx → Set where
    [] : Env []
    _∷_ : ∀ {τ Γ} → EImp τ → Env Γ → Env (τ ∷ Γ)

  -- Lookup a value in the environment, given a reference into the
  -- associated typing context.
  lookupE : ∀ { τ Γ } → τ ∈ Γ → Env Γ → EImp τ
  lookupE hd (x ∷ env) = x
  lookupE (tl v) (x ∷ env) = lookupE v env

  -- Evaluation of residual terms, given a suitably typed environment.
  ev : ∀ {τ Γ} → Exp Γ τ → Env Γ → EImp τ
  ev (EVar x) env = lookupE x env
  ev (EInt x) env = x
  ev (EAdd e e₁) env = ev e env + ev e₁ env
  ev (ELam e) env = λ x → ev e (x ∷ env)
  ev (EApp e e₁) env = ev e env (ev e₁ env)
  ev (e , e₁) env = ev e env , (ev e₁ env)
  ev (Tl e) env = tl (ev e env)
  ev (Tr e) env = tr (ev e env)
  ev (EFst e) env = fst (ev e env)
  ev (ESnd e) env = snd (ev e env)
  ev (ECase e e₁ e₂) env with ev e env
  ev (ECase e e₁ e₂) env | tl c  = (λ x → ev e₁ (x ∷ env)) c
  ev (ECase e e₁ e₂) env | tr c  = (λ x → ev e₂ (x ∷ env)) c

-- The binding-time-annotated language.
---------------------------------------

-- The type of a term determines the term's binding time. The type
-- constructors with an A-prefix denote statically bound integers and
-- functions. Terms with dynamic binding time have a `D' type. The `D'
-- type constructor simply wraps up a residual type.
data AType : Set where
    AInt  : AType
    AFun  : AType → AType → AType
    D     : Type → AType
    --pair type on the annotated type level
    _•_   : AType → AType → AType
    --sum  type on the annotated type level
    _⊎_   : AType → AType → AType

ACtx = List AType

-- The mapping from annotated types to residual types is straightforward.
typeof : AType → Type
typeof AInt = Int
typeof (AFun α₁ α₂) = Fun (typeof α₁) (typeof α₂)
typeof (D x) = x
typeof (α₁ • α₂) = typeof α₁ • typeof α₂
typeof (α₁ ⊎ α₂) = typeof α₁ ⊎ typeof α₂

-- The typed annotated terms: The binding times of variables is
-- determined by the corresponding type-binding in the context. In the
-- other cases, the A- and D-prefixes on term constructors inidicate
-- the corresponding binding times for the resulting terms.

  ------------------------------------------------------------------------------------------------
  -- Now the typed annotated terms are extended to inculde dynamic terms whose subterms are static
  ------------------------------------------------------------------------------------------------
  ---------------
  --Some examples
  ---------------
  --a. first-order static value in a dynamic environment
  -- DAdd (DInt 1) (AAdd (AInt 2) (AInt 3)) where AAdd (AInt 2) (AInt 3) : AExp [] AInt
  -- DAdd (DInt 1) (AApp (ALam (Var hd)) (AInt 5)) where AApp (ALam (Var hd)) (AInt 5) : AExp [] AInt
  --b. higher-order static value in a dynamic environment
  -- DApp (ALam (Var hd)) (DInt 5) where ALam (Var hd) : AExp [] (AFun (D Int) (D Int))
  -- DApp (ALam (ALam (AInt 0))) (DInt 5) where ALam (ALam (AInt 0)) : AExp [] (AFun (AFun (D Int) (D Int)) AInt)
  -- DApp (ALam (ALam (DInt 0))) (DInt 5) where ALam (ALam (DInt 0)) : AExp [] (AFun (AFun AInt (D Int)) (D Int))

  --Clearly these terms are not well-typed and we need to modify [AExp] such that they have the right types which are
  --compatible with the dynamic environment,or we can "lift" their static types to dynamic types so that they can be
  --used as dynamic sub-terms to be filled in the right dynamic environment. This,however,brings new difficulty when
  --we try to partially evaluate term who contains "lifted" subterms.

  ----------------
  --new difficulty
  ----------------
  --Consider the evaluation of the following term
  --DAdd (DInt 1) (Lift (AAdd (AInt 2) (AInt 3))) : AExp [] AInt
  --the expected type after evaluation is,
  --EAdd (EInt 1) ? : Exp [] Int where ? : Exp [] Int
  --and one good candidate for "?" as,
  --EInt (pe (AAdd (AInt 2) (AInt 3)) []) : Exp [] Int
  --where we wrap up the partial evaluation of the static subterm so
  --that it fits with the rest of evaluation.
  --However,we can not always "wrap up" a evaluated higher-order static
  --value so that it has the required residual type,
  --ALam (Var hd) : AExp [] (AFun AInt AInt)
  --the required type of its lifted term as,
  --? : Exp [] (Fun Int Int)
  --which can not be constructed from [λ Γ↝Γ' x → x : []↝Γ' → ℕ → ℕ]
  --for the input of the static function is evaluated to be a natural
  --number which can not be matched with the type of the input of the
  --required residual term. It is then clear that we need to impose
  --restriction upon terms to be lifted.
  -------------------------
  --restriction for lifting
  -------------------------
-------------------------------------------------------------
-- The interpretation of annotated types.
Imp : Ctx → AType → Set
Imp Γ (AInt) = ℕ
Imp Γ (AFun α₁ α₂) = ∀ {Γ'} → Γ ↝ Γ' → (Imp Γ' α₁ → Imp Γ' α₂)
Imp Γ (D σ) = Exp Γ σ
Imp Γ (α₁ • α₂) = (Imp Γ α₁) * (Imp Γ α₂)
Imp Γ (α₁ ⊎ α₂) = (Imp Γ α₁) ⨄ (Imp Γ α₂)

elevate-var : ∀ {Γ Γ'} {τ : Type} → Γ ↝ Γ' → τ ∈ Γ → τ ∈ Γ'
elevate-var ↝-refl x = x
elevate-var (↝-extend Γ↝Γ') x = tl (elevate-var Γ↝Γ' x)

elevate-var2 : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → τ ∈ Γ → τ ∈ Γ''
elevate-var2 (↝↝-base x) x₁ = elevate-var x x₁
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') hd = hd
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') (tl x) = tl (elevate-var2 Γ↝Γ'↝Γ'' x)

elevate : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → Exp Γ τ → Exp Γ'' τ
elevate Γ↝Γ'↝Γ'' (EVar x) = EVar (elevate-var2 Γ↝Γ'↝Γ'' x)
elevate Γ↝Γ'↝Γ'' (EInt x) = EInt x
elevate Γ↝Γ'↝Γ'' (EAdd e e₁) = EAdd (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)
elevate Γ↝Γ'↝Γ'' (ELam e) = ELam (elevate (↝↝-extend Γ↝Γ'↝Γ'') e)
elevate Γ↝Γ'↝Γ'' (EApp e e₁) = EApp (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)
elevate Γ↝Γ'↝Γ'' (e ,  e₁) =  ((elevate Γ↝Γ'↝Γ'' e) , (elevate Γ↝Γ'↝Γ'' e₁))
elevate Γ↝Γ'↝Γ'' (Tl e) = Tl (elevate Γ↝Γ'↝Γ'' e)
elevate Γ↝Γ'↝Γ'' (Tr e) = Tr (elevate Γ↝Γ'↝Γ'' e)
elevate Γ↝Γ'↝Γ'' (EFst e) = EFst (elevate Γ↝Γ'↝Γ'' e)
elevate Γ↝Γ'↝Γ'' (ESnd e) = ESnd (elevate Γ↝Γ'↝Γ'' e)
elevate Γ↝Γ'↝Γ'' (ECase c e₁ e₂) = ECase (elevate Γ↝Γ'↝Γ'' c) (elevate (↝↝-extend Γ↝Γ'↝Γ'') e₁) (elevate (↝↝-extend Γ↝Γ'↝Γ'') e₂)

liftE : ∀ {τ Γ Γ'} → Γ ↝ Γ' → Exp Γ τ → Exp Γ' τ
liftE Γ↝Γ' e = elevate (↝↝-base Γ↝Γ') e
-------------------------------------------------------------
-- --case 1. a first-order static value in a dynamic environment
-- lift1 : AExp [] AInt
-- lift1 = (AInt 0)

-- e1 : Imp [] AInt
-- e1 = 0

-- lifted1 : Exp [] (typeof AInt)
-- lifted1 = EInt e1
-- --case 2. higher-order static function in a dynamic environment
-- --a. a function whose input argument is of static integer
-- --lift2 : AExp [] (AFun AInt AInt)
-- --lift2 = ALam (Var hd)

-- --e2 : Imp [] (AFun AInt AInt)
-- --e2 = λ Γ↝Γ' x → x

-- --lifted2 : Exp [] (typeof (AFun AInt AInt))
-- --lifted2 = ELam {!!}
-- --Note that as explained above it is impossible to construct the right term using [e2]
-- --to fill in the above hole!

-- --b. a function whose input argument is of dynamic integer
-- --b.1. when return type is of dynamic integer
-- lift3 : AExp [] (AFun (D Int) (D Int))
-- lift3 = ALam (Var hd)

-- e3 : Imp [] (AFun (D Int) (D Int))
-- e3 =  λ Γ↝Γ' x → x

-- liftede3 : Exp [] (typeof (AFun (D Int) (D Int)))
-- liftede3 = ELam (e3 (↝-extend ↝-refl) (EVar hd))
-- --b.2. when return type is of static integer
-- lift4 : AExp [] (AFun (D Int) AInt)
-- lift4 = ALam (AInt 0)

-- e4 : Imp [] (AFun (D Int) AInt)
-- e4 = λ Γ↝Γ' x → 0

-- liftede4 : Exp [] (typeof (AFun (D Int) AInt))
-- liftede4 = ELam ( EInt {Int ∷ []} (e4 (↝-extend ↝-refl) (EVar hd)))

-- --c. a function whose input argument is of static function type
-- --c.1. static function type returns a static integer
-- --lift5 : AExp []  (AFun (AFun AInt AInt) AInt)
-- --lift5 = ALam (AApp (Var hd) (AInt 0))

-- --e5 : Imp []  (AFun (AFun AInt AInt) AInt)
-- --e5 = λ Γ↝Γ' x → x ↝-refl 0

-- --liftede5 : Exp [] (typeof ( AFun (AFun AInt AInt) AInt))
-- --liftede5 =  ELam (EInt (e5 (↝-extend {τ = Fun Int Int} ↝-refl) (λ Γ↝Γ' e' → {!!})))
-- --Note that again it is impossible to construct the right residual term

-- --c.2. static function type returns a dynamic integer
-- --c.2.1. the input of the function type is of static integer
-- lift6 : AExp []  (AFun (AFun AInt (D Int)) (D Int))
-- lift6 = ALam (AApp (Var hd) (AInt 0))

-- e6 : Imp []  (AFun (AFun AInt (D Int)) (D Int))
-- e6 = λ Γ↝Γ' x → x ↝-refl 0

-- liftede6 : Exp [] (typeof ( AFun (AFun AInt (D Int)) (D Int)))
-- liftede6 =  ELam ((e6 (↝-extend {τ = Fun Int Int} ↝-refl)
--                 (λ Γ↝Γ' e' → EApp (liftE Γ↝Γ' (EVar {Fun Int Int ∷ []} hd)) (EInt e'))))
-- --c.2.1. the input of the function type is of dynamic integer
-- lift7 : AExp []  (AFun (AFun (D Int) (D Int)) (D Int))
-- lift7 = ALam (AApp (Var hd) (DInt 0))

-- e7 : Imp []  (AFun (AFun (D Int) (D Int)) (D Int))
-- e7 = λ Γ↝Γ' x → x ↝-refl (EInt 0)

-- liftede7 : Exp [] (typeof ( AFun (AFun (D Int) (D Int)) (D Int)))
-- liftede7 =  ELam ((e7 (↝-extend {τ = Fun Int Int} ↝-refl)
--                 (λ Γ↝Γ' e' → EApp (liftE Γ↝Γ' (EVar {Fun Int Int ∷ []} hd)) e')))
-- --c.3. the output of the function type is of higher-order static value
-- --c.3.1 the return value has one static integer as input
-- -- lift8 : AExp []  (AFun (D Int) (AFun AInt (D Int)))
-- -- lift8 = ALam (ALam (Var (tl hd)))

-- -- e8 : Imp []  (AFun (D Int) (AFun AInt (D Int)))
-- -- e8 = λ Γ↝Γ' x Γ'↝Γ'' y → liftE Γ'↝Γ'' x

-- -- liftede8 : Exp [] (typeof ( AFun (D Int) (AFun AInt (D Int))))
-- -- liftede8 =  ELam (ELam (e8 (↝-extend (↝-extend ↝-refl)) (EVar (tl hd)) ↝-refl {!!}))

-- --c.3.2 the return value has one dynamic integer as input
-- lift9 : AExp []  (AFun (D Int) (AFun (D Int) (D Int)))
-- lift9 = ALam (ALam (Var (tl hd)))

-- e9 : Imp []  (AFun (D Int) (AFun (D Int) (D Int)))
-- e9 = λ Γ↝Γ' x Γ'↝Γ'' y → liftE Γ'↝Γ'' x

-- liftede9 : Exp [] (typeof ( AFun (D Int) (AFun (D Int) (D Int))))
-- liftede9 =  ELam (ELam (e9 (↝-extend (↝-extend ↝-refl)) (EVar (tl hd)) ↝-refl (EVar hd)))

-- --d. static pairs and sums in dynamic environment
-- --d.1. identity function with  static sum as its input
-- lift10 : AExp [] (AFun ((D Int) ⊎ (D Int)) ((D Int) ⊎ (D Int)))
-- lift10 = ALam (Var hd)

-- e10 : Imp [] (AFun ((D Int) ⊎ (D Int)) ((D Int) ⊎ (D Int)))
-- e10 =  λ Γ↝Γ' x → x

-- liftede10 : Exp [] (typeof (AFun ((D Int) ⊎ (D Int)) ((D Int) ⊎ (D Int))))
-- liftede10 = ELam {!e10!}

-- --d.1. identity function with  static sum as its input
-- lift11 : AExp [] (AFun ((D Int) • (D Int)) ((D Int) • (D Int)))
-- lift11 = ALam (Var hd)

-- e11 : Imp [] (AFun ((D Int) • (D Int)) ((D Int) • (D Int)))
-- e11 =  λ Γ↝Γ' x → x

-- liftede11 : Exp [] (typeof (AFun ((D Int) • (D Int)) ((D Int) • (D Int))))
-- liftede11 = ELam (fst (e11 (↝-extend ↝-refl) (EFst (EVar hd) , ESnd (EVar hd))) ,
--                     snd (e11 (↝-extend ↝-refl) (EFst (EVar hd) , ESnd (EVar hd))))

--Note that the above two examples in section "d" clearly shows that
--"static functions with inputs of static sum type are not liftable
-- while with inputs of static pair type are liftable ".

---------------------------
--summary on liftable terms
---------------------------
--a. Regarding static first-order static value (static integer) in dynamic environment
--   All terms of static integer type are liftable
--b. Regarding static higher-order static value in dynamic environment
--b.1. given that output value is liftable
--     • when input is of first-order dynamic type,liftable
--     • when input is of higher-order static type and output
--       of that input is of dynamic type,liftable
--b.2. given that input value is liftable
--     • when output is of first-order type,liftable
--     • when output is of higher-order type and inputs
--       of that type are of dynamic type,liftable

-------------------------------------------
--specification of the liftable restriction
-------------------------------------------
mutual
  data Liftable : AType → Set where
    D : ∀ τ → Liftable (D τ)
    AInt : Liftable AInt
    _⊎_ : ∀ {α₁ α₂} → Liftable α₁ → Liftable α₂ → Liftable (α₁ ⊎ α₂)
    _•_ : ∀ {α₁ α₂} → Liftable α₁ → Liftable α₂ → Liftable (α₁ • α₂)
    AFun : ∀ {α₁ α₂} → Liftable⁻ α₁ → Liftable α₂ → Liftable (AFun α₁ α₂)

  data Liftable⁻ : AType → Set where
    D : ∀ τ → Liftable⁻ (D τ)
    _•_ : ∀ {α₁ α₂} → Liftable⁻ α₁ → Liftable⁻ α₂ → Liftable⁻ (α₁ • α₂)
    AFun : ∀ {α₁ α₂} → Liftable α₁ → Liftable⁻ α₂ → Liftable⁻ (AFun α₁ α₂)
----------------------------------------
--[AExp] with liftable terms
----------------------------------------
data AExp (Δ : ACtx) : AType → Set where
  Var : ∀ {α} → α ∈ Δ → AExp Δ α
  AInt : ℕ → AExp Δ AInt
  AAdd : AExp Δ AInt → AExp Δ AInt → AExp Δ AInt
  ALam : ∀ {α₁ α₂}   → AExp (α₁ ∷ Δ) α₂ → AExp Δ (AFun α₁ α₂)
  AApp : ∀ {α₁ α₂}   → AExp Δ (AFun α₂ α₁) → AExp Δ α₂ → AExp Δ α₁
  DInt : ℕ → AExp Δ (D Int)
  DAdd : AExp Δ (D Int) → AExp Δ (D Int) → AExp Δ (D Int)
  DLam : ∀ {σ₁ σ₂}   → AExp ((D σ₁) ∷ Δ) (D σ₂) → AExp Δ (D (Fun σ₁ σ₂))
  DApp : ∀ {α₁ α₂}   → AExp Δ (D (Fun α₂ α₁)) → AExp Δ (D α₂) → AExp Δ (D α₁)
  -- Static pairs and sums
  _,_  : ∀ {α₁ α₂} → AExp Δ α₁ → AExp Δ α₂ → AExp Δ (α₁ • α₂)
  Tl   : ∀ {α₁ α₂} → AExp Δ α₁ → AExp Δ (α₁ ⊎ α₂)
  Tr   : ∀ {α₁ α₂} → AExp Δ α₂ → AExp Δ (α₁ ⊎ α₂)
  Fst  : ∀ {α₁ α₂} → AExp Δ (α₁ • α₂) → AExp Δ α₁
  Snd  : ∀ {α₁ α₂} → AExp Δ (α₁ • α₂) → AExp Δ α₂
  Case : ∀ {α₁ α₂ α₃} → AExp Δ (α₁ ⊎ α₂) → AExp (α₁ ∷ Δ) α₃ → AExp (α₂ ∷ Δ) α₃ → AExp Δ α₃
  -- Dynamic pairs and sums
  _ḋ_  : ∀ {σ₁ σ₂} → AExp Δ (D σ₁) → AExp Δ (D σ₂) → AExp Δ (D (σ₁ • σ₂))
  DTl   : ∀ {σ₁ σ₂} → AExp Δ (D σ₁) → AExp Δ (D (σ₁ ⊎ σ₂))
  DTr   : ∀ {σ₁ σ₂} → AExp Δ (D σ₂) → AExp Δ (D (σ₁ ⊎ σ₂))
  DFst  : ∀ {σ₁ σ₂} → AExp Δ (D (σ₁ • σ₂)) → AExp Δ (D σ₁)
  DSnd  : ∀ {σ₁ σ₂} → AExp Δ (D (σ₁ • σ₂)) → AExp Δ (D σ₂)
  DCase : ∀ {σ₁ σ₂ σ₃} → AExp Δ (D (σ₁ ⊎ σ₂)) → AExp ((D σ₁) ∷ Δ) (D σ₃) → AExp ((D σ₂) ∷ Δ) (D σ₃) → AExp Δ (D σ₃)
  -- Liftable static terms
  ↑     : ∀ {α} → Liftable α → AExp Δ α  → AExp Δ (D (typeof α))

-- The terms of AExp assign a binding time to each subterm. For
-- program specialization, we interpret terms with dynamic binding
-- time as the programs subject to specialization, and their subterms
-- with static binding time as statically known inputs. A partial
-- evaluation function (or specializer) then compiles the program into
-- a residual term for that is specialized for the static inputs. The
-- main complication when defining partial evaluation as a total,
-- primitively recursive function will be the treatment of the De
-- Bruijn variables of non-closed residual expressions.

lift : ∀ {Γ Γ'} α → Γ ↝ Γ' → Imp Γ α → Imp Γ' α
lift AInt p v = v
lift (AFun x x₁) Γ↝Γ' v = λ Γ'↝Γ'' → v (↝-trans Γ↝Γ' Γ'↝Γ'')
lift (D x₁) Γ↝Γ' v = elevate (↝↝-base Γ↝Γ') v
lift (α₁ • α₂) Γ↝Γ' (v₁ , v₂) = (lift α₁ Γ↝Γ' v₁) , (lift α₂ Γ↝Γ' v₂)
lift (α₁ ⊎ α₂) Γ↝Γ' (tl v) = tl (lift α₁ Γ↝Γ' v)
lift (α₁ ⊎ α₂) Γ↝Γ' (tr v) = tr (lift α₂ Γ↝Γ' v)

module SimpleAEnv where
  -- A little weaker, but much simpler
  data AEnv (Γ : Ctx) : ACtx → Set where
    [] : AEnv Γ []
    --cons : ∀ {Δ} (α : AType) → Imp Γ α → AEnv Γ Δ → AEnv Γ (α ∷ Δ)
    cons : ∀ {Δ} {α : AType} → Imp Γ α → AEnv Γ Δ → AEnv Γ (α ∷ Δ)

  lookup : ∀ {α Δ Γ} → AEnv Γ Δ → α ∈ Δ → Imp Γ α
  lookup [] ()
  --lookup {α} (cons .α  x aenv) hd = x
  --lookup {α} (cons .y  x aenv) (tl {.α} {y} id) = lookup aenv id
  lookup {α} (cons x aenv) hd = x
  lookup {α} (cons x aenv) (tl {.α} {y} id) = lookup aenv id

  liftEnv : ∀ {Γ Γ' Δ} → Γ ↝ Γ' → AEnv Γ Δ → AEnv Γ' Δ
  liftEnv Γ↝Γ' [] = []
  --liftEnv Γ↝Γ' (cons α x env) = cons α (lift α Γ↝Γ' x) (liftEnv Γ↝Γ' env)
  liftEnv Γ↝Γ' (cons {α = α} x env) = cons {α = α} (lift α Γ↝Γ' x) (liftEnv Γ↝Γ' env)

  consD : ∀ {Γ Δ} σ → AEnv Γ Δ → AEnv (σ ∷ Γ) (D σ ∷ Δ)
  --consD σ env = (cons (D σ) (EVar hd) (liftEnv (↝-extend {τ = σ} ↝-refl) env))
  consD σ env = (cons {α = D σ} (EVar hd) (liftEnv (↝-extend {τ = σ} ↝-refl) env))

----------------------------------------------
-- Helper for the evaluation of liftable terms
----------------------------------------------
  mutual
    lift' : ∀ {Γ α} → Liftable α → Imp Γ α → (Exp Γ (typeof α))
    lift' (D τ) v = v
    lift' AInt v = EInt v
    lift' (ty ⊎ ty₁) (tl a) = Tl (lift' ty a)
    lift' (ty ⊎ ty₁) (tr b) = Tr (lift' ty₁ b)
    lift' (ty • ty₁) (ffst , ssnd) = lift' ty ffst , lift' ty₁ ssnd
    lift' {Γ} (AFun {α₁} ty₁ ty₂) v = ELam
                                        ((λ x → lift' ty₂ (v (↝-extend {τ = typeof α₁} ↝-refl) x))
                                         (embed ty₁ (EVar {Γ = typeof α₁ ∷ Γ} hd)))

    embed : ∀ {Γ α} → Liftable⁻ α → Exp Γ (typeof α) → (Imp Γ α)
    embed (D τ) e = e
    -- embed (ty ⊎ ty₁) e = {!  (ECase e (EVar hd) ?)!}
    -- embed (ty ⊎ ty₁) (EVar x) = {!!}
    -- embed (ty ⊎ ty₁) (EApp e e₁) = {!!}
    -- embed (ty ⊎ ty₁) (Tl e) = tl (embed ty e)
    -- embed (ty ⊎ ty₁) (Tr e) = tr (embed ty₁ e)
    -- embed (ty ⊎ ty₁) (EFst e) = {!!}
    -- embed (ty ⊎ ty₁) (ESnd e) = {!!}
    -- embed (ty ⊎ ty₁) (ECase e e₁ e₂) = {!!}
    embed (ty • ty₁) e = embed ty (EFst e) , embed ty₁ (ESnd e)
    embed {Γ} (AFun {α} ty₁ ty₂) e =
      λ Γ↝Γ' v₁ → embed ty₂ (EApp (liftE Γ↝Γ' e) (lift' ty₁ v₁))
--------------------
-- Partial Evaluator
--------------------
  pe : ∀ {α Δ Γ} → AExp Δ α → AEnv Γ Δ → Imp Γ α
  pe (Var x) env = lookup env x
  pe (AInt x) env = x
  pe (AAdd e e₁) env = pe e env + pe e₁ env
  pe (ALam {α} e) env = λ Γ↝Γ' → λ y → pe e (cons {α = α} y (liftEnv Γ↝Γ' env))
  pe (AApp e e₁) env = pe e env ↝-refl (pe e₁ env)
  pe (DInt x) env = EInt x
  pe (DAdd e e₁) env = EAdd (pe e env) (pe e₁ env)
  pe (DLam {σ} e) env = ELam (pe e (consD σ env))
  pe (DApp e e₁) env = EApp (pe e env) (pe e₁ env)
  pe {Γ = Γ} (e , e₁) env = pe {Γ = Γ} e env , pe {Γ = Γ} e₁ env
  pe {α = α₁ ⊎ α₂} {Γ = Γ} (Tl e) env = tl (pe {α = α₁} {Γ = Γ} e env)
  pe {α = α₁ ⊎ α₂} {Γ = Γ} (Tr e) env = tr (pe {α = α₂} {Γ = Γ} e env)
  pe {Γ = Γ} (Fst e) env = fst (pe {Γ = Γ} e env)
  pe {Γ = Γ} (Snd e) env = snd (pe {Γ = Γ} e env)
  pe {Γ = Γ} (Case e e₁ e₂) env with pe {Γ = Γ} e env
  pe {Γ = Γ} (Case {α₁ = α} e e₁ e₂) env | tl y = (λ Γ↝Γ' → λ y → pe e₁ (cons {α = α} y (liftEnv Γ↝Γ' env))) ↝-refl y
  pe {Γ = Γ} (Case {α₂ = α} e e₁ e₂) env | tr y = (λ Γ↝Γ' → λ y → pe e₂ (cons {α = α} y (liftEnv Γ↝Γ' env))) ↝-refl y
  pe (e ḋ e₁) env = pe e env , pe e₁ env
  pe (DTl e) env = Tl (pe e env)
  pe (DTr e) env = Tr (pe e env)
  pe (DFst e) env = EFst (pe e env)
  pe (DSnd e) env = ESnd (pe e env)
  pe (DCase {σ₁} {σ₂} e e₁ e₂) env = ECase (pe e env) (pe e₁ (consD σ₁ env)) (pe e₂ (consD σ₂ env))
  pe (↑ x e) env = lift' x (pe e env)

-- Correctness proof

module Correctness where
  open SimpleAEnv
  open Exp-Eval

  -- TODO: rename occurences of stripα to typeof
  stripα = typeof

  stripΔ : ACtx → Ctx
  stripΔ = map stripα

  strip-lookup : ∀ { α Δ} → α ∈ Δ → stripα α ∈ stripΔ Δ
  strip-lookup hd = hd
  strip-lookup (tl x) = tl (strip-lookup x)

  strip : ∀ {α Δ} → AExp Δ α → Exp (stripΔ Δ) (stripα α)
  strip (Var x) = EVar (strip-lookup x)
  strip (AInt x) = EInt x
  strip (AAdd e e₁) = EAdd (strip e) (strip e₁)
  strip (ALam e) = ELam (strip e)
  strip (AApp e e₁)  = EApp (strip e) (strip e₁)
  strip (DInt x)  = EInt x
  strip (DAdd e e₁) = EAdd (strip e) (strip e₁)
  strip (DLam e)  = ELam (strip e)
  strip (DApp e e₁)  = EApp (strip e) (strip e₁)
  strip (e , e₁)  = strip e  , strip e₁
  strip (Tl e)  = Tl (strip e)
  strip (Tr e)  = Tr (strip e)
  strip (Fst e)  = EFst (strip e)
  strip (Snd e)  = ESnd (strip e)
  strip (Case e e₁ e₂)  = ECase (strip e) (strip e₁) (strip e₂)
  strip (e ḋ e₁)  = strip e  , strip e₁
  strip (DTl e)  = Tl (strip e)
  strip (DTr e)  = Tr (strip e)
  strip (DFst e)  = EFst (strip e)
  strip (DSnd e)  = ESnd (strip e)
  strip (DCase e e₁ e₂)  = ECase (strip e) (strip e₁) (strip e₂)
  strip (↑ x e) = strip e

  --liftE : ∀ {τ Γ Γ'} → Γ ↝ Γ' → Exp Γ τ → Exp Γ' τ
  --liftE Γ↝Γ' e = elevate (↝↝-base Γ↝Γ') e

  stripLift : ∀ {α Δ Γ} → stripΔ Δ ↝ Γ → AExp Δ α  → Exp Γ (stripα α)
  stripLift Δ↝Γ = liftE Δ↝Γ ∘ strip

  -- --------------------------------
  -- --"lift-strip" equivalence lemma
  -- --------------------------------
  -- ↑≡↓ : ∀ x e env env' aenv → Equiv-Env env' aenv env  → ev (lift' x (pe e aenv)) env'  ≡ ev (strip e) env
  -- ↑≡↓ x e env env' aenv eqenv = {!!}

  -- We want to show that pe preserves the semantics of the
  -- program. Roughly, Exp-Eval.ev-ing a stripped program is
  -- equivalent to first pe-ing a program and then Exp-Eval.ev-ing the
  -- result. But as the pe-result of a static function ``can do more''
  -- than the (ev ∘ strip)ped function we need somthing more refined.

  module Equiv where
    open import Relation.Binary.PropositionalEquality

    -- Extending a value environment according to an extension of a
    -- type environment
    data _⊢_↝_ {Γ} : ∀ {Γ'} → Γ ↝ Γ' → Env Γ → Env Γ' → Set where
      refl : ∀ env → ↝-refl ⊢ env ↝ env
      extend : ∀ {τ Γ' env env'} →  {Γ↝Γ' : Γ ↝ Γ'} →
                 (v : EImp τ) → (Γ↝Γ' ⊢  env ↝ env')  →
                 ↝-extend {Γ = Γ} {Γ' = Γ'} {τ = τ} Γ↝Γ' ⊢ env ↝ (v ∷ env')

    env↝trans : ∀ {Γ Γ' Γ''} {Γ↝Γ' : Γ ↝ Γ'} {Γ'↝Γ'' : Γ' ↝ Γ''}
                  {env env' env''} →
                  Γ↝Γ' ⊢ env ↝ env' → Γ'↝Γ'' ⊢ env' ↝ env'' →
                  let Γ↝Γ'' = ↝-trans Γ↝Γ' Γ'↝Γ'' in
                  Γ↝Γ'' ⊢ env ↝ env''
    env↝trans {Γ} {.Γ''} {Γ''} {Γ↝Γ'} {.↝-refl} {env} {.env''} {env''} env↝env' (refl .env'') = env↝env'
    env↝trans env↝env' (extend v env'↝env'') = extend v (env↝trans env↝env' env'↝env'')

    -- Equivalent Imp Γ α and EImp τ values (where τ = stripα α). As
    -- (v : Imp Γ α) is not necessarily closed, equivalence is defined for
    -- the closure (Env Γ, ImpΓ α)
    Equiv : ∀ {α Γ} → Env Γ → Imp Γ α → EImp (stripα α) → Set
    Equiv {AInt} env av v = av ≡ v
    Equiv {AFun α₁ α₂} {Γ} env av v = ∀ {Γ' env' Γ↝Γ'} →
                                        (Γ↝Γ' ⊢ env ↝ env') →
                                        {av' : Imp Γ' α₁} →
                                        {v' : EImp (stripα α₁)} →
                                        Equiv {α₁} {Γ'} env' av' v' → Equiv {α₂} env' (av Γ↝Γ' av') (v v')
    Equiv {D x} env av v = ev av env ≡ v
    Equiv {α • α₁} env (ffst , ssnd) (ffst₁ , ssnd₁) = (Equiv {α} env ffst ffst₁) ∧ (Equiv {α₁} env ssnd ssnd₁)
    Equiv {α ⊎ α₁} env (tl a) (tl a₁) = Equiv {α} env a a₁
    --------------------------------------------------------------------
    Equiv {α ⊎ α₁} env (tl a) (tr b) = ⊥  -- Interesting case!
    Equiv {α ⊎ α₁} env (tr b) (tl a) = ⊥  -- Interesting case!
    --------------------------------------------------------------------
    Equiv {α ⊎ α₁} env (tr b) (tr b₁) = Equiv {α₁} env b b₁
   -- Equiv {AInt} env av v = av ≡ v
   -- Equiv {AFun α₁ α₂} {Γ} env av v = -- extensional equality, given -- an extended context
   --     ∀ {Γ' env' Γ↝Γ'} → (Γ↝Γ' ⊢ env ↝ env') →
   --     {av' : Imp Γ' α₁} → {v' : EImp (stripα α₁)} →
   --     Equiv env' av' v' → Equiv env' (av Γ↝Γ' av') (v v')
   -- Equiv {D x} {Γ} env av v = ev av env ≡ v -- actually we mean extensional equality
                                             -- TODO: Define a proper equivalence for EImps

    -- Equivalence of AEnv and Env environments. They need to provide
    -- Equivalent bindings for a context Δ/stripΔ Δ. Again, the
    -- equivalence is defined for a closure (Env Γ', AEnv Γ' Δ).
    data Equiv-Env {Γ' : _} (env' : Env Γ') :
      ∀ {Δ} → let Γ = stripΔ Δ in
      AEnv Γ' Δ → Env Γ → Set where
      [] : Equiv-Env env' [] []
      cons : ∀ {α Δ} → let τ = stripα α
                           Γ = stripΔ Δ in
              {env : Env Γ} → {aenv : AEnv Γ' Δ} →
              Equiv-Env env' aenv env →
              (va : Imp (Γ') α) → (v : EImp τ) →
              Equiv {α} {Γ'} env' va v →
              --Equiv-Env env' (cons α va (aenv)) (v ∷ env)
              Equiv-Env env' (cons {α = α} va (aenv)) (v ∷ env)

  --------------------------------
  --"lift-strip" equivalence lemma
  --------------------------------
    -- ↑≡↓ : ∀ {Γ' Δ α} x e env env' aenv → Equiv-Env {Γ'} env' {Δ} aenv env  → ev (lift' {Γ = Γ'} {α = α} x (pe e aenv)) env'  ≡ ev (strip e) env
    -- ↑≡↓ x e env env' aenv eqenv = {!!}

  -- Now for the proof...
  module Proof where
    open Equiv
    open import Relation.Binary.PropositionalEquality

    -- Extensional equality as an axiom to prove the Equivalence of
    -- function values.  We could (should?) define it locally for
    -- Equiv.
    postulate ext : ∀ {τ₁ τ₂} {f g : EImp τ₁ → EImp τ₂} →
                    (∀ x → f x ≡ g x) → f ≡ g

    -- Ternary helper relation for environment extensions, analogous to _↝_↝_ for contexts
    data _⊢_↝_↝_⊣ : ∀ { Γ Γ' Γ''} → Γ ↝ Γ' ↝ Γ'' → Env Γ → Env Γ' → Env Γ'' → Set where
      refl : ∀ {Γ Γ''} {Γ↝Γ'' : Γ ↝ Γ''} { env env'' } →
             Γ↝Γ'' ⊢ env ↝ env'' →
             ↝↝-base Γ↝Γ'' ⊢ env ↝ [] ↝ env'' ⊣
      extend : ∀ {Γ Γ' Γ'' τ} {Γ↝Γ'↝Γ'' : Γ ↝ Γ' ↝ Γ''} { env env' env'' } →
               Γ↝Γ'↝Γ'' ⊢ env ↝ env' ↝ env'' ⊣ →
               (v : EImp τ) → ↝↝-extend {Γ = Γ} {Γ' = Γ'} {Γ'' = Γ''} {τ = τ} Γ↝Γ'↝Γ'' ⊢ (v ∷ env) ↝ (v ∷ env') ↝ (v ∷ env'') ⊣

    -- the following lemmas are strong versions of the shifting
    -- functions, proving that consistent variable renaming preserves
    -- equivalence (and not just typing).
    lookup-elevate-≡ : ∀ {τ Γ Γ'} {Γ↝Γ' : Γ ↝ Γ'}
                       {env : Env Γ} {env' : Env Γ'} →
                       Γ↝Γ' ⊢ env ↝ env' →
                       (x : τ ∈ Γ) → lookupE x env ≡ lookupE (elevate-var Γ↝Γ' x) env'
    lookup-elevate-≡ {τ} {.Γ'} {Γ'} {.↝-refl} {.env'} {env'} (refl .env') x = refl
    lookup-elevate-≡ (extend v env↝env') x = lookup-elevate-≡ env↝env' x

    lookup-elevate2-≡ : ∀ {τ Γ Γ' Γ''} {Γ↝Γ'↝Γ'' : Γ ↝ Γ' ↝ Γ''}
                       {env : Env Γ} {env' : Env Γ'} {env'' : Env Γ''} →
                       Γ↝Γ'↝Γ'' ⊢ env ↝ env' ↝ env'' ⊣ →
                       (x : τ ∈ Γ) → lookupE x env ≡ lookupE (elevate-var2 Γ↝Γ'↝Γ'' x) env''
    lookup-elevate2-≡ (refl Γ↝Γ') x = lookup-elevate-≡ Γ↝Γ' x
    lookup-elevate2-≡ (extend env↝env'↝env'' v) hd = refl
    lookup-elevate2-≡ (extend env↝env'↝env'' _) (tl x)
      rewrite lookup-elevate2-≡ env↝env'↝env'' x = refl

    lem-elevate-≡ : ∀ {τ Γ Γ' Γ''}
                      {Γ↝Γ'↝Γ'' : Γ ↝ Γ' ↝ Γ''}
                      {env : Env Γ} {env' : Env Γ'} {env'' : Env Γ''} →
                      Γ↝Γ'↝Γ'' ⊢ env ↝ env' ↝ env'' ⊣ →
                      (e : Exp Γ τ) →
                      ev e env ≡ ev (elevate Γ↝Γ'↝Γ'' e) env''
    lem-elevate-≡ env↝env' (EVar x) = lookup-elevate2-≡ env↝env' x
    lem-elevate-≡ env↝env' (EInt x) = refl
    lem-elevate-≡ env↝env' (EAdd e e₁) with lem-elevate-≡ env↝env' e | lem-elevate-≡ env↝env' e₁
    ... | IA1 | IA2 = cong₂ _+_ IA1 IA2
    lem-elevate-≡ {Fun τ₁ τ₂} {Γ↝Γ'↝Γ'' = Γ↝Γ'↝Γ''}
                  {env = env}
                  {env'' = env''}
                  env↝env' (ELam e) = ext {τ₁} {τ₂} lem-elevate-≡-body
       where lem-elevate-≡-body : ∀ x → ev e (x ∷ env) ≡ ev (elevate (↝↝-extend Γ↝Γ'↝Γ'') e) (x ∷ env'')
             lem-elevate-≡-body x = lem-elevate-≡ (extend env↝env' x) e
    lem-elevate-≡ env↝env' (EApp e e₁) with lem-elevate-≡ env↝env' e | lem-elevate-≡ env↝env' e₁
    ... | IA1 | IA2  = cong₂ (λ f₁ x → f₁ x) IA1 IA2
    lem-elevate-≡ env↝env' (e , e₁) with lem-elevate-≡ env↝env' e | lem-elevate-≡ env↝env' e₁
    ... | IA1 | IA2  = cong₂ (λ x y → x , y) IA1 IA2
    lem-elevate-≡ env↝env' (Tl e) with lem-elevate-≡ env↝env' e
    ... | IA  = cong (λ x → tl x) IA
    lem-elevate-≡ env↝env' (Tr e) with lem-elevate-≡ env↝env' e
    ... | IA  = cong (λ x → tr x) IA
    lem-elevate-≡ env↝env' (EFst e) with lem-elevate-≡ env↝env' e
    ... | IA  = cong (λ x → fst x) IA
    lem-elevate-≡ env↝env' (ESnd e) with lem-elevate-≡ env↝env' e
    ... | IA  = cong (λ x → snd x) IA
    lem-elevate-≡ {Γ↝Γ'↝Γ'' = Γ↝Γ'↝Γ''}
                  {env = env}
                  {env'' = env''}
                  env↝env' (ECase e e₁ e₂) with ev e env | ev (elevate Γ↝Γ'↝Γ'' e) env'' | lem-elevate-≡ env↝env' e
    ... | tl c | tl c' | IA rewrite (→tl {x' = c} {y' = c'} (tl c) (tl c') IA refl refl) = lem-elevate-≡-body c'
         where lem-elevate-≡-body : ∀ x → ev e₁ (x ∷ env) ≡ ev (elevate (↝↝-extend Γ↝Γ'↝Γ'') e₁) (x ∷ env'')
               lem-elevate-≡-body x = lem-elevate-≡ (extend env↝env' x) e₁
    ... | tl c | tr c' | ()
    ... | tr c | tl c' | ()
    ... | tr c | tr c' | IA rewrite (→tr {x' = c} {y' = c'} (tr c) (tr c') IA refl refl) = lem-elevate-≡-body c'
         where lem-elevate-≡-body : ∀ x → ev e₂ (x ∷ env) ≡ ev (elevate (↝↝-extend Γ↝Γ'↝Γ'') e₂) (x ∷ env'')
               lem-elevate-≡-body x = lem-elevate-≡ (extend env↝env' x) e₂

    lem-lift-refl-id : ∀ {α Γ} → let τ = stripα α in
                       (env : Env Γ) →
                       (v : EImp τ) (va : Imp Γ α) →
                       Equiv {α} {Γ} env va v →
                       Equiv {α} {Γ} env (lift α ↝-refl va) v
    lem-lift-refl-id {AInt} env v va eq = eq
    lem-lift-refl-id {AFun α α₁} {Γ} env v va eq = body
        where body : ∀ {Γ'} {env' : Env Γ'} {Γ↝Γ' : Γ ↝ Γ'} →
                     Γ↝Γ' ⊢ env ↝ env' →
                     {av' : Imp Γ' α} {v' : EImp (stripα α)} →
                     Equiv {α} {Γ'} env' av' v' → Equiv {α₁} {Γ'} env' (va (↝-trans ↝-refl Γ↝Γ') av') (v v')
              body {Γ↝Γ' = Γ↝Γ'} env↝env' eq' rewrite sym (lem-↝-refl-id Γ↝Γ') = eq env↝env' eq'

    lem-lift-refl-id {D x} env v va eq rewrite sym eq = sym (lem-elevate-≡ (refl (refl env)) va)
    lem-lift-refl-id {α • α₁} env (ffst , ssnd) (ffst₁ , ssnd₁) (∧-intro x x₁) =
                    ∧-intro (lem-lift-refl-id {α} env ffst ffst₁ x)
                             (lem-lift-refl-id {α₁} env ssnd ssnd₁ x₁)
    lem-lift-refl-id {α ⊎ α₁} env (tl a) (tl a₁) eq = lem-lift-refl-id {α}  env a a₁ eq
    lem-lift-refl-id {α ⊎ α₁} env (tl a) (tr b) ()
    lem-lift-refl-id {α ⊎ α₁} env (tr b) (tl a) ()
    lem-lift-refl-id {α ⊎ α₁} env (tr b) (tr b₁) eq = lem-lift-refl-id {α₁} env b b₁ eq

    -- lifting an Imp does not affect equivalence
    lem-lift-equiv : ∀ {α Γ Γ'} → let τ = stripα α in
                     {Γ↝Γ' : Γ ↝ Γ'} →
                     (va : Imp Γ α) (v : EImp τ) →
                     {env : Env Γ} {env' : Env Γ'} →
                     Γ↝Γ' ⊢ env ↝ env' →
                     Equiv {α} {Γ} env va v →
                     Equiv {α} {Γ'} env' (lift α Γ↝Γ' va) v
    lem-lift-equiv {α} va v {.env'} {env'} (refl .env') eq = lem-lift-refl-id {α} env' v va eq
    lem-lift-equiv {AInt} va v (extend v₁ env↝env') eq = eq
    lem-lift-equiv {AFun α α₁} va v (extend v₁ env↝env') eq =
      λ v₁env₁↝env' eq₁ → eq (env↝trans (extend v₁ env↝env') v₁env₁↝env') eq₁
    lem-lift-equiv {D x} va v (extend v₁ env↝env') eq rewrite sym eq = sym (lem-elevate-≡ (refl (extend v₁ env↝env')) va)
    lem-lift-equiv {α • α₁} (ffst , ssnd) (ffst₁ , ssnd₁) (extend v₁ env↝env') (∧-intro x x₁) =
      ∧-intro (lem-lift-equiv {α} ffst ffst₁ (extend v₁ env↝env') x)
               (lem-lift-equiv {α₁} ssnd ssnd₁ (extend v₁ env↝env') x₁)
    lem-lift-equiv {α ⊎ α₁} (tl a) (tl a₁) (extend v₁ env↝env') eq = lem-lift-equiv {α} a a₁ (extend v₁ env↝env') eq
    lem-lift-equiv {α ⊎ α₁} (tl a) (tr b) (extend v₁ env↝env') ()
    lem-lift-equiv {α ⊎ α₁} (tr b) (tl a) (extend v₁ env↝env') ()
    lem-lift-equiv {α ⊎ α₁} (tr b) (tr b₁) (extend v₁ env↝env') eq = lem-lift-equiv {α₁} b b₁ (extend v₁ env↝env') eq

    lem-equiv-lookup : ∀ {α Δ Γ'} → let Γ = stripΔ Δ in
                       { aenv : AEnv Γ' Δ } {env : Env Γ} →
                       (env' : Env Γ') →
                       Equiv-Env env' aenv env →
                       ∀ (x : α ∈ Δ) → Equiv {α} env' (lookup aenv x) (lookupE (strip-lookup x) env)
    lem-equiv-lookup env' [] ()
    lem-equiv-lookup env' (cons  enveq va v eq) hd = eq
    lem-equiv-lookup env' (cons  enveq va v eq) (tl x) = lem-equiv-lookup env' enveq x

    lem-equiv-env-lift-extend :
      ∀ {σ Γ' Δ} (env' : Env Γ') → let Γ = stripΔ Δ in
        {env : Env Γ} {aenv : AEnv Γ' Δ} →
        Equiv-Env env' aenv env → (x : EImp σ) →
        Equiv-Env {σ ∷ Γ'} (x ∷ env') (liftEnv (↝-extend ↝-refl) aenv) env
    lem-equiv-env-lift-extend _ [] x = []
    lem-equiv-env-lift-extend env' (cons {α} eqenv va v x) x₁ =
      cons (lem-equiv-env-lift-extend env' eqenv x₁)
           (lift α (↝-extend ↝-refl) va) v (lem-lift-equiv {α} va v (extend x₁ (refl env')) x)

    lem-equiv-env-lift-lift :
      ∀ {Γ' Γ'' Δ} → let Γ = stripΔ Δ in
        {Γ↝Γ' : Γ' ↝ Γ''}
        {env' : Env Γ'} {env'' : Env Γ''}
        (env'↝env'' : Γ↝Γ' ⊢ env' ↝ env'') →
        {env : Env Γ} {aenv : AEnv Γ' Δ} →
        Equiv-Env env' aenv env →
        Equiv-Env env'' (liftEnv Γ↝Γ' aenv) env
    lem-equiv-env-lift-lift env'↝env'' [] = []
    lem-equiv-env-lift-lift {Γ↝Γ' = Γ↝Γ'} env'↝env'' (cons {α} eqenv va v x)
      with lem-equiv-env-lift-lift env'↝env'' eqenv
    ... | IA = cons IA (lift α Γ↝Γ' va) v (lem-lift-equiv {α} va v env'↝env'' x)

  --------------------------------
  --"lift-correct" equivalence lemma
  --------------------------------
    open import Data.Product
    mutual
      lift-correct : ∀ {Γ α} (lft : Liftable α) (env : Env Γ) (av : Imp Γ α) (v : EImp (typeof α)) →
                     Equiv {α} {Γ} env av v → (Equiv {D (typeof α)} {Γ} env (lift' lft av) v)
      lift-correct (D τ) env av v eq = eq
      lift-correct AInt env av v eq = eq
      lift-correct (lft ⊎ lft₁) env (tl a) (tl a₁) eq with lift-correct lft env a a₁
      ... | IA rewrite IA eq = refl
      lift-correct (lft ⊎ lft₁) env (tr b) (tl a) ()
      lift-correct (lft ⊎ lft₁) env (tl a) (tr b) ()
      lift-correct (lft ⊎ lft₁) env (tr b) (tr b₁) eq with lift-correct lft₁ env b b₁
      ... | IA rewrite IA eq = refl
      lift-correct (lft • lft₁) env (ffst , ssnd) (ffst₁ , ssnd₁) (∧-intro x x₁)
        rewrite lift-correct lft env ffst ffst₁ x | lift-correct lft₁ env ssnd ssnd₁ x₁ = refl
      lift-correct {Γ} {AFun x lft} (AFun y y') env av v eq =
        ext  {typeof x} {typeof lft} (λ x₁ →
               lift-correct y' (x₁ ∷ env)
               (av (↝-extend ↝-refl) (embed y (EVar hd))) (v x₁) (eq (extend x₁ (refl env)) (embed-correct {typeof x ∷ Γ} {x} y (x₁ ∷ env) (EVar hd) x₁ refl)))

      embed-correct : ∀ {Γ α} (lft : Liftable⁻ α) (env : Env Γ) →  (e : Exp Γ (typeof α)) → (v : EImp (typeof α)) →
                      ev e env  ≡ v → Equiv {α} {Γ} env (embed lft e) v
      embed-correct (D τ) env e v eq rewrite eq = refl
      embed-correct (lft • lft₁) env e (fstv , sndv) eq  = ∧-intro (embed-correct lft env (EFst e) fstv (subst (λ x → ffst x ≡ fstv) (sym eq) refl))
                                                                   (embed-correct lft₁ env (ESnd e) sndv
                                                                      (subst (λ x → ssnd x ≡ sndv) (sym eq) refl))
      embed-correct {α = AFun α₁ α₂} (AFun x lft) env e v eq = f
        where

              f : ∀ {Γ' env' Γ↝Γ'} (x₁ : Γ↝Γ' ⊢ env ↝ env') {x₂ : Imp Γ' α₁} {x₃ : EImp (typeof α₁)}
                    (x₄ : Equiv {α₁} {Γ'} env' x₂ x₃) →
                    Equiv  {α₂} {Γ'} env'
                    (embed lft (EApp (elevate (↝↝-base Γ↝Γ') e) (lift' x x₂))) (v x₃)
              f {Γ'} {env'} {Γext} envext {av'} {v'} eq' =
                embed-correct lft env' (EApp (elevate (↝↝-base Γext) e) (lift' x av')) (v v') g
                where g : ev (elevate (↝↝-base Γext) e) env' (ev (lift' x av') env') ≡ v v'
                      g rewrite lift-correct x env' av' v' eq'
                              | sym (cong (λ f → f v') (lem-elevate-≡ (refl envext) e))
                              |  (cong (λ f → f v') eq) = refl
                      --g = {!!}

    ---------------------------------------
    --Correctness proof with liftable terms
    ---------------------------------------

    -- When we partially evaluate somthing under an environment , it
    -- will give equivalent results to a ``complete'' evaluation under
    -- an equivalent environment
    pe-correct : ∀ { α Δ Γ' } → (e : AExp Δ α) →
                 let Γ = stripΔ Δ in
                 {aenv : AEnv Γ' Δ} → {env : Env Γ} →
                 (env' : Env Γ') →
                 Equiv-Env env' aenv env →
                 Equiv {α} {Γ'} env' (pe e aenv) (ev (strip e) env)
    pe-correct (Var x) env' eqenv = lem-equiv-lookup env' eqenv x
    pe-correct (AInt x) env' eqenv = refl
    pe-correct (AAdd e e₁) env' eqenv
      rewrite pe-correct e env' eqenv | pe-correct e₁ env' eqenv = refl
    pe-correct (ALam e) env' eqenv =
     λ {_} {env''} env'↝env'' {av'} {v'} eq →
         let eqenv' : _
             eqenv' = lem-equiv-env-lift-lift env'↝env'' eqenv
             eqenv'' : _
             eqenv'' = cons eqenv' av' v' eq
         in pe-correct e env'' eqenv''
    pe-correct (AApp e e₁) env' eqenv
      with pe-correct e env' eqenv | pe-correct e₁ env' eqenv
    ... | IAe | IAf = IAe (refl env') IAf
    pe-correct (DInt x) env' eqenv = refl
    pe-correct (DAdd e e₁) env' eqenv
      rewrite pe-correct e env' eqenv | pe-correct e₁ env' eqenv = refl
    pe-correct {α = D (Fun σ₁ σ₂)} (DLam e) env' eqenv =
     ext {σ₁} {σ₂}
      (λ x →
         let eqenv₁ : _
             eqenv₁ = lem-equiv-env-lift-extend env' eqenv x
             eqenv₂ : _
             eqenv₂ = cons eqenv₁ (EVar hd) x refl
         in pe-correct e (x ∷ env') eqenv₂)
    pe-correct (DApp e e₁) env' eqenv
      with pe-correct e₁ env' eqenv | pe-correct e env' eqenv
    ... | IA' | IA = cong₂ (λ f x → f x) IA IA'
    pe-correct (e , e₁) env' eqenv = ∧-intro (pe-correct e env' eqenv) (pe-correct e₁ env' eqenv)
    pe-correct (Tl e) env' eqenv = pe-correct e env' eqenv
    pe-correct (Tr e) env' eqenv = pe-correct e env' eqenv
    pe-correct (Fst (e , e₁)) env' eqenv = pe-correct e env' eqenv
    pe-correct (Fst e) {aenv = aenv} {env = env} env' eqenv with pe e aenv | ev (strip e) env | pe-correct e env' eqenv
    ... | e₁ , e₂ | e₁' , e₂' | ∧-intro A B = A
    pe-correct (Snd (e , e₁)) env' eqenv = pe-correct e₁ env' eqenv
    pe-correct (Snd e) {aenv = aenv} {env = env} env' eqenv with pe e aenv | ev (strip e) env | pe-correct e env' eqenv
    ... | e₁ , e₂ | e₁' , e₂' | ∧-intro A B = B
    pe-correct {α} (Case e e₁ e₂) {aenv = aenv} {env = env} env' eqenv with pe e aenv | ev (strip e) env | pe-correct e env' eqenv
    ... | tl c | tl c' | L = pe-correct e₁ {aenv = cons c (liftEnv ↝-refl aenv)}
                               {env = c' ∷ env} env'
                               (cons (lem-equiv-env-lift-lift (refl env') eqenv) c c' L)
    ... | tr c | tr c' | R = pe-correct e₂ {aenv = cons c (liftEnv ↝-refl aenv)}
                               {env = c' ∷ env} env'
                               (cons (lem-equiv-env-lift-lift (refl env') eqenv) c c' R)
    ... | tr c | tl c' | ()
    ... | tl c | tr c' | ()
    pe-correct (e ḋ e₁) env' eqenv with pe-correct e env' eqenv | pe-correct e₁ env' eqenv
    ... | IA | IA' rewrite IA | IA' = refl
    pe-correct (DTl e) env' eqenv with pe-correct e env' eqenv
    ... | IA rewrite IA = refl
    pe-correct (DTr e) env' eqenv with pe-correct e env' eqenv
    ... | IA rewrite IA = refl
    pe-correct (DFst e) env' eqenv with pe-correct e env' eqenv
    ... | IA rewrite IA = refl
    pe-correct (DSnd e) env' eqenv with pe-correct e env' eqenv
    ... | IA rewrite IA = refl
    pe-correct (DCase e e₁ e₂) {aenv = aenv} {env = env} env' eqenv with ev (pe e aenv) env' | ev (strip e) env | pe-correct e env' eqenv
    ... | tl c | tl c' | IA rewrite (→tl {x' = c} {y' = c'} (tl c) (tl c') IA refl refl) =
      pe-correct e₁
        {aenv = cons (EVar hd) (liftEnv (↝-extend ↝-refl) aenv)}
        {env = c' ∷ env} (c' ∷ env') (cons (lem-equiv-env-lift-lift (extend c' (refl env')) eqenv) (EVar hd) c' refl)
    ... | tr c | tr c' | IA rewrite (→tr {x' = c} {y' = c'} (tr c) (tr c') IA refl refl) =
      pe-correct e₂
        {aenv = cons (EVar hd) (liftEnv (↝-extend ↝-refl) aenv)}
        {env = c' ∷ env} (c' ∷ env')
        (cons (lem-equiv-env-lift-lift (extend c' (refl env')) eqenv)
         (EVar hd) c' refl)
    ... | tl c | tr c' | ()
    ... | tr c | tl c' | ()
    pe-correct (↑ x e) {aenv = aenv} {env = env} env' eqenv
      with pe-correct e env' eqenv
    ... | IA = lift-correct x env' (pe e aenv) (ev (strip e) env) IA


{-# OPTIONS --safe #-}

module Cubical.Categories.Abelian where

open import Cubical.Categories.Abelian.Base public


-- Andreas, 2014-10-23
-- If you must, you can split on a shadowed hidden var...

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

f : {n n : ℕ}  → Set₁
f = Set
  where
  g : {n n : ℕ} → Set → Set
  g _ = {!.n!}


module Open2 where

data ⊤
  : Set
  where

  tt
    : ⊤

data ⊤'
  (x : ⊤)
  : Set
  where

  tt
    : ⊤' x

record R
  : Set
  where

  field

    x
      : ⊤

    y
      : ⊤

record S
  : Set₁
  where

  field

    x
      : R

  open R x public
    renaming (x to y; y to z)

postulate

  s
    : S

open S s
  using (y)

postulate

  p
    : ⊤' y


-- Andreas, 2016-06-20
-- Issue #191, reported 2009-12-02 by Nisse

data T (A : Set) : Set → Set1 where
  c₁ : {B : Set} → T A B
  c₂ :             T A A

foo : {A B C : Set} → T A (B → C) → T A B → Set₁
foo c₁ y = Set
foo x  y = {!y!}

-- WAS:
-- Perform the indicated case split. Agda will happily replace the
-- last clause with two separate clauses, one for each constructor
-- of T, but the resulting file is not type correct:

-- Bug.agda:8,1-10,13
-- Cannot split on the constructor c₂
-- when checking the definition of foo

-- In this case Agda should not modify the source file, it is
-- preferable to just give an error indicating that the split cannot
-- be performed.

-- NOW (Agda-2.5.2):
-- I'm not sure if there should be a case for the constructor c₂,
-- because I get stuck when trying to solve the following unification
-- problems (inferred index ≟ expected index):
--   A ≟ A → C
-- when checking that the expression ? has type Set₁

-- Current behavior (not splitting) is correct.


open import Agda.Builtin.Unit

data D : Set where
  c₁ c₂ : D
  @0 c₃ : D

f : @0 D → ⊤
f c₁ = tt
f c₂ = tt
f c₃ = tt


module Logic.Linear where

open import Data.Nat using (ℕ; zero; suc)
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_; _++_; map)
open import Data.Empty using (⊥)

-- Operator precedences.
infix 10 _^⊥ e?_ e!_
infixl 9 _⊗_ _&_
infixl 8 _⊕_ _⅋_
infixl 7 _⊸_
infixl 6 _≡_

-- Primitive linear propositions.
data LinearProp {a} (A : Set a) : Set a where
  atom : A → LinearProp A
  atom^⊥ : A → LinearProp A
  _⊗_ : LinearProp A → LinearProp A → LinearProp A
  _⊕_ : LinearProp A → LinearProp A → LinearProp A
  _&_ : LinearProp A → LinearProp A → LinearProp A
  _⅋_ : LinearProp A → LinearProp A → LinearProp A
  u0 : LinearProp A
  u1 : LinearProp A
  u⊥ : LinearProp A
  u⊤ : LinearProp A
  e!_ : LinearProp A → LinearProp A
  e?_ : LinearProp A → LinearProp A

-- The equivalent of the propositional negation, called "dual".
_^⊥ : ∀ {a} {A : Set a} → LinearProp A → LinearProp A
(atom p) ^⊥ = atom^⊥ p
(atom^⊥ p) ^⊥ = atom p
(p ⊗ q) ^⊥ = (p ^⊥) ⅋ (q ^⊥)
(p ⊕ q) ^⊥ = (p ^⊥) & (q ^⊥)
(p ⅋ q) ^⊥ = (p ^⊥) ⊗ (q ^⊥)
(p & q) ^⊥ = (p ^⊥) ⊕ (q ^⊥)
u1 ^⊥ = u⊥
u0 ^⊥ = u⊤
u⊥ ^⊥ = u1
u⊤ ^⊥ = u0
(e! p) ^⊥ = e? (p ^⊥)
(e? p) ^⊥ = e! (p ^⊥)

-- The linear implication, also called "lollipop operator".
_⊸_ : ∀ {a} {A : Set a} → LinearProp A → LinearProp A → LinearProp A
p ⊸ q = p ^⊥ ⅋ q

-- The equivalent of the propositional equivalence (lmao).
_≡_ : ∀ {a} {A : Set a} → LinearProp A → LinearProp A → LinearProp A
p ≡ q = (p ⊸ q) & (q ⊸ p)

-- Swaps two elements with two given positions. Just a helper of `swap`.
swap-vec : ∀ {a} {A : Set a}
          {n : ℕ} →
          Fin n →
          Fin n →
          Vec A n →
          Vec A n
swap-vec = do-swap where
  insert : ∀ {a} {A : Set a}
              {n : ℕ} →
              A →
              Vec A (suc n) →
              Vec A (suc (suc n))
  insert y (x ∷ xs) = x ∷ y ∷ xs
  swap-first : ∀ {a} {A : Set a}
              {n : ℕ} →
              Fin n →
              Vec A n →
              Vec A n
  swap-first zero xs = xs
  swap-first (suc zero) (x ∷ y ∷ xs) = y ∷ x ∷ xs
  swap-first (suc m) (x ∷ y ∷ xs) = insert y (swap-first m (x ∷ xs))
  do-swap : ∀ {a} {A : Set a}
            {n : ℕ} →
            Fin n →
            Fin n →
            Vec A n →
            Vec A n
  do-swap zero zero xs = xs
  do-swap zero (suc m) xs = swap-first (suc m) xs
  do-swap (suc m) zero xs = swap-first (suc m) xs
  do-swap (suc k) (suc m) (x ∷ xs) = x ∷ do-swap k m xs

-- List of inference rules.
-- The S parameter is an axiom scheme.
-- To prove somthing, it must be the only proposition in the sequent.
data _⊢_ {a}
         {A : Set a}
         (S : LinearProp A → Set a) :
         {n : ℕ} →
         Vec (LinearProp A) n
         → Set a
         where

  empty : S ⊢ []

  axiom : {p : LinearProp A} → S p → S ⊢ (p ∷ [])

  swap : {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         (i j : Fin n) →
         S ⊢ ps →
         S ⊢ (swap-vec i j ps)

  ^⊥-i : (p : LinearProp A) → S ⊢ (p ∷ p ^⊥ ∷ [])

  ^⊥-e : {p : LinearProp A}
        {m n : ℕ}
        {ps : Vec (LinearProp A) m} →
        {qs : Vec (LinearProp A) n} →
        S ⊢ (p ∷ ps) →
        S ⊢ (p ^⊥ ∷ qs) →
        S ⊢ (ps ++ qs)

  ⊗-i : {p q : LinearProp A}
        {m n : ℕ}
        {ps : Vec (LinearProp A) m} →
        {qs : Vec (LinearProp A) n} →
        S ⊢ (p ∷ ps) →
        S ⊢ (q ∷ qs) →
        S ⊢ (p ⊗ q ∷ ps ++ qs)

  ⅋-i : {p q : LinearProp A}
        {n : ℕ}
        {ps : Vec (LinearProp A) n} →
        S ⊢ (p ∷ q ∷ ps) →
        S ⊢ (p ⅋ q ∷ ps)

  u1-i : S ⊢ (u1 ∷ [])

  u⊥-i : {n : ℕ} {ps : Vec (LinearProp A) n} → S ⊢ ps →  S ⊢ (u⊥ ∷ ps)

  &-i : {p q : LinearProp A}
        {n : ℕ}
        {ps : Vec (LinearProp A) n} →
        S ⊢ (p ∷ ps) →
        S ⊢ (q ∷ ps) →
        S ⊢ (p & q ∷ ps)

  ⊕-i₁ : {p q : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ (p ∷ ps) →
         S ⊢ (p ⊕ q ∷ ps)

  ⊕-i₂ : {p q : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ (p ∷ ps) →
         S ⊢ (q ⊕ p ∷ ps)

  u⊤-i : {n : ℕ}
        {ps : Vec (LinearProp A) n} →
        S ⊢ (u⊤ ∷ ps)

  e?-i₁ : {p : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ ps →
         S ⊢ (e? p ∷ ps)

  e?-i₂ : {p : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ (p ∷ ps) →
         S ⊢ (e? p ∷ ps)

  e?-e : {p : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ (e? p ∷ e? p ∷ ps) →
         S ⊢ (e? p ∷ ps)

  e!-i : {p : LinearProp A}
         {n : ℕ}
         {ps : Vec (LinearProp A) n} →
         S ⊢ (p ∷ map e?_ ps) →
         S ⊢ (e! p ∷ map e?_ ps)

-- Empty axiom scheme.
data NoAxioms {a} {A : Set a} : LinearProp A → Set a where

-- Just a helper to hint something has been proven.
Proof : ∀ {a} {A : Set a} → (LinearProp A → Set a) → LinearProp A → Set a
Proof S p = S ⊢ (p ∷ [])


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

open import lib.Basics

module lib.types.Bool where

{-
data Bool : Type₀ where
  true : Bool
  false : Bool

{-# BUILTIN BOOL Bool #-}
{-# BUILTIN FALSE false #-}
{-# BUILTIN TRUE true #-}
-}

Bool = ⊤ ⊔ ⊤

pattern true = inl unit
pattern false = inr unit

⊙Bool : Ptd₀
⊙Bool = ⊙[ Bool , true ]

Bool-elim : ∀ {i} {P : Bool → Type i} → P true → P false → Π Bool P
Bool-elim true* false* true = true*
Bool-elim true* false* false = false*

Bool-rec : ∀ {i} {A : Type i} → A → A → (Bool → A)
Bool-rec {A = A} = Bool-elim {P = λ _ → A}

private
  Bool-true≠false-type : Bool → Type₀
  Bool-true≠false-type true  = Unit
  Bool-true≠false-type false = Empty

abstract
  Bool-true≠false : true ≠ false
  Bool-true≠false p = transport Bool-true≠false-type p unit

  Bool-false≠true : false ≠ true
  Bool-false≠true p = transport Bool-true≠false-type (! p) unit

  Bool-has-dec-eq : has-dec-eq Bool
  Bool-has-dec-eq true true = inl idp
  Bool-has-dec-eq true false = inr Bool-true≠false
  Bool-has-dec-eq false true = inr Bool-false≠true
  Bool-has-dec-eq false false = inl idp

  Bool-is-set : is-set Bool
  Bool-is-set = dec-eq-is-set Bool-has-dec-eq

instance
  Bool-level : {n : ℕ₋₂} → has-level (S (S n)) Bool
  Bool-level = set-has-level-SS Bool-is-set


module Data.Maybe.Instance where

open import Category.FAM
open import Data.Maybe
open import Function using (_∘_; id)
open import Relation.Binary.PropositionalEquality

instance
    MaybeFunctor : ∀ {ℓ} → Functor {ℓ} Maybe
    MaybeFunctor {ℓ} = record
        { _<$>_ = map
        ; isFunctor = record
            { identity = identity
            ; homo = homo
            }
        }
        where
            identity : ∀ {A : Set ℓ} (a : Maybe A) → map id a ≡ a
            identity (just x) = refl
            identity nothing = refl

            homo : ∀ {A B C : Set ℓ} (f : B → C) (g : A → B)
                (a : Maybe A) → map (f ∘ g) a ≡ map f (map g a)
            homo _ _ (just x) = refl
            homo _ _ nothing = refl

    MaybeApplicative : ∀ {ℓ} → Applicative {ℓ} Maybe
    MaybeApplicative {ℓ} = record
        { pure = just
        ; _⊛_ = ap
        ; isApplicative = record
            { identity = identity
            ; compose = compose
            ; homo = λ _ _ → refl
            ; interchange = interchange
            }
        }
        where
            open ≡-Reasoning
            open import Function

            ap : {A B : Set ℓ} → Maybe (A → B) → Maybe A → Maybe B
            ap (just f) x = map f x
            ap nothing  x = nothing

            identity : {A : Set ℓ} (x : Maybe A) → map id x ≡ x
            identity (just x) = refl
            identity nothing = refl

            compose : {A B C : Set ℓ} (fs : Maybe (B → C)) (gs : Maybe (A → B))
                → (xs : Maybe A)
                → ap (ap (map _∘′_ fs) gs) xs ≡ ap fs (ap gs xs)
            compose {A} {B} {C} (just fs) (just gs) (just xs) = refl
            compose {A} {B} {C} (just fs) (just gs) nothing   = refl
            compose {A} {B} {C} (just fs) nothing   (just xs) = refl
            compose {A} {B} {C} (just fs) nothing   nothing   = refl
            compose {A} {B} {C} nothing   (just gs) (just xs) = refl
            compose {A} {B} {C} nothing   (just gs) nothing   = refl
            compose {A} {B} {C} nothing   nothing   (just xs) = refl
            compose {A} {B} {C} nothing   nothing   nothing   = refl

            interchange : {A B : Set ℓ} (fs : Maybe (A → B)) (x : A) → ap fs (just x) ≡ ap (just (λ f → f x)) fs
            interchange {A} {B} (just f) x = refl
            interchange {A} {B} nothing x = refl


module Spire.Type where

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

data ⊥ : Set where
record ⊤ : Set where constructor tt
data Bool : Set where true false : Bool

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ
{-# BUILTIN NATURAL ℕ    #-}

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁
open Σ public

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

const : {A : Set₁} {B : Set} → A → B → A
const a _ = a

uncurry : {A : Set} {B : A → Set} {C : Σ A B → Set} →
  ((a : A) → (b : B a) → C (a , b)) →
  ((p : Σ A B) → C p)
uncurry f (a , b) = f a b

_∘_ : {A B C : Set₁} → (B → C) → (A → B) → A → C
_∘_ g f x = g (f x)

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

elim⊥ : {A : Set} → ⊥ → A
elim⊥ ()

elimBool : (P : Bool → Set)
  (pt : P true)
  (pf : P false)
  (b : Bool) → P b
elimBool P pt pf true = pt
elimBool P pt pf false = pf

if_then_else_ : {C : Set} → Bool → C → C → C
if b then c₁ else c₂ = elimBool _ c₁ c₂ b

elimℕ : (P : ℕ → Set)
  (pz : P zero)
  (ps : (n : ℕ) → P n → P (suc n))
  (n : ℕ) → P n
elimℕ P pz ps zero = pz
elimℕ P pz ps (suc n) = ps n (elimℕ P pz ps n)

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

record Universe : Set₁ where
  field
    Codes : Set
    Meaning : Codes → Set

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

data DescForm (U : Universe) : Set where
  `⊤ `X : DescForm U
  `Π `Σ : (A : Universe.Codes U)
    (D : Universe.Meaning U A → DescForm U)
    → DescForm U

⟦_/_⟧ᵈ : (U : Universe) → DescForm U → Set → Set
⟦ U / `⊤ ⟧ᵈ X = ⊤
⟦ U / `X ⟧ᵈ X = X
⟦ U / `Π A D ⟧ᵈ X =
  (a : Universe.Meaning U A) → ⟦ U / D a ⟧ᵈ X
⟦ U / `Σ A D ⟧ᵈ X =
  Σ (Universe.Meaning U A) (λ a → ⟦ U / D a ⟧ᵈ X)

data μ {U : Universe} (D : DescForm U) : Set where
  con : ⟦ U / D ⟧ᵈ (μ D) → μ D

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

data TypeForm (U : Universe) : Set
⟦_/_⟧ : (U : Universe) → TypeForm U → Set

data TypeForm U where
  `⊥ `⊤ `Bool `ℕ `Desc `Type : TypeForm U
  `Π `Σ : (A : TypeForm U)
    (B : ⟦ U / A ⟧ → TypeForm U)
    → TypeForm U
  `⟦_⟧ : Universe.Codes U → TypeForm U
  `⟦_⟧ᵈ : DescForm U → TypeForm U → TypeForm U
  `μ : DescForm U → TypeForm U

⟦ U / `⊥ ⟧ = ⊥
⟦ U / `⊤ ⟧ = ⊤
⟦ U / `Bool ⟧ = Bool
⟦ U / `ℕ ⟧ = ℕ
⟦ U / `Π A B ⟧ = (a : ⟦ U / A ⟧) → ⟦ U / B a ⟧
⟦ U / `Σ A B ⟧ = Σ ⟦ U / A ⟧ (λ a → ⟦ U / B a ⟧)
⟦ U / `Type ⟧ = Universe.Codes U
⟦ U / `⟦ A ⟧ ⟧ = Universe.Meaning U A
⟦ U / `Desc ⟧ = DescForm U
⟦ U / `⟦ D ⟧ᵈ X ⟧ = ⟦ U / D ⟧ᵈ ⟦ U / X ⟧
⟦ U / `μ D ⟧ = μ D

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

_`→_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `→ B = `Π A (λ _ → B)

Level : (ℓ : ℕ) → Universe
Level zero = record { Codes = ⊥ ; Meaning = λ() }
Level (suc ℓ) = record { Codes = TypeForm (Level ℓ)
                       ; Meaning = ⟦_/_⟧ (Level ℓ) }

Type : ℕ → Set
Type ℓ = TypeForm (Level ℓ)

Desc : ℕ → Set
Desc ℓ = DescForm (Level ℓ)

infix 0 ⟦_∣_⟧
⟦_∣_⟧ : (ℓ : ℕ) → Type ℓ → Set
⟦ ℓ ∣ A ⟧ = ⟦ Level ℓ / A ⟧

⟦_∣_⟧ᵈ : (ℓ : ℕ) → Desc ℓ → Set → Set
⟦ ℓ ∣ D ⟧ᵈ X = ⟦ Level ℓ / D ⟧ᵈ X

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

elimDesc : (P : (ℓ : ℕ) → Desc ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `X)
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Π A D))
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Σ A D))
  → (ℓ : ℕ) (D : Desc ℓ) → P ℓ D
elimDesc P p⊤ pX pΠ pΣ ℓ `⊤ = p⊤ ℓ
elimDesc P p⊤ pX pΠ pΣ ℓ `X = pX ℓ
elimDesc P p⊤ pX pΠ pΣ zero (`Π () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Π A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΠ ℓ A D (λ a → f (D a))
elimDesc P p⊤ pX pΠ pΣ zero (`Σ () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Σ A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΣ ℓ A D (λ a → f (D a))

des : ∀{ℓ} {D : Desc ℓ} → μ D → ⟦ ℓ ∣ D ⟧ᵈ (μ D)
des (con x) = x

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

elimType : (P : (ℓ : ℕ) → Type ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊥)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `Bool)
  → ((ℓ : ℕ) → P ℓ `ℕ)
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Π A B))
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Σ A B))
  → ((ℓ : ℕ) → P ℓ `Desc)
  → ((ℓ : ℕ) (D : Desc ℓ) (X : Type ℓ) (rec : P ℓ X) → P ℓ (`⟦ D ⟧ᵈ X))
  → ((ℓ : ℕ) (D : Desc ℓ) → P ℓ (`μ D))
  → ((ℓ : ℕ) → P ℓ `Type)
  → ((ℓ : ℕ) (A : Type ℓ) (rec : P ℓ A) → P (suc ℓ) `⟦ A ⟧)
  → (ℓ : ℕ) (A : Type ℓ) → P ℓ A

elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊥ = p⊥ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊤ = p⊤ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Bool = pBool ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `ℕ = pℕ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Π A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΠ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Σ A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΣ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Type = pType ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Desc = pDesc ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`⟦ D ⟧ᵈ X) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦D⟧ᵈ ℓ D X (f X)
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`μ D) = pμ ℓ D
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  zero `⟦ () ⟧
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  (suc ℓ) `⟦ A ⟧ =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦A⟧ ℓ A (f A)

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


module Nats where

open import Agda.Builtin.Nat public
  renaming (Nat to ℕ; _-_ to _∸_)


------------------------------------------------------------------------
-- Coinductive definition of subtyping
------------------------------------------------------------------------

module RecursiveTypes.Subtyping.Semantic.Coinductive where

open import Codata.Musical.Notation
open import Data.Nat using (ℕ; zero; suc)
open import Data.Fin using (Fin)
open import Function.Base
open import Data.Empty using (⊥-elim)
open import Relation.Nullary
open import Relation.Nullary.Negation hiding (stable)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import RecursiveTypes.Syntax
open import RecursiveTypes.Substitution
open import RecursiveTypes.Semantics

infixr 10 _⟶_
infix  4  _≤∞_ _≤Coind_
infix  3  _∎
infixr 2  _≤⟨_⟩_

------------------------------------------------------------------------
-- Definition

-- The obvious definition of subtyping for trees.

data _≤∞_ {n} : Tree n → Tree n → Set where
  ⊥   : ∀ {τ} → ⊥ ≤∞ τ
  ⊤   : ∀ {σ} → σ ≤∞ ⊤
  var : ∀ {x} → var x ≤∞ var x
  _⟶_ : ∀ {σ₁ σ₂ τ₁ τ₂}
        (τ₁≤σ₁ : ∞ (♭ τ₁ ≤∞ ♭ σ₁)) (σ₂≤τ₂ : ∞ (♭ σ₂ ≤∞ ♭ τ₂)) →
        σ₁ ⟶ σ₂ ≤∞ τ₁ ⟶ τ₂

-- Subtyping for recursive types is defined in terms of subtyping for
-- trees.

_≤Coind_ : ∀ {n} → Ty n → Ty n → Set
σ ≤Coind τ = ⟦ σ ⟧ ≤∞ ⟦ τ ⟧

------------------------------------------------------------------------
-- A trick used to ensure guardedness of expressions using
-- transitivity

infix 4 _≤∞P_ _≤∞W_

data _≤∞P_ {n} : Tree n → Tree n → Set where
  ⊥      : ∀ {τ} → ⊥ ≤∞P τ
  ⊤      : ∀ {σ} → σ ≤∞P ⊤
  var    : ∀ {x} → var x ≤∞P var x
  _⟶_    : ∀ {σ₁ σ₂ τ₁ τ₂}
           (τ₁≤σ₁ : ∞ (♭ τ₁ ≤∞P ♭ σ₁)) (σ₂≤τ₂ : ∞ (♭ σ₂ ≤∞P ♭ τ₂)) →
           σ₁ ⟶ σ₂ ≤∞P τ₁ ⟶ τ₂
  -- Transitivity.
  _≤⟨_⟩_ : ∀ τ₁ {τ₂ τ₃}
           (τ₁≤τ₂ : τ₁ ≤∞P τ₂) (τ₂≤τ₃ : τ₂ ≤∞P τ₃) → τ₁ ≤∞P τ₃

data _≤∞W_ {n} : Tree n → Tree n → Set where
  ⊥   : ∀ {τ} → ⊥ ≤∞W τ
  ⊤   : ∀ {σ} → σ ≤∞W ⊤
  var : ∀ {x} → var x ≤∞W var x
  _⟶_ : ∀ {σ₁ σ₂ τ₁ τ₂}
        (τ₁≤σ₁ : ♭ τ₁ ≤∞P ♭ σ₁) (σ₂≤τ₂ : ♭ σ₂ ≤∞P ♭ τ₂) →
        σ₁ ⟶ σ₂ ≤∞W τ₁ ⟶ τ₂

transW : ∀ {n} {τ₁ τ₂ τ₃ : Tree n} →
         τ₁ ≤∞W τ₂ → τ₂ ≤∞W τ₃ → τ₁ ≤∞W τ₃
transW ⊥               _               = ⊥
transW _               ⊤               = ⊤
transW var             var             = var
transW (τ₁≤σ₁ ⟶ σ₂≤τ₂) (χ₁≤τ₁ ⟶ τ₂≤χ₂) =
  (_ ≤⟨ χ₁≤τ₁ ⟩ τ₁≤σ₁) ⟶ (_ ≤⟨ σ₂≤τ₂ ⟩ τ₂≤χ₂)

whnf : ∀ {n} {σ τ : Tree n} → σ ≤∞P τ → σ ≤∞W τ
whnf ⊥                    = ⊥
whnf ⊤                    = ⊤
whnf var                  = var
whnf (τ₁≤σ₁ ⟶ σ₂≤τ₂)      = ♭ τ₁≤σ₁ ⟶ ♭ σ₂≤τ₂
whnf (σ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃) = transW (whnf τ₁≤τ₂) (whnf τ₂≤τ₃)

mutual

  ⟦_⟧W : ∀ {n} {σ τ : Tree n} → σ ≤∞W τ → σ ≤∞ τ
  ⟦ ⊥             ⟧W = ⊥
  ⟦ ⊤             ⟧W = ⊤
  ⟦ var           ⟧W = var
  ⟦ τ₁≤σ₁ ⟶ σ₂≤τ₂ ⟧W = ♯ ⟦ τ₁≤σ₁ ⟧P ⟶ ♯ ⟦ σ₂≤τ₂ ⟧P

  ⟦_⟧P : ∀ {n} {σ τ : Tree n} → σ ≤∞P τ → σ ≤∞ τ
  ⟦ σ≤τ ⟧P = ⟦ whnf σ≤τ ⟧W

⌜_⌝ : ∀ {n} {σ τ : Tree n} → σ ≤∞ τ → σ ≤∞P τ
⌜ ⊥             ⌝ = ⊥
⌜ ⊤             ⌝ = ⊤
⌜ var           ⌝ = var
⌜ τ₁≤σ₁ ⟶ σ₂≤τ₂ ⌝ = ♯ ⌜ ♭ τ₁≤σ₁ ⌝ ⟶ ♯ ⌜ ♭ σ₂≤τ₂ ⌝

------------------------------------------------------------------------
-- Some lemmas

refl∞ : ∀ {n} (τ : Tree n) → τ ≤∞ τ
refl∞ ⊥       = ⊥
refl∞ ⊤       = ⊤
refl∞ (var x) = var
refl∞ (σ ⟶ τ) = ♯ refl∞ (♭ σ) ⟶ ♯ refl∞ (♭ τ)

_∎ : ∀ {n} (τ : Tree n) → τ ≤∞P τ
τ ∎ = ⌜ refl∞ τ ⌝

trans : ∀ {n} {τ₁ τ₂ τ₃ : Tree n} →
        τ₁ ≤∞ τ₂ → τ₂ ≤∞ τ₃ → τ₁ ≤∞ τ₃
trans {τ₁ = τ₁} {τ₂} {τ₃} τ₁≤τ₂ τ₂≤τ₃ =
  ⟦ τ₁ ≤⟨ ⌜ τ₁≤τ₂ ⌝ ⟩
    τ₂ ≤⟨ ⌜ τ₂≤τ₃ ⌝ ⟩
    τ₃ ∎ ⟧P

unfold : ∀ {n} {τ₁ τ₂ : Ty (suc n)} →
         μ τ₁ ⟶ τ₂ ≤Coind unfold[μ τ₁ ⟶ τ₂ ]
unfold = ♯ refl∞ _ ⟶ ♯ refl∞ _

fold : ∀ {n} {τ₁ τ₂ : Ty (suc n)} →
       unfold[μ τ₁ ⟶ τ₂ ] ≤Coind μ τ₁ ⟶ τ₂
fold = ♯ refl∞ _ ⟶ ♯ refl∞ _

var:≤∞⟶≡ : ∀ {n} {x y : Fin n} →
           var x ≤∞ var y → Ty.var x ≡ Ty.var y
var:≤∞⟶≡ var = refl

left-proj : ∀ {n} {σ₁ σ₂ τ₁ τ₂ : ∞ (Tree n)} →
            σ₁ ⟶ σ₂ ≤∞ τ₁ ⟶ τ₂ → ♭ τ₁ ≤∞ ♭ σ₁
left-proj (τ₁≤σ₁ ⟶ σ₂≤τ₂) = ♭ τ₁≤σ₁

right-proj : ∀ {n} {σ₁ σ₂ τ₁ τ₂ : ∞ (Tree n)} →
             σ₁ ⟶ σ₂ ≤∞ τ₁ ⟶ τ₂ → ♭ σ₂ ≤∞ ♭ τ₂
right-proj (τ₁≤σ₁ ⟶ σ₂≤τ₂) = ♭ σ₂≤τ₂

------------------------------------------------------------------------
-- _≤∞_ is stable under double-negation

stable : ∀ {n} (σ τ : Tree n) → Stable (σ ≤∞ τ)
stable ⊥         τ         ¬≰ = ⊥
stable σ         ⊤         ¬≰ = ⊤
stable (var x)   (var  y)  ¬≰ with var x ≡? var y
stable (var x)   (var .x)  ¬≰ | yes refl = var
stable (var x)   (var  y)  ¬≰ | no  x≠y  = ⊥-elim (¬≰ (x≠y ∘ var:≤∞⟶≡))
stable (σ₁ ⟶ σ₂) (τ₁ ⟶ τ₂) ¬≰ =
  ♯ stable (♭ τ₁) (♭ σ₁) (λ ≰ → ¬≰ (≰ ∘  left-proj)) ⟶
  ♯ stable (♭ σ₂) (♭ τ₂) (λ ≰ → ¬≰ (≰ ∘ right-proj))
stable ⊤         ⊥         ¬≰ = ⊥-elim (¬≰ (λ ()))
stable ⊤         (var x)   ¬≰ = ⊥-elim (¬≰ (λ ()))
stable ⊤         (τ₁ ⟶ τ₂) ¬≰ = ⊥-elim (¬≰ (λ ()))
stable (var x)   ⊥         ¬≰ = ⊥-elim (¬≰ (λ ()))
stable (var x)   (τ₁ ⟶ τ₂) ¬≰ = ⊥-elim (¬≰ (λ ()))
stable (σ₁ ⟶ σ₂) ⊥         ¬≰ = ⊥-elim (¬≰ (λ ()))
stable (σ₁ ⟶ σ₂) (var x)   ¬≰ = ⊥-elim (¬≰ (λ ()))


_ : @ω Set → Set₁
_ = λ (@0 _) → Set


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

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.Prelims
open import Cubical.ZCohomology.KcompPrelims

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

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.Data.Unit
open import Cubical.Algebra.Group

open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim2 to pElim2 ; ∣_∣ to ∣_∣₁)
open import Cubical.HITs.Nullification
open import Cubical.HITs.Truncation renaming (elim to trElim ; elim2 to trElim2 ; map to trMap ; rec to trRec)

--------- H⁰(T²) ------------
H⁰-T²≅ℤ : GroupEquiv (coHomGr 0 (S₊ 1 × S₊ 1)) intGroup
H⁰-T²≅ℤ =
  H⁰-connected (north , north)
    λ (a , b) → pRec propTruncIsProp
                     (λ id1 → pRec propTruncIsProp
                                   (λ id2 → ∣ ΣPathP (id1 , id2) ∣₁)
                                   (Sn-connected 0 b) )
                     (Sn-connected 0 a)

------------------ H¹(T²) -------------------------------

H¹-T²≅ℤ×ℤ : GroupEquiv (coHomGr 1 ((S₊ 1) × (S₊ 1))) (dirProd intGroup intGroup)
H¹-T²≅ℤ×ℤ =
    groupequiv (isoToEquiv (setTruncIso (curryIso ⋄ codomainIso S1→K₁≡S1×Int ⋄ toProdIso)
                          ⋄ setTruncOfProdIso))
               (sElim2 (λ _ _ → isOfHLevelPath 2 (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet)) _ _)
                    λ f g → ΣPathP ((cong ∣_∣₂
                                     (funExt (λ x → helper (f (x , S¹→S1 base) +ₖ g (x , S¹→S1 base))
                                                   ∙ sym (cong₂ (λ x y → x +ₖ y)
                                                                (helper (f (x , S¹→S1 base)))
                                                                (helper (g (x , S¹→S1 base))))))) ,
                                   (cong ∣_∣₂
                                      (funExt
                                        (suspToPropRec
                                           north
                                           (λ _ → isSetInt _ _)
                                           (cong winding
                                                 (basechange-lemma2
                                                   (λ x → f (north , S¹→S1 x))
                                                   (λ x → g (north , S¹→S1 x))
                                                   λ x → S¹map (trMap S1→S¹ x))
                                          ∙∙ winding-hom
                                              (basechange2⁻
                                                  (S¹map (trMap S1→S¹ (f (north , S¹→S1 base))))
                                                  (λ i → S¹map (trMap S1→S¹ (f (north , S¹→S1 (loop i))))))
                                              (basechange2⁻
                                                  (S¹map (trMap S1→S¹ (g (north , S¹→S1 base))))
                                                  (λ i → S¹map (trMap S1→S¹ (g (north , S¹→S1 (loop i))))))
                                          ∙∙ sym (addLemma
                                                  (winding
                                                    (basechange2⁻
                                                      (S¹map (trMap S1→S¹ (f (north , S¹→S1 base))))
                                                      (λ i → S¹map (trMap S1→S¹ (f (north , S¹→S1 (loop i)))))))
                                                  (winding
                                                    (basechange2⁻
                                                      (S¹map (trMap S1→S¹ (g (north , S¹→S1 base))))
                                                      (λ i → S¹map (trMap S1→S¹ (g (north , S¹→S1 (loop i))))))))))))))
  □ dirProdEquiv (invGroupEquiv (Hⁿ-Sⁿ≅ℤ 0)) (H⁰-Sⁿ≅ℤ 0)

  where
  helper : (x : hLevelTrunc 3 (S₊ 1)) → ∣ S¹→S1 (S¹map (trMap S1→S¹ x)) ∣ ≡ x
  helper = trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _)
                  λ a → cong ∣_∣ (S1→S¹-retr a)

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

----------------------- H²(T²) ------------------------------
open import Cubical.Foundations.Equiv
H²-T²≅ℤ : GroupEquiv (coHomGr 2 (S₊ 1 × S₊ 1)) intGroup
H²-T²≅ℤ = invGroupEquiv ℤ≅H²-T²
  where
  ℤ≅H²-T² : GroupEquiv intGroup (coHomGr 2 (S₊ 1 × S₊ 1))
  GroupEquiv.eq ℤ≅H²-T² =
    compEquiv (isoToEquiv helper')
      (compEquiv (invEquiv (≃-× (GroupEquiv.eq H²-S¹≅0)
                                (invEquiv (GroupEquiv.eq (Hⁿ-Sⁿ≅ℤ 0)))))
                 (isoToEquiv
                    (invIso setTruncOfProdIso
                   ⋄ invIso (setTruncIso (curryIso
                                        ⋄ codomainIso S1→K2≡K2×K1
                                        ⋄ toProdIso)))))
    where
    helper' : Iso Int (Unit × Int)
    Iso.inv helper' = snd
    Iso.fun helper' x = tt , x
    Iso.leftInv helper' _ = refl
    Iso.rightInv helper' _ = refl

  GroupEquiv.isHom ℤ≅H²-T² a b =
      (λ i → f (GroupEquiv.isHom (invGroupEquiv (dirProdEquiv H²-S¹≅0 (invGroupEquiv (Hⁿ-Sⁿ≅ℤ 0)))) (_ , a) (_ , b) i))
    ∙ ((λ i → f (guyId i , (g a +ₕ g b)))
    ∙∙ helper (g a) (g b)
    ∙∙ (λ i → f (guyId2 (~ i) , g a) +ₕ f (guyId2 (~ i) , g b)))
    where
    f = Iso.fun (((invIso setTruncOfProdIso ⋄ invIso (setTruncIso (curryIso ⋄ codomainIso S1→K2≡K2×K1 ⋄ toProdIso)))))
    g = invEq (GroupEquiv.eq (invGroupEquiv (Hⁿ-Sⁿ≅ℤ 0)))

    isPropH²-S¹ : isProp (coHom 2 (S₊ 1))
    isPropH²-S¹ = transport (λ i → isProp (ua (GroupEquiv.eq H²-S¹≅0) (~ i))) isPropUnit

    guyId : ∣ _ ∣₂ ≡ 0ₕ
    guyId = isPropH²-S¹ _ _

    guyId2 : ∣ _ ∣₂ ≡ 0ₕ
    guyId2 = isPropH²-S¹ _ _

    helper : (x y : ∥ ((S₊ 1) → (hLevelTrunc 3 (S₊ 1) )) ∥₂) →
              f (0ₕ , x +ₕ y) ≡ f (0ₕ , x) +ₕ f (0ₕ , y)
    helper =
      sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
             λ f g i → ∣ (λ x → helper2 (f (fst x)) (g (fst x)) (snd x) i) ∣₂
      where
      helper2 : (x y : coHomK 1) (s : S₊ 1)
             → Iso.inv S1→K2≡K2×K1 (0ₖ , x +ₖ y) s ≡ (Iso.inv S1→K2≡K2×K1 (0ₖ , x)) s +ₖ (Iso.inv S1→K2≡K2×K1 (0ₖ , y)) s
      helper2 =
        trElim2 (λ _ _ → isOfHLevelΠ 3 λ _ → isOfHLevelTrunc 4 _ _)
               λ a b →
                λ {north → cong₂ (_+ₖ_) (sym (lUnitₖ 0ₖ)) (sym (lUnitₖ 0ₖ))
                ; south → cong₂ (_+ₖ_) (sym (lUnitₖ 0ₖ)) (sym (lUnitₖ 0ₖ))
                ; (merid south i) j →
                  hcomp (λ k → λ {(i = i0) → cong₂ (_+ₖ_) (sym (lUnitₖ 0ₖ)) (sym (lUnitₖ 0ₖ)) (j ∧ k)
                                 ; (i = i1) → cong₂ (_+ₖ_) (sym (lUnitₖ 0ₖ)) (sym (lUnitₖ 0ₖ)) (j ∧ k)
                                 ; (j = i0) → 0ₖ +ₖ Kn→ΩKn+1 1 (∣ a ∣ +ₖ ∣ b ∣) i
                                 ; (j = i1) →  cong₂ (_+ₖ_) (sym (lUnitₖ (Kn→ΩKn+1 1 ∣ a ∣ i))) (sym (lUnitₖ (Kn→ΩKn+1 1 ∣ b ∣ i))) k})
                        (helper3 ∣ a ∣ ∣ b ∣ j i)
                ; (merid north i) → cong₂ (_+ₖ_) (sym (lUnitₖ 0ₖ)) (sym (lUnitₖ 0ₖ)) }
        where
        helper3 : (a b : coHomK 1) → cong (0ₖ +ₖ_) (Kn→ΩKn+1 1 (a +ₖ b)) ≡ cong₂ _+ₖ_ (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b)
        helper3 a b = (cong (cong (0ₖ +ₖ_)) helper4
                    ∙ congFunct (0ₖ +ₖ_) (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b))
                   ∙∙ cong (_∙ cong (0ₖ +ₖ_) (Kn→ΩKn+1 1 b)) (helper5 (Kn→ΩKn+1 1 a))
                   ∙∙ sym (cong₂Funct (_+ₖ_) (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b))
          where
          helper4 : Kn→ΩKn+1 1 (a +ₖ b) ≡ Kn→ΩKn+1 1 a ∙ Kn→ΩKn+1 1 b -- Termination issues unless this is put as a separate lemma...
          helper4 = +ₖ→∙ 1 a b

          helper6 : ∀{ℓ} {A : Type ℓ} {a b : A} (p : a ≡ b) → p ≡ (refl ∙ refl) ∙ p ∙ refl ∙ refl
          helper6 p = (λ i → rUnit p i) ∙∙ (λ i → lUnit (p ∙ rUnit refl i) i) ∙∙ λ i → rUnit refl i ∙ p ∙ refl ∙ refl
          helper5 : (a : Path (coHomK 2) 0ₖ 0ₖ) → cong (0ₖ +ₖ_) a ≡ cong (_+ₖ 0ₖ) a
          helper5 a = (((helper6 (cong (0ₖ +ₖ_) a))
                   ∙∙ (λ i → ((λ j → lUnitₖ 0ₖ (i ∧ j)) ∙ refl) ∙ cong (λ x → lUnitₖ x i) a ∙ refl ∙ λ j → lUnitₖ 0ₖ (i ∧ (~ j)))
                   ∙∙ λ i → (lUnitₖ 0ₖ ∙ λ j → rUnitₖ 0ₖ ((~ i) ∨ (~ j))) ∙ cong (λ x → rUnitₖ x (~ i)) a ∙ (λ j → rUnitₖ 0ₖ (~ i ∨ j)) ∙ sym (lUnitₖ 0ₖ))
                   ∙∙ (λ i → (lUnitₖ 0ₖ ∙ sym (rUnitₖ 0ₖ)) ∙ isCommΩK-based 2 (0ₖ +ₖ 0ₖ) (cong (_+ₖ 0ₖ) a) (rUnitₖ 0ₖ ∙ sym (lUnitₖ 0ₖ)) i)
                   ∙∙ λ i → assoc (lUnitₖ 0ₖ ∙ sym (rUnitₖ 0ₖ)) (symDistr ((lUnitₖ 0ₖ)) (sym (rUnitₖ 0ₖ)) (~ i)) (cong (_+ₖ 0ₖ) a) i)
                   ∙∙ cong (_∙ (cong (_+ₖ 0ₖ) a)) (rCancel (lUnitₖ 0ₖ ∙ sym (rUnitₖ 0ₖ)))
                   ∙∙ sym (lUnit (cong (_+ₖ 0ₖ) a))
private
  to₂ : coHom 2 (S₊ 1 × S₊ 1) → Int
  to₂ = fst (GroupEquiv.eq H²-T²≅ℤ)

  from₂ : Int → coHom 2 (S₊ 1 × S₊ 1)
  from₂ = invEq (GroupEquiv.eq H²-T²≅ℤ)

  to₁ : coHom 1 (S₊ 1 × S₊ 1) → Int × Int
  to₁ = fst (GroupEquiv.eq H¹-T²≅ℤ×ℤ)

  from₁ : Int × Int → coHom 1 (S₊ 1 × S₊ 1)
  from₁ = invEq (GroupEquiv.eq H¹-T²≅ℤ×ℤ)

  to₀ : coHom 0 (S₊ 1 × S₊ 1) → Int
  to₀ = fst (GroupEquiv.eq H⁰-T²≅ℤ)

  from₀ : Int → coHom 0 (S₊ 1 × S₊ 1)
  from₀ = invEq (GroupEquiv.eq H⁰-T²≅ℤ)


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

module Dodo.Binary where

open import Dodo.Binary.Acyclic public
open import Dodo.Binary.Composition public
open import Dodo.Binary.Cycle public
open import Dodo.Binary.Dec public
open import Dodo.Binary.Disjoint public
open import Dodo.Binary.Domain public
open import Dodo.Binary.Empty public
open import Dodo.Binary.Equality public
open import Dodo.Binary.Filter public
open import Dodo.Binary.Flip public
open import Dodo.Binary.Functional public
open import Dodo.Binary.Identity public
open import Dodo.Binary.Immediate public
open import Dodo.Binary.Intersection public
open import Dodo.Binary.Irreflexive public
open import Dodo.Binary.Maximal public
open import Dodo.Binary.Precedes public
open import Dodo.Binary.Product public
open import Dodo.Binary.SplittableOrder public
open import Dodo.Binary.Subtraction public
open import Dodo.Binary.Transitive public
open import Dodo.Binary.Trichotomous public
open import Dodo.Binary.Union public

open ⊆₂-Reasoning public
open ⇔₂-Reasoning public


module AmbiguousConstructor where

module Foo where
  data D : Set where
    c0 : D
    c1 : D

module Bar where
  open Foo public

data B : Set where
  tt : B
  ff : B

open Foo renaming (c0 to c2)
open Bar renaming (c1 to c2)

foo : D -> B
-- c2 is ambiguous: it could refer to c0 or c1.
foo c2 = tt
foo _ = ff


------------------------------------------------------------------------
-- M-types for indexed containers, defined coinductively (in Cubical
-- Agda)
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe --guardedness #-}

import Equality.Path as P

module Container.Indexed.Variant.M.Codata
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Container.Indexed equality-with-J using (_⇾_; _∘⇾_)
open import Container.Indexed.Variant equality-with-J
  hiding (Final′≃Final′)
import Container.Indexed.Variant P.equality-with-J as PC
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J
open import H-level equality-with-J

private
  variable
    a iℓ s  : Level
    A I     : Type a
    i p q x : A
    C       : Container I s p
    n       : ℕ

-- An M-type for a given container.
--
-- This definition is similar to one in "Indexed containers" by
-- Altenkirch, Ghani, Hancock, McBride and Morris.

record M {I : Type iℓ} (C : Container I s p) (i : I) :
         Type (iℓ ⊔ s ⊔ p) where
  coinductive
  constructor in-M
  field
    out-M : ⟦ C ⟧ (M C) i

open M public

-- An η-law.

η : in-M (out-M x) ≡ x
η = _↔_.from ≡↔≡ η′
  where
  η′ : in-M (out-M x) P.≡ x
  η′ {x = x} _ .out-M = x .out-M

-- M C is, in a certain sense, a fixpoint of ⟦ C ⟧.

M-fixpoint : ⟦ C ⟧ (M C) i ≃ M C i
M-fixpoint = Eq.↔→≃ in-M out-M (λ _ → η) refl

-- A coalgebra defined using M and out-M.

M-coalgebra : (C : Container I s p) → Coalgebra C
M-coalgebra C = M C , λ _ → out-M

private

  -- M-coalgebra C is a final coalgebra.
  --
  -- This code is based on code written by Andrea Vezzosi for the
  -- cubical library.

  M-final′′ : PC.Final′ (M-coalgebra C)
  M-final′′ {C = C@(S ◁ P)} Y@(Q , f) = unfold , unique
    where
    g : Q ⇾ M C
    g i q .out-M .proj₁     = f i q .proj₁
    g i q .out-M .proj₂ j p = g j (f i q .proj₂ j p)

    g-ok : (λ _ → out-M) ∘⇾ g P.≡ map C g ∘⇾ f
    g-ok i j q .proj₁            = f j q .proj₁
    g-ok i j q .proj₂ k p .out-M = g-ok i k (f j q .proj₂ k p)

    unfold : Y PC.⇨ M-coalgebra C
    unfold = g , g-ok

    module _ (u : Y PC.⇨ M-coalgebra C) where

      lemma₁ :
        x P.≡ u .proj₁ i q →
        x .out-M .proj₁ P.≡
        (map C (u .proj₁) ∘⇾ f) i q .proj₁
      lemma₁ {i = i} {x = x} {q = q} eq =
        x .out-M .proj₁                     P.≡⟨ P.cong (λ x → x .out-M .proj₁) eq ⟩
        u .proj₁ i q .out-M .proj₁          P.≡⟨ P.cong (λ f → f i q .proj₁) (u .proj₂) ⟩∎
        (map C (u .proj₁) ∘⇾ f) i q .proj₁  ∎

      lemma₂ :
        (eq : x P.≡ u .proj₁ i q) →
        P.[ (λ l → P (lemma₁ eq l) ⇾ M C) ]
          x .out-M .proj₂ ≡
          (map C (u .proj₁) ∘⇾ f) i q .proj₂
      lemma₂ {i = i} {x = x} {q = q} eq =
        x .out-M .proj₂                     P.≡⟨ P.hcong (λ x → x .out-M .proj₂) eq ⟩[ (λ p → P p ⇾ M C) ]
        u .proj₁ i q .out-M .proj₂          P.≡⟨ P.hcong (λ f → f i q .proj₂) (u .proj₂) ⟩∎h
        (map C (u .proj₁) ∘⇾ f) i q .proj₂  ∎

      unique′ : ∀ i q x → x P.≡ u .proj₁ i q → x P.≡ g i q
      unique′ _ _ _ eq j .out-M .proj₁     = lemma₁ eq j
      unique′ i q x eq j .out-M .proj₂ k p =
        unique′ k (f i q .proj₂ k p₁) (x .out-M .proj₂ k p₀) lemma₂′ j
        where
        lem₁ = lemma₁ eq

        p₀ : P (lem₁ P.0̲) k
        p₁ : P (lem₁ P.1̲) k
        p₀ = P.transport (λ l → P (lem₁ (P.min j (P.- l))) k) (P.- j) p
        p₁ = P.transport (λ l → P (lem₁ (P.max j      l )) k)      j  p

        p₀≡p₁ : P.[ (λ l → P (lem₁ l) k) ] p₀ ≡ p₁
        p₀≡p₁ = P.elim¹
          (λ eq →
             ∀ p →
             P.[ (λ l → eq l) ]
               P.transport (λ l → eq (P.min j (P.- l))) (P.- j) p ≡
               P.transport (λ l → eq (P.max j      l ))      j  p)
          (λ p →
             P.transport (λ _ → P (x .out-M .proj₁) k) (P.- j) p  P.≡⟨ P.cong (_$ p) $ P.transport-refl (P.- j) ⟩
             p                                                    P.≡⟨ P.cong (_$ p) $ P.sym $ P.transport-refl j ⟩∎
             P.transport (λ _ → P (x .out-M .proj₁) k) j p        ∎)
          (P.cong (λ s → P s k) lem₁)
          p

        lemma₂′ :
          x .out-M .proj₂ k p₀ P.≡
          (map C (u .proj₁) ∘⇾ f) i q .proj₂ k p₁
        lemma₂′ l = lemma₂ eq l k (p₀≡p₁ l)

      unique : unfold .proj₁ P.≡ u .proj₁
      unique =
        P.⟨ext⟩ λ _ → P.⟨ext⟩ λ _ → P.sym $
        unique′ _ _ _ P.refl

  -- Finality expressed using equality is equivalent to finality
  -- expressed using paths.

  Final′≃Final′ :
    (X : Coalgebra C) →
    Final′ X ≃ PC.Final′ X
  Final′≃Final′ X =
    (∀ Y → ∃ λ (m : Y    ⇨ X) → (m′ : Y    ⇨ X) → proj₁ m ≡ proj₁ m′)    ↔⟨ (∀-cong ext λ _ →
                                                                             Σ-cong (lemma _) λ _ →
                                                                             Π-cong ext (lemma _) λ _ →
                                                                             ≡↔≡) ⟩□
    (∀ Y → ∃ λ (m : Y PC.⇨ X) → (m′ : Y PC.⇨ X) → proj₁ m P.≡ proj₁ m′)  □
    where
    lemma : ∀ Y → (Y ⇨ X) ↔ (Y PC.⇨ X)
    lemma Y = ∃-cong λ _ → ≡↔≡

-- M-coalgebra C is a final coalgebra.
--
-- The lemma M-final′′ is based on code written by Andrea Vezzosi for
-- the cubical library.

M-final′ :
  (C : Container I s p) →
  Final′ (M-coalgebra C)
M-final′ C = _≃_.from (Final′≃Final′ (M-coalgebra C)) M-final′′