{-# OPTIONS --cubical --no-import-sorts --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.Prelims where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure

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

open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.S1

open import Cubical.Homotopy.Loopspace
open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec)
open import Cubical.HITs.SetTruncation renaming (elim to sElim ; map to sMap ; rec to sRec)

infixr 33 _⋄_

_⋄_ : _
_⋄_ = compIso

-- We strengthen the elimination rule for Hⁿ(S¹). We show that we only need to work with elements ∣ f ∣₂ (definitionally) sending loop to some loop p
-- and sending base to 0
elimFunS¹ : (n : ℕ) → (p : typ (Ω (coHomK-ptd (suc n)))) → S¹ → coHomK (suc n)
elimFunS¹ n  p base = ∣ ptSn (suc n) ∣
elimFunS¹ n  p (loop i) = p i

coHomPointedElimS¹ : ∀ {ℓ} (n : ℕ) {B : coHom (suc n) S¹ → Type ℓ}
                 → ((x : coHom (suc n) S¹) → isProp (B x))
                 → ((p : typ (Ω (coHomK-ptd (suc n)))) → B ∣ elimFunS¹ n p ∣₂)
                 → (x : coHom (suc n) S¹) → B x
coHomPointedElimS¹ n {B = B} x p =
  coHomPointedElim n base x
    λ f Id → subst B
              (cong ∣_∣₂ (funExt (λ {base → sym Id ; (loop i) j → doubleCompPath-filler (sym Id) (cong f loop) Id (~ j) i})))
              (p (sym Id ∙∙ (cong f loop) ∙∙ Id))

coHomPointedElimS¹2 : ∀ {ℓ} (n : ℕ) {B : (x y : coHom (suc n) S¹) → Type ℓ}
                 → ((x y : coHom (suc n) S¹) → isProp (B x y))
                 → ((p q : typ (Ω (coHomK-ptd (suc n)))) → B ∣ elimFunS¹ n p ∣₂ ∣ elimFunS¹ n q ∣₂)
                 → (x y : coHom (suc n) S¹) → B x y
coHomPointedElimS¹2 n {B = B} x p =
  coHomPointedElim2 _ base x λ f g fId gId
    → subst2 B (cong ∣_∣₂ (funExt (λ {base → sym fId ; (loop i) j → doubleCompPath-filler (sym (fId)) (cong f loop) fId (~ j) i})))
                (cong ∣_∣₂ (funExt (λ {base → sym gId ; (loop i) j → doubleCompPath-filler (sym (gId)) (cong g loop) gId (~ j) i})))
                (p (sym fId ∙∙ cong f loop ∙∙ fId) (sym gId ∙∙ cong g loop ∙∙ gId))

-- We do the same thing for Sⁿ, n ≥ 2.
elimFunSⁿ : (n m : ℕ) (p : S₊ (suc m) → typ (Ω (coHomK-ptd (suc n))))
         → (S₊ (2 + m)) → coHomK (suc n)
elimFunSⁿ n m p north = ∣ ptSn (suc n) ∣
elimFunSⁿ n m p south = ∣ ptSn (suc n) ∣
elimFunSⁿ n m p (merid a i) = p a i

coHomPointedElimSⁿ : ∀ {ℓ} (n m : ℕ) {B : (x : coHom (suc n) (S₊ (2 + m))) → Type ℓ}
                 → ((x : coHom (suc n) (S₊ (2 + m))) → isProp (B x))
                 → ((p : _) → B ∣ elimFunSⁿ n m p ∣₂)
                 → (x : coHom (suc n) (S₊ (2 + m))) → B x
coHomPointedElimSⁿ n m {B = B} isprop ind =
  coHomPointedElim n north isprop
    λ f fId → subst B (cong ∣_∣₂ (funExt (λ {north → sym fId
                                           ; south → sym fId ∙' cong f (merid (ptSn (suc m)))
                                           ; (merid a i) j → hcomp (λ k → λ {(i = i0) → fId (~ j ∧ k)
                                                                             ; (i = i1) → compPath'-filler (sym fId)
                                                                                (cong f (merid (ptSn (suc m)))) k j
                                                                             ; (j = i1) → f (merid a i)})
                                                                    (hcomp (λ k → λ {(i = i0) → f north ;
                                                                                (i = i1) → f (merid (ptSn (suc m)) (j ∨ ~ k)) ;
                                                                                (j = i1) → f (merid a i)})
                                                                           (f (merid a i)))})))
                       (ind λ a → sym fId ∙∙ cong f (merid a) ∙ cong f (sym (merid (ptSn (suc m)))) ∙∙ fId)

0₀ = 0ₖ 0
0₁ = 0ₖ 1
0₂ = 0ₖ 2
0₃ = 0ₖ 3
0₄ = 0ₖ 4

S¹map : hLevelTrunc 3 S¹ → S¹
S¹map = trRec isGroupoidS¹ (idfun _)

S¹map-id : (x : hLevelTrunc 3 S¹) → Path (hLevelTrunc 3 S¹) ∣ S¹map x ∣ x
S¹map-id = trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _)
                  λ a → refl

-- We prove that (S¹ → ∥ S¹ ∥) ≃ S¹ × ℤ (Needed for H¹(S¹)). Note that the truncation doesn't really matter, since S¹ is a groupoid.
-- Given a map f : S¹ → S¹, the idea is to send this to (f(base) , winding (f(loop))). For this to be
-- well-typed, we need to translate f(loop) into an element in Ω(S¹,base).

S¹→S¹≡S¹×Int : Iso (S¹ → hLevelTrunc 3 S¹) (S¹ × Int)
Iso.fun S¹→S¹≡S¹×Int f = S¹map (f base)
                 , winding (basechange2⁻ (S¹map (f base)) λ i → S¹map (f (loop i)))
Iso.inv S¹→S¹≡S¹×Int (s , int) base = ∣ s ∣
Iso.inv S¹→S¹≡S¹×Int (s , int) (loop i) = ∣ basechange2 s (intLoop int) i ∣
Iso.rightInv S¹→S¹≡S¹×Int (s , int) = ΣPathP (refl , ((λ i → winding (basechange2-retr s (λ i → intLoop int i) i))
                                                      ∙ windingIntLoop int))
Iso.leftInv S¹→S¹≡S¹×Int f = funExt λ { base → S¹map-id (f base)
                                      ; (loop i) j → helper j i}
  where
  helper : PathP (λ i → S¹map-id (f base) i ≡ S¹map-id (f base) i)
                  (λ i → ∣ basechange2 (S¹map (f base))
                             (intLoop (winding (basechange2⁻ (S¹map (f base)) (λ i₁ → S¹map (f (loop i₁)))))) i ∣)
                  (cong f loop)
  helper i j =
    hcomp (λ k → λ { (i = i0) → cong ∣_∣ (basechange2 (S¹map (f base))
                                           (intLoop (winding (basechange2⁻ (S¹map (f base)) (λ i₁ → S¹map (f (loop i₁))))))) j
                    ; (i = i1) → S¹map-id (f (loop j)) k
                    ; (j = i0) → S¹map-id (f base) (i ∧ k)
                    ; (j = i1) → S¹map-id (f base) (i ∧ k)})
          (helper2 i j)
    where
    helper2 : Path (Path (hLevelTrunc 3 _) _ _)
                   (cong ∣_∣ (basechange2 (S¹map (f base))
                                         (intLoop
                                           (winding
                                             (basechange2⁻ (S¹map (f base))
                                                           (λ i₁ → S¹map (f (loop i₁))))))))
                   λ i → ∣ S¹map (f (loop i)) ∣
    helper2 i j =
         ∣ ((cong (basechange2 (S¹map (f base)))
                   (decodeEncode base (basechange2⁻ (S¹map (f base))
                                                    (λ i₁ → S¹map (f (loop i₁)))))
            ∙ basechange2-sect (S¹map (f base))
                               (λ i → S¹map (f (loop i)))) i) j ∣

{- Proof that (S¹ → K₁) ≃ K₁ × ℤ. Needed for H¹(T²) -}
S1→K₁≡S1×Int : Iso ((S₊ 1) → coHomK 1) (coHomK 1 × Int)
S1→K₁≡S1×Int = S¹→S¹≡S¹×Int ⋄ prodIso (invIso (truncIdempotentIso 3 (isGroupoidS¹))) idIso

module _ (key : Unit') where
  module P = lockedCohom key
  private
    _+K_ : {n : ℕ} → coHomK n → coHomK n → coHomK n
    _+K_ {n = n} = P.+K n

    -K_ : {n : ℕ} → coHomK n → coHomK n
    -K_ {n = n} = P.-K n

    _-K_ : {n : ℕ} → coHomK n → coHomK n → coHomK n
    _-K_ {n = n} = P.-Kbin n

  infixr 55 _+K_
  infixr 55 -K_
  infixr 56 _-K_

  {- Proof that S¹→K2 is isomorphic to K2×K1 (as types). Needed for H²(T²)  -}
  S1→K2≡K2×K1' : Iso (S₊ 1 → coHomK 2) (coHomK 2 × coHomK 1)
  Iso.fun S1→K2≡K2×K1' f = f base , ΩKn+1→Kn 1 (sym (P.rCancelK 2 (f base))
                                             ∙∙ cong (λ x → (f x) -K f base) loop
                                             ∙∙ P.rCancelK 2 (f base))
  Iso.inv S1→K2≡K2×K1' = invmap
    where
    invmap : (∥ Susp S¹ ∥ 4) × (∥ S¹ ∥ 3) → S¹ → ∥ Susp S¹ ∥ 4
    invmap (a , b) base = a +K 0₂
    invmap (a , b) (loop i) = a +K Kn→ΩKn+1 1 b i
  Iso.rightInv S1→K2≡K2×K1' (a , b) = ΣPathP ((P.rUnitK 2 a)
                                           , (cong (ΩKn+1→Kn 1) (doubleCompPath-elim' (sym (P.rCancelK 2 (a +K 0₂)))
                                             (λ i → (a +K Kn→ΩKn+1 1 b i) -K (a +K 0₂))
                                             (P.rCancelK 2 (a +K 0₂)))
                                          ∙∙ cong (ΩKn+1→Kn 1) (congHelper2 (Kn→ΩKn+1 1 b) (λ x → (a +K x) -K (a +K 0₂))
                                                               (funExt (λ x → sym (cancelHelper a x)))
                                                               (P.rCancelK 2 (a +K 0₂)))
                                          ∙∙ Iso.leftInv (Iso-Kn-ΩKn+1 1) b))

      module _ where
      cancelHelper : (a b : coHomK 2) → (a +K b) -K (a +K 0₂) ≡ b
      cancelHelper a b = cong (λ x → (a +K b) -K x) (P.rUnitK 2 a)
                       ∙ P.-cancelLK 2 a b

      congHelper2 : (p : 0₂ ≡ 0₂) (f : coHomK 2 → coHomK 2) (id : (λ x → x) ≡ f) → (q : (f 0₂) ≡ 0₂)
                  → (sym q) ∙ cong f p ∙ q ≡ p
      congHelper2 p f = J (λ f _ → (q : (f 0₂) ≡ 0₂) → (sym q) ∙ cong f p ∙ q ≡ p)
                         λ q → (cong (sym q ∙_) (isCommΩK 2 p _) ∙∙ assoc _ _ _ ∙∙ cong (_∙ p) (lCancel q))
                              ∙ sym (lUnit p)

      conghelper3 : (x : coHomK 2) (p : x ≡ x) (f : coHomK 2 → coHomK 2) (id : (λ x → x) ≡ f) (q : f x ≡ x)
                  → (sym q) ∙ cong f p ∙ q ≡ p
      conghelper3 x p f = J (λ f _ → (q : (f x) ≡ x) → (sym q) ∙ cong f p ∙ q ≡ p)
                            λ q → (cong (sym q ∙_) (isCommΩK-based 2 x p _) ∙∙ assoc _ _ _ ∙∙ cong (_∙ p) (lCancel q))
                                      ∙  sym (lUnit p)
  Iso.leftInv S1→K2≡K2×K1' a i base = P.rUnitK _ (a base) i
  Iso.leftInv S1→K2≡K2×K1' a i (loop j) = loop-helper i j
    where
    loop-helper : PathP (λ i → P.rUnitK _ (a base) i ≡ P.rUnitK _ (a base) i)
                     (cong (a base +K_) (Kn→ΩKn+1 1 (ΩKn+1→Kn 1 ((sym (P.rCancelK 2 (a base))
                           ∙∙ (λ i → a (loop i) -K (a (base)))
                           ∙∙ P.rCancelK 2 (a base))))))
                     (cong a loop)
    loop-helper i j =
      hcomp (λ k → λ { (i = i0) → (G (doubleCompPath-elim'
                                        (sym rP) (λ i₁ → a (loop i₁) -K a base) rP (~ k))) j
                      ; (i = i1) → cong a loop j
                      ; (j = i0) → P.rUnitK 2 (a base) i
                      ; (j = i1) → P.rUnitK 2 (a base) i})
             (loop-helper2 i j)

       where
       F : typ (Ω (coHomK-ptd 2)) → a base +K snd (coHomK-ptd 2) ≡ a base +K snd (coHomK-ptd 2)
       F = cong (_+K_ {n = 2} (a base))

       G : 0ₖ 2 ≡ 0ₖ 2 → a base +K snd (coHomK-ptd 2) ≡ a base +K snd (coHomK-ptd 2)
       G p = F (Kn→ΩKn+1 1 (ΩKn+1→Kn 1 p))

       rP : P.+K 2 (a base) (P.-K 2 (a base)) ≡ 0ₖ 2
       rP = P.rCancelK 2 (a base)

       lem : (x : coHomK 2) (p : x ≡ x) (q : 0₂ ≡ x)
           → Kn→ΩKn+1 1 (ΩKn+1→Kn 1 (q ∙ p ∙ sym q)) ≡ q ∙ p ∙ sym q
       lem x p q = Iso.rightInv (Iso-Kn-ΩKn+1 1) (q ∙ p ∙ sym q)

       subtr-lem : (a b : hLevelTrunc 4 (S₊ 2)) → a +K (b -K a) ≡ b
       subtr-lem a b = P.commK 2 a (b -K a) ∙ P.-+cancelK 2 b a

       subtr-lem-coher : PathP (λ i → subtr-lem (a base) (a base) i ≡ subtr-lem (a base) (a base) i)
                           (cong (a base +K_) (λ i₁ → a (loop i₁) -K a base))
                           λ i → a (loop i)
       subtr-lem-coher i j = subtr-lem (a base) (a (loop j)) i

       abstract
         helperFun2 : {A : Type₀} {0A a b : A} (main : 0A ≡ 0A) (start : b ≡ b) (p : a ≡ a) (q : a ≡ b) (r : b ≡ 0A) (Q : a ≡ 0A)
                      (R : PathP (λ i → Q i ≡ Q i) p main)
                      → start ≡ sym q ∙ p ∙ q
                      → isComm∙ (A , 0A)
                      → sym r ∙ start ∙ r ≡ main
         helperFun2 main start p q r Q R startId comm =
             sym r ∙ start ∙ r                                            ≡[ i ]⟨ sym r ∙ startId i ∙ r ⟩
             sym r ∙ (sym q ∙ p ∙ q) ∙ r                                  ≡[ i ]⟨ sym r ∙ assoc (sym q) (p ∙ q) r (~ i) ⟩
             sym r ∙ sym q ∙ (p ∙ q) ∙ r                                  ≡[ i ]⟨ sym r ∙ sym q ∙ assoc p q r (~ i) ⟩
             sym r ∙ sym q ∙ p ∙ q ∙ r                                    ≡[ i ]⟨ assoc (sym r) (rUnit (sym q) i) (p ∙ lUnit (q ∙ r) i) i ⟩
             (sym r ∙ sym q ∙ refl) ∙ p ∙ refl ∙ q ∙ r                    ≡[ i ]⟨ (sym r ∙ sym q ∙ λ j → Q (i ∧ j)) ∙ R i ∙ (λ j → Q ( i ∧ (~ j))) ∙ q ∙ r ⟩
             (sym r ∙ sym q ∙ Q) ∙ main ∙ sym Q ∙ q ∙ r                   ≡[ i ]⟨ (sym r ∙ sym q ∙ Q) ∙ main ∙ sym Q ∙ symDistr (sym r) (sym q) (~ i) ⟩
             (sym r ∙ sym q ∙ Q) ∙ main ∙ sym Q ∙ sym (sym r ∙ sym q)     ≡[ i ]⟨ (assoc (sym r) (sym q) Q i) ∙ main ∙ symDistr (sym r ∙ sym q) Q (~ i) ⟩
             ((sym r ∙ sym q) ∙ Q) ∙ main ∙ sym ((sym r ∙ sym q) ∙ Q)     ≡[ i ]⟨ ((sym r ∙ sym q) ∙ Q) ∙ comm main (sym ((sym r ∙ sym q) ∙ Q)) i ⟩
             ((sym r ∙ sym q) ∙ Q) ∙ sym ((sym r ∙ sym q) ∙ Q) ∙ main     ≡⟨ assoc ((sym r ∙ sym q) ∙ Q) (sym ((sym r ∙ sym q) ∙ Q)) main  ⟩
             (((sym r ∙ sym q) ∙ Q) ∙ sym ((sym r ∙ sym q) ∙ Q)) ∙ main   ≡[ i ]⟨ rCancel (((sym r ∙ sym q) ∙ Q)) i ∙ main ⟩
             refl ∙ main                                                  ≡⟨ sym (lUnit main) ⟩
             main ∎

         congFunct₃ : ∀ {A B : Type₀} {a b c d : A} (f : A → B) (p : a ≡ b) (q : b ≡ c) (r : c ≡ d)
                      → cong f (p ∙ q ∙ r) ≡ cong f p ∙ cong f q ∙ cong f r
         congFunct₃ f p q r = congFunct f p (q ∙ r) ∙ cong (cong f p ∙_) (congFunct f q r)

         lem₀ : G (sym rP ∙ (λ i₁ → a (loop i₁) -K a base) ∙ rP)
                 ≡ F (sym rP ∙ (λ i₁ → a (loop i₁) -K a base) ∙ rP)
         lem₀ = cong F (lem (a base -K (a base))
                               (λ i₁ → a (loop i₁) -K a base)
                               (sym (P.rCancelK 2 (a base))))

         lem₁ : G (sym rP ∙ (λ i₁ → a (loop i₁) -K a base) ∙ rP)
                ≡ sym (λ i₁ → a base +K P.rCancelK 2 (a base) i₁) ∙
                      cong (a base +K_) (λ i₁ → a (loop i₁) -K a base) ∙
                      (λ i₁ → a base +K P.rCancelK 2 (a base) i₁)
         lem₁ = lem₀ ∙ congFunct₃ (a base +K_) (sym rP)
                                                    (λ i₁ → a (loop i₁) -K a base)
                                                    rP

         loop-helper2 : PathP (λ i → P.rUnitK _ (a base) i ≡ P.rUnitK _ (a base) i)
                       (cong (a base +K_) (Kn→ΩKn+1 1 (ΩKn+1→Kn 1 ((sym (P.rCancelK 2 (a base))
                             ∙ (λ i → a (loop i) -K (a (base)))
                             ∙ P.rCancelK 2 (a base))))))
                       (cong a loop)
         loop-helper2 = compPathL→PathP (helperFun2 (cong a loop) _ _
                                                  (cong (a base +K_) (P.rCancelK 2 (a base))) _ _
                                                  subtr-lem-coher
                                                  lem₁
                                                  (isCommΩK-based 2 (a base)))

S1→K2≡K2×K1 : Iso (S₊ 1 → coHomK 2) (coHomK 2 × coHomK 1)
S1→K2≡K2×K1 = S1→K2≡K2×K1' unlock


module Issue4022.Import where

open import Agda.Builtin.Nat

Binary : Set
Binary = Nat → Nat → Nat

-- Search should be able to find `plus` if:
-- * either we do not normalise the type and look for `Binary`
-- * or we do normalise the type and look for `Nat`

plus : Binary
plus = _+_


------------------------------------------------------------------------
-- Weak bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --sized-types #-}

open import Prelude hiding (module W)

module Delay-monad.Alternative.Weak-bisimilarity {a} {A : Type a} where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)

open import Equivalence-relation equality-with-J
open import Function-universe equality-with-J
open import H-level equality-with-J
open import H-level.Closure equality-with-J

open import Delay-monad.Alternative
open import Delay-monad.Alternative.Equivalence
open import Delay-monad.Alternative.Partial-order
import Delay-monad.Bisimilarity as B
import Delay-monad.Partial-order as PO

infix 4 _≈_

-- Weak bisimilarity.

_≈_ : Delay A → Delay A → Type a
x ≈ y = x ∥⊑∥ y × y ∥⊑∥ x

-- Weak bisimilarity is pointwise propositional.

≈-propositional : ∀ x y → Is-proposition (x ≈ y)
≈-propositional x y =
  ×-closure 1 (∥⊑∥-propositional x y) (∥⊑∥-propositional y x)

-- Weak bisimilarity is an equivalence relation.

≈-is-equivalence-relation : Is-equivalence-relation _≈_
≈-is-equivalence-relation = record
  { reflexive  = λ {x} → ∥⊑∥-reflexive x , ∥⊑∥-reflexive x
  ; symmetric  = λ { (p , q) → q , p }
  ; transitive = λ {x y z} → Σ-zip (∥⊑∥-transitive x y z)
                                   (flip (∥⊑∥-transitive z y x))
  }

-- The notion of weak bisimilarity defined here is logically
-- equivalent (via Delay⇔Delay) to the one defined for the
-- coinductive delay monad (if A is a set).

≈⇔≈ :
  Is-set A →
  ∀ x y → x ≈ y ⇔ _⇔_.to Delay⇔Delay x B.≈ _⇔_.to Delay⇔Delay y
≈⇔≈ A-set x y =
  x ∥⊑∥ y × y ∥⊑∥ x                ↝⟨ inverse (⊑⇔∥⊑∥ A-set x y ×-cong ⊑⇔∥⊑∥ A-set y x) ⟩
  x ⊑ y × y ⊑ x                    ↝⟨ ⊑⇔⊑ x y ×-cong ⊑⇔⊑ y x ⟩
  to x PO.⊑ to y × to y PO.⊑ to x  ↝⟨ inverse PO.≈⇔⊑×⊒ ⟩□
  to x B.≈ to y                    □
  where
  open _⇔_ Delay⇔Delay

≈⇔≈′ :
  Is-set A →
  ∀ {x y} → x B.≈ y ⇔ _⇔_.from Delay⇔Delay x ≈ _⇔_.from Delay⇔Delay y
≈⇔≈′ A-set {x} {y} =
  x B.≈ y                                ↝⟨ PO.≈⇔⊑×⊒ ⟩
  x PO.⊑ y × y PO.⊑ x                    ↝⟨ ⊑⇔⊑′ ×-cong ⊑⇔⊑′ ⟩
  from x ⊑ from y × from y ⊑ from x      ↝⟨ ⊑⇔∥⊑∥ A-set (from x) (from y) ×-cong ⊑⇔∥⊑∥ A-set (from y) (from x) ⟩□
  from x ∥⊑∥ from y × from y ∥⊑∥ from x  □
  where
  open _⇔_ Delay⇔Delay


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

module Cubical.Algebra.Group.EilenbergMacLane.Properties where

open import Cubical.Algebra.Group.EilenbergMacLane.Base renaming (elim to EM-elim)
open import Cubical.Algebra.Group.EilenbergMacLane.WedgeConnectivity
open import Cubical.Algebra.Group.EilenbergMacLane.GroupStructure
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.AbGroup.TensorProduct
open import Cubical.Algebra.AbGroup.Base

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

open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Loopspace

open import Cubical.Functions.Morphism

open import Cubical.Data.Sigma
open import Cubical.Data.Nat hiding (_·_)

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

private
  variable ℓ ℓ' ℓ'' : Level

isConnectedEM₁ : (G : Group ℓ) → isConnected 2 (EM₁ G)
isConnectedEM₁ G = ∣ embase ∣ , h
    where
      h : (y : hLevelTrunc 2 (EM₁ G)) → ∣ embase ∣ ≡ y
      h = trElim (λ y → isOfHLevelSuc 1 (isOfHLevelTrunc 2 ∣ embase ∣ y))
            (elimProp G (λ x → isOfHLevelTrunc 2 ∣ embase ∣ ∣ x ∣) refl)

module _ {G' : AbGroup ℓ} where
  private
    G = fst G'
    open AbGroupStr (snd G') renaming (_+_ to _+G_)

  isConnectedEM : (n : ℕ) → isConnected (suc n) (EM G' n)
  fst (isConnectedEM zero) = ∣ 0g ∣
  snd (isConnectedEM zero) y = isOfHLevelTrunc 1 _ _
  isConnectedEM (suc zero) = isConnectedEM₁ (AbGroup→Group G')
  fst (isConnectedEM (suc (suc n))) = ∣ 0ₖ _ ∣
  snd (isConnectedEM (suc (suc n))) =
    trElim (λ _ → isOfHLevelTruncPath)
      (trElim (λ _ → isOfHLevelSuc (3 + n) (isOfHLevelTruncPath {n = (3 + n)}))
        (raw-elim G'
          (suc n)
          (λ _ → isOfHLevelTrunc (3 + n) _ _)
          refl))

module _ (Ĝ : Group ℓ) where
  private
    G = fst Ĝ
  open GroupStr (snd Ĝ)

  emloop-id : emloop 1g ≡ refl
  emloop-id =
    emloop 1g                                 ≡⟨ rUnit (emloop 1g) ⟩
    emloop 1g ∙ refl                          ≡⟨ cong (emloop 1g ∙_) (rCancel (emloop 1g) ⁻¹) ⟩
    emloop 1g ∙ (emloop 1g ∙ (emloop 1g) ⁻¹)  ≡⟨ ∙assoc _ _ _ ⟩
    (emloop 1g ∙ emloop 1g) ∙ (emloop 1g) ⁻¹  ≡⟨ cong (_∙ emloop 1g ⁻¹)
                                                   ((emloop-comp Ĝ 1g 1g) ⁻¹) ⟩
    emloop (1g · 1g) ∙ (emloop 1g) ⁻¹         ≡⟨ cong (λ g → emloop {Group = Ĝ} g
                                                             ∙ (emloop 1g) ⁻¹)
                                                      (·IdR 1g) ⟩
    emloop 1g ∙ (emloop 1g) ⁻¹                ≡⟨ rCancel (emloop 1g) ⟩
    refl ∎

  emloop-inv : (g : G) → emloop (inv g) ≡ (emloop g) ⁻¹
  emloop-inv g =
    emloop (inv g)                              ≡⟨ rUnit (emloop (inv g)) ⟩
    emloop (inv g) ∙ refl                       ≡⟨ cong (emloop (inv g) ∙_)
                                                      (rCancel (emloop g) ⁻¹) ⟩
    emloop (inv g) ∙ (emloop g ∙ (emloop g) ⁻¹) ≡⟨ ∙assoc _ _ _ ⟩
    (emloop (inv g) ∙ emloop g) ∙ (emloop g) ⁻¹ ≡⟨ cong (_∙ emloop g ⁻¹)
                                                      ((emloop-comp Ĝ (inv g) g) ⁻¹) ⟩
    emloop (inv g · g) ∙ (emloop g) ⁻¹          ≡⟨ cong (λ h → emloop {Group = Ĝ} h
                                                            ∙ (emloop g) ⁻¹)
                                                      (·InvL g) ⟩
    emloop 1g ∙ (emloop g) ⁻¹                 ≡⟨ cong (_∙ (emloop g) ⁻¹) emloop-id ⟩
    refl ∙ (emloop g) ⁻¹                      ≡⟨ (lUnit ((emloop g) ⁻¹)) ⁻¹ ⟩
    (emloop g) ⁻¹ ∎

  isGroupoidEM₁ : isGroupoid (EM₁ Ĝ)
  isGroupoidEM₁ = emsquash

  --------- Ω (EM₁ G) ≃ G ---------

  {- since we write composition in diagrammatic order,
     and function composition in the other order,
     we need right multiplication here -}
  rightEquiv : (g : G) → G ≃ G
  rightEquiv g = isoToEquiv isom
    where
    isom : Iso G G
    isom .Iso.fun = _· g
    isom .Iso.inv = _· inv g
    isom .Iso.rightInv h =
      (h · inv g) · g ≡⟨ (·Assoc h (inv g) g) ⁻¹ ⟩
        h · inv g · g ≡⟨ cong (h ·_) (·InvL g) ⟩
             h · 1g ≡⟨ ·IdR h ⟩ h ∎
    isom .Iso.leftInv h =
      (h · g) · inv g ≡⟨ (·Assoc h g (inv g)) ⁻¹ ⟩
        h · g · inv g ≡⟨ cong (h ·_) (·InvR g) ⟩
             h · 1g ≡⟨ ·IdR h ⟩ h ∎

  compRightEquiv : (g h : G)
    → compEquiv (rightEquiv g) (rightEquiv h) ≡ rightEquiv (g · h)
  compRightEquiv g h = equivEq (funExt (λ x → (·Assoc x g h) ⁻¹))

  CodesSet : EM₁ Ĝ → hSet ℓ
  CodesSet = EMrec Ĝ (isOfHLevelTypeOfHLevel 2) (G , is-set) RE REComp
    where
      RE : (g : G) → Path (hSet ℓ) (G , is-set) (G , is-set)
      RE g = Σ≡Prop (λ X → isPropIsOfHLevel {A = X} 2) (ua (rightEquiv g))

      lemma₁ : (g h : G) → Square
        (ua (rightEquiv g)) (ua (rightEquiv (g · h)))
        refl (ua (rightEquiv h))
      lemma₁ g h = invEq
                   (Square≃doubleComp (ua (rightEquiv g)) (ua (rightEquiv (g · h)))
                     refl (ua (rightEquiv h)))
                   (ua (rightEquiv g) ∙ ua (rightEquiv h)
                       ≡⟨ (uaCompEquiv (rightEquiv g) (rightEquiv h)) ⁻¹ ⟩
                    ua (compEquiv (rightEquiv g) (rightEquiv h))
                       ≡⟨ cong ua (compRightEquiv g h) ⟩
                    ua (rightEquiv (g · h)) ∎)

      REComp : (g h : G) → Square (RE g) (RE (g · h)) refl (RE h)
      REComp g h = ΣSquareSet (λ _ → isProp→isSet isPropIsSet) (lemma₁ g h)
  Codes : EM₁ Ĝ → Type ℓ
  Codes x = CodesSet x .fst

  encode : (x : EM₁ Ĝ) → embase ≡ x → Codes x
  encode x p = subst Codes p 1g

  decode : (x : EM₁ Ĝ) → Codes x → embase ≡ x
  decode = elimSet Ĝ (λ x → isOfHLevelΠ 2 (λ c → isGroupoidEM₁ (embase) x))
    emloop λ g → ua→ λ h → emcomp h g

  decode-encode : (x : EM₁ Ĝ) (p : embase ≡ x) → decode x (encode x p) ≡ p
  decode-encode x p = J (λ y q → decode y (encode y q) ≡ q)
    (emloop (transport refl 1g) ≡⟨ cong emloop (transportRefl 1g) ⟩
     emloop 1g ≡⟨ emloop-id ⟩ refl ∎) p

  encode-decode : (x : EM₁ Ĝ) (c : Codes x) → encode x (decode x c) ≡ c
  encode-decode = elimProp Ĝ (λ x → isOfHLevelΠ 1 (λ c → CodesSet x .snd _ _))
    λ g → encode embase (decode embase g) ≡⟨ refl ⟩
          encode embase (emloop g) ≡⟨ refl ⟩
          transport (ua (rightEquiv g)) 1g ≡⟨ uaβ (rightEquiv g) 1g ⟩
          1g · g ≡⟨ ·IdL g ⟩
          g ∎

  ΩEM₁Iso : Iso (Path (EM₁ Ĝ) embase embase) G
  Iso.fun ΩEM₁Iso = encode embase
  Iso.inv ΩEM₁Iso = emloop
  Iso.rightInv ΩEM₁Iso = encode-decode embase
  Iso.leftInv ΩEM₁Iso = decode-encode embase

  ΩEM₁≡ : (Path (EM₁ Ĝ) embase embase) ≡ G
  ΩEM₁≡ = isoToPath ΩEM₁Iso

--------- Ω (EMₙ₊₁ G) ≃ EMₙ G ---------
module _ {G : AbGroup ℓ} where
  open AbGroupStr (snd G)
    renaming (_+_ to _+G_ ; -_ to -G_ ; +Assoc to +AssocG)

  CODE : (n : ℕ) → EM G (suc (suc n)) → TypeOfHLevel ℓ (3 + n)
  CODE n =
    trElim (λ _ → isOfHLevelTypeOfHLevel (3 + n))
      λ { north → EM G (suc n) , hLevelEM G (suc n)
        ; south → EM G (suc n) , hLevelEM G (suc n)
        ; (merid a i) → fib n a i}
    where
    fib : (n : ℕ) → (a : EM-raw G (suc n))
        → Path (TypeOfHLevel _ (3 + n))
                (EM G (suc n) , hLevelEM G (suc n))
                (EM G (suc n) , hLevelEM G (suc n))
    fib zero a = Σ≡Prop (λ _ → isPropIsOfHLevel 3)
                   (isoToPath (addIso 1 a))
    fib (suc n) a = Σ≡Prop (λ _ → isPropIsOfHLevel (4 + n))
                            (isoToPath (addIso (suc (suc n)) ∣ a ∣))

  decode' : (n : ℕ) (x : EM G (suc (suc n))) → CODE n x .fst → 0ₖ (suc (suc n)) ≡ x
  decode' n =
    trElim (λ _ → isOfHLevelΠ (4 + n)
            λ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (4 + n)) _ _)
           λ { north → f n
             ; south → g n
             ; (merid a i) → main a i}
     where
     f : (n : ℕ) → _
     f n = σ-EM' n

     g : (n : ℕ) → EM G (suc n) → ∣ ptEM-raw ∣ ≡ ∣ south ∣
     g n x = σ-EM' n x ∙ cong ∣_∣ₕ (merid ptEM-raw)

     lem₂ : (n : ℕ) (a x : _)
       → Path (Path (EM G (suc (suc n))) _ _)
               ((λ i → cong ∣_∣ₕ (σ-EM n x) i) ∙ sym (cong ∣_∣ₕ (σ-EM n a)) ∙ (λ i → ∣ merid a i ∣ₕ))
               (g n (EM-raw→EM G (suc n) x))
     lem₂ zero a x =
       cong (f zero x ∙_)
         (cong (_∙ cong ∣_∣ₕ (merid a)) (cong (cong ∣_∣ₕ) (symDistr (merid a) (sym (merid embase)))
                                     ∙ cong-∙ ∣_∣ₕ (merid embase) (sym (merid a)))
          ∙∙ sym (∙assoc _ _ _)
          ∙∙ cong (cong ∣_∣ₕ (merid embase) ∙_) (lCancel (cong ∣_∣ₕ (merid a)))
           ∙ sym (rUnit _))
     lem₂ (suc n) a x =
       cong (f (suc n) ∣ x ∣ ∙_)
         ((cong (_∙ cong ∣_∣ₕ (merid a)) (cong (cong ∣_∣ₕ) (symDistr (merid a) (sym (merid north)))
                                      ∙ cong-∙ ∣_∣ₕ (merid north) (sym (merid a)))
          ∙∙ sym (∙assoc _ _ _)
          ∙∙ cong (cong ∣_∣ₕ (merid north) ∙_) (lCancel (cong ∣_∣ₕ (merid a)))
           ∙ sym (rUnit _)))

     lem : (n : ℕ) (x a : EM-raw G (suc n))
             → f n (transport (sym (cong (λ x → CODE n x .fst) (cong ∣_∣ₕ (merid a))))
                    (EM-raw→EM G (suc n) x))
                ≡ cong ∣_∣ₕ (σ-EM n x) ∙ sym (cong ∣_∣ₕ (σ-EM n a))
     lem zero x a = (λ i → cong ∣_∣ₕ (merid (transportRefl x i -[ 1 ]ₖ a) ∙ sym (merid embase)))
                  ∙∙ σ-EM'-hom zero x (-ₖ a)
                  ∙∙ cong (f zero x ∙_) (σ-EM'-ₖ zero a)
     lem (suc n) x a =
          cong (f (suc n)) (λ i → transportRefl ∣ x ∣ i -[ 2 + n ]ₖ ∣ a ∣)
        ∙∙ σ-EM'-hom (suc n) ∣ x ∣ (-ₖ ∣ a ∣)
        ∙∙ cong (f (suc n) ∣ x ∣ ∙_) (σ-EM'-ₖ (suc n) ∣ a ∣)

     main : (a : _)
         → PathP (λ i → CODE n ∣ merid a i ∣ₕ .fst
                       → 0ₖ (suc (suc n)) ≡ ∣ merid a i ∣ₕ) (f n) (g n)
     main a =
       toPathP (funExt
         (EM-elim _ (λ _ → isOfHLevelPathP (2 + (suc n)) (isOfHLevelTrunc (4 + n) _ _) _ _)
           λ x →
            ((λ i → transp (λ j → Path (EM G (2 + n)) ∣ ptEM-raw ∣ ∣ merid a (i ∨ j) ∣)
                         i (compPath-filler (lem n x a i) (cong ∣_∣ₕ (merid a)) i) ))
         ∙∙ sym (∙assoc _ _ _)
         ∙∙ lem₂ n a x))

  encode' : (n : ℕ) (x : EM G (suc (suc n))) → 0ₖ (suc (suc n)) ≡ x → CODE n x .fst
  encode' n x p = subst (λ x → CODE n x .fst) p (0ₖ (suc n))

  decode'-encode' : (n : ℕ) (x : EM G (2 + n)) (p : 0ₖ (2 + n) ≡ x)
    → decode' n x (encode' n x p) ≡ p
  decode'-encode' zero x =
    J (λ x p → decode' 0 x (encode' 0 x p) ≡ p)
      (σ-EM'-0ₖ 0)
  decode'-encode' (suc n) x =
    J (λ x p → decode' (suc n) x (encode' (suc n) x p) ≡ p)
       (σ-EM'-0ₖ (suc n))

  encode'-decode' : (n : ℕ) (x : _)
    → encode' n (0ₖ (suc (suc n))) (decode' n (0ₖ (suc (suc n))) x) ≡ x
  encode'-decode' zero x =
        cong (encode' zero (0ₖ 2)) (cong-∙ ∣_∣ₕ (merid x) (sym (merid embase)))
     ∙∙ substComposite (λ x → CODE zero x .fst)
                              (cong ∣_∣ₕ (merid x)) (sym (cong ∣_∣ₕ (merid ptEM-raw))) embase
     ∙∙ (cong (subst (λ x₁ → CODE zero x₁ .fst) (λ i → ∣ merid embase (~ i) ∣ₕ))
                                 (λ i → lUnitₖ 1 (transportRefl x i) i)
      ∙ (λ i → rUnitₖ 1 (transportRefl x i) i))
  encode'-decode' (suc n) =
    trElim (λ _ → isOfHLevelTruncPath {n = 4 + n})
      λ x → cong (encode' (suc n) (0ₖ (3 + n))) (cong-∙ ∣_∣ₕ (merid x) (sym (merid north)))
    ∙∙ substComposite (λ x → CODE (suc n) x .fst)
         (cong ∣_∣ₕ (merid x)) (sym (cong ∣_∣ₕ (merid ptEM-raw))) (0ₖ (2 + n))
    ∙∙ cong (subst (λ x₁ → CODE (suc n) x₁ .fst) (λ i → ∣ merid ptEM-raw (~ i) ∣ₕ))
            (λ i → lUnitₖ (2 + n) (transportRefl ∣ x ∣ₕ i) i)
     ∙ (λ i → rUnitₖ (2 + n) (transportRefl ∣ x ∣ₕ i) i)

  Iso-EM-ΩEM+1 : (n : ℕ) → Iso (EM G n) (typ (Ω (EM∙ G (suc n))))
  Iso-EM-ΩEM+1 zero = invIso (ΩEM₁Iso (AbGroup→Group G))
  Iso.fun (Iso-EM-ΩEM+1 (suc zero)) = decode' 0 (0ₖ 2)
  Iso.inv (Iso-EM-ΩEM+1 (suc zero)) = encode' 0 (0ₖ 2)
  Iso.rightInv (Iso-EM-ΩEM+1 (suc zero)) = decode'-encode' 0 (0ₖ 2)
  Iso.leftInv (Iso-EM-ΩEM+1 (suc zero)) = encode'-decode' 0
  Iso.fun (Iso-EM-ΩEM+1 (suc (suc n))) = decode' (suc n) (0ₖ (3 + n))
  Iso.inv (Iso-EM-ΩEM+1 (suc (suc n))) = encode' (suc n) (0ₖ (3 + n))
  Iso.rightInv (Iso-EM-ΩEM+1 (suc (suc n))) = decode'-encode' (suc n) (0ₖ (3 + n))
  Iso.leftInv (Iso-EM-ΩEM+1 (suc (suc n))) = encode'-decode' (suc n)

  EM≃ΩEM+1 : (n : ℕ) → EM G n ≃ typ (Ω (EM∙ G (suc n)))
  EM≃ΩEM+1 n = isoToEquiv (Iso-EM-ΩEM+1 n)

  -- Some properties of the isomorphism
  EM→ΩEM+1 : (n : ℕ) → EM G n → typ (Ω (EM∙ G (suc n)))
  EM→ΩEM+1 n = Iso.fun (Iso-EM-ΩEM+1 n)

  ΩEM+1→EM : (n : ℕ) → typ (Ω (EM∙ G (suc n))) → EM G n
  ΩEM+1→EM n = Iso.inv (Iso-EM-ΩEM+1 n)

  EM→ΩEM+1-0ₖ : (n : ℕ) → EM→ΩEM+1 n (0ₖ n) ≡ refl
  EM→ΩEM+1-0ₖ zero = emloop-1g _
  EM→ΩEM+1-0ₖ (suc zero) = cong (cong ∣_∣ₕ) (rCancel (merid ptEM-raw))
  EM→ΩEM+1-0ₖ (suc (suc n)) = cong (cong ∣_∣ₕ) (rCancel (merid ptEM-raw))

  EM→ΩEM+1-hom : (n : ℕ) (x y : EM G n)
    → EM→ΩEM+1 n (x +[ n ]ₖ y) ≡ EM→ΩEM+1 n x ∙ EM→ΩEM+1 n y
  EM→ΩEM+1-hom zero x y = emloop-comp _ x y
  EM→ΩEM+1-hom (suc zero) x y = σ-EM'-hom zero x y
  EM→ΩEM+1-hom (suc (suc n)) x y = σ-EM'-hom (suc n) x y

  ΩEM+1→EM-hom : (n : ℕ) → (p q : typ (Ω (EM∙ G (suc n))))
    → ΩEM+1→EM n (p ∙ q) ≡ (ΩEM+1→EM n p) +[ n ]ₖ (ΩEM+1→EM n q)
  ΩEM+1→EM-hom n =
    morphLemmas.isMorphInv (λ x y → x +[ n ]ₖ y) (_∙_) (EM→ΩEM+1 n)
      (EM→ΩEM+1-hom n) (ΩEM+1→EM n)
      (Iso.rightInv (Iso-EM-ΩEM+1 n)) (Iso.leftInv (Iso-EM-ΩEM+1 n))

  ΩEM+1→EM-refl : (n : ℕ) → ΩEM+1→EM n refl ≡ 0ₖ n
  ΩEM+1→EM-refl zero = transportRefl 0g
  ΩEM+1→EM-refl (suc zero) = refl
  ΩEM+1→EM-refl (suc (suc n)) = refl

  EM→ΩEM+1∙ : (n : ℕ) → EM∙ G n →∙ Ω (EM∙ G (suc n))
  EM→ΩEM+1∙ n .fst = EM→ΩEM+1 n
  EM→ΩEM+1∙ zero .snd = emloop-1g (AbGroup→Group G)
  EM→ΩEM+1∙ (suc zero) .snd = cong (cong ∣_∣ₕ) (rCancel (merid embase))
  EM→ΩEM+1∙ (suc (suc n)) .snd = cong (cong ∣_∣ₕ) (rCancel (merid north))

  EM≃ΩEM+1∙ : (n : ℕ) → EM∙ G n ≡ Ω (EM∙ G (suc n))
  EM≃ΩEM+1∙ n = ua∙ (EM≃ΩEM+1 n) (EM→ΩEM+1-0ₖ n)

  isHomogeneousEM : (n : ℕ) → isHomogeneous (EM∙ G n)
  isHomogeneousEM n x =
    ua∙ (isoToEquiv (addIso n x)) (lUnitₖ n x)

-- Some HLevel lemmas about function spaces (EM∙ G n →∙ EM∙ H m), mainly used for
-- the cup product
module _ where
  open AbGroupStr renaming (_+_ to comp)

  isContr-↓∙ : {G : AbGroup ℓ} {H : AbGroup ℓ'} (n : ℕ) → isContr (EM∙ G (suc n) →∙ EM∙ H n)
  fst (isContr-↓∙ {G = G} {H = H} zero) = (λ _ → 0g (snd H)) , refl
  snd (isContr-↓∙{G = G} {H = H} zero) (f , p) =
    Σ≡Prop (λ x → is-set (snd H) _ _)
      (funExt (raw-elim G 0 (λ _ → is-set (snd H) _ _) (sym p)))
  fst (isContr-↓∙ {G = G} {H = H} (suc n)) = (λ _ → 0ₖ (suc n)) , refl
  fst (snd (isContr-↓∙ {G = G} {H = H} (suc n)) f i) x =
    trElim {B = λ x → 0ₖ (suc n) ≡ fst f x}
    (λ _ → isOfHLevelPath (4 + n) (isOfHLevelSuc (3 + n) (hLevelEM H (suc n))) _ _)
    (raw-elim _ _ (λ _ → hLevelEM H (suc n) _ _) (sym (snd f)))
    x i
  snd (snd (isContr-↓∙ (suc n)) f i) j = snd f (~ i ∨ j)

  isContr-↓∙' : {G : AbGroup ℓ} {H : AbGroup ℓ'} (n : ℕ)
              → isContr ((EM-raw G (suc n) , ptEM-raw) →∙ EM∙ H n)
  isContr-↓∙' zero = isContr-↓∙ zero
  fst (isContr-↓∙' (suc n)) = (λ _ → 0ₖ (suc n)) , refl
  fst (snd (isContr-↓∙' {H = H} (suc n)) f i) x =
    raw-elim _  _ {A = λ x → 0ₖ (suc n) ≡ fst f x}
      (λ _ → hLevelEM H (suc n) _ _) (sym (snd f)) x i
  snd (snd (isContr-↓∙' (suc n)) f i) j = snd f (~ i ∨ j)

  isOfHLevel→∙EM : ∀ {ℓ} {A : Pointed ℓ} {G : AbGroup ℓ'} (n m : ℕ)
    → isOfHLevel (suc m) (A →∙ EM∙ G n)
    → isOfHLevel (suc (suc m)) (A →∙ EM∙ G (suc n))
  isOfHLevel→∙EM {A = A} {G = G} n m hlev = step₃
    where
    step₁ : isOfHLevel (suc m) (A →∙ Ω (EM∙ G (suc n)))
    step₁ =
      subst (isOfHLevel (suc m))
      (λ i → A →∙ ua∙ {A = Ω (EM∙ G (suc n))} {B = EM∙ G n}
      (invEquiv (EM≃ΩEM+1 n))
      (ΩEM+1→EM-refl n) (~ i)) hlev

    step₂ : isOfHLevel (suc m) (typ (Ω (A →∙ EM∙ G (suc n) ∙)))
    step₂ = isOfHLevelRetractFromIso (suc m) (invIso (invIso (ΩfunExtIso _ _))) step₁

    step₃ : isOfHLevel (suc (suc m)) (A →∙ EM∙ G (suc n))
    step₃ = isOfHLevelΩ→isOfHLevel m
      λ f → subst (λ x → isOfHLevel (suc m) (typ (Ω x)))
               (isHomogeneous→∙ (isHomogeneousEM (suc n)) f)
                step₂

  isOfHLevel↑∙ : {G : AbGroup ℓ} {H : AbGroup ℓ'}
            → ∀ n m → isOfHLevel (2 + n) (EM∙ G (suc m) →∙ EM∙ H (suc (n + m)))
  isOfHLevel↑∙ zero m = isOfHLevel→∙EM m 0 (isContr→isProp (isContr-↓∙ m))
  isOfHLevel↑∙ (suc n) m = isOfHLevel→∙EM (suc (n + m)) (suc n) (isOfHLevel↑∙ n m)

  isOfHLevel↑∙' : {G : AbGroup ℓ} {H : AbGroup ℓ'}
            → ∀ n m → isOfHLevel (2 + n) (EM-raw∙ G (suc m) →∙ EM∙ H (suc (n + m)))
  isOfHLevel↑∙' zero m = isOfHLevel→∙EM m 0 (isContr→isProp (isContr-↓∙' m))
  isOfHLevel↑∙' (suc n) m = isOfHLevel→∙EM (suc (n + m)) (suc n) (isOfHLevel↑∙' n m)

  →∙EMPath : ∀ {ℓ} {G : AbGroup ℓ} (A : Pointed ℓ') (n : ℕ)
           → Ω (A →∙ EM∙ G (suc n) ∙) ≡ (A →∙ EM∙ G n ∙)
  →∙EMPath {G = G} A n =
      ua∙ (isoToEquiv (ΩfunExtIso A (EM∙ G (suc n)))) refl
    ∙ (λ i → (A →∙ EM≃ΩEM+1∙ {G = G} n (~ i) ∙))

  private
    contr∙-lem : {G : AbGroup ℓ} {H : AbGroup ℓ'} {L : AbGroup ℓ''} (n m : ℕ)
      → isContr (EM∙ G (suc n) →∙ (EM∙ H (suc m) →∙ EM∙ L (suc (n + m)) ∙))
    fst (contr∙-lem n m) = (λ _ → (λ _ → 0ₖ _) , refl), refl
    snd (contr∙-lem {G = G} {H = H} {L = L} n m) (f , p) =
      →∙Homogeneous≡ (isHomogeneous→∙ (isHomogeneousEM _))
        (sym (funExt (help n f p)))
      where
      help : (n : ℕ) → (f : EM G (suc n) → EM∙ H (suc m) →∙ EM∙ L (suc (n + m)))
          → f (snd (EM∙ G (suc n))) ≡ snd (EM∙ H (suc m) →∙ EM∙ L (suc (n + m)) ∙)
          → (x : _) → (f x) ≡ ((λ _ → 0ₖ _) , refl)
      help zero f p =
        raw-elim G zero
          (λ _ → isOfHLevel↑∙ zero m _ _) p
      help (suc n) f p =
        trElim (λ _ → isOfHLevelPath (4 + n)
               (subst (λ x → isOfHLevel x (EM∙ H (suc m) →∙ EM∙ L (suc ((suc n) + m))))
                      (λ i → suc (suc (+-comm (suc n) 1 i)))
                      (isOfHLevelPlus' {n = 1} (3 + n) (isOfHLevel↑∙ (suc n) m))) _ _)
          (raw-elim G (suc n)
            (λ _ → isOfHLevel↑∙ (suc n) m _ _) p)

  isOfHLevel↑∙∙ : {G : AbGroup ℓ} {H : AbGroup ℓ'} {L : AbGroup ℓ''}
     → ∀ n m l → isOfHLevel (2 + l) (EM∙ G (suc n)
                                  →∙ (EM∙ H (suc m)
                                   →∙ EM∙ L (suc (suc (l + n + m))) ∙))
  isOfHLevel↑∙∙ {G = G} {H = H} {L = L} n m zero =
    isOfHLevelΩ→isOfHLevel 0 λ f
      → subst
          isProp (cong (λ x → typ (Ω x))
          (isHomogeneous→∙ (isHomogeneous→∙ (isHomogeneousEM _)) f))
          (isOfHLevelRetractFromIso 1 (ΩfunExtIso _ _) h)
    where
    h : isProp (EM∙ G (suc n)
             →∙ (Ω (EM∙ H (suc m)
              →∙ EM∙ L (suc (suc (n + m))) ∙)))
    h =
      subst isProp
        (λ i → EM∙ G (suc n)
            →∙ (→∙EMPath {G = L} (EM∙ H (suc m)) (suc (n + m)) (~ i)))
        (isContr→isProp (contr∙-lem n m))
  isOfHLevel↑∙∙ {G = G} {H = H} {L = L} n m (suc l) =
    isOfHLevelΩ→isOfHLevel (suc l)
      λ f →
      subst (isOfHLevel (2 + l))
          (cong (λ x → typ (Ω x))
          (isHomogeneous→∙ (isHomogeneous→∙ (isHomogeneousEM _)) f))
          (isOfHLevelRetractFromIso (2 + l) (ΩfunExtIso _ _) h)
    where
    h : isOfHLevel (2 + l)
         (EM∙ G (suc n)
           →∙ (Ω (EM∙ H (suc m)
             →∙ EM∙ L (suc (suc (suc (l + n + m)))) ∙)))
    h =
      subst (isOfHLevel (2 + l))
        (λ i → EM∙ G (suc n)
             →∙ →∙EMPath {G = L} (EM∙ H (suc m)) (suc (suc (l + n + m))) (~ i))
        (isOfHLevel↑∙∙ n m l)

-- A homomorphism φ : G → H of AbGroups induces a homomorphism
-- φ' : K(G,n) → K(H,n)
inducedFun-EM-raw : {G' : AbGroup ℓ} {H' : AbGroup ℓ'}
                     → AbGroupHom G' H'
                     → ∀ n
                     → EM-raw G' n → EM-raw H' n
inducedFun-EM-raw f =
  elim+2 (fst f)
    (EMrec _ emsquash embase
     (λ g → emloop (fst f g))
      λ g h → compPathR→PathP (sym
                (sym (lUnit _)
              ∙∙ cong (_∙ (sym (emloop (fst f h))))
                      (cong emloop (IsGroupHom.pres· (snd f) g h)
                          ∙ emloop-comp _ (fst f g) (fst f h))
              ∙∙ sym (∙assoc _ _ _)
              ∙∙ cong (emloop (fst f g) ∙_) (rCancel _)
              ∙∙ sym (rUnit _))))
    (λ n ind → λ { north → north
                  ; south → south
                  ; (merid a i) → merid (ind a) i} )

inducedFun-EM-rawIso : {G' : AbGroup ℓ} {H' : AbGroup ℓ'}
                     → AbGroupEquiv G' H'
                     → ∀ n → Iso (EM-raw G' n) (EM-raw H' n)
Iso.fun (inducedFun-EM-rawIso e n) = inducedFun-EM-raw (_ , (snd e)) n
Iso.inv (inducedFun-EM-rawIso e n) = inducedFun-EM-raw (_ , isGroupHomInv e) n
Iso.rightInv (inducedFun-EM-rawIso e n) = h n
  where
  h : (n : ℕ) → section (inducedFun-EM-raw (fst e .fst , snd e) n)
      (inducedFun-EM-raw (invEq (fst e) , isGroupHomInv e) n)
  h = elim+2
    (secEq (fst e))
    (elimSet _ (λ _ → emsquash _ _) refl
                       (λ g → compPathR→PathP
                          ((sym (cong₂ _∙_ (cong emloop (secEq (fst e) g)) (sym (lUnit _))
                               ∙ rCancel _)))))
    λ n p → λ { north → refl
               ; south → refl
               ; (merid a i) k → merid (p a k) i}
Iso.leftInv (inducedFun-EM-rawIso e n) = h n
  where
  h : (n : ℕ) → retract (Iso.fun (inducedFun-EM-rawIso e n))
                          (Iso.inv (inducedFun-EM-rawIso e n))
  h = elim+2
    (retEq (fst e))
    (elimSet _ (λ _ → emsquash _ _) refl
                       (λ g → compPathR→PathP
                          ((sym (cong₂ _∙_ (cong emloop (retEq (fst e) g)) (sym (lUnit _))
                               ∙ rCancel _)))))
    λ n p → λ { north → refl
               ; south → refl
               ; (merid a i) k → merid (p a k) i}

Iso→EMIso : {G : AbGroup ℓ} {H : AbGroup ℓ'}
  → AbGroupEquiv G H → ∀ n → Iso (EM G n) (EM H n)
Iso→EMIso is zero = inducedFun-EM-rawIso is zero
Iso→EMIso is (suc zero) = inducedFun-EM-rawIso is 1
Iso→EMIso is (suc (suc n)) = mapCompIso (inducedFun-EM-rawIso is (suc (suc n)))

EM⊗-commIso : {G : AbGroup ℓ} {H : AbGroup ℓ'}
  → ∀ n →  Iso (EM (G ⨂ H) n) (EM (H ⨂ G) n)
EM⊗-commIso {G = G} {H = H} = Iso→EMIso (GroupIso→GroupEquiv ⨂-commIso)

EM⊗-assocIso : {G : AbGroup ℓ} {H : AbGroup ℓ'} {L : AbGroup ℓ''}
  → ∀ n → Iso (EM (G ⨂ (H ⨂ L)) n) (EM ((G ⨂ H) ⨂ L) n)
EM⊗-assocIso = Iso→EMIso (GroupIso→GroupEquiv (GroupEquiv→GroupIso ⨂assoc))


module StreamEnc where

open import Data.Unit hiding (_≤_)
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

≤-step : ∀{k n} → k ≤ n → k ≤ suc n
≤-step z≤n = z≤n
≤-step (s≤s p) = s≤s (≤-step p)

pred-≤ : ∀{k n} → suc k ≤ n → k ≤ n
pred-≤ (s≤s p) = ≤-step p

Str : Set → Set
Str A = ℕ → A

hd : ∀{A} → Str A → A
hd s = s 0

tl : ∀{A} → Str A → Str A
tl s n = s (suc n)

_ω : ∀{A} → A → Str A
(a ω) n = a

_∷_ : ∀{A} → A → Str A → Str A
(a ∷ s) 0       = a
(a ∷ s) (suc n) = s n

module Mealy (A B : Set) where

  M : Set → Set
  M X = A → B × X

  M₁ : {X Y : Set} → (X → Y) → M X → M Y
  M₁ f g a =
    let (b , x) = g a
    in (b , f x)

  𝓜 : Set
  𝓜 = Str A → Str B

  d : 𝓜 → M 𝓜
  d f a = (f (a ω) 0 , (λ s n → f (a ∷ s) (suc n)))

  corec : ∀{X} → (c : X → M X) → X → 𝓜
  corec c x s zero    = proj₁ (c x (hd s))
  corec c x s (suc n) = corec c (proj₂ (c x (hd s))) (tl s) n

  compute' : ∀{X} (c : X → M X) (x : X) →
            ∀ a → d (corec c x) a ≡ M₁ (corec c) (c x) a
  compute' c x a =
    begin
      d (corec c x) a
    ≡⟨ refl ⟩
      ((corec c x) (a ω) 0 , λ s n → (corec c x) (a ∷ s) (suc n))
    ≡⟨ refl ⟩
      (proj₁ (c x (hd (a ω)))
      , λ s n → corec c (proj₂ (c x (hd (a ∷ s)))) (tl (a ∷ s)) n)
    ≡⟨ refl ⟩
      (proj₁ (c x a) , λ s n → corec c (proj₂ (c x a)) (λ n → s n) n)
    ≡⟨ refl ⟩
      (proj₁ (c x a) , λ s n → corec c (proj₂ (c x a)) s n)
    ≡⟨ refl ⟩
      (proj₁ (c x a) , λ s → corec c (proj₂ (c x a)) s)
    ≡⟨ refl ⟩
      (proj₁ (c x a) , corec c (proj₂ (c x a)))
    ≡⟨ refl ⟩
      M₁ (corec c) (c x) a
    ∎

  compute : ∀{X} (c : X → M X) (x : X) →
            d (corec c x) ≡ M₁ (corec c) (c x)
  compute c x =
    begin
      d (corec c x)
    ≡⟨ refl ⟩
      (λ a → d (corec c x) a)
    ≡⟨ refl ⟩ -- Same as in compute'
      (λ a → M₁ (corec c) (c x) a)
    ≡⟨ refl ⟩
      M₁ (corec c) (c x)
    ∎

module MealyT (A B : Set) (a₀ : A) where

  M : Set → Set
  M X = ⊤ ⊎ (A → B × X)

  M₁ : {X Y : Set} → (X → Y) → M X → M Y
  M₁ f (inj₁ x) = inj₁ x
  M₁ f (inj₂ g) =
    inj₂ (λ a →
      let (b , x) = g a
      in (b , f x))

  Mono : (Str A → Str (⊤ ⊎ B)) → Set
  -- Mono f = ∀ n → (∃ λ s → ∃ λ b → f s n ≡ inj₂ b) →
  --                ∀ s → ∀ k → k ≤ n → (∃ λ b → f s k ≡ inj₂ b)
  Mono f = ∀ n → ∀ s₁ b₁ → f s₁ n ≡ inj₂ b₁ →
                 ∀ s → ∀ k → k ≤ n → (∃ λ b → f s k ≡ inj₂ b)

  𝓜₁ : Set
  𝓜₁ = Str A → Str (⊤ ⊎ B)

  𝓜 : Set
  𝓜 = Σ[ f ∈ 𝓜₁ ] (Mono f)

  d : 𝓜 → M 𝓜
  d (f , m) = F (f (a₀ ω) 0) refl
    where
      F : (u : ⊤ ⊎ B) → (f (a₀ ω) 0) ≡ u → M 𝓜
      F (inj₁ tt) _ = inj₁ tt
      F (inj₂ b) p = inj₂ (λ a →
        let (b' , p') = m 0 (a₀ ω) b p (a ω) 0 z≤n
            f' = λ s n → f (a ∷ s) (suc n)
            m' : Mono f'
            m' = λ {n s₁ b₁ p₁ s k k≤n →
                      m (suc n) (a ∷ s₁) b₁ p₁ (a ∷ s) (suc k) (s≤s k≤n)}
        in b' , f' , m')

  corec₁ : ∀{X} → (c : X → M X) → X → 𝓜₁
  corec₁ c x s n    with c x
  corec₁ c x s n       | inj₁ tt = inj₁ tt
  corec₁ c x s zero    | inj₂ g  = inj₂ (proj₁ (g (hd s)))
  corec₁ c x s (suc n) | inj₂ g  = corec₁ c (proj₂ (g (hd s))) (tl s) n

  corec₂ : ∀{X} → (c : X → M X) (x : X) → Mono (corec₁ c x)
  corec₂ c x n s₁ b₁ p₁ s k k≤n with c x
  corec₂ c x n s₁ b₁ () s k k≤n | inj₁ tt
  corec₂ c x n s₁ b₁ p₁ s zero k≤n | inj₂ g = (proj₁ (g (hd s)) , refl)
  corec₂ c x n s₁ b₁ p₁ s (suc k) sk≤n | inj₂ g = {!!}
    -- corec₂ c
    --        (proj₂ (g (hd s)))
    --        n
    --        (tl s)
    --        (proj₁ (g (hd s)))
    --        {!!}
    --        (tl s) k (pred-≤ sk≤n)

  -- compute' : ∀{X} (c : X → M X) (x : X) →
  --           ∀ a → d (corec c x) a ≡ M₁ (corec c) (c x) a
  -- compute' c x a =
  --   begin
  --     d (corec c x) a
  --   ≡⟨ refl ⟩
  --     ((corec c x) (a ω) 0 , λ s n → (corec c x) (a ∷ s) (suc n))
  --   ≡⟨ refl ⟩
  --     (proj₁ (c x (hd (a ω)))
  --     , λ s n → corec c (proj₂ (c x (hd (a ∷ s)))) (tl (a ∷ s)) n)
  --   ≡⟨ refl ⟩
  --     (proj₁ (c x a) , λ s n → corec c (proj₂ (c x a)) (λ n → s n) n)
  --   ≡⟨ refl ⟩
  --     (proj₁ (c x a) , λ s n → corec c (proj₂ (c x a)) s n)
  --   ≡⟨ refl ⟩
  --     (proj₁ (c x a) , λ s → corec c (proj₂ (c x a)) s)
  --   ≡⟨ refl ⟩
  --     (proj₁ (c x a) , corec c (proj₂ (c x a)))
  --   ≡⟨ refl ⟩
  --     M₁ (corec c) (c x) a
  --   ∎

  -- compute : ∀{X} (c : X → M X) (x : X) →
  --           d (corec c x) ≡ M₁ (corec c) (c x)
  -- compute c x =
  --   begin
  --     d (corec c x)
  --   ≡⟨ refl ⟩
  --     (λ a → d (corec c x) a)
  --   ≡⟨ refl ⟩ -- Same as in compute'
  --     (λ a → M₁ (corec c) (c x) a)
  --   ≡⟨ refl ⟩
  --     M₁ (corec c) (c x)
  --   ∎


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}

module Cubical.HITs.InfNat where

open import Cubical.HITs.InfNat.Base public
open import Cubical.HITs.InfNat.Properties public


open import Signature
import Program

module Observations (Σ : Sig) (V : Set) (P : Program.Program Σ V) where

open import Terms Σ
open import Program Σ V
open import Rewrite Σ V P
open import Relation.Nullary
open import Relation.Unary
open import Data.Product as Prod renaming (Σ to ⨿)

NonTrivial : T V → Pred (Subst V V) _
NonTrivial t σ = ∃ λ v → (v ∈ fv t) × ¬ isVar (σ v)

{- |
We can make an observation according to the following rule.

t ↓ s   fv(s) ≠ ∅    ∃ k, σ. s ~[σ]~ Pₕ(k)
--------------------------------------------
              t ----> t[σ]
-}
data _↦_ (t : T V) : T V → Set where
  obs-step : {s : T V} → t ↓ s → ¬ Empty (fv s) →
             (cl : dom P) {σ : Subst V V} → mgu s (geth P cl) σ →
             t ↦ app σ t

GroundTerm : Pred (T V) _
GroundTerm t = Empty (fv t)

--------
-- FLAW: This does not allow us to distinguish between inductive
-- and coinductive definitions on the clause level.
-- The following definitions are _global_ for a derivation!
-------

data IndDerivable (t : T V) : Set where
  ground : GroundTerm t → Valid t → IndDerivable t
  der-step : (s : T V) → t ↦ s → IndDerivable s → IndDerivable t

record CoindDerivable (t : T V) : Set where
  coinductive
  field
    term-SN : SN t
    der-obs : ⨿ (T V) λ s → t ↦ s × CoindDerivable s
open CoindDerivable

record _↥[_]_ (t : T V) (σ : Subst∞ V V) (s : T∞ V) : Set where
  coinductive
  field
    conv-match : app∞ σ (χ t) ~ s
    conv-step : ⨿ (T V) λ t₁ → t ↦ t₁ × t₁ ↥[ ? ] s

coind-converges-to : (t : T V) → CoindDerivable t → T∞ V
out (coind-converges-to t p) with der-obs p
... | (._ , obs-step t↓s _ cl {σ} _ , q) = {!!}

coind-converges : (t : T V) → CoindDerivable t →
                  ∃₂ λ s σ → Empty (fv∞ s) × t ↥[ σ ] s
coind-converges = {!!}


{-
This second-order equational theory was created from the following second-order syntax description:

syntax PDiff | PD

type
  * : 0-ary

term
  zero  : * | 𝟘
  add   : *  *  ->  * | _⊕_ l20
  one   : * | 𝟙
  mult  : *  *  ->  * | _⊗_ l20
  neg   : *  ->  * | ⊖_ r50
  pd : *.*  *  ->  * | ∂_∣_

theory
  (𝟘U⊕ᴸ) a |> add (zero, a) = a
  (𝟘U⊕ᴿ) a |> add (a, zero) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊕C) a b |> add(a, b) = add(b, a)
  (𝟙U⊗ᴸ) a |> mult (one, a) = a
  (𝟙U⊗ᴿ) a |> mult (a, one) = a
  (⊗A) a b c |> mult (mult(a, b), c) = mult (a, mult(b, c))
  (⊗D⊕ᴸ) a b c |> mult (a, add (b, c)) = add (mult(a, b), mult(a, c))
  (⊗D⊕ᴿ) a b c |> mult (add (a, b), c) = add (mult(a, c), mult(b, c))
  (𝟘X⊗ᴸ) a |> mult (zero, a) = zero
  (𝟘X⊗ᴿ) a |> mult (a, zero) = zero
  (⊖N⊕ᴸ) a |> add (neg (a), a) = zero
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = zero
  (⊗C) a b |> mult(a, b) = mult(b, a)
  (∂⊕) a : * |> x : * |- d0 (add (x, a)) = one
  (∂⊗) a : * |> x : * |- d0 (mult(a, x)) = a
  (∂C) f : (*,*).* |> x : *  y : * |- d1 (d0 (f[x,y])) = d0 (d1 (f[x,y]))
  (∂Ch₂) f : (*,*).*  g h : *.* |> x : * |- d0 (f[g[x], h[x]]) = add (mult(pd(z. f[z, h[x]], g[x]), d0(g[x])), mult(pd(z. f[g[x], z], h[x]), d0(h[x])))
  (∂Ch₁) f g : *.* |> x : * |- d0 (f[g[x]]) = mult (pd (z. f[z], g[x]), d0(g[x]))
-}

module PDiff.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import PDiff.Signature
open import PDiff.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution PD:Syn
open import SOAS.Metatheory.SecondOrder.Equality PD:Syn

private
  variable
    α β γ τ : *T
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ PD) α Γ → (𝔐 ▷ PD) α Γ → Set where
  𝟘U⊕ᴸ : ⁅ * ⁆̣             ▹     ∅     ⊢               𝟘 ⊕ 𝔞 ≋ₐ 𝔞
  ⊕A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹     ∅     ⊢         (𝔞 ⊕ 𝔟) ⊕ 𝔠 ≋ₐ 𝔞 ⊕ (𝔟 ⊕ 𝔠)
  ⊕C   : ⁅ * ⁆ ⁅ * ⁆̣       ▹     ∅     ⊢               𝔞 ⊕ 𝔟 ≋ₐ 𝔟 ⊕ 𝔞
  𝟙U⊗ᴸ : ⁅ * ⁆̣             ▹     ∅     ⊢               𝟙 ⊗ 𝔞 ≋ₐ 𝔞
  ⊗A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹     ∅     ⊢         (𝔞 ⊗ 𝔟) ⊗ 𝔠 ≋ₐ 𝔞 ⊗ (𝔟 ⊗ 𝔠)
  ⊗D⊕ᴸ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹     ∅     ⊢         𝔞 ⊗ (𝔟 ⊕ 𝔠) ≋ₐ (𝔞 ⊗ 𝔟) ⊕ (𝔞 ⊗ 𝔠)
  𝟘X⊗ᴸ : ⁅ * ⁆̣             ▹     ∅     ⊢               𝟘 ⊗ 𝔞 ≋ₐ 𝟘
  ⊖N⊕ᴸ : ⁅ * ⁆̣             ▹     ∅     ⊢           (⊖ 𝔞) ⊕ 𝔞 ≋ₐ 𝟘
  ⊗C   : ⁅ * ⁆ ⁅ * ⁆̣       ▹     ∅     ⊢               𝔞 ⊗ 𝔟 ≋ₐ 𝔟 ⊗ 𝔞
  ∂⊕   : ⁅ * ⁆̣             ▹   ⌊ * ⌋   ⊢         ∂₀ (x₀ ⊕ 𝔞) ≋ₐ 𝟙
  ∂⊗   : ⁅ * ⁆̣             ▹   ⌊ * ⌋   ⊢         ∂₀ (𝔞 ⊗ x₀) ≋ₐ 𝔞
  ∂C   : ⁅ * · * ⊩ * ⁆̣     ▹ ⌊ * ∙ * ⌋ ⊢  ∂₁ ∂₀ 𝔞⟨ x₀ ◂ x₁ ⟩ ≋ₐ ∂₀ ∂₁ 𝔞⟨ x₀ ◂ x₁ ⟩
  ∂Ch₂ : ⁅ * · * ⊩ * ⁆ ⁅ * ⊩ * ⁆ ⁅ * ⊩ * ⁆̣ ▹ ⌊ * ⌋
       ⊢ ∂₀ 𝔞⟨ (𝔟⟨ x₀ ⟩) ◂ (𝔠⟨ x₀ ⟩) ⟩ ≋ₐ ((∂ 𝔞⟨ x₀ ◂ (𝔠⟨ x₁ ⟩) ⟩ ∣ 𝔟⟨ x₀ ⟩) ⊗ (∂₀ 𝔟⟨ x₀ ⟩))
                                       ⊕ ((∂ 𝔞⟨ (𝔟⟨ x₁ ⟩) ◂ x₀ ⟩ ∣ 𝔠⟨ x₀ ⟩) ⊗ (∂₀ 𝔠⟨ x₀ ⟩))

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning

-- Derived equations
𝟘U⊕ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ⊕ 𝟘 ≋ 𝔞
𝟘U⊕ᴿ = tr (ax ⊕C with《 𝔞 ◃ 𝟘 》) (ax 𝟘U⊕ᴸ with《 𝔞 》)
𝟙U⊗ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ⊗ 𝟙 ≋ 𝔞
𝟙U⊗ᴿ = tr (ax ⊗C with《 𝔞 ◃ 𝟙 》) (ax 𝟙U⊗ᴸ with《 𝔞 》)
⊗D⊕ᴿ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ⊕ 𝔟) ⊗ 𝔠 ≋ (𝔞 ⊗ 𝔠) ⊕ (𝔟 ⊗ 𝔠)
⊗D⊕ᴿ = begin
  (𝔞 ⊕ 𝔟) ⊗ 𝔠       ≋⟨ ax ⊗C with《 𝔞 ⊕ 𝔟 ◃ 𝔠 》 ⟩
  𝔠 ⊗ (𝔞 ⊕ 𝔟)       ≋⟨ ax ⊗D⊕ᴸ with《 𝔠 ◃ 𝔞 ◃ 𝔟 》 ⟩
  (𝔠 ⊗ 𝔞) ⊕ (𝔠 ⊗ 𝔟)  ≋⟨ cong₂[ ax ⊗C with《 𝔠 ◃ 𝔞 》 ][ ax ⊗C with《 𝔠 ◃ 𝔟 》 ]inside ◌ᵈ ⊕ ◌ᵉ ⟩
  (𝔞 ⊗ 𝔠) ⊕ (𝔟 ⊗ 𝔠)  ∎
𝟘X⊗ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ⊗ 𝟘 ≋ 𝟘
𝟘X⊗ᴿ = tr (ax ⊗C with《 𝔞 ◃ 𝟘 》) (ax 𝟘X⊗ᴸ with《 𝔞 》)
⊖N⊕ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ⊕ (⊖ 𝔞) ≋ 𝟘
⊖N⊕ᴿ = tr (ax ⊕C with《 𝔞 ◃ (⊖ 𝔞) 》) (ax ⊖N⊕ᴸ with《 𝔞 》)

-- Derivative of a variable is 1
∂id : ⁅⁆ ▹ ⌊ * ⌋ ⊢ ∂₀ x₀ ≋ 𝟙
∂id = begin
      ∂₀ x₀       ≋⟨ cong[ thm 𝟘U⊕ᴿ with《 x₀ 》 ]inside ∂₀ ◌ᵃ ⟩ₛ
      ∂₀ (x₀ ⊕ 𝟘) ≋⟨ ax ∂⊕ with《 𝟘 》 ⟩
      𝟙           ∎

-- Derivative of 0 is 0
∂𝟘 : ⁅⁆ ▹ ⌊ * ⌋ ⊢ ∂₀ 𝟘 ≋ 𝟘
∂𝟘 = begin
      ∂₀ 𝟘         ≋⟨ cong[ ax 𝟘X⊗ᴸ with《 x₀ 》 ]inside ∂₀ ◌ᵃ ⟩ₛ
      ∂₀ (𝟘 ⊗ x₀)  ≋⟨ ax ∂⊗ with《 𝟘 》 ⟩
      𝟘            ∎

-- Unary chain rule
∂Ch₁ : ⁅ * ⊩ * ⁆ ⁅ * ⊩ * ⁆̣ ▹ ⌊ * ⌋
     ⊢ ∂₀ 𝔞⟨ (𝔟⟨ x₀ ⟩) ⟩ ≋ (∂ 𝔞⟨ x₀ ⟩ ∣ 𝔟⟨ x₀ ⟩) ⊗ (∂₀ 𝔟⟨ x₀ ⟩)
∂Ch₁ = begin
      ∂₀ (𝔞⟨ (𝔟⟨ x₀ ⟩) ⟩)
  ≋⟨ ax ∂Ch₂ with《 𝔞⟨ x₀ ⟩ ◃ 𝔟⟨ x₀ ⟩ ◃ 𝟘 》 ⟩
        (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩))
      ⊕ ((∂ 𝔞⟨ (𝔟⟨ x₁ ⟩) ⟩ ∣ 𝟘) ⊗ (∂₀ 𝟘))
  ≋⟨ cong[ thm ∂𝟘 ]inside (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩)) ⊕
                          ((∂ 𝔞⟨ (𝔟⟨ x₁ ⟩) ⟩ ∣ 𝟘) ⊗ ◌ᶜ) ⟩
        (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩))
      ⊕ (∂ 𝔞⟨ (𝔟⟨ x₁ ⟩) ⟩ ∣ 𝟘) ⊗ 𝟘
  ≋⟨ cong[ thm 𝟘X⊗ᴿ with《 (∂ 𝔞⟨ (𝔟⟨ x₁ ⟩) ⟩ ∣ 𝟘) 》 ]inside (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩)) ⊕ ◌ᶜ ⟩
        (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩))
      ⊕ 𝟘
  ≋⟨ thm 𝟘U⊕ᴿ with《 (∂ 𝔞⟨ x₀ ⟩ ∣ (𝔟⟨ x₀ ⟩)) ⊗ (∂₀ (𝔟⟨ x₀ ⟩)) 》 ⟩
      (∂ 𝔞⟨ x₀ ⟩ ∣ 𝔟⟨ x₀ ⟩) ⊗ (∂₀ 𝔟⟨ x₀ ⟩)
  ∎


-- Note that this module assumes function extensionality
module guarded-recursion.prelude where

open import Level
              public
              using (_⊔_)
              renaming (zero to ₀
                       ;suc  to ₛ)
open import Function
              public
              using (id; _∘_; _∘′_)
open import Data.Nat
              public
              using (ℕ; _+_)
              renaming (zero to O
                       ;suc  to S)
open import Data.Bool
              public
              renaming (Bool  to 𝟚
                       ;false to 0₂
                       ;true  to 1₂)
open import Data.Sum
              public
              using (_⊎_; [_,_])
              renaming (inj₁ to inl
                       ;inj₂ to inr)
open import Data.Maybe
              public
              using (Maybe; nothing; just)
open import Data.Empty
              public
              renaming (⊥ to 𝟘
                       ;⊥-elim to 𝟘-elim)
open import Data.Unit
              public
              using ()
          --  using (Hidden; Unit; hide; reveal)
              renaming (⊤ to 𝟙)
open import Data.Unit.NonEta
              public
              using (Hidden; Unit; hide; reveal)
import      Data.Product
open        Data.Product
              public
              using (Σ; _×_; _,_; curry; <_,_>)
              renaming (proj₁ to fst
                       ;proj₂ to snd)
open import Relation.Binary
              public
              using (Reflexive)
import      Relation.Binary.PropositionalEquality
open        Relation.Binary.PropositionalEquality
              public
              using (_≡_)
              renaming (subst to transport
                       ;refl  to idp
                       ;sym   to !
                       ;cong  to ap)
import Relation.Binary.PropositionalEquality.TrustMe
module ThisIsUnsafeButPlease = Relation.Binary.PropositionalEquality.TrustMe

-- using stdlib only
infixr 8 _∙_
_∙_ = Relation.Binary.PropositionalEquality.trans

ℕ² = ℕ × ℕ

-- Let's rename "Set₀" as "Type" to avoid confusion with set-theory
Type = Set

-- Let's rename "Set ℓ" as "Type_ ℓ" to avoid confusion with set-theory
Type_ : ∀ ℓ → Set (ₛ ℓ)
Type_ ℓ = Set ℓ

-→- : ∀ {a b} → Type_ a → Type_ b → Type_ (a ⊔ b)
-→- A B = A → B

Endo : ∀ {a} → Type_ a → Type_ a
Endo A = A → A

Fix : ∀ {a} → Type_ a → Type_ a
Fix X = (X → X) → X

postulate
  funext : ∀ {a b}
             {A : Type_ a} {B : A → Type_ b}
             {f g : (x : A) → B x}
           → (∀ x → f x ≡ g x)
           → f ≡ g

𝟘-elim-uniq! : ∀ {a} {A : Type_ a} {f : 𝟘 → A} → 𝟘-elim ≡ f
𝟘-elim-uniq! = funext (λ())

[,]-uniq! : ∀ {a b c} {A : Type_ a} {B : Type_ b} {C : Type_ c}
              {f : (A ⊎ B) → C}
            → [ f ∘ inl , f ∘ inr ] ≡ f
[,]-uniq! = funext p
  where p : (_ : _ ⊎ _) → _
        p (inl _) = idp
        p (inr _) = idp

module Coe {ℓ} where
    coe : {A B : Type_ ℓ} → A ≡ B → A → B
    coe = transport id

    coe! : {A B : Type_ ℓ} → A ≡ B → B → A
    coe! = transport id ∘ !

    module _ {a} {A : Type_ a} {P Q : A → Type_ ℓ} (p : P ≡ Q) {x} where
        coe₁ : P x → Q x
        coe₁ = transport (λ P → P x) p

        coe₁! : Q x → P x
        coe₁! = transport (λ P → P x) (! p)

    module _ {a b} {A : Type_ a} {B : Type_ b} {R S : A → B → Type_ ℓ} (p : R ≡ S) {x y} where
        coe₂ : R x y → S x y
        coe₂ = transport (λ R → R x y) p

        coe₂! : S x y → R x y
        coe₂! = transport (λ R → R x y) (! p)

[0:_1:_] : ∀ {a} {A : Type_ a} (a₀ a₁ : A) → 𝟚 → A
[0: a₀ 1: a₁ ] 0₂ = a₀
[0: a₀ 1: a₁ ] 1₂ = a₁


module moveArg where
open import Agda.Builtin.Nat
open import Agda.Builtin.Bool

stuff : ( number : Nat) -> Bool -> Bool
stuff number bool = {!   !}

stuff2 : Nat -> Bool -> Bool
stuff2 number bool = bool

nonsense : Bool
nonsense = stuff 0 true

dep : (A : Set) -> (B : A) -> Bool -> Bool
dep a b c = c

unnamedDep : (A : Set) -> A -> Bool -> Bool
unnamedDep a b c = c

sameName : (A : Set) -> {A : Set} -> A -> A
sameName set a = a

nonDep : (A : Set) -> (B : Set) -> B -> B
nonDep set1 set2 b = b

data List (A : Set) : Nat -> Set where
    nil : List A 0
    cons : {n : Nat} -> A -> List A n -> List A (suc n)

map : {n : Nat} -> {A : Set} -> {B : Set} -> (A -> B) -> List A n -> List B n
map f nil = nil
map f (cons x xs) = cons (f x) (map f xs)

map2 : {A : Set} -> {n : Nat} -> {B : Set} -> (A -> B) -> List A n -> List B n
map2 f nil = nil
map2 f (cons x xs) = cons (f x) (map2 f xs)


open import Relation.Binary using (Rel)
open import Algebra.Bundles using (CommutativeRing)

open import Algebra.Module.Normed

module Algebra.Module.Limit.Compose
  {r ℓr} {CR : CommutativeRing r ℓr}
  (open CommutativeRing CR using () renaming (Carrier to X))
  {rel} {_≤_ : Rel X rel}
  {ma ℓma} (MA : NormedModule CR _≤_ ma ℓma)
  {mb ℓmb} (MB : NormedModule CR _≤_ mb ℓmb)
  {mc ℓmc} (MC : NormedModule CR _≤_ mc ℓmc)
  where

open import Data.Product using (_,_)
open import Function using (_∘_)

open CommutativeRing CR
open import Assume using (assume)

import Algebra.Module.Limit as Limit

open Limit MA MB using () renaming
  ( _DifferentiableAt_ to _DifferentiableAt₁₂_
  ; Differentiable to Differentiable₁₂
  )

open Limit MB MC using () renaming
  (_DifferentiableAt_ to _DifferentiableAt₂₃_
  ; Differentiable to Differentiable₂₃
  )

open Limit MA MC using () renaming
  (_DifferentiableAt_ to _DifferentiableAt₁₃_
  ; Differentiable to Differentiable₁₃
  )

private
  module MA = NormedModule MA
  module MB = NormedModule MB
  module MC = NormedModule MC

∘-differentiable-at : ∀ {g f x} → g DifferentiableAt₂₃ (f x) → f DifferentiableAt₁₂ x → (g ∘ f) DifferentiableAt₁₃ x
∘-differentiable-at {g} {f} {x} (Dg , _) (Df , _) = (Dg ∘ Df) , assume

∘-differentiable : ∀ {g f} → Differentiable₂₃ g → Differentiable₁₂ f → Differentiable₁₃ (g ∘ f)
∘-differentiable {g} {f} diff-g diff-f = λ x → ∘-differentiable-at {g} {f} {x} (diff-g (f x)) (diff-f x)


{-# OPTIONS --without-K #-}
module NTypes.Empty where

open import NTypes
open import Types

0-isSet : isSet ⊥
0-isSet x = 0-elim x


module _ where

open import Agda.Primitive.Cubical hiding (PathP)

postulate
  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

{-# BUILTIN PATHP        PathP     #-}


{-

Constant structure: _ ↦ A

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Constant where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv

open import Cubical.Foundations.SIP

private
  variable
    ℓ ℓ' : Level

-- Structured isomorphisms

module _ (A : Type ℓ') where

  ConstantStructure : Type ℓ → Type ℓ'
  ConstantStructure _ = A

  ConstantEquivStr : StrEquiv {ℓ} ConstantStructure ℓ'
  ConstantEquivStr (_ , a) (_ , a') _ = a ≡ a'

  constantUnivalentStr : UnivalentStr {ℓ} ConstantStructure ConstantEquivStr
  constantUnivalentStr e = idEquiv _


{-# OPTIONS --without-K --safe #-}
module Categories.Adjoint.Relative where

-- Relative Adjoints, in their biased, level-restricted version
--   In other words, this uses the Hom-Setoid equivalent variant
--   of the adjoint formulation because relative adjoints don't
--   have a natural unit/counit formulation.

-- We use the Altenkirch-Chapman-Uustalu formulation, which means
-- that what is adjoint is a Functor and a Category.

open import Level

open import Data.Product using (_,_; _×_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality using (Π; _⟶_; _⟨$⟩_)
open import Relation.Binary using (Setoid)

-- be explicit in imports to 'see' where the information comes from
open import Categories.Adjoint
open import Categories.Category.Core using (Category)
open import Categories.Category.Product using (Product; _⁂_)
open import Categories.Category.Instance.Setoids
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Hom using (Hom[_][-,-])
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism)
import Categories.Morphism.Reasoning as MR
open import Categories.Monad.Relative renaming (Monad to RMonad)

private
  variable
    o o′ ℓ ℓ′ e e′ : Level
    E : Category o ℓ e

record RelativeAdjoint {C : Category o ℓ e} (D : Category o ℓ e) (J : Functor E C)  : Set (levelOfTerm D ⊔ levelOfTerm J) where
  field
    L : Functor E D
    R : Functor D C

  private
    module C = Category C
    module D = Category D
    module E = Category E
    module L = Functor L
    module R = Functor R
    module J = Functor J

  Hom[L-,-] : Bifunctor E.op D (Setoids _ _)
  Hom[L-,-] = Hom[ D ][-,-] ∘F (L.op ⁂ idF)

  Hom[J-,R-] : Bifunctor E.op D (Setoids _ _)
  Hom[J-,R-] = Hom[ C ][-,-] ∘F (J.op ⁂ R)

  module Hom[L-,-] = Functor Hom[L-,-]
  module Hom[J-,R-] = Functor Hom[J-,R-]

  field
    Hom-NI : NaturalIsomorphism Hom[J-,R-] Hom[L-,-]

RA⇒RMonad : {C D : Category o ℓ e} {E : Category o′ ℓ′ e′} {J : Functor E C} → RelativeAdjoint D J → RMonad J
RA⇒RMonad {C = C} {D} {E} {J} RA = record
  { F₀ = F₀ (R ∘F L)
  ; unit = λ {c} → ⇐.η (c , F₀ L c) ⟨$⟩ D.id {F₀ L c}
  ; extend = λ {X} {Y} k → F₁ R (⇒.η (X , F₀ L Y) ⟨$⟩ k)
  ; identityʳ = idʳ
  ; identityˡ = R.F-resp-≈ (iso.isoʳ _ D.Equiv.refl) ○ R.identity
  ; assoc = a
  ; extend-≈ = λ k≈h → F-resp-≈ R (Π.cong (⇒.η _) k≈h)
  }
  where
  open RelativeAdjoint RA
  open Functor
  open NaturalIsomorphism Hom-NI
  module D = Category D
  module E = Category E
  module J = Functor J
  module L = Functor L
  module R = Functor R
  open Category C
  open HomReasoning
  open MR C
  idʳ : {x y : E.Obj} {k : J.₀ x ⇒ F₀ (R ∘F L) y} → R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k) ∘ (⇐.η (x , L.₀ x) ⟨$⟩ D.id) ≈ k
  idʳ {x} {y} {k} = begin
    R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k) ∘ (⇐.η (x , L.₀ x) ⟨$⟩ D.id)               ≈⟨ introʳ J.identity ⟩
    (R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k) ∘ (⇐.η (x , L.₀ x) ⟨$⟩ D.id)) ∘ J.₁ E.id  ≈⟨ assoc ⟩
    R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k) ∘ (⇐.η (x , L.₀ x) ⟨$⟩ D.id) ∘ J.₁ E.id    ≈⟨ ⇐.sym-commute (E.id , ⇒.η (x , L.₀ y) ⟨$⟩ k) (D.Equiv.refl) ⟩
    ⇐.η (x , L.₀ y) ⟨$⟩ ((⇒.η (x , L.₀ y) ⟨$⟩ k) D.∘ D.id D.∘ L.F₁ E.id)   ≈⟨ Π.cong (⇐.η _) (MR.elimʳ D (MR.elimʳ D L.identity)) ⟩
    ⇐.η (x , L.₀ y) ⟨$⟩ (⇒.η (x , L.₀ y) ⟨$⟩ k)                            ≈⟨ iso.isoˡ (x , _) Equiv.refl ⟩
    k            ∎
  a : {x y z : E.Obj} {k : J.₀ x ⇒ R.₀ (L.₀ y)} {l : J.₀ y ⇒ R.₀ (L.₀ z)} →
      R.₁ (⇒.η (x , L.₀ z) ⟨$⟩ R.₁ (⇒.η (y , L.₀ z) ⟨$⟩ l) ∘ k) ≈
      R.₁ (⇒.η (y , L.₀ z) ⟨$⟩ l) ∘ R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k)
  a {x} {y} {z} {k} {l} = begin
    R.₁ (⇒.η (x , L.₀ z) ⟨$⟩ (R.₁ (⇒.η (y , L.₀ z) ⟨$⟩ l) ∘ k)) ≈⟨ R.F-resp-≈ lemma ⟩
    R.₁ ((⇒.η (y , L.₀ z) ⟨$⟩ l) D.∘ (⇒.η (x , L.₀ y) ⟨$⟩ k))   ≈⟨ R.homomorphism ⟩
    R.₁ (⇒.η (y , L.₀ z) ⟨$⟩ l) ∘ R.₁ (⇒.η (x , L.₀ y) ⟨$⟩ k)   ∎
    where
    xz = (x , L.₀ z)
    yz = (y , L.₀ z)
    xy = (x , L.₀ y)
    module DR = D.HomReasoning
    lemma : ⇒.η xz ⟨$⟩ R.₁ (⇒.η yz ⟨$⟩ l) ∘ k D.≈ (⇒.η yz ⟨$⟩ l) D.∘ (⇒.η xy ⟨$⟩ k)
    lemma = DR.begin
      ⇒.η xz ⟨$⟩ R.₁ (⇒.η yz ⟨$⟩ l) ∘ k                DR.≈⟨ Π.cong (⇒.η xz) (refl⟩∘⟨ introʳ J.identity ) ⟩
      ⇒.η xz ⟨$⟩ R.₁ (⇒.η yz ⟨$⟩ l) ∘ (k ∘ J.₁ E.id)   DR.≈⟨ ⇒.commute (E.id , ⇒.η yz ⟨$⟩ l) Equiv.refl ⟩
      (⇒.η yz ⟨$⟩ l) D.∘ (⇒.η xy ⟨$⟩ k) D.∘ L.₁ E.id   DR.≈⟨ D.sym-assoc  ⟩
      ((⇒.η yz ⟨$⟩ l) D.∘ (⇒.η xy ⟨$⟩ k)) D.∘ L.₁ E.id DR.≈⟨ MR.elimʳ D L.identity ⟩
      (⇒.η yz ⟨$⟩ l) D.∘ (⇒.η xy ⟨$⟩ k) DR.∎

⊣⇒RAdjoint : {C D : Category o ℓ e} {E : Category o′ ℓ′ e′} (L : Functor C D) (R : Functor D C) (J : Functor E C) → L ⊣ R → RelativeAdjoint D J
⊣⇒RAdjoint {C = C} {D} L R J A = record
  { L = L ∘F J
  ; R = R
  ; Hom-NI = record
    { F⇒G = ntHelper record
      { η = λ _ → record { _⟨$⟩_ = Radjunct ; cong = ∘-resp-≈ʳ ∙ L.F-resp-≈ }
      ; commute = λ _ x≈y → Radjunct-comm x≈y
      }
    ; F⇐G = ntHelper record
      { η = λ _ → record { _⟨$⟩_ = Ladjunct ; cong = C.∘-resp-≈ˡ ∙ R.F-resp-≈ }
      ; commute = λ _ x≈y → Ladjunct-comm x≈y
      }
    ; iso = λ X → record
      { isoˡ = λ eq → LRadjunct≈id ○ eq
      ; isoʳ = Equiv.trans RLadjunct≈id
      }
    }
  }
  where
  open Adjoint A
  open Category D
  module C = Category C
  module L = Functor L
  module R = Functor R
  module J = Functor J
  open C.HomReasoning


{-
This second-order equational theory was created from the following second-order syntax description:

syntax TLC | Λ

type
  N   : 0-ary
  _↣_ : 2-ary | r30
  𝟙   : 0-ary
  _⊗_ : 2-ary | l40
  𝟘   : 0-ary
  _⊕_ : 2-ary | l30

term
  app   : α ↣ β  α  ->  β | _$_ l20
  lam   : α.β  ->  α ↣ β | ƛ_ r10
  unit  : 𝟙
  pair  : α  β  ->  α ⊗ β | ⟨_,_⟩
  fst   : α ⊗ β  ->  α
  snd   : α ⊗ β  ->  β
  abort : 𝟘  ->  α
  inl   : α  ->  α ⊕ β
  inr   : β  ->  α ⊕ β
  case  : α ⊕ β  α.γ  β.γ  ->  γ
  ze    : N
  su    : N  ->  N
  nrec  : N  α  (α,N).α  ->  α

theory
  (ƛβ) b : α.β  a : α |> app (lam(x.b[x]), a) = b[a]
  (ƛη) f : α ↣ β      |> lam (x. app(f, x))   = f
  (𝟙η) u : 𝟙 |> u = unit
  (fβ) a : α  b : β |> fst (pair(a, b))      = a
  (sβ) a : α  b : β |> snd (pair(a, b))      = b
  (pη) p : α ⊗ β    |> pair (fst(p), snd(p)) = p
  (𝟘η) e : 𝟘  c : α |> abort(e) = c
  (lβ) a : α   f : α.γ  g : β.γ |> case (inl(a), x.f[x], y.g[y])      = f[a]
  (rβ) b : β   f : α.γ  g : β.γ |> case (inr(b), x.f[x], y.g[y])      = g[b]
  (cη) s : α ⊕ β  c : (α ⊕ β).γ |> case (s, x.c[inl(x)], y.c[inr(y)]) = c[s]
  (zeβ) z : α   s : (α,N).α        |> nrec (ze,       z, r m. s[r,m]) = z
  (suβ) z : α   s : (α,N).α  n : N |> nrec (su (n), z, r m. s[r,m]) = s[nrec (n, z, r m. s[r,m]), n]
  (ift) t f : α |> if (true,  t, f) = t
  (iff) t f : α |> if (false, t, f) = f
-}

module TLC.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import TLC.Signature
open import TLC.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution Λ:Syn
open import SOAS.Metatheory.SecondOrder.Equality Λ:Syn

private
  variable
    α β γ τ : ΛT
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ Λ) α Γ → (𝔐 ▷ Λ) α Γ → Set where
  ƛβ  : ⁅ α ⊩ β ⁆ ⁅ α ⁆̣           ▹ ∅ ⊢                    (ƛ 𝔞⟨ x₀ ⟩) $ 𝔟 ≋ₐ 𝔞⟨ 𝔟 ⟩
  ƛη  : ⁅ α ↣ β ⁆̣                 ▹ ∅ ⊢                         ƛ (𝔞 $ x₀) ≋ₐ 𝔞
  𝟙η  : ⁅ 𝟙 ⁆̣                     ▹ ∅ ⊢                                  𝔞 ≋ₐ unit
  fβ  : ⁅ α ⁆ ⁅ β ⁆̣               ▹ ∅ ⊢                    fst (⟨ 𝔞 , 𝔟 ⟩) ≋ₐ 𝔞
  sβ  : ⁅ α ⁆ ⁅ β ⁆̣               ▹ ∅ ⊢                    snd (⟨ 𝔞 , 𝔟 ⟩) ≋ₐ 𝔟
  pη  : ⁅ α ⊗ β ⁆̣                 ▹ ∅ ⊢              ⟨ (fst 𝔞) , (snd 𝔞) ⟩ ≋ₐ 𝔞
  𝟘η  : ⁅ 𝟘 ⁆ ⁅ α ⁆̣               ▹ ∅ ⊢                            abort 𝔞 ≋ₐ 𝔟
  lβ  : ⁅ α ⁆ ⁅ α ⊩ γ ⁆ ⁅ β ⊩ γ ⁆̣ ▹ ∅ ⊢   case (inl 𝔞) (𝔟⟨ x₀ ⟩) (𝔠⟨ x₀ ⟩) ≋ₐ 𝔟⟨ 𝔞 ⟩
  rβ  : ⁅ β ⁆ ⁅ α ⊩ γ ⁆ ⁅ β ⊩ γ ⁆̣ ▹ ∅ ⊢   case (inr 𝔞) (𝔟⟨ x₀ ⟩) (𝔠⟨ x₀ ⟩) ≋ₐ 𝔠⟨ 𝔞 ⟩
  cη  : ⁅ α ⊕ β ⁆ ⁅ (α ⊕ β) ⊩ γ ⁆̣ ▹ ∅ ⊢ case 𝔞 (𝔟⟨ inl x₀ ⟩) (𝔟⟨ inr x₀ ⟩) ≋ₐ 𝔟⟨ 𝔞 ⟩
  zeβ : ⁅ α ⁆ ⁅ α · N ⊩ α ⁆̣       ▹ ∅ ⊢           nrec ze 𝔞 (𝔟⟨ x₀ ◂ x₁ ⟩) ≋ₐ 𝔞
  suβ : ⁅ α ⁆ ⁅ α · N ⊩ α ⁆ ⁅ N ⁆̣ ▹ ∅ ⊢       nrec (su 𝔠) 𝔞 (𝔟⟨ x₀ ◂ x₁ ⟩) ≋ₐ 𝔟⟨ (nrec 𝔠 𝔞 (𝔟⟨ x₀ ◂ x₁ ⟩)) ◂ 𝔠 ⟩

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning

-- Derived equations
ift : ⁅ α ⁆ ⁅ α ⁆̣ ▹ ∅ ⊢ if true 𝔞 𝔟 ≋ 𝔞
ift = ax lβ with《 unit ◃ 𝔞 ◃ 𝔟 》
iff : ⁅ α ⁆ ⁅ α ⁆̣ ▹ ∅ ⊢ if false 𝔞 𝔟 ≋ 𝔟
iff = ax rβ with《 unit ◃ 𝔞 ◃ 𝔟 》

-- Double beta reduction
ƛβ² : ⁅ β · α ⊩ γ ⁆ ⁅ α ⁆ ⁅ β ⁆̣ ▹ ∅ ⊢ (ƛ (ƛ 𝔞⟨ x₀ ◂ x₁ ⟩)) $ 𝔟 $ 𝔠 ≋ 𝔞⟨ 𝔠 ◂ 𝔟 ⟩
ƛβ² = begin
      (ƛ (ƛ 𝔞⟨ x₀ ◂ x₁ ⟩)) $ 𝔟 $ 𝔠
  ≋⟨ cong[ ax ƛβ with《 (ƛ 𝔞⟨ x₀ ◂ x₁ ⟩) ◃ 𝔟 》 ]inside ◌ᵈ $ 𝔠 ⟩
      (ƛ 𝔞⟨ x₀ ◂ 𝔟 ⟩) $ 𝔠
  ≋⟨ ax ƛβ with《 (𝔞⟨ x₀ ◂ 𝔟 ⟩) ◃ 𝔠 》 ⟩
      𝔞⟨ 𝔠 ◂ 𝔟 ⟩
  ∎

-- Uncurrying and arithmetic
1+2 : ⁅⁆ ▹ ∅ ⊢ uncurry $ plus $ ⟨ su ze , su (su ze) ⟩ ≋ su (su (su ze))
1+2 = begin
      uncurry $ plus $ ⟨ su ze , su (su ze) ⟩
  ≋⟨ thm ƛβ² with《 x₁ $ fst x₀ $ snd x₀ ◃ plus ◃ ⟨ su ze , su (su ze) ⟩ 》 ⟩
      plus $ fst ⟨ su ze , su (su ze) ⟩ $ snd ⟨ su ze , su (su ze) ⟩
  ≋⟨ cong₂[ ax fβ with《 su ze ◃ su (su ze) 》 ][
            ax sβ with《 su ze ◃ su (su ze) 》 ]inside plus $ ◌ᵃ $ ◌ᵇ ⟩
      plus $ su ze $  su (su ze)
  ≋⟨ thm ƛβ² with《 nrec x₁ x₀ (su x₀) ◃ su ze ◃ su (su ze) 》 ⟩
      nrec (su ze) (su (su ze)) (su x₀)
  ≋⟨ ax suβ with《 su (su ze) ◃ su x₀ ◃ ze 》 ⟩
      su (nrec ze (su (su ze)) (su x₀))
  ≋⟨ cong[ ax zeβ with《 su (su ze) ◃ su x₀ 》 ]inside su ◌ᵃ ⟩
      su (su (su ze))
  ∎


-- {-# OPTIONS -v tc.meta:20 #-}
module UnifyWithIrrelevantArgument where

data _≡_ {A : Set}(a : A) : A -> Set where
  refl : a ≡ a

fail : (A : Set) ->
       let X : .A -> A
           X = _
       in  (x : A) -> X x ≡ x
fail A x = refl
-- error: X cannot depend on its first argument


{-# OPTIONS --safe #-}
module JVM.Contexts where

open import JVM.Types

open import Relation.Ternary.Construct.List.Overlapping Ty public
  renaming
    ( overlap-rel to ctx-rel
    ; overlap-commutative to ctx-commutative
    ; overlap-semigroup to ctx-semigroup
    ; overlap-monoid to ctx-monoid)


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

module Agda.Builtin.List where

infixr 5 _∷_
data List {a} (A : Set a) : Set a where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  []   #-}
{-# BUILTIN CONS _∷_  #-}

{-# FOREIGN GHC type AgdaList a b = [b] #-}

{-# COMPILE GHC List = data MAlonzo.Code.Agda.Builtin.List.AgdaList ([] | (:)) #-}
{-# COMPILE UHC List = data __LIST__ (__NIL__ | __CONS__) #-}
{-# COMPILE JS  List = function(x,v) {
  if (x.length < 1) { return v["[]"](); } else { return v["_∷_"](x[0], x.slice(1)); }
} #-}
{-# COMPILE JS [] = Array() #-}
{-# COMPILE JS _∷_ = function (x) { return function(y) { return Array(x).concat(y); }; } #-}


------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module LTC-PCF.Data.Nat.Inequalities.Properties where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Inequalities
open import LTC-PCF.Data.Nat.Inequalities.EliminationProperties
open import LTC-PCF.Data.Nat.Inequalities.ConversionRules public
open import LTC-PCF.Data.Nat.Properties
open import LTC-PCF.Data.Nat.UnaryNumbers

------------------------------------------------------------------------------
-- N.B. The elimination properties are in the module
-- LTC.Data.Nat.Inequalities.EliminationProperties.

------------------------------------------------------------------------------
-- Congruence properties

ltLeftCong : ∀ {m n o} → m ≡ n → lt m o ≡ lt n o
ltLeftCong refl = refl

ltRightCong : ∀ {m n o} → n ≡ o → lt m n ≡ lt m o
ltRightCong refl = refl

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

0≯x : ∀ {n} → N n → zero ≯ n
0≯x nzero          = lt-00
0≯x (nsucc {n} Nn) = lt-S0 n

x≮x : ∀ {n} → N n → n ≮ n
x≮x nzero          = lt-00
x≮x (nsucc {n} Nn) = trans (lt-SS n n) (x≮x Nn)

Sx≰0 : ∀ {n} → N n → succ₁ n ≰ zero
Sx≰0 nzero          = x≮x (nsucc nzero)
Sx≰0 (nsucc {n} Nn) = trans (lt-SS (succ₁ n) zero) (lt-S0 n)

x<Sx : ∀ {n} → N n → n < succ₁ n
x<Sx nzero          = lt-0S zero
x<Sx (nsucc {n} Nn) = trans (lt-SS n (succ₁ n)) (x<Sx Nn)

x<y→Sx<Sy : ∀ {m n} → m < n → succ₁ m < succ₁ n
x<y→Sx<Sy {m} {n} m<n = trans (lt-SS m n) m<n

Sx<Sy→x<y : ∀ {m n} → succ₁ m < succ₁ n → m < n
Sx<Sy→x<y {m} {n} Sm<Sn = trans (sym (lt-SS m n)) Sm<Sn

x≤x : ∀ {n} → N n → n ≤ n
x≤x nzero          = lt-0S zero
x≤x (nsucc {n} Nn) = trans (lt-SS n (succ₁ n)) (x≤x Nn)

x≤y→Sx≤Sy : ∀ {m n} → m ≤ n → succ₁ m ≤ succ₁ n
x≤y→Sx≤Sy {m} {n} m≤n = trans (lt-SS m (succ₁ n)) m≤n

Sx≤Sy→x≤y : ∀ {m n} → succ₁ m ≤ succ₁ n → m ≤ n
Sx≤Sy→x≤y {m} {n} Sm≤Sn = trans (sym (lt-SS m (succ₁ n))) Sm≤Sn

x≥y→x≮y : ∀ {m n} → N m → N n → m ≥ n → m ≮ n
x≥y→x≮y nzero          nzero          _     = x≮x nzero
x≥y→x≮y nzero          (nsucc Nn)     0≥Sn  = ⊥-elim (0≥S→⊥ Nn 0≥Sn)
x≥y→x≮y (nsucc {m} Nm) nzero          _     = lt-S0 m
x≥y→x≮y (nsucc {m} Nm) (nsucc {n} Nn) Sm≥Sn =
  trans (lt-SS m n) (x≥y→x≮y Nm Nn (trans (sym (lt-SS n (succ₁ m))) Sm≥Sn))

x≮y→x≥y : ∀ {m n} → N m → N n → m ≮ n → m ≥ n
x≮y→x≥y nzero nzero 0≮0 = x≤x nzero
x≮y→x≥y nzero (nsucc {n} Nn) 0≮Sn = ⊥-elim (t≢f (trans (sym (lt-0S n)) 0≮Sn))
x≮y→x≥y (nsucc {m} Nm) nzero Sm≮n = lt-0S (succ₁ m)
x≮y→x≥y (nsucc {m} Nm) (nsucc {n} Nn) Sm≮Sn =
  trans (lt-SS n (succ₁ m)) (x≮y→x≥y Nm Nn (trans (sym (lt-SS m n)) Sm≮Sn))

x>y∨x≤y : ∀ {m n} → N m → N n → m > n ∨ m ≤ n
x>y∨x≤y {n = n} nzero Nn = inj₂ (lt-0S n)
x>y∨x≤y (nsucc {m} Nm) nzero = inj₁ (lt-0S m)
x>y∨x≤y (nsucc {m} Nm) (nsucc {n} Nn) =
  case (λ m>n → inj₁ (trans (lt-SS n m) m>n))
       (λ m≤n → inj₂ (trans (lt-SS m (succ₁ n)) m≤n))
       (x>y∨x≤y Nm Nn)

x≤y→x≯y : ∀ {m n} → N m → N n → m ≤ n → m ≯ n
x≤y→x≯y nzero          Nn             _    = 0≯x Nn
x≤y→x≯y (nsucc Nm)     nzero          Sm≤0 = ⊥-elim (S≤0→⊥ Nm Sm≤0)
x≤y→x≯y (nsucc {m} Nm) (nsucc {n} Nn) Sm≤Sn =
  trans (lt-SS n m) (x≤y→x≯y Nm Nn (trans (sym (lt-SS m (succ₁ n))) Sm≤Sn))

x≯y→x≤y : ∀ {m n} → N m → N n → m ≯ n → m ≤ n
x≯y→x≤y {n = n} nzero Nn _ = lt-0S n
x≯y→x≤y (nsucc {m} Nm) nzero Sm≯0 = ⊥-elim (t≢f (trans (sym (lt-0S m)) Sm≯0))
x≯y→x≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm≯Sn =
  trans (lt-SS m (succ₁ n)) (x≯y→x≤y Nm Nn (trans (sym (lt-SS n m)) Sm≯Sn))

x>y∨x≯y : ∀ {m n} → N m → N n → m > n ∨ m ≯ n
x>y∨x≯y nzero          Nn             = inj₂ (0≯x Nn)
x>y∨x≯y (nsucc {m} Nm) nzero          = inj₁ (lt-0S m)
x>y∨x≯y (nsucc {m} Nm) (nsucc {n} Nn) =
  case (λ h → inj₁ (trans (lt-SS n m) h))
       (λ h → inj₂ (trans (lt-SS n m) h))
       (x>y∨x≯y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → m < n ∨ m ≥ n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x<y∨x≮y : ∀ {m n} → N m → N n → m < n ∨ m ≮ n
x<y∨x≮y Nm Nn = case (λ m<n → inj₁ m<n)
                     (λ m≥n → inj₂ (x≥y→x≮y Nm Nn m≥n))
                     (x<y∨x≥y Nm Nn)

x≡y→x≤y : ∀ {m n} → N m → N n → m ≡ n → m ≤ n
x≡y→x≤y Nm _ refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → m < n → m ≤ n
x<y→x≤y Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→x≤y nzero          (nsucc {n} Nn) _     = lt-0S (succ₁ n)
x<y→x≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x≤y : ∀ {m n} → N m → N n → m < succ₁ n → m ≤ n
x<Sy→x≤y {n = n} nzero      Nn 0<Sn  = lt-0S n
x<Sy→x≤y         (nsucc Nm) Nn Sm<Sn = Sm<Sn

x≤Sx : ∀ {m} → N m → m ≤ succ₁ m
x≤Sx Nm = x<y→x≤y Nm (nsucc Nm) (x<Sx Nm)

x<y→Sx≤y : ∀ {m n} → N m → N n → m < n → succ₁ m ≤ n
x<y→Sx≤y Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→Sx≤y nzero          (nsucc {n} Nn) _     = x≤y→Sx≤Sy (lt-0S n)
x<y→Sx≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn =
  trans (lt-SS (succ₁ m) (succ₁ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → succ₁ m ≤ n → m < n
Sx≤y→x<y Nm             nzero          Sm≤0   = ⊥-elim (S≤0→⊥ Nm Sm≤0)
Sx≤y→x<y nzero          (nsucc {n} Nn) _      = lt-0S n
Sx≤y→x<y (nsucc {m} Nm) (nsucc {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

<-trans : ∀ {m n o} → N m → N n → N o → m < n → n < o → m < o
<-trans nzero          nzero           _             0<0   _    = ⊥-elim (0<0→⊥ 0<0)
<-trans nzero          (nsucc Nn)     nzero          _     Sn<0 = ⊥-elim (S<0→⊥ Sn<0)
<-trans nzero          (nsucc Nn)     (nsucc {o} No) _     _    = lt-0S o
<-trans (nsucc Nm)     Nn             nzero          _     n<0  = ⊥-elim (x<0→⊥ Nn n<0)
<-trans (nsucc Nm)     nzero          (nsucc No)     Sm<0  _    = ⊥-elim (S<0→⊥ Sm<0)
<-trans (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy (<-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So))

≤-trans : ∀ {m n o} → N m → N n → N o → m ≤ n → n ≤ o → m ≤ o
≤-trans {o = o} nzero Nn No _ _ = lt-0S o
≤-trans (nsucc Nm) nzero No Sm≤0 _ = ⊥-elim (S≤0→⊥ Nm Sm≤0)
≤-trans (nsucc Nm) (nsucc Nn) nzero _ Sn≤0 = ⊥-elim (S≤0→⊥ Nn Sn≤0)
≤-trans (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → m ≤ m + n
x≤x+y {n = n} nzero Nn = lt-0S (zero + n)
x≤x+y {n = n} (nsucc {m} Nm) Nn =
  lt (succ₁ m) (succ₁ (succ₁ m + n)) ≡⟨ lt-SS m (succ₁ m + n) ⟩
  lt m (succ₁ m + n)                 ≡⟨ ltRightCong (+-Sx m n) ⟩
  lt m (succ₁ (m + n))               ≡⟨ refl ⟩
  le m (m + n)                       ≡⟨ x≤x+y Nm Nn ⟩
  true                               ∎

x∸y<Sx : ∀ {m n} → N m → N n → m ∸ n < succ₁ m
x∸y<Sx {m} Nm nzero =
  lt (m ∸ zero) (succ₁ m) ≡⟨ ltLeftCong (∸-x0 m) ⟩
  lt m (succ₁ m)          ≡⟨ x<Sx Nm ⟩
  true                    ∎

x∸y<Sx nzero (nsucc {n} Nn) =
  lt (zero ∸ succ₁ n) [1] ≡⟨ ltLeftCong (0∸x (nsucc Nn)) ⟩
  lt zero [1]             ≡⟨ lt-0S zero ⟩
  true                    ∎

x∸y<Sx (nsucc {m} Nm) (nsucc {n} Nn) =
  lt (succ₁ m ∸ succ₁ n) (succ₁ (succ₁ m))
    ≡⟨ ltLeftCong (S∸S Nm Nn) ⟩
  lt (m ∸ n) (succ₁ (succ₁ m))
     ≡⟨ <-trans (∸-N Nm Nn) (nsucc Nm) (nsucc (nsucc Nm))
                (x∸y<Sx Nm Nn) (x<Sx (nsucc Nm))
     ⟩
  true ∎

Sx∸Sy<Sx : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n < succ₁ m
Sx∸Sy<Sx {m} {n} Nm Nn =
  lt (succ₁ m ∸ succ₁ n) (succ₁ m) ≡⟨ ltLeftCong (S∸S Nm Nn) ⟩
  lt (m ∸ n) (succ₁ m)             ≡⟨ x∸y<Sx Nm Nn ⟩
  true                             ∎

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → m > n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x nzero Nn 0>n = ⊥-elim (0>x→⊥ Nn 0>n)
x>y→x∸y+y≡x (nsucc {m} Nm) nzero Sm>0 =
  trans (+-rightIdentity (∸-N (nsucc Nm) nzero)) (∸-x0 (succ₁ m))
x>y→x∸y+y≡x (nsucc {m} Nm) (nsucc {n} Nn) Sm>Sn =
  (succ₁ m ∸ succ₁ n) + succ₁ n
    ≡⟨ +-leftCong (S∸S Nm Nn)  ⟩
  (m ∸ n) + succ₁ n
     ≡⟨ +-comm (∸-N Nm Nn) (nsucc Nn) ⟩
  succ₁ n + (m ∸ n)
    ≡⟨ +-Sx n (m ∸ n) ⟩
  succ₁ (n + (m ∸ n))
    ≡⟨ succCong (+-comm Nn (∸-N Nm Nn)) ⟩
  succ₁ ((m ∸ n) + n)
    ≡⟨ succCong (x>y→x∸y+y≡x Nm Nn (trans (sym (lt-SS n m)) Sm>Sn)) ⟩
  succ₁ m ∎

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → m ≤ n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} nzero Nn 0≤n =
  trans (+-rightIdentity (∸-N Nn nzero)) (∸-x0 n)
x≤y→y∸x+x≡y (nsucc Nm) nzero Sm≤0 = ⊥-elim (S≤0→⊥ Nm Sm≤0)
x≤y→y∸x+x≡y (nsucc {m} Nm) (nsucc {n} Nn) Sm≤Sn =
  (succ₁ n ∸ succ₁ m) + succ₁ m
    ≡⟨ +-leftCong (S∸S Nn Nm) ⟩
  (n ∸ m) + succ₁ m
     ≡⟨ +-comm (∸-N Nn Nm) (nsucc Nm) ⟩
  succ₁ m + (n ∸ m)
    ≡⟨ +-Sx m (n ∸ m) ⟩
  succ₁ (m + (n ∸ m))
    ≡⟨ succCong (+-comm Nm (∸-N Nn Nm)) ⟩
  succ₁ ((n ∸ m) + m)
    ≡⟨ succCong  (x≤y→y∸x+x≡y Nm Nn (trans (sym (lt-SS m (succ₁ n))) Sm≤Sn)) ⟩
  succ₁ n ∎

x<y→x<Sy : ∀ {m n} → N m → N n → m < n → m < succ₁ n
x<y→x<Sy Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→x<Sy nzero          (nsucc {n} Nn) 0<Sn  = lt-0S (succ₁ n)
x<y→x<Sy (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → m < succ₁ n → m < n ∨ m ≡ n
x<Sy→x<y∨x≡y nzero nzero 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y nzero (nsucc {n} Nn) 0<SSn = inj₁ (lt-0S n)
x<Sy→x<y∨x≡y (nsucc {m} Nm) nzero Sm<S0 =
  ⊥-elim (x<0→⊥ Nm (trans (sym (lt-SS m zero)) Sm<S0))
x<Sy→x<y∨x≡y (nsucc {m} Nm) (nsucc {n} Nn) Sm<SSn =
  case (λ m<n → inj₁ (trans (lt-SS m n) m<n))
       (λ m≡n → inj₂ (succCong m≡n))
       m<n∨m≡n
  where
  m<n∨m≡n : m < n ∨ m ≡ n
  m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym (lt-SS m (succ₁ n))) Sm<SSn)

x≤y→x<y∨x≡y : ∀ {m n} → N m → N n → m ≤ n → m < n ∨ m ≡ n
x≤y→x<y∨x≡y = x<Sy→x<y∨x≡y

x<y→y≡z→x<z : ∀ {m n o} → m < n → n ≡ o → m < o
x<y→y≡z→x<z m<n refl = m<n

x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → n < o → m < o
x≡y→y<z→x<z refl n<o = n<o

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → m ≥ n → n > zero → m ∸ n < m
x≥y→y>0→x∸y<x Nm             nzero          _     0>0  = ⊥-elim (x>x→⊥ nzero 0>0)
x≥y→y>0→x∸y<x nzero          (nsucc Nn)     0≥Sn  _    = ⊥-elim (S≤0→⊥ Nn 0≥Sn)
x≥y→y>0→x∸y<x (nsucc {m} Nm) (nsucc {n} Nn) Sm≥Sn Sn>0 =
  lt (succ₁ m ∸ succ₁ n) (succ₁ m)
    ≡⟨ ltLeftCong (S∸S Nm Nn) ⟩
  lt (m ∸ n) (succ₁ m)
     ≡⟨ x∸y<Sx Nm Nn ⟩
  true ∎

------------------------------------------------------------------------------
-- Properties about LT₂

xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (Lexi m n zero zero)
xy<00→⊥ Nm Nn mn<00 = case (λ m<0 → ⊥-elim (x<0→⊥ Nm m<0))
                           (λ m≡0∧n<0 → ⊥-elim (x<0→⊥ Nn (∧-proj₂ m≡0∧n<0)))
                           mn<00

0Sx<00→⊥ : ∀ {m} → ¬ (Lexi zero (succ₁ m) zero zero)
0Sx<00→⊥ 0Sm<00 = case 0<0→⊥
                       (λ 0≡0∧Sm<0 → S<0→⊥ (∧-proj₂ 0≡0∧Sm<0))
                       0Sm<00

Sxy<0y'→⊥ : ∀ {m n n'} → ¬ (Lexi (succ₁ m) n zero n')
Sxy<0y'→⊥ Smn<0n' =
  case S<0→⊥
       (λ Sm≡0∧n<n' → ⊥-elim (0≢S (sym (∧-proj₁ Sm≡0∧n<n'))))
       Smn<0n'

xy<x'0→x<x' : ∀ {m n} → N n → ∀ {m'} → Lexi m n m' zero → m < m'
xy<x'0→x<x' Nn mn<m'0 =
  case (λ m<n → m<n)
       (λ m≡n∧n<0 → ⊥-elim (x<0→⊥ Nn (∧-proj₂ m≡n∧n<0)))
       mn<m'0

xy<0y'→x≡0∧y<y' : ∀ {m} → N m → ∀ {n n'} → Lexi m n zero n' →
                  m ≡ zero ∧ n < n'
xy<0y'→x≡0∧y<y' Nm mn<0n' = case (λ m<0 → ⊥-elim (x<0→⊥ Nm m<0))
                                 (λ m≡0∧n<n' → m≡0∧n<n')
                                 mn<0n'

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     Lexi (succ₁ m ∸ succ₁ n) (succ₁ n) (succ₁ m) (succ₁ n)
[Sx∸Sy,Sy]<[Sx,Sy] Nm Nn = inj₁ (Sx∸Sy<Sx Nm Nn)

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     Lexi (succ₁ m) (succ₁ n ∸ succ₁ m) (succ₁ m) (succ₁ n)
[Sx,Sy∸Sx]<[Sx,Sy] Nm Nn = inj₂ (refl , Sx∸Sy<Sx Nn Nm)


module ShouldBeEmpty where

data Zero : Set where
data One : Set where
  one : One

ok : Zero -> One
ok ()

bad : One -> One
bad ()


module Data.List.Iterable where

open import Data
open import Data.List
import      Data.List.Functions as List
open import Logic.Propositional
open import Logic.Predicate
import      Lvl
open import Relator.Equals
open import Structure.Container.Iterable
open import Type

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}

instance
  List-iterable : Iterable(List(T))
  Iterable.Element (List-iterable {T = T}) = T
  Iterable.isEmpty List-iterable = List.isEmpty
  Iterable.current List-iterable ∅       = <>
  Iterable.current List-iterable (x ⊰ l) = x
  Iterable.indexStep List-iterable ∅       = <>
  Iterable.indexStep List-iterable (_ ⊰ _) = <>
  Iterable.step List-iterable ∅       = <>
  Iterable.step List-iterable (x ⊰ l) = l

instance
  List-finite-iterable : Iterable.Finite(List-iterable{T = T})
  ∃.witness List-finite-iterable = List.foldᵣ
  ∃.proof List-finite-iterable {iter = ∅}     = [≡]-intro
  ∃.proof List-finite-iterable {iter = x ⊰ l} = [≡]-intro

instance
  List-empty : Iterable.EmptyConstruction(List-iterable{T = T})(∅)
  List-empty = <>

instance
  List-prepend : Iterable.PrependConstruction(List-iterable{T = T})(_⊰_)
  ∃.witness List-prepend = [≡]-intro
  ∃.proof   List-prepend = [∧]-intro [≡]-intro [≡]-intro


{-# OPTIONS --cubical --no-positivity-check --no-termination-check --allow-unsolved-metas #-}

open import Prelude
open import Algebra
open import Algebra.Monus
open import Relation.Binary
open import Data.Maybe
open import Data.List using (List; _∷_; []; foldr)

module Control.Monad.HeapT.Sized
  {ℓ}
  (mon : CTMAPOM ℓ)
  (gmon : GradedMonad (CTMAPOM.monoid mon) ℓ ℓ)
  where

open CTMAPOM mon
open GradedMonad gmon

private
  variable
    w i j : 𝑆

infixr 5 _∷_
infixr 6 _⋊_

mutual
  data Root′ (A : Type ℓ) (i : 𝑆) : Type ℓ where
    _⋊_ : ∀ w → (w < i → 𝐹 w (Branch A (i ∸ w))) → Root′ A i

  data Node (A : Type ℓ) (i : 𝑆) : Type ℓ where
    ⌊_⌋ : A → Node A i
    ⌈_⌉ : Root′ A i → Node A i

  data Branch (A : Type ℓ) (i : 𝑆) : Type ℓ where
    []  : Branch A i
    _∷_ : Node A i → 𝐹 ε (Branch A i) → Branch A i

Heap : Type ℓ → Type ℓ
Heap A = ∀ {i} → 𝐹 ε (Branch A i)

infixr 5 _++_
_++_ : 𝐹 w (Branch A i) → 𝐹 ε (Branch A i) → 𝐹 w (Branch A i)
xs ++ ys =
  xs >>=ε λ  {  []       → ys
             ;  (x ∷ xs) → pure (x ∷ xs ++ ys) }

infixr 1 _>>=ᴺ_ _>>=ᴴ_
mutual
  _>>=ᴺ_ : Node A i → (A → Heap B) → 𝐹 ε (Branch B i)
  ⌊ x ⌋  >>=ᴺ f = f x
  ⌈ w ⋊ s ⌉  >>=ᴺ f = pure (⌈ w ⋊ (λ w<i → s w<i >>=ᴴ f) ⌉ ∷ pure [])

  _>>=ᴴ_ : 𝐹 w (Branch A i) → (A → Heap B) → 𝐹 w (Branch B i)
  xs >>=ᴴ f =
    xs >>=ε λ  {  []        → pure []
               ;  (x ∷ xs)  → (x >>=ᴺ f) ++ (xs >>=ᴴ f) }

pureᴴ : A → Heap A
pureᴴ x = pure (⌊ x ⌋ ∷ pure [])

liftᴴ : 𝐹 w A → Heap A
liftᴴ xs = pure (⌈ _ ⋊ const (map (λ x → ⌊ x ⌋ ∷ pure []) xs) ⌉ ∷ pure [])

flatten : 𝐹 w (Branch A i) → 𝐹 w (List A × List (Root′ A i))
flatten xs =
  xs >>=ε λ  {  []            → pure ([] , [])
             ;  (⌊ x ⌋ ∷ xs)  → map (map₁ (x ∷_)) (flatten xs)
             ;  (⌈ x ⌉ ∷ xs)  → map (map₂ (x ∷_)) (flatten xs) }

module PopMin
  (decomp : ∀ {A B w₁ w₂ w₃} → 𝐹 (w₁ ∙ w₂) A → 𝐹 (w₁ ∙ w₃) B → 𝐹 w₁ (𝐹 w₂ A × 𝐹 w₃ B))
  (choice : {w : 𝑆} → {A B : Type ℓ} → (A → 𝐹 w B) → 𝐹 w (A → B))
  where

  _∪_ : Root′ A i → Root′ A i → Root′ A i
  _∪_ {i = i} (wˣ ⋊ xs) (wʸ ⋊ ys) with wˣ ≤|≥ wʸ
  ... | inr (k , wˣ≡wʸ∙k) = {!!}
  ... | inl (k , wʸ≡wˣ∙k) = wˣ ⋊ λ wˣ<i → map (λ { (xs , ys) → ⌈ k ⋊ (λ k<i∸wˣ → subst (𝐹 _ ∘ Branch _) (cong (_ ∸_) wʸ≡wˣ∙k ; sym (∸‿assoc _ wˣ k)) (map (_$ subst (_< i) (sym wʸ≡wˣ∙k) {!!})  ys)) ⌉ ∷ xs }) (decomp (subst (flip 𝐹 _) (sym (∙ε _)) (xs wˣ<i)) (subst (flip 𝐹 _) wʸ≡wˣ∙k (choice ys)))
    where
    lemma : ∀ x y z → x < z → y < z ∸ x → x ∙ y < z
    lemma = {!!}

  -- ⋃⁺ : Root A → List (Root A) → Root A
  -- ⋃⁺ x₁ []             = x₁
  -- ⋃⁺ x₁ (x₂ ∷ [])      = x₁ ∪ x₂
  -- ⋃⁺ x₁ (x₂ ∷ x₃ ∷ xs) = (x₁ ∪ x₂) ∪ ⋃⁺ x₃ xs

  -- ⋃ : List (Root A) → Maybe (Root A)
  -- ⋃ []       = nothing
  -- ⋃ (x ∷ xs) = just (⋃⁺ x xs)

  -- popMin : 𝐹 w (Branch A) → 𝐹 w (List A × Maybe (Root A))
  -- popMin = map (map₂ ⋃) ∘ flatten


module AKS.Primality where

open import AKS.Primality.Base public
open import AKS.Primality.Properties public


open import Relation.Binary using (Rel)
open import Algebra.Bundles using (CommutativeRing)
open import Algebra.Module.Morphism.Structures
open import Algebra.Module.Normed using (NormedModule)

module Algebra.Module.Limit
  {r ℓr} {CR : CommutativeRing r ℓr}
  (open CommutativeRing CR using () renaming (Carrier to X))
  {rel} {_≤_ : Rel X rel}
  {ma ℓma} (MA : NormedModule CR _≤_ ma ℓma)
  {mb ℓmb} (MB : NormedModule CR _≤_ mb ℓmb)
  where

open import Data.Product using (Σ-syntax; ∃-syntax; _×_; proj₁)

open CommutativeRing CR
open import Algebra.Module.Morphism.Module using (⊸-normed)
private
  module MA = NormedModule MA
  module MB = NormedModule MB
  module MA⊸MB = NormedModule (⊸-normed MA MB)

open NormedModule MA using () renaming
  ( Carrierᴹ to Carrierᴬ
  ; _+ᴹ_ to _+ᴬ_
  ; _-ᴹ_ to _-ᴬ_
  ; ∥_∥ to ∥_∥ᴬ
  ; ⟨_,_⟩ to ⟨_,_⟩ᴬ
  )

open NormedModule MB using () renaming
  ( Carrierᴹ to Carrierᴮ
  ; _+ᴹ_ to _+ᴮ_
  ; _-ᴹ_ to _-ᴮ_
  ; ∥_∥ to ∥_∥ᴮ
  ; ⟨_,_⟩ to ⟨_,_⟩ᴮ
  )

open import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ using (_<_)

Limit-syntax : (L : Carrierᴮ) (f : Carrierᴬ → Carrierᴮ) (c : Carrierᴬ) → Set _
Limit-syntax L f c =
  ∀ ε → 0# < ε → ∃[ δ ]
    ∀ x →
      let d = ⟨ c , x ⟩ᴬ
      in (0# < d) × (d < δ) → ⟨ f x , L ⟩ᴮ < ε

syntax Limit-syntax L (λ x → f) c = f ⟶ L As x ⟶ c

Limit-syntax-0 : (L : Carrierᴮ) (f : Carrierᴬ → Carrierᴮ) → Set _
Limit-syntax-0 L f =
  ∀ ε → 0# < ε → ∃[ δ ]
    ∀ x →
      let d = ∥ x ∥ᴬ
      in (0# < d) × (d < δ) → ⟨ f x , L ⟩ᴮ < ε

syntax Limit-syntax-0 L (λ x → f) = f ⟶ L As x ⟶0

Limit-syntax-0-0 : (f : Carrierᴬ → Carrierᴮ) → Set _
Limit-syntax-0-0 f =
  ∀ ε → 0# < ε → ∃[ δ ]
    ∀ x →
      let d = ∥ x ∥ᴬ
      in (0# < d) × (d < δ) → ∥ f x ∥ᴮ < ε

syntax Limit-syntax-0-0 (λ x → f) = f ⟶0 As x ⟶0

_Approximates_At_
  : (δf : MA⊸MB.Carrierᴹ)
  → (f : Carrierᴬ → Carrierᴮ)
  → (x : Carrierᴬ)
  → Set _
δf Approximates f At x = (f (x +ᴬ dx) -ᴮ (f x +ᴮ proj₁ δf dx)) ⟶0 As dx ⟶0

_Differentiates_
  : (δf : Carrierᴬ → MA⊸MB.Carrierᴹ)
  → (f : Carrierᴬ → Carrierᴮ)
  → Set _
δf Differentiates f = ∀ x → (f (x +ᴬ dx) -ᴮ (f x +ᴮ proj₁ (δf x) dx)) ⟶0 As dx ⟶0

D[_,_]_~_ : (f : Carrierᴬ → Carrierᴮ) (df : Carrierᴬ → MA⊸MB.Carrierᴹ) → Set _
D[_,_]_~_ f df = df Differentiates f

_DifferentiableAt_ : (f : Carrierᴬ → Carrierᴮ) (x : Carrierᴬ) → Set _
f DifferentiableAt x = ∃[ δf ] δf Approximates f At x

Differentiable : (f : Carrierᴬ → Carrierᴮ) → Set _
Differentiable f = ∀ x → f DifferentiableAt x

D[_,_][_,_] : (f : Carrierᴬ → Carrierᴮ) (x : Carrierᴬ) → Set _
D[_,_][_,_] f x = f DifferentiableAt x

-- [_,_]~[_~_]_
--   : (δf : Carrierᴬ → Carrierᴮ)
--   → (f : Carrierᴬ → Carrierᴮ)
--   → (x : Carrierᴬ)
--   → Set _
-- [_,_][_~_]_ df f x = {! df Approximates f At x  !}


{-# OPTIONS --universe-polymorphism #-}
module Prelude.Stream where
-- open import Coinduction
  -- Infinite streams.
open import Prelude.IO
open import Prelude.Nat
open import Prelude.Unit

data Level : Set where
  zero : Level
  suc  : (i : Level) → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

infixl 6 _⊔_

_⊔_ : Level → Level → Level
zero  ⊔ j     = j
suc i ⊔ zero  = suc i
suc i ⊔ suc j = suc (i ⊔ j)

{-# BUILTIN LEVELMAX _⊔_ #-}
infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

data Stream (A : Set) : Set where
  _∷_ : (x : A) (xs : ∞ (Stream A)) → Stream A

-- A stream processor SP A B consumes elements of A and produces
-- elements of B. It can only consume a finite number of A’s before
-- producing a B.

data SP (A B : Set) : Set where
  get : (f : A → SP A B) → SP A B
  put : (b : B) (sp : ∞ (SP A B)) → SP A B

-- The function eat is defined by an outer corecursion into Stream B
-- and an inner recursion on SP A B.

eat : ∀ {A B} → SP A B → Stream A → Stream B
eat (get f)    (a ∷ as) = eat (f a) (♭ as)
eat (put b sp) as       = b ∷ ♯ eat (♭ sp) as

-- Composition of stream processors.

_∘_ : ∀ {A B C} → SP B C → SP A B → SP A C
get f₁    ∘ put x sp₂ = f₁ x ∘ ♭ sp₂
put x sp₁ ∘ sp₂       = put x (♯ (♭ sp₁ ∘ sp₂))
sp₁       ∘ get f₂    = get (λ x → sp₁ ∘ f₂ x)

ones : Stream Nat
ones = 1 ∷ (♯ ones)

twos : Stream Nat
twos = 2 ∷ (♯ twos)

printStream : Nat -> Stream Nat -> IO Unit
printStream Z _ = return unit
printStream (S steps) (n ∷ ns) =
    printNat n ,,
    printStream steps (♭ ns)

main : IO Unit
main = printStream 100 twos