{-# OPTIONS --safe #-}
module Cubical.Homotopy.Hopf where

open import Cubical.Homotopy.HSpace

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

open import Cubical.Data.Sigma
open import Cubical.Data.Unit
open import Cubical.Data.Int hiding (_·_)

open import Cubical.HITs.Pushout.Flattening
open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn hiding (joinS¹S¹→S³)
open import Cubical.HITs.Susp
open import Cubical.HITs.S1
open import Cubical.HITs.S2
open import Cubical.HITs.S3
open import Cubical.HITs.PropositionalTruncation
  renaming (rec to pRec ; elim to pElim)
open import Cubical.HITs.Join
open import Cubical.HITs.Interval
  renaming ( zero to I0 ; one to I1 )

open Iso
open HSpace
open AssocHSpace

private
  retEq≡secEq : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B)
                  → (x : _) → secEq e (e .fst x) ≡ cong (e .fst) (retEq e x)
  retEq≡secEq {A = A} =
    EquivJ (λ B e → (x : _) → secEq e (e .fst x) ≡ cong (e .fst) (retEq e x))
           λ _ → refl

module Hopf {ℓ : Level} {A : Pointed ℓ} {e : HSpace A}
            (e-ass : AssocHSpace e) (conA : ((x y : typ A) → ∥ x ≡ y ∥)) where
  isEquiv-μ : (x : typ A) → isEquiv (λ z → (μ e z x))
  isEquiv-μ x = pRec (isPropIsEquiv _)
                     (J (λ x _ → isEquiv (λ z → μ e z x))
                       (subst isEquiv (funExt (λ z → sym (μᵣ e z)))
                                      (idIsEquiv (typ A))))
                     (conA (pt A) x)

  isEquiv-μ' : (x : typ A) → isEquiv (μ e x)
  isEquiv-μ' x =
    pRec (isPropIsEquiv _)
          (J (λ x _ → isEquiv (μ e x))
            (subst isEquiv (funExt (λ x → sym (μₗ e x))) (idIsEquiv (typ A))))
          (conA (pt A) x)

  μ-eq : (x : typ A) → typ A ≃ typ A
  μ-eq x = (λ z → μ e z x) , (isEquiv-μ x)

  μ-eq' : (x : typ A) → typ A ≃ typ A
  μ-eq' x = μ e x , isEquiv-μ' x

  Hopf : Susp (typ A) → Type ℓ
  Hopf north = typ A
  Hopf south = typ A
  Hopf (merid a i₁) = ua (μ-eq a) i₁

  TotalSpaceHopfPush : Type _
  TotalSpaceHopfPush =
    Pushout {A = typ A × typ A} fst λ x → μ e (fst x) (snd x)

  TotalSpaceHopfPush→TotalSpace :
    TotalSpaceHopfPush → Σ[ x ∈ Susp (typ A) ] Hopf x
  TotalSpaceHopfPush→TotalSpace (inl x) = north , x
  TotalSpaceHopfPush→TotalSpace (inr x) = south , x
  TotalSpaceHopfPush→TotalSpace (push (x , y) i₁) =
    merid y i₁ , ua-gluePt (μ-eq y) i₁ x

  joinIso₁ : Iso (TotalSpaceHopfPush) (join (typ A) (typ A))
  joinIso₁ = theIso
    where
    F : TotalSpaceHopfPush → join (typ A) (typ A)
    F (inl x) = inl x
    F (inr x) = inr x
    F (push (a , x) i) = push a (μ e a x) i

    G : join (typ A) (typ A) → TotalSpaceHopfPush
    G (inl x) = inl x
    G (inr x) = inr x
    G (push a b i) =
      (push (a , invEq (μ-eq' a) b) ∙ cong inr (secEq (μ-eq' a) b)) i

    s : section F G
    s (inl x) = refl
    s (inr x) = refl
    s (push a b i) j =
      hcomp (λ k → λ { (i = i0) → inl a
                      ; (i = i1) → inr (secEq (μ-eq' a) b (j ∨ k))
                      ; (j = i0) → F (compPath-filler
                                       (push (a , invEq (μ-eq' a) b))
                                       (cong inr (secEq (μ-eq' a) b)) k i)
                      ; (j = i1) → push a b i})
        (hcomp (λ k → λ { (i = i0) → inl a
                      ; (i = i1) → inr (secEq (μ-eq' a) b (~ k ∨ j))
                      ; (j = i0) → push a (secEq (μ-eq' a) b (~ k)) i
                      ; (j = i1) → push a b i})
               (push a b i))

    r : retract F G
    r (inl x) = refl
    r (inr x) = refl
    r (push (x , y) i) j =
      hcomp (λ k → λ { (i = i0) → inl x
                      ; (i = i1) → inr (μ e x y)
                      ; (j = i0) → (push (x , invEq (μ-eq' x) (μ e x y))
                                  ∙ (λ i₁ → inr (retEq≡secEq (μ-eq' x) y (~ k) i₁))) i
                      ; (j = i1) → push (x , y) i})
         (hcomp (λ k → λ { (i = i0) → inl x
                      ; (i = i1) → inr (μ e x (retEq (μ-eq' x) y k))
                      ; (j = i1) → push (x , retEq (μ-eq' x) y k) i})
                ((push (x , invEq (μ-eq' x) (μ e x y))) i))

    theIso : Iso TotalSpaceHopfPush (join (typ A) (typ A))
    fun theIso = F
    inv theIso = G
    rightInv theIso = s
    leftInv theIso = r

  isEquivTotalSpaceHopfPush→TotalSpace :
    isEquiv TotalSpaceHopfPush→TotalSpace
  isEquivTotalSpaceHopfPush→TotalSpace =
    isoToIsEquiv theIso
    where
    inv' : _ → _
    inv' (north , y) = inl y
    inv' (south , y) = inr y
    inv' (merid a i , y) =
      hcomp (λ k → λ { (i = i0) → push (y , a) (~ k)
                      ; (i = i1) → inr y})
            (inr (ua-unglue (μ-eq a) i y))
      where

      pp : PathP (λ i → ua (μ-eq a) i → TotalSpaceHopfPush)
                 inl inr
      pp = ua→ {e = μ-eq a} {B = λ _ → TotalSpaceHopfPush} λ b → push (b , a)

    sect : (x : _) → TotalSpaceHopfPush→TotalSpace (inv' x) ≡ x
    sect (north , x) = refl
    sect (south , x) = refl
    sect (merid a i , y) j =
      hcomp (λ k → λ { (i = i0) → merid a (~ k ∧ ~ j)
                                  , ua-gluePt (μ-eq a) (~ k ∧ ~ j) y
                      ; (i = i1) → south , y
                      ; (j = i0) →
                        TotalSpaceHopfPush→TotalSpace
                         (hfill (λ k → λ { (i = i0) → push (y , a) (~ k)
                                          ; (i = i1) → inr y})
                                (inS (inr (ua-unglue (μ-eq a) i y)))
                                k)
                      ; (j = i1) → merid a i , y})
            ((merid a (i ∨ ~ j)) , lem (μ-eq a) i j y)
      where
      lem : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) →
                PathP (λ i → PathP (λ j → (y : ua e i) → ua e (i ∨ ~ j))
                 (λ y → ua-unglue e i y)
                 λ y → y)
                 (λ j y → ua-gluePt e (~ j) y)
                 refl
      lem {A = A} {B = B} =
        EquivJ (λ B e → PathP (λ i → PathP (λ j → (y : ua e i) → ua e (i ∨ ~ j))
          (λ y → ua-unglue e i y)
           λ y → y)
           (λ j y → ua-gluePt e (~ j) y)
           refl)
           λ i j a → ua-gluePt (idEquiv B) (i ∨ ~ j) (ua-unglue (idEquiv B) i a)

    retr : retract TotalSpaceHopfPush→TotalSpace inv'
    retr (inl x) = refl
    retr (inr x) = refl
    retr (push (x , y) i) j =
      hcomp (λ k → λ { (i = i0) → push (x , y) (~ k)
                      ; (i = i1) → inr (μ e x y)
                      ; (j = i1) → push (x , y) (i ∨ ~ k)})
            (inr (μ e x y))

    theIso : Iso TotalSpaceHopfPush (Σ (Susp (typ A)) Hopf)
    fun theIso = TotalSpaceHopfPush→TotalSpace
    inv theIso = inv'
    rightInv theIso = sect
    leftInv theIso = retr

  IsoTotalSpaceJoin : Iso (Σ[ x ∈ Susp (typ A) ] Hopf x) (join (typ A) (typ A))
  IsoTotalSpaceJoin =
    compIso (equivToIso (invEquiv (_ , isEquivTotalSpaceHopfPush→TotalSpace)))
            joinIso₁

  induced : TotalSpaceHopfPush → Susp (typ A)
  induced = fst ∘ TotalSpaceHopfPush→TotalSpace

  ua-lem : (x y z : typ A) → (i j : I) → ua (μ-eq y) i
  ua-lem x y z i j =
    fill (λ k → ua (μ-eq y) i)
         (λ j → λ { (i = i0) → μ e z x
                  ; (i = i1) → μ-assoc e-ass z x y j})
          (inS (ua-gluePt (μ-eq y) i (μ e z x)))
          j

  TotalSpaceHopfPush→≃Hopf : (x : TotalSpaceHopfPush) → typ A ≃ Hopf (induced x)
  TotalSpaceHopfPush→≃Hopf (inl x) = μ-eq x
  TotalSpaceHopfPush→≃Hopf (inr x) = μ-eq x
  TotalSpaceHopfPush→≃Hopf (push (x , y) i₁) = pp x y i₁
    where
    pp : (x y : _) → PathP (λ i → typ A ≃ ua (μ-eq y) i) (μ-eq x) (μ-eq (μ e x y))
    pp x y = ΣPathP (P , help)
      where
      P : PathP (λ z → typ A → ua (μ-eq y) z) (fst (μ-eq x))
                (fst (μ-eq (μ e x y)))
      P i z = ua-lem x y z i i1

      abstract
        help : PathP (λ i₂ → isEquiv (P i₂)) (snd (μ-eq x))
                     (snd (μ-eq (μ e x y)))
        help = toPathP (isPropIsEquiv _ _ _)

  Push→TotalSpaceHopf : (a : typ A) (x : TotalSpaceHopfPush)
    → Σ[ x ∈ Susp (typ A) ] Hopf x
  Push→TotalSpaceHopf a x = (induced x) , fst (TotalSpaceHopfPush→≃Hopf x) a

  Push→TotalSpaceHopf-equiv : (a : typ A) → isEquiv (Push→TotalSpaceHopf a)
  Push→TotalSpaceHopf-equiv a = pRec (isPropIsEquiv _)
                    (J (λ a _ → isEquiv (Push→TotalSpaceHopf a))
                      (subst isEquiv (sym main)
                        isEquivTotalSpaceHopfPush→TotalSpace))
                    (conA (pt A) a)
    where
    lem₁ : (x : _) → fst ((Push→TotalSpaceHopf (pt A)) x)
                    ≡ fst (TotalSpaceHopfPush→TotalSpace x)
    lem₁ (inl x) = refl
    lem₁ (inr x) = refl
    lem₁ (push a i) = refl

    lem₂ : (x : _)
      → PathP (λ i → Hopf (lem₁ x i))
               (snd ((Push→TotalSpaceHopf (pt A)) x))
               (snd (TotalSpaceHopfPush→TotalSpace x))
    lem₂ (inl x) = μₗ e x
    lem₂ (inr x) = μₗ e x
    lem₂ (push (x , y) i) j =
      hcomp (λ k → λ {(i = i0) → μₗ e x j
                     ; (i = i1) → μ-assoc-filler e-ass x y j k
                     ; (j = i0) → ua-lem x y (pt A) i k
                     ; (j = i1) → ua-gluePt (μ-eq y) i x})
            (ua-gluePt (μ-eq y) i (μₗ e x j))

    main : Push→TotalSpaceHopf (pt A) ≡ TotalSpaceHopfPush→TotalSpace
    main i x = (lem₁ x i) , (lem₂ x i)

  TotalSpaceHopfPush² : Type _
  TotalSpaceHopfPush² = Pushout {A = TotalSpaceHopfPush} (λ _ → tt) induced

  P : TotalSpaceHopfPush² → Type _
  P (inl x) = typ A
  P (inr x) = Hopf x
  P (push a i) = ua (TotalSpaceHopfPush→≃Hopf a) i

  TotalSpacePush² : Type _
  TotalSpacePush² = Σ[ x ∈ TotalSpaceHopfPush² ] P x

  TotalSpacePush²' : Type _
  TotalSpacePush²' =
    Pushout {A = typ A × TotalSpaceHopfPush}
            {C = Σ[ x ∈ Susp (typ A) ] Hopf x}
            fst
            λ x → Push→TotalSpaceHopf (fst x) (snd x)

  IsoTotalSpacePush²TotalSpacePush²' : Iso TotalSpacePush² TotalSpacePush²'
  IsoTotalSpacePush²TotalSpacePush²' =
    compIso iso₂ (compIso (equivToIso fl.flatten) iso₁)
    where
    module fl =
      FlatteningLemma (λ _ → tt) induced (λ x → typ A)
                      Hopf TotalSpaceHopfPush→≃Hopf

    iso₁ : Iso (Pushout fl.Σf fl.Σg) TotalSpacePush²'
    fun iso₁ (inl x) = inl (snd x)
    fun iso₁ (inr x) = inr x
    fun iso₁ (push a i) = push ((snd a) , (fst a)) i
    inv iso₁ (inl x) = inl (tt , x)
    inv iso₁ (inr x) = inr x
    inv iso₁ (push a i) = push (snd a , fst a) i
    rightInv iso₁ (inl x) = refl
    rightInv iso₁ (inr x) = refl
    rightInv iso₁ (push a i) = refl
    leftInv iso₁ (inl x) = refl
    leftInv iso₁ (inr x) = refl
    leftInv iso₁ (push a i) = refl

    iso₂ : Iso TotalSpacePush² (Σ (Pushout (λ _ → tt) induced) fl.E)
    fun iso₂ (inl x , y) = inl x , y
    fun iso₂ (inr x , y) = inr x , y
    fun iso₂ (push a i , y) = push a i , y
    inv iso₂ (inl x , y) = inl x , y
    inv iso₂ (inr x , y) = inr x , y
    inv iso₂ (push a i , y) = push a i , y
    rightInv iso₂ (inl x , snd₁) = refl
    rightInv iso₂ (inr x , snd₁) = refl
    rightInv iso₂ (push a i , snd₁) = refl
    leftInv iso₂ (inl x , snd₁) = refl
    leftInv iso₂ (inr x , snd₁) = refl
    leftInv iso₂ (push a i , snd₁) = refl

  F : TotalSpacePush²'
     → (Pushout {A = typ A × Σ (Susp (typ A)) Hopf} fst snd)
  F (inl x) = inl x
  F (inr x) = inr x
  F (push (x , y) i) = push (x , Push→TotalSpaceHopf x y) i

  G : (Pushout {A = typ A × Σ (Susp (typ A)) Hopf} fst snd)
    → TotalSpacePush²'
  G (inl x) = inl x
  G (inr x) = inr x
  G (push (x , y) i) =
    hcomp (λ k → λ { (i = i0) → inl x
                    ; (i = i1)
                     → inr (secEq (_ , Push→TotalSpaceHopf-equiv x) y k)})
      (push (x , invEq (_ , Push→TotalSpaceHopf-equiv x) y) i)

  IsoTotalSpacePush²'ΣPush : Iso TotalSpacePush²'
           (Pushout {A = typ A × Σ (Susp (typ A)) Hopf} fst snd)
  fun IsoTotalSpacePush²'ΣPush = F
  inv IsoTotalSpacePush²'ΣPush = G
  rightInv IsoTotalSpacePush²'ΣPush (inl x) = refl
  rightInv IsoTotalSpacePush²'ΣPush (inr x) = refl
  rightInv IsoTotalSpacePush²'ΣPush (push (x , y) i) j =
    hcomp (λ k → λ { (i = i0) → inl x
                    ; (i = i1)
                     → inr (secEq (_ , Push→TotalSpaceHopf-equiv x) y k)
                    ; (j = i0) → F (
                         hfill (λ k →
                           λ { (i = i0) → inl x
                             ; (i = i1)
                              → inr (secEq (_
                                    , Push→TotalSpaceHopf-equiv x) y k)})
                          (inS (push (x
                                    , invEq (_
                                     , Push→TotalSpaceHopf-equiv x) y) i)) k)
                    ; (j = i1)
                     → push (x
                           , (secEq (_
                            , Push→TotalSpaceHopf-equiv x) y k)) i})
          (push (x , (secEq (_ , Push→TotalSpaceHopf-equiv x) y i0)) i)
  leftInv IsoTotalSpacePush²'ΣPush (inl x) = refl
  leftInv IsoTotalSpacePush²'ΣPush (inr x) = refl
  leftInv IsoTotalSpacePush²'ΣPush (push (x , y) i) j =
    hcomp (λ k → λ { (i = i0) → inl x
                    ; (i = i1) → inr (secEq (Push→TotalSpaceHopf x
                                           , Push→TotalSpaceHopf-equiv x)
                                        (Push→TotalSpaceHopf x y) (j ∨ k))
                    ; (j = i1) → push (x , y) i})
          (hcomp (λ k → λ { (i = i0) → inl x
                           ; (i = i1) → inr (retEq≡secEq
                                              (Push→TotalSpaceHopf x
                                             , Push→TotalSpaceHopf-equiv x)
                                               y (~ k) j)
                           ; (j = i1) → push (x , y) i
                           ; (j = i0) → push (x , invEq
                                               (Push→TotalSpaceHopf x
                                              , Push→TotalSpaceHopf-equiv x)
                                               (Push→TotalSpaceHopf x y)) i})
            (push (x , retEq (Push→TotalSpaceHopf x
                            , Push→TotalSpaceHopf-equiv x) y j) i))

  joinIso₂ : Iso TotalSpacePush² (join (typ A) (join (typ A) (typ A)))
  joinIso₂ =
    compIso IsoTotalSpacePush²TotalSpacePush²'
              (compIso IsoTotalSpacePush²'ΣPush
                (compIso (equivToIso (joinPushout≃join _ _))
                  (pathToIso (cong (join (typ A))
                             (isoToPath IsoTotalSpaceJoin)))))

-- Direct construction of Hopf fibration for S¹
module S¹Hopf where
  Border : (x : S¹) → (j : I) → Partial (j ∨ ~ j) (Σ Type₀ (λ T → T ≃ S¹))
  Border x j (j = i0) = S¹ , (x ·_) , rotIsEquiv x
  Border x j (j = i1) = S¹ , idEquiv S¹

  -- Hopf fibration using SuspS¹
  HopfSuspS¹ : SuspS¹ → Type₀
  HopfSuspS¹ north = S¹
  HopfSuspS¹ south = S¹
  HopfSuspS¹ (merid x j) = Glue S¹ (Border x j)

  -- Hopf fibration using S²
  -- TODO : prove that it is equivalent to HopfSuspS¹
  HopfS² : S² → Type₀
  HopfS² base = S¹
  HopfS² (surf i j) = Glue S¹ (λ { (i = i0) → _ , idEquiv S¹
                                 ; (i = i1) → _ , idEquiv S¹
                                 ; (j = i0) → _ , idEquiv S¹
                                 ; (j = i1) → _ , _ , rotIsEquiv (loop i) } )

  -- Hopf fibration using more direct definition of the rot equivalence
  -- TODO : prove that it is equivalent to HopfSuspS¹
  HopfS²' : S² → Type₀
  HopfS²' base = S¹
  HopfS²' (surf i j) = Glue S¹ (λ { (i = i0) → _ , rotLoopEquiv i0
                                  ; (i = i1) → _ , rotLoopEquiv i0
                                  ; (j = i0) → _ , rotLoopEquiv i0
                                  ; (j = i1) → _ , rotLoopEquiv i } )

  -- Total space of the fibration
  TotalHopf : Type₀
  TotalHopf = Σ SuspS¹ HopfSuspS¹

  -- Forward direction
  filler-1 : I → (j : I) → (y : S¹) → Glue S¹ (Border y j) → join S¹ S¹
  filler-1 i j y x = hfill (λ t → λ { (j = i0) → inl (rotInv-1 x y t)
                                    ; (j = i1) → inr x })
                           (inS (push ((unglue (j ∨ ~ j) x) · invLooper y) (unglue (j ∨ ~ j) x) j)) i

  TotalHopf→JoinS¹S¹ : TotalHopf → join S¹ S¹
  TotalHopf→JoinS¹S¹ (north , x) = inl x
  TotalHopf→JoinS¹S¹ (south , x) = inr x
  TotalHopf→JoinS¹S¹ (merid y j , x) = filler-1 i1 j y x

  -- Backward direction
  JoinS¹S¹→TotalHopf : join S¹ S¹ → TotalHopf
  JoinS¹S¹→TotalHopf (inl x) = (north , x)
  JoinS¹S¹→TotalHopf (inr x) = (south , x)
  JoinS¹S¹→TotalHopf (push y x j) =
    (merid (invLooper y · x) j
    , glue (λ { (j = i0) → y ; (j = i1) → x }) (rotInv-2 x y j))

  -- Now for the homotopies, we will need to fill squares indexed by x y : S¹ with value in S¹
  -- Some will be extremeley tough, but happen to be easy when x = y = base
  -- therefore, we fill them for x = y = base and then use the connectedness of S¹ × S¹ and
  -- the discreteness of ΩS¹ to get general fillers.

  -- To proceed with that strategy, we first need a lemma :
  -- the sections of the trivial fibration λ (_ : S¹) (_ : S¹) → Int are constant

  -- this should be generalized to a constant fibration over a connected space with
  -- discrete fiber
  fibℤ : S¹ → S¹ → Type₀
  fibℤ _ _ = ℤ

  S¹→HSet : (A : Type₀) (p : isSet A) (F : S¹ → A) (x : S¹) → F base ≡ F x
  S¹→HSet A p F base = refl {x = F base}
  S¹→HSet A p F (loop i) = f' i
    where
    f : PathP (λ i → F base ≡ F (loop i)) refl (cong F loop)
    f i = λ j → F (loop (i ∧ j))
    L : cong F loop ≡ refl
    L = p (F base) (F base) (f i1) refl
    f' : PathP (λ i → F base ≡ F (loop i)) (refl {x = F base}) (refl {x = F base})
    f' = transport (λ i → PathP (λ j → F base ≡ F (loop j)) refl (L i)) f

  constant-loop : (F : S¹ → S¹ → ℤ) → (x y : S¹) → F base base ≡ F x y
  constant-loop F x y = L0 ∙ L1
    where
    p : isSet (S¹ → ℤ)
    p = isSetΠ (λ _ → isSetℤ)
    L : F base ≡ F x
    L = S¹→HSet (S¹ → ℤ) p F x
    L0 : F base base ≡ F x base
    L0 i = L i base
    L1 : F x base ≡ F x y
    L1 = S¹→HSet ℤ isSetℤ (F x) y

  discretefib : (F : S¹ → S¹ → Type₀) → Type₀
  discretefib F = (a : (x y : S¹) → F x y) →
          (b : (x y : S¹) → F x y) →
          (a base base ≡ b base base) →
          (x y : S¹) → a x y ≡ b x y

  discretefib-fibℤ : discretefib fibℤ
  discretefib-fibℤ a b h x y i =
    hcomp (λ t → λ { (i = i0) → constant-loop a x y t
                   ; (i = i1) → constant-loop b x y t })
          (h i)

  -- first homotopy

  assocFiller-3-aux : I → I → I → I → S¹
  assocFiller-3-aux x y j i =
    hfill (λ t → λ { (i = i0) → rotInv-1 (loop y) (loop (~ y) · loop x) t
                   ; (i = i1) → rotInv-3 (loop y) (loop x) t
                   ; (x = i0) (y = i0) → base
                   ; (x = i0) (y = i1) → base
                   ; (x = i1) (y = i0) → base
                   ; (x = i1) (y = i1) → base })
          (inS ((rotInv-2 (loop x) (loop y) i) · (invLooper (loop (~ y) · loop x)))) j

  -- assocFiller-3-endpoint is used only in the type of the next function, to specify the
  -- second endpoint.
  -- However, I only need the first endpoint, but I cannot specify only one of them as is.
  -- TODO : use cubical extension types when available to remove assocFiller-3-endpoint
  assocFiller-3-endpoint : (x : S¹) → (y : S¹) → y ≡ y
  assocFiller-3-endpoint base base i = base
  assocFiller-3-endpoint (loop x) base i = assocFiller-3-aux x i0 i1 i
  assocFiller-3-endpoint base (loop y) i = assocFiller-3-aux i0 y i1 i
  assocFiller-3-endpoint (loop x) (loop y) i = assocFiller-3-aux x y i1 i

  assocFiller-3 : (x : S¹) → (y : S¹) →
                  PathP (λ j → rotInv-1 y (invLooper y · x) j ≡ rotInv-3 y x j)
                        (λ i → ((rotInv-2 x y i) · (invLooper (invLooper y · x))))
                        (assocFiller-3-endpoint x y)
  assocFiller-3 base base j i = base
  assocFiller-3 (loop x) base j i = assocFiller-3-aux x i0 j i
  assocFiller-3 base (loop y) j i = assocFiller-3-aux i0 y j i
  assocFiller-3 (loop x) (loop y) j i = assocFiller-3-aux x y j i

  assoc-3 : (_ y : S¹) → basedΩS¹ y
  assoc-3 x y i = assocFiller-3 x y i1 i

  fibℤ≡fibAssoc-3 : fibℤ ≡ (λ _ y → basedΩS¹ y)
  fibℤ≡fibAssoc-3 i = λ x y → basedΩS¹≡ℤ y (~ i)

  discretefib-fibAssoc-3 : discretefib (λ _ y → basedΩS¹ y)
  discretefib-fibAssoc-3 =
    transp (λ i → discretefib (fibℤ≡fibAssoc-3 i)) i0 discretefib-fibℤ

  assocConst-3 : (x y : S¹) → assoc-3 x y ≡ refl
  assocConst-3 x y = discretefib-fibAssoc-3 assoc-3 (λ _ _ → refl) refl x y

  assocSquare-3 : I → I → S¹ → S¹ → S¹
  assocSquare-3 i j x y = hcomp (λ t → λ { (i = i0) → assocFiller-3 x y j i0
                                         ; (i = i1) → assocFiller-3 x y j i1
                                         ; (j = i0) → assocFiller-3 x y i0 i
                                         ; (j = i1) → assocConst-3 x y t i })
                              (assocFiller-3 x y j i)

  filler-3 : I → I → S¹ → S¹ → join S¹ S¹
  filler-3 i j y x =
    hcomp (λ t → λ { (i = i0) → filler-1 t j (invLooper y · x)
                                             (glue (λ { (j = i0) → y ; (j = i1) → x })
                                                   (rotInv-2 x y j))
                   ; (i = i1) → push (rotInv-3 y x t) x j
                   ; (j = i0) → inl (assocSquare-3 i t x y)
                   ; (j = i1) → inr x })
          (push ((rotInv-2 x y (i ∨ j)) · (invLooper (invLooper y · x))) (rotInv-2 x y (i ∨ j)) j)

  JoinS¹S¹→TotalHopf→JoinS¹S¹ : ∀ x → TotalHopf→JoinS¹S¹ (JoinS¹S¹→TotalHopf x) ≡ x
  JoinS¹S¹→TotalHopf→JoinS¹S¹ (inl x) i = inl x
  JoinS¹S¹→TotalHopf→JoinS¹S¹ (inr x) i = inr x
  JoinS¹S¹→TotalHopf→JoinS¹S¹ (push y x j) i = filler-3 i j y x

  -- Second homotopy

  -- This HIT is the total space of the Hopf fibration but the ends of SuspS¹ have not been
  -- glued together yet — which makes it into a cylinder.
  -- This allows to write compositions that do not properly match at the endpoints. However,
  -- I suspect it is unnecessary. TODO : do without PseudoHopf

  PseudoHopf : Type₀
  PseudoHopf = (S¹ × Interval) × S¹

  PseudoHopf-π1 : PseudoHopf → S¹
  PseudoHopf-π1 ((y , _) , _) = y

  PseudoHopf-π2 : PseudoHopf → S¹
  PseudoHopf-π2 (_ , x) = x

  assocFiller-4-aux : I → I → I → I → S¹
  assocFiller-4-aux x y j i =
    hfill (λ t → λ { (i = i0) → ((invLooper (loop y · loop x · loop (~ y))) · (loop y · loop x))
                                · (rotInv-1 (loop x) (loop y) t)
                   ; (i = i1) → (rotInv-4 (loop y) (loop y · loop x) (~ t)) · loop x
                   ; (x = i0) (y = i0) → base
                   ; (x = i0) (y = i1) → base
                   ; (x = i1) (y = i0) → base
                   ; (x = i1) (y = i1) → base })
          (inS (rotInv-2 (loop y · loop x) (loop y · loop x · loop (~ y)) i)) j

  -- See assocFiller-3-endpoint
  -- TODO : use cubical extension types when available to remove assocFiller-4-endpoint
  assocFiller-4-endpoint : (x y : S¹) → basedΩS¹ (((invLooper (y · x · invLooper y)) · (y · x)) · x)
  assocFiller-4-endpoint base base i = base
  assocFiller-4-endpoint (loop x) base i = assocFiller-4-aux x i0 i1 i
  assocFiller-4-endpoint base (loop y) i = assocFiller-4-aux i0 y i1 i
  assocFiller-4-endpoint (loop x) (loop y) i = assocFiller-4-aux x y i1 i

  assocFiller-4 : (x y : S¹) →
                  PathP (λ j → ((invLooper (y · x · invLooper y)) · (y · x)) · (rotInv-1 x y j) ≡ (rotInv-4 y (y · x) (~ j)) · x)
                        (λ i → (rotInv-2 (y · x) (y · x · invLooper y) i))
                        (assocFiller-4-endpoint x y)
  assocFiller-4 base base j i = base
  assocFiller-4 (loop x) base j i = assocFiller-4-aux x i0 j i
  assocFiller-4 base (loop y) j i = assocFiller-4-aux i0 y j i
  assocFiller-4 (loop x) (loop y) j i = assocFiller-4-aux x y j i

  assoc-4 : (x y : S¹) → basedΩS¹ (((invLooper (y · x · invLooper y)) · (y · x)) · x)
  assoc-4 x y i = assocFiller-4 x y i1 i

  fibℤ≡fibAssoc-4 : fibℤ ≡ (λ x y → basedΩS¹ (((invLooper (y · x · invLooper y)) · (y · x)) · x))
  fibℤ≡fibAssoc-4 i = λ x y → basedΩS¹≡ℤ (((invLooper (y · x · invLooper y)) · (y · x)) · x) (~ i)

  discretefib-fibAssoc-4 : discretefib (λ x y → basedΩS¹ (((invLooper (y · x · invLooper y)) · (y · x)) · x))
  discretefib-fibAssoc-4 =
    transp (λ i → discretefib (fibℤ≡fibAssoc-4 i)) i0 discretefib-fibℤ

  assocConst-4 : (x y : S¹) → assoc-4 x y ≡ refl
  assocConst-4 x y = discretefib-fibAssoc-4 assoc-4 (λ _ _ → refl) refl x y

  assocSquare-4 : I → I → S¹ → S¹ → S¹
  assocSquare-4 i j x y =
    hcomp (λ t → λ { (i = i0) → assocFiller-4 x y j i0
                   ; (i = i1) → assocFiller-4 x y j i1
                   ; (j = i0) → assocFiller-4 x y i0 i
                   ; (j = i1) → assocConst-4 x y t i })
          (assocFiller-4 x y j i)

  filler-4-0 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → PseudoHopf
  filler-4-0 i j y x =
    let x' = unglue (j ∨ ~ j) x in
    hfill (λ t → λ { (j = i0) → ((invLooper (y · x · invLooper y) · (y · x) , I0)
                                , invLooper (y · x · invLooper y) · (y · x) · (rotInv-1 x y t))
                   ; (j = i1) → ((invLooper (x · invLooper y) · x , I1) , x) })
          (inS ((invLooper (x' · invLooper y) · x' , seg j) , rotInv-2 x' (x' · invLooper y) j)) i

  filler-4-1 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → PseudoHopf
  filler-4-1 i j y x =
    let x' = unglue (j ∨ ~ j) x in
    hfill (λ t → λ { (j = i0) → ((invLooper (y · x · invLooper y) · (y · x) , I0)
                                , (rotInv-4 y (y · x) (~ t)) · x)
                   ; (j = i1) → ((invLooper (x · invLooper y) · x , I1) , x) })
          (inS ((invLooper (x' · invLooper y) · x' , seg j) , unglue (j ∨ ~ j) x)) i

  filler-4-2 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → TotalHopf
  filler-4-2 i j y x =
    let x' = unglue (j ∨ ~ j) x in
    hcomp (λ t → λ { (i = i0) → JoinS¹S¹→TotalHopf (filler-1 t j y x)
                   ; (i = i1) → (merid (PseudoHopf-π1 (filler-4-0 t j y x)) j
                                , glue (λ { (j = i0) → rotInv-1 x y t ; (j = i1) → x })
                                       (PseudoHopf-π2 (filler-4-0 t j y x)))
                   ; (j = i0) → (north , rotInv-1 x y t)
                   ; (j = i1) → (south , x) })
          (merid (invLooper (x' · invLooper y) · x') j
          , glue (λ { (j = i0) → y · x · invLooper y ; (j = i1) → x }) (rotInv-2 x' (x' · invLooper y) j))

  filler-4-3 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → PseudoHopf
  filler-4-3 i j y x =
    let x' = unglue (j ∨ ~ j) x in
    hcomp (λ t → λ { (i = i0) → filler-4-0 t j y x
                   ; (i = i1) → filler-4-1 t j y x
                   ; (j = i0) → ((invLooper (y · x · invLooper y) · (y · x) , I0) , assocSquare-4 i t x y)
                   ; (j = i1) → ((invLooper (x · invLooper y) · x , I1) , x) })
          ((invLooper (x' · invLooper y) · x' , seg j) , rotInv-2 x' (x' · invLooper y) (i ∨ j))

  filler-4-4 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → PseudoHopf
  filler-4-4 i j y x =
    let x' = unglue (j ∨ ~ j) x in
    hcomp (λ t → λ { (i = i0) → filler-4-1 t j y x
                   ; (i = i1) → ((y , seg j) , unglue (j ∨ ~ j) x)
                   ; (j = i0) → ((rotInv-4 y (y · x) i , I0)
                                , (rotInv-4 y (y · x) (i ∨ ~ t)) · x)
                   ; (j = i1) → ((rotInv-4 y x i , I1) , x) })
          ((rotInv-4 y x' i , seg j) , x')

  filler-4-5 : (_ j : I) → (y : S¹) → Glue S¹ (Border y j) → TotalHopf
  filler-4-5 i j y x =
    hcomp (λ t → λ { (i = i0) → filler-4-2 (~ t) j y x
                   ; (i = i1) → (merid (PseudoHopf-π1 (filler-4-4 t j y x)) j
                                , glue (λ { (j = i0) → x ; (j = i1) → x })
                                       (PseudoHopf-π2 (filler-4-4 t j y x)))
                   ; (j = i0) → (north , x)
                   ; (j = i1) → (south , x) })
          (merid (PseudoHopf-π1 (filler-4-3 i j y x)) j
          , glue (λ { (j = i0) → x ; (j = i1) → x }) (PseudoHopf-π2 (filler-4-3 i j y x)))

  TotalHopf→JoinS¹S¹→TotalHopf : ∀ x → JoinS¹S¹→TotalHopf (TotalHopf→JoinS¹S¹ x) ≡ x
  TotalHopf→JoinS¹S¹→TotalHopf (north , x) i = (north , x)
  TotalHopf→JoinS¹S¹→TotalHopf (south , x) i = (south , x)
  TotalHopf→JoinS¹S¹→TotalHopf (merid y j , x) i = filler-4-5 i j y x

  JoinS¹S¹≡TotalHopf : join S¹ S¹ ≡ TotalHopf
  JoinS¹S¹≡TotalHopf = isoToPath (iso JoinS¹S¹→TotalHopf
                                      TotalHopf→JoinS¹S¹
                                      TotalHopf→JoinS¹S¹→TotalHopf
                                      JoinS¹S¹→TotalHopf→JoinS¹S¹)

  S³≡TotalHopf : S³ ≡ TotalHopf
  S³≡TotalHopf = S³≡joinS¹S¹ ∙ JoinS¹S¹≡TotalHopf

  open Iso
  IsoS³TotalHopf : Iso (S₊ 3) TotalHopf
  fun IsoS³TotalHopf x = JoinS¹S¹→TotalHopf (S³→joinS¹S¹ (inv IsoS³S3 x))
  inv IsoS³TotalHopf x = fun IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x))
  rightInv IsoS³TotalHopf x =
       cong (JoinS¹S¹→TotalHopf ∘ S³→joinS¹S¹)
            (leftInv IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x)))
    ∙∙ cong JoinS¹S¹→TotalHopf
            (joinS¹S¹→S³→joinS¹S¹ (TotalHopf→JoinS¹S¹ x))
    ∙∙ TotalHopf→JoinS¹S¹→TotalHopf x
  leftInv IsoS³TotalHopf x =
       cong (fun IsoS³S3 ∘ joinS¹S¹→S³)
            (JoinS¹S¹→TotalHopf→JoinS¹S¹ (S³→joinS¹S¹ (inv IsoS³S3 x)))
    ∙∙ cong (fun IsoS³S3) (S³→joinS¹S¹→S³ (inv IsoS³S3 x))
    ∙∙ Iso.rightInv IsoS³S3 x


open import Agda.Primitive using (_⊔_ ; lsuc ; Level)

import Categories.Category as Category
import Categories.Category.Cartesian as Cartesian
open import Categories.Object.Terminal using (Terminal)
open import Categories.Object.Product using (Product)

open import MultiSorted.AlgebraicTheory
import MultiSorted.Product as Product
import MultiSorted.Interpretation

module MultiSorted.InterpretationCategory
         {o ℓ e}
         {𝓈 ℴ}
         (Σ : Signature {𝓈} {ℴ})
         {𝒞 : Category.Category o ℓ e}
         (cartesian-𝒞 : Cartesian.Cartesian 𝒞) where
  open Signature Σ
  open Category.Category 𝒞
  open Cartesian.Cartesian cartesian-𝒞
  open MultiSorted.Interpretation Σ cartesian-𝒞

  -- Equality of homomorphisms of interpretations
  _≈I_ : ∀ {I J : Interpretation} → I ⇒I J → I ⇒I J → Set (e ⊔ 𝓈)
  _≈I_ {I} {J} ϕ ψ =
    let open _⇒I_ in ∀ (A : sort) → hom-morphism ϕ {A} ≈ hom-morphism ψ

  -- The category of interpretations of Σ in 𝒞
  ℐ𝓃𝓉 : Category.Category (o ⊔ ℓ ⊔ e ⊔ 𝓈 ⊔ ℴ) (o ⊔ ℓ ⊔ e ⊔ 𝓈 ⊔ ℴ) (e ⊔ 𝓈)
  ℐ𝓃𝓉 = record
          { Obj = Interpretation
          ; _⇒_ = _⇒I_
          ; _≈_ = _≈I_
          ; id = id-I
          ; _∘_ = _∘I_
          ; assoc = λ _ → assoc
          ; sym-assoc = λ _ → sym-assoc
          ; identityˡ = λ _ → identityˡ
          ; identityʳ = λ _ → identityʳ
          ; identity² = λ _ → identity²
          ; equiv = record { refl = λ A → Equiv.refl
                           ; sym = λ p A → Equiv.sym (p A)
                           ; trans = λ p₁ p₂ A → Equiv.trans (p₁ A) (p₂ A)
                           }
          ; ∘-resp-≈ = λ p₁ p₂ A → ∘-resp-≈ (p₁ A) (p₂ A)
          }

  -- Cartesian structure on the category on interpretations of Σ in 𝒞
  module _ (I J : Interpretation) where
    open Interpretation
    open Product.Producted
    open HomReasoning
    A×B-ℐ𝓃𝓉 : Interpretation
    interp-sort A×B-ℐ𝓃𝓉 A = interp-sort I A × interp-sort J A
    -- Contexts
    -- -- Structure
    prod  (interp-ctx A×B-ℐ𝓃𝓉) Γ = prod (interp-ctx I) Γ × prod (interp-ctx J) Γ
    π (interp-ctx A×B-ℐ𝓃𝓉) x = (π (interp-ctx I) x) ⁂ (π (interp-ctx J) x)
    tuple (interp-ctx A×B-ℐ𝓃𝓉) Γ fs = ⟨ (tuple (interp-ctx I) Γ λ x → π₁ ∘ fs x) , ((tuple (interp-ctx J) Γ λ x → π₂ ∘ fs x)) ⟩
    project (interp-ctx A×B-ℐ𝓃𝓉) {Γ} {B} {x} {fs} =
      begin
      π (interp-ctx A×B-ℐ𝓃𝓉) x ∘
        (tuple (interp-ctx A×B-ℐ𝓃𝓉) Γ fs) ≈⟨ ⁂∘⟨⟩ ⟩
      ⟨ π (interp-ctx I) x ∘ tuple (interp-ctx I) Γ (λ x₁ → π₁ ∘ fs x₁) ,
        π (interp-ctx J) x ∘ tuple (interp-ctx J) Γ (λ x₁ → π₂ ∘ fs x₁) ⟩ ≈⟨ ⟨⟩-congʳ (project (interp-ctx I)) ⟩
      ⟨ π₁ ∘ fs x ,
        π (interp-ctx J) x ∘ tuple (interp-ctx J) Γ (λ x₁ → π₂ ∘ fs x₁) ⟩ ≈⟨ ⟨⟩-congˡ (project (interp-ctx J)) ⟩
      ⟨ π₁ ∘ fs x , π₂ ∘ fs x ⟩ ≈⟨ Product.unique product Equiv.refl Equiv.refl ⟩
      fs x ∎
    unique (interp-ctx A×B-ℐ𝓃𝓉) {Γ} {A} {g} {fs} ps = Product.unique product
                                                 (⟺ (unique (interp-ctx I) λ i → begin
                                                 π (interp-ctx I) i ∘ product.π₁  ∘ fs ≈⟨ sym-assoc ⟩
                                                 (π (interp-ctx I) i ∘ product.π₁) ∘ fs ≈⟨ (Π-nat₁ i ⟩∘⟨refl)  ⟩
                                                 (product.π₁ ∘ (π (interp-ctx A×B-ℐ𝓃𝓉) i)) ∘ fs  ≈⟨ assoc ⟩
                                                 product.π₁ ∘((π (interp-ctx A×B-ℐ𝓃𝓉) i)  ∘ fs) ≈⟨ (refl⟩∘⟨ ps i) ⟩
                                                 product.π₁ ∘ g i ∎))
                                                 (⟺ (unique (interp-ctx J) λ i → begin
                                                 (π (interp-ctx J) i ∘ π₂ ∘ fs) ≈⟨ sym-assoc ⟩
                                                 ((π (interp-ctx J) i ∘ π₂) ∘ fs) ≈⟨ (Π-nat₂ i ⟩∘⟨refl) ⟩
                                                 ((product.π₂ ∘ π (interp-ctx A×B-ℐ𝓃𝓉) i) ∘ fs) ≈⟨ assoc ⟩
                                                 (π₂ ∘ π (interp-ctx A×B-ℐ𝓃𝓉) i ∘ fs) ≈⟨ (refl⟩∘⟨ ps i) ⟩
                                                 (π₂ ∘ g i) ∎))
           where
           Π-nat₁ : {Γ : Context} → (i : var Γ) → π (interp-ctx I) i ∘ product.π₁ ≈ product.π₁ ∘ π (interp-ctx A×B-ℐ𝓃𝓉) i
           Π-nat₁ = λ i → ⟺ project₁

           Π-nat₂ : {Γ : Context} → (i : var Γ) → π (interp-ctx J) i ∘ product.π₂ ≈ product.π₂ ∘ π (interp-ctx A×B-ℐ𝓃𝓉) i
           Π-nat₂ = λ i → ⟺ project₂

    -- Operations
    interp-oper A×B-ℐ𝓃𝓉 = λ f → (interp-oper I f) ⁂ (interp-oper J f)

  -- Useful propoerties for the definition of projections
  module _ (I J : Interpretation) f where
    open Product.Producted
    open Interpretation
    open HomReasoning

    Π-nat₁ : {Γ : Context} → (i : var Γ) → π (interp-ctx I) i ∘ product.π₁ ≈ product.π₁ ∘ π (interp-ctx (A×B-ℐ𝓃𝓉 I J)) i
    Π-nat₁ = λ i → ⟺ project₁

    Π-nat₂ : {Γ : Context} → (i : var Γ) → π (interp-ctx J) i ∘ product.π₂ ≈ product.π₂ ∘ π (interp-ctx (A×B-ℐ𝓃𝓉 I J)) i
    Π-nat₂ = λ i → ⟺ project₂

    π₁-tuple : π₁ ≈ tuple (interp-ctx I) (oper-arity f) (λ i → π₁ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i))
    π₁-tuple = ⟺ (begin
                     tuple (interp-ctx I) (oper-arity f)
                       (λ i → π₁ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i)) ≈⟨ tuple-cong (interp-ctx I) (λ i → π₁∘⁂) ⟩
                     tuple (interp-ctx I) (oper-arity f) (λ x → π (interp-ctx I) x ∘ π₁) ≈⟨ ∘-distribʳ-tuple (interp-ctx I) ⟩
                     (tuple (interp-ctx I) (oper-arity f) (λ x → π (interp-ctx I) x) ∘ π₁) ≈⟨ ∘-resp-≈ˡ (Product.Producted.η (interp-ctx I)) ⟩
                     (id ∘ π₁) ≈⟨ identityˡ ⟩
                     π₁ ∎)

    π₂-tuple : π₂ ≈ tuple (interp-ctx J) (oper-arity f) (λ i → π₂ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i))
    π₂-tuple = ⟺ (begin
                      tuple (interp-ctx J) (oper-arity f)
                        (λ i → π₂ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i)) ≈⟨ tuple-cong (interp-ctx J) (λ i → π₂∘⁂) ⟩
                      tuple (interp-ctx J) (oper-arity f) (λ x → π (interp-ctx J) x ∘ π₂) ≈⟨ ∘-distribʳ-tuple (interp-ctx J) ⟩
                      (tuple (interp-ctx J) (oper-arity f) (λ x → π (interp-ctx J) x) ∘ π₂) ≈⟨ ∘-resp-≈ˡ (Product.Producted.η (interp-ctx J)) ⟩
                      (id ∘ π₂) ≈⟨ identityˡ ⟩
                      π₂ ∎)

  -- Definition of projections
  π₁-ℐ𝓃𝓉 : ∀ {I J : Interpretation} → A×B-ℐ𝓃𝓉 I J ⇒I I
  π₁-ℐ𝓃𝓉 {I} {J} =
                   let open HomReasoning in
                   let open Product.Producted in
                   let open Interpretation in
                   record
                     { hom-morphism = Cartesian.Cartesian.π₁ cartesian-𝒞
                     ; hom-commute = λ f → begin
                                             (π₁ ∘ interp-oper (A×B-ℐ𝓃𝓉 I J) f) ≈⟨ π₁∘⁂ ⟩
                                             (interp-oper I f ∘ π₁) ≈⟨ ∘-resp-≈ʳ (π₁-tuple I J f) ⟩
                                             (interp-oper I f ∘
                                               tuple (interp-ctx I) (oper-arity f)
                                               (λ i → π₁ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i))) ∎
                     }

  π₂-ℐ𝓃𝓉 : ∀ {I J : Interpretation} → A×B-ℐ𝓃𝓉 I J ⇒I J
  π₂-ℐ𝓃𝓉 {I} {J} =
                   let open HomReasoning in
                   let open Product.Producted in
                   let open Interpretation in
                   record
                     { hom-morphism = Cartesian.Cartesian.π₂ cartesian-𝒞
                     ; hom-commute = λ f → begin
                                             (π₂ ∘ interp-oper (A×B-ℐ𝓃𝓉 I J) f) ≈⟨ π₂∘⁂ ⟩
                                             (interp-oper J f ∘ π₂) ≈⟨ ∘-resp-≈ʳ (π₂-tuple I J f) ⟩
                                             (interp-oper J f ∘
                                               tuple (interp-ctx J) (oper-arity f)
                                               (λ i → π₂ ∘ (π (interp-ctx I) i ⁂ π (interp-ctx J) i))) ∎
                     }

  -- Useful properties for the definition of ⟨_,_⟩-ℐ𝓃𝓉
  module _ (I J K : Interpretation) f (ϕ : I ⇒I J) (ψ : I ⇒I K) where
         open Interpretation
         open HomReasoning
         open Product.Producted

         ⟨⟩-left : interp-oper J f ∘ tuple
                                        (interp-ctx J)
                                        (oper-arity f)
                                        (λ x → π₁ ∘ ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x) ≈ _⇒I_.hom-morphism ϕ ∘ interp-oper I f
         ⟨⟩-left = begin
                   (interp-oper J f ∘
                     tuple (interp-ctx J) (oper-arity f)
                     (λ x →
                        π₁ ∘
                        ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x)) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx J) λ i → sym-assoc) ⟩
                   (interp-oper J f ∘
                     tuple (interp-ctx J) (oper-arity f)
                     (λ x →
                        (π₁ ∘ ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩) ∘
                        π (interp-ctx I) x)) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx J) λ i → ∘-resp-≈ˡ project₁) ⟩
                   (interp-oper J f ∘
                     tuple (interp-ctx J) (oper-arity f)
                     (λ x → _⇒I_.hom-morphism ϕ ∘ π (interp-ctx I) x)) ≈⟨ ⟺ (_⇒I_.hom-commute ϕ f) ⟩
                   (_⇒I_.hom-morphism ϕ ∘ interp-oper I f) ∎

         ⟨⟩-right : interp-oper K f ∘ tuple
                                        (interp-ctx K)
                                        (oper-arity f)
                                        (λ x → π₂ ∘ ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x) ≈ _⇒I_.hom-morphism ψ ∘ interp-oper I f
         ⟨⟩-right = begin
                   (interp-oper K f ∘
                     tuple (interp-ctx K) (oper-arity f)
                     (λ x →
                        π₂ ∘
                        ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x)) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx K) λ i → sym-assoc) ⟩
                   (interp-oper K f ∘
                     tuple (interp-ctx K) (oper-arity f)
                     (λ x →
                        (π₂ ∘ ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩) ∘
                        π (interp-ctx I) x)) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx K) λ i → ∘-resp-≈ˡ project₂) ⟩
                   (interp-oper K f ∘
                     tuple (interp-ctx K) (oper-arity f)
                     (λ x → _⇒I_.hom-morphism ψ ∘ π (interp-ctx I) x)) ≈⟨ ⟺ (_⇒I_.hom-commute ψ f) ⟩
                   (_⇒I_.hom-morphism ψ ∘ interp-oper I f) ∎

  -- Definition of pairing
  ⟨_,_⟩-ℐ𝓃𝓉 : ∀ {I J K : Interpretation} → I ⇒I J → I ⇒I K → I ⇒I A×B-ℐ𝓃𝓉 J K
  ⟨_,_⟩-ℐ𝓃𝓉 {I} {J} {K} ϕ ψ =
     let open HomReasoning in
     let open Product.Producted in
     let open Interpretation in
     record
       { hom-morphism = λ {A} → ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩
       ; hom-commute = λ f →
                             ⟺ (begin
                                     (interp-oper (A×B-ℐ𝓃𝓉 J K) f ∘
                                       tuple (interp-ctx (A×B-ℐ𝓃𝓉 J K)) (oper-arity f)
                                       (λ i →
                                          ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) i)) ≈⟨ ⁂∘⟨⟩ ⟩
                                     ⟨
                                       interp-oper J f ∘
                                       tuple (interp-ctx J) (oper-arity f)
                                       (λ x →
                                          π₁ ∘
                                          ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x)
                                       ,
                                       interp-oper K f ∘
                                       tuple (interp-ctx K) (oper-arity f)
                                       (λ x →
                                          π₂ ∘
                                          ⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ π (interp-ctx I) x)
                                       ⟩ ≈⟨ ⟨⟩-cong₂ (⟨⟩-left I J K f ϕ ψ) (⟨⟩-right I J K f ϕ ψ) ⟩
                                     product.⟨ _⇒I_.hom-morphism ϕ ∘ interp-oper I f ,
                                       _⇒I_.hom-morphism ψ ∘ interp-oper I f ⟩ ≈˘⟨ ⟨⟩∘ ⟩
                                     (⟨ _⇒I_.hom-morphism ϕ , _⇒I_.hom-morphism ψ ⟩ ∘ interp-oper I f) ∎)
       }

  -- Properties about projections and unicity
  project₁-ℐ𝓃𝓉 : {I J K : Interpretation} {h : I ⇒I J} {i : I ⇒I K} (A : sort) → π₁ ∘ ⟨ _⇒I_.hom-morphism {I} {J} h {A} , _⇒I_.hom-morphism {I} {K} i ⟩ ≈ _⇒I_.hom-morphism h
  project₁-ℐ𝓃𝓉 A = project₁

  project₂-ℐ𝓃𝓉 : {I J K : Interpretation} {h : I ⇒I J} {i : I ⇒I K} (A : sort) → π₂ ∘ ⟨ _⇒I_.hom-morphism {I} {J} h {A} , _⇒I_.hom-morphism {I} {K} i ⟩ ≈ _⇒I_.hom-morphism i
  project₂-ℐ𝓃𝓉 A = project₂

  unique-ℐ𝓃𝓉 : {I J K : Interpretation}
                 {h : I ⇒I A×B-ℐ𝓃𝓉 J K}
                 {i : I ⇒I J} {j : I ⇒I K} →
                 ((A : sort) → π₁ ∘ _⇒I_.hom-morphism h {A} ≈ _⇒I_.hom-morphism i) →
                 ((A : sort) → π₂ ∘ _⇒I_.hom-morphism h {A} ≈ _⇒I_.hom-morphism j) →
                 (A : sort) →
                   ⟨ _⇒I_.hom-morphism i {A} , _⇒I_.hom-morphism j ⟩ ≈ _⇒I_.hom-morphism h
  unique-ℐ𝓃𝓉 = λ p₁ p₂ A → unique (p₁ A) (p₂ A)

  -- Definition of the structure of the product
  product-ℐ𝓃𝓉 : ∀ {I J} → Product ℐ𝓃𝓉 I J
  product-ℐ𝓃𝓉 {I} {J} =
    record
      { A×B = A×B-ℐ𝓃𝓉 I J
      ; π₁ = π₁-ℐ𝓃𝓉 {I} {J}
      ; π₂ = π₂-ℐ𝓃𝓉 {I} {J}
      ; ⟨_,_⟩ = ⟨_,_⟩-ℐ𝓃𝓉
      ; project₁ = λ {K} {h} {i} A → project₁-ℐ𝓃𝓉 {K} {I} {J} {h} {i} A
      ; project₂ = λ {K} {h} {i} A → project₂-ℐ𝓃𝓉 {K} {I} {J} {h} {i} A
      ; unique = λ {K} {h} {i} {j} p₁ p₂ A → unique-ℐ𝓃𝓉 {K} {I} {J} {h} {i} {j} p₁ p₂ A
      }

  -- The terminal object
  terminal-ℐ𝓃𝓉 : Terminal ℐ𝓃𝓉
  terminal-ℐ𝓃𝓉 =
    record
      { ⊤ = Trivial
      ; ⊤-is-terminal =
        record
          { ! =
              record
                { hom-morphism = !
                ; hom-commute =  λ f → !-unique₂
                }
          ; !-unique = λ f A → !-unique₂
          }
      }

  -- The category of interpretations is cartesian
  cartesian-ℐ𝓃𝓉 : Cartesian.Cartesian ℐ𝓃𝓉
  cartesian-ℐ𝓃𝓉 =
    record
      { terminal = terminal-ℐ𝓃𝓉
      ; products = record { product = product-ℐ𝓃𝓉 }
      }

  -- Each projection is a natural transformation with respect to the interpretation
  open Interpretation
  open HomReasoning
  open Product.Producted

  natural-π₁ : {I J : Interpretation} {A : sort} {Γ : Context} (t : Term Γ A) → π₁ ∘ (interp-term (A×B-ℐ𝓃𝓉 I J) t) ≈ (interp-term I t) ∘ π₁
  natural-π₁ {I} {J} (Signature.tm-var x) = project₁
  natural-π₁ {I} {J} (Signature.tm-oper f xs) = begin
                                                 (π₁ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (tm-oper f xs)) ≈⟨ ∘-resp-≈ʳ ⁂∘⟨⟩ ⟩
                                                 (π₁ ∘
                                                    ⟨
                                                    interp-oper I f ∘
                                                    Product.Producted.tuple (interp-ctx I) (oper-arity f)
                                                    (λ i → π₁ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))
                                                    ,
                                                    interp-oper J f ∘
                                                    Product.Producted.tuple (interp-ctx J) (oper-arity f)
                                                    (λ i → π₂ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))
                                                    ⟩) ≈⟨ project₁ ⟩
                                                 (interp-oper I f ∘
                                                   Product.Producted.tuple (interp-ctx I) (oper-arity f)
                                                   (λ i → π₁ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx I) λ i → natural-π₁ {I} {J} {arg-sort f i} (xs i)) ⟩
                                                 (interp-oper I f ∘
                                                   tuple (interp-ctx I) (oper-arity f)
                                                   (λ i → interp-term I (xs i) ∘ π₁)) ≈⟨ ∘-resp-≈ʳ (∘-distribʳ-tuple (interp-ctx I)) ⟩
                                                 (interp-oper I f ∘
                                                   tuple (interp-ctx I) (oper-arity f) (λ x → interp-term I (xs x)) ∘
                                                   π₁) ≈⟨ sym-assoc ⟩
                                                 ((interp-oper I f ∘
                                                    tuple (interp-ctx I) (oper-arity f) (λ x → interp-term I (xs x)))
                                                   ∘ π₁) ∎

  natural-π₂ : {I J : Interpretation} {A : sort} {Γ : Context} (t : Term Γ A) → π₂ ∘ (interp-term (A×B-ℐ𝓃𝓉 I J) t) ≈ (interp-term J t) ∘ π₂
  natural-π₂ {I} {J} (Signature.tm-var x) = project₂
  natural-π₂ {I} {J} (Signature.tm-oper f xs) = begin
                                                 (π₂ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (tm-oper f xs)) ≈⟨ ∘-resp-≈ʳ ⁂∘⟨⟩ ⟩
                                                 (π₂ ∘
                                                    ⟨
                                                    interp-oper I f ∘
                                                    Product.Producted.tuple (interp-ctx I) (oper-arity f)
                                                    (λ i → π₁ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))
                                                    ,
                                                    interp-oper J f ∘
                                                    Product.Producted.tuple (interp-ctx J) (oper-arity f)
                                                    (λ i → π₂ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))
                                                    ⟩) ≈⟨ project₂ ⟩
                                                 (interp-oper J f ∘
                                                   Product.Producted.tuple (interp-ctx J) (oper-arity f)
                                                   (λ i → π₂ ∘ interp-term (A×B-ℐ𝓃𝓉 I J) (xs i))) ≈⟨ ∘-resp-≈ʳ (tuple-cong (interp-ctx J) λ i → natural-π₂ {I} {J} {arg-sort f i} (xs i)) ⟩
                                                 (interp-oper J f ∘
                                                   tuple (interp-ctx J) (oper-arity f)
                                                   (λ i → interp-term J (xs i) ∘ π₂)) ≈⟨ ∘-resp-≈ʳ (∘-distribʳ-tuple (interp-ctx J)) ⟩
                                                 (interp-oper J f ∘
                                                   tuple (interp-ctx J) (oper-arity f) (λ x → interp-term J (xs x)) ∘
                                                   π₂) ≈⟨ sym-assoc ⟩
                                                 ((interp-oper J f ∘
                                                    tuple (interp-ctx J) (oper-arity f) (λ x → interp-term J (xs x)))
                                                   ∘ π₂) ∎


module imper-repeat where

open import lib
open import eq-reasoning

data Singleton {a} {A : Set a} (x : A) : Set a where
  _with≡_ : (y : A) → x ≡ y → Singleton x

inspect : ∀ {a} {A : Set a} (x : A) → Singleton x
inspect x = x with≡ refl

-- Unicode notes. I use:
--   \Mix, \Mie, \MiF etc for meta-variables 𝑥, 𝑒, 𝐹 etc.
--   \mapsto for variable frame bindings and update.
--   \| for the frame update operation.
--   \|- turnstile ⊢ is used for the semantics relations.
--   (\|-n for its negation ⊬)
--   \d= for code literal values e.g. ⇓ 42 and ⇓true
--   The down arrow is also used for the eval relation.
--   \u= for code variable lookups like ⇑ "x" and ⇑ "y"
--   superscripts of items with \^e as ᵉ, \c^c as ᶜ
--   ↩ for sequencing. This is \lefthookarrow.
--   ∷= which is \:: followed by =

--
-- variable identifiers
--
Id : Set
Id = string

_=Id_ : Id → Id → 𝔹
_=Id_ = _=string_

--
-- values (just natural numbers here)
--
Val : Set
Val = ℕ

--
-- value and variable expressions
--
data Expn : Set where
  ⇓_ : Val → Expn
  ⇑_ : Id → Expn
  _+ᵉ_ : Expn → Expn → Expn
  _-ᵉ_ : Expn → Expn → Expn
  _*ᵉ⇓_ : Expn → Val → Expn

--
-- conditions on values and variables
--
data Cond : Set where
  ⇓true : Cond
  ⇓false : Cond
  _∧ᶜ_ : Cond → Cond → Cond
  _∨ᶜ_ : Cond → Cond → Cond
  ¬ᶜ_ : Cond → Cond
  [_<ᶜ_] : Expn → Expn → Cond
  [_=ᶜ_] : Expn → Expn → Cond

--
-- stack frames containing variable bindings
--
Frm : Set
Frm = 𝕃 (Id × Val)

[_↦_] : Id → Val → Frm
[ 𝑥 ↦ 𝑣 ] = [(𝑥 , 𝑣)]

[-↦0] : Frm
[-↦0] = []

--
-- program statements that transform a frame
--
data Stmt : Set where
  skip : Stmt
  _∷=_ : Id → Expn → Stmt
  _↩_ : Stmt → Stmt → Stmt
  if_then_else_end : Cond → Stmt → Stmt → Stmt
  by_repeat_end : Id → Stmt → Stmt
  returns_ : Expn → Stmt

infix 10 ⇑_ ⇓_
infix 9 _*ᵉ⇓_
infixl 8 _+ᵉ_ _-ᵉ_
infix 7 ¬ᶜ_
infixl 6 _∨ᶜ_
infixl 5 _∧ᶜ_
infix 4 _∷=_
infix 3 returns_
infixl 2 _↩_

--
-- functional SEMANTICS of frames
--

_∥_ : Frm → Id → Val
[] ∥ 𝑥 = 0
((𝑦 , 𝑤) :: 𝐹) ∥ 𝑥  = if (𝑥 =Id 𝑦) then 𝑤 else (𝐹 ∥ 𝑥)

_∣_↦_ : Frm → Id → Val → Frm
[] ∣ 𝑥 ↦ 𝑣 = [ 𝑥 ↦ 𝑣 ]
((𝑦 , 𝑤) :: 𝐹) ∣ 𝑥 ↦ 𝑣
          = if (𝑥 =Id 𝑦)
              then (𝑦 , 𝑣) :: 𝐹
              else (𝑦 , 𝑤) :: (𝐹 ∣ 𝑥 ↦ 𝑣)

--
-- functional SEMANTICS of expressions
--
⟦_⟧ᵉ_ : Expn → Frm → Val
⟦ ⇓ 𝑣 ⟧ᵉ _ = 𝑣
⟦ ⇑ 𝑥 ⟧ᵉ 𝐹 = 𝐹 ∥ 𝑥
⟦ 𝑒₁ +ᵉ 𝑒₂ ⟧ᵉ 𝐹 = (⟦ 𝑒₁ ⟧ᵉ 𝐹) + (⟦ 𝑒₂ ⟧ᵉ 𝐹)
⟦ 𝑒₁ -ᵉ 𝑒₂ ⟧ᵉ 𝐹 = (⟦ 𝑒₁ ⟧ᵉ 𝐹) ∸ (⟦ 𝑒₂ ⟧ᵉ 𝐹)
⟦ 𝑒₁ *ᵉ⇓ 𝑣₂ ⟧ᵉ 𝐹 = (⟦ 𝑒₁ ⟧ᵉ 𝐹) * 𝑣₂

--
-- functional SEMANTICS of conditions
--
⟦_⟧ᶜ_ : Cond → Frm → 𝔹
⟦ ⇓true ⟧ᶜ _ = tt
⟦ ⇓false ⟧ᶜ _ = ff
⟦ 𝒸₁ ∧ᶜ 𝒸₂ ⟧ᶜ 𝐹 = (⟦ 𝒸₁ ⟧ᶜ 𝐹) && (⟦ 𝒸₂ ⟧ᶜ 𝐹)
⟦ 𝒸₁ ∨ᶜ 𝒸₂ ⟧ᶜ 𝐹 = (⟦ 𝒸₁ ⟧ᶜ 𝐹) || (⟦ 𝒸₂ ⟧ᶜ 𝐹)
⟦ ¬ᶜ 𝒸 ⟧ᶜ 𝐹 = ~ (⟦ 𝒸 ⟧ᶜ 𝐹)
⟦ [ 𝑒₁ <ᶜ 𝑒₂ ] ⟧ᶜ 𝐹 = (⟦ 𝑒₁ ⟧ᵉ 𝐹) < (⟦ 𝑒₂ ⟧ᵉ 𝐹)
⟦ [ 𝑒₁ =ᶜ 𝑒₂ ] ⟧ᶜ 𝐹 = (⟦ 𝑒₁ ⟧ᵉ 𝐹) =ℕ (⟦ 𝑒₂ ⟧ᵉ 𝐹)

--
-- functional SEMANTICS of program execution
--
⟦_∣_∷=_…0⟧ˢ_ : Stmt → Id → ℕ → Frm → Frm
⟦_⟧ˢ_ : Stmt → Frm → Frm
⟦ 𝑠 ∣ 𝑥 ∷= 0 …0⟧ˢ 𝐹 = 𝐹
⟦ 𝑠 ∣ 𝑥 ∷= (suc 𝑛) …0⟧ˢ 𝐹
                  = ⟦ 𝑠 ∣ 𝑥 ∷= 𝑛 …0⟧ˢ ((⟦ 𝑠 ⟧ˢ 𝐹) ∣ 𝑥 ↦ 𝑛)
⟦ skip ⟧ˢ 𝐹 = 𝐹
⟦ 𝑥 ∷= 𝑒 ⟧ˢ 𝐹 = (𝐹 ∣ 𝑥 ↦ (⟦ 𝑒 ⟧ᵉ 𝐹))
⟦ 𝑠₁ ↩ 𝑠₂ ⟧ˢ 𝐹 = (⟦ 𝑠₂ ⟧ˢ (⟦ 𝑠₁ ⟧ˢ 𝐹))
⟦ if 𝒸 then 𝑠₁ else 𝑠₂ end ⟧ˢ 𝐹 = if (⟦ 𝒸 ⟧ᶜ 𝐹) then (⟦ 𝑠₁ ⟧ˢ 𝐹) else (⟦ 𝑠₂ ⟧ˢ 𝐹)
⟦ by 𝑥 repeat 𝑠 end ⟧ˢ 𝐹 = ⟦ 𝑠 ∣ 𝑥 ∷= (⟦ ⇑ 𝑥 ⟧ᵉ 𝐹) …0⟧ˢ 𝐹
⟦ returns 𝑒 ⟧ˢ 𝐹 = 𝐹 ∣ "retval" ↦ (⟦ 𝑒 ⟧ᵉ 𝐹)

--
-- SEMANTICS of stack bindings as a relation
--
infixl 7 _⊢ᶠ_↦_
infixl 5 _∣_↦_
infixl 4 _⊢ᵉ_⇓_
infixl 3 _⊢ᶜ_ _⊬ᶜ_ -- _↦_

data _⊢ᶠ_↦_ : Frm → Id → Val → Set where

  var-undef : ∀ {𝑥 : Id}
              ----------------
              → [] ⊢ᶠ 𝑥 ↦ 0

  var-match : ∀ {𝑥 𝑦 : Id} {𝐹 : Frm} {𝑤 : Val}
              → (𝑥 =string 𝑦) ≡ tt
              ---------------------------
              → ((𝑦 , 𝑤) :: 𝐹) ⊢ᶠ 𝑥 ↦ 𝑤

  var-mismatch : ∀ {𝑥 𝑦 : Id} {𝐹 : Frm} {𝑣 𝑤 : Val}
                 → (𝑥 =string 𝑦) ≡ ff
                 → 𝐹 ⊢ᶠ 𝑥 ↦ 𝑣
                 -------------------------
                 → ((𝑦 , 𝑤) :: 𝐹) ⊢ᶠ 𝑥 ↦ 𝑣

if-tt-then : ∀{A : Set} {b : 𝔹} {a1 a2 : A}
    → b ≡ tt → if b then a1 else a2 ≡ a1
if-tt-then{A}{b}{a1}{a2} b≡tt =
  begin
    if b then a1 else a2
  ≡⟨ cong3 if_then_else_ b≡tt refl refl ⟩
    if tt then a1 else a2
  ≡⟨ refl ⟩
    a1
  ∎

postulate
  if-ff-then : ∀{A : Set}{b : 𝔹}{a1 a2 : A}
    → b ≡ ff → if b then a1 else a2 ≡ a2

var-thm-fwd : ∀{x : Id}{F : Frm}{v : Val}
  → F ⊢ᶠ x ↦ v → F ∥ x ≡ v
var-thm-fwd{x}{[]}{0} var-undef =
  begin
    [] ∥ x
  ≡⟨ refl ⟩
    0
  ∎
var-thm-fwd (var-match{x}{y}{F}{w} x≡y) =
  begin
    ((y , w) :: F) ∥ x
  ≡⟨ refl ⟩
    if (x =Id y) then w else (F ∥ x)
  ≡⟨ if-tt-then x≡y ⟩
    w
  ∎
var-thm-fwd (var-mismatch{x}{y}{F}{v}{w} x≢y x↦v) =
  let
    F∥x≡v : F ∥ x ≡ v
    F∥x≡v = var-thm-fwd x↦v
  in begin
    ((y , w) :: F) ∥ x
  ≡⟨ refl ⟩
    if (x =Id y) then w else (F ∥ x)
  ≡⟨ if-ff-then x≢y ⟩
    F ∥ x
  ≡⟨ F∥x≡v ⟩
    v
  ∎

var-thm-rev : ∀{x : Id}{F : Frm}{v : Val}
  → F ∥ x ≡ v → F ⊢ᶠ x ↦ v
var-thm-rev{x}{[]}{v} []∥x≡v =
  let v≡0 : v ≡ 0
      v≡0 = begin
             v
            ≡⟨ sym []∥x≡v ⟩
             [] ∥ x
            ≡⟨ refl ⟩
             0
            ∎
   in cong-pred (λ xxx → [] ⊢ᶠ x ↦ xxx) (sym v≡0) var-undef
var-thm-rev{x}{(y , w) :: F}{v} y,w::F∥x≡v
 with inspect (x =string y)
... | tt with≡ same =
          let v≡w : v ≡ w
              v≡w = begin
                      v
                    ≡⟨ sym y,w::F∥x≡v ⟩
                      ((y , w) :: F) ∥ x
                    ≡⟨ refl ⟩
                      if x =string y then w else F ∥ x
                    ≡⟨ cong3 if_then_else_ same refl refl ⟩
                      if tt then w else F ∥ x
                    ≡⟨ refl ⟩
                      w
                    ∎
           in cong-pred (λ xxx → ((y , w) :: F) ⊢ᶠ x ↦ xxx) (sym v≡w) (var-match same)
... | ff with≡ diff =
          let v≡F∥x : v ≡ F ∥ x
              v≡F∥x = begin
                      v
                    ≡⟨ sym y,w::F∥x≡v ⟩
                      ((y , w) :: F) ∥ x
                    ≡⟨ refl ⟩
                      if x =string y then w else F ∥ x
                    ≡⟨ cong3 if_then_else_ diff refl refl ⟩
                      if ff then w else F ∥ x
                    ≡⟨ refl ⟩
                      F ∥ x
                    ∎
           in (var-mismatch diff (var-thm-rev (sym v≡F∥x)))

--
-- SEMANTICS of expression evaluation as a relation
--

data _⊢ᵉ_⇓_ : Frm → Expn → Val → Set where

  e-val : ∀ {𝑣 : Val} {𝐹 : Frm}
            ----------------
            → 𝐹 ⊢ᵉ (⇓ 𝑣) ⇓ 𝑣

  e-var : ∀ {𝑥 : Id} {𝐹 : Frm} {𝑣 : Val}
          → 𝐹 ⊢ᶠ 𝑥 ↦ 𝑣
          ---------------
          → 𝐹 ⊢ᵉ (⇑ 𝑥) ⇓ 𝑣

  e-add : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
          → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
          → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
          ---------------------------
          → 𝐹 ⊢ᵉ (𝑒₁ +ᵉ 𝑒₂) ⇓ (𝑣₁ + 𝑣₂)

  e-sub : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
          → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
          → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
          ---------------------------
          → 𝐹 ⊢ᵉ (𝑒₁ -ᵉ 𝑒₂) ⇓ (𝑣₁ ∸ 𝑣₂)

  e-scale : ∀ {𝑒₁ : Expn} {𝑣₁ 𝑣₂ : Val} {𝐹 : Frm}
            → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
            ---------------------------
            → 𝐹 ⊢ᵉ ( 𝑒₁ *ᵉ⇓ 𝑣₂) ⇓ (𝑣₁ * 𝑣₂)

e-thm-fwd : ∀{𝑒 : Expn}{𝐹 : Frm}{𝑣 : Val}
            → (𝐹 ⊢ᵉ 𝑒 ⇓ 𝑣) → ((⟦ 𝑒 ⟧ᵉ 𝐹) ≡ 𝑣)
e-thm-fwd (e-val{v}{F}) =
  begin
    ⟦ ⇓ v ⟧ᵉ F
  ≡⟨ refl ⟩
    v
  ∎
e-thm-fwd (e-var{x}{F}{v} x↦v) =
  begin
    ⟦ ⇑ x ⟧ᵉ F
  ≡⟨ var-thm-fwd x↦v ⟩
    v
  ∎
e-thm-fwd (e-add{e1}{e2}{F}{v1}{v2} e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧≡v2 = e-thm-fwd e2⇓v2
  in begin
    ⟦ e1 +ᵉ e2 ⟧ᵉ F
  ≡⟨ refl ⟩
    ⟦ e1 ⟧ᵉ F + ⟦ e2 ⟧ᵉ F
  ≡⟨ cong2 _+_ ⟦e1⟧≡v1 ⟦e2⟧≡v2 ⟩
    v1 + v2
  ∎
e-thm-fwd (e-sub{e1}{e2}{F}{v1}{v2} e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧≡v2 = e-thm-fwd e2⇓v2
  in begin
    ⟦ e1 -ᵉ e2 ⟧ᵉ F
  ≡⟨ refl ⟩
    ⟦ e1 ⟧ᵉ F ∸ ⟦ e2 ⟧ᵉ F
  ≡⟨ cong2 _∸_ ⟦e1⟧≡v1 ⟦e2⟧≡v2 ⟩
    v1 ∸ v2
  ∎
e-thm-fwd (e-scale{e1}{v1}{v2}{F} e1⇓v1) =
  let
    ⟦e1⟧≡v1 = e-thm-fwd e1⇓v1
  in begin
    ⟦ e1 *ᵉ⇓ v2 ⟧ᵉ F
  ≡⟨ refl ⟩
    ⟦ e1 ⟧ᵉ F * v2
  ≡⟨ cong2 _*_ ⟦e1⟧≡v1 refl ⟩
    v1 * v2
  ∎

e-thm-rev : ∀{𝑒 : Expn}{𝐹 : Frm}{𝑣 : Val}
  → ((⟦ 𝑒 ⟧ᵉ 𝐹) ≡ 𝑣) → (𝐹 ⊢ᵉ 𝑒 ⇓ 𝑣)
e-thm-rev{e}{F}{v} ⟦e⟧F≡v
    with e
...    | ⇓ w = cong-pred (λ xxx → F ⊢ᵉ (⇓ w) ⇓ xxx) ⟦e⟧F≡v e-val
...    | ⇑ x = let v≡F∥x : v ≡ F ∥ x
                   v≡F∥x = begin
                             v
                           ≡⟨ sym ⟦e⟧F≡v ⟩
                             ⟦ ⇑ x ⟧ᵉ F
                           ≡⟨ refl ⟩
                             F ∥ x
                           ∎
                in  e-var (var-thm-rev (sym v≡F∥x))
...    | e1 +ᵉ e2 = {!!}
...    | e1 -ᵉ e2 = {!!}
...    | e1 *ᵉ⇓ v2 = {!!}

--
-- SEMANTICS of conditions as a decidable relation
--

data _⊢ᶜ_ : Frm → Cond → Set
data _⊬ᶜ_ : Frm → Cond → Set

data _⊢ᶜ_ where

  c-tt :  ∀ {𝐹 : Frm}
          -----------
          → 𝐹 ⊢ᶜ ⇓true

  c-and : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
          → 𝐹 ⊢ᶜ 𝒸₁
          → 𝐹 ⊢ᶜ 𝒸₂
          -----------------
          → 𝐹 ⊢ᶜ (𝒸₁ ∧ᶜ 𝒸₂)

  c-or₁ : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
          → 𝐹 ⊢ᶜ 𝒸₁
          ---------------
          → 𝐹 ⊢ᶜ (𝒸₁ ∨ᶜ 𝒸₂)

  c-or₂ : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
          → 𝐹 ⊢ᶜ 𝒸₂
          ----------------
          → 𝐹 ⊢ᶜ (𝒸₁ ∨ᶜ 𝒸₂)

  c-less : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
           → 𝑣₁ < 𝑣₂ ≡ tt
           → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
           → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
           -------------------
           → 𝐹 ⊢ᶜ [ 𝑒₁ <ᶜ 𝑒₂ ]

  c-eq : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
           → 𝑣₁ =ℕ 𝑣₂ ≡ tt
           → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
           → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
           -------------------
           → 𝐹 ⊢ᶜ [ 𝑒₁ =ᶜ 𝑒₂ ]

  c-not : ∀ {𝒸 : Cond} {𝐹 : Frm}
          → 𝐹 ⊬ᶜ 𝒸
          -------------
          → 𝐹 ⊢ᶜ (¬ᶜ 𝒸)

data _⊬ᶜ_ where

  ~c-ff :  ∀ {𝐹 : Frm}
           --------------
           → 𝐹 ⊬ᶜ ⇓false

  ~c-or : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
          → 𝐹 ⊬ᶜ 𝒸₁
          → 𝐹 ⊬ᶜ 𝒸₂
          ----------------
          → 𝐹 ⊬ᶜ (𝒸₁ ∨ᶜ 𝒸₂)

  ~c-and₁ : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
            → 𝐹 ⊬ᶜ 𝒸₁
            -----------------
            → 𝐹 ⊬ᶜ (𝒸₁ ∧ᶜ 𝒸₂)

  ~c-and₂ : ∀ {𝒸₁ 𝒸₂ : Cond} {𝐹 : Frm}
            → 𝐹 ⊬ᶜ 𝒸₂
            -----------------
            → 𝐹 ⊬ᶜ (𝒸₁ ∧ᶜ 𝒸₂)

  ~c-eq : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
            → 𝑣₁ =ℕ 𝑣₂ ≡ ff
            → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
            → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
            -------------------
            → 𝐹 ⊬ᶜ [ 𝑒₁ =ᶜ 𝑒₂ ]

  ~c-less : ∀ {𝑒₁ 𝑒₂ : Expn} {𝐹 : Frm} {𝑣₁ 𝑣₂ : Val}
            → 𝑣₁ < 𝑣₂ ≡ ff
            → 𝐹 ⊢ᵉ 𝑒₁ ⇓ 𝑣₁
            → 𝐹 ⊢ᵉ 𝑒₂ ⇓ 𝑣₂
            -------------------
            → 𝐹 ⊬ᶜ [ 𝑒₁ <ᶜ 𝑒₂ ]

  ~c-not : ∀ {𝒸 : Cond} {𝐹 : Frm}
           → 𝐹 ⊢ᶜ 𝒸
           -------------
           → 𝐹 ⊬ᶜ (¬ᶜ 𝒸)

test3 : [] ⊢ᶜ (⇓true ∧ᶜ (¬ᶜ ⇓false))
test3 = c-and c-tt (c-not ~c-ff)

c-thm-fwd : ∀{𝒸 : Cond}{𝐹 : Frm} → 𝐹 ⊢ᶜ 𝒸 → (⟦ 𝒸 ⟧ᶜ 𝐹 ≡ tt)
~c-thm-fwd : ∀{𝒸 : Cond}{𝐹 : Frm} → 𝐹 ⊬ᶜ 𝒸 → (⟦ 𝒸 ⟧ᶜ 𝐹 ≡ ff)
c-thm-fwd (c-tt{F}) =
  begin
    ⟦ ⇓true ⟧ᶜ F
  ≡⟨ refl ⟩
    tt
  ∎
c-thm-fwd (c-and{c1}{c2}{F} dat1 dat2) =
  let
    ⟦c1⟧F≡tt : ⟦ c1 ⟧ᶜ F ≡ tt
    ⟦c1⟧F≡tt = c-thm-fwd dat1
    ⟦c2⟧F≡tt : ⟦ c2 ⟧ᶜ F ≡ tt
    ⟦c2⟧F≡tt = c-thm-fwd dat2
  in begin
    ⟦ c1 ∧ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) && (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _&&_ ⟦c1⟧F≡tt ⟦c2⟧F≡tt ⟩
    tt && tt
  ≡⟨ refl ⟩
    tt
  ∎
c-thm-fwd (c-or₁{c1}{c2}{F} dat1) =
  let
    ⟦c1⟧F≡tt : ⟦ c1 ⟧ᶜ F ≡ tt
    ⟦c1⟧F≡tt = c-thm-fwd dat1
  in begin
    ⟦ c1 ∨ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) || (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _||_ ⟦c1⟧F≡tt refl ⟩
    tt || (⟦ c2 ⟧ᶜ F)
  ≡⟨ refl ⟩
    tt
  ∎
c-thm-fwd (c-or₂{c1}{c2}{F} dat2) =
  let
    ⟦c2⟧F≡tt : ⟦ c2 ⟧ᶜ F ≡ tt
    ⟦c2⟧F≡tt = c-thm-fwd dat2
  in begin
    ⟦ c1 ∨ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) || (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _||_ refl ⟦c2⟧F≡tt ⟩
    (⟦ c1 ⟧ᶜ F) || tt
  ≡⟨ ||-tt (⟦ c1 ⟧ᶜ F) ⟩
    tt
  ∎
c-thm-fwd (c-less{e1}{e2}{F}{v1}{v2} v1<v2 e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧F≡v1 : ⟦ e1 ⟧ᵉ F ≡ v1
    ⟦e1⟧F≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧F≡v2 : ⟦ e2 ⟧ᵉ F ≡ v2
    ⟦e2⟧F≡v2 = e-thm-fwd e2⇓v2
  in
    begin
      ⟦ [ e1 <ᶜ e2 ] ⟧ᶜ F
    ≡⟨ refl ⟩
      ⟦ e1 ⟧ᵉ F < ⟦ e2 ⟧ᵉ F
    ≡⟨ cong2 _<_ ⟦e1⟧F≡v1 ⟦e2⟧F≡v2 ⟩
      v1 < v2
    ≡⟨ v1<v2 ⟩
     tt
   ∎
c-thm-fwd (c-eq{e1}{e2}{F}{v1}{v2} v1≡v2 e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧F≡v1 : ⟦ e1 ⟧ᵉ F ≡ v1
    ⟦e1⟧F≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧F≡v2 : ⟦ e2 ⟧ᵉ F ≡ v2
    ⟦e2⟧F≡v2 = e-thm-fwd e2⇓v2
  in begin
    ⟦ [ e1 =ᶜ e2 ] ⟧ᶜ F
  ≡⟨ refl ⟩
    ⟦ e1 ⟧ᵉ F =ℕ ⟦ e2 ⟧ᵉ F
  ≡⟨ cong2 _=ℕ_ ⟦e1⟧F≡v1 ⟦e2⟧F≡v2 ⟩
    v1 =ℕ v2
  ≡⟨ v1≡v2 ⟩
   tt
  ∎
c-thm-fwd (c-not{c}{F} dat) =
  let
    ⟦c⟧F≡ff : ⟦ c ⟧ᶜ F ≡ ff
    ⟦c⟧F≡ff = ~c-thm-fwd dat
  in begin
  begin
    ⟦ ¬ᶜ c ⟧ᶜ F
  ≡⟨ refl ⟩
    ~ ⟦ c ⟧ᶜ F
  ≡⟨ cong ~_ ⟦c⟧F≡ff ⟩
    ~ ff
  ≡⟨ refl ⟩
    tt
  ∎
~c-thm-fwd (~c-ff{F}) =
  begin
    ⟦ ⇓false ⟧ᶜ F
  ≡⟨ refl ⟩
    ff
  ∎
~c-thm-fwd (~c-or{c1}{c2}{F} dat1 dat2) =
  let
    ⟦c1⟧F≡ff : ⟦ c1 ⟧ᶜ F ≡ ff
    ⟦c1⟧F≡ff = ~c-thm-fwd dat1
    ⟦c2⟧F≡ff : ⟦ c2 ⟧ᶜ F ≡ ff
    ⟦c2⟧F≡ff = ~c-thm-fwd dat2
  in begin
    ⟦ c1 ∨ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) || (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _||_ ⟦c1⟧F≡ff ⟦c2⟧F≡ff ⟩
    ff || ff
  ≡⟨ refl ⟩
    ff
  ∎
~c-thm-fwd (~c-and₁{c1}{c2}{F} dat1) =
  let
    ⟦c1⟧F≡ff : ⟦ c1 ⟧ᶜ F ≡ ff
    ⟦c1⟧F≡ff = ~c-thm-fwd dat1
  in begin
    ⟦ c1 ∧ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) && (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _&&_ ⟦c1⟧F≡ff refl ⟩
    ff && (⟦ c2 ⟧ᶜ F)
  ≡⟨ refl ⟩
    ff
  ∎
~c-thm-fwd (~c-and₂{c1}{c2}{F} dat2) =
  let
    ⟦c2⟧F≡ff : ⟦ c2 ⟧ᶜ F ≡ ff
    ⟦c2⟧F≡ff = ~c-thm-fwd dat2
  in begin
  begin
    ⟦ c1 ∧ᶜ c2 ⟧ᶜ F
  ≡⟨ refl ⟩
    (⟦ c1 ⟧ᶜ F) && (⟦ c2 ⟧ᶜ F)
  ≡⟨ cong2 _&&_ refl ⟦c2⟧F≡ff ⟩
    (⟦ c1 ⟧ᶜ F) && ff
  ≡⟨ &&-ff (⟦ c1 ⟧ᶜ F) ⟩
    ff
  ∎
~c-thm-fwd (~c-less{e1}{e2}{F}{v1}{v2} v1≮v2 e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧F≡v1 : ⟦ e1 ⟧ᵉ F ≡ v1
    ⟦e1⟧F≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧F≡v2 : ⟦ e2 ⟧ᵉ F ≡ v2
    ⟦e2⟧F≡v2 = e-thm-fwd e2⇓v2
  in
    begin
      ⟦ [ e1 <ᶜ e2 ] ⟧ᶜ F
    ≡⟨ refl ⟩
      ⟦ e1 ⟧ᵉ F < ⟦ e2 ⟧ᵉ F
    ≡⟨ cong2 _<_ ⟦e1⟧F≡v1 ⟦e2⟧F≡v2 ⟩
      v1 < v2
    ≡⟨ v1≮v2 ⟩
     ff
   ∎
~c-thm-fwd (~c-eq{e1}{e2}{F}{v1}{v2} v1≢v2 e1⇓v1 e2⇓v2) =
  let
    ⟦e1⟧F≡v1 : ⟦ e1 ⟧ᵉ F ≡ v1
    ⟦e1⟧F≡v1 = e-thm-fwd e1⇓v1
    ⟦e2⟧F≡v2 : ⟦ e2 ⟧ᵉ F ≡ v2
    ⟦e2⟧F≡v2 = e-thm-fwd e2⇓v2
  in begin
    ⟦ [ e1 =ᶜ e2 ] ⟧ᶜ F
  ≡⟨ refl ⟩
    ⟦ e1 ⟧ᵉ F =ℕ ⟦ e2 ⟧ᵉ F
  ≡⟨ cong2 _=ℕ_ ⟦e1⟧F≡v1 ⟦e2⟧F≡v2 ⟩
    v1 =ℕ v2
  ≡⟨ v1≢v2 ⟩
   ff
  ∎
~c-thm-fwd (~c-not{c}{F} ⊢c) =
  begin
    ⟦ ¬ᶜ c ⟧ᶜ F
  ≡⟨ refl ⟩
    ~ ⟦ c ⟧ᶜ F
  ≡⟨ cong ~_ (c-thm-fwd ⊢c) ⟩
    ~ tt
  ≡⟨ refl ⟩
    ff
  ∎

-- These can probably be shown just by using
-- the contrapositives of c-thm-fwd and ~c-thm-fwd
postulate
  c-thm-rev : ∀{𝒸 : Cond}{𝐹 : Frm} → (⟦ 𝒸 ⟧ᶜ 𝐹 ≡ tt) → 𝐹 ⊢ᶜ 𝒸
  ~c-thm-rev : ∀{𝒸 : Cond}{𝐹 : Frm} → (⟦ 𝒸 ⟧ᶜ 𝐹 ≡ ff) → 𝐹 ⊬ᶜ 𝒸

--
-- SEMANTICS of program statements
-- as a state transformation relation
--

data _=[_]⇒_ : Frm → Stmt → Frm → Set where

  s-skip : ∀ {𝐹 : Frm}
    --------------
    → 𝐹 =[ skip ]⇒ 𝐹

  s-assign : ∀ {𝑥 : Id} {𝑒 : Expn} {𝐹 : Frm}  {𝑣 : Val}
    → 𝐹 ⊢ᵉ 𝑒 ⇓ 𝑣
    ---------------------------
    → 𝐹 =[ 𝑥 ∷= 𝑒 ]⇒ (𝐹 ∣ 𝑥 ↦ 𝑣)

  s-seq : ∀ {𝑠₁ 𝑠₂ : Stmt} {𝐹₀ 𝐹₁ 𝐹₂ : Frm}
    → 𝐹₀ =[ 𝑠₁ ]⇒ 𝐹₁
    → 𝐹₁ =[ 𝑠₂ ]⇒ 𝐹₂
    -------------------
    → 𝐹₀ =[ 𝑠₁ ↩ 𝑠₂ ]⇒ 𝐹₂

  s-if-then : ∀ {𝒸 : Cond} {𝑠₁ 𝑠₂ : Stmt} {𝐹 𝐹' : Frm}
    → 𝐹 ⊢ᶜ 𝒸
    → 𝐹 =[ 𝑠₁ ]⇒ 𝐹'
    → 𝐹 =[ 𝑠₂ ]⇒ 𝐹'
    ------------------------------------
    → 𝐹 =[ if 𝒸 then 𝑠₁ else 𝑠₂ end ]⇒ 𝐹'

  s-if-else : ∀ {𝒸 : Cond} {𝑠₁ 𝑠₂ : Stmt} {𝐹 𝐹' : Frm}
    → 𝐹 ⊬ᶜ 𝒸
    → 𝐹 =[ 𝑠₂ ]⇒ 𝐹'
    ------------------------------------
    → 𝐹 =[ if 𝒸 then 𝑠₁ else 𝑠₂ end ]⇒ 𝐹'

  s-repeat-0 : ∀ {𝑠 : Stmt} {𝑥 : Id} {𝐹 : Frm}
     → 𝐹 ⊢ᶠ 𝑥 ↦ 0
     -----------------------------
     → 𝐹 =[ by 𝑥 repeat 𝑠 end ]⇒ 𝐹

  s-repeat-suc : ∀ {𝑛 : ℕ} {𝑠 : Stmt} {𝑥 : Id} {𝐹 𝐹' : Frm}
    → 𝐹 ⊢ᶠ 𝑥 ↦ suc 𝑛
    → 𝐹 =[ 𝑠 ↩ 𝑥 ∷= (⇓ 𝑛) ↩ by 𝑥 repeat 𝑠 end ]⇒ 𝐹'
    ----------------------------------------------
    → 𝐹 =[ by 𝑥 repeat 𝑠 end ]⇒ 𝐹'

  --
  -- A lil cheat: "returns" is just assign; doesn't exit

  s-return : ∀ {𝑒 : Expn} {𝐹 : Frm}  {𝑣 : Val}
    → 𝐹 ⊢ᵉ 𝑒 ⇓ 𝑣
    -------------------------------------
    → 𝐹 =[ returns 𝑒 ]⇒ (𝐹 ∣ "retval" ↦ 𝑣)

arg1 : Id
arg1 = "arg1"

arg2 : Id
arg2 = "arg2"

retval : Id
retval = "retval"

W : Id
W = "w"

X : Id
X = "x"

Y : Id
Y = "y"

Z : Id
Z = "z"

pgm0 : Stmt
pgm0 = X ∷= ⇓ 3 ↩
       Y ∷= ⇓ 1 ↩
       Y ∷= ⇑ Y *ᵉ⇓ 2

pgm1 : Stmt
pgm1 = X ∷= ⇓ 3 ↩
       Y ∷= ⇓ 1 ↩
       by X repeat
         Y ∷= ⇑ Y *ᵉ⇓ 2
       end

Z∷=X*Y = W ∷= ⇑ X ↩
         Z ∷= ⇓ 0 ↩
         by W repeat
           Z ∷= ⇑ Z +ᵉ ⇑ Y
         end

pgm2 = X ∷= ⇓ 3 ↩
       Y ∷= ⇓ 1 ↩
       by X repeat
         Z∷=X*Y ↩
         Y ∷= ⇑ Z
       end

fact-pgm : Stmt
fact-pgm =
  X ∷= ⇑ arg1 ↩
  Y ∷= ⇓ 1 ↩
  by X repeat
    Z∷=X*Y ↩
    Y ∷= ⇑ Z
  end ↩
  returns ⇑ Y

min-pgm : Stmt
min-pgm = if [ ⇑ arg2 <ᶜ ⇑ arg1 ] then
            X ∷= ⇑ arg1 ↩
            arg1 ∷= ⇑ arg2 ↩
            arg2 ∷= ⇑ X
          else
            skip
          end

result1 = ⟦ pgm1 ⟧ˢ [-↦0]
result2 = ⟦ pgm2 ⟧ˢ [-↦0]

[➊↦_] : Val → Frm
[➊↦ 𝑣 ] = [-↦0] ∣ arg1 ↦ 𝑣

[➊↦_,➋↦_] : Val →  Val → Frm
[➊↦ 𝑣₁ ,➋↦ 𝑣₂ ] = (([-↦0] ∣ arg1 ↦ 𝑣₁) ∣ arg2 ↦ 𝑣₂ )

frame6 = ((((( [➊↦ 3 ] ∣ X ↦ 0) ∣ Y ↦ 6) ∣ W ↦ 0) ∣ Z ↦ 6) ∣ retval ↦ 6)
postulate
  test6 : [➊↦ 3 ] =[ fact-pgm ]⇒ frame6

exec : Stmt → Frm
exec 𝑠 = ⟦ 𝑠 ⟧ˢ [-↦0]

exec1 : Stmt → Val → Frm
exec1 𝑠 𝑣₁ = ⟦ 𝑠 ⟧ˢ [➊↦ 𝑣₁ ]

exec2 : Stmt → Val → Val → Frm
exec2 𝑠 𝑣₁ 𝑣₂ = ⟦ 𝑠 ⟧ˢ [➊↦ 𝑣₁ ,➋↦ 𝑣₂ ]

test7 = exec2 min-pgm 7 5

test7a : (test7 ∥ arg1) ≡ 5
test7a = refl

test7b : (test7 ∥ arg2) ≡ 7
test7b = refl

postulate
  s-thm : ∀ {𝑠 : Stmt } {𝐹 : Frm} → 𝐹 =[ 𝑠 ]⇒ (⟦ 𝑠 ⟧ˢ 𝐹)

postulate
  fact-thm : ∀ {n : ℕ} {𝐹 : Frm} → [➊↦ n ] =[ fact-pgm ]⇒ 𝐹 → 𝐹 ⊢ᶠ retval ↦ (factorial n)


module Haskell.Prim.Absurd where

open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Unit
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_; absurd to absurdP)
open import Agda.Builtin.Equality

open import Haskell.Prim

private

  pattern vArg x = arg (arg-info visible relevant) x

  refute : Nat → Term
  refute i = def (quote _$_) (vArg (pat-lam (absurd-clause (vArg absurdP ∷ []) ∷ []) []) ∷ vArg (var i []) ∷ [])

  tryRefute : Nat → Term → TC ⊤
  tryRefute 0       _    = typeError (strErr "No variable of empty type found in the context" ∷ [])
  tryRefute (suc n) hole = catchTC (unify hole (refute n)) (tryRefute n hole)

absurd : Term → TC ⊤
absurd hole = do
  Γ ← getContext
  tryRefute (lengthNat Γ) hole


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

open import HoTT
open import cohomology.ChainComplex
open import cohomology.Theory
open import groups.KernelImage
open import cw.CW

module cw.cohomology.ReconstructedFirstCohomologyGroup {i : ULevel} (OT : OrdinaryTheory i) where

  open OrdinaryTheory OT
  import cw.cohomology.TipCoboundary OT as TC
  import cw.cohomology.HigherCoboundary OT as HC
  import cw.cohomology.TipAndAugment OT as TAA
  open import cw.cohomology.WedgeOfCells OT
  open import cw.cohomology.Descending OT
  open import cw.cohomology.ReconstructedCochainComplex OT
  import cw.cohomology.FirstCohomologyGroup OT as FCG
  import cw.cohomology.FirstCohomologyGroupOnDiag OT as FCGD
  import cw.cohomology.CohomologyGroupsTooHigh OT as CGTH

  private
    ≤-dec-has-all-paths : {m n : ℕ} → has-all-paths (Dec (m ≤ n))
    ≤-dec-has-all-paths = prop-has-all-paths (Dec-level ≤-is-prop)

  private
    abstract
      first-cohomology-group-descend : ∀ {n} (⊙skel : ⊙Skeleton {i} (3 + n))
        →  cohomology-group (cochain-complex ⊙skel) 1
        == cohomology-group (cochain-complex (⊙cw-init ⊙skel)) 1
      first-cohomology-group-descend {n = O} ⊙skel
        = ap2 (λ δ₁ δ₂ → Ker/Im δ₂ δ₁ (CXₙ/Xₙ₋₁-is-abelian (⊙cw-take (lteSR lteS) ⊙skel) 1))
            (coboundary-first-template-descend-from-far {n = 2} ⊙skel (ltSR ltS) ltS)
            (coboundary-higher-template-descend-from-one-above ⊙skel)
      first-cohomology-group-descend {n = S n} ⊙skel -- n = S n
        = ap2 (λ δ₁ δ₂ → Ker/Im δ₂ δ₁ (CXₙ/Xₙ₋₁-is-abelian (⊙cw-take (≤-+-l 1 (lteSR $ lteSR $ inr (O<S n))) ⊙skel) 1))
            (coboundary-first-template-descend-from-far  {n = 3 + n} ⊙skel (ltSR (ltSR (O<S n))) (<-+-l 1 (ltSR (O<S n))))
            (coboundary-higher-template-descend-from-far {n = 3 + n} ⊙skel (<-+-l 1 (ltSR (O<S n))) (<-+-l 2 (O<S n)))

      first-cohomology-group-β : ∀ (⊙skel : ⊙Skeleton {i} 2)
        →  cohomology-group (cochain-complex ⊙skel) 1
        == Ker/Im
            (HC.cw-co∂-last ⊙skel)
            (TC.cw-co∂-head (⊙cw-init ⊙skel))
            (CXₙ/Xₙ₋₁-is-abelian (⊙cw-init ⊙skel) 1)
      first-cohomology-group-β ⊙skel
        = ap2 (λ δ₁ δ₂ → Ker/Im δ₂ δ₁ (CXₙ/Xₙ₋₁-is-abelian (⊙cw-init ⊙skel) 1))
            ( coboundary-first-template-descend-from-two ⊙skel
            ∙ coboundary-first-template-β (⊙cw-init ⊙skel))
            (coboundary-higher-template-β ⊙skel)

      first-cohomology-group-β-one-below : ∀ (⊙skel : ⊙Skeleton {i} 1)
        →  cohomology-group (cochain-complex ⊙skel) 1
        == Ker/Im
            (cst-hom {H = Lift-group {j = i} Unit-group})
            (TC.cw-co∂-head ⊙skel)
            (CXₙ/Xₙ₋₁-is-abelian ⊙skel 1)
      first-cohomology-group-β-one-below ⊙skel
        = ap
            (λ δ₁ → Ker/Im
              (cst-hom {H = Lift-group {j = i} Unit-group})
              δ₁ (CXₙ/Xₙ₋₁-is-abelian ⊙skel 1))
            (coboundary-first-template-β ⊙skel)

  abstract
    first-cohomology-group : ∀ {n} (⊙skel : ⊙Skeleton {i} n)
      → ⊙has-cells-with-choice 0 ⊙skel i
      → C 1 ⊙⟦ ⊙skel ⟧ ≃ᴳ cohomology-group (cochain-complex ⊙skel) 1
    first-cohomology-group {n = 0} ⊙skel ac =
      CGTH.C-cw-iso-ker/im 1 ltS (TAA.C2×CX₀ ⊙skel 0) ⊙skel ac
    first-cohomology-group {n = 1} ⊙skel ac =
          coe!ᴳ-iso (first-cohomology-group-β-one-below ⊙skel)
      ∘eᴳ FCGD.C-cw-iso-ker/im ⊙skel ac
    first-cohomology-group {n = 2} ⊙skel ac =
          coe!ᴳ-iso (first-cohomology-group-β ⊙skel)
      ∘eᴳ FCG.C-cw-iso-ker/im ⊙skel ac
    first-cohomology-group {n = S (S (S n))} ⊙skel ac =
          coe!ᴳ-iso (first-cohomology-group-descend ⊙skel)
      ∘eᴳ first-cohomology-group (⊙cw-init ⊙skel) (⊙init-has-cells-with-choice ⊙skel ac)
      ∘eᴳ C-cw-descend-at-lower ⊙skel (<-+-l 1 (O<S n)) ac


-- {-# OPTIONS -v tc.meta:30 #-}
{-# OPTIONS --sized-types #-}
module GiveSize where

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

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


{-# OPTIONS --safe --experimental-lossy-unification #-}

module Cubical.Algebra.Group.EilenbergMacLane.GroupStructure where

open import Cubical.Algebra.Group.EilenbergMacLane.Base
open import Cubical.Algebra.Group.EilenbergMacLane.WedgeConnectivity
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.AbGroup.Base

open import Cubical.Data.Nat

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Path

open import Cubical.Homotopy.Loopspace

open import Cubical.HITs.EilenbergMacLane1
open import Cubical.HITs.Truncation
  renaming (elim to trElim ; rec to trRec ; rec2 to trRec2)
open import Cubical.HITs.Susp

open import Cubical.Functions.Morphism

private
  variable ℓ : Level

module _ {G : AbGroup ℓ} where
  infixr 34 _+ₖ_
  infixr 34 _-ₖ_
  open AbGroupStr (snd G) renaming (_+_ to _+G_ ; -_ to -G_ ; +Assoc to +AssocG)

  private
    help : (n : ℕ) → n + (4 + n) ≡ (2 + n) + (2 + n)
    help n = +-suc n (3 + n) ∙ cong suc (+-suc n (suc (suc n)))

    hLevHelp : (n : ℕ) → isOfHLevel ((2 + n) + (2 + n)) (EM G (2 + n))
    hLevHelp n =
      transport (λ i → isOfHLevel (help n i) (EM G (2 + n)))
            (isOfHLevelPlus {n = 4 + n} n (isOfHLevelTrunc (4 + n)))

    helper : (g h : fst G)
      → PathP (λ i → Path (EM₁ (AbGroup→Group G))
               (emloop h i) (emloop h i)) (emloop g) (emloop g)
    helper g h =
      comm→PathP
        ((sym (emloop-comp _ h g)
          ∙∙ cong emloop (+Comm h g)
          ∙∙ emloop-comp _ g h))

  _+ₖ_ : {n : ℕ} → EM G n → EM G n → EM G n
  _+ₖ_ {n = zero} = _+G_
  _+ₖ_ {n = suc zero} =
    rec _ (isGroupoidΠ (λ _ → emsquash))
      (λ x → x)
      (λ x → funExt (looper x))
      λ g h i j x → el g h x i j
    where
    looper : fst G → (x : _) → x ≡ x
    looper g = (elimSet _ (λ _ → emsquash _ _)
                     (emloop g)
                     (helper g))

    el : (g h : fst G) (x : EM₁ (AbGroup→Group G))
      → Square (looper g x)
                (looper (g +G h) x)
                refl (looper h x)
    el g h =
      elimProp _ (λ _ → isOfHLevelPathP' 1 (emsquash _ _) _ _)
        (emcomp g h)

  _+ₖ_ {n = suc (suc n)} =
    trRec2 (isOfHLevelTrunc (4 + n))
      (wedgeConEM.fun G G (suc n) (suc n)
        (λ _ _ → hLevHelp n)
        ∣_∣ ∣_∣ refl)

  σ-EM : (n : ℕ) → EM-raw G (suc n) → Path (EM-raw G (2 + n)) ptEM-raw ptEM-raw
  σ-EM n x = merid x ∙ sym (merid ptEM-raw)

  -ₖ_ : {n : ℕ} → EM G n → EM G n
  -ₖ_ {n = zero} x = -G x
  -ₖ_ {n = suc zero} =
    rec _ emsquash
      embase
      (λ g → sym (emloop g))
      λ g h → sym (emloop-sym _ g)
            ◁ (flipSquare
                (flipSquare (emcomp (-G g) (-G h))
               ▷ emloop-sym _ h)
            ▷ (cong emloop (+Comm (-G g) (-G h)
                          ∙ sym (GroupTheory.invDistr (AbGroup→Group G) g h))
             ∙ emloop-sym _ (g +G h)))
  -ₖ_ {n = suc (suc n)} =
    map λ { north → north
          ; south → north
          ; (merid a i) → σ-EM n a (~ i)}

  _-ₖ_ : {n : ℕ} → EM G n → EM G n → EM G n
  _-ₖ_ {n = n} x y = _+ₖ_ {n = n} x (-ₖ_ {n = n} y)

  +ₖ-syntax : (n : ℕ) →  EM G n → EM G n → EM G n
  +ₖ-syntax n = _+ₖ_ {n = n}

  -ₖ-syntax : (n : ℕ) → EM G n → EM G n
  -ₖ-syntax n = -ₖ_ {n = n}

  -'ₖ-syntax : (n : ℕ) → EM G n → EM G n → EM G n
  -'ₖ-syntax n = _-ₖ_ {n = n}

  syntax +ₖ-syntax n x y = x +[ n ]ₖ y
  syntax -ₖ-syntax n x = -[ n ]ₖ x
  syntax -'ₖ-syntax n x y = x -[ n ]ₖ y

  lUnitₖ : (n : ℕ) (x : EM G n) → 0ₖ n +[ n ]ₖ x ≡ x
  lUnitₖ zero x = +IdL x
  lUnitₖ (suc zero) _ = refl
  lUnitₖ (suc (suc n)) =
    trElim (λ _ → isOfHLevelTruncPath {n = 4 + n})
      λ _ → refl

  rUnitₖ : (n : ℕ) (x : EM G n) → x +[ n ]ₖ 0ₖ n ≡ x
  rUnitₖ zero x = +IdR x
  rUnitₖ (suc zero) =
    elimSet _ (λ _ → emsquash _ _)
            refl
            λ _ _ → refl
  rUnitₖ (suc (suc n)) =
    trElim (λ _ → isOfHLevelTruncPath {n = 4 + n})
      (wedgeConEM.right G G (suc n) (suc n)
      (λ _ _ → hLevHelp n)
      ∣_∣ ∣_∣ refl)

  commₖ : (n : ℕ) (x y : EM G n) → x +[ n ]ₖ y ≡ y +[ n ]ₖ x
  commₖ zero = +Comm
  commₖ (suc zero) =
    wedgeConEM.fun G G 0 0 (λ _ _ → emsquash _ _)
      (λ x → sym (rUnitₖ 1 x))
      (rUnitₖ 1)
      refl
  commₖ (suc (suc n)) =
    elim2 (λ _ _ → isOfHLevelTruncPath {n = 4 + n})
      (wedgeConEM.fun G G _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (hLevHelp n) _ _)
      (λ x → sym (rUnitₖ (2 + n) ∣ x ∣))
      (λ x → rUnitₖ (2 + n) ∣ x ∣)
      refl)

  cong₂+₁ : (p q : typ (Ω (EM∙ G 1)))
          → cong₂ (λ x y → x +[ 1 ]ₖ y) p q ≡ p ∙ q
  cong₂+₁ p q =
      (cong₂Funct (λ x y → x +[ 1 ]ₖ y) p q)
   ∙ (λ i → (cong (λ x → rUnitₖ 1 x i) p) ∙ (cong (λ x → lUnitₖ 1 x i) q))

  cong₂+₂ : (n : ℕ) (p q : typ (Ω (EM∙ G  (suc (suc n)))))
          → cong₂ (λ x y → x +[ (2 + n) ]ₖ y) p q ≡ p ∙ q
  cong₂+₂ n p q =
      (cong₂Funct (λ x y → x +[ (2 + n) ]ₖ y) p q)
   ∙ (λ i → (cong (λ x → rUnitₖ (2 + n) x i) p) ∙ (cong (λ x → lUnitₖ (2 + n) x i) q))

  isCommΩEM : (n : ℕ) (p q : typ (Ω (EM∙ G  (suc n)))) → p ∙ q ≡ q ∙ p
  isCommΩEM zero p q =
       sym (cong₂+₁ p q)
    ∙∙ (λ i j → commₖ 1 (p j) (q j) i)
    ∙∙ cong₂+₁ q p
  isCommΩEM (suc n) p q =
       (sym (cong₂+₂ n p q)
    ∙∙ (λ i j → commₖ (suc (suc n)) (p j) (q j) i)
    ∙∙ cong₂+₂ n q p)

  cong-₁ : (p : typ (Ω (EM∙ G 1))) → cong (λ x → -[ 1 ]ₖ x) p ≡ sym p
  cong-₁ p = main embase p
    where
    decoder : (x : EM G 1) → embase ≡ x → x ≡ embase
    decoder =
      elimSet _
        (λ _ → isSetΠ λ _ → emsquash _ _)
        (λ p i → -[ 1 ]ₖ (p i))
        λ g → toPathP
          (funExt λ x →
            (λ i → transport (λ i → Path (EM G 1) (emloop g i) embase)
               (cong (-ₖ_ {n = 1})
                 (transp (λ j → Path (EM G 1) embase (emloop g (~ j ∧ ~ i))) i
                   (compPath-filler x (sym (emloop g)) i) )))
         ∙∙ (λ i → transp (λ j → Path (EM G 1) (emloop g (i ∨ j)) embase) i
                           (compPath-filler'
                             (sym (emloop g))
                             (cong-∙ (-ₖ_ {n = 1})
                                   x (sym (emloop g)) i) i))
      ∙∙ (cong (sym (emloop g) ∙_) (isCommΩEM 0 (cong (-ₖ_ {n = 1}) x) (emloop g)))
      ∙∙ ∙assoc _ _ _
      ∙∙ cong (_∙ (cong (-ₖ_ {n = 1}) x)) (lCancel (emloop g))
       ∙ sym (lUnit _))

    main : (x : EM G 1) (p : embase ≡ x) → decoder x p ≡ sym p
    main x = J (λ x p → decoder x p ≡ sym p) refl

  cong-₂ : (n : ℕ) (p : typ (Ω (EM∙ G (2 + n))))
    → cong (λ x → -[ 2 + n ]ₖ x) p ≡ sym p
  cong-₂ n p = main _ p
    where
    pp : (a : _)
      → PathP (λ i → 0ₖ (suc (suc n)) ≡ ∣ merid a i ∣ₕ → ∣ merid a i ∣ₕ ≡ 0ₖ (2 + n))
               (cong (λ x → -[ 2 + n ]ₖ x))
               λ p → cong ∣_∣ₕ (sym (merid ptEM-raw)) ∙ cong (λ x → -[ 2 + n ]ₖ x) p
    pp a =
      toPathP
        (funExt λ x →
          (λ k → transp (λ i → Path (EM G (2 + n)) ∣ merid a (i ∨ k) ∣ ∣ ptEM-raw ∣) k
                         (compPath-filler' (cong ∣_∣ₕ (sym (merid a)))
                          (cong (-ₖ-syntax (suc (suc n)))
                           (transp (λ j → Path (EM G (2 + n)) ∣ ptEM-raw ∣ ∣ merid a (~ j ∧ ~ k) ∣) k
                            (compPath-filler x (sym (cong ∣_∣ₕ (merid a))) k))) k))
               ∙∙ cong (cong ∣_∣ₕ (sym (merid a)) ∙_)
                       (cong-∙ (λ x → -[ 2 + n ]ₖ x) x (sym (cong ∣_∣ₕ (merid a)))
                      ∙ isCommΩEM (suc n) (cong (λ x → -[ 2 + n ]ₖ x) x) (cong ∣_∣ₕ (σ-EM n a)))
               ∙∙ (λ k → (λ i → ∣ merid a (~ i ∨ k) ∣)
                        ∙ (λ i → ∣ compPath-filler' (merid a) (sym (merid ptEM-raw)) (~ k) i ∣)
                        ∙ cong (λ x → -ₖ-syntax (suc (suc n)) x) x)
                ∙ sym (lUnit _))

    decoder : (x : EM G (2 + n))
            → 0ₖ (2 + n) ≡ x → x ≡ 0ₖ (2 + n)
    decoder =
      trElim (λ _ → isOfHLevelΠ (4 + n) λ _ → isOfHLevelTruncPath {n = 4 + n})
             λ { north → pp ptEM-raw i0
               ; south → pp ptEM-raw i1
               ; (merid a i) → pp a i}

    main : (x : EM G (2 + n)) (p : 0ₖ (2 + n) ≡ x) → decoder x p ≡ sym p
    main x = J (λ x p → decoder x p ≡ sym p) refl

  rCancelₖ : (n : ℕ) (x : EM G n) → x +[ n ]ₖ (-[ n ]ₖ x) ≡ 0ₖ n
  rCancelₖ zero x = +InvR x
  rCancelₖ (suc zero) =
    elimSet _ (λ _ → emsquash _ _)
      refl
      λ g → flipSquare (cong₂+₁ (emloop g) (λ i → -ₖ-syntax 1 (emloop g i))
           ∙ rCancel (emloop g))
  rCancelₖ (suc (suc n)) =
    trElim (λ _ → isOfHLevelTruncPath {n = 4 + n})
      λ { north → refl
        ; south i → +ₖ-syntax (suc (suc n)) ∣ merid ptEM-raw (~ i) ∣
                      (-ₖ-syntax (suc (suc n)) ∣ merid ptEM-raw (~ i) ∣)
        ; (merid a i) j
          → hcomp (λ r → λ { (i = i0) → 0ₖ (2 + n)
                             ; (i = i1) → ∣ merid ptEM-raw (~ j ∧ r) ∣ₕ -[ 2 + n ]ₖ ∣ merid ptEM-raw (~ j ∧ r) ∣
                             ; (j = i0) → ∣ compPath-filler (merid a) (sym (merid ptEM-raw)) (~ r) i ∣
                                        -[ 2 + n ]ₖ ∣ compPath-filler (merid a) (sym (merid ptEM-raw)) (~ r) i ∣
                             ; (j = i1) → 0ₖ (2 + n)})
                   (help' a j i) }
    where
    help' : (a : _)
      → cong₂ (λ x y → ∣ x ∣ -[ suc (suc n) ]ₖ ∣ y ∣) (σ-EM n a) (σ-EM n a) ≡ refl
    help' a =
         cong₂+₂ n (cong ∣_∣ₕ (σ-EM n a)) (cong (λ x → -[ 2 + n ]ₖ ∣ x ∣) (σ-EM n a))
      ∙∙ cong (cong ∣_∣ₕ (σ-EM n a) ∙_) (cong-₂ n (cong ∣_∣ₕ (σ-EM n a)))
      ∙∙ rCancel _

  lCancelₖ : (n : ℕ) (x : EM G n) → (-[ n ]ₖ x) +[ n ]ₖ x ≡ 0ₖ n
  lCancelₖ n x = commₖ n (-[ n ]ₖ x) x ∙ rCancelₖ n x

  assocₖ : (n : ℕ) (x y z : EM G n)
        → (x +[ n ]ₖ (y +[ n ]ₖ z) ≡ (x +[ n ]ₖ y) +[ n ]ₖ z)
  assocₖ zero = +AssocG
  assocₖ (suc zero) =
    elimSet _ (λ _ → isSetΠ2 λ _ _ → emsquash _ _)
      (λ _ _ → refl)
      λ g i y z k → lem g y z k i
    where
    lem : (g : fst G) (y z : _)
        → cong (λ x → x +[ suc zero ]ₖ (y +[ suc zero ]ₖ z)) (emloop g)
         ≡ cong (λ x → (x +[ suc zero ]ₖ y) +[ suc zero ]ₖ z) (emloop g)
    lem g =
      elimProp _ (λ _ → isPropΠ λ _ → emsquash _ _ _ _)
        (elimProp _ (λ _ → emsquash _ _ _ _)
          refl)
  assocₖ (suc (suc n)) =
    elim2 (λ _ _ → isOfHLevelΠ (4 + n) λ _ → isOfHLevelTruncPath {n = 4 + n})
      λ a b → trElim (λ _ → isOfHLevelTruncPath {n = 4 + n})
                (λ c → main c a b)
    where
    lem : (c : _) (a b : _)
      → PathP (λ i → (∣ a ∣ₕ +[ suc (suc n) ]ₖ (∣ b ∣ₕ +[ suc (suc n) ]ₖ ∣ merid c i ∣ₕ)
                    ≡ (∣ a ∣ₕ +[ suc (suc n) ]ₖ ∣ b ∣ₕ) +[ suc (suc n) ]ₖ ∣ merid c i ∣ₕ))
               (cong (λ x → ∣ a ∣ₕ +[ suc (suc n) ]ₖ x) (rUnitₖ (suc (suc n)) ∣ b ∣)
                   ∙ sym (rUnitₖ (suc (suc n)) (∣ a ∣ₕ +[ suc (suc n) ]ₖ ∣ b ∣ₕ)))
               ((λ i → ∣ a ∣ₕ +[ suc (suc n) ]ₖ (∣ b ∣ₕ +[ suc (suc n) ]ₖ ∣ merid ptEM-raw (~ i) ∣ₕ))
             ∙∙ cong (λ x → ∣ a ∣ₕ +[ suc (suc n) ]ₖ x) (rUnitₖ (suc (suc n)) ∣ b ∣)
                 ∙ sym (rUnitₖ (suc (suc n)) (∣ a ∣ₕ +[ suc (suc n) ]ₖ ∣ b ∣ₕ))
             ∙∙ λ i → (∣ a ∣ₕ +[ suc (suc n) ]ₖ ∣ b ∣ₕ) +[ suc (suc n) ]ₖ ∣ merid ptEM-raw i ∣ₕ)
    lem c =
      raw-elim G (suc n)
        (λ _ → isOfHLevelΠ (2 + n)
          (λ _ → isOfHLevelPathP' (2 + n) (isOfHLevelTrunc (4 + n) _ _) _ _))
           (raw-elim G (suc n)
            (λ _ → isOfHLevelPathP' (2 + n) (isOfHLevelTrunc (4 + n) _ _) _ _)
             ((sym (rUnit refl)
             ◁ λ _ → refl)
             ▷ (sym (lCancel (cong ∣_∣ₕ (merid ptEM-raw)))
             ∙ λ i → (λ j → ∣ merid ptEM-raw (~ j ∨ ~ i) ∣ₕ)
                   ∙∙ lUnit (λ j → ∣ merid ptEM-raw (~ j ∧ ~ i) ∣ₕ) i
                   ∙∙ cong ∣_∣ₕ (merid ptEM-raw))))
    main : (c a b : _)
      → (∣ a ∣ₕ +[ suc (suc n) ]ₖ (∣ b ∣ₕ +[ suc (suc n) ]ₖ ∣ c ∣ₕ)
       ≡ (∣ a ∣ₕ +[ suc (suc n) ]ₖ ∣ b ∣ₕ) +[ suc (suc n) ]ₖ ∣ c ∣ₕ)
    main north a b = lem ptEM-raw a b i0
    main south a b = lem ptEM-raw a b i1
    main (merid c i) a b = lem c a b i

  σ-EM' : (n : ℕ) (x : EM G (suc n))
        → Path (EM G (suc (suc n)))
                (0ₖ (suc (suc n)))
                (0ₖ (suc (suc n)))
  σ-EM' zero x = cong ∣_∣ₕ (σ-EM zero x)
  σ-EM' (suc n) =
    trElim (λ _ → isOfHLevelTrunc (5 + n) _ _)
      λ x → cong ∣_∣ₕ (σ-EM (suc n) x)

  σ-EM'-0ₖ : (n : ℕ) → σ-EM' n (0ₖ (suc n)) ≡ refl
  σ-EM'-0ₖ zero = cong (cong ∣_∣ₕ) (rCancel (merid ptEM-raw))
  σ-EM'-0ₖ (suc n) = cong (cong ∣_∣ₕ) (rCancel (merid ptEM-raw))

  private
    lUnit-rUnit-coh : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (r : refl ≡ p)
        → lUnit p ∙ cong (_∙ p) r
         ≡ rUnit p ∙ cong (p ∙_) r
    lUnit-rUnit-coh p =
      J (λ p r → lUnit p ∙ cong (_∙ p) r ≡ rUnit p ∙ cong (p ∙_) r) refl

  σ-EM'-hom : (n : ℕ) → (a b : _) → σ-EM' n (a +ₖ b) ≡ σ-EM' n a ∙ σ-EM' n b
  σ-EM'-hom zero =
    wedgeConEM.fun G G 0 0 (λ _ _ → isOfHLevelTrunc 4 _ _ _ _) l r p
    where
    l : _
    l x = cong (σ-EM' zero) (lUnitₖ 1 x)
        ∙∙ lUnit (σ-EM' zero x)
        ∙∙ cong (_∙ σ-EM' zero x) (sym (σ-EM'-0ₖ zero))

    r : _
    r x =
         cong (σ-EM' zero) (rUnitₖ 1 x)
      ∙∙ rUnit (σ-EM' zero x)
      ∙∙ cong (σ-EM' zero x ∙_) (sym (σ-EM'-0ₖ zero))

    p : _
    p = lUnit-rUnit-coh (σ-EM' zero embase) (sym (σ-EM'-0ₖ zero))
  σ-EM'-hom (suc n) =
    elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (5 + n) _ _) _ _)
      (wedgeConEM.fun G G _ _
        (λ x y → transport (λ i → isOfHLevel (help n i)
                            ((σ-EM' (suc n) (∣ x ∣ₕ +ₖ ∣ y ∣ₕ)
                           ≡ σ-EM' (suc n) ∣ x ∣ₕ ∙ σ-EM' (suc n) ∣ y ∣ₕ)))
                    (isOfHLevelPlus {n = 4 + n} n
                      (isOfHLevelPath (4 + n)
                        (isOfHLevelTrunc (5 + n) _ _) _ _)))
        (λ x → cong (σ-EM' (suc n)) (lUnitₖ (suc (suc n)) ∣ x ∣)
            ∙∙ lUnit (σ-EM' (suc n) ∣ x ∣)
            ∙∙ cong (_∙ σ-EM' (suc n) ∣ x ∣) (sym (σ-EM'-0ₖ (suc n))))
        (λ x → cong (σ-EM' (suc n)) (rUnitₖ (2 + n) ∣ x ∣)
      ∙∙ rUnit (σ-EM' (suc n) ∣ x ∣)
      ∙∙ cong (σ-EM' (suc n) ∣ x ∣ ∙_) (sym (σ-EM'-0ₖ (suc n))))
        (lUnit-rUnit-coh (σ-EM' (suc n) (0ₖ (2 + n))) (sym (σ-EM'-0ₖ (suc n)))))

  σ-EM'-ₖ : (n : ℕ) → (a : _) → σ-EM' n (-ₖ a) ≡ sym (σ-EM' n a)
  σ-EM'-ₖ n =
    morphLemmas.distrMinus
      (λ x y → x +[ suc n ]ₖ y) (_∙_)
      (σ-EM' n) (σ-EM'-hom n)
      (0ₖ (suc n)) refl
      (λ x → -ₖ x) sym
      (λ x → sym (lUnit x)) (λ x → sym (rUnit x))
      (lCancelₖ (suc n)) rCancel
      ∙assoc (σ-EM'-0ₖ n)

  -Dist : (n : ℕ) (x y : EM G n) → -[ n ]ₖ (x +[ n ]ₖ y) ≡ (-[ n ]ₖ x) +[ n ]ₖ (-[ n ]ₖ y)
  -Dist zero x y = (GroupTheory.invDistr (AbGroup→Group G) x y) ∙ commₖ zero _ _
  -Dist (suc zero) = k
    where -- useless where clause. Needed for fast type checking for some reason.
    l : _
    l x = refl

    r : _
    r x = cong (λ z → -[ 1 ]ₖ z) (rUnitₖ 1 x) ∙ sym (rUnitₖ 1 (-[ 1 ]ₖ x))

    p : r ptEM-raw ≡ l ptEM-raw
    p = sym (rUnit refl)

    k = wedgeConEM.fun G G 0 0 (λ _ _ → emsquash _ _) l r (sym p)

  -Dist (suc (suc n)) =
    elim2 (λ _ _ → isOfHLevelTruncPath {n = 4 + n})
      (wedgeConEM.fun G G (suc n) (suc n)
        (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (hLevHelp n) _ _)
        (λ x → refl)
        (λ x → cong (λ z → -[ (suc (suc n)) ]ₖ z)
                     (rUnitₖ (suc (suc n)) ∣ x ∣ₕ)
                     ∙ sym (rUnitₖ (suc (suc n)) (-[ (suc (suc n)) ]ₖ ∣ x ∣ₕ)))
        (rUnit refl))

  addIso : (n : ℕ) (x : EM G n) → Iso (EM G n) (EM G n)
  Iso.fun (addIso n x) y = y +[ n ]ₖ x
  Iso.inv (addIso n x) y = y -[ n ]ₖ x
  Iso.rightInv (addIso n x) y =
       sym (assocₖ n y (-[ n ]ₖ x) x)
    ∙∙ cong (λ x → y +[ n ]ₖ x) (lCancelₖ n x)
    ∙∙ rUnitₖ n y
  Iso.leftInv (addIso n x) y =
    sym (assocₖ n y x (-[ n ]ₖ x))
    ∙∙ cong (λ x → y +[ n ]ₖ x) (rCancelₖ n x)
    ∙∙ rUnitₖ n y