{-# OPTIONS --safe --warning=error --without-K --guardedness #-}

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Setoids.Setoids
open import Rings.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Fields.Fields
open import Sets.EquivalenceRelations
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Semirings.Definition

module Fields.CauchyCompletion.Comparison {m n o : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {m} {o} A} {pOrder : SetoidPartialOrder S _<_} {R : Ring S _+_ _*_} {pRing : PartiallyOrderedRing R pOrder} (order : TotallyOrderedRing pRing) (F : Field R) where

open Setoid S
open SetoidTotalOrder (TotallyOrderedRing.total order)
open SetoidPartialOrder pOrder
open Equivalence eq
open PartiallyOrderedRing pRing
open Ring R
open Group additiveGroup
open Field F
open import Fields.Orders.Lemmas {F = F} {pRing} (record { oRing = order })

open import Rings.Orders.Partial.Lemmas pRing
open import Rings.Orders.Total.Lemmas order
open import Rings.Orders.Total.AbsoluteValue order
open import Fields.Lemmas F
open import Fields.CauchyCompletion.Definition order F
open import Fields.CauchyCompletion.Setoid order F
open import Fields.CauchyCompletion.Group order F
open import Fields.Orders.Total.Lemmas {F = F} (record { oRing = order })

-- "<C rational", where the r indicates where the rational number goes
record _<Cr_ (a : CauchyCompletion) (b : A) : Set (m ⊔ o) where
  field
    e : A
    0<e : 0G < e
    N : ℕ
    property : ((m : ℕ) → (N<m : N <N m) → (e + index (CauchyCompletion.elts a) m) < b)

<CrWellDefinedRight : (a : CauchyCompletion) (b c : A) → b ∼ c → a <Cr b → a <Cr c
<CrWellDefinedRight a b c b=c record { e = ε ; 0<e = 0<e ; N = N ; property = pr } = record { e = ε ; 0<e = 0<e ; N = N ; property = λ m N<m → <WellDefined (Equivalence.reflexive eq) b=c (pr m N<m) }

private
  <CrWellDefinedLemma : (a b e/2 e : A) (0<e : 0G < e) (pr : e/2 + e/2 ∼ e) → abs (a + inverse b) < e/2 → (e/2 + b) < (e + a)
  <CrWellDefinedLemma a b e/2 e 0<e pr a-b<e with totality 0G (a + inverse b)
  <CrWellDefinedLemma a b e/2 e 0<e pr a-b<e | inl (inl 0<a-b) = ringAddInequalities (halfLess e/2 e 0<e pr) (<WellDefined identLeft (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) invLeft) identRight)) (orderRespectsAddition 0<a-b b))
  <CrWellDefinedLemma a b e/2 e 0<e pr a-b<e | inl (inr a-b<0) = <WellDefined (Equivalence.transitive eq (+WellDefined (invContravariant (Ring.additiveGroup R)) groupIsAbelian) (Equivalence.transitive eq (Equivalence.transitive eq +Associative (+WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (Equivalence.transitive eq (+WellDefined (invTwice additiveGroup b) invLeft) identRight)) (Equivalence.reflexive eq))) groupIsAbelian)) (Equivalence.transitive eq +Associative (+WellDefined pr (Equivalence.reflexive eq))) (orderRespectsAddition a-b<e (e/2 + a))
  <CrWellDefinedLemma a b e/2 e 0<e pr a-b<e | inr 0=a-b = <WellDefined (Equivalence.reflexive eq) (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq (transferToRight (Ring.additiveGroup R) (Equivalence.symmetric eq 0=a-b)))) (orderRespectsAddition (halfLess e/2 e 0<e pr) b)

<CrWellDefinedLeft : (a b : CauchyCompletion) (c : A) → Setoid._∼_ cauchyCompletionSetoid a b → a <Cr c → b <Cr c
<CrWellDefinedLeft a b c a=b record { e = ε ; 0<e = 0<e ; N = N ; property = pr } with halve charNot2 ε
... | e/2 , prE/2 with halvePositive e/2 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/2) 0<e)
... | 0<e/2 with a=b e/2 0<e/2
... | N2 , prN2 = record { e = e/2 ; 0<e = 0<e/2 ; N = N +N N2 ; property = ans }
  where
    ans : (m : ℕ) → (N<m : (N +N N2) <N m) → (e/2 + index (CauchyCompletion.elts b) m) < c
    ans m N<m with prN2 {m} (inequalityShrinkRight N<m)
    ... | bl rewrite indexAndApply (CauchyCompletion.elts a) (map inverse (CauchyCompletion.elts b)) _+_ {m} | equalityCommutative (mapAndIndex (CauchyCompletion.elts b) inverse m) = SetoidPartialOrder.<Transitive pOrder (<CrWellDefinedLemma (index (CauchyCompletion.elts a) m) (index (CauchyCompletion.elts b) m) e/2 ε 0<e prE/2 bl) (pr m (inequalityShrinkLeft N<m))

<CrWellDefined : (a b : CauchyCompletion) (c d : A) → Setoid._∼_ cauchyCompletionSetoid a b → c ∼ d → a <Cr c → b <Cr d
<CrWellDefined a b c d a=b c=d a<c = <CrWellDefinedLeft a b d a=b (<CrWellDefinedRight a c d c=d a<c)

record _r<C_ (a : A) (b : CauchyCompletion) : Set (m ⊔ o) where
  field
    e : A
    0<e : 0G < e
    N : ℕ
    pr : (m : ℕ) → (N<m : N <N m) → (a + e) < index (CauchyCompletion.elts b) m

r<CWellDefinedLeft : (a b : A) (c : CauchyCompletion) → (a ∼ b) → (a r<C c) → b r<C c
r<CWellDefinedLeft a b c a=b record { e = e ; 0<e = 0<e ; N = N ; pr = pr } = record { e = e ; 0<e = 0<e ; N = N ; pr =  λ m N<m → <WellDefined (+WellDefined a=b (Equivalence.reflexive eq)) (Equivalence.reflexive eq) (pr m N<m) }

private
  r<CWellDefinedLemma : (a b c e e/2 : A) (_ : e/2 + e/2 ∼ e) (0<e : 0G < e) (_ : abs (a + inverse b) < e/2) (_ : (c + e) < a) → (c + e/2) < b
  r<CWellDefinedLemma a b c e e/2 prE/2 0<e pr c+e<a with totality 0G (a + inverse b)
  r<CWellDefinedLemma a b c e e/2 prE/2 0<e pr c+e<a | inl (inl 0<a-b) = SetoidPartialOrder.<Transitive pOrder (<WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq (+WellDefined (Equivalence.symmetric eq prE/2) (Equivalence.reflexive eq)) (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) invRight)) identRight)))) (Equivalence.reflexive eq) (orderRespectsAddition c+e<a (inverse e/2))) (<WellDefined (Equivalence.transitive eq +Associative (+WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) invLeft) identRight)) (Equivalence.reflexive eq))) (Equivalence.transitive eq groupIsAbelian (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) (invLeft)) identRight))) (orderRespectsAddition pr (b + inverse e/2)))
  r<CWellDefinedLemma a b c e e/2 prE/2 0<e pr c+e<a | inl (inr a-b<0) = SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined groupIsAbelian groupIsAbelian (orderRespectsAddition (halfLess e/2 e 0<e prE/2) c)) c+e<a) (<WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) invLeft)) identRight) identLeft (orderRespectsAddition a-b<0 b))
  r<CWellDefinedLemma a b c e e/2 prE/2 0<e pr c+e<a | inr 0=a-b = SetoidPartialOrder.<Transitive pOrder (<WellDefined groupIsAbelian (Equivalence.reflexive eq) (orderRespectsAddition (halfLess e/2 e 0<e prE/2) c)) (<WellDefined (groupIsAbelian {c} {e}) (transferToRight additiveGroup (Equivalence.symmetric eq 0=a-b)) c+e<a)

r<CWellDefinedRight : (a b : CauchyCompletion) (c : A) → Setoid._∼_ cauchyCompletionSetoid a b → c r<C a → c r<C b
r<CWellDefinedRight a b c a=b record { e = e ; 0<e = 0<e ; N = N ; pr = pr } with halve charNot2 e
... | e/2 , prE/2 with halvePositive e/2 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/2) 0<e)
... | 0<e/2 with a=b e/2 0<e/2
... | N2 , prN2 = record { e = e/2 ; 0<e = 0<e/2 ; N = N +N N2 ; pr = ans }
  where
    ans : (m : ℕ) → (N<m : (N +N N2) <N m) → (c + e/2) < index (CauchyCompletion.elts b) m
    ans m N<m with prN2 {m} (inequalityShrinkRight N<m)
    ... | bl rewrite indexAndApply (CauchyCompletion.elts a) (map inverse (CauchyCompletion.elts b)) _+_ {m} | equalityCommutative (mapAndIndex (CauchyCompletion.elts b) inverse m) = r<CWellDefinedLemma (index (CauchyCompletion.elts a) m) (index (CauchyCompletion.elts b) m) c e e/2 prE/2 0<e bl (pr m (inequalityShrinkLeft N<m))

record _<C_ (a : CauchyCompletion) (b : CauchyCompletion) : Set (m ⊔ o) where
  field
    i : A
    a<i : a <Cr i
    i<b : i r<C b

<CWellDefined : {a b c d : CauchyCompletion} → Setoid._∼_ cauchyCompletionSetoid a b → Setoid._∼_ cauchyCompletionSetoid c d → a <C c → b <C d
<CWellDefined {a} {b} {c} {d} a=b c=d record { i = bound ; a<i = a<bound ; i<b = bound<b } = record { i = bound ; a<i = <CrWellDefinedLeft a b bound a=b a<bound ; i<b = r<CWellDefinedRight c d bound c=d bound<b }

<CInheritedL : {a b : A} → a < b → injection a <Cr b
<CInheritedL {a} {b} a<b with dense charNot2 a<b
... | between , (a<between ,, between<b) = record { e = between + inverse a ; 0<e = <WellDefined invRight (Equivalence.reflexive eq) (orderRespectsAddition a<between (inverse a)) ; N = 0 ; property = λ m _ → <WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq identRight) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) (ans a m)) +Associative)) (Equivalence.reflexive eq) between<b }
  where
    ans : (x : A) (m : ℕ) → 0G ∼ inverse x + index (constSequence x) m
    ans x m rewrite indexAndConst x m = Equivalence.symmetric eq invLeft

<CInheritedR : {a b : A} → a < b → a r<C injection b
<CInheritedR {a} {b} a<b with dense charNot2 a<b
... | between , (a<between ,, between<b) = record { e = between + inverse a ; 0<e = <WellDefined invRight (Equivalence.reflexive eq) (orderRespectsAddition a<between (inverse a)) ; N = 0 ; pr = λ m _ → <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq identRight) (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq invLeft))) +Associative) groupIsAbelian) (identityOfIndiscernablesLeft _∼_ (Equivalence.reflexive eq) (indexAndConst b m)) between<b }

<CInherited : {a b : A} → a < b → (injection a) <C (injection b)
<CInherited {a} {b} a<b with dense charNot2 a<b
... | between , (a<between ,, between<b) = record { i = between ; a<i = <CInheritedL a<between ; i<b = <CInheritedR between<b }

<CCollapsesL : (a b : A) → (injection a) <Cr b → a < b
<CCollapsesL a b record { e = e ; 0<e = 0<i ; N = N ; property = pr } with pr (succ N) (le 0 refl)
... | bl rewrite indexAndConst a N = <Transitive (<WellDefined identLeft reflexive (orderRespectsAddition 0<i a)) bl

<CCollapsesR : (a b : A) → a r<C injection b → a < b
<CCollapsesR a b record { e = e ; 0<e = 0<e ; N = N ; pr = pr } with pr (succ N) (le 0 refl)
... | bl rewrite indexAndConst b N = <Transitive (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<e a)) bl

<CCollapses : {a b : A} → (injection a) <C (injection b) → a < b
<CCollapses {a} {b} record { i = inter ; a<i = pr1 ; i<b = pr2 } = <Transitive (<CCollapsesL a inter pr1) (<CCollapsesR inter b pr2)

<CRelaxL : {a : A} {b : CauchyCompletion} → a r<C b → injection a <C b
<CRelaxL {a} {b} record { e = e ; 0<e = 0<e ; N = N ; pr = pr } with halve charNot2 e
... | e/2 , e/2pr = record { i = a + e/2 ; a<i = <CInheritedL (<WellDefined identLeft groupIsAbelian (orderRespectsAddition (halvePositive' e/2pr 0<e) a)) ; i<b = record { e = e/2 ; 0<e = halvePositive' e/2pr 0<e ; N = N ; pr = λ m N<m → <WellDefined (transitive (+WellDefined reflexive (symmetric e/2pr)) +Associative) reflexive (pr m N<m) } }

<CRelaxL' : {a : A} {b : CauchyCompletion} → injection a <C b → a r<C b
<CRelaxL' {a} {b} record { i = i ; a<i = a<i ; i<b = record { e = e ; 0<e = 0<e ; N = N ; pr = pr } } = record { e = e ; 0<e = 0<e ; N = N ; pr = λ m N<m → <Transitive (orderRespectsAddition (<CCollapsesL _ _ a<i) e) (pr m N<m) }

<CRelaxR : {a : CauchyCompletion} {b : A} → a <Cr b → a <C injection b
<CRelaxR {a} {b} record { e = ε ; 0<e = 0<ε ; N = N ; property = property } with halve charNot2 ε
... | e/2 , e/2+e/2=e = record { i = b + inverse e/2 ; a<i = record { e = e/2 ; 0<e = halvePositive' e/2+e/2=e 0<ε ; N = N ; property = λ m N<m → <WellDefined (transitive groupIsAbelian (transitive +Associative (+WellDefined (transitive (+WellDefined reflexive (symmetric e/2+e/2=e)) (transitive +Associative (transitive (+WellDefined invLeft reflexive) identLeft))) reflexive))) reflexive (orderRespectsAddition (property m N<m) (inverse e/2)) } ; i<b = <CInheritedR (<WellDefined groupIsAbelian identLeft (orderRespectsAddition (<WellDefined reflexive (invIdent additiveGroup) (ringSwapNegatives (<WellDefined (symmetric (invTwice additiveGroup 0R)) (symmetric (invTwice additiveGroup e/2)) (halvePositive' e/2+e/2=e 0<ε)))) b)) }

<CRelaxR' : {a : CauchyCompletion} {b : A} → a <C injection b → a <Cr b
<CRelaxR' {a} {b} record { i = i ; a<i = record { e = ε ; 0<e = 0<ε ; N = N ; property = property } ; i<b = i<b } = record { e = ε ; 0<e = 0<ε ; N = N ; property = λ m N<m → <Transitive (property m N<m) (<CCollapsesR _ _ i<b) }

flip<CR : {a : CauchyCompletion} {b : A} → a <Cr b → inverse b r<C Group.inverse CGroup a
_r<C_.e (flip<CR {a} {b} record { e = e ; 0<e = 0<e ; N = N ; property = property }) = e
_r<C_.0<e (flip<CR {a} {b} record { e = e ; 0<e = 0<e ; N = N ; property = property }) = 0<e
_r<C_.N (flip<CR {a} {b} record { e = e ; 0<e = 0<e ; N = N ; property = property }) = N
_r<C_.pr (flip<CR {a} {b} record { e = e ; 0<e = 0<e ; N = N ; property = property }) m N<m with property m N<m
... | bl = <WellDefined (transitive (transitive (symmetric +Associative) (+WellDefined reflexive (transitive groupIsAbelian (transitive (symmetric +Associative) (transitive (+WellDefined reflexive invLeft) identRight))))) groupIsAbelian) (transitive +Associative (transitive (+WellDefined invRight reflexive) (transitive identLeft (identityOfIndiscernablesRight _∼_ reflexive (mapAndIndex (CauchyCompletion.elts a) inverse m))))) (orderRespectsAddition bl (inverse b + inverse (index (CauchyCompletion.elts a) m)))

flipR<C : {a : A} {b : CauchyCompletion} → a r<C b → Group.inverse CGroup b <Cr inverse a
_<Cr_.e (flipR<C record { e = e ; 0<e = 0<e ; N = N ; pr = pr }) = e
_<Cr_.0<e (flipR<C record { e = e ; 0<e = 0<e ; N = N ; pr = pr }) = 0<e
_<Cr_.N (flipR<C record { e = e ; 0<e = 0<e ; N = N ; pr = pr }) = N
_<Cr_.property (flipR<C {a} {b} record { e = e ; 0<e = 0<e ; N = N ; pr = pr }) m N<m with pr m N<m
... | t = <WellDefined (transitive (+WellDefined groupIsAbelian (+WellDefined reflexive (identityOfIndiscernablesRight _∼_ reflexive (mapAndIndex (CauchyCompletion.elts b) inverse m)))) (transitive (symmetric +Associative) (+WellDefined reflexive (transitive +Associative (transitive (+WellDefined invRight reflexive) identLeft))))) (transitive groupIsAbelian (transitive (symmetric +Associative) (transitive (+WellDefined reflexive invLeft) identRight))) (orderRespectsAddition t (inverse a + inverse (index (CauchyCompletion.elts b) m)))

flip<C : {a b : CauchyCompletion} → a <C b → Group.inverse CGroup b <C Group.inverse CGroup a
flip<C {a} {b} record { i = i ; a<i = a<i ; i<b = i<b } = record { i = inverse i ; a<i = flipR<C i<b ; i<b = flip<CR a<i }

flip<C' : {a b : CauchyCompletion} → Group.inverse CGroup b <C Group.inverse CGroup a → a <C b
flip<C' {a} {b} a<b = <CWellDefined (invTwice CGroup a) (invTwice CGroup b) (flip<C a<b)

<CIrreflexive : {a : CauchyCompletion} → a <C a → False
<CIrreflexive {a} record { i = bound ; a<i = record { e = bA ; 0<e = 0<bA ; N = Na ; property = prA } ; i<b = record { e = bB ; 0<e = 0<bB ; N = Nb ; pr = prB } } with prA (succ Na +N Nb) (le Nb (applyEquality succ (Semiring.commutative ℕSemiring Nb Na)))
... | bl with prB (succ Na +N Nb) (le Na refl)
... | bl2 with <WellDefined (Equivalence.transitive eq +Associative (+WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) groupIsAbelian) (Equivalence.reflexive eq))) groupIsAbelian (ringAddInequalities bl bl2)
... | bad = irreflexive (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft +Associative (<WellDefined (Equivalence.reflexive eq) groupIsAbelian (orderRespectsAddition (<WellDefined identLeft (Equivalence.reflexive eq) (ringAddInequalities 0<bA 0<bB)) (index (CauchyCompletion.elts a) (succ Na +N Nb) + bound)))) bad)

<CTransitive : {a b c : CauchyCompletion} → a <C b → b <C c → a <C c
<CTransitive {a} {b} {c} record { i = boundA ; a<i = record { e = eL ; 0<e = 0<eL ; N = NL ; property = prL } ; i<b = record { e = eR ; 0<e = 0<eR ; N = Nr ; pr = prR } } record { i = boundB ; a<i = record { e = fL ; 0<e = 0<fL ; N = Nfl ; property = prFl } ; i<b = record { e = fR ; 0<e = 0<fR ; N = N ; pr = prFR } } = record { i = boundA ; a<i = record { e = eL ; 0<e = 0<eL ; N = NL ; property = prL } ; i<b = record { e = eR ; 0<e = 0<eR ; N = (Nr +N Nfl) +N N ; pr = λ m N<m → SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (prR m (inequalityShrinkLeft {Nr} (inequalityShrinkLeft N<m))) (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<fL (index (CauchyCompletion.elts b) m)))) (prFl m (inequalityShrinkRight {Nr} (inequalityShrinkLeft N<m)))) (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<fR boundB))) (prFR m (inequalityShrinkRight N<m)) } }

<COrder : SetoidPartialOrder cauchyCompletionSetoid _<C_
SetoidPartialOrder.<WellDefined <COrder {a} {b} {c} {d} a=b c=d a<c = <CWellDefined {a} {b} {c} {d} a=b c=d a<c
SetoidPartialOrder.irreflexive <COrder {a} a<a = <CIrreflexive {a} a<a
SetoidPartialOrder.<Transitive <COrder {a} {b} {c} a<b b<c = <CTransitive {a} {b} {c} a<b b<c


-- Common imports and other auxiliary operations used in the library
module SOAS.Common where

open import Categories.Category.Instance.Sets public
open import Axiom.Extensionality.Propositional
  using (Extensionality; ExtensionalityImplicit)
open import Relation.Binary.PropositionalEquality public
  hiding (Extensionality)
  renaming (subst to ≡subst; [_] to ≡[_])

open import Categories.Category public
open import Categories.Category.Helper public
open import Categories.Functor public
  renaming (id to idF)

open import Categories.NaturalTransformation public
  using (ntHelper)
  renaming (NaturalTransformation to NT; id to idN; _∘ᵥ_ to _∘N_)
open import Categories.NaturalTransformation.Equivalence using (_≃_) public
open import Categories.Morphism using (Iso) public

open import Level as L hiding (lift) renaming (suc to lsuc) public
open import Function using (flip; case_of_; _∋_) public renaming (_$_ to _$ᶠ_)
open import Data.Product public using (_×_; proj₁; proj₂; _,_; Σ; module Σ; Σ-syntax; swap)
open import Data.Sum public using (_⊎_ ; inj₁; inj₂)
open import Data.Unit public using (tt)

-- Unit type
data *T : Set where
  * : *T

-- Shorthand for first universe level
1ℓ : Level
1ℓ = lsuc 0ℓ

-- Basic function extensionality postulates
postulate
  -- Extensionality with one explicit or implicit argument
  ext  : Extensionality 0ℓ 0ℓ
  iext : ExtensionalityImplicit 0ℓ 0ℓ

-- Functions with two explicit arguments
ext² : {A : Set} {B : A → Set}{C : (x : A) → B x → Set}
       {f g : (x : A) → (y : B x) → C x y} →
       (∀ x y → f x y ≡ g x y) →
       (λ x y → f x y) ≡ (λ x y → g x y)
ext² p = ext (λ x → ext (λ y → p x y))

-- Functions with one implicit and one explicit argument
dext : {A : Set} {B : A → Set}{C : (x : A) → B x → Set}
       {f g : {x : A} → (y : B x) → C x y} →
       (∀ {x} y → f {x} y ≡ g {x} y) →
       (λ {x} y → f {x} y) ≡ (λ {x} y → g {x} y)
dext p = iext (ext p)

-- Functions with two pairs of implicit-explicit arguments
dext² : {A : Set}{B : A → Set}{C : A → A → Set}
       {D : (x : A) → B x → (y : A) → C x y → Set}
       {f g : {x : A} → (b : B x) → {y : A} → (c : C x y) → D x b y c} →
       (∀ {x} b {y} c → f {x} b {y} c ≡ g {x} b {y} c) →
       (λ {x} b {y} c → f {x} b {y} c) ≡
       (λ {x} b {y} c → g {x} b {y} c)
dext² p = dext (λ {x} y → dext (p {x} y))

-- Functions with one implicit and one explicit argument where the
-- pointwise equality proof does not use the explicit argument
dext′ : {A : Set} {B : A → Set}{C : (x : A) → B x → Set}
       {f g : {x : A} → (y : B x) → C x y} →
       (∀ {x} {y} → f {x} y ≡ g {x} y) →
       (λ {x} y → f {x} y) ≡ (λ {x} y → g {x} y)
dext′ p = dext (λ {x} y → p {x}{y})

-- Use the naming convention for categories
𝕊ets : Category 1ℓ 0ℓ 0ℓ
𝕊ets = Sets 0ℓ
module 𝕊et = Category 𝕊ets

-- Make composition and the identity globally accessible
open Category (Sets 0ℓ) public using (_∘_; id)

-- Set isomorphism shorthands
open import Categories.Morphism 𝕊ets public using ()
        renaming ( _≅_ to _≅ₛ_ ; module ≅ to ≅ₛ ; ≅-setoid to ≅ₛ-setoid)

-- Congruence with the arguments reversed -- easier to focus on the equalities
-- if the congruence environment is very large
congr : ∀{ℓ}{A B : Set ℓ}{x y : A} → x ≡ y → (f : A → B) → f x ≡ f y
congr refl f = refl


{-# OPTIONS --cubical --without-K --safe #-}
module Cubical.Relation.Binary.Converse where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Data.Prod hiding (map)
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Relation.Binary

------------------------------------------------------------------------
-- Properties

module _ {a ℓ} {A : Type a} (∼ : Rel A ℓ) where

  reflexive : Reflexive ∼ → Reflexive (flip ∼)
  reflexive r = r

  irrefl : Irreflexive ∼ → Irreflexive (flip ∼)
  irrefl i = i

  symmetric : Symmetric ∼ → Symmetric (flip ∼)
  symmetric s = s

  transitive : Transitive ∼ → Transitive (flip ∼)
  transitive t = flip t

  asym : Asymmetric ∼ → Asymmetric (flip ∼)
  asym a = a

  rawtotal : RawTotal ∼ → RawTotal (flip ∼)
  rawtotal t x y = t y x

  total : Total ∼ → Total (flip ∼)
  total t x y = t y x

  resp : ∀ {p} (P : A → hProp p) → Symmetric ∼ →
             P Respects ∼ → P Respects (flip ∼)
  resp _ sym resp ∼ = resp (sym ∼)

  max : ∀ {⊥} → Minimum ∼ ⊥ → Maximum (flip ∼) ⊥
  max min = min

  min : ∀ {⊤} → Maximum ∼ ⊤ → Minimum (flip ∼) ⊤
  min max = max

  fromEq : FromEq ∼ → FromEq (flip ∼)
  fromEq impl = impl ∘ map sym

  toNotEq : ToNotEq ∼ → ToNotEq (flip ∼)
  toNotEq tne y∼x x≡y = tne y∼x (map sym x≡y)

  antisym : Antisymmetric ∼ → Antisymmetric (flip ∼)
  antisym ans = flip ans

  compare : Trichotomous ∼ → Trichotomous (flip ∼)
  compare cmp x y with cmp x y
  ... | tri< x<y x≡y y≮x = tri> y≮x x≡y x<y
  ... | tri≡ x≮y x≡y y≮x = tri≡ y≮x x≡y x≮y
  ... | tri> x≮y x≡y y<x = tri< y<x x≡y x≮y

module _ {a ℓ₁ ℓ₂} {A : Type a} (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) where

  resp₂ : ∼₁ Respects₂ ∼₂ → (flip ∼₁) Respects₂ ∼₂
  resp₂ (resp₁ , resp₂) = resp₂ , resp₁

module _ {a b ℓ} {A : Type a} {B : Type b} (∼ : REL A B ℓ) where

  dec : Decidable ∼ → Decidable (flip ∼)
  dec dec = flip dec

------------------------------------------------------------------------
-- Structures

module _ {a ℓ} {A : Type a} {≈ : Rel A ℓ} where

  isPartialEquivalence : IsPartialEquivalence ≈ → IsPartialEquivalence (flip ≈)
  isPartialEquivalence eq = record
    { symmetric  = symmetric  ≈ Eq.symmetric
    ; transitive = transitive ≈ Eq.transitive
    }
    where module Eq = IsPartialEquivalence eq

  isEquivalence : IsEquivalence ≈ → IsEquivalence (flip ≈)
  isEquivalence eq = record
    { isPartialEquivalence = isPartialEquivalence Eq.isPartialEquivalence
    ; reflexive            = reflexive ≈ Eq.reflexive
    }
    where module Eq = IsEquivalence eq

  isDecEquivalence : IsDecEquivalence ≈ → IsDecEquivalence (flip ≈)
  isDecEquivalence eq = record
    { isEquivalence = isEquivalence Dec.isEquivalence
    ; _≟_           = dec ≈ Dec._≟_
    }
    where module Dec = IsDecEquivalence eq

module _ {a ℓ} {A : Set a} {∼ : Rel A ℓ} where

  isPreorder : IsPreorder ∼ → IsPreorder (flip ∼)
  isPreorder O = record
    { reflexive  = reflexive ∼ O.reflexive
    ; transitive = transitive ∼ O.transitive
    }
    where module O = IsPreorder O

  isPartialOrder : IsPartialOrder ∼ → IsPartialOrder (flip ∼)
  isPartialOrder O = record
    { isPreorder = isPreorder O.isPreorder
    ; antisym    = antisym ∼ O.antisym
    }
    where module O = IsPartialOrder O

  isTotalOrder : IsTotalOrder ∼ → IsTotalOrder (flip ∼)
  isTotalOrder O = record
    { isPartialOrder = isPartialOrder O.isPartialOrder
    ; total          = total ∼ O.total
    }
    where module O = IsTotalOrder O

  isDecTotalOrder : IsDecTotalOrder ∼ → IsDecTotalOrder (flip ∼)
  isDecTotalOrder O = record
    { isTotalOrder = isTotalOrder O.isTotalOrder
    ; _≤?_         = dec ∼ O._≤?_
    }
    where module O = IsDecTotalOrder O

  isStrictPartialOrder : IsStrictPartialOrder ∼ →
                         IsStrictPartialOrder (flip ∼)
  isStrictPartialOrder O = record
    { irrefl     = irrefl ∼ O.irrefl
    ; transitive = transitive ∼ O.transitive
    }
    where module O = IsStrictPartialOrder O

  isStrictTotalOrder : IsStrictTotalOrder ∼ →
                       IsStrictTotalOrder (flip ∼)
  isStrictTotalOrder O = record
    { transitive = transitive ∼ O.transitive
    ; compare    = compare ∼ O.compare
    }
    where module O = IsStrictTotalOrder O

module _ {a ℓ} {A : Type a} where

  equivalence : Equivalence A ℓ → Equivalence A ℓ
  equivalence S = record
    { isEquivalence = isEquivalence S.isEquivalence
    }
    where module S = Equivalence S

  decEquivalence : DecEquivalence A ℓ → DecEquivalence A ℓ
  decEquivalence S = record
    { isDecEquivalence = isDecEquivalence S.isDecEquivalence
    }
    where module S = DecEquivalence S

module _ {a ℓ} {A : Type a} where

  preorder : Preorder A ℓ → Preorder A ℓ
  preorder O = record
    { isPreorder = isPreorder O.isPreorder
    }
    where module O = Preorder O

  partialOrder : PartialOrder A ℓ → PartialOrder A ℓ
  partialOrder O = record
    { isPartialOrder = isPartialOrder O.isPartialOrder
    }
    where module O = PartialOrder O

  totalOrder : TotalOrder A ℓ → TotalOrder A ℓ
  totalOrder O = record
    { isTotalOrder = isTotalOrder O.isTotalOrder
    }
    where module O = TotalOrder O

  decTotalOrder : DecTotalOrder A ℓ → DecTotalOrder A ℓ
  decTotalOrder O = record
    { isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
    }
    where module O = DecTotalOrder O

  strictPartialOrder : StrictPartialOrder A ℓ →
                       StrictPartialOrder A ℓ
  strictPartialOrder O = record
    { isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
    }
    where module O = StrictPartialOrder O

  strictTotalOrder : StrictTotalOrder A ℓ →
                     StrictTotalOrder A ℓ
  strictTotalOrder O = record
    { isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
    }
    where module O = StrictTotalOrder O


{-

A simpler definition of truncation ∥ A ∥ n from n ≥ -1

Note that this uses the HoTT book's indexing, so it will be off
 from `∥_∥_` in HITs.Truncation.Base by -2

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Truncation.Base where

open import Cubical.Data.NatMinusOne renaming (suc₋₁ to suc)
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.HITs.Sn.Base
open import Cubical.Data.Nat.Base renaming (suc to sucℕ)
open import Cubical.Data.Unit.Base
open import Cubical.Data.Empty

-- this definition is off by one. Use hLevelTrunc or ∥_∥ for truncations
-- (off by 2 w.r.t. the HoTT-book)
data HubAndSpoke {ℓ} (A : Type ℓ) (n : ℕ) : Type ℓ where
  ∣_∣ : A  → HubAndSpoke A n
  hub : (f : S₊ n → HubAndSpoke A n) → HubAndSpoke A n
  spoke : (f : S₊ n → HubAndSpoke A n) (x : S₊ n) → hub f ≡ f x

hLevelTrunc : ∀ {ℓ} (n : ℕ) (A : Type ℓ) → Type ℓ
hLevelTrunc zero A = Unit*
hLevelTrunc (sucℕ n) A = HubAndSpoke A n

∥_∥_ : ∀ {ℓ} (A : Type ℓ) (n : ℕ) → Type ℓ
∥ A ∥ n = hLevelTrunc n A


------------------------------------------------------------------------------
-- Conversion rules for the division
------------------------------------------------------------------------------

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

module FOTC.Program.Division.ConversionRulesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Program.Division.Division

------------------------------------------------------------------------------
-- Division properties

private
    -- Before to prove some properties for div it is convenient
    -- to have a proof for each possible execution step.

    -- Initially, we define the possible states (div-s₁, div-s₂, ...)
    -- and after that, we write down the proof for the execution step
    -- from the state p to the state q, e.g.
    --
    -- proof₂₋₃ : ∀ i j → div-s₂ i j ≡ div-s₃ i j.

    -- Initially, the conversion rule div-eq is applied.
    div-s₁ : D → D → D
    div-s₁ i j = if (lt i j) then zero else succ₁ (div (i ∸ j) j)

    -- lt i j ≡ true.
    div-s₂ : D → D → D
    div-s₂ i j = if true
                   then zero
                   else succ₁ (div (i ∸ j) j)

    -- lt i j ≡ false.
    div-s₃ : D → D → D
    div-s₃ i j = if false
                   then zero
                   else succ₁ (div (i ∸ j) j)

    -- The conditional is true.
    div-s₄ : D
    div-s₄ = zero

    -- The conditional is false.
    div-s₅ : D → D → D
    div-s₅ i j = succ₁ (div (i ∸ j) j)

    {-

    To prove the execution steps, e.g.

    proof₃₋₄ : ∀ i j → div-s₃ i j → divh_s₄ i j,

    we usually need to prove that

                             ... m ... ≡ ... n ...    (1)

    given that
                                  m ≡ n,              (2)

    where (2) is a conversion rule usually.

    We prove (1) using

    subst : ∀ {x y} (A : D → Set) → x ≡ y → A x → A y

    where
      • P is given by \m → ... m ... ≡ ... n ...,
      • x ≡ y is given n ≡ m (actually, we use ≡-sym (m ≡ n)) and
      • P x is given by ... n ... ≡ ... n ... (i.e. ≡-refl)

    -}

    -- From div i j to div-s₁ using the equation div-eq.
    proof₀₋₁ : ∀ i j → div i j ≡ div-s₁ i j
    proof₀₋₁ i j = div-eq i j

    -- From div-s₁ to div-s₂ using the proof i<j.
    proof₁₋₂ : ∀ i j → i < j → div-s₁ i j ≡ div-s₂ i j
    proof₁₋₂ i j i<j =
      subst (λ t → (if t
                      then zero
                      else succ₁ (div (i ∸ j) j))
                   ≡
                   (if true
                      then zero
                      else succ₁ (div (i ∸ j) j))
            )
            (sym i<j)
            refl

    -- From div-s₁ to div-s₃ using the proof i≮j.
    proof₁₋₃ : ∀ i j → i ≮ j → div-s₁ i j ≡ div-s₃ i j
    proof₁₋₃ i j i≮j =
      subst (λ t → (if t
                      then zero
                      else succ₁ (div (i ∸ j) j))
                   ≡
                   (if false
                      then zero
                      else succ₁ (div (i ∸ j) j))
            )
            (sym i≮j)
            refl

    -- From div-s₂ to div-s₄ using the conversion rule if-true.
    proof₂₋₄ : ∀ i j → div-s₂ i j ≡ div-s₄
    proof₂₋₄ i j = if-true zero

    -- From div-s₃ to div-s₅ using the conversion rule if-false.
    proof₃₋₅ : ∀ i j → div-s₃ i j ≡ div-s₅ i j
    proof₃₋₅ i j = if-false (succ₁ (div (i ∸ j) j))

----------------------------------------------------------------------
-- The division result when the dividend is minor than the
-- the divisor.
div-x<y : ∀ {i j} → i < j → div i j ≡ zero
div-x<y {i} {j} i<j =
  div i j    ≡⟨ proof₀₋₁ i j ⟩
  div-s₁ i j ≡⟨ proof₁₋₂ i j i<j ⟩
  div-s₂ i j ≡⟨ proof₂₋₄ i j ⟩
  div-s₄     ∎

----------------------------------------------------------------------
-- The division result when the dividend is greater or equal than the
-- the divisor.
div-x≮y : ∀ {i j} → i ≮ j → div i j ≡ succ₁ (div (i ∸ j) j)
div-x≮y {i} {j} i≮j =
  div i j    ≡⟨ proof₀₋₁ i j ⟩
  div-s₁ i j ≡⟨ proof₁₋₃ i j i≮j ⟩
  div-s₃ i j ≡⟨ proof₃₋₅ i j ⟩
  div-s₅ i j ∎


{-# OPTIONS --safe --without-K #-}
module JVM.Prelude where

open import Level public hiding (zero) renaming (suc to sucℓ)
open import Function public using (case_of_; _∘_; id; const)

open import Data.List using (List; _∷_; []; [_]) public
open import Data.Unit using (⊤; tt) public
open import Data.Nat using (ℕ; suc; zero; _+_) public
open import Data.Sum using (inj₁; inj₂) renaming (_⊎_ to _⊕_)public
open import Data.Product public hiding (map; zip)

open import Relation.Unary hiding (_∈_; Empty) public
open import Relation.Binary.PropositionalEquality hiding ([_]) public

open import Relation.Ternary.Core public
open import Relation.Ternary.Structures public


{-# OPTIONS --rewriting #-}
module MessageClosureProperties where

open import Data.Nat using (ℕ; zero ; suc)
open import Data.Fin using (Fin; zero; suc)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; cong; cong₂; sym; refl)

open import Auxiliary.Extensionality
open import Auxiliary.RewriteLemmas

import Types.COI as COI
import Types.IND1 as IND
import Types.Tail1 as Tail
import DualTail1 as DT
import MessageClosure as MC

open COI using (_≈_; _≈'_; _≈ᵗ_)
open DT using (Stack; ε; ⟪_,_⟫)

private
  variable
    n : ℕ
    σ σ′ : Stack n
    G : IND.GType n

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

var=shift-var : (i : Fin (suc n)) → IND.var i ≡ MC.shift{m = n}{n = 0} IND.var i
var=shift-var zero = refl
var=shift-var (suc i) = refl

apply-id-S : (S : IND.SType n) → MC.applyS{n = 0} IND.var S ≡ S
apply-id-G : (G : IND.GType n) → MC.applyG{n = 0} IND.var G ≡ G
apply-id-T : (T : IND.TType n) → MC.applyT{n = 0} IND.var T ≡ T

apply-id-S (IND.gdd G) = cong IND.gdd (apply-id-G G)
apply-id-S{n} (IND.rec G) rewrite sym (ext (var=shift-var{n})) = cong IND.rec (apply-id-G G)
apply-id-S (IND.var x) = refl

apply-id-G (IND.transmit d T S) = cong₂ (IND.transmit d) (apply-id-T T) (apply-id-S S)
apply-id-G (IND.choice d m alt) = cong (IND.choice d m) (ext (apply-id-S ∘ alt))
apply-id-G IND.end = refl

apply-id-T IND.TUnit = refl
apply-id-T IND.TInt = refl
apply-id-T (IND.TPair T T₁) = cong₂ IND.TPair (apply-id-T T) (apply-id-T T₁)
apply-id-T (IND.TChan S) = cong IND.TChan (apply-id-S S)

mc-equiv-S : (s : IND.SType 0)
  → DT.ind2coiS ε s ≈ DT.tail2coiS ε (MC.mclosureS s)
mc-equiv-G : (g : IND.GType 0)
  → DT.ind2coiG ε g ≈' DT.tail2coiG ε (MC.mclosureG g)
mc-equiv-T : (t : IND.TType 0)
  → DT.ind2coiT ε t ≈ᵗ DT.tail2coiT (MC.injectT (MC.applyT IND.var t))

COI.Equiv.force (mc-equiv-S (IND.gdd g)) = mc-equiv-G g
COI.Equiv.force (mc-equiv-S (IND.rec G)) = {!!}
-- mc-equiv-G (IND.st-substG G zero (IND.rec G))

mc-equiv-G (IND.transmit d t s) =
  COI.eq-transmit d (mc-equiv-T t) (mc-equiv-S s)
mc-equiv-G (IND.choice d m alt) =
  COI.eq-choice d (mc-equiv-S ∘ alt)
mc-equiv-G IND.end =
  COI.eq-end

mc-equiv-T IND.TUnit = COI.eq-unit
mc-equiv-T IND.TInt = COI.eq-int
mc-equiv-T (IND.TPair t t₁) = COI.eq-pair (mc-equiv-T t) (mc-equiv-T t₁)
mc-equiv-T (IND.TChan S) rewrite apply-id-S S = COI.eq-chan COI.≈-refl

-- relation between two stacks (to fill above hole in mc-equiv-S)

data Related : DT.Stack {IND.GType} n → Stack {Tail.GType} n → Set where
  base : Related {0} ε ε
  step : Related {n} σ σ′
       → Related {suc n} ⟪ σ , G ⟫ ⟪ σ′ , MC.mcloG (MC.ext {!!} (IND.rec G)) G ⟫


open import Relation.Binary.PropositionalEquality using ( refl )
open import Web.Semantic.DL.Category.Object using ( Object )
open import Web.Semantic.DL.Category.Morphism using ( _≣_ )
open import Web.Semantic.DL.Category.Composition using ( _∙_ )
open import Web.Semantic.DL.Category.Tensor using ( _⊗_ ; _⟨⊗⟩_ )
open import Web.Semantic.DL.Category.Unit using ( I )
open import Web.Semantic.DL.Category.Wiring using
  ( identity ; symm ; assoc ; assoc⁻¹ ; unit₁ ; unit₁⁻¹ ; unit₂ ; unit₂⁻¹ )
open import Web.Semantic.DL.Category.Properties.Wiring using
  ( rewriting ; rewrite-compose ; rewrite-tensor
  ; rewrite-identity ; rewrite-symm ; rewrite-assoc ; rewrite-assoc⁻¹
  ; rewrite-unit₁ ; rewrite-unit₁⁻¹ ; rewrite-unit₂ ; rewrite-unit₂⁻¹ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.Util using ( _≡⊎≡_ )

module Web.Semantic.DL.Category.Properties.Tensor.Coherence
  {Σ : Signature} {S T : TBox Σ} where

assoc-unit : ∀ (A₁ A₂ : Object S T) →
  (assoc A₁ I A₂ ∙ (identity A₁ ⟨⊗⟩ unit₁ A₂) ≣ unit₂ A₁ ⟨⊗⟩ identity A₂)
assoc-unit A₁ A₂ = rewriting
  (rewrite-compose (rewrite-assoc A₁ I A₂)
    (rewrite-tensor (rewrite-identity A₁) (rewrite-unit₁ A₂)))
  ((λ x → refl) ≡⊎≡ (λ x → refl))
  (rewrite-tensor (rewrite-unit₂ A₁) (rewrite-identity A₂))

assoc-assoc : ∀ (A₁ A₂ A₃ A₄ : Object S T) →
  (assoc (A₁ ⊗ A₂) A₃ A₄ ∙ assoc A₁ A₂ (A₃ ⊗ A₄) ≣
    (assoc A₁ A₂ A₃ ⟨⊗⟩ identity A₄) ∙ assoc A₁ (A₂ ⊗ A₃) A₄ ∙ (identity A₁ ⟨⊗⟩ assoc A₂ A₃ A₄))
assoc-assoc A₁ A₂ A₃ A₄ = rewriting
  (rewrite-compose (rewrite-assoc (A₁ ⊗ A₂) A₃ A₄) (rewrite-assoc A₁ A₂ (A₃ ⊗ A₄)))
  ((λ x → refl) ≡⊎≡ ((λ x → refl) ≡⊎≡ ((λ x → refl) ≡⊎≡ (λ x → refl))))
  (rewrite-compose (rewrite-tensor (rewrite-assoc A₁ A₂ A₃) (rewrite-identity A₄))
    (rewrite-compose (rewrite-assoc A₁ (A₂ ⊗ A₃) A₄)
      (rewrite-tensor (rewrite-identity A₁) (rewrite-assoc A₂ A₃ A₄))))

assoc-symm : ∀ (A₁ A₂ A₃ : Object S T) →
  (symm (A₁ ⊗ A₂) A₃ ∙ assoc⁻¹ A₃ A₁ A₂ ≣
    assoc A₁ A₂ A₃ ∙ (identity A₁ ⟨⊗⟩ symm A₂ A₃) ∙ assoc⁻¹ A₁ A₃ A₂ ∙ (symm A₁ A₃ ⟨⊗⟩ identity A₂))
assoc-symm A₁ A₂ A₃ = rewriting
  (rewrite-compose (rewrite-symm (A₁ ⊗ A₂) A₃) (rewrite-assoc⁻¹ A₃ A₁ A₂))
  (((λ x → refl) ≡⊎≡ (λ x → refl)) ≡⊎≡ (λ x → refl))
  (rewrite-compose (rewrite-assoc A₁ A₂ A₃)
    (rewrite-compose (rewrite-tensor (rewrite-identity A₁) (rewrite-symm A₂ A₃))
      (rewrite-compose (rewrite-assoc⁻¹ A₁ A₃ A₂)
        (rewrite-tensor (rewrite-symm A₁ A₃) (rewrite-identity A₂)))))

symm-unit : ∀ (A : Object S T) →
  (symm A I ∙ unit₁ A ≣ unit₂ A)
symm-unit A = rewriting
  (rewrite-compose (rewrite-symm A I) (rewrite-unit₁ A))
  (λ x → refl)
  (rewrite-unit₂ A)


-- In this document we'll consider various encodings of mutual data types,
-- including those that are System Fω compatible.

module MutualData where

open import Function
open import Data.Unit.Base
open import Data.Sum
open import Data.Product

-- In the first part of this document we'll demostrate how various encodings work taking
-- the rose tree data type as an example:

mutual
  data Tree₀ (A : Set) : Set where
    node₀ : A -> Forest₀ A -> Tree₀ A

  data Forest₀ (A : Set) : Set where
    nil₀  : Forest₀ A
    cons₀ : Tree₀ A -> Forest₀ A -> Forest₀ A

module Joined where
  -- For encoding a family of mutually recursive data types in terms of a single data type we can
  -- create the type of tags each of which denotes a particular data type from the family, then
  -- merge all constructors of the original data types together into a single data type and index
  -- each of the constructors by the tag representing the data type it constructs.

  -- Since we encode a family consisting of two data types, the type of tags has two inhabitants:

  data TreeForestᵗ : Set where
    Treeᵗ Forestᵗ : TreeForestᵗ

  -- The encoding:

  mutual
    -- There is nothing inherently mutual about these data types.
    -- `Tree` and `Forest` are just aliases defined for convenience and readability.

    Tree : Set -> Set
    Tree A = TreeForest A Treeᵗ

    Forest : Set -> Set
    Forest A = TreeForest A Forestᵗ

    -- Now we have one big data type that contains all constructors of the `Tree`-`Forest` family:

    data TreeForest (A : Set) : TreeForestᵗ -> Set where
      node : A -> Forest A -> Tree A
      nil  : Forest A
      cons : Tree A -> Forest A -> Forest A

    -- Note that the constructors have exactly the same type signatures as before,
    -- but now `Tree` and `Forest` are instances of the same data type.

  -- As a sanity check we show one side (just to save space and because it's demonstrative enough)
  -- of the isomorphism between the original family and its encoded version:

  mutual
    toTree₀ : ∀ {A} -> Tree A -> Tree₀ A
    toTree₀ (node x forest) = node₀ x (toForest₀ forest)

    toForest₀ : ∀ {A} -> Forest A -> Forest₀ A
    toForest₀  nil               = nil₀
    toForest₀ (cons tree forest) = cons₀ (toTree₀ tree) (toForest₀ forest)

  -- The encoding technique described in this module is fairly well-known.

module JoinedCompute where
  -- In this section we'll make `TreeForest` a data type with a single constructor,
  -- the contents of which depends on the type being constructed.

  data TreeForestᵗ : Set where
    Treeᵗ Forestᵗ : TreeForestᵗ

  mutual
    -- Again, `Tree` and `Forest` are just aliases.

    Tree : Set -> Set
    Tree A = TreeForest A Treeᵗ

    Forest : Set -> Set
    Forest A = TreeForest A Forestᵗ

    -- `TreeForestF` matches on the `TreeForestᵗ` index in order to figure out which data type
    -- from the original family is being constructed.
    -- Like in the previous section `TreeForest` defines both the `Tree` and `Forest` data types,
    -- but now it contains a single constructor that only captures the notion of recursion.
    -- What data to store in this constructor is determined by the `TreeForestF` function.

    TreeForestF : Set -> TreeForestᵗ -> Set
    TreeForestF A Treeᵗ   = A × Forest A           -- The only constructor of `Tree` is `node` which
                                                   -- carries an `A` and a `Forest A`.
    TreeForestF A Forestᵗ = ⊤ ⊎ Tree A × Forest A  -- There are two constructors of `Forest`:
                                                   -- `nil` and `cons`. The former one doesn't
                                                   -- carry any information while the latter one
                                                   -- receives a `Tree` and a `Forest`.

    data TreeForest (A : Set) (tfᵗ : TreeForestᵗ) : Set where
      treeForest : TreeForestF A tfᵗ -> TreeForest A tfᵗ

  -- For convenience, we'll be using pattern synonyms in this module and the modules below.

  pattern node x forest    = treeForest (x , forest)
  pattern nil              = treeForest (inj₁ tt)
  pattern cons tree forest = treeForest (inj₂ (tree , forest))

  -- The sanity check.

  mutual
    toTree₀ : ∀ {A} -> Tree A -> Tree₀ A
    toTree₀ (node x forest) = node₀ x (toForest₀ forest)

    toForest₀ : ∀ {A} -> Forest A -> Forest₀ A
    toForest₀  nil               = nil₀
    toForest₀ (cons tree forest) = cons₀ (toTree₀ tree) (toForest₀ forest)

-- In the previous section we had the `TreeForest` data type and its `treeForest` constructor
-- which together captured the notion of recursion. This pattern can be abstracted, so that we can
-- tie knots in arbitrary other data types -- not just `Tree` and `Forest`. Enter `IFix`:

{-# NO_POSITIVITY_CHECK #-}
data IFix {α β} {A : Set α} (B : (A -> Set β) -> A -> Set β) (x : A) : Set β where
  wrap : B (IFix B) x -> IFix B x

module JoinedComputeIFix where
  -- In this module we define the `TreeForest` data type using `IFix`.
  -- The type of tags is as before:

  data TreeForestᵗ : Set where
    Treeᵗ Forestᵗ : TreeForestᵗ

  -- The definition of `TreeForest` is similar to the definition from the previous section:
  -- we again have the `Tree` and `Forest` type aliases, they're just local now,
  -- and as before we dispatch on `tfᵗ` and describe the constructors of the `Tree` and `Forest`
  -- data types using the sum-of-products representation:

  TreeForest : Set -> TreeForestᵗ -> Set
  TreeForest A =
    IFix λ Rec tfᵗ ->
      let Tree   = Rec Treeᵗ
          Forest = Rec Forestᵗ
        in case tfᵗ of λ
          { Treeᵗ   -> A × Forest
          ; Forestᵗ -> ⊤ ⊎ Tree × Forest
          }

  -- We've cheated a little bit here by keeping `A` outside of the pattern functor.
  -- That's just for simplicity, there is no fundamental limitation that prevents us
  -- from taking fixed points of pattern functors of arbitrary arity.
  -- Which is a topic for another document.

  Tree : Set -> Set
  Tree A = TreeForest A Treeᵗ

  Forest : Set -> Set
  Forest A = TreeForest A Forestᵗ

  pattern node x forest    = wrap (x , forest)
  pattern nil              = wrap (inj₁ tt)
  pattern cons tree forest = wrap (inj₂ (tree , forest))

  -- The sanity check.

  mutual
    toTree₀ : ∀ {A} -> Tree A -> Tree₀ A
    toTree₀ (node x forest) = node₀ x (toForest₀ forest)

    toForest₀ : ∀ {A} -> Forest A -> Forest₀ A
    toForest₀  nil               = nil₀
    toForest₀ (cons tree forest) = cons₀ (toTree₀ tree) (toForest₀ forest)

module JoinedComputeIFixFω where
  -- The types we had previously are not System Fω compatible, because we matched on tags at the
  -- type level. Can we avoid this? Yes, easily. Instead of defining data types representing tags
  -- we can just lambda-encode them, because we do have lambdas at the type level in System Fω.

  -- The Church-encoded version of `TreeForestᵗ` at the type level looks like this:

  -- ∀ R -> (Set -> Set -> R) -> R

  -- However this is still not System Fω compatible, because here we quantify over `R` which in
  -- System Fω is a kind and we can't quatify over kinds there. But looking at

  -- TreeForestF : Set -> TreeForestᵗ -> Set
  -- TreeForestF A Treeᵗ   = A × Forest A
  -- TreeForestF A Forestᵗ = ⊤ ⊎ Tree A × Forest A

  -- we see that we match on a `TreeForestᵗ` only to return a `Set`. Hence we can just instantiate
  -- `R` to `Set` right away as we do not do anything else with tags. We arrive at

  TreeForestᵗ : Set₁
  TreeForestᵗ = Set -> Set -> Set

  Treeᵗ : TreeForestᵗ
  Treeᵗ A B = A

  Forestᵗ : TreeForestᵗ
  Forestᵗ A B = B

  -- Where `TreeForestᵗ` is the type of inlined matchers which always return a `Set` and
  -- `Treeᵗ` and `Forestᵗ` are such matchers. The rest is straightforward:

  TreeForest : Set -> TreeForestᵗ -> Set
  TreeForest A =
    IFix λ Rec tfᵗ ->
      let Tree   = Rec Treeᵗ
          Forest = Rec Forestᵗ
        in tfᵗ
             (A × Forest)         -- Returned when `tfᵗ` is `Treeᵗ`.
             (⊤ ⊎ Tree × Forest)  -- Returned when `tfᵗ` is `Forestᵗ`.

  Tree : Set -> Set
  Tree A = TreeForest A Treeᵗ

  Forest : Set -> Set
  Forest A = TreeForest A Forestᵗ

  -- All types are System Fω compatible (except the definition of `TreeForestᵗ` has to be inlined)
  -- as System Fω does not support kind aliases.

  pattern node x forest    = wrap (x , forest)
  pattern nil              = wrap (inj₁ tt)
  pattern cons tree forest = wrap (inj₂ (tree , forest))

  -- The sanity check.

  mutual
    toTree₀ : ∀ {A} -> Tree A -> Tree₀ A
    toTree₀ (node x forest) = node₀ x (toForest₀ forest)

    toForest₀ : ∀ {A} -> Forest A -> Forest₀ A
    toForest₀  nil               = nil₀
    toForest₀ (cons tree forest) = cons₀ (toTree₀ tree) (toForest₀ forest)

  -- An additional test:

  mutual
    mapTree : ∀ {A B} -> (A -> B) -> Tree A -> Tree B
    mapTree f (node x forest) = node (f x) (mapForest f forest)

    mapForest : ∀ {A B} -> (A -> B) -> Forest A -> Forest B
    mapForest f  nil               = nil
    mapForest f (cons tree forest) = cons (mapTree f tree) (mapForest f forest)

-- The first part ends here.  We've just seen how to encode mutual data types in pure System Fω
-- with build-in isorecursive `IFix :: ((k -> *) -> k -> *) -> k -> *`.

-- In the second part we'll see how to encode mutual data types with distinct kind signatures.
-- Due to my lack of imagination, we'll take the following family as an example:

mutual
  data M₀ (A : Set) : Set where
    p₀ : A -> M₀ A
    n₀ : N₀ -> M₀ A

  data N₀ : Set where
    m₀ : M₀ ⊤ -> N₀

-- `M₀` is of kind `Set -> Set` while `N₀` is of kind `Set`.

module DistinctParamsJoined where
  -- As in the first part we start with a single data type that contains all the constructors of
  -- the family of data types being encoded.

  -- The only thing we need to do, is to add all the parameters to the constructors of the type
  -- of tags. The rest just follows.

  data MNᵗ : Set₁ where
    Mᵗ : Set -> MNᵗ  -- `M` is parameterized by a `Set`, hence one `Set` argument.
    Nᵗ : MNᵗ         -- `N` is not parameterized, hence no arguments.

  -- The encoding itself follows the same pattern we've seen previously:

  mutual
    M : Set -> Set
    M A = MN (Mᵗ A)

    N : Set
    N = MN Nᵗ

    data MN : MNᵗ -> Set where
      -- `∀ {A} -> ...` is an artifact of this particular encoding, it'll disappear later.
      p : ∀ {A} -> A -> M A
      n : ∀ {A} -> N -> M A
      m : M ⊤ -> N

  -- The sanity check.

  mutual
    toM₀ : ∀ {A} -> M A -> M₀ A
    toM₀ (p x) = p₀ x
    toM₀ (n y) = n₀ (toN₀ y)

    toN₀ : N -> N₀
    toN₀ (m y) = m₀ (toM₀ y)

module DistinctParamsJoinedComputeIFix where
  -- We skip the `JoinedCompute` stage and jump straight to `JoinedComputeIFix`.

  -- Again, we just add arguments to tags and the rest follows:

  data MNᵗ : Set₁ where
    Mᵗ : Set -> MNᵗ
    Nᵗ : MNᵗ

  MN : MNᵗ -> Set
  MN =
    IFix λ Rec mnᵗ ->
      let M A = Rec (Mᵗ A)
          N   = Rec Nᵗ
        in case mnᵗ of λ
          { (Mᵗ A) -> A ⊎ N  -- `M` has two constructors: one receives an `A` and
                             -- the other receives an `N`.
          ;  Nᵗ    -> M ⊤    -- `N` has one constructor which receives an `M ⊤`.
          }

  M : Set -> Set
  M A = MN (Mᵗ A)

  N : Set
  N = MN Nᵗ

  pattern p x = wrap (inj₁ x)
  pattern n y = wrap (inj₂ y)
  pattern m y = wrap y

  -- The sanity check.

  mutual
    toM₀ : ∀ {A} -> M A -> M₀ A
    toM₀ (p x) = p₀ x
    toM₀ (n y) = n₀ (toN₀ y)

    toN₀ : N -> N₀
    toN₀ (m y) = m₀ (toM₀ y)

module DistinctParamsJoinedComputeIFixFω where
  -- Mechanically performing the restricted Church-encoding transformation that allows to bring
  -- the types into the realms of System Fω, we get

  MNᵗ : Set₁
  MNᵗ = (Set -> Set) -> Set -> Set

  Mᵗ : Set -> MNᵗ
  Mᵗ A = λ rM rN -> rM A

  Nᵗ : MNᵗ
  Nᵗ = λ rM rN -> rN

  -- Nothing new here:

  MN : MNᵗ -> Set
  MN =
    IFix λ Rec mnᵗ ->
      let M A = Rec (Mᵗ A)
          N   = Rec Nᵗ
        in mnᵗ (λ A -> A ⊎ N) (M ⊤)

  M : Set -> Set
  M A = MN (Mᵗ A)

  N : Set
  N = MN Nᵗ

  pattern p x = wrap (inj₁ x)
  pattern n y = wrap (inj₂ y)
  pattern m y = wrap y

  -- The sanity check.

  mutual
    toM₀ : ∀ {A} -> M A -> M₀ A
    toM₀ (p x) = p₀ x
    toM₀ (n y) = n₀ (toN₀ y)

    toN₀ : N -> N₀
    toN₀ (m y) = m₀ (toM₀ y)

module FakingFix where
  -- We can look at encoding mutual data types from entirely distinct perspective.
  -- One of the standard approaches is to have kind-level products and use `Fix :: (k -> k) -> k`
  -- over them. There is no such `Fix` in Agda, but we can pretend it exists:

  postulate
    Fix : ∀ {α} {A : Set α} -> (A -> A) -> A

  -- Then we can encode `MN` as

  MN : (Set -> Set) × Set
  MN =
    Fix λ Rec ->
      let M A = proj₁ Rec A
          N   = proj₂ Rec
        in (λ A -> A ⊎ N) , M ⊤

  -- This all is very similar to what we've seen in the previous section: the local definitions
  -- of `M` and `N` differ and we construct a type-level tuple rather than a `Set`, but the
  -- pattern is the same.

  -- The global definitions of `M` and `N` are

  M : Set -> Set
  M = proj₁ MN

  N : Set
  N = proj₂ MN

  -- And now we can perform the same restricted Church-encoding trick again and use
  -- `((Set -> Set) -> Set -> Set) -> Set` instead of `(Set -> Set) × Set`.
  -- Note that the new type then is exactly the same as the one of `MN` from the previous section:

  -- MN : MNᵗ -> Set

  -- which being inlined becomes:

  -- MN : ((Set -> Set) -> Set -> Set) -> Set

  -- Hence we arrived at the same encoding taking a folklore technique as a starting point.


{-# OPTIONS --cubical --safe #-}

module Data.Binary.Conversion.Strict where

open import Data.Binary.Definition
open import Data.Binary.Increment.Strict
import Data.Nat as ℕ
import Data.Nat.Properties as ℕ
open import Data.Nat using (ℕ; suc; zero)
open import Data.Nat.Fold
open import Strict
open import Data.Nat.DivMod
open import Data.Bool

⟦_⇑⟧′ : ℕ → 𝔹
⟦_⇑⟧′ = foldl-ℕ inc′ 0ᵇ

⟦_⇓⟧′ : 𝔹 → ℕ
⟦ 0ᵇ ⇓⟧′ = zero
⟦ 1ᵇ xs ⇓⟧′ = let! xs′ =! ⟦ xs ⇓⟧′ in! 1 ℕ.+ xs′ ℕ.* 2
⟦ 2ᵇ xs ⇓⟧′ = let! xs′ =! ⟦ xs ⇓⟧′ in! 2 ℕ.+ xs′ ℕ.* 2


{-# OPTIONS --warning=error --safe --without-K --guardedness #-}

open import Sets.EquivalenceRelations
open import Functions.Definition
open import Functions.Lemmas
open import Sets.FinSet.Definition
open import Sets.FinSet.Lemmas
open import Sets.Cardinality.Finite.Definition
open import LogicalFormulae
open import Groups.Definition
open import Groups.Groups
open import Groups.FiniteGroups.Definition
open import Groups.Abelian.Definition
open import Setoids.Setoids
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Integers.Integers
open import Numbers.Rationals.Definition
open import Numbers.Reals.Definition
open import Rings.Definition
open import Fields.FieldOfFractions.Setoid
open import Semirings.Definition
open import Numbers.Modulo.Definition
open import Numbers.Modulo.Group
open import Fields.Fields
open import Setoids.Subset
open import Rings.IntegralDomains.Definition
open import Fields.Lemmas
open import Rings.Examples.Examples

module LectureNotes.Groups.Lecture1 where

-- Examples

groupExample1 : Group (reflSetoid ℤ) (_+Z_)
groupExample1 = ℤGroup

groupExample2 : Group ℚSetoid (_+Q_)
groupExample2 = Ring.additiveGroup ℚRing

groupExample2' : Group ℝSetoid (_+R_)
groupExample2' = Ring.additiveGroup ℝRing

groupExample3 : Group (reflSetoid ℤ) (_-Z_) → False
groupExample3 record { +Associative = multAssoc } with multAssoc {nonneg 3} {nonneg 2} {nonneg 1}
groupExample3 record { +WellDefined = wellDefined } | ()

negSuccInjective : {a b : ℕ} → (negSucc a ≡ negSucc b) → a ≡ b
negSuccInjective {a} {.a} refl = refl

nonnegInjective : {a b : ℕ} → (nonneg a ≡ nonneg b) → a ≡ b
nonnegInjective {a} {.a} refl = refl

integersTimesNotGroup : Group (reflSetoid ℤ) (_*Z_) → False
integersTimesNotGroup = multiplicationNotGroup ℤRing λ ()

rationalsTimesNotGroup : Group ℚSetoid (_*Q_) → False
rationalsTimesNotGroup = multiplicationNotGroup ℚRing λ ()

QNonzeroGroup : Group _ _
QNonzeroGroup = fieldMultiplicativeGroup ℚField

-- TODO: {1, -1} is a group with *

ℤnIsGroup : (n : ℕ) → (0<n : 0 <N n) → _
ℤnIsGroup n pr = ℤnGroup n pr

-- Groups example 8.9 from lecture 1
data Weird : Set where
  e : Weird
  a : Weird
  b : Weird
  c : Weird

_+W_ : Weird → Weird → Weird
e +W t = t
a +W e = a
a +W a = e
a +W b = c
a +W c = b
b +W e = b
b +W a = c
b +W b = e
b +W c = a
c +W e = c
c +W a = b
c +W b = a
c +W c = e

+WAssoc : {x y z : Weird} → (x +W (y +W z)) ≡ (x +W y) +W z
+WAssoc {e} {y} {z} = refl
+WAssoc {a} {e} {z} = refl
+WAssoc {a} {a} {e} = refl
+WAssoc {a} {a} {a} = refl
+WAssoc {a} {a} {b} = refl
+WAssoc {a} {a} {c} = refl
+WAssoc {a} {b} {e} = refl
+WAssoc {a} {b} {a} = refl
+WAssoc {a} {b} {b} = refl
+WAssoc {a} {b} {c} = refl
+WAssoc {a} {c} {e} = refl
+WAssoc {a} {c} {a} = refl
+WAssoc {a} {c} {b} = refl
+WAssoc {a} {c} {c} = refl
+WAssoc {b} {e} {z} = refl
+WAssoc {b} {a} {e} = refl
+WAssoc {b} {a} {a} = refl
+WAssoc {b} {a} {b} = refl
+WAssoc {b} {a} {c} = refl
+WAssoc {b} {b} {e} = refl
+WAssoc {b} {b} {a} = refl
+WAssoc {b} {b} {b} = refl
+WAssoc {b} {b} {c} = refl
+WAssoc {b} {c} {e} = refl
+WAssoc {b} {c} {a} = refl
+WAssoc {b} {c} {b} = refl
+WAssoc {b} {c} {c} = refl
+WAssoc {c} {e} {z} = refl
+WAssoc {c} {a} {e} = refl
+WAssoc {c} {a} {a} = refl
+WAssoc {c} {a} {b} = refl
+WAssoc {c} {a} {c} = refl
+WAssoc {c} {b} {e} = refl
+WAssoc {c} {b} {a} = refl
+WAssoc {c} {b} {b} = refl
+WAssoc {c} {b} {c} = refl
+WAssoc {c} {c} {e} = refl
+WAssoc {c} {c} {a} = refl
+WAssoc {c} {c} {b} = refl
+WAssoc {c} {c} {c} = refl

weirdGroup : Group (reflSetoid Weird) _+W_
Group.+WellDefined weirdGroup = reflGroupWellDefined
Group.0G weirdGroup = e
Group.inverse weirdGroup t = t
Group.+Associative weirdGroup {r} {s} {t} = +WAssoc {r} {s} {t}
Group.identRight weirdGroup {e} = refl
Group.identRight weirdGroup {a} = refl
Group.identRight weirdGroup {b} = refl
Group.identRight weirdGroup {c} = refl
Group.identLeft weirdGroup {e} = refl
Group.identLeft weirdGroup {a} = refl
Group.identLeft weirdGroup {b} = refl
Group.identLeft weirdGroup {c} = refl
Group.invLeft weirdGroup {e} = refl
Group.invLeft weirdGroup {a} = refl
Group.invLeft weirdGroup {b} = refl
Group.invLeft weirdGroup {c} = refl
Group.invRight weirdGroup {e} = refl
Group.invRight weirdGroup {a} = refl
Group.invRight weirdGroup {b} = refl
Group.invRight weirdGroup {c} = refl

weirdAb : AbelianGroup weirdGroup
AbelianGroup.commutative weirdAb {e} {e} = refl
AbelianGroup.commutative weirdAb {e} {a} = refl
AbelianGroup.commutative weirdAb {e} {b} = refl
AbelianGroup.commutative weirdAb {e} {c} = refl
AbelianGroup.commutative weirdAb {a} {e} = refl
AbelianGroup.commutative weirdAb {a} {a} = refl
AbelianGroup.commutative weirdAb {a} {b} = refl
AbelianGroup.commutative weirdAb {a} {c} = refl
AbelianGroup.commutative weirdAb {b} {e} = refl
AbelianGroup.commutative weirdAb {b} {a} = refl
AbelianGroup.commutative weirdAb {b} {b} = refl
AbelianGroup.commutative weirdAb {b} {c} = refl
AbelianGroup.commutative weirdAb {c} {e} = refl
AbelianGroup.commutative weirdAb {c} {a} = refl
AbelianGroup.commutative weirdAb {c} {b} = refl
AbelianGroup.commutative weirdAb {c} {c} = refl

weirdProjection : Weird → FinSet 4
weirdProjection a = ofNat 0 (le 3 refl)
weirdProjection b = ofNat 1 (le 2 refl)
weirdProjection c = ofNat 2 (le 1 refl)
weirdProjection e = ofNat 3 (le zero refl)

weirdProjectionSurj : Surjection weirdProjection
weirdProjectionSurj fzero = a , refl
weirdProjectionSurj (fsucc fzero) = b , refl
weirdProjectionSurj (fsucc (fsucc fzero)) = c , refl
weirdProjectionSurj (fsucc (fsucc (fsucc fzero))) = e , refl
weirdProjectionSurj (fsucc (fsucc (fsucc (fsucc ()))))

weirdProjectionInj : (x y : Weird) → weirdProjection x ≡ weirdProjection y → Setoid._∼_ (reflSetoid Weird) x y
weirdProjectionInj e e fx=fy = refl
weirdProjectionInj e a ()
weirdProjectionInj e b ()
weirdProjectionInj e c ()
weirdProjectionInj a e ()
weirdProjectionInj a a fx=fy = refl
weirdProjectionInj a b ()
weirdProjectionInj a c ()
weirdProjectionInj b e ()
weirdProjectionInj b a ()
weirdProjectionInj b b fx=fy = refl
weirdProjectionInj b c ()
weirdProjectionInj c e ()
weirdProjectionInj c a ()
weirdProjectionInj c b ()
weirdProjectionInj c c fx=fy = refl

weirdFinite : FiniteGroup weirdGroup (FinSet 4)
SetoidToSet.project (FiniteGroup.toSet weirdFinite) = weirdProjection
SetoidToSet.wellDefined (FiniteGroup.toSet weirdFinite) x y = applyEquality weirdProjection
SetoidToSet.surj (FiniteGroup.toSet weirdFinite) = weirdProjectionSurj
SetoidToSet.inj (FiniteGroup.toSet weirdFinite) = weirdProjectionInj
FiniteSet.size (FiniteGroup.finite weirdFinite) = 4
FiniteSet.mapping (FiniteGroup.finite weirdFinite) = id
FiniteSet.bij (FiniteGroup.finite weirdFinite) = idIsBijective

weirdOrder : groupOrder weirdFinite ≡ 4
weirdOrder = refl


------------------------------------------------------------------------------
-- Testing records
------------------------------------------------------------------------------

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

module Record where

postulate
  D  : Set
  P₁ : D → Set
  P₂ : D → D → Set

record P (a b : D) : Set where
  constructor is
  field
    property₁ : P₁ a
    property₂ : P₂ a b
{-# ATP axiom is #-}

postulate
  p₁ : ∀ a → P₁ a
  p₂ : ∀ a b → P₂ a b
{-# ATP axiom p₁ #-}
{-# ATP axiom p₂ #-}

thm₁ : ∀ a b → P a b
thm₁ a b = is (p₁ a) (p₂ a b)

postulate thm₂ : ∀ a b → P a b
{-# ATP prove thm₂ #-}


{-# OPTIONS --safe --warning=error --without-K #-}

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

open import Boolean.Definition
open import Setoids.Setoids
open import Setoids.Subset
open import Setoids.Functions.Definition
open import LogicalFormulae
open import Functions.Definition
open import Lists.Lists

module LectureNotes.MetAndTop.Chapter1 where

PowerSet : {a : _} (A : Set a) → {b : _} → Set (a ⊔ lsuc b)
PowerSet A {b} = A → Set b

equality : {a b c : _} (A : Set a) → PowerSet A {b} → PowerSet A {c} → Set (a ⊔ b ⊔ c)
equality A x y = (z : A) → (x z → y z) && (y z → x z)

trans : {a b c d : _} {A : Set a} → {x : PowerSet A {b}} {y : PowerSet A {c}} {z : PowerSet A {d}} → equality A x y → equality A y z → equality A x z
trans {x} {y} {z} x=y y=z i with x=y i
... | r ,, s with y=z i
... | t ,, u = (λ z → t (r z)) ,, λ z → s (r (_&&_.snd (x=y i) (u z)))

symm : {a b c : _} {A : Set a} → {x : PowerSet A {b}} {y : PowerSet A {c}} → equality A x y → equality A y x
symm x=y i with x=y i
... | r ,, s = s ,, r

reflex : {a b : _} {A : Set a} → (x : PowerSet A {b}) → equality A x x
reflex x i = (λ z → z) ,, λ z → z

mapPower : {a b c : _} {A : Set a} {B : Set b} (f : A → B) → PowerSet B {c} → PowerSet A {c}
mapPower f p a = p (f a)

mapF : {a b c : _} {A : Set a} {B : Set b} (f : A → B) → PowerSet A {c} → PowerSet B {_}
mapF {A = A} f p b = Sg A (λ a → (p a) && (f a ≡ b))

singleton : {a b : _} {A : Set a} → (decidableEquality : (x y : A) → (x ≡ y) || ((x ≡ y) → False)) → A → PowerSet A {b}
singleton decidable a n with decidable a n
singleton decidable a n | inl x = True'
singleton decidable a n | inr x = False'

intersection : {a b c : _} {A : Set a} {B : Set b} (sets : A → PowerSet B {c}) → PowerSet B {a ⊔ c}
intersection {A = A} sets x = (a : A) → (sets a) x

union : {a b c : _} {A : Set a} {B : Set b} (sets : A → PowerSet B {c}) → PowerSet B {a ⊔ c}
union {A = A} sets x = Sg A λ i → sets i x

complement : {a b : _} {A : Set a} → (x : PowerSet A {b}) → PowerSet A
complement x t = x t → False

emptySet : {a b : _} (A : Set a) → PowerSet A {b}
emptySet A x = False'

decideIt : {a b : _} {A : Set a} → {f : A → Set b} → ((x : A) → (f x) || ((f x) → False)) → A → Set _
decideIt decide a with decide a
decideIt decide a | inl x = True
decideIt decide a | inr x = False

fromExtension : {a : _} {A : Set a} → ((x y : A) → (x ≡ y) || ((x ≡ y) → False)) → List A → PowerSet A
fromExtension decideEquality l = decideIt {f = contains l} (containsDecidable decideEquality l)

private

  data !1234 : Set where
    !1 : !1234
    !2 : !1234
    !3 : !1234
    !4 : !1234

  decidable1234 : (x y : !1234) → (x ≡ y) || ((x ≡ y) → False)
  decidable1234 !1 !1 = inl refl
  decidable1234 !1 !2 = inr (λ ())
  decidable1234 !1 !3 = inr (λ ())
  decidable1234 !1 !4 = inr (λ ())
  decidable1234 !2 !1 = inr (λ ())
  decidable1234 !2 !2 = inl refl
  decidable1234 !2 !3 = inr (λ ())
  decidable1234 !2 !4 = inr (λ ())
  decidable1234 !3 !1 = inr (λ ())
  decidable1234 !3 !2 = inr (λ ())
  decidable1234 !3 !3 = inl refl
  decidable1234 !3 !4 = inr (λ ())
  decidable1234 !4 !1 = inr (λ ())
  decidable1234 !4 !2 = inr (λ ())
  decidable1234 !4 !3 = inr (λ ())
  decidable1234 !4 !4 = inl refl

  f : !1234 → !1234
  f !1 = !1
  f !2 = !1
  f !3 = !4
  f !4 = !3

  exercise1'1i1 : {b : _} → equality {b = b} !1234 (mapPower f (singleton decidable1234 !1)) (fromExtension decidable1234 (!1 :: !2 :: []))
  exercise1'1i1 !1 = (λ x → record {}) ,, (λ x → record {})
  exercise1'1i1 !2 = (λ x → record {}) ,, (λ x → record {})
  exercise1'1i1 !3 = (λ ()) ,, (λ ())
  exercise1'1i1 !4 = (λ ()) ,, λ ()

  exercise1'1i2 : {b : _} → equality {b = b} !1234 (mapPower f (singleton decidable1234 !2)) (λ _ → False)
  exercise1'1i2 !1 = (λ ()) ,, λ ()
  exercise1'1i2 !2 = (λ ()) ,, (λ ())
  exercise1'1i2 !3 = (λ ()) ,, (λ ())
  exercise1'1i2 !4 = (λ ()) ,, (λ ())

  exercise1'1i3 : equality !1234 (mapPower f (fromExtension decidable1234 (!3 :: !4 :: []))) (fromExtension decidable1234 (!3 :: !4 :: []))
  exercise1'1i3 !1 = (λ x → x) ,, (λ x → x)
  exercise1'1i3 !2 = (λ x → x) ,, (λ x → x)
  exercise1'1i3 !3 = (λ x → record {}) ,, (λ x → record {})
  exercise1'1i3 !4 = (λ x → record {}) ,, (λ x → record {})

  exercise1'1ii1 : {a b c t : _} {A : Set a} {B : Set b} {T : Set t} → (f : A → B) → (sets : T → PowerSet B {c}) → equality A (mapPower f (union sets)) (union λ x → mapPower f (sets x))
  exercise1'1ii1 f sets i = (λ x → x) ,, (λ x → x)

  exercise1'1ii2 : {a b c t : _} {A : Set a} {B : Set b} {T : Set t} → (f : A → B) → (sets : T → PowerSet B {c}) → equality A (mapPower f (intersection sets)) (intersection λ x → mapPower f (sets x))
  exercise1'1ii2 f sets i = (λ x → x) ,, (λ x → x)

  exercise1'1ii3 : {a b : _} {A : Set a} {B : Set b} → (f : A → B) → equality A (mapPower f (λ i → True)) (λ i → True)
  exercise1'1ii3 f = λ z → (λ x → record {}) ,, (λ x → record {})

  exercise1'1ii4 : {a b c : _} {A : Set a} {B : Set b} → (f : A → B) → equality A (mapPower f (emptySet {b = c} B)) (emptySet A)
  exercise1'1ii4 f = λ z → (λ x → x) ,, (λ x → x)

  exercise1'1ii5 : {a b c : _} {A : Set a} {B : Set b} → (f : A → B) → (u : PowerSet B {c}) → equality A (mapPower f (complement u)) (complement (mapPower f u))
  exercise1'1ii5 f u z = (λ x → x) ,, (λ x → x)

  exercise1'1iii1 : {a b c t : _} {A : Set a} {B : Set b} {T : Set t} → (f : A → B) (sets : T → PowerSet A {c}) → equality B (mapF f (union sets)) (union λ t → mapF f (sets t))
  exercise1'1iii1 {A = A} {T = T} f sets z = x ,, y
    where
      x : mapF f (union sets) z → union (λ t → mapF f (sets t)) z
      x (a , ((t , isIn) ,, snd)) = t , (a , (isIn ,, snd))
      y : union (λ t → mapF f (sets t)) z → mapF f (union sets) z
      y (t , (r , s)) = r , ((t , _&&_.fst s) ,, _&&_.snd s)

  exercise1'1iii2 : {a b c d : _} {A : Set a} {B : Set b} → (f : A → B) → equality B (mapF f (emptySet {b = c} A)) (emptySet {b = d} B)
  exercise1'1iii2 {A = A} {B = B} f z = x ,, λ ()
    where
      x : mapF f (emptySet A) z → emptySet B z
      x (a , ())

  ex4F : !1234 → !1234
  ex4F !1 = !1
  ex4F !2 = !2
  ex4F !3 = !1
  ex4F !4 = !4

  v1 : PowerSet !1234
  v1 !1 = True
  v1 !2 = True
  v1 !3 = False
  v1 !4 = False
  v2 : PowerSet !1234
  v2 !1 = False
  v2 !2 = True
  v2 !3 = True
  v2 !4 = False

  v1AndV2 : Bool → !1234 → Set
  v1AndV2 BoolTrue = v1
  v1AndV2 BoolFalse = v2

  lhs : equality {c = lzero} !1234 (mapF ex4F (intersection v1AndV2)) (singleton decidable1234 !2)
  lhs !1 = ans ,, λ ()
    where
      ans : mapF ex4F (intersection v1AndV2) !1 → False'
      ans (!1 , (fst ,, refl)) with fst BoolFalse
      ans (!1 , (fst ,, refl)) | ()
      ans (!3 , (fst ,, refl)) with fst BoolTrue
      ans (!3 , (fst ,, refl)) | ()
  lhs !2 = (λ _ → record {}) ,, ans
    where
      u : intersection v1AndV2 !2
      u BoolTrue = record {}
      u BoolFalse = record {}
      ans : singleton decidable1234 !2 !2 → mapF ex4F (intersection v1AndV2) !2
      ans _ = !2 , (u ,, refl)
  lhs !3 = ans ,, λ ()
    where
      ans : mapF ex4F (intersection v1AndV2) !3 → False'
      ans (!3 , (fst ,, ()))
  lhs !4 = ans ,, λ ()
    where
      ans : mapF ex4F (intersection v1AndV2) !4 → False'
      ans (!4 , (fst ,, refl)) with fst BoolTrue
      ans (!4 , (fst ,, refl)) | ()

  fv1AndV2 : Bool → !1234 → Set
  fv1AndV2 BoolTrue = mapF ex4F v1
  fv1AndV2 BoolFalse = mapF ex4F v2

  rhs : equality {c = lzero} !1234 (intersection fv1AndV2) (fromExtension decidable1234 (!2 :: !1 :: []))
  rhs !1 = (λ _ → record {}) ,, λ _ → a
    where
      a : intersection fv1AndV2 !1
      a BoolTrue = !1 , (record {} ,, refl)
      a BoolFalse = !3 , (record {} ,, refl)
  rhs !2 = (λ _ → record {}) ,, λ _ → a
    where
      a : intersection fv1AndV2 !2
      a BoolTrue = !2 , (record {} ,, refl)
      a BoolFalse = !2 , (record {} ,, refl)
  rhs !3 = a ,, λ ()
    where
      a : intersection fv1AndV2 !3 → fromExtension decidable1234 (!2 :: !1 :: []) !4
      a pr with pr BoolTrue
      a pr | !1 , (fst ,, ())
      a pr | !2 , (fst ,, ())
      a pr | !3 , (fst ,, snd) = fst
      a pr | !4 , (fst ,, snd) = fst
  rhs !4 = a ,, λ ()
    where
      a : intersection fv1AndV2 !4 → fromExtension decidable1234 (!2 :: !1 :: []) !4
      a pr with pr BoolTrue
      a pr | !1 , (x ,, ())
      a pr | !2 , (x ,, ())
      a pr | !3 , (x ,, ())
      a pr | !4 , (x ,, _) = x

  exercise1'1iv1 : (equality !1234 (mapF ex4F (intersection v1AndV2)) (intersection fv1AndV2)) → False
  exercise1'1iv1 pr = ohno
    where
      bad : equality !1234 (fromExtension decidable1234 (!2 :: !1 :: [])) (singleton decidable1234 !2)
      bad = trans (symm rhs) (trans (symm pr) lhs)
      ohno : False
      ohno with bad !1
      ohno | fst ,, snd with fst record {}
      ... | ()

  exercise1'1iv2 : (equality !1234 (mapF ex4F (λ _ → True)) (λ _ → True)) → False
  exercise1'1iv2 pr with pr !3
  exercise1'1iv2 pr | fst ,, snd with snd _
  exercise1'1iv2 pr | fst ,, snd | !1 , ()
  exercise1'1iv2 pr | fst ,, snd | !2 , ()
  exercise1'1iv2 pr | fst ,, snd | !3 , ()
  exercise1'1iv2 pr | fst ,, snd | !4 , ()

  exercise1'1iv3 : equality !1234 (mapF ex4F (complement v1)) (complement v1) → False
  exercise1'1iv3 pr with pr !1
  exercise1'1iv3 pr | fst ,, snd with fst (!3 , ((λ i → i) ,, refl)) (record {})
  ... | ()


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Talks.DURG where

open import Cubical.Algebra.Group
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv
open import Cubical.Functions.FunExtEquiv
open import Cubical.Data.Sigma
open import Cubical.Data.Empty
open import Cubical.Data.Unit
open import Cubical.Data.Nat
open import Cubical.Relation.Binary

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties
open import Cubical.DStructures.Meta.Isomorphism
open import Cubical.DStructures.Structures.XModule

private
  variable
    ℓ ℓ' ℓ'' ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓA ℓ≅A ℓA' ℓ≅A' ℓB ℓB' ℓ≅B' ℓ≅B ℓC ℓ≅C ℓ≅ᴰ ℓP : Level

{-
  Goals of the project:
  - define strict 2-groups
  - define crossed modules
  - prove their equivalence
  - do something with the classifying space
    perspective on groups

  Problems:
  - performance
  - the maps going back and forth were fine,
    but the identity types stating that these maps
    are inverse to each other were too complex

  How did we solve this?
  - Copatterns
  - Ulrik's idea: displayed univalent reflexive graphs
    - Provide a fiberwise characterization of the identity types
      of a type family to obtain a characterization of the
      identity types of the total space
    - Avoid equality on objects in proofs
    - Modular and abstract
-}

-- DEFINITION
-- - URG structure
-- - alternative constructors

record URGStr' (A : Type ℓA) (ℓ≅A : Level) : Type (ℓ-max ℓA (ℓ-suc ℓ≅A)) where
  no-eta-equality
  constructor urgstr'

  field
    _≅_ : Rel A A ℓ≅A
    ρ : isRefl _≅_
    uni : isUnivalent _≅_ ρ

-- substituted version
record URGStr'' (A : Type ℓA) (ℓ≅A : Level) : Type (ℓ-max ℓA (ℓ-suc ℓ≅A)) where
  field
    -- a binary relation
    _≅_ : A → A → Type ℓ≅A
    -- a witness of reflexivity
    ρ : (a : A) → a ≅ a
  -- these two fields induce a map that turns
  -- a path into a proof the endpoints are related
  ≡→≅ : {a a' : A} → a ≡ a' → a ≅ a'
  ≡→≅ {a} {a'} p = subst (λ z → a ≅ z) p (ρ a)
  field
    -- that natural map is a fiberwise equivalence
    uni : (a a' : A) → isEquiv (≡→≅ {a} {a'})

  -- alternatively, we could ask for any fiberwise equivalence
  uni' = (a a' : A) → (a ≡ a') ≃ (a ≅ a')
  -- another alternative: all ≅-singletons should be contractible
  contrRelSingl' = (a : A) → isContr (Σ[ a' ∈ A ] (a ≅ a'))

  -- We can prove that these are equivalent:
  -- uni ↔ uni' ↔ contrRelSingl'

  -- This gives rise to alternative constructors for URGs:

make-𝒮' : {A : Type ℓA}
         {_≅_ : Rel A A ℓ≅A}
         (ρ : isRefl _≅_)
         (contrTotal : contrRelSingl _≅_)
         → URGStr A ℓ≅A
make-𝒮' {_≅_ = _≅_} ρ contrTotal =
  urgstr _≅_
         ρ
         (contrRelSingl→isUnivalent _≅_ ρ contrTotal)

-- EXAMPLES
-- - groups
-- - univalent categories
-- - observational equality on ℕ
-- - universe
-- - identity types

-- The SIP for groups produces a URG structure on the type of groups
𝒮-group' : (ℓ : Level) → URGStr (Group {ℓ}) ℓ
𝒮-group' ℓ .URGStr._≅_ = GroupEquiv
𝒮-group' ℓ .URGStr.ρ = idGroupEquiv
𝒮-group' ℓ .URGStr.uni =
  isUnivalent'→isUnivalent GroupEquiv
                            idGroupEquiv
                            λ G H → invEquiv (GroupPath G H)

-- Every univalent Category induces a URG on its type of objects
open import Cubical.Categories.Category renaming (isUnivalent to isUnivalentCat)
Cat→𝒮 : (𝒞 : Precategory ℓ ℓ')
         → (uni : isUnivalentCat 𝒞)
         → URGStr (𝒞 .ob) ℓ'
Cat→𝒮 𝒞 uni
  = urgstr (CatIso {𝒞 = 𝒞})
           idCatIso
           λ x y → isUnivalentCat.univ uni x y

-- observational equality on ℕ
ℕ-≅ : ℕ → ℕ → Type ℓ-zero
ℕ-≅ 0 0 = Unit
ℕ-≅ 0 (suc _) = ⊥
ℕ-≅ (suc _) 0 = ⊥
ℕ-≅ (suc n) (suc m) = ℕ-≅ n m
-- observational equality on ℕ is a URG
𝒮-Nat' : URGStr ℕ ℓ-zero
𝒮-Nat' = {!!}
  where
    import Cubical.DStructures.Structures.Nat using (𝒮-Nat)

-- equivalences determine a URG on any universe
𝒮-universe : URGStr (Type ℓ) ℓ
𝒮-universe
  = make-𝒮 {_≅_ = _≃_}
            idEquiv
            λ A → isContrRespectEquiv (Σ-cong-equiv-snd (λ A' → isoToEquiv (equivInv A' A)))
                                       (equivContr' A)
  where
    module _ (A : Type ℓ) where
      equivInv : (A' : Type ℓ) → Iso (A ≃ A') (A' ≃ A)
      Iso.fun (equivInv A') = invEquiv
      Iso.inv (equivInv A') = invEquiv
      Iso.leftInv (equivInv A') = λ e → equivEq (invEquiv (invEquiv e)) e (funExt (λ x → refl))
      Iso.rightInv (equivInv A') = λ e → equivEq (invEquiv (invEquiv e)) e (funExt (λ x → refl))
      equivContr' : isContr (Σ[ A' ∈ Type ℓ ] A' ≃ A)
      equivContr' = EquivContr A

-- trivially, a type is a URGStr with the relation given by its identity types
𝒮-type : (A : Type ℓ) → URGStr A ℓ
𝒮-type A = make-𝒮 {_≅_ = _≡_}
                  (λ _ → refl)
                  isContrSingl

-- THEOREM:
-- uniqueness of small URGs

𝒮-uniqueness' : (A : Type ℓA) → isContr (URGStr A ℓA)
𝒮-uniqueness' = {!!}
  where
    import Cubical.DStructures.Structures.Type using (𝒮-uniqueness)

-- DEFINITION
-- - displayed URG

record URGStrᴰ' {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                (B : A → Type ℓB) (ℓ≅ᴰ : Level) : Type (ℓ-max (ℓ-max (ℓ-max ℓA ℓB) ℓ≅A) (ℓ-suc ℓ≅ᴰ)) where
  no-eta-equality
  constructor urgstrᴰ'
  open URGStr 𝒮-A

  field
    _≅ᴰ⟨_⟩_ : {a a' : A} → B a → a ≅ a' → B a' → Type ℓ≅ᴰ
    ρᴰ : {a : A} → isRefl _≅ᴰ⟨ ρ a ⟩_
    uniᴰ : {a : A} → isUnivalent _≅ᴰ⟨ ρ a ⟩_ ρᴰ

  -- Of course, this also has the alternative constructor make-𝒮ᴰ
  -- using that the uniᴰ field follows from
  uniᴰ' = {a : A} → (b : B a) → isContr (Σ[ b' ∈ B a ] b ≅ᴰ⟨ ρ a ⟩ b')

-- EXAMPLE
-- - pointedness displayed over the universe
𝒮ᴰ-pointed : {ℓ : Level} → URGStrᴰ (𝒮-universe {ℓ}) (λ A → A) ℓ
𝒮ᴰ-pointed {ℓ} =
  make-𝒮ᴰ (λ a e b → equivFun e a ≡ b)
          (λ _ → refl)
          p
          where
            p : (A : Type ℓ) (a : A) → isContr (Σ[ b ∈ A ] a ≡ b)
            p _ a = isContrSingl a

-- THEOREM
-- Every DURG on a type family B induces
-- a URG on the total space Σ[ a ∈ A ] B a

∫⟨_⟩'_ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
        {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
        → URGStr (Σ A B) (ℓ-max ℓ≅A ℓ≅B)
∫⟨_⟩'_ = {!!}

{-
  B   ∫
  |   ↦   A × B
  A
-}

-- EXAMPLE
-- A characterization of the identity types of pointed types
𝒮-pointed : {ℓ : Level} → URGStr (Σ[ A ∈ Type ℓ ] A) ℓ
𝒮-pointed = ∫⟨ 𝒮-universe ⟩ 𝒮ᴰ-pointed

-- EXAMPLE
-- - constant DURG
-- - URG product
-- - URG structure on pairs of groups

𝒮ᴰ-const : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
           {B : Type ℓB} (𝒮-B : URGStr B ℓ≅B)
           → URGStrᴰ 𝒮-A (λ _ → B) ℓ≅B
𝒮ᴰ-const {A = A} 𝒮-A {B} 𝒮-B
  = urgstrᴰ (λ b _ b' → b ≅ b') ρ uni
    where
      open URGStr 𝒮-B

_×𝒮_ : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
        {B : Type ℓB} (𝒮-B : URGStr B ℓ≅B)
        → URGStr (A × B) (ℓ-max ℓ≅A ℓ≅B)
_×𝒮_ 𝒮-A 𝒮-B = ∫⟨ 𝒮-A ⟩ (𝒮ᴰ-const 𝒮-A 𝒮-B)

{-
        const   B    ∫
  A, B   ↦     |    ↦ A × B
                A
-}

-- EXAMPLE
-- Group Homomorphisms displayed over pairs of groups

𝒮ᴰ-G²\F' : URGStrᴰ (𝒮-group' ℓ ×𝒮 𝒮-group' ℓ')
                  (λ (G , H) → GroupHom G H)
                  (ℓ-max ℓ ℓ')
𝒮ᴰ-G²\F' =
    make-𝒮ᴰ (λ {(G , H)} {(G' , H')} f (eG , eH) f'
               → (g : ⟨ G ⟩)
               → GroupEquiv.eq eH .fst ((f .fun) g) ≡ (f' .fun) (GroupEquiv.eq eG .fst g))
            (λ _ _ → refl)
            λ (G , H) f → isContrRespectEquiv (Σ-cong-equiv-snd (λ f' → isoToEquiv (invIso (GroupMorphismExtIso f f'))))
                                              (isContrSingl f)
    where open GroupHom

{-
The displayed relation is defined as

  f ≅⟨ eG , eH ⟩ f = commutativity of

         f
   G --------> H
   |           |
eG |           | eH
   |           |
   G'--------> H'
        f'

Reflexivity is trivial

Univalence follows from contractibility of
Σ[ (f' , _) ∈ GroupHom G H ] (f ∼ f')
for all (f , _) ∈ GroupHom G H
-}

{-
  Overview of Crossed Modules and Strict 2-Groups

  Definition: Crossed module
    - group action α of G₀ on H
    - homomorphism φ : H → G₀
    - equivariance condition
      (g : G₀) → (h : H) → φ (g α h) ≡ g + (φ h) - g
    - peiffer condition
      (h h' : ⟨ H ⟩) → (φ h) α h' ≡ h + h' - h

  Definition: Strict 2-Group
    - internal category in the category of groups
    This means
    - split mono ι with two retractions
      ι : G₀ ↔ G : σ τ₁
    - vertical composition operation which satisfies the interchange law
      _∘⟨_⟩_ : (g f : G₁) → isComposable g f → G₁
    - equivalent to type of vertical compositions on internal reflexive graph: PFG
      (a b :  G₁) → ι(σ b) + a - ι(τ a) - ι(σ b) + b + ι(τ a) ≡ b + a

  Produce this tree of displayed structures:

  PFXM                    PFG     VertComp
  |                       |      /
  |                       |     /
  isEquivar               isSecRet
  |                       |
  |                       |
  B                       B
  |                       |
  |                       |
  isAction                isSecRet
  |                       |
  |                       |
  LAS       F      B      F×B
  \         |      |      /
    \       |      |    /
      \     |      /   /
        \   |     /  /
            Grp
            |
            |
             Grp

use the next result to display propositions like isAction, isEquivariant and isSecRet
-}

-- THEOREM
-- Subtypes have a simple DURG structure given by 𝟙
-- This makes it easy to impose axioms on a structure
Subtype→Sub-𝒮ᴰ : {A : Type ℓA}
                 → (P : A → hProp ℓP)
                 → (𝒮-A : URGStr A ℓ≅A)
                 → URGStrᴰ 𝒮-A (λ a → P a .fst) ℓ-zero
Subtype→Sub-𝒮ᴰ P 𝒮-A =
  make-𝒮ᴰ (λ _ _ _ → Unit)
          (λ _ → tt)
          (λ a p → isContrRespectEquiv (invEquiv (Σ-contractSnd (λ _ → isContrUnit)))
                                        (inhProp→isContr p (P a .snd)))

-- EXAMPLE
-- isAction axioms on pairs of groups together with a left action structure
module _ (ℓ ℓ' : Level) where
  ℓℓ' = ℓ-max ℓ ℓ'

  open import Cubical.DStructures.Structures.Action
  𝒮ᴰ-G²Las\Action' : URGStrᴰ (𝒮-G²Las ℓ ℓ')
                     (λ ((G , H) , _α_) → IsGroupAction G H _α_)
                     ℓ-zero
  𝒮ᴰ-G²Las\Action' = Subtype→Sub-𝒮ᴰ (λ ((G , H) , _α_) → IsGroupAction G H _α_ , isPropIsGroupAction G H _α_)
                                    (𝒮-G²Las ℓ ℓ')
  𝒮-G²LasAction' : URGStr (Action ℓ ℓ') (ℓ-max ℓ ℓ')
  𝒮-G²LasAction' = ∫⟨ 𝒮-G²Las ℓ ℓ' ⟩ 𝒮ᴰ-G²Las\Action'

{-
-- THEOREM
-- DURGs can be lifted to be displayed over the total space of
-- another DURG on the same base URG

                 B
                 |
  B   C   Lift   C
   \ /     ↦    |
    A            A
-}

VerticalLift-𝒮ᴰ' : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                   {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                   {C : A → Type ℓC} (𝒮ᴰ-C : URGStrᴰ 𝒮-A C ℓ≅C)
                   → URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-C) (λ (a , _) → B a) ℓ≅B
VerticalLift-𝒮ᴰ' {ℓ≅B = ℓ≅B} 𝒮-A {B = B} 𝒮ᴰ-B 𝒮ᴰ-C =
  urgstrᴰ (λ b (pA , _) b' → b ≅ᴰ⟨ pA ⟩ b')
          ρᴰ
          uniᴰ
  where open URGStrᴰ 𝒮ᴰ-B

{-
-- THEOREM
-- A tower of two DURGs can be reassociated

   C
   |
   B  split  B × C
   |   ↦      |
   A           A
(but C depends on B)

-}
splitTotal-𝒮ᴰ' : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
                {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                {C : Σ A B → Type ℓC} (𝒮ᴰ-C : URGStrᴰ (∫⟨ 𝒮-A ⟩ 𝒮ᴰ-B) C ℓ≅C)
                → URGStrᴰ 𝒮-A
                          (λ a → Σ[ b ∈ B a ] C (a , b))
                          (ℓ-max ℓ≅B ℓ≅C)
splitTotal-𝒮ᴰ' {A = A} 𝒮-A {B} 𝒮ᴰ-B {C} 𝒮ᴰ-C
  = make-𝒮ᴰ (λ (b , c) eA (b' , c') → Σ[ eB ∈ b B≅ᴰ⟨ eA ⟩ b' ] c ≅ᴰ⟨ eA , eB ⟩ c')
            (λ (b , c) → Bρᴰ b , ρᴰ c)
            {!!}
  where
    open URGStrᴰ 𝒮ᴰ-C
    open URGStr 𝒮-A
    _B≅ᴰ⟨_⟩_ = URGStrᴰ._≅ᴰ⟨_⟩_ 𝒮ᴰ-B
    Bρᴰ = URGStrᴰ.ρᴰ 𝒮ᴰ-B
    Buniᴰ = URGStrᴰ.uniᴰ 𝒮ᴰ-B

{-
-- THEOREM
-- two DURGs over the same URGs can be combined

                 B
                 |
  B   C   Lift   C   split  B × C
   \ /     ↦    |     ↦     |
    A            A           A
-}
combine-𝒮ᴰ' : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
             {B : A → Type ℓB} {C : A → Type ℓC}
             (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
             (𝒮ᴰ-C : URGStrᴰ 𝒮-A C ℓ≅C)
             → URGStrᴰ 𝒮-A (λ a → B a × C a) (ℓ-max ℓ≅B ℓ≅C)
combine-𝒮ᴰ' {𝒮-A = 𝒮-A} 𝒮ᴰ-B 𝒮ᴰ-C = splitTotal-𝒮ᴰ 𝒮-A 𝒮ᴰ-B (VerticalLift-𝒮ᴰ 𝒮-A 𝒮ᴰ-C 𝒮ᴰ-B)

-- REMARK: DURG is equivalent to URG + morphism of URG via fibrant replacement

module _ (C : Type ℓ) where
  dispTypeIso :  Iso (C → Type ℓ) (Σ[ X ∈ Type ℓ ] (X → C))
  Iso.fun dispTypeIso D = (Σ[ c ∈ C ] D c) , fst
  Iso.inv dispTypeIso (X , F) c = Σ[ x ∈ X ] F x ≡ c
  Iso.leftInv dispTypeIso = {!!}
  Iso.rightInv dispTypeIso = {!!}

-- → combine is pullback in the (∞,1)-topos of DURGs

{-
With these operations we can construct the entire tree, but how
to get equivalences?

  PFXM                    PFG     VertComp
  |                       |      /
  |                       |     /
  isEquivar               isSecRet
  |                       |
  |                       |
  B                       B
  |                       |
  |                       |
  isAction                isSecRet
  |                       |
  |                       |
  LAS       F      B      F×B
  \         |      |      /
    \       |      |    /
      \     |      /   /
        \   |     /  /
            Grp
            |
            |
            Grp

-- For URGs: relational isomorphisms
-}

record RelIso' {A : Type ℓA} (_≅_ : Rel A A ℓ≅A)
              {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where
  constructor reliso'
  field
    fun : A → A'
    inv : A' → A
    rightInv : (a' : A') → fun (inv a') ≅' a'
    leftInv : (a : A) → inv (fun a) ≅ a

RelIso→Iso' : {A : Type ℓA} {A' : Type ℓA'}
             (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A')
             {ρ : isRefl _≅_} {ρ' : isRefl _≅'_}
             (uni : isUnivalent _≅_ ρ) (uni' : isUnivalent _≅'_ ρ')
             (f : RelIso _≅_ _≅'_)
             → Iso A A'
Iso.fun (RelIso→Iso' _ _ _ _ f) = RelIso.fun f
Iso.inv (RelIso→Iso' _ _ _ _ f) = RelIso.inv f
Iso.rightInv (RelIso→Iso' _ _≅'_ {ρ' = ρ'} _ uni' f) a'
  = invEquiv (≡→R _≅'_ ρ' , uni' (RelIso.fun f (RelIso.inv f a')) a') .fst (RelIso.rightInv f a')
Iso.leftInv (RelIso→Iso' _≅_ _ {ρ = ρ} uni _ f) a
  = invEquiv (≡→R _≅_ ρ , uni (RelIso.inv f (RelIso.fun f a)) a) .fst (RelIso.leftInv f a)

{-
  For DURGs:
  pull back one of the DURGs
  along an equivalence and show that
  there is a fiberwise relational isomorphism
  between B and f*B'

  B   f*B' B'
  |  /     |
  | /      |
  A   ≃   A'
      f
-}

𝒮ᴰ-*-Iso-Over→TotalIso : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
                         {A' : Type ℓA'} {𝒮-A' : URGStr A' ℓ≅A'}
                         (ℱ : Iso A A')
                         {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                         {B' : A' → Type ℓB'} (𝒮ᴰ-B' : URGStrᴰ 𝒮-A' B' ℓ≅B')
                         (𝒢 : 𝒮ᴰ-♭PIso (Iso.fun ℱ) 𝒮ᴰ-B 𝒮ᴰ-B')
                         → Iso (Σ A B) (Σ A' B')
𝒮ᴰ-*-Iso-Over→TotalIso  ℱ 𝒮ᴰ-B 𝒮ᴰ-B' 𝒢
  = RelFiberIsoOver→Iso ℱ
                        (𝒮ᴰ→relFamily 𝒮ᴰ-B) (𝒮ᴰ-B .uniᴰ)
                        (𝒮ᴰ→relFamily 𝒮ᴰ-B') (𝒮ᴰ-B' .uniᴰ)
                        𝒢
  where open URGStrᴰ

{-
  Let's apply this machinery to our tower of DURGs.
-}

import Cubical.DStructures.Equivalences.GroupSplitEpiAction
import Cubical.DStructures.Equivalences.PreXModReflGraph
import Cubical.DStructures.Equivalences.XModPeifferGraph
import Cubical.DStructures.Equivalences.PeifferGraphS2G

{-
DISCUSSION
- alternate definition of URGs
- how to layer the cake
- uniformity, abstraction, no equality on objects,
  results transferrable across proof assistants
  and type theories
- unlike displayed categories not limited to
  1-truncated types and type families
- easy to set up
- associates the other way compared to SNS
- every SNS gives DURG on the URG of the universe (not implemented)

OTHER THINGS WE DID
- Define (n,k)-groups
- Display homomorphisms of (n,k)-groups over pairs of such groups
- prove the equivalence of (0,1)-groups and axiomatic groups via EM-spaces

FUTURE WORK
- construct more operations
- use reflection to automate steps
- construct URG on the type of URG or even DURG structures
  - meta-theory
  - model of type theory
- more higher group theory ...
-}