open import Level
open import Ordinals
module BAlgbra {n : Level } (O : Ordinals {n})   where

open import zf
open import logic
import OrdUtil
import OD
import ODUtil
import ODC

open import Relation.Nullary
open import Relation.Binary
open import Data.Empty
open import Relation.Binary
open import Relation.Binary.Core
open import  Relation.Binary.PropositionalEquality
open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ ; _+_ to _n+_ )

open inOrdinal O
open Ordinals.Ordinals  O
open Ordinals.IsOrdinals isOrdinal
open Ordinals.IsNext isNext
open OrdUtil O
open ODUtil O

open OD O
open OD.OD
open ODAxiom odAxiom
open HOD

open _∧_
open _∨_
open Bool

--_∩_ : ( A B : HOD  ) → HOD
--A ∩ B = record { od = record { def = λ x → odef A x ∧ odef B x } ;
--    odmax = omin (odmax A) (odmax B) ; <odmax = λ y → min1 (<odmax A (proj1 y)) (<odmax B (proj2 y)) }

_∪_ : ( A B : HOD  ) → HOD
A ∪ B = record { od = record { def = λ x → odef A x ∨ odef B x } ;
    odmax = omax (odmax A) (odmax B) ; <odmax = lemma } where
      lemma :  {y : Ordinal} → odef A y ∨ odef B y → y o< omax (odmax A) (odmax B)
      lemma {y} (case1 a) = ordtrans (<odmax A a) (omax-x _ _)
      lemma {y} (case2 b) = ordtrans (<odmax B b) (omax-y _ _)

_＼_ : ( A B : HOD  ) → HOD
A ＼ B = record { od = record { def = λ x → odef A x ∧ ( ¬ ( odef B x ) ) }; odmax = odmax A ; <odmax = λ y → <odmax A (proj1 y) }

∪-Union : { A B : HOD } → Union (A , B) ≡ ( A ∪ B )
∪-Union {A} {B} = ==→o≡ ( record { eq→ =  lemma1 ; eq← = lemma2 } )  where
    lemma1 :  {x : Ordinal} → odef (Union (A , B)) x → odef (A ∪ B) x
    lemma1 {x} lt = lemma3 lt where
        lemma4 : {y : Ordinal} → odef (A , B) y ∧ odef (* y) x → ¬ (¬ ( odef A x ∨ odef B x) )
        lemma4 {y} z with proj1 z
        lemma4 {y} z | case1 refl = double-neg (case1 ( subst (λ k → odef k x ) *iso (proj2 z)) )
        lemma4 {y} z | case2 refl = double-neg (case2 ( subst (λ k → odef k x ) *iso (proj2 z)) )
        lemma3 : (((u : Ordinal ) → ¬ odef (A , B) u ∧ odef (* u) x) → ⊥) → odef (A ∪ B) x
        lemma3 not = ODC.double-neg-eilm O (FExists _ lemma4 not)   -- choice
    lemma2 :  {x : Ordinal} → odef (A ∪ B) x → odef (Union (A , B)) x
    lemma2 {x} (case1 A∋x) = subst (λ k → odef (Union (A , B)) k) &iso ( IsZF.union→ isZF (A , B) (* x) A
        ⟪ case1 refl , d→∋ A A∋x ⟫ )
    lemma2 {x} (case2 B∋x) = subst (λ k → odef (Union (A , B)) k) &iso ( IsZF.union→ isZF (A , B) (* x) B
        ⟪ case2 refl , d→∋ B B∋x ⟫ )

∩-Select : { A B : HOD } →  Select A (  λ x → ( A ∋ x ) ∧ ( B ∋ x )  ) ≡ ( A ∩ B )
∩-Select {A} {B} = ==→o≡ ( record { eq→ =  lemma1 ; eq← = lemma2 } ) where
    lemma1 : {x : Ordinal} → odef (Select A (λ x₁ → (A ∋ x₁) ∧ (B ∋ x₁))) x → odef (A ∩ B) x
    lemma1 {x} lt = ⟪ proj1 lt , subst (λ k → odef B k ) &iso (proj2 (proj2 lt)) ⟫
    lemma2 : {x : Ordinal} → odef (A ∩ B) x → odef (Select A (λ x₁ → (A ∋ x₁) ∧ (B ∋ x₁))) x
    lemma2 {x} lt = ⟪ proj1 lt , ⟪ d→∋ A (proj1 lt) , d→∋ B (proj2 lt) ⟫ ⟫

dist-ord : {p q r : HOD } → p ∩ ( q ∪ r ) ≡   ( p ∩ q ) ∪ ( p ∩ r )
dist-ord {p} {q} {r} = ==→o≡ ( record { eq→ = lemma1 ; eq← = lemma2 } ) where
    lemma1 :  {x : Ordinal} → odef (p ∩ (q ∪ r)) x → odef ((p ∩ q) ∪ (p ∩ r)) x
    lemma1 {x} lt with proj2 lt
    lemma1 {x} lt | case1 q∋x = case1 ⟪ proj1 lt , q∋x ⟫
    lemma1 {x} lt | case2 r∋x = case2 ⟪ proj1 lt , r∋x ⟫
    lemma2  : {x : Ordinal} → odef ((p ∩ q) ∪ (p ∩ r)) x → odef (p ∩ (q ∪ r)) x
    lemma2 {x} (case1 p∩q) = ⟪ proj1 p∩q , case1 (proj2 p∩q ) ⟫
    lemma2 {x} (case2 p∩r) = ⟪ proj1 p∩r , case2 (proj2 p∩r ) ⟫

dist-ord2 : {p q r : HOD } → p ∪ ( q ∩ r ) ≡   ( p ∪ q ) ∩ ( p ∪ r )
dist-ord2 {p} {q} {r} = ==→o≡ ( record { eq→ = lemma1 ; eq← = lemma2 } ) where
    lemma1 : {x : Ordinal} → odef (p ∪ (q ∩ r)) x → odef ((p ∪ q) ∩ (p ∪ r)) x
    lemma1 {x} (case1 cp) = ⟪ case1 cp , case1 cp ⟫
    lemma1 {x} (case2 cqr) = ⟪ case2 (proj1 cqr) , case2 (proj2 cqr) ⟫
    lemma2 : {x : Ordinal} → odef ((p ∪ q) ∩ (p ∪ r)) x → odef (p ∪ (q ∩ r)) x
    lemma2 {x} lt with proj1 lt | proj2 lt
    lemma2 {x} lt | case1 cp | _ = case1 cp
    lemma2 {x} lt | _ | case1 cp = case1 cp
    lemma2 {x} lt | case2 cq | case2 cr = case2 ⟪ cq , cr ⟫

record IsBooleanAlgebra ( L : Set n)
       ( b1 : L )
       ( b0 : L )
       ( -_ : L → L  )
       ( _+_ : L → L → L )
       ( _x_ : L → L → L ) : Set (suc n) where
   field
       +-assoc : {a b c : L } → a + ( b + c ) ≡ (a + b) + c
       x-assoc : {a b c : L } → a x ( b x c ) ≡ (a x b) x c
       +-sym : {a b : L } → a + b ≡ b + a
       -sym : {a b : L } → a x b  ≡ b x a
       +-aab : {a b : L } → a + ( a x b ) ≡ a
       x-aab : {a b : L } → a x ( a + b ) ≡ a
       +-dist : {a b c : L } → a + ( b x c ) ≡ ( a x b ) + ( a x c )
       x-dist : {a b c : L } → a x ( b + c ) ≡ ( a + b ) x ( a + c )
       a+0 : {a : L } → a + b0 ≡ a
       ax1 : {a : L } → a x b1 ≡ a
       a+-a1 : {a : L } → a + ( - a ) ≡ b1
       ax-a0 : {a : L } → a x ( - a ) ≡ b0

record BooleanAlgebra ( L : Set n) : Set (suc n) where
   field
       b1 : L
       b0 : L
       -_ : L → L
       _+_ : L → L → L
       _x_ : L → L → L
       isBooleanAlgebra : IsBooleanAlgebra L b1 b0 -_ _+_ _x_


module Chain
    { A : Set }
    (_==_  : A -> A -> Set )
    (refl  : (x : A) -> x == x)
    (trans : (x y z : A) -> x == y -> y == z -> x == z)
  where

  infix 2 chain>_
  infixl 2 _===_
  infix 3 _by_

  chain>_ : (x : A) -> x == x
  chain> x = refl _

  _===_ : {x y z : A} -> x == y -> y == z -> x == z
  xy === yz = trans _ _ _ xy yz

  _by_ : {x : A}(y : A) -> x == y -> x == y
  y by eq = eq


{-# OPTIONS --without-K --safe --exact-split #-}

module Constructive.Axiom.Properties where

open import Constructive.Axiom.Properties.Base public
open import Constructive.Axiom.Properties.Transport public
open import Constructive.Axiom.Properties.Bool public


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

open import HoTT
open import cohomology.FunctionOver
open import cohomology.FlipPushout

module cohomology.CofiberSequence {i} where

{- Lemma: pushing flip-susp through susp-fmap -}
flip-susp-fmap : {A B : Type i} (f : A → B)
  → ∀ σ → flip-susp (susp-fmap f σ) == susp-fmap f (flip-susp σ)
flip-susp-fmap f = Suspension-elim idp idp $ λ y → ↓-='-in $
  ap-∘ (susp-fmap f) flip-susp (merid y)
  ∙ ap (ap (susp-fmap f)) (FlipSusp.merid-β y)
  ∙ ap-! (susp-fmap f) (merid y)
  ∙ ap ! (SuspFmap.merid-β f y)
  ∙ ! (FlipSusp.merid-β (f y))
  ∙ ! (ap (ap flip-susp) (SuspFmap.merid-β f y))
  ∙ ∘-ap flip-susp (susp-fmap f) (merid y)

{- Useful abbreviations -}
module _ {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

  ⊙Cof² = ⊙Cof (⊙cfcod' f)
  ⊙cfcod² = ⊙cfcod' (⊙cfcod' f)
  cfcod² = fst ⊙cfcod²
  ⊙Cof³ = ⊙Cof ⊙cfcod²
  ⊙cfcod³ = ⊙cfcod' ⊙cfcod²
  cfcod³ = fst ⊙cfcod³

{- For [f : X → Y], the cofiber space [Cof(cfcod f)] is equivalent to
 - [Suspension X]. This is essentially an application of the two pushouts
 - lemma:
 -
 -       f
 -   X ––––> Y ––––––––––––––> ∙
 -   |       |                 |
 -   |       |cfcod f          |
 -   v       v                 v
 -   ∙ ––> Cof f ––––––––––> Cof² f
 -                cfcod² f
 -
 - The map [cfcod² f : Cof f → Cof² f] becomes [ext-glue : Cof f → ΣX],
 - and the map [ext-glue : Cof² f → ΣY] becomes [susp-fmap f : ΣX → ΣY].
 -}
module Cof² {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

  module Equiv {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

    module Into = CofiberRec {f = cfcod' (fst f)} {C = fst (⊙Susp X)}
      south ext-glue (λ _ → idp)

    into = Into.f

    ⊙into : fst (⊙Cof² f ⊙→ ⊙Susp X)
    ⊙into = (into , ! (merid (snd X)))

    module Out = SuspensionRec {C = fst (⊙Cof² f)}
      (cfcod cfbase) cfbase
      (λ x → ap cfcod (cfglue x) ∙ ! (cfglue (fst f x)))

    out = Out.f

    into-out : ∀ σ → into (out σ) == σ
    into-out = Suspension-elim idp idp
      (λ x → ↓-∘=idf-in into out $
        ap (ap into) (Out.merid-β x)
        ∙ ap-∙ into (ap cfcod (cfglue x)) (! (cfglue (fst f x)))
        ∙ ap (λ w → ap into (ap cfcod (cfglue x)) ∙ w)
             (ap-! into (cfglue (fst f x)) ∙ ap ! (Into.glue-β (fst f x)))
        ∙ ∙-unit-r _
        ∙ ∘-ap into cfcod (cfglue x) ∙ ExtGlue.glue-β x)

    out-into : ∀ κ → out (into κ) == κ
    out-into = Cofiber-elim {f = cfcod' (fst f)}
      idp
      (Cofiber-elim {f = fst f} idp cfglue
        (λ x → ↓-='-from-square $
          (ap-∘ out ext-glue (cfglue x)
           ∙ ap (ap out) (ExtGlue.glue-β x) ∙ Out.merid-β x)
          ∙v⊡ (vid-square {p = ap cfcod (cfglue x)}
               ⊡h rt-square (cfglue (fst f x)))
          ⊡v∙ ∙-unit-r _))
      (λ y → ↓-∘=idf-from-square out into $
         ap (ap out) (Into.glue-β y) ∙v⊡ connection)

    eq = equiv into out into-out out-into

    space-path : ⊙Cof² f == ⊙Susp X
    space-path = ⊙ua (⊙≃-in eq (! (merid (snd X))))

  cfcod²-over : cfcod² f == ext-glue
                [ (λ U → fst (⊙Cof f) → fst U) ↓ Equiv.space-path f ]
  cfcod²-over = ↓-cst2-in _ _ $ codomain-over-equiv (cfcod² f) _

  cfcod³-over : ext-glue == flip-susp ∘ susp-fmap (fst f)
                [ (λ U → fst U → fst (⊙Susp Y)) ↓ Equiv.space-path f ]
  cfcod³-over = ↓-cst2-in _ _ $
    domain!-over-equiv ext-glue _ ▹ λ= lemma
    where
    lemma : (σ : fst (⊙Susp X))
      → ext-glue (Equiv.out f σ) == flip-susp (susp-fmap (fst f) σ)
    lemma = Suspension-elim idp idp
      (λ x → ↓-='-in $
        ap-∘ flip-susp (susp-fmap (fst f)) (merid x)
        ∙ ap (ap flip-susp) (SuspFmap.merid-β (fst f) x)
        ∙ FlipSusp.merid-β (fst f x)
        ∙ ! (ap-∘ ext-glue (Equiv.out f) (merid x)
             ∙ ap (ap ext-glue) (Equiv.Out.merid-β f x)
             ∙ ap-∙ ext-glue (ap cfcod (cfglue x))
                             (! (cfglue (fst f x)))
             ∙ (∘-ap ext-glue cfcod (cfglue x)
                ∙ ap-cst south (cfglue x))
               ∙2
               (ap-! ext-glue (cfglue (fst f x))
                ∙ ap ! (ExtGlue.glue-β (fst f x)))))

  open Equiv f public

cofiber-sequence : {X Y : Ptd i} (f : fst (X ⊙→ Y)) → Path
  {A = Σ (Ptd i × Ptd i)
         (λ {(U , V) → (fst (⊙Cof f) → fst U) × (fst U → fst V)})}
  ((⊙Cof² f , ⊙Cof³ f) , cfcod² f , cfcod³ f)
  ((⊙Susp X , ⊙Susp Y) , ext-glue , susp-fmap (fst f))
cofiber-sequence {X} {Y} f =
    ap (λ {(Z , g) → ((⊙Cof² f , Z) , cfcod² f , g)})
       (pair= (Cof².space-path (⊙cfcod' f)) (Cof².cfcod²-over (⊙cfcod' f)))
  ∙ ap (λ {(Z , g , h) → ((Z , ⊙Susp Y) , g , h)})
       (pair= (Cof².space-path f)
         (↓-×-in (Cof².cfcod²-over f) (Cof².cfcod³-over f)))
  ∙ ap (λ {(Z , g) → ((⊙Susp X , Z) , ext-glue , g)})
       (pair= (flip-⊙pushout-path (suspension-⊙span Y))
              (↓-cst2-in _ _ $ codomain!-over-equiv _ _))


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

module Evaluator where

open import Agda.Prim
open import Data.Unit
open import Data.Nat hiding (_⊔_)
open import Data.Sum
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality

open import Paths

------------------------------------------------------------------------------
-- For the usual situation, we can only establish one direction of univalence

swap₊ : {ℓ : Level} {A B : Set ℓ} → A ⊎ B → B ⊎ A
swap₊ (inj₁ a) = inj₂ a
swap₊ (inj₂ b) = inj₁ b

assocl₊ : {ℓ : Level} {A B C : Set ℓ} → A ⊎ (B ⊎ C) → (A ⊎ B) ⊎ C
assocl₊ (inj₁ a) = inj₁ (inj₁ a)
assocl₊ (inj₂ (inj₁ b)) = inj₁ (inj₂ b)
assocl₊ (inj₂ (inj₂ c)) = inj₂ c

assocr₊ : {ℓ : Level} {A B C : Set ℓ} → (A ⊎ B) ⊎ C → A ⊎ (B ⊎ C)
assocr₊ (inj₁ (inj₁ a)) = inj₁ a
assocr₊ (inj₁ (inj₂ b)) = inj₂ (inj₁ b)
assocr₊ (inj₂ c) = inj₂ (inj₂ c)

unite⋆ : {ℓ : Level} {A : Set ℓ} → ⊤ × A → A
unite⋆ (tt , a) = a

uniti⋆ : {ℓ : Level} {A : Set ℓ} → A → ⊤ × A
uniti⋆ a = (tt , a)

swap⋆ : {ℓ : Level} {A B : Set ℓ} → A × B → B × A
swap⋆ (a , b) = (b , a)

assocl⋆ : {ℓ : Level} {A B C : Set ℓ} → A × (B × C) → (A × B) × C
assocl⋆ (a , (b , c)) = ((a , b) , c)

assocr⋆ : {ℓ : Level} {A B C : Set ℓ} → (A × B) × C → A × (B × C)
assocr⋆ ((a , b) , c) = (a , (b , c))

dist : {ℓ : Level} {A B C : Set ℓ} → (A ⊎ B) × C → (A × C ⊎ B × C)
dist (inj₁ a , c) = inj₁ (a , c)
dist (inj₂ b , c) = inj₂ (b , c)

fact : {ℓ : Level} {A B C : Set ℓ} → (A × C ⊎ B × C) → (A ⊎ B) × C
fact (inj₁ (a , c)) = (inj₁ a , c)
fact (inj₂ (b , c)) = (inj₂ b , c)

eval : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} → Path a b → (A → B)
eval swap₁₊⇛              = swap₊
eval swap₂₊⇛              = swap₊
eval assocl₁₊⇛            = assocl₊
eval assocl₁₊⇛'           = assocl₊
{-- eval (assocl₂₁₊⇛ _)        = assocl₊
eval (assocl₂₂₊⇛ _)        = assocl₊
eval (assocr₁₁₊⇛ _)        = assocr₊
eval (assocr₁₂₊⇛ _)        = assocr₊
eval (assocr₂₊⇛ _)         = assocr₊
eval (unite⋆⇛ _)           = unite⋆
eval (uniti⋆⇛ _)           = uniti⋆
eval (swap⋆⇛ _ _)          = swap⋆
eval (assocl⋆⇛ _ _ _)      = assocl⋆
eval (assocr⋆⇛ _ _ _)      = assocr⋆
eval (dist₁⇛ _ _)          = dist
eval (dist₂⇛ _ _)          = dist
eval (factor₁⇛ _ _)        = fact
eval (factor₂⇛ _ _)        = fact
eval (id⇛ _)               = id
eval (trans⇛ c d)          = eval d ∘ eval c
eval (plus₁⇛ c d)          = Data.Sum.map (eval c) (eval d)
eval (plus₂⇛ c d)          = Data.Sum.map (eval c) (eval d)
eval (times⇛ c d)          = Data.Product.map (eval c) (eval d)
--}
-- Inverses

evalB : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} → Path a b → (B → A)
evalB swap₂₊⇛              = swap₊
evalB swap₁₊⇛          = swap₊
evalB assocl₁₊⇛        = assocr₊
evalB assocl₁₊⇛'        = assocr₊
{-- evalB (assocr₂₊⇛ _)        = assocl₊
evalB (assocr₁₂₊⇛ _)       = assocl₊
evalB (assocr₁₁₊⇛ _)       = assocl₊
evalB (assocl₂₂₊⇛ _)       = assocr₊
evalB (assocl₂₁₊⇛ _)       = assocr₊
evalB (uniti⋆⇛ _)          = unite⋆
evalB (unite⋆⇛ _)          = uniti⋆
evalB (swap⋆⇛ _ _)         = swap⋆
evalB (assocr⋆⇛ _ _ _)     = assocl⋆
evalB (assocl⋆⇛ _ _ _)     = assocr⋆
evalB (dist₁⇛ _ _)         = fact
evalB (dist₂⇛ _ _)         = fact
evalB (factor₁⇛ _ _)       = dist
evalB (factor₂⇛ _ _)       = dist
evalB (id⇛ _)              = id
evalB (trans⇛ c d)         = evalB c ∘ evalB d
evalB (plus₁⇛ c d)         = Data.Sum.map (evalB c) (evalB d)
evalB (plus₂⇛ c d)         = Data.Sum.map (evalB c) (evalB d)
evalB (times⇛ c d)         = Data.Product.map (evalB c) (evalB d)
--}

------------------------------------------------------------------------------
-- Proving univalence•

eval-resp-• : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} →
              (c : Path a b) → eval c a ≡ b
eval-resp-• swap₁₊⇛ = refl
eval-resp-• swap₂₊⇛ = refl
eval-resp-• assocl₁₊⇛ = refl
eval-resp-• assocl₁₊⇛' = refl
{-- eval-resp-• (assocl₂₁₊⇛ b) = refl
eval-resp-• (assocl₂₂₊⇛ c) = refl
eval-resp-• (assocr₁₁₊⇛ a) = refl
eval-resp-• (assocr₁₂₊⇛ b) = refl
eval-resp-• (assocr₂₊⇛ c) = refl
eval-resp-• {b = b} (unite⋆⇛ .b) = refl
eval-resp-• {a = a} (uniti⋆⇛ .a) = refl
eval-resp-• (swap⋆⇛ a b) = refl
eval-resp-• (assocl⋆⇛ a b c) = refl
eval-resp-• (assocr⋆⇛ a b c) = refl
eval-resp-• (dist₁⇛ a c) = refl
eval-resp-• (dist₂⇛ b c) = refl
eval-resp-• (factor₁⇛ a c) = refl
eval-resp-• (factor₂⇛ b c) = refl
eval-resp-• {a = a} (id⇛ .a) = refl
eval-resp-• {a = a} (trans⇛ c d) rewrite eval-resp-• c | eval-resp-• d = refl
eval-resp-• (plus₁⇛ c d) rewrite eval-resp-• c = refl
eval-resp-• (plus₂⇛ c d) rewrite eval-resp-• d = refl
eval-resp-• (times⇛ c d) rewrite eval-resp-• c | eval-resp-• d = refl
--}
evalB-resp-• : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} →
              (c : Path a b) → evalB c b ≡ a
evalB-resp-• swap₁₊⇛ = refl
evalB-resp-• swap₂₊⇛ = refl
evalB-resp-• assocl₁₊⇛ = refl
evalB-resp-• assocl₁₊⇛' = refl
{-- evalB-resp-• (assocl₂₁₊⇛ b) = refl
evalB-resp-• (assocl₂₂₊⇛ c) = refl
evalB-resp-• (assocr₁₁₊⇛ a) = refl
evalB-resp-• (assocr₁₂₊⇛ b) = refl
evalB-resp-• (assocr₂₊⇛ c) = refl
evalB-resp-• {b = b} (unite⋆⇛ .b) = refl
evalB-resp-• {a = a} (uniti⋆⇛ .a) = refl
evalB-resp-• (swap⋆⇛ a b) = refl
evalB-resp-• (assocl⋆⇛ a b c) = refl
evalB-resp-• (assocr⋆⇛ a b c) = refl
evalB-resp-• (dist₁⇛ a c) = refl
evalB-resp-• (dist₂⇛ b c) = refl
evalB-resp-• (factor₁⇛ a c) = refl
evalB-resp-• (factor₂⇛ b c) = refl
evalB-resp-• {a = a} (id⇛ .a) = refl
evalB-resp-• {a = a} (trans⇛ c d) rewrite evalB-resp-• d | evalB-resp-• c = refl
evalB-resp-• (plus₁⇛ c d) rewrite evalB-resp-• c = refl
evalB-resp-• (plus₂⇛ c d) rewrite evalB-resp-• d = refl
evalB-resp-• (times⇛ c d) rewrite evalB-resp-• c | evalB-resp-• d = refl
--}
-- the proof that eval ∙ evalB x ≡ x will be useful below
eval∘evalB≡id :  {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} →
  (c : Path a b) → evalB c (eval c a) ≡ a
eval∘evalB≡id c rewrite eval-resp-• c | evalB-resp-• c = refl

{--
-- if this is useful, move it elsewhere
-- but it might not be, as it appears to be 'level raising'
cong⇚ : {ℓ : Level} {A B : Set ℓ} {a₁ a₂ : A}
       (f : Path a₁ a₂ ) → (x : A) → Path (evalB f x) (evalB f x)
cong⇚ f x = id⇛ (evalB f x)
--}

{--
eval∘evalB :  {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} →
  (c : Path a b) → (x : A) → Path (evalB c (eval c x)) x
eval∘evalB (swap₁₊⇛ a) (inj₁ x) = id⇛ (inj₁ x)
eval∘evalB (swap₁₊⇛ a) (inj₂ y) = id⇛ (inj₂ y)
eval∘evalB (swap₂₊⇛ b) (inj₁ x) = id⇛ (inj₁ x)
eval∘evalB (swap₂₊⇛ b) (inj₂ y) = id⇛ (inj₂ y)
eval∘evalB (assocl₁₊⇛ a) (inj₁ x) = id⇛ (inj₁ x)
eval∘evalB (assocl₁₊⇛ a) (inj₂ (inj₁ x)) = id⇛ (inj₂ (inj₁ x))
eval∘evalB (assocl₁₊⇛ a) (inj₂ (inj₂ y)) = id⇛ (inj₂ (inj₂ y))
eval∘evalB (assocl₂₁₊⇛ b) (inj₁ x) = id⇛ (inj₁ x)
eval∘evalB (assocl₂₁₊⇛ b) (inj₂ (inj₁ x)) = id⇛ (inj₂ (inj₁ x))
eval∘evalB (assocl₂₁₊⇛ b) (inj₂ (inj₂ y)) = id⇛ (inj₂ (inj₂ y))
eval∘evalB (assocl₂₂₊⇛ c) (inj₁ x) = id⇛ (inj₁ x)
eval∘evalB (assocl₂₂₊⇛ c) (inj₂ (inj₁ x)) = id⇛ (inj₂ (inj₁ x))
eval∘evalB (assocl₂₂₊⇛ c) (inj₂ (inj₂ y)) = id⇛ (inj₂ (inj₂ y))
eval∘evalB (assocr₁₁₊⇛ a) (inj₁ (inj₁ x)) = id⇛ (inj₁ (inj₁ x))
eval∘evalB (assocr₁₁₊⇛ a) (inj₁ (inj₂ y)) = id⇛ (inj₁ (inj₂ y))
eval∘evalB (assocr₁₁₊⇛ a) (inj₂ y) = id⇛ (inj₂ y)
eval∘evalB (assocr₁₂₊⇛ b) (inj₁ (inj₁ x)) = id⇛ (inj₁ (inj₁ x))
eval∘evalB (assocr₁₂₊⇛ b) (inj₁ (inj₂ y)) = id⇛ (inj₁ (inj₂ y))
eval∘evalB (assocr₁₂₊⇛ b) (inj₂ y) = id⇛ (inj₂ y)
eval∘evalB (assocr₂₊⇛ c) (inj₁ (inj₁ x)) = id⇛ (inj₁ (inj₁ x))
eval∘evalB (assocr₂₊⇛ c) (inj₁ (inj₂ y)) = id⇛ (inj₁ (inj₂ y))
eval∘evalB (assocr₂₊⇛ c) (inj₂ y) = id⇛ (inj₂ y)
eval∘evalB {b = b} (unite⋆⇛ .b) (tt , x) = id⇛ (tt , x)
eval∘evalB {a = a} (uniti⋆⇛ .a) x = id⇛ x
eval∘evalB (swap⋆⇛ a b) (x , y) = id⇛ (x , y)
eval∘evalB (assocl⋆⇛ a b c) (x , y , z) = id⇛ (x , y , z)
eval∘evalB (assocr⋆⇛ a b c) ((x , y) , z) = id⇛ ((x , y) , z)
eval∘evalB (dist₁⇛ a c) (inj₁ x , y) = id⇛ (inj₁ x , y)
eval∘evalB (dist₁⇛ a c) (inj₂ y , z) = id⇛ (inj₂ y , z)
eval∘evalB (dist₂⇛ b c) (inj₁ x , z) = id⇛ (inj₁ x , z)
eval∘evalB (dist₂⇛ b c) (inj₂ y , z) = id⇛ (inj₂ y , z)
eval∘evalB (factor₁⇛ a c) (inj₁ (x , y)) = id⇛ (inj₁ (x , y))
eval∘evalB (factor₁⇛ a c) (inj₂ (x , y)) = id⇛ (inj₂ (x , y))
eval∘evalB (factor₂⇛ b c) (inj₁ (x , y)) = id⇛ (inj₁ (x , y))
eval∘evalB (factor₂⇛ b c) (inj₂ (x , y)) = id⇛ (inj₂ (x , y))
eval∘evalB {a = a} (id⇛ .a) x = id⇛ x
eval∘evalB (trans⇛ {A = A} {B} {C} {a} {b} {c} c₁ c₂) x = trans⇛ {!cong⇚ ? (id⇛ (eval c₁ x))!} (eval∘evalB c₁ x)
eval∘evalB (plus₁⇛ {b = b} c₁ c₂) (inj₁ x) = plus₁⇛ (eval∘evalB c₁ x) (id⇛ b)
eval∘evalB (plus₁⇛ {a = a} c₁ c₂) (inj₂ y) = plus₂⇛ (id⇛ a) (eval∘evalB c₂ y)
eval∘evalB (plus₂⇛ {b = b} c₁ c₂) (inj₁ x) = plus₁⇛ (eval∘evalB c₁ x) (id⇛ b)
eval∘evalB (plus₂⇛ {a = a} c₁ c₂) (inj₂ y) = plus₂⇛ (id⇛ a) (eval∘evalB c₂ y)
eval∘evalB (times⇛ c₁ c₂) (x , y) = times⇛ (eval∘evalB c₁ x) (eval∘evalB c₂ y)
--}

{--
eval-gives-id⇛ : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} →
  (c : Path a b) → Path (eval c a) b
eval-gives-id⇛ {b = b} c rewrite eval-resp-• c = id⇛ b
--}


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

open import Cubical.Core.Everything

module Cubical.Algebra.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Relation.Binary.Base using (Rel)
open import Cubical.Relation.Binary.Definitions

open import Cubical.Algebra.Base
open import Cubical.Algebra.Definitions
open import Cubical.Data.Sum.Base using (inl; inr)
open import Cubical.Data.Sigma using (_,_)
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Relation.Binary.Reasoning.Equality

private
  variable
    ℓ : Level
    A : Type ℓ

----------------------------------------------------------------------
-- Operation properties are propositions

private
  isPropImpΠ2 : ∀ {ℓ′ ℓ′′} {B : A → Type ℓ′} {C : ∀ x → B x → Type ℓ′′} →
                  (∀ x y → isProp (C x y)) → isProp (∀ {x y} → C x y)
  isPropImpΠ2 isPropC f g i {x} {y} = isPropC x y (f {x} {y}) (g {x} {y}) i

module _ (isSetA : isSet A) where

  isPropAssociative : (_•_ : Op₂ A) → isProp (Associative _•_)
  isPropAssociative _ = isPropΠ3 λ _ _ _ → isSetA _ _

  isPropCommutative : (_•_ : Op₂ A) → isProp (Commutative _•_)
  isPropCommutative _ = isPropΠ2 λ _ _ → isSetA _ _

  isPropLeftIdentity : (_•_ : Op₂ A) (e : A) → isProp (LeftIdentity e _•_)
  isPropLeftIdentity _ _ = isPropΠ λ _ → isSetA _ _

  isPropRightIdentity : (_•_ : Op₂ A) (e : A) → isProp (RightIdentity e _•_)
  isPropRightIdentity _ _ = isPropΠ λ _ → isSetA _ _

  isPropIdentity : (_•_ : Op₂ A) (e : A) → isProp (Identity e _•_)
  isPropIdentity _•_ e = isProp× (isPropLeftIdentity _•_ e) (isPropRightIdentity _•_ e)

  isPropLeftZero : (_•_ : Op₂ A) (z : A) → isProp (LeftZero z _•_)
  isPropLeftZero _ _ = isPropΠ λ _ → isSetA _ _

  isPropRightZero : (_•_ : Op₂ A) (z : A) → isProp (RightZero z _•_)
  isPropRightZero _ _ = isPropΠ λ _ → isSetA _ _

  isPropZero : (_•_ : Op₂ A) (z : A) → isProp (Zero z _•_)
  isPropZero _•_ z = isProp× (isPropLeftZero _•_ z) (isPropRightZero _•_ z)

  isPropLeftInverse : (_•_ : Op₂ A) (_⁻¹ : Op₁ A) (e : A) → isProp (LeftInverse e _⁻¹ _•_)
  isPropLeftInverse _ _ _ = isPropΠ λ _ → isSetA _ _

  isPropRightInverse : (_•_ : Op₂ A) (_⁻¹ : Op₁ A) (e : A) → isProp (RightInverse e _⁻¹ _•_)
  isPropRightInverse _ _ _ = isPropΠ λ _ → isSetA _ _

  isPropInverse : (_•_ : Op₂ A) (_⁻¹ : Op₁ A) (e : A) → isProp (Inverse e _⁻¹ _•_)
  isPropInverse _•_ _⁻¹ e = isProp× (isPropLeftInverse _•_ _⁻¹ e) (isPropRightInverse _•_ _⁻¹ e)

  isPropLeftConical : (_•_ : Op₂ A) (e : A) → isProp (LeftConical e _•_)
  isPropLeftConical _ _ = isPropΠ3 λ _ _ _ → isSetA _ _

  isPropRightConical : (_•_ : Op₂ A) (e : A) → isProp (RightConical e _•_)
  isPropRightConical _ _ = isPropΠ3 λ _ _ _ → isSetA _ _

  isPropConical : (_•_ : Op₂ A) (e : A) → isProp (Conical e _•_)
  isPropConical _•_ e = isProp× (isPropLeftConical _•_ e) (isPropRightConical _•_ e)

  isPropDistrˡ : (_*_ _+_ : Op₂ A) → isProp (_*_ DistributesOverˡ _+_)
  isPropDistrˡ _ _ = isPropΠ3 λ _ _ _ → isSetA _ _

  isPropDistrʳ : (_*_ _+_ : Op₂ A) → isProp (_*_ DistributesOverʳ _+_)
  isPropDistrʳ _ _ = isPropΠ3 λ _ _ _ → isSetA _ _

  isPropDistr : (_*_ _+_ : Op₂ A) → isProp (_*_ DistributesOver _+_)
  isPropDistr _*_ _+_ = isProp× (isPropDistrˡ _*_ _+_) (isPropDistrʳ _*_ _+_)

  isPropIdempotentOn : (_•_ : Op₂ A) (x : A) → isProp (_•_ IdempotentOn x)
  isPropIdempotentOn _ _ = isSetA _ _

  isPropIdempotent : (_•_ : Op₂ A) → isProp (Idempotent _•_)
  isPropIdempotent _•_ = isPropΠ λ x → isPropIdempotentOn _•_ x

  isPropIdempotentFun : (f : Op₁ A) → isProp (IdempotentFun f)
  isPropIdempotentFun _ = isPropΠ λ _ → isSetA _ _

  isPropSelective : (_•_ : Op₂ A) → isProp (Selective _•_)
  isPropSelective _ = isPropΠ2 λ _ _ → squash

  isPropAbsorbs : (_⋀_ _⋁_ : Op₂ A) → isProp (_⋀_ Absorbs _⋁_)
  isPropAbsorbs _ _ = isPropΠ2 λ _ _ → isSetA _ _

  isPropAbsorptive : (_⋀_ _⋁_ : Op₂ A) → isProp (Absorptive _⋀_ _⋁_)
  isPropAbsorptive _⋀_ _⋁_ = isProp× (isPropAbsorbs _⋀_ _⋁_) (isPropAbsorbs _⋁_ _⋀_)

  isPropInvolutive : (f : Op₁ A) → isProp (Involutive f)
  isPropInvolutive _ = isPropΠ λ _ → isSetA _ _

  isPropLeftCancel : (_•_ : Op₂ A) → isProp (LeftCancellative _•_)
  isPropLeftCancel _ = isPropΠ λ _ → isPropImpΠ2 λ _ _ → isPropΠ λ _ → isSetA _ _

  isPropRightCancel : (_•_ : Op₂ A) → isProp (RightCancellative _•_)
  isPropRightCancel _ = isPropImpΠ2 λ _ _ → isPropΠ2 λ _ _ → isSetA _ _

  isPropCancellative : (_•_ : Op₂ A) → isProp (Cancellative _•_)
  isPropCancellative _•_ = isProp× (isPropLeftCancel _•_) (isPropRightCancel _•_)

  isPropInterchangeable : (_•_ _◦_ : Op₂ A) → isProp (Interchangeable _•_ _◦_)
  isPropInterchangeable _ _ = isPropΠ2 λ _ _ → isPropΠ2 λ _ _ → isSetA _ _

  sel⇒idem : {_•_ : Op₂ A} → Selective _•_ → Idempotent _•_
  sel⇒idem {_•_ = _•_} sel x = rec (isPropIdempotentOn _•_ x)
    (λ { (inl p) → p
       ; (inr p) → p
      })
    (sel x x)

module _ {ℓ′} {B : Type ℓ′} (isSetB : isSet B) where

  isPropHomomorphic₀ : (f : A → B) (x : A) (y : B) → isProp (Homomorphic₀ f x y)
  isPropHomomorphic₀ _ _ _ = isSetB _ _

  isPropHomomorphic₁ : (f : A → B) (g : Op₁ A) (h : Op₁ B) → isProp (Homomorphic₁ f g h)
  isPropHomomorphic₁ _ _ _ = isPropΠ λ _ → isSetB _ _

  isPropHomomorphic₂ : (f : A → B) (• : Op₂ A) (◦ : Op₂ B) → isProp (Homomorphic₂ f • ◦)
  isPropHomomorphic₂ _ _ _ = isPropΠ2 λ _ _ → isSetB _ _

id-unique′ : ∀ {_•_ : Op₂ A} {e i} → LeftIdentity e _•_ → RightIdentity i _•_ → e ≡ i
id-unique′ {_} {_} {_•_} {e} {i} idˡ idʳ =
  e     ≡˘⟨ idʳ e ⟩
  e • i ≡⟨ idˡ i ⟩
  i     ∎

id-unique : ∀ {_•_ : Op₂ A} {e i} → Identity e _•_ → Identity i _•_ → e ≡ i
id-unique (idˡ , _) (_ , idʳ) = id-unique′ idˡ idʳ

id-collapseʳ : ∀ {_•_ : Op₂ A} {e i} → LeftIdentity e _•_ → RightIdentity i _•_ → Identity e _•_
id-collapseʳ {_} {_} {_•_} idˡ idʳ = idˡ , subst (λ e → RightIdentity e _•_) (sym (id-unique′ idˡ idʳ)) idʳ

id-collapseˡ : ∀ {_•_ : Op₂ A} {e i} → LeftIdentity e _•_ → RightIdentity i _•_ → Identity i _•_
id-collapseˡ {_} {_} {_•_} idˡ idʳ = subst (λ e → LeftIdentity e _•_) (id-unique′ idˡ idʳ) idˡ , idʳ

------------------------------------------------------------------------
-- Magma-like Algebra

module _ {_•_ : Op₂ A} (comm : Commutative _•_) where

  comm+cancelˡ⇒cancelʳ : LeftCancellative _•_ → RightCancellative _•_
  comm+cancelˡ⇒cancelʳ cancelˡ {x = x} {y} z eq = cancelˡ z (
    z • x ≡⟨ comm z x ⟩
    x • z ≡⟨ eq ⟩
    y • z ≡⟨ comm y z ⟩
    z • y ∎)

  comm+cancelʳ⇒cancelˡ : RightCancellative _•_ → LeftCancellative _•_
  comm+cancelʳ⇒cancelˡ cancelʳ x {y} {z} eq = cancelʳ x (
    y • x ≡⟨ comm y x ⟩
    x • y ≡⟨ eq ⟩
    x • z ≡⟨ comm x z ⟩
    z • x ∎)

------------------------------------------------------------------------
-- Monoid-like Algebra

module _ {_•_ : Op₂ A} (comm : Commutative _•_) {e : A} where

  comm+idˡ⇒idʳ : LeftIdentity e _•_ → RightIdentity e _•_
  comm+idˡ⇒idʳ idˡ x =
    x • e ≡⟨ comm x e ⟩
    e • x ≡⟨ idˡ x ⟩
    x     ∎

  comm+idʳ⇒idˡ : RightIdentity e _•_ → LeftIdentity e _•_
  comm+idʳ⇒idˡ idʳ x =
    e • x ≡⟨ comm e x ⟩
    x • e ≡⟨ idʳ x ⟩
    x     ∎

  comm+zeˡ⇒zeʳ : LeftZero e _•_ → RightZero e _•_
  comm+zeˡ⇒zeʳ zeˡ x =
    x • e ≡⟨ comm x e ⟩
    e • x ≡⟨ zeˡ x ⟩
    e     ∎

  comm+zeʳ⇒zeˡ : RightZero e _•_ → LeftZero e _•_
  comm+zeʳ⇒zeˡ zeʳ x =
    e • x ≡⟨ comm e x ⟩
    x • e ≡⟨ zeʳ x ⟩
    e     ∎

------------------------------------------------------------------------
-- Group-like Algebra

module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} (comm : Commutative _•_) where

  comm+invˡ⇒invʳ : LeftInverse e _⁻¹ _•_ → RightInverse e _⁻¹ _•_
  comm+invˡ⇒invʳ invˡ x =
    x • (x ⁻¹) ≡⟨ comm x (x ⁻¹) ⟩
    (x ⁻¹) • x ≡⟨ invˡ x ⟩
    e          ∎

  comm+invʳ⇒invˡ : RightInverse e _⁻¹ _•_ → LeftInverse e _⁻¹ _•_
  comm+invʳ⇒invˡ invʳ x =
    (x ⁻¹) • x ≡⟨ comm (x ⁻¹) x ⟩
    x • (x ⁻¹) ≡⟨ invʳ x ⟩
    e          ∎

module _ {_•_ : Op₂ A} {_⁻¹ : Op₁ A} {e} where

  assoc+id+invʳ⇒invʳ-unique : Associative _•_ →
                              Identity e _•_ → RightInverse e _⁻¹ _•_ →
                              ∀ x y → (x • y) ≡ e → x ≡ (y ⁻¹)
  assoc+id+invʳ⇒invʳ-unique assoc (idˡ , idʳ) invʳ x y eq =
    x                ≡⟨ sym (idʳ x) ⟩
    x • e            ≡˘⟨ cong (x •_) (invʳ y) ⟩
    x • (y • (y ⁻¹)) ≡˘⟨ assoc x y (y ⁻¹) ⟩
    (x • y) • (y ⁻¹) ≡⟨ cong (_• (y ⁻¹)) eq ⟩
    e • (y ⁻¹)       ≡⟨ idˡ (y ⁻¹) ⟩
    y ⁻¹             ∎

  assoc+id+invˡ⇒invˡ-unique : Associative _•_ →
                              Identity e _•_ → LeftInverse e _⁻¹ _•_ →
                              ∀ x y → (x • y) ≡ e → y ≡ (x ⁻¹)
  assoc+id+invˡ⇒invˡ-unique assoc (idˡ , idʳ) invˡ x y eq =
    y                ≡˘⟨ idˡ y ⟩
    e • y            ≡˘⟨ cong (_• y) (invˡ x) ⟩
    ((x ⁻¹) • x) • y ≡⟨ assoc (x ⁻¹) x y ⟩
    (x ⁻¹) • (x • y) ≡⟨ cong ((x ⁻¹) •_) eq ⟩
    (x ⁻¹) • e       ≡⟨ idʳ (x ⁻¹) ⟩
    x ⁻¹             ∎

  assoc+idˡ+invˡ⇒cancelˡ : Associative _•_ →
                          LeftIdentity e _•_ → LeftInverse e _⁻¹ _•_ →
                          LeftCancellative _•_
  assoc+idˡ+invˡ⇒cancelˡ assoc idˡ invˡ x {y} {z} eq =
    y                ≡˘⟨ idˡ y ⟩
    e • y            ≡˘⟨ cong (_• y) (invˡ x) ⟩
    ((x ⁻¹) • x) • y ≡⟨ assoc (x ⁻¹) x y ⟩
    (x ⁻¹) • (x • y) ≡⟨ cong ((x ⁻¹) •_) eq ⟩
    (x ⁻¹) • (x • z) ≡˘⟨ assoc (x ⁻¹) x z ⟩
    ((x ⁻¹) • x) • z ≡⟨ cong (_• z) (invˡ x) ⟩
    e • z            ≡⟨ idˡ z ⟩
    z                ∎

  assoc+idʳ+invʳ⇒cancelʳ : Associative _•_ →
                          RightIdentity e _•_ → RightInverse e _⁻¹ _•_ →
                          RightCancellative _•_
  assoc+idʳ+invʳ⇒cancelʳ assoc idʳ invʳ {x} {y} z eq =
    x                ≡˘⟨ idʳ x ⟩
    x • e            ≡˘⟨ cong (x •_) (invʳ z) ⟩
    x • (z • (z ⁻¹)) ≡˘⟨ assoc x z (z ⁻¹) ⟩
    (x • z) • (z ⁻¹) ≡⟨ cong (_• (z ⁻¹)) eq ⟩
    (y • z) • (z ⁻¹) ≡⟨ assoc y z (z ⁻¹) ⟩
    y • (z • (z ⁻¹)) ≡⟨ cong (y •_) (invʳ z) ⟩
    y • e            ≡⟨ idʳ y ⟩
    y                ∎

----------------------------------------------------------------------
-- Bisemigroup-like Algebra

module _ {_*_ _+_ : Op₂ A} (*-comm : Commutative _*_) where

  comm+distrˡ⇒distrʳ :  _*_ DistributesOverˡ _+_ → _*_ DistributesOverʳ _+_
  comm+distrˡ⇒distrʳ distrˡ x y z =
    (y + z) * x       ≡⟨ *-comm (y + z) x ⟩
    x * (y + z)       ≡⟨ distrˡ x y z ⟩
    (x * y) + (x * z) ≡⟨ cong₂ _+_ (*-comm x y) (*-comm x z) ⟩
    (y * x) + (z * x) ∎

  comm+distrʳ⇒distrˡ : _*_ DistributesOverʳ _+_ → _*_ DistributesOverˡ _+_
  comm+distrʳ⇒distrˡ distrʳ x y z =
    x * (y + z)       ≡⟨ *-comm x (y + z) ⟩
    (y + z) * x       ≡⟨ distrʳ x y z ⟩
    (y * x) + (z * x) ≡⟨ cong₂ _+_ (*-comm y x) (*-comm z x) ⟩
    (x * y) + (x * z) ∎

----------------------------------------------------------------------
-- Ring-like Algebra

module _ {_+_ _*_ : Op₂ A} { -_ : Op₁ A} {0# : A} where

  assoc+distribʳ+idʳ+invʳ⇒zeˡ : Associative _+_ → _*_ DistributesOverʳ _+_ →
                                RightIdentity 0# _+_ → RightInverse 0# -_ _+_ →
                                LeftZero 0# _*_
  assoc+distribʳ+idʳ+invʳ⇒zeˡ +-assoc distribʳ idʳ invʳ x =
    0# * x                              ≡⟨ sym (idʳ _) ⟩
    (0# * x) + 0#                       ≡˘⟨ cong ((0# * x) +_) (invʳ _) ⟩
    (0# * x) + ((0# * x) + (-(0# * x))) ≡˘⟨ +-assoc _ _ _ ⟩
    ((0# * x) + (0# * x)) + (-(0# * x)) ≡˘⟨ cong (_+ (-(0# * x))) (distribʳ _ _ _) ⟩
    ((0# + 0#) * x) + (-(0# * x))       ≡⟨ cong (λ v → (v * x) + (-(0# * x))) (idʳ 0#) ⟩
    (0# * x) + (-(0# * x))              ≡⟨ invʳ _ ⟩
    0#                                  ∎

  assoc+distribˡ+idʳ+invʳ⇒zeʳ : Associative _+_ → _*_ DistributesOverˡ _+_ →
                                RightIdentity 0# _+_ → RightInverse 0# -_ _+_ →
                                RightZero 0# _*_
  assoc+distribˡ+idʳ+invʳ⇒zeʳ +-assoc distribˡ idʳ invʳ x =
     x * 0#                              ≡⟨ sym (idʳ _) ⟩
     (x * 0#) + 0#                       ≡˘⟨ cong ((x * 0#) +_) (invʳ _) ⟩
     (x * 0#) + ((x * 0#) + (-(x * 0#))) ≡˘⟨ +-assoc _ _ _ ⟩
     ((x * 0#) + (x * 0#)) + (-(x * 0#)) ≡˘⟨ cong (_+ (-(x * 0#))) (distribˡ _ _ _) ⟩
     (x * (0# + 0#)) + (-(x * 0#))       ≡⟨ cong (λ v → (x * v) + (-(x * 0#))) (idʳ 0#) ⟩
     (x * 0#) + (-(x * 0#))              ≡⟨ invʳ _ ⟩
     0#                                  ∎

----------------------------------------------------------------------
-- Other

module _ {c ℓ} {A : Type c} (R : Rel A ℓ) (reflexive : Reflexive R) (• : Op₂ A) where

  cong₂⇒lcong : Congruent₂ R • → LeftCongruent R •
  cong₂⇒lcong cong₂ {x} {y} {z} yRz = cong₂ reflexive yRz

  cong₂⇒rcong : Congruent₂ R • → RightCongruent R •
  cong₂⇒rcong cong₂ {x} {y} {z} yRz = cong₂ yRz reflexive

module _ {c ℓ} {A : Type c} (R : Rel A ℓ) (transitive : Transitive R) (• : Op₂ A) where

  lcong+rcong⇒cong₂ : LeftCongruent R • → RightCongruent R • → Congruent₂ R •
  lcong+rcong⇒cong₂ lcong rcong xRy uRv = transitive (lcong uRv) (rcong xRy)


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

open import Sets.Cardinality.Infinite.Definition
open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Groups.FreeGroup.Definition
open import Groups.Homomorphisms.Definition
open import Groups.Definition
open import Decidable.Sets
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import LogicalFormulae
open import Semirings.Definition
open import Functions.Definition
open import Functions.Lemmas
open import Groups.Isomorphisms.Definition
open import Groups.FreeGroup.Word
open import Groups.FreeGroup.Group
open import Groups.FreeGroup.UniversalProperty
open import Groups.Abelian.Definition
open import Groups.QuotientGroup.Definition
open import Groups.Lemmas
open import Groups.Homomorphisms.Lemmas

module Groups.FreeGroup.Lemmas {a : _} {A : Set a} (decA : DecidableSet A) where

freeGroupNonAbelian : AbelianGroup (freeGroup decA) → (a : A) → Sg (A → True) Bijection
freeGroupNonAbelian record { commutative = commutative } a = (λ _ → record {}) , b
  where
    b : Bijection (λ _ → record {})
    Bijection.inj b {x} {y} _ with decA x y
    ... | inl pr = pr
    ... | inr neq = exFalso (neq (ofLetterInjective (prependLetterInjective' decA t)))
      where
        t : prependLetter {decA = decA} (ofLetter x) (prependLetter (ofLetter y) empty (wordEmpty refl)) (wordEnding (succIsPositive 0) refl) ≡ prependLetter (ofLetter y) (prependLetter (ofLetter x) empty (wordEmpty refl)) (wordEnding (succIsPositive 0) refl)
        t = commutative {prependLetter (ofLetter x) empty (wordEmpty refl)} {prependLetter (ofLetter y) empty (wordEmpty refl)}
    Bijection.surj b record {} = a , refl

private
  iso : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → Bijection f → ReducedWord decA → ReducedWord decB
  iso decB {f} bij = universalPropertyFunction decA (freeGroup decB) λ a → freeEmbedding decB (f a)

  isoHom : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → GroupHom (freeGroup decA) (freeGroup decB) (iso decB bij)
  isoHom decB {f} bij = universalPropertyHom decA (freeGroup decB) λ a → iso decB bij (freeEmbedding decA a)

  iso2 : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → Bijection f → ReducedWord decB → ReducedWord decA
  iso2 decB {f} bij = universalPropertyFunction decB (freeGroup decA) λ b → freeEmbedding decA (Invertible.inverse (bijectionImpliesInvertible bij) b)

  iso2Hom : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → GroupHom (freeGroup decB) (freeGroup decA) (iso2 decB bij)
  iso2Hom decB {f} bij = universalPropertyHom decB (freeGroup decA) λ b → iso2 decB bij (freeEmbedding decB b)

  fixesF : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : A) → iso2 decB bij (iso decB bij (freeEmbedding decA x)) ≡ freeEmbedding decA x
  fixesF decB {f} bij x with Bijection.surj bij (f x)
  ... | _ , pr rewrite Bijection.inj bij pr = refl

  fixesF' : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : B) → iso decB bij (iso2 decB bij (freeEmbedding decB x)) ≡ freeEmbedding decB x
  fixesF' decB {f} bij x with Bijection.surj bij x
  ... | _ , pr rewrite pr = refl

  uniq : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decA) → x ≡ universalPropertyFunction decA (freeGroup decA) (λ x → iso2 decB bij (iso decB bij (freeEmbedding decA x))) x
  uniq decB {f} bij x = universalPropertyUniqueness decA (freeGroup decA) (λ x → iso2 decB bij (iso decB bij (freeEmbedding decA x))) {id} (record { wellDefined = id ; groupHom = refl }) (fixesF decB bij) x
  uniqLemm : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decA) → iso2 decB bij (iso decB bij x) ≡ universalPropertyFunction decA (freeGroup decA) (λ x → iso2 decB bij (iso decB bij (freeEmbedding decA x))) x
  uniqLemm decB {f} bij x = universalPropertyUniqueness decA (freeGroup decA) (λ i → freeEmbedding decA (underlying (Bijection.surj bij (f i)))) {λ i → iso2 decB bij (iso decB bij i)} (groupHomsCompose (isoHom decB bij) (iso2Hom decB bij)) (λ _ → refl) x
  uniq! : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decA) → iso2 decB bij (iso decB bij x) ≡ x
  uniq! decB bij x = transitivity (uniqLemm decB bij x) (equalityCommutative (uniq decB bij x))

  uniq' : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decB) → x ≡ universalPropertyFunction decB (freeGroup decB) (λ x → iso decB bij (iso2 decB bij (freeEmbedding decB x))) x
  uniq' decB {f} bij x = universalPropertyUniqueness decB (freeGroup decB) (λ x → iso decB bij (iso2 decB bij (freeEmbedding decB x))) {id} (record { wellDefined = id ; groupHom = refl }) (fixesF' decB bij) x
  uniq'Lemm : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decB) → iso decB bij (iso2 decB bij x) ≡ universalPropertyFunction decB (freeGroup decB) (λ x → iso decB bij (iso2 decB bij (freeEmbedding decB x))) x
  uniq'Lemm decB {f} bij x = universalPropertyUniqueness decB (freeGroup decB) (λ i → freeEmbedding decB (f (Invertible.inverse (bijectionImpliesInvertible bij) i))) {λ i → iso decB bij (iso2 decB bij i)} (groupHomsCompose (iso2Hom decB bij) (isoHom decB bij)) (λ _ → refl) x
  uniq'! : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → (bij : Bijection f) → (x : ReducedWord decB) → iso decB bij (iso2 decB bij x) ≡ x
  uniq'! decB bij x = transitivity (uniq'Lemm decB bij x) (equalityCommutative (uniq' decB bij x))

  inBijection : {b : _} {B : Set b} (decB : DecidableSet B) {f : A → B} (bij : Bijection f) → Bijection (iso decB bij)
  inBijection decB bij = invertibleImpliesBijection (record { inverse = iso2 decB bij ; isLeft = uniq'! decB bij ; isRight = uniq! decB bij })

freeGroupFunctorWellDefined : {b : _} {B : Set b} (decB : DecidableSet B) → {f : A → B} → Bijection f → GroupsIsomorphic (freeGroup decA) (freeGroup decB)
GroupsIsomorphic.isomorphism (freeGroupFunctorWellDefined decB {f} bij) = iso decB bij
GroupIso.groupHom (GroupsIsomorphic.proof (freeGroupFunctorWellDefined decB {f} bij)) = universalPropertyHom decA (freeGroup decB) λ a → freeEmbedding decB (f a)
SetoidInjection.wellDefined (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof (freeGroupFunctorWellDefined decB {f} bij)))) refl = refl
SetoidInjection.injective (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof (freeGroupFunctorWellDefined decB {f} bij)))) {x} {y} pr = Bijection.inj (inBijection decB bij) pr
SetoidSurjection.wellDefined (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof (freeGroupFunctorWellDefined decB {f} bij)))) refl = refl
SetoidSurjection.surjective (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof (freeGroupFunctorWellDefined decB {f} bij)))) {x} = Bijection.surj (inBijection decB bij) x

{-
freeGroupFunctorInjective : {b : _} {B : Set b} (decB : DecidableSet B) → GroupsIsomorphic (freeGroup decA) (freeGroup decB) → Sg (A → B) (λ f → Bijection f)
freeGroupFunctorInjective decB iso = {!!}

everyGroupQuotientOfFreeGroup : {b : _} → (S : Setoid {a} {b} A) → {_+_ : A → A → A} → (G : Group S _+_) → GroupsIsomorphic G (quotientGroupByHom (freeGroup decA) (universalPropertyHom decA {!!} {!!}))
everyGroupQuotientOfFreeGroup = {!!}

everyFGGroupQuotientOfFGFreeGroup : {!!}
everyFGGroupQuotientOfFGFreeGroup = {!!}

freeGroupTorsionFree : {!!}
freeGroupTorsionFree = {!!}
-}

private
  mapNToGrp : (a : A) → (n : ℕ) → ReducedWord decA
  mapNToGrpLen : (a : A) → (n : ℕ) → wordLength decA (mapNToGrp a n) ≡ n
  mapNToGrpFirstLetter : (a : A) → (n : ℕ) → .(pr : 0 <N wordLength decA (mapNToGrp a (succ n))) → firstLetter decA (mapNToGrp a (succ n)) pr ≡ (ofLetter a)
  lemma : (a : A) → (n : ℕ) → .(pr : 0 <N wordLength decA (mapNToGrp a (succ n))) → ofLetter a ≡ freeInverse (firstLetter decA (mapNToGrp a (succ n)) pr) → False

  lemma a zero _ ()
  lemma a (succ n) _ ()

  mapNToGrp a zero = empty
  mapNToGrp a 1 = prependLetter (ofLetter a) empty (wordEmpty refl)
  mapNToGrp a (succ (succ n)) = prependLetter (ofLetter a) (mapNToGrp a (succ n)) (wordEnding (identityOfIndiscernablesRight _<N_ (succIsPositive n) (equalityCommutative (mapNToGrpLen a (succ n)))) (freeCompletionEqualFalse decA λ p → lemma a n ((identityOfIndiscernablesRight _<N_ (succIsPositive n) (equalityCommutative (mapNToGrpLen a (succ n))))) p))

  mapNToGrpFirstLetter a zero pr = refl
  mapNToGrpFirstLetter a (succ n) pr = refl

  mapNToGrpLen a zero = refl
  mapNToGrpLen a (succ zero) = refl
  mapNToGrpLen a (succ (succ n)) = applyEquality succ (mapNToGrpLen a (succ n))

  mapNToGrpInj : (a : A) → (x y : ℕ) → mapNToGrp a x ≡ mapNToGrp a y → x ≡ y
  mapNToGrpInj a zero zero pr = refl
  mapNToGrpInj a zero (succ zero) ()
  mapNToGrpInj a zero (succ (succ y)) ()
  mapNToGrpInj a (succ zero) zero ()
  mapNToGrpInj a (succ (succ x)) zero ()
  mapNToGrpInj a (succ zero) (succ zero) pr = refl
  mapNToGrpInj a (succ zero) (succ (succ y)) pr = exFalso (naughtE (transitivity (applyEquality (wordLength decA) (prependLetterInjective decA pr)) (mapNToGrpLen a (succ y))))
  mapNToGrpInj a (succ (succ x)) (succ 0) pr = exFalso (naughtE (transitivity (equalityCommutative (applyEquality (wordLength decA) (prependLetterInjective decA pr))) (mapNToGrpLen a (succ x))))
  mapNToGrpInj a (succ (succ x)) (succ (succ y)) pr = applyEquality succ (mapNToGrpInj a (succ x) (succ y) (prependLetterInjective decA pr))

freeGroupInfinite : (nonempty : A) → DedekindInfiniteSet (ReducedWord decA)
DedekindInfiniteSet.inj (freeGroupInfinite nonempty) = mapNToGrp nonempty
DedekindInfiniteSet.isInjection (freeGroupInfinite nonempty) {x} {y} = mapNToGrpInj nonempty x y


interleaved mutual

  data CoNat : Set
  record ∞CoNat : Set

  constructor
    zero : CoNat

  record ∞CoNat where
    coinductive
    field force : CoNat

  constructor
    suc : ∞CoNat → ?


module Formalization.ClassicalPropositionalLogic.Place where

open import Data.Boolean
open import Data.Tuple as Tuple using (_,_ ; _⨯_)
import      Lvl
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Functional as Fn using (_∘_ ; const)
open import Sets.PredicateSet using (PredSet)
open import Type

private variable ℓₚ ℓᵢ ℓ : Lvl.Level
private variable T A B I : Type{ℓ}
private variable f : A → B

module _ (P : Type{ℓₚ}) where
  private variable s e : Bool
  private variable p : P
  private variable φ ψ γ : Formula(P)

  record Index(I : Type{ℓ}) : Type{ℓ} where
    field
      id : I
      ∧ₗ : I → I
      ∧ᵣ : I → I
      ∨ₗ : I → I
      ∨ᵣ : I → I
      ⟶ₗ : I → I
      ⟶ᵣ : I → I

      ∧ₗ₀ : I → I
      ∧ᵣ₀ : I → I
      ∨ₗ₀ : I → I
      ∨ᵣ₀ : I → I
      ⟶ₗ₀ : I → I
      ⟶ᵣ₀ : I → I

  module _ (ind : Index(I)) where
    private variable i : I

    data Context : I → (Formula(P) → Formula(P)) → Type{Lvl.of(I) Lvl.⊔ ℓₚ} where
      identity     : Context(Index.id ind) Fn.id
      conjunctionₗ : Context(Index.∧ₗ₀ ind i) f → Context(Index.∧ₗ ind i) ((φ ∧_) ∘ f)
      conjunctionᵣ : Context(Index.∧ᵣ₀ ind i) f → Context(Index.∧ᵣ ind i) ((_∧ φ) ∘ f)
      disjunctionₗ : Context(Index.∨ₗ₀ ind i) f → Context(Index.∨ₗ ind i) ((φ ∨_) ∘ f)
      disjunctionᵣ : Context(Index.∨ᵣ₀ ind i) f → Context(Index.∨ᵣ ind i) ((_∨ φ) ∘ f)
      implicationₗ : Context(Index.⟶ₗ₀ ind i) f → Context(Index.⟶ₗ ind i) ((φ ⟶_) ∘ f)
      implicationᵣ : Context(Index.⟶ᵣ₀ ind i) f → Context(Index.⟶ᵣ ind i) ((_⟶ φ) ∘ f)

  Place : Bool → Bool → (Formula(P) → Formula(P)) → Type
  Place s e = Context index (s , e) where
    index : Index(Bool ⨯ Bool)
    Index.id index = (𝑇 , e)
    Index.∧ₗ index = Fn.id
    Index.∧ᵣ index = Fn.id
    Index.∨ₗ index = Fn.id
    Index.∨ᵣ index = Fn.id
    Index.⟶ₗ index = Fn.id
    Index.⟶ᵣ index = Tuple.map Fn.id (const 𝑇)
    Index.∧ₗ₀ index = Fn.id
    Index.∧ᵣ₀ index = Fn.id
    Index.∨ₗ₀ index = Fn.id
    Index.∨ᵣ₀ index = Fn.id
    Index.⟶ₗ₀ index = Fn.id
    Index.⟶ᵣ₀ index = Tuple.map not (const 𝑇)
  {-
  -- (Place s e F φ) means that the formula F lies on a (strictly (e = 𝐹) / not strictly (e = 𝑇)) (positive (s = 𝑇) / negative (s = 𝐹)) position in the formula φ.
  -- Also called: Occurrence, part, (strictly) positive/negative subformula.
  data Place : Bool → Bool → Formula(P) → Formula(P) → Type{ℓₚ} where
    refl         : Place 𝑇 e φ φ
    conjunctionₗ : Place s e γ φ       → Place s e γ (φ ∧ ψ)
    conjunctionᵣ : Place s e γ ψ       → Place s e γ (φ ∧ ψ)
    disjunctionₗ : Place s e γ φ       → Place s e γ (φ ∨ ψ)
    disjunctionᵣ : Place s e γ ψ       → Place s e γ (φ ∨ ψ)
    implicationₗ : Place (not s) e γ φ → Place s 𝑇 γ (φ ⟶ ψ)
    implicationᵣ : Place s e γ ψ       → Place s e γ (φ ⟶ ψ)
  -}

  StrictlyPositive = Place 𝑇 𝐹
  StrictlyNegative = Place 𝐹 𝐹
  Positive         = Place 𝑇 𝑇
  Negative         = Place 𝐹 𝑇

  strictly-negative-to-strictly-positive : Place 𝐹 𝐹 f → Place 𝑇 𝐹 f
  strictly-negative-to-strictly-positive (conjunctionₗ p) = conjunctionₗ (strictly-negative-to-strictly-positive p)
  strictly-negative-to-strictly-positive (conjunctionᵣ p) = conjunctionᵣ (strictly-negative-to-strictly-positive p)
  strictly-negative-to-strictly-positive (disjunctionₗ p) = disjunctionₗ (strictly-negative-to-strictly-positive p)
  strictly-negative-to-strictly-positive (disjunctionᵣ p) = disjunctionᵣ (strictly-negative-to-strictly-positive p)
  strictly-negative-to-strictly-positive (implicationₗ p) = implicationₗ (strictly-negative-to-strictly-positive p)

  strictly-to-not-strictly : Place s 𝐹 f → Place s 𝑇 f
  strictly-to-not-strictly identity         = identity
  strictly-to-not-strictly (conjunctionₗ p) = conjunctionₗ (strictly-to-not-strictly p)
  strictly-to-not-strictly (conjunctionᵣ p) = conjunctionᵣ (strictly-to-not-strictly p)
  strictly-to-not-strictly (disjunctionₗ p) = disjunctionₗ (strictly-to-not-strictly p)
  strictly-to-not-strictly (disjunctionᵣ p) = disjunctionᵣ (strictly-to-not-strictly p)
  strictly-to-not-strictly (implicationₗ p) = implicationₗ (strictly-to-not-strictly p)


-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Algebra.Group.Semigroup where

open import Algebra.Category
open import Core

-- A semigroup is an associative binary function.

record SemigroupOver {a r} (A : Set a) (Eq : Equiv {r = r} A) : Set (a ⊔ r) where
  open Equiv Eq

  field
    _⋄_    : A → A → A
    ⋄-cong : ∀ {x1 x2 y1 y2} → x1 ≈ x2 → y1 ≈ y2 → x1 ⋄ y1 ≈ x2 ⋄ y2
    assoc  : ∀ x y z → (x ⋄ y) ⋄ z ≈ x ⋄ (y ⋄ z)

  semigroupoid : Semigroupoid
  semigroupoid =
    record {
      Ob = ⊤;
      Hom = λ _ _ → A;
      Eq = Eq;
      _∘_ = _⋄_;
      ∘-cong = ⋄-cong;
      assoc = assoc
    }

  open Semigroupoid semigroupoid public
    using (Epic; Monic)

record Semigroup {a r} : Set (lsuc (a ⊔ r)) where
  field
    A  : Set a
    Eq : Equiv {r = r} A
    semigroupOver : SemigroupOver A Eq

  open Equiv Eq public
  open SemigroupOver semigroupOver public

-- Commutative semigroups.

record IsComm {a r} (S : Semigroup {a} {r}) : Set (a ⊔ r) where
  open Semigroup S

  field
    comm : ∀ x y → x ⋄ y ≈ y ⋄ x

-- A semigroup morphism is a function that maps the elements of one
-- semigroup to another while preserving the compositional structure.

record SemigroupMorphism
           {sa sr ta tr}
           (S : Semigroup {sa} {sr})
           (T : Semigroup {ta} {tr})
           : Set (sa ⊔ ta ⊔ sr ⊔ tr)
       where

  private
    module S = Semigroup S
    module T = Semigroup T

  field
    map : S.A → T.A
    map-cong : ∀ {x y} → x S.≈ y → map x T.≈ map y
    ⋄-preserving : ∀ x y → map (x S.⋄ y) T.≈ map x T.⋄ map y

  semifunctor : Semifunctor S.semigroupoid T.semigroupoid
  semifunctor =
    record {
      F = λ _ → tt;
      map = map;
      map-cong = map-cong;
      ∘-preserving = ⋄-preserving
    }

-- An equivalence relation on semigroup morphisms that considers
-- semigroup morphisms to be equal iff they map every element in the
-- domain to the same element in the codomain.

SemigroupMorphismEq :
  ∀ {sa sr ta tr}
    {S : Semigroup {sa} {sr}} {T : Semigroup {ta} {tr}}
  → Equiv (SemigroupMorphism S T)
SemigroupMorphismEq {T = T} =
  record {
    _≈_ = λ F G →
            let module F = SemigroupMorphism F
                module G = SemigroupMorphism G
            in ∀ x → F.map x ≈ G.map x;
    refl = λ _ → refl;
    sym = λ x≈y x → sym (x≈y x);
    trans = λ x≈y y≈z x → trans (x≈y x) (y≈z x)
  }

  where
  module T = Semigroup T
  open Equiv T.Eq

-- The category of semigroups and semigroup morphisms.

Semigroups : ∀ {a r} → Category
Semigroups {a} {r} =
  record {
    semigroupoid = record {
      Ob = Semigroup {a} {r};
      Hom = SemigroupMorphism;
      Eq = SemigroupMorphismEq;
      _∘_ = _∘_;
      ∘-cong = λ {_} {_} {_} {F1} {F2} {G1} {G2} → ∘-cong {F1 = F1} {F2} {G1} {G2};
      assoc = assoc
    };
    id = id;
    left-id = left-right-id;
    right-id = left-right-id
  }

  where
  open module MyEquiv {S T} = Equiv (SemigroupMorphismEq {S = S} {T = T})

  _∘_ : ∀ {S T U} → SemigroupMorphism T U → SemigroupMorphism S T → SemigroupMorphism S U
  _∘_ {S} {T} {U} F G =
    record {
      map = F.map Sets.∘ G.map;
      map-cong = λ p → F.map-cong (G.map-cong p);
      ⋄-preserving = λ x y →
        U.begin
          F.map (G.map (x S.⋄ y))             U.≈[ F.map-cong (G.⋄-preserving _ _) ]
          F.map (G.map x T.⋄ G.map y)         U.≈[ F.⋄-preserving _ _ ]
          F.map (G.map x) U.⋄ F.map (G.map y)
        U.qed
    }

    where
    module S = Semigroup S
    module T = Semigroup T
    module U = Semigroup U

    module F = SemigroupMorphism F
    module G = SemigroupMorphism G

  ∘-cong :
    ∀ {S T U}
      {F1 F2 : SemigroupMorphism T U}
      {G1 G2 : SemigroupMorphism S T}
    → F1 ≈ F2 → G1 ≈ G2 → F1 ∘ G1 ≈ F2 ∘ G2
  ∘-cong {U = U} {F1} {F2} {G1} {G2} F1≈F2 G1≈G2 x =
    U.begin
      F1.map (G1.map x) U.≈[ F1.map-cong (G1≈G2 _) ]
      F1.map (G2.map x) U.≈[ F1≈F2 _ ]
      F2.map (G2.map x)
    U.qed

    where
    module U = Semigroup U

    module F1 = SemigroupMorphism F1
    module F2 = SemigroupMorphism F2
    module G1 = SemigroupMorphism G1
    module G2 = SemigroupMorphism G2

  assoc :
    ∀ {S T U V}
      (F : SemigroupMorphism U V)
      (G : SemigroupMorphism T U)
      (H : SemigroupMorphism S T)
    → (F ∘ G) ∘ H ≈ F ∘ (G ∘ H)
  assoc {V = V} _ _ _ _ = V.refl
    where
    module V = Semigroup V

  id : ∀ {S} → SemigroupMorphism S S
  id {S} =
    record {
      map = λ x → x;
      map-cong = λ x → x;
      ⋄-preserving = λ _ _ → Semigroup.refl S
    }

  left-right-id :
    ∀ {S T}
      (F : SemigroupMorphism S T)
    → F ≈ F
  left-right-id {T = T} _ _ = T.refl
    where
    module T = Semigroup T

module Semigroups {a r} = Category (Semigroups {a} {r})

-- Product semigroups

_×S_ : ∀ {sa sr ta tr} → Semigroup {sa} {sr} → Semigroup {ta} {tr} → Semigroup
S ×S T =
  record {
    A = S.A × T.A;
    Eq = record {
      _≈_ = λ { (x1 , x2) (y1 , y2) → (x1 S.≈ y1) × (x2 T.≈ y2) };
      refl = S.refl , T.refl;
      sym = λ { (p1 , p2) → S.sym p1 , T.sym p2 };
      trans = λ { (p1 , p2) (q1 , q2) → S.trans p1 q1 , T.trans p2 q2 }
    };
    semigroupOver = record {
      _⋄_ = λ { (x1 , x2) (y1 , y2) → (x1 S.⋄ y1) , (x2 T.⋄ y2) };
      ⋄-cong = λ { (p1 , p2) (q1 , q2) → S.⋄-cong p1 q1 , T.⋄-cong p2 q2 };
      assoc = λ { (x1 , x2) (y1 , y2) (z1 , z2) → S.assoc x1 y1 z1 , T.assoc x2 y2 z2 }
    }
  }

  where
  module S = Semigroup S
  module T = Semigroup T


-- Andreas, Ulf, 2022-05-06, AIM XXXV
-- Make sure you cannot trick Agda into admitting data types in IUniv.
-- The previous check let this exploit through.
-- Note: I : IUniv : SSet₁

open import Agda.Primitive.Cubical

mutual
  Univ = _
  data False : Univ where

  I' : Univ
  I' = I

-- Should fail.

-- Error:
-- The universe _6 of False
-- is unresolved, thus does not permit data or record declarations
-- when checking the definition of False


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties imply others
------------------------------------------------------------------------

module Relation.Binary.Consequences where

open import Relation.Binary.Core hiding (refl)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.Core
open import Function
open import Data.Sum
open import Data.Product
open import Data.Empty

-- Some of the definitions can be found in the following module:

open import Relation.Binary.Consequences.Core public

trans∧irr⟶asym :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} → {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Reflexive _≈_ →
  Transitive _<_ → Irreflexive _≈_ _<_ → Asymmetric _<_
trans∧irr⟶asym refl trans irrefl = λ x<y y<x →
  irrefl refl (trans x<y y<x)

irr∧antisym⟶asym :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Irreflexive _≈_ _<_ → Antisymmetric _≈_ _<_ → Asymmetric _<_
irr∧antisym⟶asym irrefl antisym = λ x<y y<x →
  irrefl (antisym x<y y<x) x<y

asym⟶antisym :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Asymmetric _<_ → Antisymmetric _≈_ _<_
asym⟶antisym asym x<y y<x = ⊥-elim (asym x<y y<x)

asym⟶irr :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  _<_ Respects₂ _≈_ → Symmetric _≈_ →
  Asymmetric _<_ → Irreflexive _≈_ _<_
asym⟶irr {_<_ = _<_} resp sym asym {x} {y} x≈y x<y = asym x<y y<x
  where
  y<y : y < y
  y<y = proj₂ resp x≈y x<y
  y<x : y < x
  y<x = proj₁ resp (sym x≈y) y<y

total⟶refl :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_∼_ : Rel A ℓ₂} →
  _∼_ Respects₂ _≈_ → Symmetric _≈_ →
  Total _∼_ → _≈_ ⇒ _∼_
total⟶refl {_≈_ = _≈_} {_∼_ = _∼_} resp sym total = refl
  where
  refl : _≈_ ⇒ _∼_
  refl {x} {y} x≈y with total x y
  ...              | inj₁ x∼y = x∼y
  ...              | inj₂ y∼x =
    proj₁ resp x≈y (proj₂ resp (sym x≈y) y∼x)

total+dec⟶dec :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_≤_ : Rel A ℓ₂} →
  _≈_ ⇒ _≤_ → Antisymmetric _≈_ _≤_ →
  Total _≤_ → Decidable _≈_ → Decidable _≤_
total+dec⟶dec {_≈_ = _≈_} {_≤_ = _≤_} refl antisym total _≟_ = dec
  where
  dec : Decidable _≤_
  dec x y with total x y
  ... | inj₁ x≤y = yes x≤y
  ... | inj₂ y≤x with x ≟ y
  ...   | yes  x≈y = yes (refl x≈y)
  ...   | no  ¬x≈y = no (λ x≤y → ¬x≈y (antisym x≤y y≤x))

tri⟶asym :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Trichotomous _≈_ _<_ → Asymmetric _<_
tri⟶asym tri {x} {y} x<y x>y with tri x y
... | tri< _   _ x≯y = x≯y x>y
... | tri≈ _   _ x≯y = x≯y x>y
... | tri> x≮y _ _   = x≮y x<y

tri⟶irr :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  _<_ Respects₂ _≈_ → Symmetric _≈_ →
  Trichotomous _≈_ _<_ → Irreflexive _≈_ _<_
tri⟶irr resp sym tri = asym⟶irr resp sym (tri⟶asym tri)

tri⟶dec≈ :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Trichotomous _≈_ _<_ → Decidable _≈_
tri⟶dec≈ compare x y with compare x y
... | tri< _ x≉y _ = no  x≉y
... | tri≈ _ x≈y _ = yes x≈y
... | tri> _ x≉y _ = no  x≉y

tri⟶dec< :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂} →
  Trichotomous _≈_ _<_ → Decidable _<_
tri⟶dec< compare x y with compare x y
... | tri< x<y _ _ = yes x<y
... | tri≈ x≮y _ _ = no  x≮y
... | tri> x≮y _ _ = no  x≮y

map-NonEmpty : ∀ {a b p q} {A : Set a} {B : Set b}
                 {P : REL A B p} {Q : REL A B q} →
               P ⇒ Q → NonEmpty P → NonEmpty Q
map-NonEmpty f x = nonEmpty (f (NonEmpty.proof x))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed containers aka interaction structures aka polynomial
-- functors. The notation and presentation here is closest to that of
-- Hancock and Hyvernat in "Programming interfaces and basic topology"
-- (2006/9).
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe --guardedness #-}

module Data.Container.Indexed where

open import Level
open import Codata.Musical.M.Indexed
open import Data.Product as Prod hiding (map)
open import Data.W.Indexed
open import Function renaming (id to ⟨id⟩; _∘_ to _⟨∘⟩_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (_↔_; module Inverse)
open import Relation.Unary using (Pred; _⊆_)
import Relation.Binary as B
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_; refl)

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

-- The type and its semantics ("extension").

open import Data.Container.Indexed.Core public
open Container public

-- Abbreviation for the commonly used level one version of indexed
-- containers.

_▷_ : Set → Set → Set₁
I ▷ O = Container I O zero zero

-- The least and greatest fixpoint.

μ ν : ∀ {o c r} {O : Set o} → Container O O c r → Pred O _
μ = W
ν = M

-- An equivalence relation is defined in Data.Container.Indexed.WithK.

------------------------------------------------------------------------
-- Functoriality

-- Indexed containers are functors.

map : ∀ {i o c r ℓ₁ ℓ₂} {I : Set i} {O : Set o}
      (C : Container I O c r) {X : Pred I ℓ₁} {Y : Pred I ℓ₂} →
      X ⊆ Y → ⟦ C ⟧ X ⊆ ⟦ C ⟧ Y
map _ f = Prod.map ⟨id⟩ (λ g → f ⟨∘⟩ g)

-- Some properties are proved in Data.Container.Indexed.WithK.

------------------------------------------------------------------------
-- Container morphisms

module _ {i₁ i₂ o₁ o₂}
         {I₁ : Set i₁} {I₂ : Set i₂} {O₁ : Set o₁} {O₂ : Set o₂} where

  -- General container morphism.

  record ContainerMorphism {c₁ c₂ r₁ r₂ ℓ₁ ℓ₂}
         (C₁ : Container I₁ O₁ c₁ r₁) (C₂ : Container I₂ O₂ c₂ r₂)
         (f : I₁ → I₂) (g : O₁ → O₂)
         (_∼_ : B.Rel I₂ ℓ₁) (_≈_ : B.REL (Set r₂) (Set r₁) ℓ₂)
         (_·_ : ∀ {A B} → A ≈ B → A → B) :
         Set (i₁ ⊔ i₂ ⊔ o₁ ⊔ o₂ ⊔ c₁ ⊔ c₂ ⊔ r₁ ⊔ r₂ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      command   : Command C₁ ⊆ Command C₂ ⟨∘⟩ g
      response  : ∀ {o} {c₁ : Command C₁ o} →
                  Response C₂ (command c₁) ≈ Response C₁ c₁
      coherent  : ∀ {o} {c₁ : Command C₁ o} {r₂ : Response C₂ (command c₁)} →
                  f (next C₁ c₁ (response · r₂)) ∼ next C₂ (command c₁) r₂

  open ContainerMorphism public

  -- Plain container morphism.

  _⇒[_/_]_ : ∀ {c₁ c₂ r₁ r₂} →
             Container I₁ O₁ c₁ r₁ → (I₁ → I₂) → (O₁ → O₂) →
             Container I₂ O₂ c₂ r₂ → Set _
  C₁ ⇒[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ (λ R₂ R₁ → R₂ → R₁) _$_

  -- Linear container morphism.

  _⊸[_/_]_ : ∀ {c₁ c₂ r₁ r₂} →
             Container I₁ O₁ c₁ r₁ → (I₁ → I₂) → (O₁ → O₂) →
             Container I₂ O₂ c₂ r₂ → Set _
  C₁ ⊸[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ _↔_
                                       (λ r₂↔r₁ r₂ → Inverse.to r₂↔r₁ ⟨$⟩ r₂)

  -- Cartesian container morphism.

  _⇒C[_/_]_ : ∀ {c₁ c₂ r} →
              Container I₁ O₁ c₁ r → (I₁ → I₂) → (O₁ → O₂) →
              Container I₂ O₂ c₂ r → Set _
  C₁ ⇒C[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ (λ R₂ R₁ → R₂ ≡ R₁)
                                        (λ r₂≡r₁ r₂ → P.subst ⟨id⟩ r₂≡r₁ r₂)

-- Degenerate cases where no reindexing is performed.

module _ {i o c r} {I : Set i} {O : Set o} where

  _⇒_ : B.Rel (Container I O c r) _
  C₁ ⇒ C₂ = C₁ ⇒[ ⟨id⟩ / ⟨id⟩ ] C₂

  _⊸_ : B.Rel (Container I O c r) _
  C₁ ⊸ C₂ = C₁ ⊸[ ⟨id⟩ / ⟨id⟩ ] C₂

  _⇒C_ : B.Rel (Container I O c r) _
  C₁ ⇒C C₂ = C₁ ⇒C[ ⟨id⟩ / ⟨id⟩ ] C₂

------------------------------------------------------------------------
-- Plain morphisms

-- Interpretation of _⇒_.

⟪_⟫ : ∀ {i o c r ℓ} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r} →
      C₁ ⇒ C₂ → (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
⟪ m ⟫ X (c , k) = command m c , λ r₂ →
  P.subst X (coherent m) (k (response m r₂))

module PlainMorphism {i o c r} {I : Set i} {O : Set o} where

  -- Identity.

  id : (C : Container I O c r) → C ⇒ C
  id _ = record
    { command  = ⟨id⟩
    ; response = ⟨id⟩
    ; coherent = refl
    }

  -- Composition.

  infixr 9 _∘_

  _∘_ : {C₁ C₂ C₃ : Container I O c r} →
        C₂ ⇒ C₃ → C₁ ⇒ C₂ → C₁ ⇒ C₃
  f ∘ g = record
    { command  = command  f ⟨∘⟩ command g
    ; response = response g ⟨∘⟩ response f
    ; coherent = coherent g ⟨ P.trans ⟩ coherent f
    }

  -- Identity commutes with ⟪_⟫.

  id-correct : ∀ {ℓ} {C : Container I O c r} → ∀ {X : Pred I ℓ} {o} →
               ⟪ id C ⟫ X {o} ≗ ⟨id⟩
  id-correct _ = refl

  -- More properties are proved in Data.Container.Indexed.WithK.

------------------------------------------------------------------------
-- Linear container morphisms

module LinearMorphism
  {i o c r} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r}
  (m : C₁ ⊸ C₂)
  where

  morphism : C₁ ⇒ C₂
  morphism = record
    { command  = command m
    ; response = _⟨$⟩_ (Inverse.to (response m))
    ; coherent = coherent m
    }

  ⟪_⟫⊸ : ∀ {ℓ} (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
  ⟪_⟫⊸ = ⟪ morphism ⟫

open LinearMorphism public using (⟪_⟫⊸)

------------------------------------------------------------------------
-- Cartesian morphisms

module CartesianMorphism
  {i o c r} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r}
  (m : C₁ ⇒C C₂)
  where

  morphism : C₁ ⇒ C₂
  morphism = record
    { command  = command m
    ; response = P.subst ⟨id⟩ (response m)
    ; coherent = coherent m
    }

  ⟪_⟫C : ∀ {ℓ} (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
  ⟪_⟫C = ⟪ morphism ⟫

open CartesianMorphism public using (⟪_⟫C)

------------------------------------------------------------------------
-- All and any

-- □ and ◇ are defined in the core module.

module _ {i o c r ℓ₁ ℓ₂} {I : Set i} {O : Set o} (C : Container I O c r)
         {X : Pred I ℓ₁} {P Q : Pred (Σ I X) ℓ₂} where

  -- All.

  □-map : P ⊆ Q → □ C P ⊆ □ C Q
  □-map P⊆Q = _⟨∘⟩_ P⊆Q

  -- Any.

  ◇-map : P ⊆ Q → ◇ C P ⊆ ◇ C Q
  ◇-map P⊆Q = Prod.map ⟨id⟩ P⊆Q

-- Membership is defined in Data.Container.Indexed.WithK.


------------------------------------------------------------------------
-- The Agda standard library
--
-- First generalizes the idea that an element is the first in a list to
-- satisfy a predicate.
------------------------------------------------------------------------

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

module Data.List.Relation.Unary.First {a} {A : Set a} where

open import Level using (_⊔_)
open import Data.Empty
open import Data.Fin as Fin using (Fin; zero; suc)
open import Data.List.Base as List using (List; []; _∷_)
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
open import Data.List.Relation.Unary.Any as Any using (Any; here; there)
open import Data.Product as Prod using (∃; -,_; _,_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Function
open import Relation.Unary
open import Relation.Nullary

-----------------------------------------------------------------------
-- Basic type.

module _ {p q} (P : Pred A p) (Q : Pred A q) where

  data First : Pred (List A) (a ⊔ p ⊔ q) where
    [_] : ∀ {x xs} → Q x            → First (x ∷ xs)
    _∷_ : ∀ {x xs} → P x → First xs → First (x ∷ xs)

  data FirstView : Pred (List A) (a ⊔ p ⊔ q) where
    _++_∷_ : ∀ {xs y} → All P xs → Q y → ∀ ys → FirstView (xs List.++ y ∷ ys)

------------------------------------------------------------------------
-- map

module _ {p q r s} {P : Pred A p} {Q : Pred A q} {R : Pred A r} {S : Pred A s} where

  map : P ⊆ R → Q ⊆ S → First P Q ⊆ First R S
  map p⇒r q⇒r [ qx ]      = [ q⇒r qx ]
  map p⇒r q⇒r (px ∷ pqxs) = p⇒r px ∷ map p⇒r q⇒r pqxs

module _ {p q r} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where

  map₁ : P ⊆ R → First P Q ⊆ First R Q
  map₁ p⇒r = map p⇒r id

  map₂ : Q ⊆ R → First P Q ⊆ First P R
  map₂ = map id

  refine : P ⊆ Q ∪ R → First P Q ⊆ First R Q
  refine f [ qx ]      = [ qx ]
  refine f (px ∷ pqxs) with f px
  ... | inj₁ qx = [ qx ]
  ... | inj₂ rx = rx ∷ refine f pqxs

module _ {p q} {P : Pred A p} {Q : Pred A q} where

------------------------------------------------------------------------
-- Operations

  empty : ¬ First P Q []
  empty ()

  tail : ∀ {x xs} → ¬ Q x → First P Q (x ∷ xs) → First P Q xs
  tail ¬qx [ qx ]      = ⊥-elim (¬qx qx)
  tail ¬qx (px ∷ pqxs) = pqxs

  index : First P Q ⊆ (Fin ∘′ List.length)
  index [ qx ]     = zero
  index (_ ∷ pqxs) = suc (index pqxs)

  index-satisfied : ∀ {xs} (pqxs : First P Q xs) → Q (List.lookup xs (index pqxs))
  index-satisfied [ qx ]     = qx
  index-satisfied (_ ∷ pqxs) = index-satisfied pqxs

  satisfied : ∀ {xs} → First P Q xs → ∃ Q
  satisfied pqxs = -, index-satisfied pqxs

  satisfiable : Satisfiable Q → Satisfiable (First P Q)
  satisfiable (x , qx) = List.[ x ] , [ qx ]

------------------------------------------------------------------------
-- Decidability results

  first : Π[ P ∪ Q ] → Π[ First P Q ∪ All P ]
  first p⊎q []       = inj₂ []
  first p⊎q (x ∷ xs) with p⊎q x
  ... | inj₁ px = Sum.map (px ∷_) (px ∷_) (first p⊎q xs)
  ... | inj₂ qx = inj₁ [ qx ]

------------------------------------------------------------------------
-- Relationship with Any

module _ {q} {Q : Pred A q} where

  fromAny : Any Q ⊆ First U Q
  fromAny (here qx)   = [ qx ]
  fromAny (there any) = _ ∷ fromAny any

  toAny : ∀ {p} {P : Pred A p} → First P Q ⊆ Any Q
  toAny [ qx ]     = here qx
  toAny (_ ∷ pqxs) = there (toAny pqxs)


------------------------------------------------------------------------
-- Definitional interpreters can model systems with bounded space
------------------------------------------------------------------------

-- In "Reasoning on Divergent Computations with Coaxioms" Ancona,
-- Dagnino and Zucca write the following:
--
--   "To assess the applicability and generality of our approach much
--   work is still needed. We are currently considering to apply
--   coaxioms to other kinds of semantics; in particular, trace
--   semantics seems particularly interesting for investigating
--   whether our approach is suitable for formalizing and proving
--   important safety properties of non terminating programs, as
--   ensuring that a server will never try to use infinite resources.
--   Other approaches based on definitional interpreters [Danielsson
--   2012], and the adoption of step counters [Amin and Rompf 2017;
--   Ancona 2014; Ernst et al. 2006; Owens et al. 2016] seem to be
--   appealing for proving type soundness properties with big-step
--   semantics, and other results concerning program equivalence;
--   however, it is not clear whether these solutions work well for
--   other kinds of properties. For instance, if a program consists of
--   an infinite loop that allocates new heap space at each step
--   without releasing it, one would like to conclude that it will
--   eventually crash even though a definitional interpreter returns
--   timeout for all possible values of the step counter."
--
-- This is an attempt to show that definitional interpreters can
-- handle this situation.

module Bounded-space where

open import Equality.Propositional
open import Prelude
open import Tactic.By.Propositional
open import Prelude.Size

open import Colist equality-with-J
open import Nat equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity as B
  hiding (reflexive; symmetric)

open import Only-allocation

------------------------------------------------------------------------
-- Heaps

-- Bounded heaps. (Only a size, plus a proof showing that the size is
-- bounded.)

record Heap (limit : ℕ) : Type where
  field
    size  : ℕ
    bound : size ≤ limit

open Heap public

-- An empty heap.

empty : ∀ {l} → Heap l
empty = record { size = zero; bound = zero≤ _ }

-- A full heap.

full : ∀ l → Heap l
full l = record { size = l; bound = ≤-refl }

-- Reduces the heap's size by one. If the heap is empty, then it is
-- returned unchanged.

shrink : ∀ {l} → Heap l → Heap l
shrink {l} h = record
  { size  = pred (h .size)
  ; bound = pred (h .size)  ≤⟨ pred≤ _ ⟩
            h .size         ≤⟨ h .bound ⟩∎
            l               ∎≤
  }

-- Increases the heap's size by one. If the heap already has the
-- maximum size, then nothing is returned.

grow : ∀ {l} → Heap l → Maybe (Heap l)
grow {l} h with l ≤⊎> h .size
... | inj₁ _   = nothing
... | inj₂ h<l = just (record { size  = suc (h .size)
                              ; bound = h<l
                              })

-- Lemmas related to grow.

grow-full :
  ∀ {l} (h : Heap l) → h .size ≡ l → grow h ≡ nothing
grow-full {l} h h≡l with l ≤⊎> h .size
... | inj₁ _   = refl
... | inj₂ h<l =
  ⊥-elim (+≮ 0 (
    1 + h .size  ≤⟨ h<l ⟩
    l            ≡⟨ sym h≡l ⟩≤
    h .size      ∎≤))

grow-not-full :
  ∀ {l} (h : Heap l) →
  h .size < l → ∃ λ h′ → grow h ≡ just h′ × h′ .size ≡ 1 + h .size
grow-not-full {l} h h<l with l ≤⊎> h .size
... | inj₂ _   = _ , refl , refl
... | inj₁ l≤h =
  ⊥-elim (+≮ 0 (
    1 + h .size  ≤⟨ h<l ⟩
    l            ≤⟨ l≤h ⟩∎
    h .size      ∎≤))

------------------------------------------------------------------------
-- Definitional interpreter

-- One step of computation.

step : ∀ {l} → Stmt → Heap l → Maybe (Heap l)
step dealloc heap = just (shrink heap)
step alloc   heap = grow heap

-- A crashing computation.

crash : ∀ {i l} → Delay (Maybe (Heap l)) i
crash = now nothing

-- A definitional interpreter.

⟦_⟧ : ∀ {i l} → Program i → Heap l → Delay (Maybe (Heap l)) i
⟦ []    ⟧ heap = now (just heap)
⟦ s ∷ p ⟧ heap with step s heap
... | nothing       = crash
... | just new-heap = later λ { .force → ⟦ p .force ⟧ new-heap }

------------------------------------------------------------------------
-- A program equivalence

-- An equivalence relation that identifies programs that, given a
-- sufficient amount of memory, behave identically (up to weak
-- bisimilarity).

infix 4 [_]_≃_ [_]_≃′_

[_]_≃_ : Size → Program ∞ → Program ∞ → Type
[ i ] p ≃ q =
  ∃ λ c →
  ∀ l (h : Heap l) →
  c + h .size ≤ l →
  [ i ] ⟦ p ⟧ h ≈ ⟦ q ⟧ h

[_]_≃′_ : Size → Program ∞ → Program ∞ → Type
[ i ] p ≃′ q =
  ∃ λ c →
  ∀ l (h : Heap l) →
  c + h .size ≤ l →
  [ i ] ⟦ p ⟧ h ≈′ ⟦ q ⟧ h

-- The relation is an equivalence relation.

reflexive : ∀ {i} p → [ i ] p ≃ p
reflexive _ = 0 , λ _ _ _ → B.reflexive _

symmetric : ∀ {i p q} → [ i ] p ≃ q → [ i ] q ≃ p
symmetric = Σ-map id λ hyp l h c → B.symmetric (hyp l h c)

transitive : ∀ {i p q r} → [ ∞ ] p ≃ q → [ ∞ ] q ≃ r → [ i ] p ≃ r
transitive {p = p} {q} {r} (c₁ , p₁) (c₂ , p₂) =
  max c₁ c₂ , λ l h c →
    ⟦ p ⟧ h  ≈⟨ p₁ l h (lemma₁ l h c) ⟩
    ⟦ q ⟧ h  ≈⟨ p₂ l h (lemma₂ l h c) ⟩∎
    ⟦ r ⟧ h  ∎
  where
  lemma₁ = λ l h c →
    c₁ + h .size         ≤⟨ ˡ≤max c₁ _ +-mono ≤-refl ⟩
    max c₁ c₂ + h .size  ≤⟨ c ⟩∎
    l                   ∎≤

  lemma₂ = λ l h c →
    c₂ + h .size         ≤⟨ ʳ≤max c₁ _ +-mono ≤-refl ⟩
    max c₁ c₂ + h .size  ≤⟨ c ⟩∎
    l                   ∎≤

-- The relation is compatible with respect to the program formers.

[]-cong : ∀ {i} → [ i ] [] ≃ []
[]-cong = reflexive []

∷-cong : ∀ {s p q i} → [ i ] p .force ≃′ q .force → [ i ] s ∷ p ≃ s ∷ q
∷-cong {dealloc} (c , p≈q) =
  c , λ l h c≤ → later λ { .force → p≈q l (shrink h) (
        c + shrink h .size  ≤⟨ ≤-refl {n = c} +-mono pred≤ _ ⟩
        c + h .size         ≤⟨ c≤ ⟩
        l                   ∎≤) .force }
∷-cong {alloc} {p} {q} {i} (c , p≈q) = 1 + c , lemma
  where
  lemma : ∀ l (h : Heap l) → 1 + c + h .size ≤ l →
          [ i ] ⟦ alloc ∷ p ⟧ h ≈ ⟦ alloc ∷ q ⟧ h
  lemma l h 1+c≤ with l ≤⊎> h .size
  ... | inj₁ _   = now
  ... | inj₂ h<l = later λ { .force → p≈q l _ (
                     c + (1 + h .size)  ≡⟨ +-assoc c ⟩≤
                     c + 1 + h .size    ≡⟨ by (+-comm c) ⟩≤
                     1 + c + h .size    ≤⟨ 1+c≤ ⟩∎
                     l                  ∎≤) .force }

------------------------------------------------------------------------
-- Some examples

-- The program bounded crashes when the heap is full.

bounded-crash :
  ∀ {i l} (h : Heap l) →
  h .size ≡ l →
  [ i ] ⟦ bounded ⟧ h ≈ crash
bounded-crash h h≡l
  rewrite grow-full h h≡l =
  now

-- However, for smaller heaps the program loops.

bounded-loop :
  ∀ {i l} (h : Heap l) →
  h .size < l →
  [ i ] ⟦ bounded ⟧ h ≈ never
bounded-loop {l = l} h <l
  with grow h | grow-not-full h <l
... | .(just h′) | h′ , refl , refl =
  later λ { .force →
  later λ { .force →
  bounded-loop _ <l }}

-- The program bounded₂ loops when there are at least two empty slots
-- in the heap.

bounded₂-loop :
  ∀ {i l} (h : Heap l) →
  2 + h .size ≤ l →
  [ i ] ⟦ bounded₂ ⟧ h ≈ never
bounded₂-loop {i} {l} h 2+h≤l
  with grow h | grow-not-full h (<→≤ 2+h≤l)
... | .(just h′) | h′ , refl , refl = later λ { .force → lemma }
  where
  lemma : [ i ] ⟦ force (tail bounded₂) ⟧ h′ ≈ never
  lemma with grow h′ | grow-not-full h′ 2+h≤l
  lemma | .(just h″) | h″ , refl , refl =
    later λ { .force →
    later λ { .force →
    later λ { .force →
    bounded₂-loop _ 2+h≤l }}}

-- The program unbounded crashes for all heaps.

unbounded-crash :
  ∀ {i l} (h : Heap l) → [ i ] ⟦ unbounded ⟧ h ≈ crash
unbounded-crash {l = l} h = helper h (≤→≤↑ (h .bound))
  where
  helper :
    ∀ {i} (h′ : Heap l) → size h′ ≤↑ l →
    [ i ] ⟦ unbounded ⟧ h′ ≈ crash
  helper h′ (≤↑-refl h′≡l)
    rewrite grow-full h′ h′≡l =
    now
  helper h′ (≤↑-step 1+h′≤l)
    with grow h′ | grow-not-full h′ (≤↑→≤ 1+h′≤l)
  ... | .(just h″) | h″ , refl , refl =
    laterˡ (helper h″ 1+h′≤l)

-- The programs bounded and bounded₂ are ≃-equivalent.

bounded≃bounded₂ : [ ∞ ] bounded ≃ bounded₂
bounded≃bounded₂ =
  2 , λ l h 2+h≤l →
    ⟦ bounded ⟧ h   ≈⟨ bounded-loop _ (<→≤ 2+h≤l) ⟩
    never           ≈⟨ B.symmetric (bounded₂-loop _ 2+h≤l) ⟩∎
    ⟦ bounded₂ ⟧ h  ∎

-- The programs bounded and unbounded are not ≃-equivalent.

¬bounded≃unbounded :
  ¬ [ ∞ ] bounded ≃ unbounded
¬bounded≃unbounded (c , c≈u) = now≉never (
  crash            ≈⟨ B.symmetric (unbounded-crash h) ⟩
  ⟦ unbounded ⟧ h  ≈⟨ B.symmetric (c≈u _ h (≤-refl +-mono zero≤ _)) ⟩
  ⟦ bounded ⟧ h    ≈⟨ bounded-loop h (m≤n+m _ _) ⟩∎
  never            ∎)
  where
  h : Heap (c + 1)
  h = record
    { size  = 0
    ; bound = zero≤ _
    }


------------------------------------------------------------------------
-- Up-to techniques for the delay monad and the alternative
-- coinductive definition of weak bisimilarity
------------------------------------------------------------------------

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

open import Prelude

module Bisimilarity.Weak.Alternative.Up-to.Delay-monad
         {a} {A : Type a} where

open import Delay-monad
import Delay-monad.Bisimilarity as B
import Delay-monad.Partial-order as P
open import Equality.Propositional as Eq
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Excluded-middle equality-with-J
open import Function-universe equality-with-J hiding (id)
open import H-level equality-with-J

import Bisimilarity.Weak.Alternative.Equational-reasoning-instances
import Bisimilarity.Weak.Delay-monad as W′
open import Bisimilarity.Weak.Equivalent
open import Equational-reasoning
open import Labelled-transition-system
open import Labelled-transition-system.Delay-monad A
open import Relation

open import Bisimilarity.Step (weak delay-monad) _[_]⇒̂_ _[_]⇒̂_
open import Bisimilarity.Up-to (weak delay-monad)
import Bisimilarity.Weak delay-monad as BW
open import Bisimilarity.Weak.Alternative delay-monad

-- Everything is an up-to technique for the alternative coinductive
-- definition of weak bisimilarity for the delay monad (if A is a set,
-- and assuming excluded middle and extensionality).

everything-up-to :
  Excluded-middle a →
  Eq.Extensionality a a →
  Is-set A →
  (F : Trans₂ a (Delay A ∞)) →
  Up-to-technique F
everything-up-to em ext A-set F {R = R} R-prog {x = x , y} =
  everything-up-to′ x y
  where
  lemma :
    ∀ {x y} {P : Rel₂ a (Delay A ∞)} →
    (∀ {x′ z} → x [ just z ]⇒̂ x′ →
     ∃ λ y′ → y [ just z ]⇒̂ y′ × P (x′ , y′)) →
    (∃ λ z → now z B.≈ x) →
    x ≈ y
  lemma {x} {y} hyp = uncurry λ z →
    now z B.≈ x                              ↝⟨ _⇔_.to W′.direct⇔alternative ⟩
    now z ≈ x                                ↝⟨ (λ nz≈x → Σ-map id proj₁ $ left-to-right nz≈x (⟶→⇒̂ now)) ⟩
    ∃ (x [ just z ]⇒̂_)                       ↝⟨ (λ x⇒̂ → x⇒̂ , Σ-map id proj₁ (hyp (proj₂ x⇒̂))) ⟩
    ∃ (x [ just z ]⇒̂_) × ∃ (y [ just z ]⇒̂_)  ↝⟨ (uncurry λ x⇒̂ y⇒̂ → W′.⇒̂-with-equal-labels→≈ id (proj₂ x⇒̂) (proj₂ y⇒̂)) ⟩
    x BW.≈ y                                 ↝⟨ ⇒alternative ⟩□
    x ≈ y                                    □

  everything-up-to′ : ∀ x y → R (x , y) → x ≈ y
  everything-up-to′ x y Rxy =
    case P.⇑⊎⇓ em ext A-set x ,′ P.⇑⊎⇓ em ext A-set y of λ where
      (inj₂ x⇓ , _)       → lemma (StepC.left-to-right (R-prog Rxy)) x⇓
      (_       , inj₂ y⇓) → symmetric
                              (lemma (StepC.right-to-left (R-prog Rxy))
                                     y⇓)
      (inj₁ x⇑ , inj₁ y⇑) →
        x      ∼⟨ symmetric (_⇔_.to W′.direct⇔alternative x⇑) ⟩
        never  ∼⟨ _⇔_.to W′.direct⇔alternative y⇑ ⟩■
        y


------------------------------------------------------------------------------
-- Properties related with lists
------------------------------------------------------------------------------

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

module FOTC.Data.List.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Conat
open import FOTC.Data.List
open import FOTC.Data.Nat.Type

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

postulate ++-leftCong : ∀ {xs ys zs} → xs ≡ ys → xs ++ zs ≡ ys ++ zs
{-# ATP prove ++-leftCong #-}

postulate mapCong₂ : ∀ {f xs ys} → xs ≡ ys → map f xs ≡ map f ys
{-# ATP prove mapCong₂ #-}

------------------------------------------------------------------------------
-- Totality properties

++-List : ∀ {xs ys} → List xs → List ys → List (xs ++ ys)
++-List {ys = ys} lnil Lys = prf
  where postulate prf : List ([] ++ ys)
        {-# ATP prove prf #-}

++-List {ys = ys} (lcons x {xs} Lxs) Lys = prf (++-List Lxs Lys)
  where postulate prf : List (xs ++ ys) → List ((x ∷ xs) ++ ys)
        {-# ATP prove prf #-}

map-List : ∀ f {xs} → List xs → List (map f xs)
map-List f lnil = prf
  where postulate prf : List (map f [])
        {-# ATP prove prf #-}
map-List f (lcons x {xs} Lxs) = prf (map-List f Lxs)
  where postulate prf : List (map f xs) → List (map f (x ∷ xs))
        {-# ATP prove prf #-}

rev-List : ∀ {xs ys} → List xs → List ys → List (rev xs ys)
rev-List {ys = ys} lnil Lys = prf
  where postulate prf : List (rev [] ys)
        {-# ATP prove prf #-}
rev-List {ys = ys} (lcons x {xs} Lxs) Lys = prf (rev-List Lxs (lcons x Lys))
  where postulate prf : List (rev xs (x ∷ ys)) → List (rev (x ∷ xs) ys)
        {-# ATP prove prf #-}

postulate reverse-List : ∀ {xs} → List xs → List (reverse xs)
{-# ATP prove reverse-List rev-List #-}

-- Length properties

length-replicate : ∀ x {n} → N n → length (replicate n x) ≡ n
length-replicate x nzero = prf
  where postulate prf : length (replicate zero x) ≡ zero
        {-# ATP prove prf #-}
length-replicate x (nsucc {n} Nn) = prf (length-replicate x Nn)
  where postulate prf : length (replicate n x) ≡ n →
                        length (replicate (succ₁ n) x) ≡ succ₁ n
        {-# ATP prove prf #-}

postulate lg-xs≡∞→lg-x∷xs≡∞ : ∀ x xs → length xs ≡ ∞ → length (x ∷ xs) ≡ ∞
{-# ATP prove lg-xs≡∞→lg-x∷xs≡∞ #-}

-- Append properties

++-leftIdentity : ∀ xs → [] ++ xs ≡ xs
++-leftIdentity = ++-[]

++-rightIdentity : ∀ {xs} → List xs → xs ++ [] ≡ xs
++-rightIdentity lnil = prf
  where postulate prf : [] ++ [] ≡ []
        {-# ATP prove prf #-}

++-rightIdentity (lcons x {xs} Lxs) = prf (++-rightIdentity Lxs)
  where postulate prf : xs ++ [] ≡ xs → (x ∷ xs) ++ [] ≡ x ∷ xs
        {-# ATP prove prf #-}

++-assoc : ∀ {xs} → List xs → ∀ ys zs → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
++-assoc .{[]} lnil ys zs = prf
  where postulate prf : ([] ++ ys) ++ zs ≡ [] ++ ys ++ zs
        {-# ATP prove prf #-}

++-assoc .{x ∷ xs} (lcons x {xs} Lxs) ys zs = prf (++-assoc Lxs ys zs)
  where postulate prf : (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs →
                        ((x ∷ xs) ++ ys) ++ zs ≡ (x ∷ xs) ++ ys ++ zs
        {-# ATP prove prf #-}

-- Map properties

map-++ : ∀ f {xs} → List xs → ∀ ys → map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++ f lnil ys = prf
  where postulate prf : map f ([] ++ ys) ≡ map f [] ++ map f ys
        {-# ATP prove prf #-}

map-++ f (lcons x {xs} Lxs) ys = prf (map-++ f Lxs ys)
  where postulate prf : map f (xs ++ ys) ≡ map f xs ++ map f ys →
                        map f ((x ∷ xs) ++ ys) ≡ map f (x ∷ xs) ++ map f ys
        {-# ATP prove prf #-}

-- Reverse properties

postulate reverse-[x]≡[x] : ∀ x → reverse (x ∷ []) ≡ x ∷ []
{-# ATP prove reverse-[x]≡[x] #-}

rev-++ : ∀ {xs} → List xs → ∀ ys → rev xs ys ≡ rev xs [] ++ ys
rev-++ lnil ys = prf
  where postulate prf : rev [] ys ≡ rev [] [] ++ ys
        {-# ATP prove prf #-}
rev-++ (lcons x {xs} Lxs) ys = prf (rev-++ Lxs (x ∷ ys)) (rev-++ Lxs (x ∷ []))
  where postulate prf : rev xs (x ∷ ys) ≡ rev xs [] ++ x ∷ ys →
                        rev xs (x ∷ []) ≡ rev xs [] ++ x ∷ [] →
                        rev (x ∷ xs) ys ≡ rev (x ∷ xs) [] ++ ys
        {-# ATP prove prf ++-assoc rev-List #-}

reverse-++ : ∀ {xs ys} → List xs → List ys →
             reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++ {ys = ys} lnil Lys = prf
  where postulate prf : reverse ([] ++ ys) ≡ reverse ys ++ reverse []
        {-# ATP prove prf ++-rightIdentity reverse-List #-}

reverse-++ (lcons x {xs} Lxs) lnil = prf
  where
  postulate prf : reverse ((x ∷ xs) ++ []) ≡ reverse [] ++ reverse (x ∷ xs)
  {-# ATP prove prf ++-rightIdentity #-}

reverse-++ (lcons x {xs} Lxs) (lcons y {ys} Lys) =
  prf (reverse-++ Lxs (lcons y Lys))
  where
  postulate prf : reverse (xs ++ y ∷ ys) ≡ reverse (y ∷ ys) ++
                                           reverse xs →
                  reverse ((x ∷ xs) ++ y ∷ ys) ≡ reverse (y ∷ ys) ++
                                                 reverse (x ∷ xs)
  {-# ATP prove prf reverse-List ++-List rev-++ ++-assoc #-}

reverse-∷ : ∀ x {ys} → List ys →
            reverse (x ∷ ys) ≡ reverse ys ++ (x ∷ [])
reverse-∷ x lnil = prf
  where postulate prf : reverse (x ∷ []) ≡ reverse [] ++ x ∷ []
        {-# ATP prove prf #-}

reverse-∷ x (lcons y {ys} Lys) = prf
  where postulate prf : reverse (x ∷ y ∷ ys) ≡ reverse (y ∷ ys) ++ x ∷ []
        {-# ATP prove prf reverse-[x]≡[x] reverse-++ #-}

reverse-involutive : ∀ {xs} → List xs → reverse (reverse xs) ≡ xs
reverse-involutive lnil = prf
  where postulate prf : reverse (reverse []) ≡ []
        {-# ATP prove prf #-}

reverse-involutive (lcons x {xs} Lxs) = prf (reverse-involutive Lxs)
  where
  postulate prf : reverse (reverse xs) ≡ xs →
                  reverse (reverse (x ∷ xs)) ≡ x ∷ xs
  {-# ATP prove prf rev-List reverse-++ ++-List ++-rightIdentity #-}


------------------------------------------------------------------------------
-- Issue in the translation of definitions using λ-terms.
------------------------------------------------------------------------------

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

module Issue2b where

postulate
  D   : Set
  _≡_ : D → D → Set

-- The translations of foo₁ and foo₂ should be the same.
foo₁ : D → D → D
foo₁ d _ = d
{-# ATP definition foo₁ #-}

foo₂ : D → D → D
foo₂ = λ d _ → d
{-# ATP definition foo₂ #-}

postulate bar₁ : ∀ d e → d ≡ foo₁ d e
{-# ATP prove bar₁ #-}

postulate bar₂ : ∀ d e → d ≡ foo₂ d e
{-# ATP prove bar₂ #-}


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

module Proofs where

-- Various general lemmas

open import Level using (Level)

open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst; cong)
open import Data.Sum using (inj₁; inj₂)
open import Data.Empty

open import Data.Nat.Properties.Simple using ()

----------------------------------------------
-- re-open some sub-files 'public'
open import FiniteFunctions public
open import VectorLemmas public
open import SubstLemmas public
open import LeqLemmas public
open import FinNatLemmas public
open import PathLemmas public

---------------------------------------------
-- Some generally useful functions

-- From Alan Jeffrey's post to Agda list

_⊨_⇒_≡_ : ∀ {I : Set} (F : I → Set) {i j} →
  (i ≡ j) → (F i) → (F j) → Set
(F ⊨ refl ⇒ x ≡ y) = (x ≡ y)

xcong : ∀ {I J F G} (f : I → J) (g : ∀ {i} → F i → G (f i)) →
  ∀ {i j} (i≡j : i ≡ j) {x y} →
    (F ⊨ i≡j ⇒ x ≡ y) → (G ⊨ cong f i≡j ⇒ g x ≡ g y)
xcong f g refl refl = refl

congD! : {a b : Level} {A : Set a} {B : A → Set b}
         (f : (x : A) → B x) → {x₁ x₂ : A} → (x₂≡x₁ : x₂ ≡ x₁) →
         subst B x₂≡x₁ (f x₂) ≡ f x₁
congD! f refl = refl

-- Courtesy of Wolfram Kahl, a dependent cong₂

cong₂D! : {a b c : Level} {A : Set a} {B : A → Set b} {C : Set c}
         (f : (x : A) → B x → C)
       → {x₁ x₂ : A} {y₁ : B x₁} {y₂ : B x₂}
       → (x₂≡x₁ : x₂ ≡ x₁) → subst B x₂≡x₁ y₂ ≡ y₁ → f x₁ y₁ ≡ f x₂ y₂
cong₂D! f refl refl = refl

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

inj-injective : ∀ {A B : Set} {a : A} {b : B} → inj₁ a ≡ inj₂ b → ⊥
inj-injective ()