------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Theorems of ⊃ connective.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Theorems.Implication ( n : ℕ ) where

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

open import Data.PropFormula.Syntax n
open import Data.PropFormula.Theorems.Classical n

open import Function using ( _$_; _∘_; flip )

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

-- Theorem.
⊃-equiv
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⊃ ψ
  → Γ ⊢ ¬ φ ∨ ψ
⊃-to-¬∨ = ⊃-equiv

-- Proof.
⊃-equiv {φ = φ}{ψ} Γ⊢φ⊃ψ =
  (⊃-elim
    (⊃-intro
      (∨-elim
        (∨-intro₂ (¬ φ)
          (⊃-elim
            (weaken φ Γ⊢φ⊃ψ)
            (assume φ)))
        (∨-intro₁ ψ
          (assume (¬ φ)))))
      PEM)
-------------------------------------------------------------------------- ∎

-- Theorems from the book:
-- van Dalen 4th Edition. Chapter 2. Section 2.4.

-- Theorem.
vanDalen244a
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⊃ (ψ ⊃ φ)

-- Proof.
vanDalen244a {φ = φ}{ψ} =
  (⊃-intro
    (⊃-intro
      (weaken ψ
        (assume φ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
vanDalen244b
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⊃ (¬ φ ⊃ ψ)

-- Proof.
vanDalen244b {Γ}{φ}{ψ} =
  ⊃-intro $
    ⊃-intro $
      ⊥-elim {Γ = (Γ , φ , ¬ φ)} ψ $
        ¬-elim
          (assume  {Γ = Γ , φ} (¬ φ))
          (weaken (¬ φ) (assume φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
vanDalen244c
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ⊃ ψ) ⊃ ((ψ ⊃ γ) ⊃ (φ ⊃ γ))

-- Proof.
vanDalen244c {Γ}{φ}{ψ}{γ} =
  ⊃-intro $
    ⊃-intro $
      ⊃-intro $
        ⊃-elim
          (weaken φ $
            assume {Γ = Γ , φ ⊃ ψ} $ ψ ⊃ γ)
          (⊃-elim
            (weaken φ $
              weaken (ψ ⊃ γ) $
                assume $ φ ⊃ ψ)
            (assume {Γ = Γ , φ ⊃ ψ , ψ ⊃ γ} φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
vanDalen244d
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ ψ ⊃ ¬ φ
  → Γ ⊢ φ ⊃ ψ
¬⊃¬-to-⊃ = vanDalen244d
contraposition₁ = vanDalen244d

-- Proof.
vanDalen244d {Γ}{φ}{ψ} Γ⊢¬ψ⊃¬φ =
  (⊃-elim
    (⊃-intro $
      (⊃-intro $
        RAA $
          ¬-elim
            (⊃-elim
              (weaken (¬ ψ) $
                weaken φ $
                  assume $ ¬ ψ  ⊃ ¬ φ)
              (assume {Γ = Γ , ¬ ψ ⊃ ¬ φ , φ} $ ¬ ψ))
            (weaken (¬ ψ) $
              assume {Γ = Γ , ¬ ψ ⊃ ¬ φ} φ)))
      Γ⊢¬ψ⊃¬φ)
-------------------------------------------------------------------------- ∎

-- Theorem.
contraposition₂
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⊃ ψ
  → Γ ⊢ ¬ ψ ⊃ ¬ φ
⊃-to-¬⊃¬ = contraposition₂

-- Proof.
contraposition₂ {Γ}{φ}{ψ} Γ⊢φ⊃ψ =
  ⊃-intro
    (¬-intro
      (¬-elim
        (weaken φ (assume (¬ ψ)))
        (⊃-elim
          (weaken φ (weaken (¬ ψ) Γ⊢φ⊃ψ))
          (assume {Γ = Γ , ¬ ψ} φ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
vanDalen244e
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ (¬ φ) ⊃ φ

-- Proof.
vanDalen244e {Γ}{φ} =
  ⊃-intro $ RAA
    (¬-elim
      (weaken (¬ φ) $
        assume $ ¬ (¬ φ))
      (assume {Γ = Γ , ¬ (¬ φ)} $ ¬ φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
⊃⊃-to-∧⊃
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ⊃ (ψ ⊃ γ)
  → Γ ⊢ (φ ∧ ψ) ⊃ γ

-- Proof.
⊃⊃-to-∧⊃ {Γ}{φ}{ψ} Γ⊢φ⊃ψ⊃γ =
  ⊃-intro
    (⊃-elim
      (⊃-elim
        (weaken (φ ∧ ψ) Γ⊢φ⊃ψ⊃γ)
        (∧-proj₁ (assume (φ ∧ ψ))))
      (∧-proj₂ (assume (φ ∧ ψ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧⊃-to-⊃⊃
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ∧ ψ) ⊃ γ
  → Γ ⊢ φ ⊃ (ψ ⊃ γ)

-- Proof.
∧⊃-to-⊃⊃ {Γ}{φ}{ψ} Γ⊢φ∧ψ⊃γ =
  ⊃-intro
    (⊃-intro
      (⊃-elim
        (weaken ψ (weaken φ Γ⊢φ∧ψ⊃γ))
        (∧-intro
          (weaken ψ (assume φ))
          (assume {Γ = Γ , φ} ψ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
⊃∧⊃-to-⊃∧
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ⊃ ψ) ∧ (φ ⊃ γ)
  → Γ ⊢ φ ⊃ (ψ ∧ γ)

-- Proof.
⊃∧⊃-to-⊃∧ {φ = φ} Γ⊢⟨φ⊃ψ⟩∧⟨φ⊃γ⟩ =
  ⊃-intro
    (∧-intro
      (⊃-elim (∧-proj₁ (weaken φ Γ⊢⟨φ⊃ψ⟩∧⟨φ⊃γ⟩)) (assume φ))
      (⊃-elim (∧-proj₂ (weaken φ Γ⊢⟨φ⊃ψ⟩∧⟨φ⊃γ⟩)) (assume φ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
subst⊢⊃₁
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ γ ⊃ φ
  → Γ ⊢ φ ⊃ ψ
  → Γ ⊢ γ ⊃ ψ

-- Proof.
subst⊢⊃₁ {γ = γ} Γ⊢ψ⊃γ Γ⊢φ⊃ψ =
  ⊃-intro
    (⊃-elim
      (weaken γ Γ⊢φ⊃ψ)
      (⊃-elim (weaken γ Γ⊢ψ⊃γ) (assume γ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
subst⊢⊃₂
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ ψ ⊃ γ
  → Γ ⊢ φ ⊃ ψ
  → Γ ⊢ φ ⊃ γ

-- Proof.
subst⊢⊃₂ {φ = φ} Γ⊢γ⊃φ Γ⊢φ⊃ψ =
 ⊃-intro
   (⊃-elim
     (weaken φ Γ⊢γ⊃φ)
     (⊃-elim (weaken φ Γ⊢φ⊃ψ) (assume φ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
⊃-trans
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ⊃ ψ
  → Γ ⊢ ψ ⊃ γ
  → Γ ⊢ φ ⊃ γ

-- Proof.
⊃-trans Γ⊢φ⊃ψ Γ⊢ψ⊃γ = subst⊢⊃₂ Γ⊢ψ⊃γ Γ⊢φ⊃ψ
-------------------------------------------------------------------------- ∎


{-A
Polynomials over commutative rings
==================================
-}
{-# OPTIONS --safe #-}

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

module Cubical.Algebra.Polynomials where

open import Cubical.HITs.PropositionalTruncation
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma
open import Cubical.Data.Nat renaming (_+_ to _Nat+_; _·_ to _Nat·_) hiding (·-comm)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty.Base renaming (rec to ⊥rec )
open import Cubical.Data.Bool

open import Cubical.Algebra.Group hiding (Bool)
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

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

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ

module PolyMod (R' : CommRing ℓ) where
  private
    R = fst R'
  open CommRingStr (snd R') public

-------------------------------------------------------------------------------------------
-- First definition of a polynomial.
-- A polynomial a₁ +  a₂x + ... + aⱼxʲ of degree j is represented as a list [a₁, a₂, ...,aⱼ]
-- modulo trailing zeros.
-------------------------------------------------------------------------------------------

  data Poly : Type ℓ where
    []    : Poly
    _∷_  : (a : R) → (p : Poly) → Poly
    drop0 : 0r ∷ [] ≡ []

  infixr 5 _∷_

  module Elim (B      : Poly → Type ℓ')
              ([]*    : B [])
              (cons*  : (r : R) (p : Poly) (b : B p) → B (r ∷ p))
              (drop0* : PathP (λ i → B (drop0 i)) (cons* 0r [] []*) []*) where

   f : (p : Poly) → B p
   f [] = []*
   f (x ∷ p) = cons* x p (f p)
   f (drop0 i) = drop0* i

  -- Given a proposition (as type) ϕ ranging over polynomials, we prove it by:
  -- ElimProp.f ϕ ⌜proof for base case []⌝ ⌜proof for induction case a ∷ p⌝
  --           ⌜proof that ϕ actually is a proposition over the domain of polynomials⌝
  module ElimProp (B : Poly → Type ℓ')
                  ([]* : B [])
                  (cons* : (r : R) (p : Poly) (b : B p) → B (r ∷ p))
                  (BProp : {p : Poly} → isProp (B p)) where
   f : (p : Poly) → B p
   f = Elim.f B []* cons* (toPathP (BProp (transport (λ i → B (drop0 i)) (cons* 0r [] []*)) []*))

  module Rec (B : Type ℓ')
             ([]* : B)
             (cons* : R → B → B)
             (drop0* : cons* 0r []* ≡ []*)
             (Bset : isSet B) where
    f : Poly → B
    f = Elim.f (λ _ → B) []* (λ r p b → cons* r b) drop0*

  module RecPoly ([]* : Poly) (cons* : R → Poly → Poly) (drop0* : cons* 0r []* ≡ []*) where
    f : Poly → Poly
    f [] = []*
    f (a ∷ p) = cons* a (f p)
    f (drop0 i) = drop0* i

--------------------------------------------------------------------------------------------------
-- Second definition of a polynomial. The purpose of this second definition is to
-- facilitate the proof that the first definition is a set. The two definitions are
-- then shown to be equivalent.
-- A polynomial a₀ +  a₁x + ... + aⱼxʲ of degree j is represented as a function f
-- such that for i ∈ ℕ we have  f(i) = aᵢ if i ≤ j, and 0 for i > j
--------------------------------------------------------------------------------------------------

  PolyFun : Type ℓ
  PolyFun = Σ[ p ∈ (ℕ → R) ] (∃[ n ∈ ℕ ] ((m : ℕ) → n ≤ m → p m ≡ 0r))

  isSetPolyFun : isSet PolyFun
  isSetPolyFun = isSetΣSndProp (isSetΠ (λ x → isSetCommRing R')) λ f x y → squash x y

  --construction of the function that represents the polynomial
  Poly→Fun : Poly → (ℕ → R)
  Poly→Fun [] = (λ _ → 0r)
  Poly→Fun (a ∷ p) = (λ n → if isZero n then a else Poly→Fun p (predℕ n))
  Poly→Fun (drop0 i) = lemma i
    where
    lemma : (λ n → if isZero n then 0r else 0r) ≡ (λ _ → 0r)
    lemma i zero = 0r
    lemma i (suc n) = 0r

  Poly→Prf : (p : Poly) → ∃[ n ∈ ℕ ] ((m : ℕ) → n ≤ m → (Poly→Fun p m ≡ 0r))
  Poly→Prf = ElimProp.f (λ p →  ∃[ n ∈ ℕ ] ((m : ℕ) → n ≤ m → (Poly→Fun p m ≡ 0r)))
                        ∣ 0 , (λ m ineq → refl) ∣
                        (λ r p → map ( λ (n , ineq) → (suc n) ,
                                       λ { zero h → ⊥rec (znots (sym (≤0→≡0 h))) ;
                                           (suc m) h → ineq m (pred-≤-pred h)
                                         }
                                     )
                        )
                        squash

  Poly→PolyFun : Poly → PolyFun
  Poly→PolyFun p = (Poly→Fun p) , (Poly→Prf p)

----------------------------------------------------
-- Start of code by Anders Mörtberg and Evan Cavallo

  at0 : (ℕ → R) → R
  at0 f = f 0

  atS : (ℕ → R) → (ℕ → R)
  atS f n = f (suc n)

  polyEq : (p p' : Poly) → Poly→Fun p ≡ Poly→Fun p' → p ≡ p'
  polyEq [] [] _ = refl
  polyEq [] (a ∷ p') α =
    sym drop0 ∙∙ cong₂ _∷_ (cong at0 α) (polyEq [] p' (cong atS α)) ∙∙ refl
  polyEq [] (drop0 j) α k =
    hcomp
      (λ l → λ
        { (j = i1) → drop0 l
        ; (k = i0) → drop0 l
        ; (k = i1) → drop0 (j ∧ l)
        })
      (is-set 0r 0r (cong at0 α) refl j k ∷ [])
  polyEq (a ∷ p) [] α =
    refl ∙∙ cong₂ _∷_ (cong at0 α) (polyEq p [] (cong atS α)) ∙∙ drop0
  polyEq (a ∷ p) (a₁ ∷ p') α =
    cong₂ _∷_ (cong at0 α) (polyEq p p' (cong atS α))
  polyEq (a ∷ p) (drop0 j) α k =
    hcomp -- filler
      (λ l → λ
        { (k = i0) → a ∷ p
        ; (k = i1) → drop0 (j ∧ l)
        ; (j = i0) → at0 (α k) ∷ polyEq p [] (cong atS α) k
        })
      (at0 (α k) ∷ polyEq p [] (cong atS α) k)
  polyEq (drop0 i) [] α k =
    hcomp
      (λ l → λ
        { (i = i1) → drop0 l
        ; (k = i0) → drop0 (i ∧ l)
        ; (k = i1) → drop0 l
        })
      (is-set 0r 0r (cong at0 α) refl i k ∷ [])
  polyEq (drop0 i) (a ∷ p') α k =
    hcomp -- filler
      (λ l → λ
        { (k = i0) → drop0 (i ∧ l)
        ; (k = i1) → a ∷ p'
        ; (i = i0) → at0 (α k) ∷ polyEq [] p' (cong atS α) k
        })
      (at0 (α k) ∷ polyEq [] p' (cong atS α) k)
  polyEq (drop0 i) (drop0 j) α k =
    hcomp
      (λ l → λ
        { (k = i0) → drop0 (i ∧ l)
        ; (k = i1) → drop0 (j ∧ l)
        ; (i = i0) (j = i0) → at0 (α k) ∷ []
        ; (i = i1) (j = i1) → drop0 l
        })
      (is-set 0r 0r (cong at0 α) refl (i ∧ j) k ∷ [])

  PolyFun→Poly+ : (q : PolyFun) → Σ[ p ∈ Poly ] Poly→Fun p ≡ q .fst
  PolyFun→Poly+ (f , pf) = rec lem (λ x → rem1 f (x .fst) (x .snd) ,
                                               funExt (rem2 f (fst x) (snd x))
                                   ) pf
    where
    lem : isProp (Σ[ p ∈ Poly ] Poly→Fun p ≡ f)
    lem (p , α) (p' , α') =
      ΣPathP (polyEq p p' (α ∙ sym α'), isProp→PathP (λ i → (isSetΠ λ _ → is-set) _ _) _ _)

    rem1 : (p : ℕ → R) (n : ℕ) → ((m : ℕ) → n ≤ m → p m ≡ 0r) → Poly
    rem1 p zero h = []
    rem1 p (suc n) h = p 0 ∷ rem1 (λ x → p (suc x)) n (λ m x → h (suc m) (suc-≤-suc x))

    rem2 : (f : ℕ → R) (n : ℕ) → (h : (m : ℕ) → n ≤ m → f m ≡ 0r) (m : ℕ) →
                                                                 Poly→Fun (rem1 f n h) m ≡ f m
    rem2 f zero h m = sym (h m zero-≤)
    rem2 f (suc n) h zero = refl
    rem2 f (suc n) h (suc m) = rem2 (λ x → f (suc x)) n (λ k p → h (suc k) (suc-≤-suc p)) m

  PolyFun→Poly : PolyFun → Poly
  PolyFun→Poly q = PolyFun→Poly+ q .fst

  PolyFun→Poly→PolyFun : (p : Poly) → PolyFun→Poly (Poly→PolyFun p) ≡ p
  PolyFun→Poly→PolyFun p = polyEq _ _ (PolyFun→Poly+ (Poly→PolyFun p) .snd)

--End of code by Mörtberg and Cavallo
-------------------------------------

  isSetPoly : isSet Poly
  isSetPoly = isSetRetract Poly→PolyFun
                           PolyFun→Poly
                           PolyFun→Poly→PolyFun
                           isSetPolyFun

-------------------------------------------------
-- The rest of the file uses the first definition
-------------------------------------------------

  open CommRingTheory R'
  open RingTheory (CommRing→Ring R')
  open GroupTheory (Ring→Group (CommRing→Ring R'))

  pattern [_] x = x ∷ []

---------------------------------------
-- Definition
-- Identity for addition of polynomials
---------------------------------------
  0P : Poly
  0P = []

  --ReplicatePoly(n,p) returns 0 ∷ 0 ∷ ... ∷ [] (n zeros)
  ReplicatePoly0 : (n : ℕ)  → Poly
  ReplicatePoly0 zero  = 0P
  ReplicatePoly0 (suc n) = 0r ∷ ReplicatePoly0 n

  --The empty polynomial has multiple equal representations on the form 0 + 0x + 0 x² + ...
  replicatePoly0Is0P : ∀ (n : ℕ) → ReplicatePoly0 n ≡ 0P
  replicatePoly0Is0P zero = refl
  replicatePoly0Is0P (suc n) = (cong (0r ∷_) (replicatePoly0Is0P n)) ∙ drop0

-----------------------------
-- Definition
-- subtraction of polynomials
-----------------------------
  Poly- : Poly → Poly
  Poly- [] = []
  Poly- (a ∷ p) = (- a) ∷ (Poly- p)
  Poly- (drop0 i) = (cong (_∷ []) (inv1g) ∙ drop0) i

  -- Double negation (of subtraction of polynomials) is the identity mapping
  Poly-Poly- : (p : Poly) → Poly- (Poly- p) ≡ p
  Poly-Poly- = ElimProp.f (λ x → Poly- (Poly- x) ≡ x)
                          refl
                          (λ a p e → cong (_∷ (Poly- (Poly- p)))
                                          (-Idempotent a) ∙ cong (a ∷_ ) (e))
                          (isSetPoly _ _)

---------------------------
-- Definition
-- addition for polynomials
---------------------------
  _Poly+_ : Poly → Poly → Poly
  p Poly+ [] = p
  [] Poly+ (drop0 i) = drop0 i
  [] Poly+ (b ∷ q) = b ∷ q
  (a ∷ p) Poly+ (b ∷ q) = (a + b) ∷ (p Poly+ q)
  (a ∷ p) Poly+ (drop0 i) = +Rid a i ∷ p
  (drop0 i) Poly+ (a ∷ q) = lem q i  where
                                 lem : ∀ q → (0r + a) ∷ ([] Poly+ q) ≡ a ∷ q
                                 lem = ElimProp.f (λ q → (0r + a) ∷ ([] Poly+ q) ≡ a ∷ q)
                                                  (λ i → (+Lid a i ∷ []))
                                                  (λ r p _ → λ i → +Lid a i ∷ r ∷ p )
                                                  (isSetPoly _ _)
  (drop0 i) Poly+ (drop0 j) =  isSet→isSet' isSetPoly  (cong ([_] ) (+Rid 0r)) drop0
                                                       (cong ([_] ) (+Lid 0r)) drop0 i j

  -- [] is the left identity for Poly+
  Poly+Lid : ∀ p → ([] Poly+ p ≡ p)
  Poly+Lid =  ElimProp.f (λ p → ([] Poly+ p ≡ p) )
                         refl
                         (λ r p prf → refl)
                         (λ x y → isSetPoly _ _ x y)

  -- [] is the right identity for Poly+
  Poly+Rid : ∀ p → (p Poly+ [] ≡ p)
  Poly+Rid p = refl

  --Poly+ is Associative
  Poly+Assoc : ∀ p q r → p Poly+ (q Poly+ r) ≡ (p Poly+ q) Poly+ r
  Poly+Assoc =
    ElimProp.f (λ p → (∀ q r → p Poly+ (q Poly+ r) ≡ (p Poly+ q) Poly+ r))
               (λ q r → Poly+Lid (q Poly+ r) ∙ cong (_Poly+ r)  (sym (Poly+Lid q)))
               (λ a p prf → ElimProp.f ((λ q → ∀ r → ((a ∷ p) Poly+ (q Poly+ r)) ≡
                                                   (((a ∷ p) Poly+ q) Poly+ r)))
                                       (λ r → cong ((a ∷ p) Poly+_) (Poly+Lid r))
                                       (λ b q prf2 →
                                       ElimProp.f
                                         (λ r → ((a ∷ p) Poly+ ((b ∷ q) Poly+ r)) ≡
                                                 ((a + b ∷ (p Poly+ q)) Poly+ r))
                                         refl
                                         (λ c r prfp → cong ((a + (b + c))∷_)
                                                            (prf q r) ∙
                                                            (cong (_∷ ((p Poly+ q) Poly+ r))
                                                                  (+Assoc a b c)))
                                         (isSetPoly _ _))
                                       λ x y i r → isSetPoly (x r i0) (y r i1) (x r) (y r) i)
                λ x y i q r  → isSetPoly _ _ (x q r) (y q r) i

  -- for any polynomial, p, the additive inverse is given by Poly- p
  Poly+Inverses : ∀ p → p Poly+ (Poly- p) ≡ []
  Poly+Inverses = ElimProp.f ( λ p → p Poly+ (Poly- p) ≡ [])
                             refl --(Poly+Lid (Poly- []))
                             (λ r p prf → cong (r + - r ∷_) prf ∙
                                          (cong (_∷ [])  (+Rinv r) ∙ drop0))
                             (isSetPoly _ _)

  --Poly+ is commutative
  Poly+Comm : ∀ p q → p Poly+ q ≡ q Poly+ p
  Poly+Comm = ElimProp.f (λ p → (∀ q → p Poly+ q ≡ q Poly+ p))
                         (λ q → Poly+Lid q)
                         (λ a p prf → ElimProp.f (λ q → ((a ∷ p) Poly+ q) ≡ (q Poly+ (a ∷ p)))
                                                 refl
                                                 (λ b q prf2 → cong (_∷ (p Poly+ q)) (+Comm a b) ∙
                                                               cong ((b + a) ∷_) (prf q))
                                                 (isSetPoly _ _)
                         )
                         (λ {p} → isPropΠ (λ q → isSetPoly (p Poly+ q) (q Poly+ p)))

--------------------------------------------------------------
-- Definition
-- multiplication of a polynomial by a (constant) ring element
--------------------------------------------------------------
  _PolyConst*_ : (R) → Poly → Poly
  r PolyConst* [] = []
  r PolyConst* (a ∷ p) = (r · a) ∷ (r PolyConst* p)
  r PolyConst* (drop0 i) = lem r i where
                                 lem : ∀ r → [ r · 0r ] ≡ []
                                 lem =  λ r → [ r · 0r ] ≡⟨ cong (_∷ []) (0RightAnnihilates r) ⟩
                                        [ 0r ] ≡⟨ drop0 ⟩
                                        [] ∎

  -- For any polynomial p we have: 0 _PolyConst*_ p = []
  0rLeftAnnihilatesPoly : ∀ q → 0r PolyConst* q ≡ [ 0r ]
  0rLeftAnnihilatesPoly = ElimProp.f (λ q → 0r PolyConst* q ≡ [ 0r ])
                                         (sym drop0)
                                         (λ r p prf → cong ((0r · r) ∷_) prf ∙
                                                      cong (_∷ [ 0r ]) (0LeftAnnihilates r) ∙
                                                      cong (0r ∷_) drop0 )
                                         λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: 1 _PolyConst*_ p = p
  PolyConst*Lid : ∀ q → 1r PolyConst* q ≡ q
  PolyConst*Lid = ElimProp.f (λ q → 1r PolyConst* q ≡ q ) refl
                             (λ a p prf → cong (_∷ (1r PolyConst* p)) (·Lid a) ∙
                                          cong (a ∷_) (prf) )
                             λ x y → isSetPoly _ _ x y

--------------------------------
-- Definition
-- Multiplication of polynomials
--------------------------------
  _Poly*_ : Poly → Poly → Poly
  [] Poly* q = []
  (a ∷ p) Poly* q = (a PolyConst* q) Poly+ (0r ∷ (p Poly* q))
  (drop0 i) Poly* q = lem q i where
                               lem : ∀ q → (0r PolyConst* q) Poly+ [ 0r ] ≡ []
                               lem = λ q → ((0r PolyConst* q) Poly+ [ 0r ]) ≡⟨ cong ( _Poly+ [ 0r ] ) (0rLeftAnnihilatesPoly q)⟩
                                           ([ 0r ] Poly+ [ 0r ]) ≡⟨ cong (_∷ []) 0Idempotent  ∙ drop0 ⟩
                                           [] ∎

--------------------
--Definition
--Identity for Poly*
--------------------
  1P : Poly
  1P = [ 1r ]

  -- For any polynomial p we have: p Poly* [] = []
  0PRightAnnihilates : ∀ q → 0P Poly* q ≡ 0P
  0PRightAnnihilates = ElimProp.f (λ q → 0P Poly* q ≡ 0P)
                                  refl
                                  (λ r p prf → prf)
                                  λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: [] Poly* p = []
  0PLeftAnnihilates : ∀ p → p Poly* 0P ≡ 0P
  0PLeftAnnihilates = ElimProp.f (λ p → p Poly* 0P ≡ 0P )
                                 refl
                                 (λ r p prf → cong (0r ∷_) prf ∙ drop0)
                                 λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: p Poly* [ 1r ] = p
  Poly*Lid : ∀ q → 1P Poly* q ≡ q
  Poly*Lid =
    ElimProp.f (λ q → 1P Poly* q ≡ q)
               drop0
               (λ r p prf → lemma r p)
               (λ x y → isSetPoly _ _ x y)
                 where
                 lemma : ∀ r p → 1r · r + 0r ∷ (1r PolyConst* p) ≡ r ∷ p
                 lemma =
                   λ r p → 1r · r + 0r ∷ (1r PolyConst* p) ≡⟨ cong (_∷ (1r PolyConst* p) )
                                                                   (+Rid (1r · r)) ⟩
                           1r · r ∷ (1r PolyConst* p) ≡⟨ cong (_∷ 1r PolyConst* p) (·Lid r) ⟩
                           r ∷ (1r PolyConst* p) ≡⟨ cong (r ∷_) (PolyConst*Lid p) ⟩
                           r ∷ p ∎

  -- Distribution of indeterminate: (p + q)x = px + qx
  XLDistrPoly+ : ∀ p q → (0r ∷ (p Poly+ q)) ≡ ((0r ∷ p) Poly+ (0r ∷ q))
  XLDistrPoly+ =
    ElimProp.f (λ p → ∀ q → (0r ∷ (p Poly+ q)) ≡ ((0r ∷ p) Poly+ (0r ∷ q)) )
               (λ q → (cong (0r ∷_) (Poly+Lid q)) ∙
                      cong (0r ∷_) (sym (Poly+Lid q)) ∙
                      sym (cong (_∷ [] Poly+ q) (+Lid 0r)))
               (λ a p prf → ElimProp.f (λ q → 0r ∷ ((a ∷ p) Poly+ q) ≡
                                         ((0r ∷ a ∷ p) Poly+ (0r ∷ q)))
                                       (cong (_∷ a ∷ p ) (sym (+Lid 0r)))
                                       (λ b q prf2 → cong (_∷ a + b ∷ (p Poly+ q)) (sym (+Lid 0r)))
                                       (λ x y i → isSetPoly (x i0) (x i1) x y i))
               (λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- Distribution of a constant ring element over added polynomials p, q: a (p + q) = ap + aq
  PolyConst*LDistrPoly+ : ∀ a p q → a PolyConst* (p Poly+ q) ≡
                                    (a PolyConst* p) Poly+ (a PolyConst* q)
  PolyConst*LDistrPoly+ =
    λ a → ElimProp.f (λ p → ∀ q → a PolyConst* (p Poly+ q) ≡
                                  (a PolyConst* p) Poly+ (a PolyConst* q))
                     (λ q → cong (a PolyConst*_) (Poly+Lid q) ∙
                            (sym (Poly+Lid (a PolyConst* q))))
                     (λ b p prf → ElimProp.f (λ q → (a PolyConst* ((b ∷ p) Poly+ q)) ≡
                                                    (a PolyConst* (b ∷ p)) Poly+ (a PolyConst* q))
                                             refl
                                             (λ c q prf2  → cong (_∷ (a PolyConst* (p Poly+ q)))
                                                                 (·Rdist+ a b c) ∙
                                                            cong (a · b + a · c ∷_) (prf q))
                                             (isSetPoly _ _))
                     (λ x y i q  → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  --Poly* left distributes over Poly+
  Poly*LDistrPoly+ : ∀ p q r → p Poly* (q Poly+ r) ≡ (p Poly* q) Poly+ (p Poly* r)
  Poly*LDistrPoly+ =
    ElimProp.f
      (λ p → ∀ q r → p Poly* (q Poly+ r) ≡ (p Poly* q) Poly+ (p Poly* r))
      (λ _ _ → refl)
      (λ a p prf q r → ((a PolyConst* (q Poly+ r)) Poly+
                        (0r ∷(p Poly*(q Poly+ r)))) ≡⟨
                                                      cong (_Poly+ (0r ∷ (p Poly* (q Poly+ r))))
                                                           (PolyConst*LDistrPoly+ a q r)
                                                     ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ (p Poly* (q Poly+ r)))) ≡⟨
                                        cong (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+_)
                                             (cong (0r ∷_) (prf q r))
                                       ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ ((p Poly* q) Poly+ (p Poly* r)))) ≡⟨
                                                  cong (((a PolyConst* q) Poly+
                                                         (a PolyConst* r)) Poly+_)
                                                  (XLDistrPoly+ (p Poly* q) (p Poly* r))
                                                 ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        ((0r ∷ (p Poly* q)) Poly+ (0r ∷ (p Poly* r)))) ≡⟨
                                                         Poly+Assoc ((a PolyConst* q) Poly+
                                                                      (a PolyConst* r))
                                                                    (0r ∷ (p Poly* q))
                                                                    (0r ∷ (p Poly* r))
                                                        ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ (p Poly* q))) Poly+ (0r ∷ (p Poly* r)) ≡⟨ cong (_Poly+ (0r ∷ (p Poly* r)))
                                                             (sym (Poly+Assoc (a PolyConst* q)
                                                                              (a PolyConst* r)
                                                                              (0r ∷ (p Poly* q))))
                                                    ⟩
      (((a PolyConst* q) Poly+ ((a PolyConst* r) Poly+
        (0r ∷ (p Poly* q)))) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                         cong (_Poly+ (0r ∷ (p Poly* r)))
                                                              (cong ((a PolyConst* q) Poly+_)
                                                                    (Poly+Comm (a PolyConst* r)
                                                                               (0r ∷ (p Poly* q))))
                                                         ⟩
      (((a PolyConst* q) Poly+ ((0r ∷ (p Poly* q)) Poly+
        (a PolyConst* r))) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                       cong (_Poly+ (0r ∷ (p Poly* r)))
                                                            (Poly+Assoc (a PolyConst* q)
                                                                        (0r ∷ (p Poly* q))
                                                                        (a PolyConst* r))
                                                            ⟩
      ((((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) Poly+
        (a PolyConst* r)) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                      sym (Poly+Assoc ((a PolyConst* q) Poly+
                                                                         (0r ∷ (p Poly* q)))
                                                                      ((a PolyConst* r))
                                                                      ((0r ∷ (p Poly* r))))
                                                     ⟩
      ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) Poly+
        ((a PolyConst* r) Poly+ (0r ∷ (p Poly* r))) ∎)
      (λ x y i q r → isSetPoly _ _ (x q r) (y q r) i)

  -- The constant multiplication of a ring element, a, with a polynomial, p, can be
  -- expressed by polynomial multiplication with the singleton polynomial [ a ]
  PolyConst*r=Poly*[r] : ∀ a p → a PolyConst* p ≡ p Poly* [ a ]
  PolyConst*r=Poly*[r] =
    λ a → ElimProp.f (λ p → a PolyConst* p ≡ p Poly* [ a ])
                     refl
                     ( λ r p prf →  a · r ∷ (a PolyConst* p) ≡⟨
                                                              cong (a · r ∷_) prf
                                                             ⟩
                       a · r ∷ (p Poly* [ a ]) ≡⟨
                                                 cong (a · r ∷_)
                                                      (sym (Poly+Lid (p Poly* [ a ])))
                                                ⟩
                       a · r ∷ ([] Poly+ (p Poly* [ a ])) ≡⟨
                                                            cong (_∷ ([] Poly+ (p Poly* [ a ])))
                                                                 (·Comm a r )
                                                           ⟩
                       r · a ∷ ([] Poly+ (p Poly* [ a ])) ≡⟨
                                                            cong (_∷ ([] Poly+ (p Poly* [ a ])))
                                                                 (sym (+Rid (r · a)))
                                                           ⟩
                       r · a + 0r ∷ ([] Poly+ (p Poly* [ a ])) ∎)
                     ( λ x y i → isSetPoly (x i0) (x i1) x y i)

  -- Connection between the constant multiplication and the multiplication in the ring
  PolyConst*Nested· : ∀ a b p → a PolyConst* (b PolyConst* p) ≡ (a · b) PolyConst* p
  PolyConst*Nested· =
    λ a b → ElimProp.f (λ p → a PolyConst* (b PolyConst* p) ≡ (a · b) PolyConst* p)
                       refl
                       (λ c p prf → cong ((a · (b · c)) ∷_) prf ∙
                                    cong (_∷ ((a · b) PolyConst* p)) (·Assoc a b c))
                       (isSetPoly _ _)

  -- We can move the indeterminate from left to outside: px * q = (p * q)x
  0r∷LeftAssoc : ∀ p q → (0r ∷ p) Poly* q ≡ 0r ∷ (p Poly* q)
  0r∷LeftAssoc =
    ElimProp.f (λ p → ∀ q → (0r ∷ p) Poly* q ≡ 0r ∷ (p Poly* q))
               (λ q → cong (_Poly+ [ 0r ])((cong (_Poly+ []) (0rLeftAnnihilatesPoly q))) ∙
                      cong (_∷ []) (+Lid 0r))
               (λ r p b q → cong (_Poly+ (0r ∷ ((r PolyConst* q) Poly+ (0r ∷ (p Poly* q)))))
                                 ((0rLeftAnnihilatesPoly q) ∙ drop0))
               (λ x y i q → isSetPoly _ _ (x q) (y q) i)

  --Associativity of constant multiplication in relation to polynomial multiplication
  PolyConst*AssocPoly* : ∀ a p q → a PolyConst* (p Poly* q) ≡ (a PolyConst* p) Poly* q
  PolyConst*AssocPoly* =
    λ a → ElimProp.f (λ p → ∀ q → a PolyConst* (p Poly* q) ≡ (a PolyConst* p) Poly* q)
                     (λ q → refl)
                     (λ b p prf q → a PolyConst* ((b PolyConst* q) Poly+
                                    (0r ∷ (p Poly* q))) ≡⟨
                                                          PolyConst*LDistrPoly+ a
                                                                                (b PolyConst* q)
                                                                                (0r ∷ (p Poly* q))
                                                         ⟩
                     (a PolyConst* (b PolyConst* q)) Poly+
                      (a PolyConst* (0r ∷ (p Poly* q))) ≡⟨
                                             cong (_Poly+ (a · 0r ∷ (a PolyConst* (p Poly* q))))
                                                  (PolyConst*Nested· a b q)
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (a PolyConst* (0r ∷ (p Poly* q))) ≡⟨
                                                    cong (((a · b) PolyConst* q) Poly+_)
                                                         (cong (a · 0r  ∷_)
                                                               (PolyConst*r=Poly*[r] a
                                                                                (p Poly* q)))
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (a · 0r ∷ ((p Poly* q) Poly* [ a ])) ≡⟨
                                                         cong (((a · b) PolyConst* q) Poly+_)
                                                              (cong (_∷ ((p Poly* q) Poly* [ a ]))
                                                                    (0RightAnnihilates a))  ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ ((p Poly* q) Poly* [ a ])) ≡⟨
                                            cong (((a · b) PolyConst* q) Poly+_)
                                                 (cong (0r ∷_)
                                                       (sym (PolyConst*r=Poly*[r] a (p Poly* q))))
                                                        ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ (a PolyConst* (p Poly* q))) ≡⟨
                                                         cong (((a · b) PolyConst* q) Poly+_)
                                                              (cong (0r ∷_) (prf q))
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ ((a PolyConst* p) Poly* q)) ∎)
                     (λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- We can move the indeterminate from left to outside: p * qx = (p * q)x
  0r∷RightAssoc : ∀ p q → p Poly* (0r ∷  q) ≡ 0r ∷ (p Poly* q)
  0r∷RightAssoc =
    ElimProp.f (λ p → ∀ q → p Poly* (0r ∷  q) ≡ 0r ∷ (p Poly* q))
               (λ q → sym drop0)
               (λ a p prf q → ((a ∷ p) Poly* (0r ∷ q)) ≡⟨
                                                        cong ( a · 0r + 0r ∷_)
                                                             (cong ((a PolyConst* q) Poly+_ )
                                                                   (prf q))
                                                        ⟩
               a · 0r + 0r ∷ ((a PolyConst* q) Poly+
                 (0r ∷ (p Poly* q))) ≡⟨
                                       cong (_∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))))
                                            ((+Rid (a · 0r)))
                                      ⟩
               a · 0r ∷ ((a PolyConst* q) Poly+
                 (0r ∷ (p Poly* q))) ≡⟨
                                      cong (_∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))))
                                           (0RightAnnihilates a) ⟩
               0r ∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) ∎)
               (λ x y i q  → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- We can move the indeterminate around: px * q = p * qx
  0r∷Comm : ∀ p q → (0r ∷ p) Poly* q ≡ p Poly* (0r ∷ q)
  0r∷Comm = ElimProp.f (λ p → ∀ q → (0r ∷ p) Poly* q ≡ p Poly* (0r ∷ q))
                         (λ q → (cong ((0r PolyConst* q) Poly+_) drop0) ∙
                                                0rLeftAnnihilatesPoly q ∙
                                                                 drop0  )
                         (λ a p prf q → ((0r ∷ a ∷ p) Poly* q) ≡⟨ 0r∷LeftAssoc (a ∷ p) q ⟩
                                        0r ∷ ((a ∷ p) Poly* q) ≡⟨ sym (0r∷RightAssoc (a ∷ p) q) ⟩
                                      ((a ∷ p) Poly* (0r ∷ q)) ∎
                       )
                       λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i

  --Poly* is commutative
  Poly*Commutative : ∀ p q → p Poly* q ≡ q Poly* p
  Poly*Commutative =
    ElimProp.f (λ p → ∀ q → p Poly* q ≡ q Poly* p)
               (λ q → sym (0PLeftAnnihilates q))
               (λ a p prf q → (a PolyConst* q) Poly+ (0r ∷ (p Poly* q)) ≡⟨
                                       cong ((a PolyConst* q) Poly+_)
                                            (cong (0r ∷_) (prf q)) ⟩
               ((a PolyConst* q) Poly+ (0r ∷ (q Poly* p))) ≡⟨
                                                            cong ((a PolyConst* q) Poly+_)
                                                            (sym (0r∷LeftAssoc q p))
                                                            ⟩
               ((a PolyConst* q) Poly+ ((0r ∷ q) Poly* p)) ≡⟨
                                      cong (_Poly+ ((0r PolyConst* p) Poly+ (0r ∷ (q Poly* p))))
                                           (PolyConst*r=Poly*[r] a q) ⟩
               ((q Poly* [ a ]) Poly+ ((0r ∷ q) Poly* p)) ≡⟨
                                                           cong ((q Poly* [ a ]) Poly+_)
                                                                (0r∷Comm q p)
                                                           ⟩
               ((q Poly* [ a ]) Poly+ (q Poly* (0r ∷ p))) ≡⟨
                                                           sym (Poly*LDistrPoly+ q [ a ] (0r ∷ p))
                                                           ⟩
               (((q Poly* ([ a ] Poly+ (0r ∷ p))))) ≡⟨
                                                     cong (q Poly*_)
                                                          (Poly+Comm [ a ] (0r ∷ p))
                                                     ⟩
               ((q Poly* ((0r ∷ p) Poly+ [ a ]))) ≡⟨
                                                   refl
                                                   ⟩
               (q Poly* ((0r + a) ∷ p)) ≡⟨ cong (q Poly*_)
                                                (cong (_∷ p) (+Lid a))
                                         ⟩
               (q Poly* (a ∷ p)) ∎)
               (λ x y i q → isSetPoly _ _ (x q ) (y q) i)

  --1P is the right identity of Poly*.
  Poly*Rid : ∀ p → p Poly* 1P ≡ p
  Poly*Rid = λ p → (Poly*Commutative p 1P ∙ Poly*Lid p)

  --Polynomial multiplication right distributes over polynomial addition.
  Poly*RDistrPoly+ : ∀ p q r → (p Poly+ q) Poly* r ≡ (p Poly* r) Poly+ (q Poly* r)
  Poly*RDistrPoly+ = λ p q r → sym (Poly*Commutative r (p Poly+ q)) ∙
                                       Poly*LDistrPoly+ r p q ∙
                                       cong (_Poly+ (r Poly* q)) (Poly*Commutative r p) ∙
                                       cong ((p Poly* r) Poly+_) (Poly*Commutative r q)

  --Polynomial multiplication is associative
  Poly*Associative : ∀ p q r → p Poly* (q Poly* r) ≡  (p Poly* q) Poly* r
  Poly*Associative =
    ElimProp.f (λ p → ∀ q r → p Poly* (q Poly* r) ≡  (p Poly* q) Poly* r )
               (λ _ _ → refl)
               (λ a p prf q r  →
                 ((a ∷ p) Poly* (q Poly* r)) ≡⟨
                                               cong (_Poly+ (0r ∷ (p Poly* (q Poly* r))))
                                                    (PolyConst*AssocPoly* a q r)
                                              ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r ∷ (p Poly* (q Poly* r)))) ≡⟨
                                                 sym (cong (((a PolyConst* q) Poly* r) Poly+_)
                                                           (cong (_∷ (p Poly* (q Poly* r)))
                                                                 (+Lid 0r)))
                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ (p Poly* (q Poly* r)))) ≡⟨
                                                 cong (((a PolyConst* q) Poly* r) Poly+_)
                                                      (cong (0r + 0r ∷_)
                                                            (sym (Poly+Lid (p Poly* (q Poly* r)))))
                                                      ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ ([] Poly+ (p Poly* (q Poly* r))))) ≡⟨
                                                         cong (((a PolyConst* q) Poly* r) Poly+_)
                                                              (cong (0r + 0r ∷_)
                                                                    (cong ([] Poly+_)
                                                                          (prf q r)))
                                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ ([] Poly+ ((p Poly* q) Poly* r)))) ≡⟨
                                                  cong (((a PolyConst* q) Poly* r) Poly+_)
                                                       (cong (_Poly+ (0r ∷ ((p Poly* q) Poly* r)))
                                                             (sym (0rLeftAnnihilatesPoly r)))
                                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  ((0r PolyConst* r) Poly+ (0r ∷ ((p Poly* q) Poly* r)))) ≡⟨
                                                     sym (Poly*RDistrPoly+ (a PolyConst* q)
                                                                           (0r ∷ (p Poly* q)) r)
                                                                           ⟩
                 ((((a ∷ p) Poly* q) Poly* r)) ∎)
               (λ x y i q r  → isSetPoly _ _ (x q r) (y q r) i)

----------------------------------------------------------------------------------------------
-- An instantiation of Polynomials as a commutative ring can be found in CommRing/Instances --
----------------------------------------------------------------------------------------------


open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

module MLib.Matrix.SemiTensor {c ℓ} (struct : Struct bimonoidCode c ℓ) where

open import MLib.Matrix.SemiTensor.Core struct using (_⋉_) public
open import MLib.Matrix.SemiTensor.GeneralizesMul struct public


-- https://www.codewars.com/kata/50654ddff44f800200000004

{-# OPTIONS --safe #-}
module Solution where

open import Data.Nat

multiply : ℕ → ℕ → ℕ
multiply a b = a * b


module Haskell.Prim.Traversable where

open import Haskell.Prim
open import Haskell.Prim.Applicative
open import Haskell.Prim.Functor
open import Haskell.Prim.Foldable
open import Haskell.Prim.Monad
open import Haskell.Prim.List
open import Haskell.Prim.Maybe
open import Haskell.Prim.Either
open import Haskell.Prim.Tuple

--------------------------------------------------
-- Traversable

record Traversable (t : Set → Set) : Set₁ where
  field
    traverse : ⦃ Applicative f ⦄ → (a → f b) → t a → f (t b)
    overlap ⦃ functor ⦄ : Functor t
    overlap ⦃ foldable ⦄ : Foldable t

  sequenceA : ⦃ Applicative f ⦄ → t (f a) → f (t a)
  sequenceA = traverse id

  mapM : ⦃ Monad m ⦄ → (a → m b) → t a → m (t b)
  mapM = traverse

  sequence : ⦃ Monad m ⦄ → t (m a) → m (t a)
  sequence = sequenceA

open Traversable ⦃ ... ⦄ public

instance
  iTraversableList : Traversable List
  iTraversableList .traverse f []       = pure []
  iTraversableList .traverse f (x ∷ xs) = ⦇ f x ∷ traverse f xs ⦈

  iTraversableMaybe : Traversable Maybe
  iTraversableMaybe .traverse f Nothing  = pure Nothing
  iTraversableMaybe .traverse f (Just x) = Just <$> f x

  iTraversableEither : Traversable (Either a)
  iTraversableEither .traverse f (Left  x) = pure (Left x)
  iTraversableEither .traverse f (Right y) = Right <$> f y

  iTraversablePair : Traversable (a ×_)
  iTraversablePair .traverse f (x , y) = (x ,_) <$> f y


module Structure.Setoid.Size.Proofs where

open import Data
open import Data.Proofs
import      Data.Either        as Either
import      Data.Either.Proofs as Either
import      Lvl
open import Functional
open import Function.Proofs
open import Function.Inverseₗ
open import Function.Inverse
open import Function.Iteration
open import Lang.Instance
open import Logic
open import Logic.Classical
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Setoid.Size
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Function
open import Structure.Relator.Equivalence
open import Structure.Relator.Ordering
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type.Properties.Empty
open import Type.Properties.Inhabited
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₗ : Lvl.Level
private variable A B C : Setoid{ℓₑ}{ℓ}
private variable X Y Z : Type{ℓ}

module _ where
  instance
    [≍]-to-[≼] : (_≍_ {ℓₑ₁}{ℓ₁}{ℓₑ₂}{ℓ₂}) ⊆₂ (_≼_)
    _⊆₂_.proof [≍]-to-[≼] ([∃]-intro(f) ⦃ [∧]-intro f-function f-bijective ⦄) =
      ([∃]-intro(f) ⦃ [∧]-intro f-function (bijective-to-injective(f) ⦃ f-bijective ⦄) ⦄)

  instance
    [≍]-to-[≽] : (_≍_ {ℓₑ₁}{ℓ₁}{ℓₑ₂}{ℓ₂}) ⊆₂ (_≽_)
    _⊆₂_.proof [≍]-to-[≽] ([∃]-intro(f) ⦃ [∧]-intro f-function f-bijective ⦄) =
      ([∃]-intro(f) ⦃ [∧]-intro f-function (bijective-to-surjective(f) ⦃ f-bijective ⦄) ⦄)

  [≼]-empty-is-minimal : (([∃]-intro(Empty{ℓ})) ≼ A)
  [≼]-empty-is-minimal = [∃]-intro empty ⦃ [∧]-intro empty-function empty-injective ⦄

  [≽]-empty-is-not-minimal : ¬(∀{A : Setoid{ℓ}} → (A ≽ ([∃]-intro(Empty{ℓ}))))
  [≽]-empty-is-not-minimal proof with () ← [∃]-witness(proof {[∃]-intro Unit}) <>

  [≼]-to-[≽]-not-all : ¬((_≼_ {ℓ}) ⊆₂ swap(_≽_))
  [≼]-to-[≽]-not-all (intro proof) = [≽]-empty-is-not-minimal(proof [≼]-empty-is-minimal)

  [≼]-to-[≽]-for-inhabited : ⦃ _ : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ ⦃ inh-A : (◊([∃]-witness A)) ⦄ → ((A ≼ B) → (B ≽ A))
  [≼]-to-[≽]-for-inhabited {A = [∃]-intro a} {B = [∃]-intro b} ([∃]-intro f ⦃ [∧]-intro f-func f-inj ⦄) = [∃]-intro (invₗ-construction(const [◊]-existence) f) ⦃ [∧]-intro (invₗ-construction-function ⦃ inj = f-inj ⦄) (inverseₗ-surjective ⦃ inverₗ = invₗ-construction-inverseₗ ⦃ inj = f-inj ⦄ ⦄) ⦄

  {- TODO: Maybe this proof could be made to a proof about invertibility instead
  [≼][≍]-almost-antisymmetry : ⦃ _ : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ → (A ≼ B) → (B ≼ A) → (A ≽ B)
  [≼][≍]-almost-antisymmetry {A = A}{B = B} ([∃]-intro f ⦃ [∧]-intro func-f inj-f ⦄) ([∃]-intro g ⦃ [∧]-intro func-g inj-g ⦄) = [∃]-intro h ⦃ [∧]-intro func-h surj-h ⦄ where
    h : [∃]-witness A → [∃]-witness B
    h(a) = Either.map1 [∃]-witness (const(f(a))) (excluded-middle(∃(b ↦ g(b) ≡ a)))

    func-h : Function(h)
    Function.congruence func-h {a₁} {a₂} a₁a₂ with excluded-middle(∃(b ↦ g(b) ≡ a₁)) | excluded-middle(∃(b ↦ g(b) ≡ a₂)) | a₁a₂ -- TODO: Not sure why the last a₁a₂ is neccessary for the result to normalize from the cases, if this is a bug in Agda or if it is intended. An alternative is to just use two-layered Either.map1-values
    ... | [∨]-introₗ ([∃]-intro b₁ ⦃ gba1 ⦄) | [∨]-introₗ ([∃]-intro b₂ ⦃ gba2 ⦄) | _ = injective(g) ⦃ inj-g ⦄ (gba1 🝖 a₁a₂ 🝖 symmetry(_≡_) gba2)
    ... | [∨]-introₗ ([∃]-intro b₁ ⦃ gba1 ⦄) | [∨]-introᵣ ngba2                   | _ = [⊥]-elim(ngba2([∃]-intro b₁ ⦃ gba1 🝖 a₁a₂ ⦄))
    ... | [∨]-introᵣ ngba1                   | [∨]-introₗ ([∃]-intro b₂ ⦃ gba2 ⦄) | _ = [⊥]-elim(ngba1([∃]-intro b₂ ⦃ gba2 🝖 symmetry(_≡_) a₁a₂ ⦄))
    ... | [∨]-introᵣ _                       | [∨]-introᵣ _                       | _ = congruence₁(f) ⦃ func-f ⦄ a₁a₂

      {- TODO: This choice of h probably does not work for proving antisymmetry because nothing states that f and g are inverses, which is neccessary for this kind of proof
      inj-h : Injective(h)
      Injective.proof inj-h {a₁} {a₂} ha₁ha₂ with excluded-middle(∃(b ↦ g(b) ≡ a₁)) | excluded-middle(∃(b ↦ g(b) ≡ a₂)) | ha₁ha₂
      ... | [∨]-introₗ ([∃]-intro b₁ ⦃ gba1 ⦄) | [∨]-introₗ ([∃]-intro b₂ ⦃ gba2 ⦄) | b₁b₂ =
        a₁    🝖-[ gba1 ]-sym
        g(b₁) 🝖-[ congruence₁(g) ⦃ func-g ⦄ b₁b₂ ]
        g(b₂) 🝖-[ gba2 ]
        a₂    🝖-end
      ... | [∨]-introₗ ([∃]-intro b₁ ⦃ gba1 ⦄) | [∨]-introᵣ nega₂                   | b₁fa₂ = [⊥]-elim(nega₂ ([∃]-intro (f(a₂)) ⦃ p ⦄)) where
        p =
          g(f(a₂)) 🝖-[ congruence₁(g) ⦃ func-g ⦄ b₁fa₂ ]-sym
          g(b₁)    🝖-[ gba1 ]
          a₁       🝖-[ {!gba1!} ]
          a₂       🝖-end
        q =
          f(a₁)    🝖-[ congruence₁(f) ⦃ func-f ⦄ gba1 ]-sym
          f(g(b₁)) 🝖-[ {!!} ]
          b₁       🝖-[ b₁fa₂ ]
          f(a₂)    🝖-end
      ... | [∨]-introᵣ nega₁                   | [∨]-introₗ ([∃]-intro b₂ ⦃ gba2 ⦄) | fa₁b₂ = {!!}
      ... | [∨]-introᵣ nega₁                   | [∨]-introᵣ nega₂                   | fa₁fa₂ = injective(f) ⦃ inj-f ⦄ fa₁fa₂
      -}

    -- TODO: Is it possible to use [≼]-to-[≽]-for-inhabited instead or maybe this should be moved out?
    surj-h : Surjective(h)
    Surjective.proof surj-h {b} with Either.map1-values{f = [∃]-witness}{g = const(f(g(b)))}{e = excluded-middle(∃(x ↦ g(x) ≡ g(b)))}
    ... | [∨]-introₗ ([∃]-intro ([∃]-intro b₂ ⦃ gb₂gb ⦄) ⦃ fgbb₂ ⦄) = [∃]-intro (g(b)) ⦃ fgbb₂ 🝖 injective(g) ⦃ inj-g ⦄ gb₂gb ⦄
    ... | [∨]-introᵣ([∃]-intro neggb ⦃ p ⦄) = [⊥]-elim(neggb ([∃]-intro b ⦃ reflexivity(_≡_) ⦄))
  -}

  open import Structure.Operator
  open import Structure.Setoid.Uniqueness
  module _ ⦃ equiv-X : Equiv{ℓₑ₁}(X) ⦄ ⦃ equiv-Y : Equiv{ℓₑ₂}(Y) ⦄ (P : X → Type{ℓₗ}) ⦃ classical-P : Classical(∃ P) ⦄ (c : ¬(∃ P) → Y) (f : X → Y) ⦃ func-f : Function(f) ⦄ where -- TODO: Maybe f should also be able to depend on P, so that (f : (x : X) → P(x) → Y)?
    -- TODO: This is a generalization of both h in [≼][≍]-antisymmetry-raw and invₗ-construction from Function.Inverseₗ
    existence-decider : Y
    existence-decider = Either.map1 (f ∘ [∃]-witness) c (excluded-middle(∃ P))

    existence-decider-satisfaction-value : Unique(P) → ∀{x} → P(x) → (f(x) ≡ existence-decider)
    existence-decider-satisfaction-value unique-P {x} px with Classical.excluded-middle classical-P
    ... | Either.Left  ([∃]-intro y ⦃ py ⦄) = congruence₁(f) (unique-P px py)
    ... | Either.Right nep with () ← nep ([∃]-intro x ⦃ px ⦄)

    existence-decider-unsatisfaction-value : ⦃ Constant(c) ⦄ → (p : ¬(∃ P)) → (c(p) ≡ existence-decider)
    existence-decider-unsatisfaction-value nep with Classical.excluded-middle classical-P
    ... | Either.Left  ep with () ← nep ep
    ... | Either.Right _ = constant(c)

  module _ ⦃ equiv-X : Equiv{ℓₑ₁}(X) ⦄ ⦃ equiv-Y : Equiv{ℓₑ₂}(Y) ⦄ ⦃ equiv-Z : Equiv{ℓₑ₃}(Z) ⦄ (P : X → Y → Type{ℓₗ}) ⦃ classical-P : ∀{x} → Classical(∃(P(x))) ⦄ (c : (x : X) → ¬(∃(P(x))) → Z) (f : X → Y → Z) ⦃ func-f : BinaryOperator(f) ⦄ where
    existence-decider-fn : X → Z
    existence-decider-fn(x) = existence-decider (P(x)) (c(x)) (f(x)) ⦃ BinaryOperator.right func-f ⦄

    open import Structure.Relator
    existence-decider-fn-function : (∀{x} → Unique(P(x))) → (∀{x₁ x₂}{p₁ p₂} → (x₁ ≡ x₂) → (c x₁ p₁ ≡ c x₂ p₂)) → ⦃ ∀{y} → UnaryRelator(swap P y) ⦄ → Function(existence-decider-fn)
    Function.congruence (existence-decider-fn-function unique constant) {x₁} {x₂} x₁x₂ with excluded-middle(∃(P(x₁))) | excluded-middle(∃(P(x₂))) | x₁x₂
    ... | [∨]-introₗ ([∃]-intro y₁ ⦃ p₁ ⦄) | [∨]-introₗ ([∃]-intro y₂ ⦃ p₂ ⦄) | _
      = congruence₂(f) x₁x₂ (unique (substitute₁(swap P y₁) x₁x₂ p₁) p₂)
    ... | [∨]-introₗ ([∃]-intro y₁ ⦃ p₁ ⦄) | [∨]-introᵣ ngba2 | _
      with () ← ngba2 ([∃]-intro y₁ ⦃ substitute₁(swap P y₁) x₁x₂ p₁ ⦄)
    ... | [∨]-introᵣ ngba1 | [∨]-introₗ ([∃]-intro y₂ ⦃ p₂ ⦄) | _
      with () ← ngba1 ([∃]-intro y₂ ⦃ substitute₁(swap P y₂) (symmetry(_≡_) x₁x₂) p₂ ⦄)
    ... | [∨]-introᵣ _ | [∨]-introᵣ _ | _ = constant x₁x₂

    existence-decider-fn-surjective : (∀{x} → Unique(P(x))) → ⦃ ∀{x} → Constant(c(x)) ⦄ → (∀{z} → ∃(x ↦ (∀{y} → P(x)(y) → (f x y ≡ z)) ∧ ((nepx : ¬ ∃(P(x))) → (c x nepx ≡ z)))) → Surjective(existence-decider-fn)
    Surjective.proof (existence-decider-fn-surjective unique-p property) {z} with [∃]-intro x ⦃ px ⦄ ← property{z} with excluded-middle(∃(P(x)))
    ... | [∨]-introₗ ([∃]-intro y ⦃ pxy ⦄)
      = [∃]-intro x ⦃ symmetry(_≡_) (existence-decider-satisfaction-value(P(x)) (c(x)) (f(x)) ⦃ BinaryOperator.right func-f ⦄ unique-p pxy) 🝖 [∧]-elimₗ px pxy ⦄
    ... | [∨]-introᵣ nepx
      = [∃]-intro x ⦃ symmetry(_≡_) (existence-decider-unsatisfaction-value(P(x)) (c(x)) (f(x)) ⦃ BinaryOperator.right func-f ⦄ nepx) 🝖 [∧]-elimᵣ px nepx ⦄

    existence-decider-fn-surjective2 : (∀{x} → Unique(P(x))) → ⦃ ∀{x} → Constant(c(x)) ⦄ → (∃{Obj = Z → X}(x ↦ (∀{z}{y} → P(x(z))(y) → (f (x(z)) y ≡ z)) ∧ (∀{z} → (nepx : ¬ ∃(P(x(z)))) → (c (x(z)) nepx ≡ z)))) → Surjective(existence-decider-fn)
    Surjective.proof (existence-decider-fn-surjective2 unique-p property) {z} with [∃]-intro x ⦃ px ⦄ ← property with excluded-middle(∃(P(x(z))))
    ... | [∨]-introₗ ([∃]-intro y ⦃ pxy ⦄)
      = [∃]-intro (x(z)) ⦃ symmetry(_≡_) (existence-decider-satisfaction-value(P(x(z))) (c(x(z))) (f(x(z))) ⦃ BinaryOperator.right func-f ⦄ unique-p pxy) 🝖 [∧]-elimₗ px pxy ⦄
    ... | [∨]-introᵣ nepx
      = [∃]-intro (x(z)) ⦃ symmetry(_≡_) (existence-decider-unsatisfaction-value(P(x(z))) (c(x(z))) (f(x(z))) ⦃ BinaryOperator.right func-f ⦄ nepx) 🝖 [∧]-elimᵣ px nepx ⦄

    module _
      (inj-f   : ∀{x₁ x₂}{y₁ y₂} → P(x₁)(y₁) → P(x₂)(y₂) → (f x₁ y₁ ≡ f x₂ y₂) → (x₁ ≡ x₂))
      (inj-c   : ∀{x₁ x₂} → (nep₁ : ¬ ∃(P(x₁))) → (nep₂ : ¬ ∃(P(x₂))) → (c x₁ nep₁ ≡ c x₂ nep₂) → (x₁ ≡ x₂))
      (inj-mix : ∀{x₁ x₂}{y₁} → P(x₁)(y₁) → (nep₂ : ¬ ∃(P(x₂))) → (f x₁ y₁ ≡ c x₂ nep₂) → (x₁ ≡ x₂))
      where

      existence-decider-fn-injective : Injective(existence-decider-fn)
      Injective.proof existence-decider-fn-injective {x₁}{x₂} dx₁dx₂ with excluded-middle(∃(P(x₁))) | excluded-middle(∃(P(x₂))) | dx₁dx₂
      ... | Either.Left ([∃]-intro y₁ ⦃ p₁ ⦄) | Either.Left ([∃]-intro y₂ ⦃ p₂ ⦄) | fx₁y₁fx₂y₂ = inj-f p₁ p₂ fx₁y₁fx₂y₂
      ... | Either.Left ([∃]-intro y₁ ⦃ p₁ ⦄) | Either.Right nep₂                 | fxy₁cxp₂   = inj-mix p₁ nep₂ fxy₁cxp₂
      ... | Either.Right nep₁                 | Either.Left ([∃]-intro y₂ ⦃ p₂ ⦄) | cxp₁fxy₂   = symmetry(_≡_) (inj-mix p₂ nep₁ (symmetry(_≡_) cxp₁fxy₂))
      ... | Either.Right nep₁                 | Either.Right nep₂                 | cxp₁cxp₂   = inj-c nep₁ nep₂ cxp₁cxp₂

  -- The property of antisymmetry for injection existence.
  -- Also called: Cantor-Schröder-Bernstein Theorem, Schröder-Bernstein Theorem, Cantor–Bernstein theorem
  -- Source: https://artofproblemsolving.com/wiki/index.php/Schroeder-Bernstein_Theorem
  [≼][≍]-antisymmetry-raw : ⦃ _ : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ → (A ≼ B) → (B ≼ A) → (A ≍ B) -- TODO: Not everything needs to be classical, only forall, exists, and equality
  [≼][≍]-antisymmetry-raw {A = [∃]-intro A}{B = [∃]-intro B} ⦃ classical ⦄ ([∃]-intro f ⦃ [∧]-intro func-f inj-f ⦄) ([∃]-intro g ⦃ [∧]-intro func-g inj-g ⦄) = [∃]-intro h ⦃ [∧]-intro func-h (injective-surjective-to-bijective(h)) ⦄ where
    open import Logic.Predicate.Theorems
    open import Function.Inverseₗ
    open import Numeral.Natural
    open import Structure.Relator

    -- A lone point `b` of `B` is a point not in the image of `f`.
    Lone : B → Stmt
    Lone(b) = ∀{a} → (f(a) ≢ b)

    -- A point `b₁` is a descendent from a point `b₀` in `B` when a number of compositions of `(f ∘ g)` on `b₀` yields `b₁`.
    Desc : B → B → Stmt
    Desc(b₁)(b₀) = ∃(n ↦ (b₁ ≡ ((f ∘ g) ^ n)(b₀)))

    instance
      lone-desc-rel : ∀{y} → UnaryRelator(x ↦ Lone(y) ∧ Desc(f(x)) y)
      UnaryRelator.substitution lone-desc-rel xy = [∧]-map id (ep ↦ [∃]-map-proof-dependent ep (symmetry(_≡_) (congruence₁(f) ⦃ func-f ⦄ xy) 🝖_))

    f⁻¹ : B → A
    f⁻¹ = invₗ-construction g f

    g⁻¹ : A → B
    g⁻¹ = invₗ-construction f g

    instance
      func-f⁻¹ : Function(f⁻¹)
      func-f⁻¹ = invₗ-construction-function ⦃ inj = inj-f ⦄ ⦃ func-g ⦄

    instance
      func-g⁻¹ : Function(g⁻¹)
      func-g⁻¹ = invₗ-construction-function ⦃ inj = inj-g ⦄ ⦃ func-f ⦄

    instance
      inverₗ-f⁻¹ : Inverseₗ(f)(f⁻¹)
      inverₗ-f⁻¹ = invₗ-construction-inverseₗ ⦃ inj = inj-f ⦄ ⦃ func-g ⦄

    instance
      inverₗ-g⁻¹ : Inverseₗ(g)(g⁻¹)
      inverₗ-g⁻¹ = invₗ-construction-inverseₗ ⦃ inj = inj-g ⦄ ⦃ func-f ⦄

    instance
      func-const-invₗ-construction : BinaryOperator(const ∘ g⁻¹)
      func-const-invₗ-construction = functions-to-binaryOperator _ ⦃ r = const-function ⦄

    -- The to-be-proven bijection.
    -- `h` is a mapping such that:
    -- • If `f(a)` is a descendent of a lonely point,     then `h(a) = g⁻¹(a)`.
    -- • If `f(a)` is not a descendent of a lonely point, then `h(a) = f(a)`.
    -- Note: The construction of this function requires excluded middle.
    h : A → B
    h = existence-decider-fn (a ↦ b ↦ Lone(b) ∧ Desc(f(a))(b)) (\a _ → f(a)) (\a _ → g⁻¹(a))

    -- The left inverse of `g` is a right inverse on a point `a` when `f(a)` is a descendent of a lonely point.
    inverᵣ-g⁻¹-specific : ∀{a}{b} → Lone(b) → Desc(f(a))(b) → (g(g⁻¹(a)) ≡ a)
    inverᵣ-g⁻¹-specific        lone-b ([∃]-intro 𝟎      ⦃ desc-b ⦄) with () ← lone-b desc-b
    inverᵣ-g⁻¹-specific {a}{b} lone-b ([∃]-intro (𝐒(n)) ⦃ desc-b ⦄) =
      g(g⁻¹(a))                   🝖[ _≡_ ]-[ congruence₁(g) ⦃ func-g ⦄ (congruence₁(g⁻¹) (injective(f) ⦃ inj-f ⦄ desc-b)) ]
      g(g⁻¹(g(((f ∘ g) ^ n)(b)))) 🝖[ _≡_ ]-[ congruence₁(g) ⦃ func-g ⦄ (inverseₗ(g)(g⁻¹)) ]
      g(((f ∘ g) ^ n)(b))         🝖[ _≡_ ]-[ inverseₗ(f)(f⁻¹) ]-sym
      f⁻¹(f(g(((f ∘ g) ^ n)(b)))) 🝖[ _≡_ ]-[]
      f⁻¹(((f ∘ g) ^ 𝐒(n))(b))    🝖[ _≡_ ]-[ congruence₁(f⁻¹) desc-b ]-sym
      f⁻¹(f(a))                   🝖[ _≡_ ]-[ inverseₗ(f)(f⁻¹) ]
      a                           🝖-end

    inj-different-fgn : ∀{n₁ n₂}{b₁ b₂} → (((f ∘ g) ^ n₁)(b₁) ≡ ((f ∘ g) ^ n₂)(b₂)) → ∃(n ↦ (b₁ ≡ ((f ∘ g) ^ 𝐒(n))(b₂)) ∨ (((f ∘ g) ^ 𝐒(n))(b₁) ≡ b₂) ∨ (b₁ ≡ b₂))
    inj-different-fgn {𝟎}    {𝟎}    p = [∃]-intro 𝟎 ⦃ [∨]-introᵣ p ⦄
    inj-different-fgn {𝟎}    {𝐒 n₂} p = [∃]-intro n₂ ⦃ [∨]-introₗ([∨]-introₗ p) ⦄
    inj-different-fgn {𝐒 n₁} {𝟎}    p = [∃]-intro n₁ ⦃ [∨]-introₗ([∨]-introᵣ p) ⦄
    inj-different-fgn {𝐒 n₁} {𝐒 n₂} p = inj-different-fgn {n₁} {n₂} (Injective.proof inj-g(Injective.proof inj-f p))

    -- The lonely points are unique for all descendents from the image of `f`.
    unique-lone-descendant : ∀{a} → Unique(b ↦ Lone(b) ∧ Desc(f(a))(b))
    unique-lone-descendant {a} {b₁} {b₂} ([∧]-intro lone-b₁ ([∃]-intro n₁ ⦃ desc-b₁ ⦄)) ([∧]-intro lone-b₂ ([∃]-intro n₂ ⦃ desc-b₂ ⦄)) with inj-different-fgn{n₁}{n₂}{b₁}{b₂} (symmetry(_≡_) desc-b₁ 🝖 desc-b₂)
    ... | [∃]-intro n ⦃ Either.Left(Either.Left  p) ⦄ with () ← lone-b₁ (symmetry(_≡_) p)
    ... | [∃]-intro n ⦃ Either.Left(Either.Right p) ⦄ with () ← lone-b₂ p
    ... | [∃]-intro n ⦃ Either.Right b₁b₂ ⦄ = b₁b₂

    instance
      func-h : Function(h)
      func-h = existence-decider-fn-function (a ↦ b ↦ Lone(b) ∧ Desc(f(a))(b)) (\x _ → f(x)) (const ∘ g⁻¹) unique-lone-descendant (congruence₁(f) ⦃ func-f ⦄)

    -- What it means to not have a lonely descendent.
    not-lone-desc : ∀{a} → ¬ ∃(b ↦ Lone(b) ∧ Desc(f(a)) b) → (∀{b} → (∃(x ↦ f(x) ≡ b) ∨ (∀{n} → (f(a) ≢ ((f ∘ g) ^ n)(b)))))
    not-lone-desc {z} = (\nepx {x} → (Either.map ([∃]-map-proof [¬¬]-elim ∘ [¬∀]-to-[∃¬] ⦃ classical ⦄ ⦃ classical ⦄) [¬∃]-to-[∀¬] ∘ [¬]-preserves-[∧][∨]ᵣ) (nepx{x})) ∘ [¬∃]-to-[∀¬]

    instance
      surj-h : Surjective(h)
      Surjective.proof surj-h {z} with excluded-middle(∃(y ↦ Lone(y) ∧ Desc(f(g(z))) y))
      ... | [∨]-introₗ ([∃]-intro y ⦃ pxy ⦄)
        = [∃]-intro (g(z)) ⦃ symmetry(_≡_) (existence-decider-satisfaction-value(y ↦ Lone(y) ∧ Desc(f(g(z))) y) (\_ → f(g(z))) (\_ → g⁻¹(g(z))) unique-lone-descendant pxy) 🝖 inverseₗ(g)(g⁻¹) ⦄
      ... | [∨]-introᵣ nepx
        = [∨]-elim
          (\([∃]-intro x ⦃ p ⦄) → [∃]-intro x ⦃ symmetry(_≡_) (existence-decider-unsatisfaction-value(y ↦ Lone(y) ∧ Desc(f(x)) y) (\_ → f(x)) (\_ → g⁻¹(x)) ⦃ const-function ⦄ ⦃ intro(reflexivity(_≡_)) ⦄ \([∃]-intro xx ⦃ [∧]-intro pp₁ ([∃]-intro n ⦃ pp₂ ⦄) ⦄) → nepx ([∃]-intro xx ⦃ [∧]-intro (\{xxx} ppp → pp₁ ppp) ([∃]-intro (𝐒(n)) ⦃ congruence₁(f) ⦃ func-f ⦄ (congruence₁(g) ⦃ func-g ⦄ (symmetry(_≡_) p 🝖 pp₂)) ⦄) ⦄)) 🝖 p ⦄)
          (\p → [∃]-intro (g(z)) ⦃ symmetry(_≡_) (existence-decider-unsatisfaction-value(y ↦ Lone(y) ∧ Desc(f(g(z))) y) (\_ → f(g(z))) (\_ → g⁻¹(g(z))) ⦃ const-function ⦄ ⦃ intro(reflexivity(_≡_)) ⦄ nepx) 🝖 [⊥]-elim(p{1} (reflexivity(_≡_))) ⦄)
          (not-lone-desc nepx {z})
      {-TODO: How to define surj-h using existence-decider-fn-surjective? Should existence-decider-fn-surjective be more general?
      surj-h = existence-decider-fn-surjective
        (a ↦ b ↦ Lone(b) ∧ Desc(f(a))(b))
        (\x _ → f(x))
        (const ∘ invₗ-construction f g)
        unique-lone-descendant
        ⦃ intro (reflexivity(_≡_)) ⦄
        (\{z} → [∃]-intro (g(z)) ⦃ [∧]-intro
          (\{y} ([∧]-intro lone-y desc-y) → inverseₗ(g)(g⁻¹))
          -- ((\nepx → [⊥]-elim(nepx{z} ([∧]-intro (\{x} fxz → nepx{f(x)} ([∧]-intro (\{x'} p → {!!}) {!!})) ([∃]-intro 1 ⦃ reflexivity(_≡_) ⦄)))) ∘ [¬∃]-to-[∀¬])
          ((\nepx → Either.map1
              ((\([∃]-intro x ⦃ p ⦄) → {!!}) ∘ [∃]-map-proof [¬¬]-elim)
              (\p → [⊥]-elim(p{1} (reflexivity(_≡_))))
              (Either.map ([¬∀]-to-[∃¬] ⦃ classical ⦄ ⦃ classical ⦄) [¬∃]-to-[∀¬] ([¬]-preserves-[∧][∨]ᵣ (nepx{z})))
          ) ∘ [¬∃]-to-[∀¬])
        ⦄)
      -}

    instance
      inj-h : Injective(h)
      inj-h = existence-decider-fn-injective
        (a ↦ b ↦ Lone(b) ∧ Desc(f(a))(b))
        (\x _ → f(x))
        (const ∘ invₗ-construction f g)
        (\{x₁ x₂}{y₁ y₂} ([∧]-intro lone₁ desc₁) ([∧]-intro lone₂ desc₂) g⁻¹x₁g⁻¹x₂ →
          x₁            🝖[ _≡_ ]-[ inverᵣ-g⁻¹-specific lone₁ desc₁ ]-sym
          (g ∘ g⁻¹)(x₁) 🝖[ _≡_ ]-[ congruence₁(g) ⦃ func-g ⦄ g⁻¹x₁g⁻¹x₂ ]
          (g ∘ g⁻¹)(x₂) 🝖[ _≡_ ]-[ inverᵣ-g⁻¹-specific lone₂ desc₂ ]
          x₂            🝖-end
        )
        (\_ _ → Injective.proof inj-f)
        (\{
          {_} {_} {_}  ([∧]-intro lone₁ ([∃]-intro 𝟎       ⦃ desc₁ ⦄)) no g⁻¹x₁fx₂ → [⊥]-elim(lone₁ desc₁) ;
          {x₁}{x₂}{y₁} ([∧]-intro lone₁ ([∃]-intro (𝐒(n₁)) ⦃ desc₁ ⦄)) no g⁻¹x₁fx₂ → [⊥]-elim(no([∃]-intro y₁ ⦃ [∧]-intro lone₁ ([∃]-intro n₁ ⦃
            f(x₂)                      🝖[ _≡_ ]-[ g⁻¹x₁fx₂ ]-sym
            g⁻¹(x₁)                    🝖[ _≡_ ]-[ congruence₁(g⁻¹) (injective(f) ⦃ inj-f ⦄ desc₁) ]
            g⁻¹(g(((f ∘ g) ^ n₁)(y₁))) 🝖[ _≡_ ]-[ inverseₗ(g)(g⁻¹) ]
            ((f ∘ g) ^ n₁)(y₁)         🝖-end
          ⦄) ⦄))
        })

  instance
    [≼][≍]-antisymmetry : ⦃ _ : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ → Antisymmetry(_≼_ {ℓₑ}{ℓ})(_≍_)
    [≼][≍]-antisymmetry = intro [≼][≍]-antisymmetry-raw

  instance
    [≍]-reflexivity : Reflexivity(_≍_ {ℓₑ}{ℓ})
    Reflexivity.proof([≍]-reflexivity) = [∃]-intro(id) ⦃ [∧]-intro id-function id-bijective ⦄

  instance
    [≍]-symmetry : Symmetry(_≍_ {ℓₑ}{ℓ})
    Symmetry.proof [≍]-symmetry ([∃]-intro(f) ⦃ [∧]-intro f-function f-bijective ⦄) = ([∃]-intro(inv f) ⦃ [∧]-intro inv-function (inv-bijective ⦃ func = f-function ⦄) ⦄) where
      instance
        f-invertible : Invertible(f)
        f-invertible = bijective-to-invertible ⦃ bij = f-bijective ⦄

      instance
        invf-invertible : Invertible(inv f)
        ∃.witness invf-invertible = f
        ∃.proof invf-invertible = [∧]-intro f-function (Inverse-symmetry ([∧]-elimᵣ([∃]-proof f-invertible)))

  instance
    [≍]-transitivity : Transitivity(_≍_ {ℓₑ}{ℓ})
    Transitivity.proof([≍]-transitivity) ([∃]-intro(f) ⦃ [∧]-intro f-function f-bijective ⦄) ([∃]-intro(g) ⦃ [∧]-intro g-function g-bijective ⦄)
      = [∃]-intro(g ∘ f) ⦃ [∧]-intro
          ([∘]-function  {f = g}{g = f} ⦃ g-function ⦄ ⦃ f-function ⦄)
          ([∘]-bijective {f = g} ⦃ g-function ⦄ {g = f} ⦃ g-bijective ⦄ ⦃ f-bijective ⦄)
        ⦄

  instance
    [≍]-equivalence : Equivalence(_≍_ {ℓₑ}{ℓ})
    [≍]-equivalence = intro

  instance
    [≼]-reflexivity : Reflexivity(_≼_ {ℓₑ}{ℓ})
    Reflexivity.proof([≼]-reflexivity) = [∃]-intro(id) ⦃ [∧]-intro id-function id-injective ⦄

  instance
    [≼]-transitivity : Transitivity(_≼_ {ℓₑ}{ℓ})
    Transitivity.proof([≼]-transitivity) ([∃]-intro(f) ⦃ [∧]-intro f-function f-injective ⦄) ([∃]-intro(g) ⦃ [∧]-intro g-function g-injective ⦄)
      = [∃]-intro(g ∘ f) ⦃ [∧]-intro
          ([∘]-function  {f = g}{g = f} ⦃ g-function ⦄ ⦃ f-function ⦄)
          ([∘]-injective {f = g}{g = f} ⦃ g-injective ⦄ ⦃ f-injective ⦄)
        ⦄

  instance
    [≽]-reflexivity : Reflexivity(_≽_ {ℓₑ}{ℓ})
    Reflexivity.proof([≽]-reflexivity) = [∃]-intro(id) ⦃ [∧]-intro id-function id-surjective ⦄

  instance
    [≽]-transitivity : Transitivity(_≽_ {ℓₑ}{ℓ})
    Transitivity.proof([≽]-transitivity) ([∃]-intro(f) ⦃ [∧]-intro f-function f-surjective ⦄) ([∃]-intro(g) ⦃ [∧]-intro g-function g-surjective ⦄)
      = [∃]-intro(g ∘ f) ⦃ [∧]-intro
          ([∘]-function  {f = g}{g = f} ⦃ g-function ⦄ ⦃ f-function ⦄)
          ([∘]-surjective {f = g} ⦃ g-function ⦄ {g = f} ⦃ g-surjective ⦄ ⦃ f-surjective ⦄)
        ⦄

  module _  where
    -- This is variant of the "extensional axiom of choice" and is unprovable in Agda, though it is a possible axiom.
    -- A proof of `(A ≽ B)` means that a right inverse exist, but if the surjection is non-injective (it could be in general), then the right inverse is not a function (two equal values in the codomain of the surjection may point to two inequal objects in the domain).
    -- Example:
    --   For X: Set, Y: Set, f: X → Y, a: X, b: X, c₁: Y, c₂: Y
    --   Assume:
    --     X = {a,b}
    --     Y = {c₁,c₂}
    --     a ≢ b
    --     c₁ ≡ c₂
    --     f(a) = c₁
    --     f(b) = c₂
    --   This means that f is surjective (maps to both c₁ and c₂) but not injective ((c₁ ≡ c₂) implies (f(a) ≡ f(b)) implies (a ≡ b) which is false).
    --   Then an inverse f⁻¹ to f can be constructed from the witnesses in surjectivity:
    --     f⁻¹: Y → X
    --     f⁻¹(c₁) = a
    --     f⁻¹(c₂) = b
    --   f⁻¹ is obviously injective, but it is also not a function: ((c₁ ≡ c₂) would imply (a ≡ b) if it were a function, but that is false).
    --   This example shows that not all surjections are injective.
    --   But looking at the example, there are functions that are injective:
    --     g₁: Y → X
    --     g₁(c₁) = a
    --     g₁(c₂) = a
    --
    --     g₂: Y → X
    --     g₂(c₁) = b
    --     g₂(c₂) = b
    --   They are, because: ((a ≡ a) implies (g₁(c₁) ≡ g₁(c₂)) implies (c₁ ≡ c₂) which is true).
    --   and              : ((b ≡ b) implies (g₂(c₁) ≡ g₂(c₂)) implies (c₁ ≡ c₂) which is true).
    --   This is a simplified example for finite sets, and a restriction of this proposition for finite sets is actually provable because it is possible to enumerate all functions up to function extensionality.
    --   The real problem comes when the sets are non-finite because then, there is no general way to enumerate the elements. How would an injection be chosen in this case?
    -- Note that if the surjection is injective, then it is a bijection, and therefore also an injection.
    record SurjectionInjectionChoice (A : Setoid{ℓₑ₁}{ℓ₁}) (B : Setoid{ℓₑ₂}{ℓ₂}) : Stmt{ℓₑ₁ Lvl.⊔ ℓ₁ Lvl.⊔ ℓₑ₂ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : (A ≽ B) → (B ≼ A)
    open SurjectionInjectionChoice ⦃ … ⦄ using () renaming (proof to [≽]-to-[≼]) public

    record SurjectionInvertibleFunctionChoice (A : Setoid{ℓₑ₁}{ℓ₁}) (B : Setoid{ℓₑ₂}{ℓ₂}) : Stmt{ℓₑ₁ Lvl.⊔ ℓ₁ Lvl.⊔ ℓₑ₂ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        invertibleᵣ : ∀{f : ∃.witness A → ∃.witness B} → Surjective(f) → Invertibleᵣ(f)
        function    : ∀{f : ∃.witness A → ∃.witness B}{surj : Surjective(f)} → Function(∃.witness(invertibleᵣ surj))

  module _ ⦃ classical : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ ⦃ surjChoice-ab : SurjectionInjectionChoice A B ⦄ ⦃ surjChoice-ba : SurjectionInjectionChoice B A ⦄ where
    [≽][≍]-antisymmetry-raw : (A ≽ B) → (B ≽ A) → (A ≍ B)
    [≽][≍]-antisymmetry-raw ab ba = [≼][≍]-antisymmetry-raw ([≽]-to-[≼] ba) ([≽]-to-[≼] ab)

  module _ ⦃ classical : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ ⦃ surjChoice-ab : SurjectionInjectionChoice A B ⦄ where
    [≼][≽][≍]-antisymmetry-raw : (A ≼ B) → (A ≽ B) → (A ≍ B)
    [≼][≽][≍]-antisymmetry-raw lesser greater = [≼][≍]-antisymmetry-raw lesser ([≽]-to-[≼] greater)

  module _ ⦃ classical : ∀{ℓ}{P : Stmt{ℓ}} → Classical(P) ⦄ ⦃ surjChoice : ∀{ℓ₁ ℓ₂ ℓₑ₁ ℓₑ₂}{A : Setoid{ℓₑ₁}{ℓ₁}}{B : Setoid{ℓₑ₂}{ℓ₂}} → SurjectionInjectionChoice A B ⦄ where
    instance
      [≽][≍]-antisymmetry : Antisymmetry(_≽_ {ℓₑ}{ℓ})(_≍_)
      [≽][≍]-antisymmetry = intro [≽][≍]-antisymmetry-raw

    -- TODO: Totality of (_≼_).  Is this difficult to prove?
    -- [≼]-total : ((A ≼ B) ∨ (B ≼ A))

  -- TODO: Move
  global-equiv : ∀{ℓ}{T : Type{ℓ}} → Equiv{ℓₑ}(T)
  Equiv._≡_                                   global-equiv  = const(const Unit)
  Equivalence.reflexivity  (Equiv.equivalence global-equiv) = intro <>
  Equivalence.symmetry     (Equiv.equivalence global-equiv) = intro(const <>)
  Equivalence.transitivity (Equiv.equivalence global-equiv) = intro(const(const <>))

  [≼]-to-[≽]-for-inhabited-to-excluded-middle : (∀{ℓ₁ ℓ₂ ℓₑ₁ ℓₑ₂}{A : Setoid{ℓₑ₁}{ℓ₁}}{B : Setoid{ℓₑ₂}{ℓ₂}} → ⦃ ◊([∃]-witness A) ⦄ → (A ≼ B) → (B ≽ A)) → (∀{P : Type{ℓ}} → Classical(P))
  Classical.excluded-middle ([≼]-to-[≽]-for-inhabited-to-excluded-middle p {P = P}) = proof where
    open import Data.Boolean
    open import Data.Option
    open import Data.Option.Setoid
    open import Relator.Equals.Proofs.Equivalence
    f : Option(◊ P) → Bool
    f (Option.Some _) = 𝑇
    f Option.None     = 𝐹

    instance
      equiv-bool : Equiv(Bool)
      equiv-bool = [≡]-equiv

    instance
      equiv-pos-P : Equiv{Lvl.𝟎}(◊ P)
      equiv-pos-P = global-equiv

    func-f : Function(f)
    Function.congruence func-f {None}   {None}   _ = reflexivity(_≡_ ⦃ [≡]-equiv ⦄)
    Function.congruence func-f {Some _} {Some _} _ = reflexivity(_≡_ ⦃ [≡]-equiv ⦄)

    inj-f : Injective(f)
    Injective.proof inj-f {None}   {None}   _ = <>
    Injective.proof inj-f {Some _} {Some _} _ = <>

    surjection : ([∃]-intro Bool ⦃ [≡]-equiv ⦄) ≽ ([∃]-intro (Option(◊ P)))
    surjection = p ⦃ intro ⦃ None ⦄ ⦄ ([∃]-intro f ⦃ [∧]-intro func-f inj-f ⦄)

    g : Bool → Option(◊ P)
    g = [∃]-witness surjection

    g-value-elim : ∀{y} → (g(𝑇) ≡ y) → (g(𝐹) ≡ y) → (∀{b} → (g(b) ≡ y))
    g-value-elim l r {𝑇} = l
    g-value-elim l r {𝐹} = r

    open Equiv(Option-equiv ⦃ equiv-pos-P ⦄) using () renaming (transitivity to Option-trans ; symmetry to Option-sym)
    proof : (P ∨ ¬ P)
    proof with g(𝐹) | g(𝑇) | (\p → Surjective.proof ([∧]-elimᵣ([∃]-proof surjection)) {Some(intro ⦃ p ⦄)}) | g-value-elim{Option.None}
    ... | Some l | Some r | _    | _ = [∨]-introₗ (◊.existence l)
    ... | Some l | None   | _    | _ = [∨]-introₗ (◊.existence l)
    ... | None   | Some r | _    | _ = [∨]-introₗ (◊.existence r)
    ... | None   | None   | surj | tttest = [∨]-introᵣ
      (\p →
        empty(transitivity _ ⦃ Option-trans ⦄ {Some(intro ⦃ p ⦄)}{g([∃]-witness(surj p))}{None} (symmetry _ ⦃ Option-sym ⦄ {g([∃]-witness(surj p))}{Some(intro ⦃ p ⦄)} ([∃]-proof(surj p))) (tttest <> <>))
      )
      {-
        Some(intro ⦃ p ⦄)      🝖[ Equiv._≡_ Option-equiv ]-[ [∃]-proof(surj p) ]-sym
        g([∃]-witness(surj p)) 🝖[ Equiv._≡_ Option-equiv ]-[ tttest <> <> ]
        None                   🝖[ Equiv._≡_ Option-equiv ]-end
      -}

  {-module _ ⦃ surjChoice : ∀{A B : Setoid{ℓ}} → SurjectionInjectionChoice A B ⦄ where
    surjection-injection-choice-to-excluded-middle : ∀{P : Type{ℓ}} → Classical(P)
    Classical.excluded-middle (surjection-injection-choice-to-excluded-middle {P = P}) = {!!}
  -}


postulate
  I : Set
  f : Set → I

mutual

  data P : I → Set where

  Q : I → Set
  Q x = P (f (P x))


open import Coinduction using ( ♭ ; ♯_ )
open import Data.Empty using ( ⊥-elim )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Relation.Binary.PropositionalEquality
  using ( _≡_ ; _≢_ ; refl ; sym ; cong ; cong₂ )
open import Relation.Nullary using ( ¬_ ; Dec ; yes ; no )
open import System.IO.Transducers.Lazy
  using ( _⇒_ ; inp ; out ; done ; _⟫_ ;
     equiv ; assoc ; assoc⁻¹ ; unit₁ ; unit₁⁻¹ ; unit₂ ; unit₂⁻¹ ;
     _[&]_ ; ⟦_⟧ ; _≃_ )
open import System.IO.Transducers.Reflective using ( Reflective )
open import System.IO.Transducers.Strict using ( Strict )
open import System.IO.Transducers.Session
  using ( I ; Σ ; IsΣ ; _∼_ ; ∼-refl ; ∼-trans ; ∼-sym ; _&_ )
  renaming ( unit₁ to ∼-unit₁ ; unit₂ to ∼-unit₂ ; assoc to ∼-assoc )
open import System.IO.Transducers.Trace using ( Trace ; _✓ ; [] ; _∷_ )
open import System.IO.Transducers.Properties.Category
  using ( ⟦done⟧ ; done-semantics ; _⟦⟫⟧_ ; ⟫-semantics ; ⟫-≃-⟦⟫⟧ ; ⟫-resp-≃ ; done-isEquiv ; ⟫-isEquiv ; equiv-is-iso )
open import System.IO.Transducers.Properties.Lemmas
  using ( ≃-refl ; ≃-sym ; ✓-tl ; ✓? ; ⟦⟧-resp-✓ ; ⟦⟧-refl-✓ ; ⟦⟧-resp-[] ;
    IsEquiv ; isEquiv ; ≃-equiv ; I-η)

module System.IO.Transducers.Properties.Monoidal where

open Relation.Binary.PropositionalEquality.≡-Reasoning

infixr 8 _++_ _⟦[&]⟧_

-- Concatenation of traces

_++_ : ∀ {S T} → (Trace S) → (Trace T) → (Trace (S & T))
_++_ {I}     []        bs = bs
_++_ {Σ V F} []        bs = []
_++_ {Σ V F} (a ∷ as)  bs = a ∷ (as ++ bs)
_++_ {I}     (() ∷ as) bs

-- Projection of traces

front : ∀ {S T} → (Trace (S & T)) → (Trace S)
front {I}     as       = []
front {Σ V F} []       = []
front {Σ V F} (a ∷ as) = a ∷ front as

back : ∀ {S T} → (Trace (S & T)) → (Trace T)
back {I}     as       = as
back {Σ V F} []       = []
back {Σ V F} (a ∷ as) = back {♭ F a} as

-- Semantics of tensor

_⟦[&]⟧_ : ∀ {S T U V} →
  (f : Trace S → Trace T) → (g : Trace U → Trace V) →
    (Trace (S & U)) → (Trace (T & V))
_⟦[&]⟧_ {S} f g as = f (front as) ++ g (back {S} as)

[&]-semantics : ∀ {S T U V} (P : S ⇒ T) (Q : U ⇒ V) →
  ⟦ P [&] Q ⟧ ≃ ⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧
[&]-semantics (inp {I} P) (inp Q) [] = refl
[&]-semantics (inp {I} P) (inp Q) (a ∷ as) = [&]-semantics (♭ P a) (inp Q) as
[&]-semantics (inp {I} P) done [] = refl
[&]-semantics (inp {I} P) done (a ∷ as) = [&]-semantics (♭ P a) done as
[&]-semantics (inp {Σ V F} P) Q [] = refl
[&]-semantics (inp {Σ V F} P) Q (a ∷ as) = [&]-semantics (♭ P a) Q as
[&]-semantics (out b P) Q as = cong (_∷_ b) ([&]-semantics P Q as)
[&]-semantics (done {I}) Q as = refl
[&]-semantics (done {Σ V F}) Q [] = refl
[&]-semantics (done {Σ V F}) Q (a ∷ as) = cong (_∷_ a) ([&]-semantics (done {♭ F a}) Q as)
[&]-semantics (inp {I} P) (out c Q) as =
  begin
    c ∷ ⟦ inp P [&] Q ⟧ as
  ≡⟨ cong (_∷_ c) ([&]-semantics (inp P) Q as) ⟩
    c ∷ (⟦ inp P ⟧ ⟦[&]⟧ ⟦ Q ⟧) as
  ≡⟨ cong (_∷_ c) (cong₂ _++_ (I-η (⟦ inp P ⟧ (front as))) refl) ⟩
    c ∷ ⟦ Q ⟧ _
  ≡⟨ cong₂ _++_ (sym (I-η (⟦ inp P ⟧ (front as)))) refl ⟩
    (⟦ inp P ⟧ ⟦[&]⟧ ⟦ out c Q ⟧) as
  ∎

[&]-≃-⟦[&]⟧ : ∀ {S T U V}
  {P : S ⇒ T} {f : Trace S → Trace T} {Q : U ⇒ V} {g : Trace U → Trace V} →
    (⟦ P ⟧ ≃ f) → (⟦ Q ⟧ ≃ g) → (⟦ P [&] Q ⟧ ≃ f ⟦[&]⟧ g)
[&]-≃-⟦[&]⟧ {S} {T} {U} {V} {P} {f} {Q} {g} P≃f Q≃g as =
  begin
    ⟦ P [&] Q ⟧ as
  ≡⟨ [&]-semantics P Q as ⟩
    (⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧) as
  ≡⟨ cong₂ _++_ (P≃f (front as)) (Q≃g (back {S} as)) ⟩
    (f ⟦[&]⟧ g) as
  ∎

-- Semantics of units

⟦unit₁⟧ : ∀ {S} → (Trace (I & S)) → (Trace S)
⟦unit₁⟧ as = as

unit₁-semantics : ∀ {S} → ⟦ unit₁ {S} ⟧ ≃ ⟦unit₁⟧ {S}
unit₁-semantics {I}     as        = refl
unit₁-semantics {Σ V F} []        = refl
unit₁-semantics {Σ V F} (a ∷ as)  = cong (_∷_ a) (unit₁-semantics as)

⟦unit₁⁻¹⟧ : ∀ {S} → (Trace (I & S)) → (Trace S)
⟦unit₁⁻¹⟧ as = as

unit₁⁻¹-semantics : ∀ {S} → ⟦ unit₁⁻¹ {S} ⟧ ≃ ⟦unit₁⁻¹⟧ {S}
unit₁⁻¹-semantics {I}     as        = refl
unit₁⁻¹-semantics {Σ V F} []        = refl
unit₁⁻¹-semantics {Σ V F} (a ∷ as)  = cong (_∷_ a) (unit₁⁻¹-semantics as)

⟦unit₂⟧ : ∀ {S} → (Trace (S & I)) → (Trace S)
⟦unit₂⟧ = front

unit₂-semantics : ∀ {S} → ⟦ unit₂ {S} ⟧ ≃ ⟦unit₂⟧ {S}
unit₂-semantics {I}     []        = refl
unit₂-semantics {Σ V F} []        = refl
unit₂-semantics {Σ V F} (a ∷ as)  = cong (_∷_ a) (unit₂-semantics as)
unit₂-semantics {I}     (() ∷ as)

⟦unit₂⁻¹⟧ : ∀ {S} → (Trace S) → (Trace (S & I))
⟦unit₂⁻¹⟧ as = as ++ []

unit₂⁻¹-semantics : ∀ {S} → ⟦ unit₂⁻¹ {S} ⟧ ≃ ⟦unit₂⁻¹⟧
unit₂⁻¹-semantics {I}     []       = refl
unit₂⁻¹-semantics {Σ W F} []       = refl
unit₂⁻¹-semantics {Σ W F} (a ∷ as) = cong (_∷_ a) (unit₂⁻¹-semantics as)
unit₂⁻¹-semantics {I}     (() ∷ as)

-- Semantics of associativity

⟦assoc⟧ : ∀ {S T U} → (Trace (S & (T & U))) → (Trace ((S & T) & U))
⟦assoc⟧ {S} {T} {U} as =
  (front {S} as ++ front {T} (back {S} as)) ++ back {T} (back {S} as)

assoc-semantics : ∀ {S T U} → ⟦ assoc {S} {T} {U} ⟧ ≃ ⟦assoc⟧ {S} {T} {U}
assoc-semantics {I}     {I}     {I}     []        = refl
assoc-semantics {I}     {I}     {Σ X H} []        = refl
assoc-semantics {I}     {Σ W G}         []        = refl
assoc-semantics {I}     {I}     {Σ X H} (a ∷ as)  = cong (_∷_ a) (assoc-semantics {I} {I} as)
assoc-semantics {I}     {Σ W G}         (a ∷ as)  = cong (_∷_ a) (assoc-semantics {I} {♭ G a} as)
assoc-semantics {Σ V F}                 []        = refl
assoc-semantics {Σ V F}                 (a ∷ as)  = cong (_∷_ a) (assoc-semantics {♭ F a} as)
assoc-semantics {I}     {I}     {I}     (() ∷ as)

⟦assoc⁻¹⟧ : ∀ {S T U} → (Trace ((S & T) & U)) → (Trace (S & (T & U)))
⟦assoc⁻¹⟧ {S} {T} {U} as =
  front {S} (front {S & T} as) ++ back {S} (front {S & T} as) ++ back {S & T} as

assoc⁻¹-semantics : ∀ {S T U} → ⟦ assoc⁻¹ {S} {T} {U} ⟧ ≃ ⟦assoc⁻¹⟧ {S} {T} {U}
assoc⁻¹-semantics {I}     {I}     {I}     []        = refl
assoc⁻¹-semantics {I}     {I}     {Σ X H} []        = refl
assoc⁻¹-semantics {I}     {Σ W G}         []        = refl
assoc⁻¹-semantics {I}     {I}     {Σ X H} (a ∷ as)  = cong (_∷_ a) (assoc⁻¹-semantics {I} {I} as)
assoc⁻¹-semantics {I}     {Σ W G}         (a ∷ as)  = cong (_∷_ a) (assoc⁻¹-semantics {I} {♭ G a} as)
assoc⁻¹-semantics {Σ V F}                 []        = refl
assoc⁻¹-semantics {Σ V F}                 (a ∷ as)  = cong (_∷_ a) (assoc⁻¹-semantics {♭ F a} as)
assoc⁻¹-semantics {I}     {I}     {I}     (() ∷ as)

-- Congruence for concatenation, where the rhs can assume the lhs has terminated

++-cong : ∀ {S T} {as₁ as₂ : Trace S} {bs₁ bs₂ : Trace T} →
  (as₁ ≡ as₂) → (as₁ ✓ → bs₁ ≡ bs₂) → (as₁ ++ bs₁) ≡ (as₂ ++ bs₂)
++-cong {I}     {T} {[]}      refl bs₁≡bs₂ = bs₁≡bs₂ []
++-cong {Σ V F} {T} {[]}      refl bs₁≡bs₂ = refl
++-cong {Σ V F} {T} {a ∷ as}  refl bs₁≡bs₂ = cong (_∷_ a) (++-cong refl (λ ✓as → bs₁≡bs₂ (a ∷ ✓as)))
++-cong {I}     {T} {() ∷ as} refl bs₁≡bs₂

-- Concatenation respects and reflects termination

++-resp-✓ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ✓) → (bs ✓) → (as ++ bs ✓)
++-resp-✓         []         ✓bs = ✓bs
++-resp-✓ {Σ V F} (a ∷ ✓as)  ✓bs = a ∷ ++-resp-✓ ✓as ✓bs
++-resp-✓ {I}     (() ∷ ✓as) ✓bs

++-refl-✓₁ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ++ bs ✓) → (as ✓)
++-refl-✓₁ {I}     {T} {[]}      ✓cs        = []
++-refl-✓₁ {Σ V F} {T} {a ∷ as}  (.a ∷ ✓cs) = a ∷ ++-refl-✓₁ ✓cs
++-refl-✓₁ {I}     {T} {() ∷ as} ✓cs
++-refl-✓₁ {Σ V F} {T} {[]}      ()

++-refl-✓₂ : ∀ {S T} {as : Trace S} {bs : Trace T} → (as ++ bs ✓) → (bs ✓)
++-refl-✓₂ {I}     {T} {[]}      ✓cs        = ✓cs
++-refl-✓₂ {Σ W F} {T} {a ∷ as}  (.a ∷ ✓cs) = ++-refl-✓₂ {♭ F a} {T} {as} ✓cs
++-refl-✓₂ {I}     {T} {() ∷ as} cs
++-refl-✓₂ {Σ V F} {T} {[]}      ()

-- Concatenaton respects emptiness

++-resp-[] : ∀ {S T} {as : Trace S} {bs : Trace T} →
  (as ≡ []) → (bs ≡ []) → (as ++ bs ≡ [])
++-resp-[] {I}     refl refl = refl
++-resp-[] {Σ V F} refl refl = refl

-- Beta and eta equivalence for concatenation.
-- Note that β₂ only holds when as is complete.

++-β₁ : ∀ {S T} (as : Trace S) → (bs : Trace T) → (front (as ++ bs) ≡ as)
++-β₁ {I}     []        bs = refl
++-β₁ {I}     (() ∷ as) bs
++-β₁ {Σ V F} []        bs = refl
++-β₁ {Σ V F} (a ∷ as)  bs = cong (_∷_ a) (++-β₁ as bs)

++-β₂ : ∀ {S T} {as : Trace S} → (as ✓) → (bs : Trace T) → (back {S} (as ++ bs) ≡ bs)
++-β₂ {I}     []        bs = refl
++-β₂ {Σ V F} (a ∷ as)  bs = ++-β₂ as bs
++-β₂ {I}     (() ∷ as) bs

++-η : ∀ {S T} (as : Trace (S & T)) → (front {S} as ++ back {S} as ≡ as)
++-η {I}     []       = refl
++-η {I}     (a ∷ as) = refl
++-η {Σ V F} []       = refl
++-η {Σ V F} (a ∷ as) = cong (_∷_ a) (++-η {♭ F a} as)

-- Beta for concatenation with an incomplete trace

++-β₂-[] : ∀ {S T} {as : Trace S} → (¬ (as ✓)) → (bs : Trace T) → (back {S} (as ++ bs) ≡ [])
++-β₂-[] {I}     {T} {[]}      ¬✓[]   bs = ⊥-elim (¬✓[] [])
++-β₂-[] {Σ V F} {T} {[]}      ¬✓[]   bs = refl
++-β₂-[] {Σ V F} {T} {a ∷ as}  ¬✓a∷as bs = ++-β₂-[] (λ ✓as → ¬✓a∷as (a ∷ ✓as)) bs
++-β₂-[] {I}     {T} {() ∷ as} ¬✓a∷as bs

-- If the front of a trace is incomplete then its back is empty

back≡[] : ∀ {S T as} → (¬ (front {S} {T} as ✓)) → (back {S} {T} as ≡ [])
back≡[] {I}     {T} {as}     ¬✓as₁   = ⊥-elim (¬✓as₁ [])
back≡[] {Σ V F} {T} {[]}     ¬✓as₁   = refl
back≡[] {Σ V F} {T} {a ∷ as} ¬✓a∷as₁ = back≡[] (λ ✓as₁ → ¬✓a∷as₁ (a ∷ ✓as₁))

-- Front respects completion, but only reflects it when T = I.

front-resp-✓ :  ∀ {S T} {as : Trace (S & T)} → (as ✓) → (front {S} as ✓)
front-resp-✓ {I}     ✓as       = []
front-resp-✓ {Σ V F} (a ∷ ✓as) = a ∷ front-resp-✓ ✓as

front-refl-✓ :  ∀ {S} (as : Trace (S & I)) → (front {S} as ✓) → (as ✓)
front-refl-✓ {I}     []        ✓as₁        = []
front-refl-✓ {Σ V F} (a ∷ as)  (.a ∷ ✓as₁) = a ∷ front-refl-✓ as ✓as₁
front-refl-✓ {I}     (() ∷ as) ✓as₁
front-refl-✓ {Σ V F} []        ()

-- Back respects emptiness

back-resp-[] : ∀ {S T as} → (as ≡ []) → (back {S} {T} as ≡ [])
back-resp-[] {I}     refl = refl
back-resp-[] {Σ V F} refl = refl

-- Back reflects completion for non-trivial T

back-refl-✓ :  ∀ {S T} {isΣ : IsΣ T} (as : Trace (S & T)) → (back {S} as ✓) → (as ✓)
back-refl-✓ {I}             as       ✓as₂ = ✓as₂
back-refl-✓ {Σ V F} {Σ W G} (a ∷ as) ✓as₂ = a ∷ back-refl-✓ {♭ F a} as ✓as₂
back-refl-✓ {Σ V F} {I}  {} as       ✓as₂
back-refl-✓ {Σ V F} {Σ W G} []       ()

-- Back respects completion

back-resp-✓ :  ∀ {S} {T} {as : Trace (S & T)} → (as ✓) → (back {S} as ✓)
back-resp-✓ {I}     ✓as       = ✓as
back-resp-✓ {Σ W F} (a ∷ ✓as) = back-resp-✓ {♭ F a} ✓as

-- Tensor plays nicely with concatenation when f reflects completion

⟦[&]⟧-++ : ∀ {S T U V} (f : Trace S → Trace T) (g : Trace U → Trace V) →
  (∀ cs → (f cs ✓) → (cs ✓)) → ∀ as bs →
    (f ⟦[&]⟧ g) (as ++ bs) ≡ (f as ++ g bs)
⟦[&]⟧-++ {S} {T} {U} {V} f g f-refl-✓ as bs =
  begin
    f (front {S} (as ++ bs)) ++ g (back {S} (as ++ bs))
  ≡⟨ cong₂ _++_ (cong f (++-β₁ as bs)) refl ⟩
    f as ++ g (back {S} (as ++ bs))
  ≡⟨ ++-cong refl (λ ✓fas → cong g (++-β₂ (f-refl-✓ as ✓fas) bs)) ⟩
    f as ++ g bs
  ∎

-- Tensor respects ≃

[&]-resp-≃ : ∀ {S T U V} {P₁ P₂ : S ⇒ T} {Q₁ Q₂ : U ⇒ V} →
  (⟦ P₁ ⟧ ≃ ⟦ P₂ ⟧) → (⟦ Q₁ ⟧ ≃ ⟦ Q₂ ⟧) →
    (⟦ P₁ [&] Q₁ ⟧ ≃ ⟦ P₂ [&] Q₂ ⟧)
[&]-resp-≃ {S} {T} {U} {V} {P₁} {P₂} {Q₁} {Q₂} P₁≃P₂ Q₁≃Q₂ as =
  begin
    ⟦ P₁ [&] Q₁ ⟧ as
  ≡⟨ [&]-≃-⟦[&]⟧ P₁≃P₂ Q₁≃Q₂ as ⟩
    (⟦ P₂ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧) as
  ≡⟨ sym ([&]-semantics P₂ Q₂ as) ⟩
    ⟦ P₂ [&] Q₂ ⟧ as
  ∎

-- Tensor respects identity

[&]-resp-done : ∀ S T → ⟦ done {S} [&] done {T} ⟧ ≃ ⟦ done {S & T} ⟧
[&]-resp-done S T as =
  begin
    ⟦ done {S} [&] done {T} ⟧ as
  ≡⟨ [&]-semantics (done {S}) (done {T}) as ⟩
    front {S} as ++ back {S} as
  ≡⟨ ++-η {S} as ⟩
    as
  ∎

-- Tensor respects composition when g₁ reflects completion

⟦[&]⟧-resp-⟦⟫⟧ : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} →
  (f₁ : Trace S₁ → Trace T₁) → (g₁ : Trace T₁ → Trace U₁) →
    (f₂ : Trace S₂ → Trace T₂) → (g₂ : Trace T₂ → Trace U₂) →
      (∀ as → (g₁ as ✓) → (as ✓)) →
        (((f₁ ⟦⟫⟧ g₁) ⟦[&]⟧ (f₂ ⟦⟫⟧ g₂)) ≃ (f₁ ⟦[&]⟧ f₂) ⟦⟫⟧ (g₁ ⟦[&]⟧ g₂))
⟦[&]⟧-resp-⟦⟫⟧ {S₁} f₁ g₁ f₂ g₂ g₁-refl-✓ as =
  sym (⟦[&]⟧-++ g₁ g₂ g₁-refl-✓ (f₁ (front {S₁} as)) (f₂ (back {S₁} as)))

-- Tensor respects composition when f₁ respects completion and f₂ is strict

⟦[&]⟧-resp-⟦⟫⟧' : ∀ {S₁ S₂ T₁ T₂ U₁ U₂} →
  (f₁ : Trace S₁ → Trace T₁) → (g₁ : Trace T₁ → Trace U₁) →
    (f₂ : Trace S₂ → Trace T₂) → (g₂ : Trace T₂ → Trace U₂) →
       (∀ as → as ✓ → f₁ as ✓) → (f₂ [] ≡ []) →
        (((f₁ ⟦⟫⟧ g₁) ⟦[&]⟧ (f₂ ⟦⟫⟧ g₂)) ≃ (f₁ ⟦[&]⟧ f₂) ⟦⟫⟧ (g₁ ⟦[&]⟧ g₂))
⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as with ✓? (f₁ (front as))
⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as | yes ✓bs₁ =
  cong₂ _++_ (cong g₁ (sym (++-β₁ _ _))) (cong g₂ (sym (++-β₂ ✓bs₁ _)))
⟦[&]⟧-resp-⟦⟫⟧' {S₁} {S₂} {T₁} {T₂} f₁ g₁ f₂ g₂ f₁-resp-✓ f₂[]≡[] as | no ¬✓bs₁ =
  begin
    g₁ (f₁ as₁) ++ g₂ (f₂ as₂)
  ≡⟨ cong (_++_  (g₁ (f₁ as₁))) (cong g₂ (cong f₂ (back≡[] ¬✓as₁))) ⟩
    g₁ (f₁ as₁) ++ g₂ (f₂ [])
  ≡⟨ cong (_++_  (g₁ (f₁ as₁))) (cong g₂ f₂[]≡[]) ⟩
    g₁ (f₁ as₁) ++ g₂ []
  ≡⟨ cong₂ _++_ (cong g₁ (sym (++-β₁ _ _))) (cong g₂ (sym (++-β₂-[] ¬✓bs₁ _))) ⟩
    g₁ (front (f₁ as₁ ++ f₂ as₂)) ++ g₂ (back {T₁} (f₁ as₁ ++ f₂ as₂))
  ∎ where
  as₁ = front {S₁} as
  as₂ = back {S₁} as
  ¬✓as₁ : ¬ as₁ ✓
  ¬✓as₁ = λ as₁✓ → ¬✓bs₁ (f₁-resp-✓ as₁ as₁✓)

-- Tensor respects composition when Q₁ is reflective

[&]-resp-⟫ : ∀ {S₁ S₂ T₁ T₂ U₁ U₂}
  (P₁ : S₁ ⇒ T₁) {Q₁ : T₁ ⇒ U₁} (⟳Q₁ : Reflective Q₁)
    (P₂ : S₂ ⇒ T₂) (Q₂ : T₂ ⇒ U₂) →
      ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ ≃ ⟦ (P₁ [&] P₂) ⟫ (Q₁ [&] Q₂) ⟧
[&]-resp-⟫ P₁ {Q₁} ⟳Q₁ P₂ Q₂ as =
  begin
    ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ as
  ≡⟨ [&]-≃-⟦[&]⟧ (⟫-semantics P₁ Q₁) (⟫-semantics P₂ Q₂) as ⟩
    ((⟦ P₁ ⟧ ⟦⟫⟧ ⟦ Q₁ ⟧) ⟦[&]⟧ (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧)) as
  ≡⟨ ⟦[&]⟧-resp-⟦⟫⟧ ⟦ P₁ ⟧ ⟦ Q₁ ⟧ ⟦ P₂ ⟧ ⟦ Q₂ ⟧ (⟦⟧-refl-✓ ⟳Q₁) as ⟩
    ((⟦ P₁ ⟧ ⟦[&]⟧ ⟦ P₂ ⟧) ⟦⟫⟧ (⟦ Q₁ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧)) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-semantics P₁ P₂) ([&]-semantics Q₁ Q₂) as) ⟩
    ⟦ P₁ [&] P₂ ⟫ Q₁ [&] Q₂ ⟧ as
  ∎

-- Tensor respects composition when P₂ is strict

[&]-resp-⟫' : ∀ {S₁ S₂ T₁ T₂ U₁ U₂}
  (P₁ : S₁ ⇒ T₁) (Q₁ : T₁ ⇒ U₁)
    {P₂ : S₂ ⇒ T₂} (#P₂ : Strict P₂) (Q₂ : T₂ ⇒ U₂) →
      ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ ≃ ⟦ (P₁ [&] P₂) ⟫ (Q₁ [&] Q₂) ⟧
[&]-resp-⟫' P₁ Q₁ {P₂} #P₂ Q₂ as =
  begin
    ⟦ (P₁ ⟫ Q₁) [&] (P₂ ⟫ Q₂) ⟧ as
  ≡⟨ [&]-≃-⟦[&]⟧ (⟫-semantics P₁ Q₁) (⟫-semantics P₂ Q₂) as ⟩
    ((⟦ P₁ ⟧ ⟦⟫⟧ ⟦ Q₁ ⟧) ⟦[&]⟧ (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧)) as
  ≡⟨ ⟦[&]⟧-resp-⟦⟫⟧' ⟦ P₁ ⟧ ⟦ Q₁ ⟧ ⟦ P₂ ⟧ ⟦ Q₂ ⟧ (⟦⟧-resp-✓ P₁) (⟦⟧-resp-[] #P₂) as ⟩
    ((⟦ P₁ ⟧ ⟦[&]⟧ ⟦ P₂ ⟧) ⟦⟫⟧ (⟦ Q₁ ⟧ ⟦[&]⟧ ⟦ Q₂ ⟧)) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ ([&]-semantics P₁ P₂) ([&]-semantics Q₁ Q₂) as) ⟩
    ⟦ P₁ [&] P₂ ⟫ Q₁ [&] Q₂ ⟧ as
  ∎

-- Units and associator are equivalences

unit₁-isEquiv : ∀ {S} → IsEquiv (unit₁ {S})
unit₁-isEquiv = isEquiv ∼-unit₁ ≃-refl

unit₂-isEquiv : ∀ {S} → IsEquiv (unit₂ {S})
unit₂-isEquiv {S} = isEquiv (∼-unit₂ {S}) ≃-refl

assoc-isEquiv : ∀ {S T U} → IsEquiv (assoc {S} {T} {U})
assoc-isEquiv {S} {T} = isEquiv (∼-assoc {S} {T}) ≃-refl

unit₁⁻¹-isEquiv : ∀ {S} → IsEquiv (unit₁⁻¹ {S})
unit₁⁻¹-isEquiv = isEquiv (∼-sym ∼-unit₁) ≃-refl

unit₂⁻¹-isEquiv : ∀ {S} → IsEquiv (unit₂⁻¹ {S})
unit₂⁻¹-isEquiv = isEquiv (∼-sym ∼-unit₂) ≃-refl

assoc⁻¹-isEquiv : ∀ {S T U} → IsEquiv (assoc⁻¹ {S} {T} {U})
assoc⁻¹-isEquiv {S} = isEquiv (∼-sym (∼-assoc {S})) ≃-refl

-- Equivalence respects &

&-resp-∼ : ∀ {S T U V} → (S ∼ T) → (U ∼ V) → ((S & U) ∼ (T & V))
&-resp-∼ I       U∼V = U∼V
&-resp-∼ (Σ V F) U∼V = Σ V (♯ λ a → &-resp-∼ (♭ F a) U∼V)

equiv-resp-⟦[&]⟧ : ∀ {S T U V} (S∼T : S ∼ T) (U∼V : U ∼ V) →
  ⟦ equiv S∼T ⟧ ⟦[&]⟧ ⟦ equiv U∼V ⟧ ≃ ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧
equiv-resp-⟦[&]⟧ I       U∼V as       = refl
equiv-resp-⟦[&]⟧ (Σ V F) U∼V []       = refl
equiv-resp-⟦[&]⟧ (Σ V F) U∼V (a ∷ as) = cong (_∷_ a) (equiv-resp-⟦[&]⟧ (♭ F a) U∼V as)

equiv-resp-[&] : ∀ {S T U V} (S∼T : S ∼ T) (U∼V : U ∼ V) →
  ⟦ equiv S∼T [&] equiv U∼V ⟧ ≃ ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧
equiv-resp-[&] S∼T U∼V as =
  begin
    ⟦ equiv S∼T [&] equiv U∼V ⟧ as
  ≡⟨ [&]-semantics (equiv S∼T) (equiv U∼V) as ⟩
    (⟦ equiv S∼T ⟧ ⟦[&]⟧ ⟦ equiv U∼V ⟧) as
  ≡⟨ equiv-resp-⟦[&]⟧ S∼T U∼V as ⟩
    ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ as
  ∎

[&]-isEquiv : ∀ {S T U V} {P : S ⇒ T} {Q : U ⇒ V} →
  (IsEquiv P) → (IsEquiv Q) → (IsEquiv (P [&] Q))
[&]-isEquiv {S} {T} {U} {V} {P} {Q} (isEquiv S∼T P≃S∼T) (isEquiv U∼V Q≃U∼V) =
  isEquiv (&-resp-∼ S∼T U∼V) λ as →
    begin
      ⟦ P [&] Q ⟧ as
    ≡⟨ [&]-resp-≃ P≃S∼T Q≃U∼V as ⟩
      ⟦ equiv S∼T [&] equiv U∼V ⟧ as
    ≡⟨ equiv-resp-[&] S∼T U∼V as ⟩
      ⟦ equiv (&-resp-∼ S∼T U∼V) ⟧ as
    ∎

-- Isomorphisms

unit₁-iso : ∀ {S} → ⟦ unit₁ {S} ⟫ unit₁⁻¹ {S} ⟧ ≃ ⟦ done ⟧
unit₁-iso = equiv-is-iso unit₁-isEquiv unit₁⁻¹-isEquiv

unit₁⁻¹-iso : ∀ {S} → ⟦ unit₁⁻¹ {S} ⟫ unit₁ {S} ⟧ ≃ ⟦ done ⟧
unit₁⁻¹-iso = equiv-is-iso unit₁⁻¹-isEquiv unit₁-isEquiv

unit₂-iso : ∀ {S} → ⟦ unit₂ {S} ⟫ unit₂⁻¹ {S} ⟧ ≃ ⟦ done ⟧
unit₂-iso {S} = equiv-is-iso (unit₂-isEquiv {S}) unit₂⁻¹-isEquiv

unit₂⁻¹-iso : ∀ {S} → ⟦ unit₂⁻¹ {S} ⟫ unit₂ {S} ⟧ ≃ ⟦ done ⟧
unit₂⁻¹-iso {S} = equiv-is-iso unit₂⁻¹-isEquiv (unit₂-isEquiv {S})

assoc-iso : ∀ {S T U} → ⟦ assoc {S} {T} {U} ⟫ assoc⁻¹ {S} {T} {U} ⟧ ≃ ⟦ done ⟧
assoc-iso {S} {T} = equiv-is-iso (assoc-isEquiv {S} {T}) (assoc⁻¹-isEquiv {S} {T})

assoc⁻¹-iso : ∀ {S T U} → ⟦ assoc⁻¹ {S} {T} {U} ⟫ assoc {S} {T} {U} ⟧ ≃ ⟦ done ⟧
assoc⁻¹-iso {S} {T} = equiv-is-iso (assoc⁻¹-isEquiv {S} {T}) (assoc-isEquiv {S} {T})

-- Coherence conditions

assoc-unit : ∀ {S T} →
  ⟦ done {S} [&] unit₁ {T} ⟧ ≃ ⟦ assoc {S} {I} {T} ⟫ unit₂ {S} [&] done {T} ⟧
assoc-unit {S} {T} =
  ≃-equiv ([&]-isEquiv (done-isEquiv {S}) (unit₁-isEquiv {T}))
    (⟫-isEquiv (assoc-isEquiv {S} {I} {T}) ([&]-isEquiv (unit₂-isEquiv {S}) (done-isEquiv {T})))

assoc-assoc : ∀ {S T U V} →
  ⟦ done {S} [&] assoc {T} {U} {V} ⟫
      assoc {S} {T & U} {V} ⟫
        assoc {S} {T} {U} [&] done {V} ⟧ ≃
  ⟦ assoc {S} {T} {U & V} ⟫ assoc {S & T} {U} {V} ⟧
assoc-assoc {S} {T} {U} {V} =
  ≃-equiv
    (⟫-isEquiv ([&]-isEquiv (done-isEquiv {S}) (assoc-isEquiv {T} {U} {V}))
      (⟫-isEquiv (assoc-isEquiv {S} {T & U} {V})
        ([&]-isEquiv (assoc-isEquiv {S} {T} {U}) done-isEquiv)))
    (⟫-isEquiv (assoc-isEquiv {S} {T} {U & V}) (assoc-isEquiv {S & T} {U} {V}))

-- Concatenation plays nicely with associativity

⟦assoc⟧-++ : ∀ {S T U} → (as : Trace S) (bs : Trace T) (cs : Trace U) →
  ⟦assoc⟧ {S} (as ++ (bs ++ cs)) ≡ ((as ++ bs) ++ cs)
⟦assoc⟧-++ {I} {I}     []        bs       cs = refl
⟦assoc⟧-++ {I} {Σ W G} []        []       cs = refl
⟦assoc⟧-++ {I} {Σ W G} []        (b ∷ bs) cs = cong (_∷_ b) (⟦assoc⟧-++ {I} [] bs cs)
⟦assoc⟧-++ {Σ W F}     []        bs       cs = refl
⟦assoc⟧-++ {Σ W F}     (a ∷ as)  bs       cs = cong (_∷_ a) (⟦assoc⟧-++ as bs cs)
⟦assoc⟧-++ {I}         (() ∷ as) bs       cs

⟦assoc⁻¹⟧-++ : ∀ {S T U} → (as : Trace S) (bs : Trace T) (cs : Trace U) →
  ⟦assoc⁻¹⟧ {S} ((as ++ bs) ++ cs) ≡ (as ++ (bs ++ cs))
⟦assoc⁻¹⟧-++ {I} {I}     []        bs       cs = refl
⟦assoc⁻¹⟧-++ {I} {Σ W G} []        []       cs = refl
⟦assoc⁻¹⟧-++ {I} {Σ W G} []        (b ∷ bs) cs = cong (_∷_ b) (⟦assoc⁻¹⟧-++ {I} [] bs cs)
⟦assoc⁻¹⟧-++ {Σ W F}     []        bs       cs = refl
⟦assoc⁻¹⟧-++ {Σ W F}     (a ∷ as)  bs       cs = cong (_∷_ a) (⟦assoc⁻¹⟧-++ as bs cs)
⟦assoc⁻¹⟧-++ {I}         (() ∷ as) bs       cs

-- Front and back play well with associativity

front-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) →
  (front {S} as ≡ front {S} (front {S & T} (⟦assoc⟧ {S} as)))
front-⟦assoc⟧ {I}     as = refl
front-⟦assoc⟧ {Σ V F} []       = refl
front-⟦assoc⟧ {Σ V F} (a ∷ as) = cong (_∷_ a) (front-⟦assoc⟧ as)

mid-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) →
  (front {T} (back {S} as) ≡ back {S} (front {S & T} (⟦assoc⟧ {S} as)))
mid-⟦assoc⟧ {I}     {T}     as       = cong (front {T}) (sym (++-η {T} as))
mid-⟦assoc⟧ {Σ V F} {I}     []       = refl
mid-⟦assoc⟧ {Σ V F} {Σ W G} []       = refl
mid-⟦assoc⟧ {Σ V F}         (a ∷ as) = mid-⟦assoc⟧ {♭ F a} as

back-⟦assoc⟧ : ∀ {S T U} (as : Trace (S & (T & U))) →
  (back {T} (back {S} as) ≡ back {S & T} (⟦assoc⟧ {S} as))
back-⟦assoc⟧ {I}     {T}     as       = cong (back {T}) (sym (++-η {T} as))
back-⟦assoc⟧ {Σ V F} {I}     []       = refl
back-⟦assoc⟧ {Σ V F} {Σ W G} []       = refl
back-⟦assoc⟧ {Σ V F}         (a ∷ as) = back-⟦assoc⟧ {♭ F a} as

-- Units are natural

⟦unit₁⟧-natural : ∀ {S T} (f : Trace S → Trace T) →
  (⟦done⟧ {I} ⟦[&]⟧ f) ⟦⟫⟧ ⟦unit₁⟧ ≃ ⟦unit₁⟧ ⟦⟫⟧ f
⟦unit₁⟧-natural f []       = refl
⟦unit₁⟧-natural f (a ∷ as) = refl

unit₁-natural : ∀ {S T} (P : S ⇒ T) →
  ⟦ done {I} [&] P ⟫ unit₁ ⟧ ≃ ⟦ unit₁ ⟫ P ⟧
unit₁-natural P as =
  begin
    ⟦ done {I} [&] P ⟫ unit₁ ⟧ as
  ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-semantics (done {I}) P) unit₁-semantics as ⟩
    (⟦done⟧ {I} ⟦[&]⟧ ⟦ P ⟧ ⟦⟫⟧ ⟦unit₁⟧) as
  ≡⟨ ⟦unit₁⟧-natural ⟦ P ⟧ as ⟩
     (⟦unit₁⟧ ⟦⟫⟧ ⟦ P ⟧) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ unit₁-semantics ≃-refl as) ⟩
    ⟦ unit₁ ⟫ P ⟧ as
  ∎

⟦unit₂⟧-natural : ∀ {S T} (f : Trace S → Trace T) →
  (f ⟦[&]⟧ ⟦done⟧ {I}) ⟦⟫⟧ ⟦unit₂⟧ ≃ ⟦unit₂⟧ ⟦⟫⟧ f
⟦unit₂⟧-natural {S} {T} f as =
  ++-β₁ (f (front {S} as)) (back {S} as)

unit₂-natural : ∀ {S T} (P : S ⇒ T) →
  ⟦ P [&] done {I} ⟫ unit₂ ⟧ ≃ ⟦ unit₂ ⟫ P ⟧
unit₂-natural {S} {T} P as =
  begin
    ⟦ P [&] done {I} ⟫ unit₂ ⟧ as
  ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-semantics P (done {I})) (unit₂-semantics {T}) as ⟩
    (⟦ P ⟧ ⟦[&]⟧ ⟦done⟧ {I} ⟦⟫⟧ ⟦unit₂⟧) as
  ≡⟨ ⟦unit₂⟧-natural ⟦ P ⟧ as ⟩
     (⟦unit₂⟧ ⟦⟫⟧ ⟦ P ⟧) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ (unit₂-semantics {S}) ≃-refl as) ⟩
    ⟦ unit₂ ⟫ P ⟧ as
  ∎

-- Associativity is natural

⟦assoc⟧-natural : ∀ {S S' T T' U U'}
  (f : Trace S → Trace S') (g : Trace T → Trace T') (h : Trace U → Trace U') →
    ((f ⟦[&]⟧ (g ⟦[&]⟧ h)) ⟦⟫⟧ ⟦assoc⟧ {S'} {T'} {U'}) ≃
      (⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ((f ⟦[&]⟧ g) ⟦[&]⟧ h))
⟦assoc⟧-natural {S} {S'} {T} {T'} {U} {U'} f g h as =
  begin
    ⟦assoc⟧ {S'} (f as₁ ++ g as₂ ++ h as₃)
  ≡⟨ ⟦assoc⟧-++ (f as₁) (g as₂) (h as₃) ⟩
    (f as₁ ++ g as₂) ++ h as₃
  ≡⟨ cong₂ _++_ (cong₂ _++_ (cong f (front-⟦assoc⟧ as))
       (cong g (mid-⟦assoc⟧ {S} as))) (cong h (back-⟦assoc⟧ {S} as)) ⟩
    ((f ⟦[&]⟧ g) ⟦[&]⟧ h) ((as₁ ++ as₂) ++ as₃)
  ∎ where
  as₁ = front {S} as
  as₂ = front {T} (back {S} as)
  as₃ = back {T} (back {S} as)

assoc-natural : ∀ {S S' T T' U U'} (P : S ⇒ S') (Q : T ⇒ T') (R : U ⇒ U') →
  ⟦ P [&] (Q [&] R) ⟫ assoc {S'} {T'} {U'} ⟧ ≃
    ⟦ assoc {S} {T} {U} ⟫ (P [&] Q) [&] R ⟧
assoc-natural {S} {S'} {T} {T'} {U} {U'} P Q R as =
  begin
    ⟦ P [&] (Q [&] R) ⟫ assoc {S'} {T'} {U'} ⟧ as
  ≡⟨ ⟫-≃-⟦⟫⟧ ([&]-≃-⟦[&]⟧ {P = P} ≃-refl ([&]-semantics Q R)) (assoc-semantics {S'} {T'} {U'}) as ⟩
    ((⟦ P ⟧ ⟦[&]⟧ (⟦ Q ⟧ ⟦[&]⟧ ⟦ R ⟧)) ⟦⟫⟧ ⟦assoc⟧ {S'} {T'} {U'}) as
  ≡⟨ ⟦assoc⟧-natural ⟦ P ⟧ ⟦ Q ⟧ ⟦ R ⟧ as ⟩
    (⟦assoc⟧ {S} {T} {U} ⟦⟫⟧ ((⟦ P ⟧ ⟦[&]⟧ ⟦ Q ⟧) ⟦[&]⟧ ⟦ R ⟧)) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ (assoc-semantics {S} {T} {U}) ([&]-≃-⟦[&]⟧ ([&]-semantics P Q) ≃-refl) as) ⟩
    ⟦ assoc {S} {T} {U} ⟫ (P [&] Q) [&] R ⟧ as
  ∎