{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.AbGroup.TensorProduct where

open import Cubical.Algebra.AbGroup.Base
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Function hiding (flip)
open import Cubical.Foundations.Isomorphism

open import Cubical.Relation.Binary

open import Cubical.Data.Sigma

open import Cubical.Data.List
open import Cubical.Data.Nat as ℕ
open import Cubical.Foundations.HLevels
open import Cubical.Data.Int
open import Cubical.Data.Sum hiding (map)

open import Cubical.HITs.PropositionalTruncation
  renaming (map to pMap ; rec to pRec ; elim to pElim ; elim2 to pElim2)

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Semigroup

private
  variable
    ℓ ℓ' : Level

module _ (AGr : AbGroup ℓ) (BGr : AbGroup ℓ') where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  data _⨂₁_ : Type (ℓ-max ℓ ℓ') where
   _⊗_ : (a : A) → (b : B) → _⨂₁_
   _+⊗_ : (w : _⨂₁_) → (u : _⨂₁_) → _⨂₁_

   ⊗comm : (x y : _) → x +⊗ y ≡ y +⊗ x
   ⊗assoc : (x y z : _) → x +⊗ (y +⊗ z) ≡ (x +⊗ y) +⊗ z
   ⊗lUnit : (x : _) → (0A ⊗ 0B) +⊗ x ≡ x

   linl : (x y : A) (z : B) → (x +A y) ⊗ z ≡ ((x ⊗ z) +⊗ (y ⊗ z))
   linr : (x : A) (y z : B) → x ⊗ (y +B z) ≡ ((x ⊗ y) +⊗ (x ⊗ z))

   ⊗squash : isSet _⨂₁_

module _ {AGr : AbGroup ℓ} {BGr : AbGroup ℓ'} where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  A⊗B = AGr ⨂₁ BGr

  ⊗elimProp : ∀ {ℓ} {C : AGr ⨂₁ BGr → Type ℓ}
           → ((x : _) → isProp (C x))
           → (f : (x : A) (b : B) → C (x ⊗ b))
           → (g : ((x y : _) → C x → C y → C (x +⊗ y)))
           → (x : _) → C x
  ⊗elimProp p f g (a ⊗ b) = f a b
  ⊗elimProp p f g (x +⊗ y) = g x y (⊗elimProp p f g x) (⊗elimProp p f g y)
  ⊗elimProp  {C = C} p f g (⊗comm x y j) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g x y (⊗elimProp p f g x) (⊗elimProp p f g y))
      (g y x (⊗elimProp p f g y) (⊗elimProp p f g x)) (⊗comm x y) j
  ⊗elimProp {C = C} p f g (⊗assoc x y z j) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g x (y +⊗ z) (⊗elimProp p f g x)
         (g y z (⊗elimProp p f g y) (⊗elimProp p f g z)))
         (g (x +⊗ y) z (g x y (⊗elimProp p f g x)
           (⊗elimProp p f g y)) (⊗elimProp p f g z)) (⊗assoc x y z) j
  ⊗elimProp {C = C} p f g (⊗lUnit x i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g (0A ⊗ 0B) x (f 0A 0B) (⊗elimProp p f g x))
      (⊗elimProp p f g x)
      (⊗lUnit x) i
  ⊗elimProp {C = C} p f g (linl x y z i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (f (x +A y) z) (g (x ⊗ z) (y ⊗ z) (f x z) (f y z)) (linl x y z) i
  ⊗elimProp {C = C} p f g (linr x y z i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (f x (y +B z)) (g (x ⊗ y) (x ⊗ z) (f x y) (f x z)) (linr x y z) i
  ⊗elimProp {C = C} p f g (⊗squash x y q r i j) =
    isOfHLevel→isOfHLevelDep 2 {B = C} (λ x → isProp→isSet (p x))
      _ _ (λ j → ⊗elimProp p f g (q j)) (λ j → ⊗elimProp p f g (r j))
          (⊗squash x y q r) i j

  -- Group structure
  0⊗ : AGr ⨂₁ BGr
  0⊗ = 0A ⊗ 0B

  -⊗ : AGr ⨂₁ BGr → AGr ⨂₁ BGr
  -⊗ (a ⊗ b) = (-A a) ⊗ b
  -⊗ (x +⊗ x₁) = -⊗ x +⊗ -⊗ x₁
  -⊗ (⊗comm x y i) = ⊗comm (-⊗ x) (-⊗ y) i
  -⊗ (⊗assoc x y z i) = ⊗assoc (-⊗ x) (-⊗ y) (-⊗ z) i
  -⊗ (⊗lUnit x i) =
    ((λ i → (GroupTheory.inv1g (AbGroup→Group AGr) i ⊗ 0B) +⊗ -⊗ x)
       ∙ ⊗lUnit (-⊗ x)) i
  -⊗ (linl x y z i) =
     ((λ i → (GroupTheory.invDistr (AbGroup→Group AGr) x y
             ∙ comm strA (-A y) (-A x)) i ⊗ z)
    ∙ linl (-A x) (-A y) z) i
  -⊗ (linr x y z i) = linr (-A x) y z i
  -⊗ (⊗squash x y p q i j) =
    ⊗squash _ _ (λ j → -⊗ (p j)) (λ j → -⊗ (q j)) i j

  ⊗rUnit : (x : A⊗B) → x +⊗ 0⊗ ≡ x
  ⊗rUnit x = ⊗comm x 0⊗ ∙ ⊗lUnit x

  -------------------------------------------------------------------------------
  -- Useful induction principle, which lets us view elements of A ⨂ B as lists
  -- over (A × B). Used for the right cancellation law
  unlist : List (A × B) → AGr ⨂₁ BGr
  unlist [] = 0A ⊗ 0B
  unlist (x ∷ x₁) = (fst x ⊗ snd x) +⊗ unlist x₁

  unlist++ : (x y : List (A × B))
            → unlist (x ++ y) ≡ (unlist x +⊗ unlist y)
  unlist++ [] y = sym (⊗lUnit (unlist y))
  unlist++ (x ∷ x₁) y =
       (λ i → (fst x ⊗ snd x) +⊗ (unlist++ x₁ y i))
     ∙ ⊗assoc (fst x ⊗ snd x) (unlist x₁) (unlist y)

  ∃List : (x : AGr ⨂₁ BGr) → ∃[ l ∈ List (A × B) ] (unlist l ≡ x)
  ∃List =
    ⊗elimProp (λ _ → squash₁)
      (λ a b → ∣ [ a , b ] , ⊗rUnit (a ⊗ b) ∣₁)
      λ x y → rec2 squash₁ λ {(l1 , p) (l2 , q)
                          → ∣ (l1 ++ l2) , unlist++ l1 l2 ∙ cong₂ _+⊗_ p q ∣₁}

  ⊗elimPropUnlist : ∀ {ℓ} {C : AGr ⨂₁ BGr → Type ℓ}
           → ((x : _) → isProp (C x))
           → ((x : _) → C (unlist x))
           → (x : _) → C x
  ⊗elimPropUnlist {C = C} p f =
    ⊗elimProp p (λ x y → subst C (⊗rUnit (x ⊗ y)) (f [ x , y ]))
      λ x y → pRec (isPropΠ2 λ _ _ → p _)
                    (pRec (isPropΠ3 λ _ _ _ → p _)
                      (λ {(l1 , p) (l2 , q) ind1 ind2
                        → subst C (unlist++ l2 l1 ∙ cong₂ _+⊗_ q p) (f (l2 ++ l1))})
                      (∃List y))
                    (∃List x)
  -----------------------------------------------------------------------------------

  lCancelPrim : (x : B) → (0A ⊗ x) ≡ 0⊗
  lCancelPrim x =
    sym (⊗rUnit _)
    ∙∙ cong ((0A ⊗ x) +⊗_) (sym cancelLem)
    ∙∙ ⊗assoc (0A ⊗ x) (0A ⊗ x) (0A ⊗ (-B x))
    ∙∙ cong (_+⊗ (0A ⊗ (-B x))) inner
    ∙∙ cancelLem
    where
    cancelLem : (0A ⊗ x) +⊗ (0A ⊗ (-B x)) ≡ 0⊗
    cancelLem = sym (linr 0A x (-B x)) ∙ (λ i → 0A ⊗ invr strB x i)

    inner : (0A ⊗ x) +⊗ (0A ⊗ x) ≡ 0A ⊗ x
    inner = sym (linl 0A 0A x) ∙ (λ i → rid strA 0A i ⊗ x)

  rCancelPrim : (x : A) → (x ⊗ 0B) ≡ 0⊗
  rCancelPrim x =
    sym (⊗rUnit _)
    ∙∙ cong ((x ⊗ 0B) +⊗_) (sym cancelLem)
    ∙∙ ⊗assoc (x ⊗ 0B) (x ⊗ 0B) ((-A x) ⊗ 0B)
    ∙∙ cong (_+⊗ ((-A x) ⊗ 0B)) inner
    ∙∙ cancelLem
    where
    cancelLem : (x ⊗ 0B) +⊗ ((-A x) ⊗ 0B) ≡ 0⊗
    cancelLem = sym (linl x (-A x) 0B) ∙ (λ i → invr strA x i ⊗ 0B)

    inner : (x ⊗ 0B) +⊗ (x ⊗ 0B) ≡ x ⊗ 0B
    inner = sym (linr x 0B 0B) ∙ (λ i → x ⊗ rid strB 0B i)

  flip : (x : A) (b : B) → x ⊗ (-B b) ≡ ((-A x) ⊗ b)
  flip x b =
    sym (⊗rUnit _)
    ∙ cong ((x ⊗ (-B b)) +⊗_) (sym cancelLemA)
    ∙ ⊗assoc (x ⊗ (-B b)) (x ⊗ b) ((-A x) ⊗ b)
    ∙ cong (_+⊗ ((-A x) ⊗ b)) cancelLemB
    ∙ ⊗lUnit _
    where
    cancelLemA : (x ⊗ b) +⊗ ((-A x) ⊗ b) ≡ 0⊗
    cancelLemA = sym (linl x (-A x) b) ∙ (λ i → invr strA x i ⊗ b) ∙ lCancelPrim b

    cancelLemB : (x ⊗ (-B b)) +⊗ (x ⊗ b) ≡ 0⊗
    cancelLemB = sym (linr x (-B b) b) ∙ (λ i → x ⊗ invl strB b i) ∙ rCancelPrim x

  ⊗rCancel : (x : AGr ⨂₁ BGr) → (x +⊗ -⊗ x) ≡ 0⊗
  ⊗rCancel =
    ⊗elimPropUnlist (λ _ → ⊗squash _ _) h
    where
    h : (x : List (A × B)) → (unlist x +⊗ -⊗ (unlist x)) ≡ 0⊗
    h [] = sym (linl 0A (-A 0A) (0B))
         ∙ cong (λ x →  _⊗_ {AGr = AGr} {BGr = BGr} x 0B) (invr strA 0A)
    h (x ∷ x₁) =
      move4 (fst x ⊗ snd x) (unlist x₁) ((-A fst x) ⊗ snd x) (-⊗ (unlist x₁))
            _+⊗_ ⊗assoc ⊗comm
      ∙∙ cong₂ _+⊗_ (sym (linl (fst x) (-A (fst x)) (snd x))
                   ∙∙ (λ i → invr strA (fst x) i ⊗ (snd x))
                   ∙∙ lCancelPrim (snd x))
                    (h x₁)
      ∙∙ ⊗rUnit 0⊗

  ⊗lCancel : (x : AGr ⨂₁ BGr) → (-⊗ x +⊗ x) ≡ 0⊗
  ⊗lCancel x = ⊗comm _ _ ∙ ⊗rCancel x

module _ where
  open AbGroupStr
  open IsAbGroup
  open IsGroup
  open IsMonoid
  open IsSemigroup

  _⨂_ : AbGroup ℓ → AbGroup ℓ' → AbGroup (ℓ-max ℓ ℓ')
  fst (A ⨂ B) = A ⨂₁ B
  0g (snd (A ⨂ B)) = 0⊗
  AbGroupStr._+_ (snd (A ⨂ B)) = _+⊗_
  AbGroupStr.- snd (A ⨂ B) = -⊗
  is-set (isSemigroup (isMonoid (isGroup (isAbGroup (snd (A ⨂ B)))))) = ⊗squash
  assoc (isSemigroup (isMonoid (isGroup (isAbGroup (snd (A ⨂ B)))))) = ⊗assoc
  fst (identity (isMonoid (isGroup (isAbGroup (snd (A ⨂ B))))) x) = ⊗rUnit x
  snd (identity (isMonoid (isGroup (isAbGroup (snd (A ⨂ B))))) x) = ⊗lUnit x
  fst (inverse (isGroup (isAbGroup (snd (A ⨂ B)))) x) = ⊗rCancel x
  snd (inverse (isGroup (isAbGroup (snd (A ⨂ B)))) x) = ⊗lCancel x
  comm (isAbGroup (snd (A ⨂ B))) = ⊗comm

-------------- Elimination principle into AbGroups --------------
module _ {ℓ ℓ' : Level} {A : AbGroup ℓ}  {B : AbGroup ℓ'} where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G)
    _+A_ = _+G_ (snd A)
    _+B_ = _+G_ (snd B)

    0A = 0g (snd A)
    0B = 0g (snd B)

  ⨂→AbGroup-elim : ∀ {ℓ} (C : AbGroup ℓ)
         → (f : (fst A × fst B) → fst C)
         → (f (0A , 0B) ≡ 0g (snd C))
         → (linL : (x y : fst A) (b : fst B)
                 → f (x +A y , b) ≡ _+G_ (snd C) (f (x , b)) (f (y , b)))
         → (linR : (a : fst A) (x y : fst B)
                 → f (a , x +B y) ≡ _+G_ (snd C) (f (a , x)) (f (a , y)))
         → A ⨂₁ B → fst C
  ⨂→AbGroup-elim C f p linL linR (a ⊗ b) = f (a , b)
  ⨂→AbGroup-elim C f p linL linR (x +⊗ x₁) =
    _+G_ (snd C) (⨂→AbGroup-elim C f p linL linR x)
                 (⨂→AbGroup-elim C f p linL linR x₁)
  ⨂→AbGroup-elim C f p linL linR (⊗comm x x₁ i) =
    comm (snd C) (⨂→AbGroup-elim C f p linL linR x)
                 (⨂→AbGroup-elim C f p linL linR x₁) i
  ⨂→AbGroup-elim C f p linL linR (⊗assoc x x₁ x₂ i) =
    assoc (snd C) (⨂→AbGroup-elim C f p linL linR x)
                  (⨂→AbGroup-elim C f p linL linR x₁)
                  (⨂→AbGroup-elim C f p linL linR x₂) i
  ⨂→AbGroup-elim C f p linL linR (⊗lUnit x i) =
    (cong (λ y → (snd C +G y) (⨂→AbGroup-elim C f p linL linR x)) p
                     ∙ (lid (snd C) (⨂→AbGroup-elim C f p linL linR x))) i
  ⨂→AbGroup-elim C f p linL linR (linl x y z i) = linL x y z i
  ⨂→AbGroup-elim C f p linL linR (linr x y z i) = linR x y z i
  ⨂→AbGroup-elim C f p linL linR (⊗squash x x₁ x₂ y i i₁) =
    is-set (snd C) _ _
           (λ i → ⨂→AbGroup-elim C f p linL linR (x₂ i))
           (λ i → ⨂→AbGroup-elim C f p linL linR (y i)) i i₁

  ⨂→AbGroup-elim-hom : ∀ {ℓ} (C : AbGroup ℓ)
        → (f : (fst A × fst B) → fst C) (linL : _) (linR : _) (p : _)
        → AbGroupHom (A ⨂ B) C
  fst (⨂→AbGroup-elim-hom C f linL linR p) = ⨂→AbGroup-elim C f p linL linR
  snd (⨂→AbGroup-elim-hom C f linL linR p) =
    makeIsGroupHom
      (λ x y → refl)

private
  _* = AbGroup→Group

----------- Definition of universal property ------------
tensorFun : (A : Group ℓ) (B : Group ℓ') (T C : AbGroup (ℓ-max ℓ ℓ'))
    (f : GroupHom A (HomGroup B T *))
  → GroupHom (T *) (C *)
  → GroupHom A (HomGroup B C *)
fst (fst (tensorFun A B T C (f , p) (g , q)) a) b = g (fst (f a) b)
snd (fst (tensorFun A B T C (f , p) (g , q)) a) =
    makeIsGroupHom λ x y
      → cong g (IsGroupHom.pres· (snd (f a)) x y)
       ∙ IsGroupHom.pres· q _ _
snd (tensorFun A B T C (f , p) (g , q)) =
     makeIsGroupHom λ x y
      → Σ≡Prop (λ _ → isPropIsGroupHom _ _)
           (funExt λ b
             → cong g (funExt⁻ (cong fst (IsGroupHom.pres· p x y)) b)
              ∙ IsGroupHom.pres· q _ _)

isTensorProductOf_and_ : AbGroup ℓ → AbGroup ℓ' → AbGroup (ℓ-max ℓ ℓ')→ Type _
isTensorProductOf_and_ {ℓ} {ℓ'} A B T =
  Σ[ f ∈ GroupHom (A *) ((HomGroup (B *) T) *) ]
    ((C : AbGroup (ℓ-max ℓ ℓ'))
      → isEquiv {A = GroupHom (T *) (C *)}
                 {B = GroupHom (A *) ((HomGroup (B *) C) *)}
          (tensorFun (A *) (B *) T C f))

------ _⨂_ satisfies the universal property --------
module UP (AGr : AbGroup ℓ) (BGr : AbGroup ℓ') where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  mainF : GroupHom (AGr *) (HomGroup (BGr *) (AGr ⨂ BGr) *)
  fst (fst mainF a) b = a ⊗ b
  snd (fst mainF a) =
    makeIsGroupHom (linr a)
  snd mainF =
    makeIsGroupHom λ x y → Σ≡Prop (λ _ → isPropIsGroupHom _ _)
      (funExt (linl x y))

  isTensorProduct⨂ : (isTensorProductOf AGr and BGr) (AGr ⨂ BGr)
  fst isTensorProduct⨂ = mainF
  snd isTensorProduct⨂ C = isoToIsEquiv mainIso
    where
    invF : GroupHom (AGr *) (HomGroup (BGr *) C *) → GroupHom ((AGr ⨂ BGr) *) (C *)
    fst (invF (f , p)) = F
      where
      lem : f (0g (snd AGr)) .fst (0g (snd BGr)) ≡ 0g (snd C)
      lem = funExt⁻ (cong fst (IsGroupHom.pres1 p)) (0g (snd BGr))
      F : ((AGr ⨂ BGr) *) .fst → (C *) .fst
      F (a ⊗ b) = f a .fst b
      F (x +⊗ x₁) = _+G_ (snd C) (F x) (F x₁)
      F (⊗comm x x₁ i) = comm (snd C) (F x) (F x₁) i
      F (⊗assoc x y z i) = assoc (snd C) (F x) (F y) (F z) i
      F (⊗lUnit x i) = (cong (λ y → _+G_ (snd C) y (F x)) lem ∙ lid (snd C) (F x)) i
      F (linl x y z i) = fst (IsGroupHom.pres· p x y i) z
      F (linr x y z i) = IsGroupHom.pres· (f x .snd) y z i
      F (⊗squash x x₁ x₂ y i i₁) =
        is-set (snd C) (F x) (F x₁)
          (λ i → F (x₂ i)) (λ i → F (y i)) i i₁
    snd (invF (f , p)) =
      makeIsGroupHom λ x y → refl

    mainIso : Iso (GroupHom ((AGr ⨂ BGr) *) (C *))
                  (GroupHom (AGr *) (HomGroup (BGr *) C *))
    Iso.fun mainIso = _
    Iso.inv mainIso = invF
    Iso.rightInv mainIso (f , p) =
      Σ≡Prop (λ _ → isPropIsGroupHom _ _)
             (funExt λ a → Σ≡Prop (λ _ → isPropIsGroupHom _ _) refl)
    Iso.leftInv mainIso (f , p) =
      Σ≡Prop (λ _ → isPropIsGroupHom _ _)
             (funExt (⊗elimProp (λ _ → is-set (snd C) _ _)
               (λ _ _ → refl)
               λ x y ind1 ind2 → cong₂ (_+G_ (snd C)) ind1 ind2 ∙ sym (IsGroupHom.pres· p x y)))

-------------------- Commutativity ------------------------
commFun : ∀ {ℓ ℓ'} {A : AbGroup ℓ}  {B : AbGroup ℓ'} → A ⨂₁ B → B ⨂₁ A
commFun (a ⊗ b) = b ⊗ a
commFun (x +⊗ x₁) = commFun x +⊗ commFun x₁
commFun (⊗comm x x₁ i) = ⊗comm (commFun x) (commFun x₁) i
commFun (⊗assoc x x₁ x₂ i) = ⊗assoc (commFun x) (commFun x₁) (commFun x₂) i
commFun (⊗lUnit x i) = ⊗lUnit (commFun x) i
commFun (linl x y z i) = linr z x y i
commFun (linr x y z i) = linl y z x i
commFun (⊗squash x x₁ x₂ y i i₁) =
  ⊗squash (commFun x) (commFun x₁)
          (λ i → commFun (x₂ i)) (λ i → commFun (y i)) i i₁

commFun²≡id : ∀ {ℓ ℓ'} {A : AbGroup ℓ}  {B : AbGroup ℓ'} (x : A ⨂₁ B)
          → commFun (commFun x) ≡ x
commFun²≡id =
  ⊗elimProp (λ _ → ⊗squash _ _)
    (λ _ _ → refl)
    λ _ _ p q → cong₂ _+⊗_ p q

⨂-commIso : ∀ {ℓ ℓ'} {A : AbGroup ℓ} {B : AbGroup ℓ'}
          → GroupIso ((A ⨂ B) *) ((B ⨂ A) *)
Iso.fun (fst ⨂-commIso) = commFun
Iso.inv (fst ⨂-commIso) = commFun
Iso.rightInv (fst ⨂-commIso) = commFun²≡id
Iso.leftInv (fst ⨂-commIso) = commFun²≡id
snd ⨂-commIso = makeIsGroupHom λ x y → refl

⨂-comm : ∀ {ℓ ℓ'} {A : AbGroup ℓ} {B : AbGroup ℓ'} → AbGroupEquiv (A ⨂ B) (B ⨂ A)
fst ⨂-comm = isoToEquiv (fst (⨂-commIso))
snd ⨂-comm = snd ⨂-commIso

open AbGroupStr

-------------------- Associativity ------------------------
module _ {ℓ ℓ' ℓ'' : Level} {A : AbGroup ℓ} {B : AbGroup ℓ'} {C : AbGroup ℓ''} where
  private
    f : (c : fst C) → AbGroupHom (A ⨂ B) (A ⨂ (B ⨂ C))
    f c = ⨂→AbGroup-elim-hom (A ⨂ (B ⨂ C)) ((λ ab → fst ab ⊗ (snd ab ⊗ c)))
                  (λ x y b → linl x y (b ⊗ c))
                  (λ x y b → (λ i → x ⊗ (linl y b c i)) ∙ linr x (y ⊗ c) (b ⊗ c))
                  (λ i → 0g (snd A) ⊗ (lCancelPrim c i))

  assocHom : AbGroupHom ((A ⨂ B) ⨂ C) (A ⨂ (B ⨂ C))
  assocHom =
    ⨂→AbGroup-elim-hom _ (λ x → f (snd x) .fst (fst x))
      (λ x y b → IsGroupHom.pres· (snd (f b)) x y)
      (⊗elimProp (λ _ → isPropΠ2 λ _ _ → ⊗squash _ _)
                 (λ a b x y → (λ i → a ⊗ (linr b x y i))
                            ∙∙ linr a (b ⊗ x) (b ⊗ y)
                            ∙∙ refl)
                 λ a b ind1 ind2 x y → cong₂ _+⊗_ (ind1 x y) (ind2 x y)
                       ∙∙ move4 (f x .fst a) (f y .fst a) (f x .fst b) (f y .fst b)
                                _+⊗_ ⊗assoc ⊗comm
                       ∙∙ cong₂ _+⊗_ (sym (IsGroupHom.pres· (snd (f x)) a b))
                                     (IsGroupHom.pres· (snd (f y)) a b))
      refl

module _ {ℓ ℓ' ℓ'' : Level} {A : AbGroup ℓ} {B : AbGroup ℓ'} {C : AbGroup ℓ''} where
  private
    f' : (a : fst A) → AbGroupHom (B ⨂ C) ((A ⨂ B) ⨂ C)
    f' a =
      ⨂→AbGroup-elim-hom ((A ⨂ B) ⨂ C)
         (λ bc → (a ⊗ fst bc) ⊗ snd bc)
         (λ x y b → (λ i → (linr a x y i) ⊗ b) ∙ linl (a ⊗ x) (a ⊗ y) b)
         (λ x y b → linr (a ⊗ x) y b)
         λ i → rCancelPrim a i ⊗ (0g (snd C))

  assocHom⁻ : AbGroupHom (A ⨂ (B ⨂ C)) ((A ⨂ B) ⨂ C)
  assocHom⁻ =
    ⨂→AbGroup-elim-hom _ (λ abc → f' (fst abc) .fst (snd abc))
       (λ x y → ⊗elimProp (λ _ → ⊗squash _ _)
                   (λ b c → (λ i → linl x y b i ⊗ c) ∙ linl (x ⊗ b) (y ⊗ b) c)
                   λ a b ind1 ind2 → cong₂ _+⊗_ ind1 ind2
                                  ∙∙ move4 _ _ _ _ _+⊗_ ⊗assoc ⊗comm
                                  ∙∙ cong₂ _+⊗_ (IsGroupHom.pres· (snd (f' x)) a b)
                                                (IsGroupHom.pres· (snd (f' y)) a b))
       (λ a → IsGroupHom.pres· (snd (f' a)))
       refl

  ⨂assocIso : Iso (A ⨂₁ (B ⨂ C)) ((A ⨂ B) ⨂₁ C)
  Iso.fun ⨂assocIso = fst assocHom⁻
  Iso.inv ⨂assocIso = fst assocHom
  Iso.rightInv ⨂assocIso =
    ⊗elimProp (λ _ → ⊗squash _ _)
      (⊗elimProp (λ _ → isPropΠ (λ _ → ⊗squash _ _))
        (λ a b c → refl)
        λ a b ind1 ind2 c → cong₂ _+⊗_ (ind1 c) (ind2 c) ∙ sym (linl a b c))
      λ x y p q → cong (fst assocHom⁻) (IsGroupHom.pres· (snd assocHom) x y)
               ∙∙ IsGroupHom.pres· (snd assocHom⁻) (fst assocHom x) (fst assocHom y)
               ∙∙ cong₂ _+⊗_ p q
  Iso.leftInv ⨂assocIso =
    ⊗elimProp (λ _ → ⊗squash _ _)
      (λ a → ⊗elimProp (λ _ → ⊗squash _ _)
              (λ b c → refl)
              λ x y ind1 ind2 →
                   cong (fst assocHom ∘ fst assocHom⁻) (linr a x y)
                ∙∙ cong (fst assocHom) (IsGroupHom.pres· (snd assocHom⁻) (a ⊗ x) (a ⊗ y))
                ∙∙ IsGroupHom.pres· (snd assocHom) (fst assocHom⁻ (a ⊗ x)) (fst assocHom⁻ (a ⊗ y))
                ∙∙ cong₂ _+⊗_ ind1 ind2
                ∙∙ sym (linr a x y))
      λ x y p q → cong (fst assocHom) (IsGroupHom.pres· (snd assocHom⁻) x y)
               ∙∙ IsGroupHom.pres· (snd assocHom) (fst assocHom⁻ x) (fst assocHom⁻ y)
               ∙∙ cong₂ _+⊗_ p q

  ⨂assoc : AbGroupEquiv (A ⨂ (B ⨂ C)) ((A ⨂ B) ⨂ C)
  fst ⨂assoc = isoToEquiv ⨂assocIso
  snd ⨂assoc = snd assocHom⁻


{-# OPTIONS --safe --experimental-lossy-unification #-}
{-
This file contains:
1. The iso π₃S²≅ℤ
2. A proof that π₃S² is generated by the Hopf map
-}
module Cubical.Homotopy.Group.Pi3S2 where

open import Cubical.Homotopy.Loopspace

open import Cubical.Homotopy.Group.LES
open import Cubical.Homotopy.Group.PinSn
open import Cubical.Homotopy.Group.Base
open import Cubical.Homotopy.HopfInvariant.HopfMap
open import Cubical.Homotopy.HopfInvariant.Base
open import Cubical.Homotopy.HopfInvariant.Homomorphism

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Isomorphism
open Iso
open import Cubical.Foundations.Equiv

open import Cubical.HITs.SetTruncation renaming (elim to sElim)
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.S1

open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.Int

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Exact
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Unit
open import Cubical.Algebra.Group.Instances.Int

TotalHopf→∙S² : (Σ (S₊ 2) S¹Hopf , north , base) →∙ S₊∙ 2
fst TotalHopf→∙S² = fst
snd TotalHopf→∙S² = refl

IsoTotalSpaceJoin' : Iso (Σ (S₊ 2) S¹Hopf) (S₊ 3)
IsoTotalSpaceJoin' = compIso hopfS¹.IsoTotalSpaceJoin (IsoSphereJoin 1 1)

IsoFiberTotalHopfS¹ : Iso (fiber (fst TotalHopf→∙S²) north) S¹
fun IsoFiberTotalHopfS¹ ((x , y) , z) = subst S¹Hopf z y
inv IsoFiberTotalHopfS¹ x = (north , x) , refl
rightInv IsoFiberTotalHopfS¹ x = refl
leftInv IsoFiberTotalHopfS¹ ((x , y) , z) =
  ΣPathP
    ((ΣPathP
      (sym z , (λ i → transp (λ j → S¹Hopf (z (~ i ∧ j))) i y)))
         , (λ j i → z (i ∨ ~ j)))

IsoFiberTotalHopfS¹∙≡ :
  (fiber (fst TotalHopf→∙S²) north , (north , base) , refl) ≡ S₊∙ 1
IsoFiberTotalHopfS¹∙≡ = ua∙ (isoToEquiv IsoFiberTotalHopfS¹) refl

private
  transportGroupEquiv : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
      (n : ℕ) (f : A →∙ B)
    → isEquiv (fst (πLES.A→B f n))
    → isEquiv (fst (π'∘∙Hom n f))
  transportGroupEquiv n f iseq =
    transport (λ i → isEquiv (fst (π∘∙A→B-PathP n f i))) iseq

π₃S²≅π₃TotalHopf : GroupEquiv (πGr 2 (Σ (S₊ 2) S¹Hopf , north , base))
                              (πGr 2 (S₊∙ 2))
fst (fst π₃S²≅π₃TotalHopf) = fst (πLES.A→B TotalHopf→∙S² 2)
snd (fst π₃S²≅π₃TotalHopf) =
  SES→isEquiv
    (isContr→≡UnitGroup
      (subst isContr (cong (π 3) (sym IsoFiberTotalHopfS¹∙≡))
        (∣ refl ∣₂ , (sElim (λ _ → isSetPathImplicit)
          (λ p → cong ∣_∣₂
            (isOfHLevelSuc 3 isGroupoidS¹ _ _ _ _ _ _ refl p))))))
    (isContr→≡UnitGroup
      (subst isContr (cong (π 2) (sym IsoFiberTotalHopfS¹∙≡))
        (∣ refl ∣₂ , (sElim (λ _ → isSetPathImplicit) (λ p
                    → cong ∣_∣₂ (isGroupoidS¹ _ _ _ _ refl p))))))
    (πLES.fib→A TotalHopf→∙S² 2)
    (πLES.A→B TotalHopf→∙S² 2)
    (πLES.B→fib TotalHopf→∙S² 1)
    (πLES.Ker-A→B⊂Im-fib→A TotalHopf→∙S² 2)
    (πLES.Ker-B→fib⊂Im-A→B TotalHopf→∙S² 1)
snd π₃S²≅π₃TotalHopf = snd (πLES.A→B TotalHopf→∙S² 2)

π'₃S²≅π'₃TotalHopf : GroupEquiv (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base))
                                (π'Gr 2 (S₊∙ 2))
fst (fst π'₃S²≅π'₃TotalHopf) = fst (π'∘∙Hom 2 TotalHopf→∙S²)
snd (fst π'₃S²≅π'₃TotalHopf) =
  transportGroupEquiv 2 TotalHopf→∙S² (π₃S²≅π₃TotalHopf .fst .snd)
snd π'₃S²≅π'₃TotalHopf = snd (π'∘∙Hom 2 TotalHopf→∙S²)

πS³≅πTotalHopf : (n : ℕ)
  → GroupEquiv (π'Gr n (S₊∙ 3)) (π'Gr n (Σ (S₊ 2) S¹Hopf , north , base))
πS³≅πTotalHopf n =
  π'Iso n
   ((isoToEquiv
     (invIso
      (compIso
       (hopfS¹.IsoTotalSpaceJoin)
       (IsoSphereJoin 1 1))))
  , refl)

π₃S²≅ℤ : GroupEquiv (π'Gr 2 (S₊∙ 2)) ℤGroup
π₃S²≅ℤ =
  compGroupEquiv
    (invGroupEquiv
      (compGroupEquiv (πS³≅πTotalHopf 2) π'₃S²≅π'₃TotalHopf))
    (GroupIso→GroupEquiv (πₙ'Sⁿ≅ℤ 2))

-- We prove that the generator is the Hopf map
π₃TotalHopf-gen' : π' 3 (Σ (Susp S¹) S¹Hopf , north , base)
π₃TotalHopf-gen' =
  ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂

πS³≅πTotalHopf-gen :
  fst (fst (πS³≅πTotalHopf 2)) ∣ idfun∙ _ ∣₂ ≡ π₃TotalHopf-gen'
πS³≅πTotalHopf-gen =
  cong ∣_∣₂
    (∘∙-idʳ (inv (compIso (hopfS¹.IsoTotalSpaceJoin)
                 (IsoSphereJoin 1 1)) , refl))

πTotalHopf-gen :
  gen₁-by (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base))
    ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂
πTotalHopf-gen =
  subst (gen₁-by (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base)))
        πS³≅πTotalHopf-gen
        (Iso-pres-gen₁ (π'Gr 2 (S₊∙ 3))
                       (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base))
                       ∣ idfun∙ _ ∣₂
                       (πₙ'Sⁿ-gen-by-idfun 2)
                       (GroupEquiv→GroupIso (πS³≅πTotalHopf 2)))

πTotalHopf≅πS²-gen :
    fst (fst π'₃S²≅π'₃TotalHopf)
      π₃TotalHopf-gen'
  ≡ ∣ HopfMap' , refl ∣₂
πTotalHopf≅πS²-gen =
  cong ∣_∣₂ (ΣPathP (refl , (sym (rUnit refl))))

π₂S³-gen-by-HopfMap' : gen₁-by (π'Gr 2 (S₊∙ 2)) ∣ HopfMap' , refl ∣₂
π₂S³-gen-by-HopfMap' =
  subst (gen₁-by (π'Gr 2 (S₊∙ 2)))  πTotalHopf≅πS²-gen
    (Iso-pres-gen₁ (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base)) (π'Gr 2 (S₊∙ 2))
      ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂
      πTotalHopf-gen
      (GroupEquiv→GroupIso π'₃S²≅π'₃TotalHopf))

π₂S³-gen-by-HopfMap : gen₁-by (π'Gr 2 (S₊∙ 2)) ∣ HopfMap ∣₂
π₂S³-gen-by-HopfMap =
  subst (gen₁-by (π'Gr 2 (S₊∙ 2)))
        (cong ∣_∣₂ (sym hopfMap≡HopfMap'))
        π₂S³-gen-by-HopfMap'

-- As a consequence, we also get that the Hopf invariant determines
-- an iso π₃S²≅ℤ
hopfInvariantEquiv : GroupEquiv (π'Gr 2 (S₊∙ 2)) ℤGroup
fst (fst hopfInvariantEquiv) = HopfInvariant-π' 0
snd (fst hopfInvariantEquiv) =
  GroupEquivℤ-isEquiv (invGroupEquiv π₃S²≅ℤ) ∣ HopfMap ∣₂
                      π₂S³-gen-by-HopfMap (GroupHom-HopfInvariant-π' 0)
                      (abs→⊎ _ _ HopfInvariant-HopfMap)
snd hopfInvariantEquiv = snd (GroupHom-HopfInvariant-π' 0)


module Numeric.Rational.Properties where

open import Prelude
open import Numeric.Rational
open import Numeric.Nat.Properties
open import Numeric.Nat.Divide
open import Numeric.Nat.Divide.Properties
open import Numeric.Nat.Prime
open import Numeric.Nat.Prime.Properties
open import Numeric.Nat.GCD
open import Numeric.Nat.GCD.Properties
open import Tactic.Nat
open import Tactic.Nat.Coprime

-- Correctness proofs for the efficient arithmetic operations -------

private
  lem-coprime : ∀ n₁ n₂ s′ d₁′ d₂′ g g₁ →
                  s′ * g₁ ≡ n₁ * d₂′ + n₂ * d₁′ →
                  Coprime n₁ (d₁′ * g) →
                  Coprime d₁′ d₂′ →
                  Coprime s′ d₁′
  lem-coprime n₁ n₂ s′ d₁′ d₂′ g g₁ s′g₁=s n₁⊥d₁ d₁′⊥d₂′ =
    coprimeByPrimes s′ d₁′ λ p isP p|s′ p|d₁′ →

      let s  = n₁ * d₂′ + n₂ * d₁′
          d₁ = d₁′ * g

          p|d₁ : p Divides d₁
          p|d₁ = divides-mul-l g p|d₁′

          p|s : p Divides s
          p|s = transport (p Divides_) s′g₁=s (divides-mul-l g₁ p|s′)

          p|n₁d₂′ : p Divides (n₁ * d₂′)
          p|n₁d₂′ = divides-sub-r p|s (divides-mul-r n₂ p|d₁′)

          p∤n₁ : ¬ (p Divides n₁)
          p∤n₁ p|n₁ = prime-divide-coprime p n₁ d₁ isP n₁⊥d₁ p|n₁ p|d₁

          p|d₂′ : p Divides d₂′
          p|d₂′ = case prime-split n₁ d₂′ isP p|n₁d₂′ of λ where
                    (left p|n₁)   → ⊥-elim (p∤n₁ p|n₁)
                    (right p|d₂′) → p|d₂′

      in divide-coprime p d₁′ d₂′ d₁′⊥d₂′ p|d₁′ p|d₂′

addQ-sound : ∀ x y → x + y ≡ slowAddQ x y
addQ-sound (ratio n₁ d₁ n₁⊥d₁) (ratio n₂ d₂ n₂⊥d₂)
  with gcd (n₁ * d₂ + n₂ * d₁) (d₁ * d₂) | gcd d₁ d₂
...  | gcd-res g₀ g₀-gcd@(is-gcd (factor p pg₀=n₀) (factor q qg₀=d₀) _)
     | gcd-res g isgcd-dd@(is-gcd (factor! d₁′) (factor! d₂′) _)
  with gcd (n₁ * d₂′ + n₂ * d₁′) g
...  | gcd-res g₁ isgcd-sg@(is-gcd (factor s′ s′g₁=s) (factor! g′) _) =

  let n₀ = n₁ * d₂ + n₂ * d₁
      d₀ = d₁ * d₂
      s  = n₁ * d₂′ + n₂ * d₁′

      instance
        nz-g₀  = nonzero-is-gcd-r ⦃ mul-nonzero d₁ d₂ ⦄ g₀-gcd
        nz-g   = nonzero-is-gcd-l isgcd-dd
        nz-g₁  = nonzero-is-gcd-r isgcd-sg
        nz-gg₁ = mul-nonzero g g₁

      s′gg₁=n₀ : s′ * (g * g₁) ≡ n₀
      s′gg₁=n₀ =
        s′ * (g * g₁)
          ≡⟨ auto ⟩
        s′ * g₁ * g
          ≡⟨ _* g $≡ s′g₁=s ⟩
        (n₁ * d₂′ + n₂ * d₁′) * g
          ≡⟨ auto ⟩
        n₀ ∎

      ddg′gg₁=d₀ : d₁′ * d₂′ * g′ * (g * g₁) ≡ d₀
      ddg′gg₁=d₀ = auto

      s′⊥ddg : Coprime s′ (d₁′ * d₂′ * g′)
      s′⊥ddg =
        let[ _ := is-gcd-factors-coprime isgcd-dd ]
        let[ _ := lem-coprime n₁ n₂ s′ d₁′ d₂′ g g₁ s′g₁=s n₁⊥d₁ auto-coprime ]
        let[ _ := lem-coprime n₂ n₁ s′ d₂′ d₁′ g g₁ (s′g₁=s ⟨≡⟩ auto) n₂⊥d₂ auto-coprime ]
        let[ _ := is-gcd-factors-coprime isgcd-sg ]
        auto-coprime

      gg₁-gcd : IsGCD (g * g₁) n₀ d₀
      gg₁-gcd = is-gcd-by-coprime-factors (g * g₁) n₀ d₀
                  (factor s′ s′gg₁=n₀) (factor (d₁′ * d₂′ * g′) ddg′gg₁=d₀)
                  s′⊥ddg

      gg₁=g₀ : g * g₁ ≡ g₀
      gg₁=g₀ = is-gcd-unique (g * g₁) g₀ gg₁-gcd g₀-gcd

      s′g₀=n₀ : s′ * g₀ ≡ n₀
      s′g₀=n₀ = s′ *_ $≡ sym gg₁=g₀ ⟨≡⟩ s′gg₁=n₀

      ddgg₀=d₀ : d₁′ * d₂′ * g′ * g₀ ≡ d₀
      ddgg₀=d₀ = d₁′ * d₂′ * g′ *_ $≡ sym gg₁=g₀ ⟨≡⟩ ddg′gg₁=d₀

      s′=p : s′ ≡ p
      s′=p = mul-inj₁ s′ p g₀ (s′g₀=n₀ ⟨≡⟩ʳ pg₀=n₀)

      ddg=q : d₁′ * d₂′ * g′ ≡ q
      ddg=q = mul-inj₁ _ q g₀ (ddgg₀=d₀ ⟨≡⟩ʳ qg₀=d₀)

    in cong-ratio s′=p ddg=q

mulQ-sound : ∀ x y → x * y ≡ slowMulQ x y
mulQ-sound (ratio n₁ d₁ n₁⊥d₁) (ratio n₂ d₂ n₂⊥d₂)
  with gcd n₁ d₂ | gcd n₂ d₁ | gcd (n₁ * n₂) (d₁ * d₂)
... | gcd-res g₁ gcd₁₂@(is-gcd (factor! n₁′) (factor! d₂′) _)
    | gcd-res g₂ gcd₂₁@(is-gcd (factor! n₂′) (factor! d₁′) _)
    | gcd-res g  gcdnd@(is-gcd (factor n′ n′g=n) (factor d′ d′g=d) _) =
  let instance _ = nonzero-is-gcd-r gcd₁₂
               _ = nonzero-is-gcd-r gcd₂₁
               _ = mul-nonzero g₁ g₂
      g=gg : g ≡ g₁ * g₂
      g=gg = is-gcd-unique _ _ gcdnd $
               is-gcd-by-coprime-factors _ _ _ (factor (n₁′ * n₂′) auto)
                                               (factor (d₁′ * d₂′) auto) $
                 let[ _ := is-gcd-factors-coprime gcd₁₂ ]
                 let[ _ := is-gcd-factors-coprime gcd₂₁ ]
                 auto-coprime
      neq : n₁′ * n₂′ ≡ n′
      neq = case g=gg of λ where
              refl → mul-inj₁ (n₁′ * n₂′) n′ (g₁ * g₂) (by n′g=n)
      deq : d₁′ * d₂′ ≡ d′
      deq = case g=gg of λ where
              refl → mul-inj₁ (d₁′ * d₂′) d′ (g₁ * g₂) (by d′g=d)
  in cong-ratio neq deq


{-

  Importing and re-exporting this module allows for (constrained) natural number
   and negative integer literals for any type (e.g. Int, ℕ₋₁, ℕ₋₂, ℕ₊₁).

-}
{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.Nat.Literals where

open import Agda.Builtin.FromNat public
  renaming (Number to HasFromNat)
open import Agda.Builtin.FromNeg public
  renaming (Negative to HasFromNeg)
open import Cubical.Data.Unit.Base public

-- Natural number literals for ℕ

open import Agda.Builtin.Nat renaming (Nat to ℕ)

instance
  fromNatℕ : HasFromNat ℕ
  fromNatℕ = record { Constraint = λ _ → Unit ; fromNat = λ n → n }


------------------------------------------------------------------------
-- A coinductive definition of the expansion ordering
------------------------------------------------------------------------

-- The definition of expansion is based on the one in "Enhancements of
-- the bisimulation proof method" by Pous and Sangiorgi.

{-# OPTIONS --sized-types #-}

open import Labelled-transition-system

module Expansion {ℓ} (lts : LTS ℓ) where

open import Equality.Propositional
open import Prelude
open import Prelude.Size

import Bisimilarity
import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.General
open import Equational-reasoning
open import Indexed-container using (Container; ν; ν′)
open import Relation

open LTS lts
private
  open module SB = Bisimilarity lts
    using (_∼_; _∼′_; [_]_∼_; [_]_∼′_)

private
  module General = Bisimilarity.General lts _[_]⟶̂_ _[_]⇒_ ⟶→⟶̂ ⟶→[]⇒

open General public
  using (module StepC; ⟨_,_⟩; left-to-right; right-to-left; force;
         [_]_≡_; [_]_≡′_; []≡↔;
         Extensionality; extensionality)
  renaming ( reflexive-∼ to reflexive-≳
           ; reflexive-∼′ to reflexive-≳′
           ; ≡⇒∼ to ≡⇒≳
           ; ∼:_ to ≳:_
           ; ∼′:_ to ≳′:_
           )

-- StepC is given in the following way, rather than via open public,
-- to make hyperlinks to it more informative.

StepC : Container (Proc × Proc) (Proc × Proc)
StepC = General.StepC

-- The following definitions are given explicitly, to make the code
-- easier to follow for readers of the paper.

Expansion : Size → Rel₂ ℓ Proc
Expansion = ν StepC

Expansion′ : Size → Rel₂ ℓ Proc
Expansion′ = ν′ StepC

infix 4 _≳_ _≳′_ [_]_≳_ [_]_≳′_

[_]_≳_ : Size → Proc → Proc → Type ℓ
[ i ] p ≳ q = ν StepC i (p , q)

[_]_≳′_ : Size → Proc → Proc → Type ℓ
[ i ] p ≳′ q = ν′ StepC i (p , q)

_≳_ : Proc → Proc → Type ℓ
_≳_ = [ ∞ ]_≳_

_≳′_ : Proc → Proc → Type ℓ
_≳′_ = [ ∞ ]_≳′_

private

  -- However, these definitions are definitionally equivalent to
  -- corresponding definitions in General.

  indirect-Expansion : Expansion ≡ General.Bisimilarity
  indirect-Expansion = refl

  indirect-Expansion′ : Expansion′ ≡ General.Bisimilarity′
  indirect-Expansion′ = refl

  indirect-[]≳ : [_]_≳_ ≡ General.[_]_∼_
  indirect-[]≳ = refl

  indirect-[]≳′ : [_]_≳′_ ≡ General.[_]_∼′_
  indirect-[]≳′ = refl

  indirect-≳ : _≳_ ≡ General._∼_
  indirect-≳ = refl

  indirect-≳′ : _≳′_ ≡ General._∼′_
  indirect-≳′ = refl

-- The converse relation.

infix 4 _≲_ _≲′_ [_]_≲_ [_]_≲′_

[_]_≲_ : Size → Proc → Proc → Type ℓ
[_]_≲_ i = flip [ i ]_≳_

[_]_≲′_ : Size → Proc → Proc → Type ℓ
[_]_≲′_ i = flip [ i ]_≳′_

_≲_ : Proc → Proc → Type ℓ
_≲_ = [ ∞ ]_≲_

_≲′_ : Proc → Proc → Type ℓ
_≲′_ = [ ∞ ]_≲′_

-- Combinators that can perhaps make the code a bit nicer to read.

infix -3 lr-result-⟶̂ rl-result-⇒ lr-result-⇒ rl-result-⟶̂

lr-result-⟶̂ : ∀ {i p′ q q′} μ → [ i ] p′ ≳′ q′ → q [ μ ]⟶̂ q′ →
              ∃ λ q′ → q [ μ ]⟶̂ q′ × [ i ] p′ ≳′ q′
lr-result-⟶̂ _ p′≳′q′ q⟶̂q′ = _ , q⟶̂q′ , p′≳′q′

rl-result-⇒ : ∀ {i p p′ q′} μ → p [ μ ]⇒ p′ → [ i ] p′ ≳′ q′ →
              ∃ λ p′ → p [ μ ]⇒ p′ × [ i ] p′ ≳′ q′
rl-result-⇒ _ p⇒p′ p′≳′q′ = _ , p⇒p′ , p′≳′q′

lr-result-⇒ : ∀ {i p′ q q′} μ → [ i ] p′ ≲′ q′ → q [ μ ]⇒ q′ →
              ∃ λ q′ → q [ μ ]⇒ q′ × [ i ] p′ ≲′ q′
lr-result-⇒ _ p′≲′q′ q⇒q′ = _ , q⇒q′ , p′≲′q′

rl-result-⟶̂ : ∀ {i p p′ q′} μ → p [ μ ]⟶̂ p′ → [ i ] p′ ≲′ q′ →
              ∃ λ p′ → p [ μ ]⟶̂ p′ × [ i ] p′ ≲′ q′
rl-result-⟶̂ _ p⟶̂p′ p′≲′q′ = _ , p⟶̂p′ , p′≲′q′

syntax lr-result-⟶̂ μ p′≳′q′ q⟶̂q′ = p′≳′q′ ⟵̂[ μ ] q⟶̂q′
syntax rl-result-⇒ μ p⇒p′ p′≳′q′ = p⇒p′ ⇒[ μ ] p′≳′q′
syntax lr-result-⇒ μ p′≲′q′ q⇒q′ = p′≲′q′ ⇐[ μ ] q⇒q′
syntax rl-result-⟶̂ μ p⟶̂p′ p′≲′q′ = p⟶̂p′ ⟶̂[ μ ] p′≲′q′

-- Strongly bisimilar processes are related by the expansion ordering.

mutual

  ∼⇒≳ : ∀ {i p q} → [ i ] p ∼ q → [ i ] p ≳ q
  ∼⇒≳ {i} = λ p∼q → StepC.⟨ lr p∼q , rl p∼q ⟩
    where
    lr : ∀ {p p′ q μ} →
         [ i ] p ∼ q → p [ μ ]⟶ p′ →
         ∃ λ q′ → q [ μ ]⟶̂ q′ × [ i ] p′ ≳′ q′
    lr p∼q p⟶p′ =
      let q′ , q⟶q′ , p′∼′q′ = SB.left-to-right p∼q p⟶p′
      in q′ , step q⟶q′ , ∼⇒≳′ p′∼′q′

    rl : ∀ {p q q′ μ} →
         [ i ] p ∼ q → q [ μ ]⟶ q′ →
         ∃ λ p′ → p [ μ ]⇒ p′ × [ i ] p′ ≳′ q′
    rl p∼q q⟶q′ =
      let p′ , p⟶p′ , p′∼′q′ = SB.right-to-left p∼q q⟶q′
      in p′ , ⟶→[]⇒ p⟶p′ , ∼⇒≳′ p′∼′q′

  ∼⇒≳′ : ∀ {i p q} → [ i ] p ∼′ q → [ i ] p ≳′ q
  force (∼⇒≳′ p∼′q) = ∼⇒≳ (SB.force p∼′q)

-- Expansion is a weak simulation (of three different kinds).

expansion-is-weak⇒ :
  ∀ {p p′ q} →
  p ≳ q → p ⇒ p′ →
  ∃ λ q′ → q ⇒ q′ × p′ ≳ q′
expansion-is-weak⇒ =
  is-weak⇒ StepC.left-to-right (λ p≳′q → force p≳′q) ⟶̂→⇒

expansion-is-weak[]⇒ :
  ∀ {p p′ q μ} →
  ¬ Silent μ →
  p ≳ q → p [ μ ]⇒ p′ →
  ∃ λ q′ → q [ μ ]⇒ q′ × p′ ≳ q′
expansion-is-weak[]⇒ ¬s =
  is-weak[]⇒ StepC.left-to-right (λ p≳′q → force p≳′q)
             ⟶̂→⇒ (⇒̂→[]⇒ ¬s ∘ ⟶̂→⇒̂)

expansion-is-weak⇒̂ :
  ∀ {p p′ q μ} →
  p ≳ q → p [ μ ]⇒̂ p′ →
  ∃ λ q′ → q [ μ ]⇒̂ q′ × p′ ≳ q′
expansion-is-weak⇒̂ =
  is-weak⇒̂ StepC.left-to-right (λ p≳′q → force p≳′q) ⟶̂→⇒ ⟶̂→⇒̂

-- The converse of expansion is a weak simulation (of three different
-- kinds).

converse-of-expansion-is-weak :
  ∀ {p p′ q} →
  p ≲ q → p ⇒ p′ →
  ∃ λ q′ → q ⇒ q′ × p′ ≲ q′
converse-of-expansion-is-weak =
  is-weak⇒ StepC.right-to-left (λ p≲′q → force p≲′q) []⇒→⇒

converse-of-expansion-is-weak[]⇒ :
  ∀ {p p′ q μ} →
  p ≲ q → p [ μ ]⇒ p′ →
  ∃ λ q′ → q [ μ ]⇒ q′ × p′ ≲ q′
converse-of-expansion-is-weak[]⇒ =
  is-weak[]⇒ StepC.right-to-left (λ p≲′q → force p≲′q) []⇒→⇒ id

converse-of-expansion-is-weak⇒̂ :
  ∀ {p p′ q μ} →
  p ≲ q → p [ μ ]⇒̂ p′ →
  ∃ λ q′ → q [ μ ]⇒̂ q′ × p′ ≲ q′
converse-of-expansion-is-weak⇒̂ =
  is-weak⇒̂ StepC.right-to-left (λ p≲′q → force p≲′q) []⇒→⇒ ⇒→⇒̂

mutual

  -- Expansion is transitive.
  --
  -- Note that the transitivity proof is not claimed to be fully
  -- size-preserving. For a proof showing that it cannot, in general,
  -- be size-preserving in the first argument, see
  -- Expansion.Delay-monad.size-preserving-transitivityˡ⇔uninhabited.

  transitive-≳ : ∀ {i p q r} → p ≳ q → [ i ] q ≳ r → [ i ] p ≳ r
  transitive-≳ {i} = λ p≳q q≳r → StepC.⟨ lr p≳q q≳r , rl p≳q q≳r ⟩
    where
    lr : ∀ {p p′ q r μ} →
         p ≳ q → [ i ] q ≳ r → p [ μ ]⟶ p′ →
         ∃ λ r′ → r [ μ ]⟶̂ r′ × [ i ] p′ ≳′ r′
    lr p≳q q≳r p⟶p′ with StepC.left-to-right p≳q p⟶p′
    ... | _  , done s , p′≳′q  =
      _ , done s
        , transitive-≳′ p′≳′q (record { force = λ { {_} → q≳r } })
    ... | q′ , step q⟶q′ , p′≳′q′ =
      let r′ , r⟶̂r′ , q′≳′r′ = StepC.left-to-right q≳r q⟶q′
      in r′ , r⟶̂r′ , transitive-≳′ p′≳′q′ q′≳′r′

    rl : ∀ {p q r r′ μ} →
         p ≳ q → [ i ] q ≳ r → r [ μ ]⟶ r′ →
         ∃ λ p′ → p [ μ ]⇒ p′ × [ i ] p′ ≳′ r′
    rl p≳q q≳r r⟶r′ =
      let q′ , q⇒q′ , q′≳′r′ = StepC.right-to-left q≳r r⟶r′
          p′ , p⇒̂p′ , p′≳q′  = converse-of-expansion-is-weak[]⇒ p≳q q⇒q′
      in p′ , p⇒̂p′ , transitive-≳′ (record { force = p′≳q′ }) q′≳′r′

  transitive-≳′ : ∀ {i p q r} → p ≳′ q → [ i ] q ≳′ r → [ i ] p ≳′ r
  force (transitive-≳′ p≳q q≳r) = transitive-≳ (force p≳q) (force q≳r)

-- The following variant of transitivity is fully size-preserving.

mutual

  transitive-≳∼ : ∀ {i p q r} →
                  [ i ] p ≳ q → [ i ] q ∼ r → [ i ] p ≳ r
  transitive-≳∼ {i} {p} {r = r} p≳q q∼r = StepC.⟨ lr , rl ⟩
    where
    rl : ∀ {r′ μ} → r [ μ ]⟶ r′ →
         ∃ λ p′ → p [ μ ]⇒ p′ × [ i ] p′ ≳′ r′
    rl r⟶r′ =
      let q′ , q⟶q′ , q′∼′r′ = SB.right-to-left q∼r r⟶r′
          p′ , p⇒p′ , p′≳′q′ = StepC.right-to-left p≳q q⟶q′
      in p′ , p⇒p′ , transitive-≳∼′ p′≳′q′ q′∼′r′

    lr : ∀ {p′ μ} → p [ μ ]⟶ p′ →
         ∃ λ r′ → r [ μ ]⟶̂ r′ × [ i ] p′ ≳′ r′
    lr p⟶p′ =
      let q′ , q⟶̂q′ , p′≳′q′ = StepC.left-to-right p≳q p⟶p′
          r′ , r⇒̂r′ , q′∼r′  = lemma q∼r q⟶̂q′
      in r′ , r⇒̂r′ , transitive-≳∼′ p′≳′q′ q′∼r′
      where
      lemma :
        ∀ {i p p′ q μ} →
        [ i ] p ∼ q → p [ μ ]⟶̂ p′ →
        ∃ λ q′ → q [ μ ]⟶̂ q′ × [ i ] p′ ∼′ q′
      lemma p∼q (done s)    = _ , done s
                                , record { force = λ { {_} → p∼q } }
      lemma p∼q (step p⟶p′) =
        let q′ , q⟶q′ , p′∼q′ = SB.left-to-right p∼q p⟶p′
        in q′ , ⟶→⟶̂ q⟶q′ , p′∼q′

  transitive-≳∼′ : ∀ {i p q r} →
                   [ i ] p ≳′ q → [ i ] q ∼′ r → [ i ] p ≳′ r
  force (transitive-≳∼′ p≳′q q∼′r) =
    transitive-≳∼ (force p≳′q) (SB.force q∼′r)

-- The following variant of transitivity is partially size-preserving.
--
-- For a proof showing that it cannot, in general, be size-preserving
-- in the first argument, see
-- Expansion.Delay-monad.size-preserving-transitivity-∼≳ˡ⇔uninhabited.

transitive-∼≳ : ∀ {i p q r} →
                p ∼ q → [ i ] q ≳ r → [ i ] p ≳ r
transitive-∼≳ = transitive-≳ ∘ ∼⇒≳


-- {-# OPTIONS -v extendedlambda:100 -v int2abs.reifyterm.def:100 #-}
module Issue435 where

data Bool : Set where
  true false : Bool

record Unit : Set where

postulate
  Dh : ({ x : Bool } → Bool) → Set
  Di : ({{x : Bool}} → Bool) → Set

noth : Set
noth = Dh (\ { {true}  → false ; {false} → true})

noti : Set
noti = Di (\ { {{true}}  → false ; {{false}} → true})

-- Testing absurd patterns

data ⊥ : Set where

data T : Set where
  expl : (⊥ → ⊥) → T
  impl : ({_ : ⊥} → ⊥) → T
  inst : ({{_ : ⊥}} → ⊥) → T

explicit : T
explicit = expl (λ ())

implicit : T
implicit = impl (λ {})

instance : T
instance = inst (λ {{ }})

explicit-match : T
explicit-match = expl (λ { () })

implicit-match : T
implicit-match = impl (λ { {} })

implicit-match′ : T
implicit-match′ = impl (λ { { () } })

instance-match : T
instance-match = inst (λ { {{}} })

instance-match′ : T
instance-match′ = inst (λ { {{ () }} })


{-# OPTIONS --safe #-}
module Cubical.Algebra.Ring.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Ring.Base

private
  variable
    ℓ : Level

{-
  some basic calculations (used for example in QuotientRing.agda),
  that should become obsolete or subject to change once we have a
  ring solver (see https://github.com/agda/cubical/issues/297)
-}
module RingTheory (R' : Ring ℓ) where

  open RingStr (snd R')
  private R = ⟨ R' ⟩
  implicitInverse : (x y : R)
                 → x + y ≡ 0r
                 → y ≡ - x
  implicitInverse x y p =
    y               ≡⟨ sym (+Lid y) ⟩
    0r + y          ≡⟨ cong (λ u → u + y) (sym (+Linv x)) ⟩
    (- x + x) + y   ≡⟨ sym (+Assoc _ _ _) ⟩
    (- x) + (x + y) ≡⟨ cong (λ u → (- x) + u) p ⟩
    (- x) + 0r      ≡⟨ +Rid _ ⟩
    - x             ∎

  equalByDifference : (x y : R)
                      → x - y ≡ 0r
                      → x ≡ y
  equalByDifference x y p =
    x               ≡⟨ sym (+Rid _) ⟩
    x + 0r          ≡⟨ cong (λ u → x + u) (sym (+Linv y)) ⟩
    x + ((- y) + y) ≡⟨ +Assoc _ _ _ ⟩
    (x - y) + y     ≡⟨ cong (λ u → u + y) p ⟩
    0r + y          ≡⟨ +Lid _ ⟩
    y               ∎

  0Selfinverse : - 0r ≡ 0r
  0Selfinverse = sym (implicitInverse _ _ (+Rid 0r))

  0Idempotent : 0r + 0r ≡ 0r
  0Idempotent = +Lid 0r

  +Idempotency→0 : (x : R) → x ≡ x + x → x ≡ 0r
  +Idempotency→0 x p =
    x               ≡⟨ sym (+Rid x) ⟩
    x + 0r          ≡⟨ cong (λ u → x + u) (sym (+Rinv _)) ⟩
    x + (x + (- x)) ≡⟨ +Assoc _ _ _ ⟩
    (x + x) + (- x) ≡⟨ cong (λ u → u + (- x)) (sym p) ⟩
    x + (- x)       ≡⟨ +Rinv _ ⟩
    0r              ∎

  -Idempotent : (x : R) → -(- x) ≡ x
  -Idempotent x =  - (- x)   ≡⟨ sym (implicitInverse (- x) x (+Linv _)) ⟩
                   x ∎

  0RightAnnihilates : (x : R) → x · 0r ≡ 0r
  0RightAnnihilates x =
              let x·0-is-idempotent : x · 0r ≡ x · 0r + x · 0r
                  x·0-is-idempotent =
                    x · 0r               ≡⟨ cong (λ u → x · u) (sym 0Idempotent) ⟩
                    x · (0r + 0r)        ≡⟨ ·Rdist+ _ _ _ ⟩
                    (x · 0r) + (x · 0r)  ∎
              in (+Idempotency→0 _ x·0-is-idempotent)

  0LeftAnnihilates : (x : R) → 0r · x ≡ 0r
  0LeftAnnihilates x =
              let 0·x-is-idempotent : 0r · x ≡ 0r · x + 0r · x
                  0·x-is-idempotent =
                    0r · x               ≡⟨ cong (λ u → u · x) (sym 0Idempotent) ⟩
                    (0r + 0r) · x        ≡⟨ ·Ldist+ _ _ _ ⟩
                    (0r · x) + (0r · x)  ∎
              in +Idempotency→0 _ 0·x-is-idempotent

  -DistR· : (x y : R) →  x · (- y) ≡ - (x · y)
  -DistR· x y = implicitInverse (x · y) (x · (- y))

                               (x · y + x · (- y)     ≡⟨ sym (·Rdist+ _ _ _) ⟩
                               x · (y + (- y))        ≡⟨ cong (λ u → x · u) (+Rinv y) ⟩
                               x · 0r                 ≡⟨ 0RightAnnihilates x ⟩
                               0r ∎)

  -DistL· : (x y : R) →  (- x) · y ≡ - (x · y)
  -DistL· x y = implicitInverse (x · y) ((- x) · y)

                              (x · y + (- x) · y     ≡⟨ sym (·Ldist+ _ _ _) ⟩
                              (x - x) · y            ≡⟨ cong (λ u → u · y) (+Rinv x) ⟩
                              0r · y                 ≡⟨ 0LeftAnnihilates y ⟩
                              0r ∎)

  -Swap· : (x y : R) → (- x) · y ≡ x · (- y)
  -Swap· _ _ = -DistL· _ _ ∙ sym (-DistR· _ _)

  -IsMult-1 : (x : R) → - x ≡ (- 1r) · x
  -IsMult-1 _ = sym (·Lid _) ∙ sym (-Swap· _ _)

  -Dist : (x y : R) → (- x) + (- y) ≡ - (x + y)
  -Dist x y =
    implicitInverse _ _
         ((x + y) + ((- x) + (- y)) ≡⟨ sym (+Assoc _ _ _) ⟩
          x + (y + ((- x) + (- y))) ≡⟨ cong
                                         (λ u → x + (y + u))
                                         (+Comm _ _) ⟩
          x + (y + ((- y) + (- x))) ≡⟨ cong (λ u → x + u) (+Assoc _ _ _) ⟩
          x + ((y + (- y)) + (- x)) ≡⟨ cong (λ u → x + (u + (- x)))
                                            (+Rinv _) ⟩
          x + (0r + (- x))           ≡⟨ cong (λ u → x + u) (+Lid _) ⟩
          x + (- x)                 ≡⟨ +Rinv _ ⟩
          0r ∎)

  translatedDifference : (x a b : R) → a - b ≡ (x + a) - (x + b)
  translatedDifference x a b =
              a - b                       ≡⟨ cong (λ u → a + u)
                                                  (sym (+Lid _)) ⟩
              (a + (0r + (- b)))          ≡⟨ cong (λ u → a + (u + (- b)))
                                                  (sym (+Rinv _)) ⟩
              (a + ((x + (- x)) + (- b))) ≡⟨ cong (λ u → a + u)
                                                  (sym (+Assoc _ _ _)) ⟩
              (a + (x + ((- x) + (- b)))) ≡⟨ (+Assoc _ _ _) ⟩
              ((a + x) + ((- x) + (- b))) ≡⟨ cong (λ u → u + ((- x) + (- b)))
                                                  (+Comm _ _) ⟩
              ((x + a) + ((- x) + (- b))) ≡⟨ cong (λ u → (x + a) + u)
                                                  (-Dist _ _) ⟩
              ((x + a) - (x + b)) ∎

  +Assoc-comm1 : (x y z : R) → x + (y + z) ≡ y + (x + z)
  +Assoc-comm1 x y z = +Assoc x y z ∙∙ cong (λ x → x + z) (+Comm x y) ∙∙ sym (+Assoc y x z)

  +Assoc-comm2 : (x y z : R) → x + (y + z) ≡ z + (y + x)
  +Assoc-comm2 x y z = +Assoc-comm1 x y z ∙∙ cong (λ x → y + x) (+Comm x z) ∙∙ +Assoc-comm1 y z x

  +ShufflePairs : (a b c d : R)
                → (a + b) + (c + d) ≡ (a + c) + (b + d)
  +ShufflePairs a b c d =
    (a + b) + (c + d) ≡⟨ +Assoc _ _ _ ⟩
    ((a + b) + c) + d ≡⟨ cong (λ u → u + d) (sym (+Assoc _ _ _)) ⟩
    (a + (b + c)) + d ≡⟨ cong (λ u → (a + u) + d) (+Comm _ _) ⟩
    (a + (c + b)) + d ≡⟨ cong (λ u → u + d) (+Assoc _ _ _) ⟩
    ((a + c) + b) + d ≡⟨ sym (+Assoc _ _ _) ⟩
    (a + c) + (b + d) ∎

  ·-assoc2 : (x y z w : R) → (x · y) · (z · w) ≡ x · (y · z) · w
  ·-assoc2 x y z w = ·Assoc (x · y) z w ∙ cong (_· w) (sym (·Assoc x y z))

module RingHoms where
  open IsRingHom

  idRingHom : (R : Ring ℓ) → RingHom R R
  fst (idRingHom R) = idfun (fst R)
  snd (idRingHom R) = makeIsRingHom refl (λ _ _ → refl) (λ _ _ → refl)

  compRingHom : {R S T : Ring ℓ} → RingHom R S → RingHom S T → RingHom R T
  fst (compRingHom f g) x = g .fst (f .fst x)
  snd (compRingHom f g) = makeIsRingHom (cong (g .fst) (pres1 (snd f)) ∙ pres1 (snd g))
                                        (λ x y → cong (g .fst) (pres+ (snd f) _ _) ∙ pres+ (snd g) _ _)
                                        (λ x y → cong (g .fst) (pres· (snd f) _ _) ∙ pres· (snd g) _ _)

  compIdRingHom : {R S : Ring ℓ} (φ : RingHom R S) → compRingHom (idRingHom R) φ ≡ φ
  compIdRingHom φ = RingHom≡ refl

  idCompRingHom : {R S : Ring ℓ} (φ : RingHom R S) → compRingHom φ (idRingHom S) ≡ φ
  idCompRingHom φ = RingHom≡ refl

  compAssocRingHom : {R S T U : Ring ℓ} (φ : RingHom R S) (ψ : RingHom S T) (χ : RingHom T U) →
                     compRingHom (compRingHom φ ψ) χ ≡ compRingHom φ (compRingHom ψ χ)
  compAssocRingHom _ _ _ = RingHom≡ refl

module RingHomTheory {R S : Ring ℓ} (φ : RingHom R S) where
  open RingTheory ⦃...⦄
  open RingStr ⦃...⦄
  open IsRingHom (φ .snd)
  private
    instance
      _ = R
      _ = S
      _ = snd R
      _ = snd S
    f = fst φ

  ker≡0→inj : ({x : ⟨ R ⟩} → f x ≡ 0r → x ≡ 0r)
            → ({x y : ⟨ R ⟩} → f x ≡ f y → x ≡ y)
  ker≡0→inj ker≡0 {x} {y} p = equalByDifference _ _ (ker≡0 path)
   where
   path : f (x - y) ≡ 0r
   path = f (x - y)     ≡⟨ pres+ _ _ ⟩
          f x + f (- y) ≡⟨ cong (f x +_) (pres- _) ⟩
          f x - f y     ≡⟨ cong (_- f y) p ⟩
          f y - f y     ≡⟨ +Rinv _ ⟩
          0r            ∎


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category

-- small indexed products of specific shapes

module Categories.Object.IndexedProducts {o ℓ e} (C : Category o ℓ e) where

open Category C
-- open Equiv

open import Level

open import Categories.Support.Equivalence using (Setoid; module Setoid)

import Categories.Object.Indexed as IObj
import Categories.Object.IndexedProduct as IProduct
import Categories.Morphism.Indexed as IArrow
import Categories.Morphisms as Morphisms

record IndexedProducts {c q} {Shape : Setoid c q} : Set (o ⊔ ℓ ⊔ e ⊔ c ⊔ q) where
  open IObj C Shape
  open IArrow C Shape
  open IProduct C
  module Fan-Setoid {V} (xs : Dust) = Setoid (fan-setoid V xs)
  open Fan-Setoid using () renaming (_≈_ to _[_≜_])

  field
    product : ∀ {As} → IndexedProduct Shape As

  ∏ : ∀ As → Obj
  ∏ As = IndexedProduct.∏ (product {As})

  -- ×-comm : ∀ {A B} → _≅_ C (A × B) (B × A)
  -- ×-comm = Commutative product product

  -- ×-assoc : ∀ {X Y Z} → _≅_ C (X × (Y × Z)) ((X × Y) × Z)
  -- ×-assoc = Associative product product product product

  -- Convenience!  well, sort of.
  module Product {As} = IndexedProduct {As = As} (product {As = As})
  open Product using (π; π[_]; π-cong; π▹_; uncurry; commute; commute∗; universal; universal∗; g-η; η; uncurry-cong; uncurry-cong∗; uncurry∘)

  -- assocˡ : ∀ {A B C} → (((A × B) × C) ⇒ (A × (B × C)))
  -- assocˡ = _≅_.g C ×-assoc

  -- assocʳ : ∀ {A B C} → ((A × (B × C)) ⇒ ((A × B) × C))
  -- assocʳ = _≅_.f C ×-assoc

  _⋉π : ∀ {As Bs} → (As ∗⇒∗ Bs) → (∏ As ⇒∗ Bs)
  _⋉π {As} {Bs} fs = _⋉_ {Ys = As} {Bs} fs (π {As})

  bundle : ∀ {As Bs} → (As ∗⇒∗ Bs) → (∏ As ⇒ ∏ Bs)
  bundle {As} {Bs} fs = uncurry {Bs} (_⋉π {As} {Bs} fs)

  -- TODO: this is probably harder to use than necessary because of this definition. Maybe make a version
  -- that doesn't have an explicit id in it, too?
  -- first : ∀ {A B C} → (A ⇒ B) → ((A × C) ⇒ (B × C))
  -- first f = f ⁂ id

  -- second : ∀ {A C D} → (C ⇒ D) → ((A × C) ⇒ (A × D))
  -- second g = id ⁂ g

  -- Just to make this more obvious
  .π▹bundle : ∀ {As Bs} {fs : As ∗⇒∗ Bs} → Bs [ π▹ bundle {As} {Bs} fs ≜ _⋉π {As} {Bs} fs ]
  π▹bundle {As} {Bs} {fs = fs} = commute∗ {Bs} (_⋉π {As} {Bs} fs)

  .π∘bundle : ∀ {As Bs} {fs : As ∗⇒∗ Bs} {x} → π[_] {Bs} x ∘ bundle {As} {Bs} fs ≡ (fs ‼ x) ∘ π[_] {As} x
  π∘bundle {As} {Bs} {fs = fs} = commute {Bs} (_⋉π {As} {Bs} fs)

  .bundle∘uncurry : ∀ {A Bs Cs} {fs : Bs ∗⇒∗ Cs} {gs : A ⇒∗ Bs} → bundle {Bs} {Cs} fs ∘ uncurry {Bs} gs ≡ uncurry {Cs} (_⋉_ {Ys = Bs} {Cs} fs gs)
  bundle∘uncurry {Bs = Bs} {Cs} {fs = fs} {gs} = Equiv.sym (universal {Cs} (_⋉_ {Ys = Bs} {Cs} fs gs) helper)
    where
    helper : ∀ {x} → π[_] {Cs} x ∘ (bundle {Bs} {Cs} fs ∘ uncurry {Bs} gs) ≡ (fs ‼ x) ∘ (gs ‼ x)
    helper {x} =
      begin
        π[_] {Cs} x ∘ (bundle {Bs} {Cs} fs ∘ uncurry {Bs} gs)
      ↑⟨ assoc ⟩
        (π[_] {Cs} x ∘ bundle {Bs} {Cs} fs) ∘ uncurry {Bs} gs
      ↓⟨ ∘-resp-≡ˡ (π∘bundle {Bs} {Cs} {fs = fs}) ⟩
        ((fs ‼ x) ∘ π[_] {Bs} x) ∘ uncurry {Bs} gs
      ↓⟨ assoc ⟩
        (fs ‼ x) ∘ (π[_] {Bs} x ∘ uncurry {Bs} gs)
      ↓⟨ ∘-resp-≡ʳ (commute {Bs} gs) ⟩
        (fs ‼ x) ∘ (gs ‼ x)
      ∎
      where
      open HomReasoning

  {-
  .first∘⟨⟩ : ∀ {A B C D} → {f : B ⇒ C} {f′ : A ⇒ B} {g′ : A ⇒ D} → first f ∘ ⟨ f′ , g′ ⟩ ≡ ⟨ f ∘ f′ , g′ ⟩
  first∘⟨⟩ {f = f} {f′} {g′} =
    begin
      first f ∘ ⟨ f′ , g′ ⟩
    ↓⟨ ⁂∘⟨⟩ ⟩
      ⟨ f ∘ f′ , id ∘ g′ ⟩
    ↓⟨ ⟨⟩-cong₂ refl identityˡ ⟩
      ⟨ f ∘ f′ , g′ ⟩
    ∎
    where
    open HomReasoning

  .second∘⟨⟩ : ∀ {A B D E} → {f′ : A ⇒ B} {g : D ⇒ E} {g′ : A ⇒ D} → second g ∘ ⟨ f′ , g′ ⟩ ≡ ⟨ f′ , g ∘ g′ ⟩
  second∘⟨⟩ {f′ = f′} {g} {g′} =
    begin
      second g ∘ ⟨ f′ , g′ ⟩
    ↓⟨ ⁂∘⟨⟩ ⟩
      ⟨ id ∘ f′ , g ∘ g′ ⟩
    ↓⟨ ⟨⟩-cong₂ identityˡ refl ⟩
      ⟨ f′ , g ∘ g′ ⟩
    ∎
    where
    open HomReasoning
  -}

  .bundle∘bundle : ∀ {As Bs Cs} → {fs : Bs ∗⇒∗ Cs} {gs : As ∗⇒∗ Bs} → (bundle {Bs} {Cs} fs) ∘ (bundle {As} {Bs} gs) ≡ bundle {As} {Cs} (_◽_ {As} {Bs} {Cs} fs gs)
  bundle∘bundle {As} {Bs} {Cs} {fs = fs} {gs} =
    begin
      (bundle {Bs} {Cs} fs) ∘ (bundle {As} {Bs} gs)
    ↓⟨ bundle∘uncurry {Bs = Bs} {Cs} {fs = fs} ⟩
      uncurry {Cs} (_⋉_ {Ys = Bs} {Cs} fs (_⋉_ {Ys = As} {Bs} gs (π {As})))
    ↑⟨ uncurry-cong∗ {Cs} {_} {_⋉_ {Ys = As} {Cs} (_◽_ {As} {Bs} {Cs} fs gs) (π {As})} {_⋉_ {Ys = Bs} {Cs} fs (_⋉_ {Ys = As} {Bs} gs (π {As}))} (assoc-◽⋉ {Ys = As} {Bs} {Cs} {fs} {gs} {π {As}}) ⟩
      (bundle {As} {Cs} (_◽_ {As} {Bs} {Cs} fs gs))
    ∎
    where
    open HomReasoning


------------------------------------------------------------------------
-- Code related to the paper "Compiling Programs with Erased
-- Univalence"
--
-- Nils Anders Danielsson
--
-- The paper is coauthored with Andreas Abel and Andrea Vezzosi.
------------------------------------------------------------------------

-- Most of the code referenced below can be found in modules that are
-- parametrised by a notion of equality. One can use them both with
-- Cubical Agda paths and with the Cubical Agda identity type family.

-- Note that the code does not follow the paper exactly. For instance,
-- some definitions use bijections (functions with quasi-inverses)
-- instead of equivalences.

-- An attempt has been made to track uses of univalence by passing
-- around explicit proofs of the univalence axiom (except in certain
-- README modules). However, some library code that is used does not
-- adhere to this convention (note that univalence is provable in
-- Cubical Agda), so perhaps some use of univalence is not tracked in
-- this way. On the other hand some library code that is not defined
-- in Cubical Agda passes around explicit proofs of function
-- extensionality.

-- Some other differences are mentioned below.

-- Note that there is a known problem with guarded corecursion in
-- Agda. Due to "quantifier inversion" (see "Termination Checking in
-- the Presence of Nested Inductive and Coinductive Types" by Thorsten
-- Altenkirch and myself) certain types may not have the expected
-- semantics when the option --guardedness is used. I expect that the
-- results would still hold if this bug were fixed, but because I do
-- not know what the rules of a fixed version of Agda would be I do
-- not know if any changes to the code would be required.

{-# OPTIONS --guardedness #-}

module README.Compiling-Programs-with-Erased-Univalence where

import Coherently-constant
import Colimit.Sequential
import Colimit.Sequential.Very-erased
import Equality.Path
import Equality.Path.Univalence
import Equivalence
import Equivalence.Erased
import Equivalence.Erased.Basics
import Equivalence.Erased.Contractible-preimages
import Equivalence.Half-adjoint
import Erased.Basics
import Erased.Cubical
import Erased.Level-1
import Erased.Stability
import H-level.Truncation.Propositional
import H-level.Truncation.Propositional.Completely-erased
import H-level.Truncation.Propositional.Erased
import H-level.Truncation.Propositional.Non-recursive
import H-level.Truncation.Propositional.Non-recursive.Erased
import H-level.Truncation.Propositional.One-step
import Preimage
import Univalence-axiom

import Lens.Non-dependent.Higher
import Lens.Non-dependent.Higher.Erased
import Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant
import Lens.Non-dependent.Higher.Coinductive
import Lens.Non-dependent.Higher.Coinductive.Erased
import Lens.Non-dependent.Higher.Coinductive.Small
import Lens.Non-dependent.Higher.Coinductive.Small.Erased

import README.Fst-snd

------------------------------------------------------------------------
-- 2: Cubical Agda

-- The functions cong and ext.

cong = Equality.Path.cong
ext  = Equality.Path.⟨ext⟩

-- The propositional truncation operator.
--
-- The current module uses --erased-cubical, so this operator, which
-- is defined using --cubical, can only be used in erased contexts.

@0 ∥_∥ : _
∥_∥ = H-level.Truncation.Propositional.∥_∥

-- The map function. This function is not defined in the same way as
-- in the paper, it is defined using a non-dependent eliminator.

@0 map : _
map = H-level.Truncation.Propositional.∥∥-map

-- The propositional truncation operator with an erased truncation
-- constructor.

∥_∥ᴱ = H-level.Truncation.Propositional.Erased.∥_∥ᴱ

-- Half adjoint equivalences. Note that, unlike in the paper, _≃_ is
-- defined as a record type.

Is-equivalence = Equivalence.Half-adjoint.Is-equivalence
_≃_            = Equivalence._≃_

-- Univalence. (This type family is not defined in exactly the same
-- way as in the paper.)

Univalence = Univalence-axiom.Univalence

-- A proof of univalence. The proof uses glue.

@0 univ : _
univ = Equality.Path.Univalence.univ

------------------------------------------------------------------------
-- 3: Postulating Erased Univalence

-- Erased.

Erased = Erased.Basics.Erased

-- []-cong for paths.

[]-cong = Erased.Cubical.[]-cong-Path

------------------------------------------------------------------------
-- 6.1: Equivalences with Erased Proofs

-- Equivalences with erased proofs. Note that, unlike in the paper,
-- _≃ᴱ_ is defined as a record type.

Is-equivalenceᴱ = Equivalence.Erased.Basics.Is-equivalenceᴱ
_≃ᴱ_            = Equivalence.Erased.Basics._≃ᴱ_
to              = Equivalence.Erased.Basics._≃ᴱ_.to
from            = Equivalence.Erased.Basics._≃ᴱ_.from
@0 to-from : _
to-from         = Equivalence.Erased.Basics._≃ᴱ_.right-inverse-of
@0 from-to : _
from-to         = Equivalence.Erased.Basics._≃ᴱ_.left-inverse-of

-- Erased≃ is stated a little differently.

Erased≃ = Erased.Level-1.Erased↔

-- Lemmas 41 and 42 are proved in modules parametrised by definitions
-- of []-cong, in the latter case []-cong is also assumed to satisfy
-- certain properties (that hold for the definition mentioned above).
-- Some definitions below are also defined in such modules.

Lemma-41 = Erased.Level-1.[]-cong₁.Erased-cong-≃
Lemma-42 = Equivalence.Erased.[]-cong.Σ-cong-≃ᴱ-Erased

-- The functions substᴱ and subst.

substᴱ = Erased.Level-1.[]-cong₁.substᴱ
subst  = Equality.Path.subst

-- Lemmas 45–47.

Lemma-45 = Equivalence.Erased.[]-cong.drop-⊤-left-Σ-≃ᴱ-Erased
Lemma-46 = Equivalence.Erased.Σ-cong-≃ᴱ
Lemma-47 = Equivalence.Erased.drop-⊤-left-Σ-≃ᴱ

------------------------------------------------------------------------
-- 6.2: A Non-recursive Definition of the Propositional Truncation
-- Operator

-- ∥_∥¹ and Colimit.

@0 ∥_∥¹ : _
∥_∥¹ = H-level.Truncation.Propositional.One-step.∥_∥¹
@0 Colimit : _
Colimit = Colimit.Sequential.Colimit

-- Lemma 50.

@0 Lemma-50 : _
Lemma-50 = Colimit.Sequential.universal-property

-- ∥_∥¹-out and ∥_∥ᴺ.

@0 ∥_∥¹-out : _
∥_∥¹-out = H-level.Truncation.Propositional.One-step.∥_∥¹-out-^
@0 ∥_∥ᴺ : _
∥_∥ᴺ = H-level.Truncation.Propositional.Non-recursive.∥_∥

-- ∥_∥ᴺ and ∥_∥ are pointwise equivalent.

@0 ∥∥ᴺ≃∥∥ : _
∥∥ᴺ≃∥∥ = H-level.Truncation.Propositional.Non-recursive.∥∥≃∥∥

-- Colimitᴱ.

Colimitᴱ = Colimit.Sequential.Very-erased.Colimitᴱ

-- Lemma 54.

Lemma-54 = Colimit.Sequential.Very-erased.universal-property

-- ∥_∥ᴺᴱ.

∥_∥ᴺᴱ = H-level.Truncation.Propositional.Non-recursive.Erased.∥_∥ᴱ

-- Lemma 56 (or rather its inverse).

Lemma-56 = H-level.Truncation.Propositional.Erased.∥∥ᴱ≃∥∥ᴱ

------------------------------------------------------------------------
-- 6.3: Higher Lenses with Erased Proofs

-- Lensᴱ, get and set.

@0 Lensᴱ : _
Lensᴱ = Lens.Non-dependent.Higher.Lens
@0 get : _
get = Lens.Non-dependent.Higher.Lens.get
@0 set : _
set = Lens.Non-dependent.Higher.Lens.set

-- Lensᴱᴱ.

Lensᴱᴱ = Lens.Non-dependent.Higher.Erased.Lens

-- The function _⁻¹_.

_⁻¹_ = Preimage._⁻¹_

-- Lens^C (defined using a record type).

@0 Lens^C : _
Lens^C = Lens.Non-dependent.Higher.Coinductive.Small.Lens

-- Coherently-constant^C.

@0 Coherently-constant^C : _
Coherently-constant^C =
  Lens.Non-dependent.Higher.Coinductive.Small.Coherently-constant

-- Lens^CE (with the field name get⁻¹-coherently-constant instead of
-- cc).

Lens^CE = Lens.Non-dependent.Higher.Coinductive.Small.Erased.Lens

------------------------------------------------------------------------
-- 6.4: The Definitions Are Equivalent

-- Lemma 65 (or rather its inverse), and a proof (in an erased
-- context) showing that Lemma 65 preserves getters and setters.
--
-- Lemma 65 and some other lemmas use arguments of type Block s (for
-- some string s). This type is equivalent to the unit type. These
-- arguments are used to block definitions from being unfolded by the
-- type-checker.

Lemma-65 =
  Lens.Non-dependent.Higher.Coinductive.Small.Erased.Lens≃ᴱLensᴱ
@0 Lemma-65-preserves-getters-and-setters : _
Lemma-65-preserves-getters-and-setters =
  Lens.Non-dependent.Higher.Coinductive.Small.Erased.Lens≃ᴱLensᴱ-preserves-getters-and-setters

-- Lens₁ᴱ and Lens₂ᴱ.

Lens₁ᴱ = Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant.Lens
Lens₂ᴱ = Lens.Non-dependent.Higher.Coinductive.Erased.Lens

-- The function _⁻¹ᴱ_.

_⁻¹ᴱ_ = Equivalence.Erased.Contractible-preimages._⁻¹ᴱ_

-- Coherently-constant₁ᴱ, Coherently-constant, Coherently-constant₂ᴱ,
-- Coherently-constant₂^C and constant.

Coherently-constant₁ᴱ =
  Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant.Coherently-constant
@0 Coherently-constant : _
Coherently-constant = Coherently-constant.Coherently-constant
Coherently-constant₂ᴱ =
  Lens.Non-dependent.Higher.Coinductive.Erased.Coherently-constant
@0 Coherently-constant₂^C : _
Coherently-constant₂^C =
  Lens.Non-dependent.Higher.Coinductive.Coherently-constant
@0 constant : _
constant = Lens.Non-dependent.Higher.Coinductive.constant

-- Lemmas 74–77.

Lemma-74 = Erased.Stability.[]-cong.Erased-other-singleton≃ᴱ⊤
Lemma-75 = Lens.Non-dependent.Higher.Coinductive.Erased.∥∥ᴱ→≃
Lemma-76 = Equivalence.Erased.other-singleton-with-Π-≃ᴱ-≃ᴱ-⊤
Lemma-77 = H-level.Truncation.Propositional.Erased.Σ-Π-∥∥ᴱ-Erased-≡-≃

------------------------------------------------------------------------
-- 6.5: Compilation of Lenses

-- A slightly more general variant of sndᴱ.

sndᴱ = Lens.Non-dependent.Higher.Erased.snd

-- Lemma 79.

Lemma-79 =
  H-level.Truncation.Propositional.Completely-erased.Erased-∥∥×≃

-- A slightly more general variant of snd^C.

snd^C = README.Fst-snd.snd-with-space-leak

-- Lemma 81.

Lemma-81 =
  Lens.Non-dependent.Higher.Coinductive.Small.Erased.with-other-setter

-- A slightly more general variant of the variant of snd^C with a
-- changed setter.

snd^C-with-changed-setter = README.Fst-snd.snd


{-
Comments of the following form are parsed automatically by [extract.py] in order
to convert them to LaTeX and include them in the pdf.

{-<nameofbloc>-}
code
code
code
{-</>-}

-}

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

open import PathInduction
open import Pushout

module JamesTwoMaps {i} (A : Type i) (⋆A : A) where

-- We first define [J], [ι], [α] and [β].
-- We need [JS] to make the termination checker happy.

{-<defJiab>-}
J   : ℕ → Type i
JS  : ℕ → Type i
ι   : (n : ℕ) → J n → JS n
α   : (n : ℕ) → A → J n → JS n
β   : (n : ℕ) (x : J n) → α n ⋆A x == ι n x

data J0 : Type i where
  ε : J0

J 0 = J0
J (S n) = JS n

JS 0 = A
JS (S n) = Pushout (span (A × JS n) (JS n) X f g)  module JS where

  X : Type i
  X = Pushout (span (A × J n) (JS n) (J n) (λ x → (⋆A , x)) (ι n))

  f : X → A × JS n
  f = Pushout-rec (λ {(a , x) → (a , ι n x)}) (λ y → (⋆A , y)) (λ x → idp)

  g : X → JS n
  g = Pushout-rec (λ {(a , x) → α n a x}) (λ y → y) (β n)

ι 0 ε = ⋆A
ι (S n) x = inr x

α 0 a ε = a
α (S n) a x = inl (a , x)

β 0 ε = idp
β (S n) x = push (inr x)
{-</>-}

-- We can now define [γ] and [η]

{-<defge>-}
γ : (n : ℕ) (a : A) (x : J n) → α (S n) a (ι n x) == ι (S n) (α n a x)
γ n a x = push (inl (a , x))

η : (n : ℕ) (x : J n)
  → Square (γ n ⋆A x) idp (ap (ι (S n)) (β n x)) (β (S n) (ι n x))
η n x = natural-square push (push x) α-f-push ι-g-push  where

  α-f-push : ap (uncurry (α (S n)) ∘ JS.f n) (push x) == idp
  α-f-push =  ap-∘ (uncurry (α (S n))) (JS.f n) (push x)
              ∙ ap (ap (uncurry (α (S n)))) (push-β _)

  ι-g-push : ap (ι (S n) ∘ JS.g n) (push x) == ap (ι (S n)) (β n x)
  ι-g-push =  ap-∘ (ι (S n)) (JS.g n) (push x)
              ∙ ap (ap (ι (S n))) (push-β _)
{-</>-}

-- We define the more convenient elimination principle for JSS n:

{-<JSSElim>-}
module _ {l} (n : ℕ) {P : JS (S n) → Type l}
  (ι* : (x : JS n) → P (ι (S n) x))
  (α* : (a : A) (x : JS n) → P (α (S n) a x))
  (β* : (x : JS n) → α* ⋆A x == ι* x [ P ↓ β (S n) x ])
  (γ* : (a : A) (x : J n) → α* a (ι n x) == ι* (α n a x) [ P ↓ γ n a x ])
  (η* : (x : J n) → SquareOver P (η n x)  (γ* ⋆A x)
                                          idp
                                          (↓-ap-in P inr (apd ι* (β n x)))
                                          (β* (ι n x)))
  where

  JSS-elim : (x : JS (S n)) → P x
  JSS-elim = Pushout-elim (uncurry α*) ι* JSS-elim-push  where

    JSS-elim-push : (x : JS.X n) → uncurry α* (JS.f n x) == ι* (JS.g n x) [ P ↓ push x ]
    JSS-elim-push = Pushout-elim (uncurry γ*) β*
          (λ x → ↓-PathOver-from-square
               (adapt-SquareOver
                 (↓-ap-in-coh P (uncurry α*)) (↓-ap-in-coh P ι*)
                 (η* x)))
{-</>-}

{-<JSSRec>-}
module _ {l} (n : ℕ) {X : Type l}
  (ι* : JS n → X)
  (α* : A → JS n → X)
  (β* : (x : JS n) → α* ⋆A x == ι* x)
  (γ* : (a : A) (x : J n) → α* a (ι n x) == ι* (α n a x))
  (η* : (x : J n) → Square (γ* ⋆A x) idp (ap ι* (β n x)) (β* (ι n x)))
  where

  JSS-rec : JS (S n) → X
  JSS-rec = Pushout-rec (uncurry α*) ι* JSS-rec-push  module _ where

    JSS-rec-push : (c : JS.X n) → uncurry α* (JS.f n c) == ι* (JS.g n c)
    JSS-rec-push = Pushout-elim (uncurry γ*) β* (λ x → ↓-='-from-square (α-f-push x) (ι-g-push x) (η* x))  where

      α-f-push : (x : J n) → ap ((uncurry α*) ∘ (JS.f n)) (push x) == idp
      α-f-push x = ap-∘ _ _ (push x) ∙ ap (ap (uncurry α*)) (push-β x)

      ι-g-push : (x : J n) → ap (ι* ∘ (JS.g n)) (push x) == ap ι* (β n x)
      ι-g-push x = ap-∘ ι* _ (push x) ∙ ap (ap ι*) (push-β x)

module _ {l} (n : ℕ) {X : Type l}
  {ι* : JS n → X}
  {α* : A → JS n → X}
  {β* : (x : JS n) → α* ⋆A x == ι* x}
  {γ* : (a : A) (x : J n) → α* a (ι n x) == ι* (α n a x)}
  {η* : (x : J n) → Square (γ* ⋆A x) idp (ap ι* (β n x)) (β* (ι n x))}
  where

  private JSS-rec' = JSS-rec n ι* α* β* γ* η*
  private JSS-rec-push' = JSS-rec-push n ι* α* β* γ* η*

  β-β : (x : JS n) → ap JSS-rec' (β (S n) x) == β* x
  β-β x = push-β (inr x)

  γ-β : (a : A) (x : J n) → ap JSS-rec' (γ n a x) == γ* a x
  γ-β a x = push-β (inl (a , x))

  η-β : (x : J n) → FlatCube (ap-square JSS-rec' (η n x))
                             (η* x)
                             (γ-β ⋆A x)
                             idp
                             (∘-ap JSS-rec' inr (β n x))
                             (β-β (ι n x))
  η-β x = adapt-flatcube ∙idp
                         (& coh (ap-∘3 JSS-rec' inl  _ (push x)) (natural-square (ap-∘ JSS-rec' inl)  (push-β x) idp (ap-∘ (ap JSS-rec') (ap inl)  _)) (ap-∙ _ _ _))
                         (& coh (ap-∘3 JSS-rec' inr _ (push x)) (natural-square (ap-∘ JSS-rec' inr) (push-β x) idp (ap-∘ (ap JSS-rec') (ap inr) _)) (ap-∙ _ _ _))
                         ∙idp
            ((& (ap-square-natural-square JSS-rec') (push x) push idp idp
            /∙³ & natural-square-homotopy push-β (push x)
            ∙fc & natural-square== JSS-rec-push' (push x) idp idp
            ∙³/ natural-square-β JSS-rec-push' (push x) (push-βd x)))  where

    coh : Coh ({A : Type l} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} (sq1 : Square p q r s)
                {e : A} {t : c == e} {f : A} {u : d == f} {v : e == f} (sq2 : Square s t u v)
                {ru : b == f} (ru= : ru == r ∙ u)
                → idp ∙ ! (p ∙ ru) ∙ q ∙ t == ! v)
    coh = path-induction
{-</>-}

-- Let’s now define JA

{-<defJA>-}
postulate
  JA  : Type i
  εJ  : JA
  αJ  : A → JA → JA
  δJ  : (x : JA) → x == αJ ⋆A x

module _ {l} {P : JA → Type l}
  (εJ*  : P εJ)
  (αJ*  : (a : A) (x : JA) → P x → P (αJ a x))
  (δJ*  : (x : JA) (y : P x) → y == αJ* ⋆A x y [ P ↓ (δJ x)]) where

  postulate
    JA-elim  : (x : JA) → P x
    εJ-β     : JA-elim εJ ↦ εJ*
    αJ-β     : (a : A) (x : JA) → JA-elim (αJ a x) ↦ αJ* a x (JA-elim x)
    {-# REWRITE εJ-β #-}
    {-# REWRITE αJ-β #-}
    δJ-βd'   : (x : JA) → apd JA-elim (δJ x) == δJ* x (JA-elim x)
{-</>-}

δJ-βd : ∀ {l} {P : JA → Type l}
  {εJ* : P εJ}
  {αJ* : (a : A) (x : JA) → P x → P (αJ a x)}
  {δJ* : (x : JA) (y : P x) → y == αJ* ⋆A x y [ P ↓ (δJ x)]}
  → (x : JA) → apd (JA-elim εJ* αJ* δJ*) (δJ x) == δJ* x (JA-elim εJ* αJ* δJ* x)
δJ-βd = δJ-βd' _ _ _

JA-rec : ∀ {l} {P : Type l}
  (εJ* : P)
  (αJ* : (a : A) → P → P)
  (δJ* : (y : P) → y == αJ* ⋆A y)
  → JA → P
JA-rec εJ* αJ* δJ* = JA-elim εJ* (λ a x y → αJ* a y) (λ x y → ↓-cst-in (δJ* y))

δJ-β : ∀ {l} {P : Type l}
  {εJ* : P}
  {αJ* : (a : A) → P → P}
  {δJ* : (y : P) → y == αJ* ⋆A y}
  → (x : JA) → ap (JA-rec εJ* αJ* δJ*) (δJ x) == δJ* (JA-rec εJ* αJ* δJ* x)
δJ-β x = apd=cst-in (δJ-βd x)

-- We define the structure on JA

{-<defgJeJ>-}
module _ {i} {X : Type i} (α : A → X → X) (δ : (x : X) → x == α ⋆A x) where

  γ-ify : (a : A) (x : X) → α a (α ⋆A x) == α ⋆A (α a x)
  γ-ify a x = ! (ap (α a) (δ x)) ∙ δ (α a x)

  η-ify : (x : X) → γ-ify ⋆A x == idp
  η-ify = λ x → & coh (natural-square δ (δ x) (ap-idf (δ x)) idp)  module ηIfy where

    coh : Coh  ({A : Type i} {a b : A} {p : a == b}
               {c : A} {q r : b == c} (sq : Square p p q r)
               → ! q ∙ r == idp)
    coh = path-induction

γJ : (a : A) (x : JA) → αJ a (αJ ⋆A x) == αJ ⋆A (αJ a x)
γJ = γ-ify αJ δJ

ηJ : (x : JA) → γJ ⋆A x == idp
ηJ = η-ify αJ δJ
{-</>-}

-- The functions [inJS-ι], [inJS-α] and [inJS-β] are to be thought of as
-- reduction rules.
{-<definJpushJ>-}
inJ   : (n : ℕ) → J n → JA
inJS  : (n : ℕ) → J (S n) → JA

inJS-ι  : (n : ℕ) (x : J n) → inJS n (ι n x) == αJ ⋆A (inJ n x)
inJS-α  : (n : ℕ) (a : A) (x : J n) → inJS n (α n a x) == αJ a (inJ n x)
inJS-β  : (n : ℕ) (x : J n) → Square (ap (inJS n) (β n x)) (inJS-α n ⋆A x) (inJS-ι n x) idp

inJ 0 ε = εJ
inJ (S n) x = inJS n x

inJS 0 a = αJ a εJ
inJS (S n) = JSS-rec n ι* α* β* γ* η*  module InJS where

  ι* : JS n → JA
  ι* x = αJ ⋆A (inJS n x)

  α* : A → JS n → JA
  α* a x = αJ a (inJS n x)

  β* : (x : JS n) → α* ⋆A x == ι* x
  β* x = idp

  γ* : (a : A) (x : J n) → α* a (ι n x) == ι* (α n a x)
  γ* a x = ap (αJ a) (inJS-ι n x) ∙ γJ a (inJ n x) ∙ ! (ap (αJ ⋆A) (inJS-α n a x))

  η* : (x : J n) → Square (γ* ⋆A x) idp (ap (αJ ⋆A ∘ inJS n) (β n x)) (β* (ι n x))
  η* x = & coh  (ηJ (inJ n x))
                (ap-square (αJ ⋆A) (inJS-β n x))
                (ap-∘ (αJ ⋆A) (inJS n) _)  module η* where

        coh :  Coh  ({A : Type i} {a b : A} {p : a == b} {c : A} {r : c == b}
                    {q : b == b} (q= : q == idp) {t : c == a} (sq : Square t r p idp)
                    {t' : c == a} (t= : t' == t)
               → Square (p ∙ q ∙ ! r) idp t' idp)
        coh = path-induction

inJS-ι 0 ε = idp
inJS-ι (S n) x = idp

inJS-α 0 a ε = idp
inJS-α (S n) a x = idp

inJS-β 0 ε = ids
inJS-β (S n) x = horiz-degen-square (push-β _)

pushJ : (n : ℕ) (x : J n) → inJ n x == inJ (S n) (ι n x)
pushJ n x = δJ (inJ n x) ∙ ! (inJS-ι n x)
{-</>-}

-- [inJS-β] applied for [n = S n] gives a degenerate square.
-- It is sometimes more convenient to see it as a 2-path as belown.
inJS-βS : (n : ℕ) (x : J (S n)) → ap (inJS (S n)) (β (S n) x) == idp
inJS-βS n x = push-β _

-- We give reduction rules for [inJS (S n)] applied to [γ] and [η] which are
-- more convenient to use

inJSS-γ : (n : ℕ) (a : A) (x : J n) → Square (ap (inJS (S n)) (γ n a x)) (ap (αJ a) (inJS-ι n x)) (ap (αJ ⋆A) (inJS-α n a x)) (γJ a (inJ n x))
inJSS-γ n a x = & coh (γ-β n a x)  module InJSγ where

  coh : Coh ({A : Type i} {a c : A} {q : a == c} {d : A} {s : c == d} {b : A} {r : b == d} {p : a == b}
        → p == q ∙ s ∙ ! r
        → Square p q r s)
  coh = path-induction

ap-inJSS-ι : (n : ℕ) {x y : J (S n)} (p : x == y) → ap (inJS (S n)) (ap (ι (S n)) p) == ap (αJ ⋆A) (ap (inJS n) p)
ap-inJSS-ι n p = ∘-ap (inJS (S n)) (ι (S n)) p ∙ ap-∘ (αJ ⋆A) (inJS n) p

inJSS-η : (n : ℕ) (x : J n) → Cube (ap-square (inJS (S n)) (η n x))
                                   (horiz-degen-square (ηJ (inJ n x)))
                                   (inJSS-γ n ⋆A x)
                                   vid-square
                                   (ap-inJSS-ι n (β n x) |∙ ap-square (αJ ⋆A) (inJS-β n x))
                                   (inJS-βS n (ι n x) |∙ vid-square)
inJSS-η n x = & coh (η-β n x)  where

  coh : {A : Type i} {a : A} → Coh ({r : a == a} {right : r == idp}
        {b : A} {s : b == a} {c : A} {t : b == c} {u : c == c} {to : u == idp}
        {s' : b == a} {down : s == s'} {s'' : b == a} {down' : s' == s''}
        {p : a == c} {down2 : Square s'' t p idp}
        {q : a == b} {sq : q == p ∙ u ∙ ! t} {from : Square q idp s r}
        → FlatCube from (& (InJS.η*.coh n x) to down2 down') sq idp down right
        → Cube from (horiz-degen-square to) (& (InJSγ.coh n ⋆A x) sq) vid-square ((down ∙ down') |∙ down2) (right |∙ vid-square))
  coh = path-induction

-- This function is used to apply a function to the result of [inJSS-η]
ap-shapeInJSη : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a : A}
  → Coh ({r : a == a} {right : r == idp} {b : A} {q : a == b}
  {c : A} {p : a == c} {u : c == c} {to : u == idp} {t : b == c} {left : Square q p t u}
  {s' : b == a} {down3 : Square s' t p idp} {s : b == a} {down1 : s == s'}
  {from : Square q idp s r}
  → Cube from (horiz-degen-square to) left vid-square (down1 |∙ down3) (right |∙ vid-square)
  → {ft : f b == f c} (ft= : ap f t == ft) {fp : f a == f c} (fp= : ap f p == fp)
  → Cube (ap-square f from) (horiz-degen-square (ap (ap f) to))
         (adapt-square (ap-square f left) fp= ft=) vid-square
         (adapt-square (ap (ap f) down1 |∙ ap-square f down3) ft= fp=) (ap (ap f) right |∙ vid-square))
ap-shapeInJSη f = path-induction

-- Definition of J∞A

{-<defJiA>-}
postulate
  J∞A    : Type i
  in∞    : (n : ℕ) (x : J n) → J∞A
  push∞  : (n : ℕ) (x : J n) → in∞ n x == in∞ (S n) (ι n x)

module _ {l} {P : J∞A → Type l}
  (in∞*    : (n : ℕ) (x : J n) → P (in∞ n x))
  (push∞*  : (n : ℕ) (x : J n) → in∞* n x == in∞* (S n) (ι n x) [ P ↓ (push∞ n x) ])  where

  postulate
    J∞A-elim   : (x : J∞A) → P x
    in∞-β      : (n : ℕ) (x : J n) → J∞A-elim (in∞ n x) ↦ in∞* n x
    {-# REWRITE in∞-β #-}
    push∞-βd'  : (n : ℕ) (x : J n) → apd J∞A-elim (push∞ n x) == push∞* n x
{-</>-}

push∞-βd : ∀ {l} {P : J∞A → Type l}
  {in∞* : (n : ℕ) (x : J n) → P (in∞ n x)}
  {push∞* : (n : ℕ) (x : J n) → in∞* n x == in∞* (S n) (ι n x) [ P ↓ (push∞ n x) ]}
  → (n : ℕ) (x : J n) → apd (J∞A-elim in∞* push∞*) (push∞ n x) == push∞* n x
push∞-βd = push∞-βd' _ _

J∞A-rec : ∀ {l} {P : Type l}
  (in∞* : (n : ℕ) (x : J n) → P)
  (push∞* : (n : ℕ) (x : J n) → in∞* n x == in∞* (S n) (ι n x))
  → J∞A → P
J∞A-rec in∞* push∞* = J∞A-elim in∞* (λ n x → ↓-cst-in (push∞* n x))

push∞-β : ∀ {l} {P : Type l}
  {in∞* : (n : ℕ) (x : J n) → P}
  {push∞* : (n : ℕ) (x : J n) → in∞* n x == in∞* (S n) (ι n x)}
  → (n : ℕ) (x : J n) → ap (J∞A-rec in∞* push∞*) (push∞ n x) == push∞* n x
push∞-β n x = apd=cst-in (push∞-βd n x)

-- Structure on J∞A

{-<defstructinf>-}
ε∞ : J∞A
ε∞ = in∞ 0 ε

α∞ : A → J∞A → J∞A
α∞ a = J∞A-rec α∞-in∞ α∞-push∞  module _ where

  α∞-in∞ : (n : ℕ) (x : J n) → J∞A
  α∞-in∞ n x = in∞ (S n) (α n a x)

  α∞-push∞ : (n : ℕ) (x : J n) → α∞-in∞ n x == α∞-in∞ (S n) (ι n x)
  α∞-push∞ n x = push∞ (S n) (α n a x) ∙ ! (ap (in∞ (S (S n))) (γ n a x))

δ∞ : (x : J∞A) → x == α∞ ⋆A x
δ∞ = J∞A-elim δ∞-in∞ (λ n x → ↓-='-from-square (ap-idf (push∞ n x)) idp (δ∞-push∞ n x))
  module _ where

  δ∞-in∞ : (n : ℕ) (x : J n) → in∞ n x == α∞ ⋆A (in∞ n x)
  δ∞-in∞ n x = push∞ n x ∙ ! (ap (in∞ (S n)) (β n x))

  δ∞-push∞ : (n : ℕ) (x : J n) → Square  (δ∞-in∞ n x)
                                         (push∞ n x)
                                         (ap (α∞ ⋆A) (push∞ n x))
                                         (δ∞-in∞ (S n) (ι n x))
  δ∞-push∞ = λ n x →
    & coh  (push∞ n x)
           (ap-square (in∞ (S (S n))) (η n x))
           (natural-square (push∞ (S n)) (β n x) idp (ap-∘ _ _ _))
           (push∞-β n x)
             module δ∞Push∞ where

    coh : Coh  ({A : Type i} {a b : A} (p : a == b) {d : A} {s : d == b}
               {c : A} {r : b == c} {f : A} {u : f == c} {e : A} {t : e == c}
               {w : f == e} (eta : Square w idp t u)
               {v : d == e} (nat : Square v s t r)
               {vw : d == f} (vw= : vw == v ∙ ! w)
               → Square (p ∙ ! s) p vw (r ∙ ! u))
    coh = path-induction
{-</>-}

    ap-coh : {A B : Type i} (g : A → B) →
             Coh ({a b : A} {p : a == b} {d : A} {s : d == b}
                 {c : A} {r : b == c} {f : A} {u : f == c} {e : A} {t : e == c}
                 {w : f == e} {eta : Square w idp t u}
                 {v : d == e} {nat : Square v s t r}
                 {vw : d == f} {vw= : vw == v ∙ ! w}
                 → FlatCube (ap-square g (& coh p eta nat vw=))
                            (& coh (ap g p) (ap-square g eta) (ap-square g nat) (ap-shape-∙! g vw=))
                            (ap-∙! g p s) idp idp (ap-∙! g r u))
    ap-coh g = path-induction

ap-α∞-in∞ : (n : ℕ) (a : A) {x y : J n} (p : x == y) → ap (α∞ a) (ap (in∞ n) p) == ap (in∞ (S n)) (ap (α n a) p)
ap-α∞-in∞ n a p = ∘-ap _ _ _ ∙ ap-∘ _ _ _

δ∞-in∞-β : (n : ℕ) (x : J n) → Square (δ∞ (in∞ n x)) idp (ap (in∞ (S n)) (β n x)) (push∞ n x)
δ∞-in∞-β = λ n x → & coh  module δ∞Inβ where

  coh : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : c == b} → Square (p ∙ ! q) idp q p)
  coh = path-induction

-- [γ∞] and the reduction rule for [γ∞ a (in∞ n x)] (3.2.6)

{-<gammainfin>-}
γ∞ : (a : A) (x : J∞A) → α∞ a (α∞ ⋆A x) == α∞ ⋆A (α∞ a x)
γ∞ = γ-ify α∞ δ∞

γ∞-in  : (a : A) (n : ℕ) (x : J n)
       → Square  (γ∞ a (in∞ n x))
                 (ap (in∞ (S (S n))) (ap (α (S n) a) (β n x)))
                 (ap (in∞ (S (S n))) (β (S n) (α n a x)))
                 (ap (in∞ (S (S n))) (γ n a x))
γ∞-in = λ a n x → & coh (push∞-β n x) (ap-∙! _ _ _) (ap-α∞-in∞ (S n) a (β n x))
                  module γ∞In where

  coh : Coh  ({A : Type i} {a d : A} {r : a == d} {b : A} {s : b == d}
             {c : A} {t' : c == b} {e : A} {u : e == d}
             {rs' : a == b} (rs= : rs' == r ∙ ! s)
             {fpq : a == c} (fpq= : fpq == rs' ∙ ! t')
             {t : c == b} (t= : t' == t)
             → Square (! fpq ∙ (r ∙ ! u)) t u s)
  coh = path-induction
{-</>-}

-- [η∞] and the reduction rule for [η∞ a (in∞ n x)] (3.2.7)

comp-square : {A : Type i} {a b c : A} {p : a == b} {q : b == c} → Square idp p (p ∙ q) q
comp-square {p = idp} {q = idp} = ids

skew : ∀ {i} {A : Type i} {a b c d : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} → Square p q r s → Square idp q (p ∙ r) s
skew ids = ids

ope1 : {A B : Type i} (f : A → B) {a b c : A} {p : a == b} {q : c == b}
       {fp : _} (fp= : ap f p == fp)
       {fq : _} (fq= : ap f q == fq)
       {fpq : _} (fpq= : ap f (p ∙ ! q) == fpq)
       → fpq == fp ∙ ! fq
ope1 f {p = idp} {q = idp} idp idp idp = idp

_∙!²_ : {A : Type i} {a b c : A} {p p' : a == b} (p= : p == p') {q q' : c == b} (q= : q == q')
        → (p ∙ ! q) == (p' ∙ ! q')
idp ∙!² idp = idp

ope1-idf : {A B : Type i} (f : A → B) → Coh ({b c : A} {q : c == b} {a : B} {p : a == f b}
         → ope1 (λ z → z) (ap-idf p) (∘-ap (λ z → z) f q ∙ idp) (ap-idf (p ∙ ! (ap f q))) == idp)
ope1-idf f = path-induction

natural-square-∙! : {A B : Type i} {a b c : A} (p : a == b) (q : c == b) → Coh ({f g : A → B} (h : (a : A) → f a == g a)
         {fp : _} {fp= : ap f p == fp}
         {gp : _} {gp= : ap g p == gp}
         {fq : _} {fq= : ap f q == fq}
         {gq : _} {gq= : ap g q == gq}
         {fpq : _ } {fpq= : ap f (p ∙ ! q) == fpq}
         {gpq : _ } {gpq= : ap g (p ∙ ! q) == gpq}
         → FlatCube (natural-square h (p ∙ ! q) fpq= gpq=) (natural-square h p fp= gp= ∙□ !² (natural-square h q fq= gq=)) idp (ope1 f fp= fq= fpq=) (ope1 g gp= gq= gpq=) idp)
natural-square-∙! {a = a} idp idp = path-induction

vcomp! : {A : Type i} {a b c d e f : A} {p : a == b} {q : a == c} {r : b == d} {s : c == d} {t : e == b} {u : f == d} {v : e == f}
         (sq1 : Square p q r s) (sq2 : Square t v r u)
       → Square (p ∙ ! t) q v (s ∙ ! u)
vcomp! {t = idp} ids ids = ids

natural-square∙! : {A B : Type i} {a b : A} (p : a == b)
       → Coh ({f g : A → B} (k : (a : A) → f a == g a) {h : A → B} (l : (a : A) → h a == g a)
              {fp : _} {fp= : ap f p == fp}
              {gp : _} {gp= : ap g p == gp}
              {hp : _} {hp= : ap h p == hp}
             → natural-square (λ x → k x ∙ ! (l x)) p fp= hp= == vcomp! (natural-square k p fp= gp=) (natural-square l p hp= gp=))
natural-square∙! {a = a} idp = path-induction

η∞ : (x : J∞A) → γ∞ ⋆A x == idp
η∞ = η-ify α∞ δ∞

η∞-in  : (n : ℕ) (x : J n)
       → Cube  (horiz-degen-square (η∞ (in∞ n x)))
               (ap-square (in∞ (S (S n))) (η n x))
               (γ∞-in ⋆A n x)
               vid-square
               comp-square
               (skew (ap-square (in∞ (S (S n))) (natural-square (β (S n)) (β n x) idp idp)))
η∞-in n x = & coh  (push∞-β n x)
                   (& (coh-ope1 (α∞ ⋆A)))
                   (& (ope1-idf (in∞ (S n))))
                   (natural-square-β δ∞ (push∞ n x) (push∞-βd n x))
                   (& (ap-square-natural-square (in∞ (S (S n)))) (β n x) (β (S n)) ∙idp ∙idp)
                   (& (natural-square∙! (β n x)) (push∞ (S n)) (ap (in∞ (S (S n))) ∘ β (S n)))
                   (& (natural-square-∘ (β n x) (in∞ (S n))) δ∞ idp idp)
                   (& (natural-square-∙! (push∞ n x) (ap (in∞ (S n)) (β n x))) δ∞)
                where

  coh-ope1 : {A B : Type i} (f : A → B)
           → Coh ({x y : A} {p : x == y}
                  {z : A} {q : z == y} {fq : f z == f y} {r : ap f q == fq}
                  → ap-∙! f p q == ope1 f idp r idp ∙ (idp ∙!² ! r))
  coh-ope1 f = path-induction

  -- X = apin∞SS
  coh : Coh ({A : Type i} {a b : A} {push∞Sα : a == b} {c : A} {apin∞Sβ : a == c} {d : A} {XapιSβ : b == d}
        {f : A} {Xγ : f == b} {XβSι : f == d} {apinη : Square Xγ idp XapιSβ XβSι}
        {push∞Sι : c == d} {natpush∞Sβ : Square push∞Sα apin∞Sβ XapιSβ push∞Sι}
        {e : A} {XβSα : e == b} {XapαSβ : e == f} {natβSβ : Square XβSα XapαSβ XapιSβ XβSι}
        {g : A} {p : g == c}
        {rs : a == f}
        (rs= : rs == push∞Sα ∙ ! Xγ)
        {z : _}
        {z= : z == rs ∙ ! XapαSβ}
        {t : _} {t= : t == XapαSβ}
        {fpq= : z == rs ∙ ! t}
        (fpq== : fpq= == z= ∙ (idp ∙!² ! t=))
        {pq=' : _} (pq== : pq=' == idp)
        {α' : _} (α= : α' == (& δ∞Push∞.coh p apinη natpush∞Sβ rs=))
        {γ' : _} (γ= : natβSβ == γ')
        {βγ : _} (βγ=comp : βγ == vcomp! natpush∞Sβ γ')
        {βγ' : _} (βγ= : βγ == βγ')
        {sq : _} (sq= : FlatCube sq (α' ∙□ !² βγ') idp pq=' z= idp)
      → Cube (horiz-degen-square (& (ηIfy.coh α∞ δ∞) sq))
             apinη
             (& γ∞In.coh rs= fpq= t=)
             vid-square
             comp-square
             (skew natβSβ))
  coh = path-induction

-- The two maps

{-<twomaps>-}
to : J∞A → JA
to = J∞A-rec inJ pushJ

from : JA → J∞A
from = JA-rec ε∞ α∞ δ∞
{-</>-}

-- Rules which better match the intuitive definition of [pushJ n x]
to-push∞ : (n : ℕ) (x : J n) → Square (ap to (push∞ n x)) idp (inJS-ι n x) (δJ (inJ n x))
to-push∞ n x = & coh (push∞-β n x)  where

  coh : Coh ({A : Type i} {a b : A} {p : a == b} {c : A} {q : c == b} {r : a == c} (r= : r == p ∙ ! q) → Square r idp q p)
  coh = path-induction

to-push∞-S : (n : ℕ) (x : J (S n)) → ap to (push∞ (S n) x) == δJ (inJ (S n) x)
to-push∞-S n x = horiz-degen-path (to-push∞ (S n) x)

ap-from-αJ : (a : A) {x y : JA} (p : x == y) → ap from (ap (αJ a) p) == ap (α∞ a) (ap from p)
ap-from-αJ a p = ∘-ap _ _ _ ∙ ap-∘ _ _ _

ap-square-from-αJ : (a : A) {x y z t : JA} {p : x == y} {q : x == z} {r : y == t} {s : z == t} (sq : Square p q r s)
  → FlatCube (ap-square from (ap-square (αJ a) sq))
             (ap-square (α∞ a) (ap-square from sq))
             (ap-from-αJ _ _) (ap-from-αJ _ _)
             (ap-from-αJ _ _) (ap-from-αJ _ _)
ap-square-from-αJ a ids = idfc

-- Abbreviation for the natural square of [δJ]
ap-δJ : {x y : JA} (p : x == y) → Square (δJ x) p (ap (αJ ⋆A) p) (δJ y)
ap-δJ p = natural-square δJ p (ap-idf p) idp


------------------------------------------------------------------------
-- A type soundness result
------------------------------------------------------------------------

open import Prelude
open import Prelude.Size

import Lambda.Syntax

module Lambda.Type-soundness
  {Name : Type}
  (open Lambda.Syntax Name)
  (open Closure Tm)
  (def : Name → Tm 1)
  (Σ : Name → Ty ∞ × Ty ∞)
  where

open import Equality.Propositional

open import Function-universe equality-with-J
open import Maybe equality-with-J
open import Monad equality-with-J
open import Vec.Data equality-with-J

open import Delay-monad.Always
open import Delay-monad.Bisimilarity

open import Lambda.Delay-crash
open import Lambda.Interpreter def

-- WF-Value, WF-Env and WF-MV specify when a
-- value/environment/potential value is well-formed with respect to a
-- given context (and type).

mutual

  data WF-Value : Ty ∞ → Value → Type where
    lam   : ∀ {n Γ σ τ} {t : Tm (1 + n)} {ρ} →
            Σ , force σ ∷ Γ ⊢ t ∈ force τ →
            WF-Env Γ ρ →
            WF-Value (σ ⇾′ τ) (lam t ρ)
    con   : ∀ b → WF-Value bool (con b)

  WF-Env : ∀ {n} → Ctxt n → Env n → Type
  WF-Env Γ ρ = ∀ x → WF-Value (index Γ x) (index ρ x)

WF-MV : Ty ∞ → Maybe Value → Type
WF-MV σ v = maybe (WF-Value σ) Prelude.⊥ v

-- Some "constructors" for WF-Env.

[]-wf : WF-Env [] []
[]-wf ()

infixr 5 _∷-wf_

_∷-wf_ : ∀ {n} {Γ : Ctxt n} {ρ σ v} →
         WF-Value σ v → WF-Env Γ ρ → WF-Env (σ ∷ Γ) (v ∷ ρ)
(v-wf ∷-wf ρ-wf) fzero    = v-wf
(v-wf ∷-wf ρ-wf) (fsuc x) = ρ-wf x

-- If we can prove □ ∞ (WF-MV σ) (run x), then x does not "go wrong".

does-not-go-wrong : ∀ {σ} {x : Delay-crash Value ∞} →
                    □ ∞ (WF-MV σ) x → ¬ x ≈ crash
does-not-go-wrong (now {x = nothing} ())
does-not-go-wrong (now {x = just x} x-wf) ()
does-not-go-wrong (later x-wf)            (laterˡ x↯) =
  does-not-go-wrong (force x-wf) x↯

-- A "constructor" for □ i ∘ WF-MV.

_>>=-wf_ :
  ∀ {i σ τ} {x : Delay-crash Value ∞} {f : Value → Delay-crash Value ∞} →
  □ i (WF-MV σ) x →
  (∀ {v} → WF-Value σ v → □ i (WF-MV τ) (f v)) →
  □ i (WF-MV τ) (x >>= f)
x-wf >>=-wf f-wf =
  □->>= x-wf λ { {nothing} ()
               ; {just v}  v-wf → f-wf v-wf
               }

-- Well-typed programs do not "go wrong".

module _ (def∈ : (f : Name) →
                 Σ , proj₁ (Σ f) ∷ [] ⊢ def f ∈ proj₂ (Σ f)) where

  mutual

    ⟦⟧-wf : ∀ {i n Γ} (t : Tm n) {σ} → Σ , Γ ⊢ t ∈ σ →
            ∀ {ρ} → WF-Env Γ ρ →
            □ i (WF-MV σ) (⟦ t ⟧ ρ)
    ⟦⟧-wf (var x)   var         ρ-wf = now (ρ-wf x)
    ⟦⟧-wf (lam t)   (lam t∈)    ρ-wf = now (lam t∈ ρ-wf)
    ⟦⟧-wf (t₁ · t₂) (t₁∈ · t₂∈) ρ-wf =
      ⟦⟧-wf t₁ t₁∈ ρ-wf >>=-wf λ f-wf →
      ⟦⟧-wf t₂ t₂∈ ρ-wf >>=-wf λ v-wf →
      ∙-wf f-wf v-wf
    ⟦⟧-wf (call f t) (call t∈) ρ-wf =
      ⟦⟧-wf t t∈ ρ-wf >>=-wf λ v-wf →
      ∙-wf {σ = λ { .force → proj₁ (Σ f) }}
           {τ = λ { .force → proj₂ (Σ f) }}
           (lam (def∈ f) []-wf) v-wf
    ⟦⟧-wf (con b)       con              ρ-wf = now (con b)
    ⟦⟧-wf (if t₁ t₂ t₃) (if t₁∈ t₂∈ t₃∈) ρ-wf =
      ⟦⟧-wf t₁ t₁∈ ρ-wf >>=-wf λ v₁-wf →
      ⟦if⟧-wf v₁-wf t₂∈ t₃∈ ρ-wf

    ∙-wf : ∀ {i σ τ f v} →
           WF-Value (σ ⇾′ τ) f → WF-Value (force σ) v →
           □ i (WF-MV (force τ)) (f ∙ v)
    ∙-wf (lam t₁∈ ρ₁-wf) v₂-wf =
      later λ { .force → ⟦⟧-wf _ t₁∈ (v₂-wf ∷-wf ρ₁-wf) }

    ⟦if⟧-wf : ∀ {i n Γ σ v} {t₂ t₃ : Tm n} →
              WF-Value bool v →
              Σ , Γ ⊢ t₂ ∈ σ →
              Σ , Γ ⊢ t₃ ∈ σ →
              ∀ {ρ} → WF-Env Γ ρ →
              □ i (WF-MV σ) (⟦if⟧ v t₂ t₃ ρ)
    ⟦if⟧-wf (con true)  t₂∈ t₃∈ ρ-wf = ⟦⟧-wf _ t₂∈ ρ-wf
    ⟦if⟧-wf (con false) t₂∈ t₃∈ ρ-wf = ⟦⟧-wf _ t₃∈ ρ-wf

  type-soundness : ∀ {t : Tm 0} {σ} →
                   Σ , [] ⊢ t ∈ σ → ¬ ⟦ t ⟧ [] ≈ crash
  type-soundness {t = t} {σ} =
    Σ , [] ⊢ t ∈ σ            ↝⟨ (λ t∈ → ⟦⟧-wf _ t∈ []-wf) ⟩
    □ ∞ (WF-MV σ) (⟦ t ⟧ [])  ↝⟨ does-not-go-wrong ⟩□
    ¬ ⟦ t ⟧ [] ≈ crash        □


-- Andreas, 2019-11-06 issue #4168, version with shape-irrelevance.

-- Eta-contraction of records with all-irrelevant fields is unsound.
-- In this case, it lead to a compilation error.

{-# OPTIONS --irrelevant-projections #-}

-- {-# OPTIONS -v tc.cc:20 #-}

open import Agda.Builtin.Unit
open import Common.IO using (IO; return)

main : IO ⊤
main = return _

record Box (A : Set) : Set where
  constructor box
  field
    ..unbox : A

open Box

record R (M : Set → Set) : Set₁ where
  field
    bind : (A B : Set) → M A → (A → M B) → M B
open R

works : R Box
works .bind A B x g .unbox = unbox (g (unbox x))

test : R Box
test .bind A B x g = box (unbox (g (unbox x)))
-- WAS eta-contracted to: test .bind A B x g = g (unbox x)
-- crashing compilation.

-- Compilation should succeed.


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

module FinEquivEquivPlusTimes where

open import Data.Product using (_×_; proj₁; proj₂)

open import Equiv using (refl∼; sym∼; sym≃; _⊎≃_; id≃; _≃_; _●_; _×≃_; qinv)

open import FinEquivPlusTimes using (F0≃⊥; module Plus; module Times)
open Plus using (⊎≃+; +≃⊎)
open Times using (×≃*; *≃×)

open import FinEquivTypeEquiv
  using (_fin≃_; module PlusE; module TimesE; module PlusTimesE)
open PlusE using (_+F_; unite+; uniti+; unite+r; uniti+r; assocr+; assocl+;
                 swap+; sswap+)
open TimesE using (_*F_; unite*; uniti*; unite*r; uniti*r; assocr*; assocl*;
                  swap*; sswap*)
open PlusTimesE using (distz; factorz; distzr; factorzr;
                       dist; factor; distl; factorl)
open import EquivEquiv
open import TypeEquiv
  using (unite₊equiv; unite₊′equiv; assocl₊equiv)

open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Fin using (Fin)
open import Data.Sum using (_⊎_)
open import Data.Product using (_,_)
import Relation.Binary.PropositionalEquality as P using (refl)

import TypeEquivEquiv as T
  using (
    -- much lower down
    0×0≃0)

------------------------------------------------------------------------------
-- Equivalences for distributivity

distl-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    distl {m'} {n'} {o'} ● (f *F (g +F h)) ≋
      ((f *F g) +F (f *F h)) ● distl {m} {n} {o}
distl-nat = {!!}

factorl-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    factorl {m'} {n'} {o'} ● ((f *F g) +F (f *F h)) ≋
      (f *F (g +F h)) ● factorl {m} {n} {o}
factorl-nat = {!!}

dist-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    dist {m'} {n'} {o'} ● ((f +F g) *F h) ≋
      ((f *F h) +F (g *F h)) ● dist {m} {n} {o}
dist-nat = {!!}

factor-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    factor {m'} {n'} {o'} ● ((f *F h) +F (g *F h)) ≋
      ((f +F g) *F h) ● factor {m} {n} {o}
factor-nat = {!!}

distzr-nat : {m n : ℕ} {f : m fin≃ n} {g : 0 fin≃ 0} →
    distzr {n} ● (f *F g) ≋ g ● distzr {m}
distzr-nat = {!!}

factorzr-nat : {m n : ℕ} {f : m fin≃ n} {g : 0 fin≃ 0} →
    factorzr {n} ● g ≋ (f *F g) ● factorzr {m}
factorzr-nat = {!!}

distz-nat : {m n : ℕ} → {f : m fin≃ n} → {g : 0 fin≃ 0} →
    distz {n} ● (g *F f) ≋ g ● distz {m}
distz-nat = {!!}

factorz-nat : {m n : ℕ} → {f : m fin≃ n} → {g : 0 fin≃ 0} →
    factorz {n} ● g ≋ (g *F f) ● factorz {m}
factorz-nat = {!!}

A×[B⊎C]≃[A×C]⊎[A×B] : {m n o : ℕ} →
    distl {m} {o} {n} ● (id≃ {A = Fin m} *F swap+ {n} {o}) ≋
    swap+ {m * n} {m * o} ● distl {m} {n} {o}
A×[B⊎C]≃[A×C]⊎[A×B] = {!!}

[A⊎B]×C≃[C×A]⊎[C×B] : {m n o : ℕ} →
    (swap* {m} {o} +F swap* {n} {o}) ● dist {m} {n} {o} ≋
    distl {o} {m} {n} ● swap* {m + n} {o}
[A⊎B]×C≃[C×A]⊎[C×B] = {!!}

[A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D : {m n o p : ℕ} →
    (dist {m} {n} {p} +F id≃ {A = Fin (o * p)}) ●
      dist {m + n} {o} {p} ● (assocl+ {m} {n} {o} *F id≃ {A = Fin p}) ≋
    assocl+ {m * p} {n * p} {o * p} ●
      (id≃ {A = Fin (m * p)} +F dist {n} {o} {p}) ● dist {m} {n + o} {p}
[A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D = {!!}

A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D : {m n o p : ℕ} →
    distl {m * n} {o} {p} ● assocl* {m} {n} {o + p} ≋
    (assocl* {m} {n} {o} +F assocl* {m} {n} {p}) ●
      distl {m} {n * o} {n * p} ● (id≃ {A = Fin m} *F distl {n} {o} {p})
A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D = {!!}

[A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D : {m n o p : ℕ} →
    assocl+ {(m * o) + (n * o)} {m * p} {n * p} ●
      (dist {m} {n} {o} +F dist {m} {n} {p}) ●
      distl {m + n} {o} {p} ≋
    (assocl+ {m * o} {n * o} {m * p} +F id≃ {A = Fin (n * p)}) ●
      ((id≃ {A = Fin (m * o)} +F swap+ {m * p} {n * o}) +F id≃ {A = Fin (n * p)}) ●
      (assocr+ {m * o} {m * p} {n * o} +F id≃ {A = Fin (n * p)}) ●
      assocl+ {(m * o) + (m * p)} {n * o} {n * p} ●
      (distl {m} {o} {p} +F distl {n} {o} {p}) ● dist {m} {n} {o + p}
[A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D = {!!}

-- can't be done via equational reasoning!?!?
-- cannot even dig into T.0×0≃0 as f≋ is abstract
0×0≃0 : distz {0} ≋ distzr {0}
0×0≃0 = eq (λ {()}) (λ {()}) -- wow, talk about low-level reasoning!

0×[A⊎B]≃0 : {m n : ℕ} →
    distz {m + n} ≋ unite+ ● (distz {m} +F distz {n}) ● distl {0} {m} {n}
0×[A⊎B]≃0 = {!!}

0×1≃0 : unite*r ≋ distz {1}
0×1≃0 = {!!}

A×0≃0 : {m : ℕ} → distzr {m} ≋ distz {m} ● swap* {m} {0}
A×0≃0 = {!!}

0×A×B≃0 : {m n : ℕ} →
    distz {m * n} ≋
    distz {n} ● (distz {m} *F id≃ {A = Fin n}) ● assocl* {0} {m} {n}
0×A×B≃0 = {!!}

A×0×B≃0 : {m n : ℕ} →
    distzr {m} ● (id≃ {A = Fin m} *F distz {n})  ≋
    distz {n} ● (distzr {m} *F id≃ {A = Fin n}) ● assocl* {m} {0} {n}
A×0×B≃0 = {!!}

A×[0+B]≃A×B : {m n : ℕ} →
    (id≃ {A = Fin m} *F unite+ {n}) ≋
    unite+ ● (distzr {m} +F id≃) ● distl {m} {0} {n}
A×[0+B]≃A×B = {!!}

1×[A⊎B]≃A⊎B : {m n : ℕ} →
    unite* ≋ (unite* {m} +F unite* {n}) ● distl {1} {m} {n}
1×[A⊎B]≃A⊎B = {!!}

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