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

open import lib.Basics
open import lib.types.Span
open import lib.types.Pointed
open import lib.types.Pushout
open import lib.types.PushoutFlattening
open import lib.types.Unit
open import lib.types.Paths
open import lib.types.Lift
open import lib.cubical.Square

-- Suspension is defined as a particular case of pushout

module lib.types.Suspension where

module _ {i} (A : Type i) where

  suspension-span : Span
  suspension-span = span Unit Unit A (λ _ → tt) (λ _ → tt)

  Suspension : Type i
  Suspension = Pushout suspension-span

  -- [north'] and [south'] explictly ask for [A]

  north' : Suspension
  north' = left tt

  south' : Suspension
  south' = right tt

module _ {i} {A : Type i} where

  north : Suspension A
  north = north' A

  south : Suspension A
  south = south' A

  merid : A → north == south
  merid x = glue x

  module SuspensionElim {j} {P : Suspension A → Type j} (n : P north)
    (s : P south) (p : (x : A) → n == s [ P ↓ merid x ]) where
    open module P = PushoutElim (λ _ → n) (λ _ → s) p
      public using (f) renaming (glue-β to merid-β)

  open SuspensionElim public using () renaming (f to Suspension-elim)

  module SuspensionRec {j} {C : Type j} (n s : C) (p : A → n == s) where
    open module P = PushoutRec {d = suspension-span A} (λ _ → n) (λ _ → s) p
      public using (f) renaming (glue-β to merid-β)

  open SuspensionRec public using () renaming (f to Suspension-rec)

  module SuspensionRecType {j} (n s : Type j) (p : A → n ≃ s)
    = PushoutRecType {d = suspension-span A} (λ _ → n) (λ _ → s) p

suspension-⊙span : ∀ {i} → Ptd i → ⊙Span
suspension-⊙span X =
  ⊙span ⊙Unit ⊙Unit X (⊙cst {X = X}) (⊙cst {X = X})

⊙Susp : ∀ {i} → Ptd i → Ptd i
⊙Susp (A , _) = ⊙[ Suspension A , north ]

σloop : ∀ {i} (X : Ptd i) → fst X → north' (fst X) == north' (fst X)
σloop (_ , x₀) x = merid x ∙ ! (merid x₀)

σloop-pt : ∀ {i} {X : Ptd i} → σloop X (snd X) == idp
σloop-pt {X = (_ , x₀)} = !-inv-r (merid x₀)

module FlipSusp {i} {A : Type i} = SuspensionRec
  (south' A) north (! ∘ merid)

flip-susp : ∀ {i} {A : Type i} → Suspension A → Suspension A
flip-susp = FlipSusp.f

⊙flip-susp : ∀ {i} (X : Ptd i) → fst (⊙Susp X ⊙→ ⊙Susp X)
⊙flip-susp X = (flip-susp , ! (merid (snd X)))

module _ {i j} where

  module SuspFmap {A : Type i} {B : Type j} (f : A → B) =
    SuspensionRec north south (merid ∘ f)

  susp-fmap : {A : Type i} {B : Type j} (f : A → B)
    → (Suspension A → Suspension B)
  susp-fmap = SuspFmap.f

  ⊙susp-fmap : {X : Ptd i} {Y : Ptd j} (f : fst (X ⊙→ Y))
    → fst (⊙Susp X ⊙→ ⊙Susp Y)
  ⊙susp-fmap (f , fpt) = (susp-fmap f , idp)

module _ {i} where

  susp-fmap-idf : (A : Type i) → ∀ a → susp-fmap (idf A) a == a
  susp-fmap-idf A = Suspension-elim idp idp $ λ a →
    ↓-='-in (ap-idf (merid a) ∙ ! (SuspFmap.merid-β (idf A) a))

  ⊙susp-fmap-idf : (X : Ptd i)
    → ⊙susp-fmap (⊙idf X) == ⊙idf (⊙Susp X)
  ⊙susp-fmap-idf X = ⊙λ= (susp-fmap-idf (fst X)) idp

module _ {i j} where

  susp-fmap-cst : {A : Type i} {B : Type j} (b : B)
    (a : Suspension A) → susp-fmap (cst b) a == north
  susp-fmap-cst b = Suspension-elim idp (! (merid b)) $ (λ a →
    ↓-app=cst-from-square $ SuspFmap.merid-β (cst b) a ∙v⊡ tr-square _)

  ⊙susp-fmap-cst : {X : Ptd i} {Y : Ptd j}
    → ⊙susp-fmap (⊙cst {X = X} {Y = Y}) == ⊙cst
  ⊙susp-fmap-cst = ⊙λ= (susp-fmap-cst _) idp

module _ {i j k} where

  susp-fmap-∘ : {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
    (σ : Suspension A) → susp-fmap (g ∘ f) σ == susp-fmap g (susp-fmap f σ)
  susp-fmap-∘ g f = Suspension-elim
    idp
    idp
    (λ a → ↓-='-in $
      ap-∘ (susp-fmap g) (susp-fmap f) (merid a)
      ∙ ap (ap (susp-fmap g)) (SuspFmap.merid-β f a)
      ∙ SuspFmap.merid-β g (f a)
      ∙ ! (SuspFmap.merid-β (g ∘ f) a))

  ⊙susp-fmap-∘ : {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
    (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
    → ⊙susp-fmap (g ⊙∘ f) == ⊙susp-fmap g ⊙∘ ⊙susp-fmap f
  ⊙susp-fmap-∘ g f = ⊙λ= (susp-fmap-∘ (fst g) (fst f)) idp

{- Extract the 'glue component' of a pushout -}
module _ {i j k} {s : Span {i} {j} {k}} where

  module ExtGlue = PushoutRec {d = s} {D = Suspension (Span.C s)}
    (λ _ → north) (λ _ → south) merid

  ext-glue = ExtGlue.f

  module _ {x₀ : Span.A s} where

    ⊙ext-glue :
      fst ((Pushout s , left x₀) ⊙→ (Suspension (Span.C s) , north))
    ⊙ext-glue = (ext-glue , idp)

module _ {i j} {A : Type i} {B : Type j} where

  equiv-Suspension : A ≃ B → Suspension A ≃ Suspension B
  equiv-Suspension eq = equiv to from to-from from-to where
    module To = SuspensionRec north south (λ a → merid (–> eq a))
    module From = SuspensionRec north south (λ b → merid (<– eq b))

    to : Suspension A → Suspension B
    to = To.f

    from : Suspension B → Suspension A
    from = From.f

    to-from : ∀ b → to (from b) == b
    to-from = Suspension-elim idp idp to-from-merid where
      to-from-merid : ∀ b → idp == idp [ (λ b → to (from b) == b) ↓ merid b ]
      to-from-merid b = ↓-app=idf-in $
        idp ∙' merid b
          =⟨ ∙'-unit-l (merid b) ⟩
        merid b
          =⟨ ! $ <–-inv-r eq b |in-ctx merid ⟩
        merid (–> eq (<– eq b))
          =⟨ ! $ To.merid-β (<– eq b) ⟩
        ap to (merid (<– eq b))
          =⟨ ! $ From.merid-β b |in-ctx ap To.f ⟩
        ap to (ap from (merid b))
          =⟨ ! $ ap-∘ to from (merid b) ⟩
        ap (to ∘ from) (merid b)
          =⟨ ! $ ∙-unit-r (ap (to ∘ from) (merid b)) ⟩
        ap (to ∘ from) (merid b) ∙ idp
          ∎

    from-to : ∀ a → from (to a) == a
    from-to = Suspension-elim idp idp from-to-merid where
      from-to-merid : ∀ a → idp == idp [ (λ a → from (to a) == a) ↓ merid a ]
      from-to-merid a = ↓-app=idf-in $
        idp ∙' merid a
          =⟨ ∙'-unit-l (merid a) ⟩
        merid a
          =⟨ ! $ <–-inv-l eq a |in-ctx merid ⟩
        merid (<– eq (–> eq a))
          =⟨ ! $ From.merid-β (–> eq a) ⟩
        ap from (merid (–> eq a))
          =⟨ ! $ To.merid-β a |in-ctx ap From.f ⟩
        ap from (ap to (merid a))
          =⟨ ! $ ap-∘ from to (merid a) ⟩
        ap (from ∘ to) (merid a)
          =⟨ ! $ ∙-unit-r (ap (from ∘ to) (merid a)) ⟩
        ap (from ∘ to) (merid a) ∙ idp
          ∎

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  ⊙equiv-⊙Susp : X ⊙≃ Y → ⊙Susp X ⊙≃ ⊙Susp Y
  ⊙equiv-⊙Susp ⊙eq = ⊙≃-in (equiv-Suspension (fst (⊙≃-out ⊙eq))) idp

{- Interaction with [Lift] -}
module _ {i j} (X : Type i) where

  Suspension-Lift-equiv-Lift-Suspension : Suspension (Lift {j = j} X) ≃ Lift {j = j} (Suspension X)
  Suspension-Lift-equiv-Lift-Suspension = lift-equiv ∘e equiv-Suspension lower-equiv

  Suspension-Lift : Suspension (Lift {j = j} X) == Lift {j = j} (Suspension X)
  Suspension-Lift = ua Suspension-Lift-equiv-Lift-Suspension

module _ {i j} (X : Ptd i) where

  ⊙Susp-⊙Lift-⊙equiv-⊙Lift-⊙Susp : ⊙Susp (⊙Lift {j = j} X) ⊙≃ ⊙Lift {j = j} (⊙Susp X)
  ⊙Susp-⊙Lift-⊙equiv-⊙Lift-⊙Susp = ⊙lift-equiv {j = j} ⊙∘e ⊙equiv-⊙Susp {X = ⊙Lift {j = j} X} {Y = X} ⊙lower-equiv

  ⊙Susp-⊙Lift : ⊙Susp (⊙Lift {j = j} X) == ⊙Lift {j = j} (⊙Susp X)
  ⊙Susp-⊙Lift = ⊙ua ⊙Susp-⊙Lift-⊙equiv-⊙Lift-⊙Susp


open import Agda.Builtin.Unit
open import Agda.Builtin.Sigma
open import Agda.Builtin.List
open import Agda.Builtin.Equality
open import Agda.Builtin.Reflection renaming (bindTC to infixl 4 _>>=_)

macro
  quoteDef : Name → Term → TC ⊤
  quoteDef f hole = (getDefinition f >>= quoteTC) >>= unify hole

postulate
  A : Set
  B : A → Set

-- foo is projection-like
foo : (x : A) → B x → B x
foo x y = y

pattern vArg x = arg (arg-info visible relevant) x

test : quoteDef foo ≡
  function
    (clause
     (("x" , vArg (def (quote A) [])) ∷
      ("y" , vArg (def (quote B) (vArg (var 0 []) ∷ [])))
      ∷ [])
     (vArg (var 1) ∷ vArg (var 0) ∷ [])
     (var 0 [])
     ∷ [])
test = refl


-- Andreas, 2019-05-30, issue #3824:
-- Named where module should be in scope even if defined under a rewrite.

open import Agda.Builtin.Equality

postulate
  A   : Set
  a b : A
  a≡b : a ≡ b
  P   : A → Set

cast : P a → P b
cast p rewrite a≡b = q
  module M where
    q = p

test : P b → P b
test = M.q

-- ERROR WAS: M.q not in scope.

module Test = M

-- ERROR WAS: M not in scope.

-- Should succeed.


module ProofUtilities where

-- open import Data.Nat hiding (_>_)

open import StdLibStuff

open import Syntax
open import FSC

mutual
 hn-left-i : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t α) (F : Form Γ-t β) (G : Form Γ-t α) → Γ ⊢ α ∋ S (headNorm m F) ↔ G → Γ ⊢ α ∋ S F ↔ G
 hn-left-i m S (app F H) G p = hn-left-i m (λ x → S (app x H)) F G (hn-left-i' m S (headNorm m F) H G p)
 hn-left-i _ _ (var _ _) _ p = p
 hn-left-i _ _ N _ p = p
 hn-left-i _ _ A _ p = p
 hn-left-i _ _ Π _ p = p
 hn-left-i _ _ i _ p = p
 hn-left-i _ _ (lam _ _) _ p = p

 hn-left-i' : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β γ : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t α) (F : Form Γ-t (γ > β)) (H : Form Γ-t γ) (G : Form Γ-t α) → Γ ⊢ α ∋ S (headNorm' m F H) ↔ G → Γ ⊢ α ∋ S (app F H) ↔ G
 hn-left-i' (suc m) S (lam _ F) H G p with hn-left-i m S (sub H F) G p
 hn-left-i' (suc _) S (lam _ _) _ _ _ |    p' = reduce-l {_} {_} {_} {_} {_} {_} {S} p'
 hn-left-i' 0 _ (lam _ _) _ _ p = p
 hn-left-i' zero _ (var _ _) _ _ p = p
 hn-left-i' (suc _) _ (var _ _) _ _ p = p
 hn-left-i' zero _ N _ _ p = p
 hn-left-i' (suc _) _ N _ _ p = p
 hn-left-i' zero _ A _ _ p = p
 hn-left-i' (suc _) _ A _ _ p = p
 hn-left-i' zero _ Π _ _ p = p
 hn-left-i' (suc _) _ Π _ _ p = p
 hn-left-i' zero _ i _ _ p = p
 hn-left-i' (suc _) _ i _ _ p = p
 hn-left-i' zero _ (app _ _) _ _ p = p
 hn-left-i' (suc _) _ (app _ _) _ _ p = p

hn-left : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α : Type n} (m : ℕ) (F : Form Γ-t α) (G : Form Γ-t α) → Γ ⊢ α ∋ headNorm m F ↔ G → Γ ⊢ α ∋ F ↔ G
hn-left m F G p = hn-left-i m (λ x → x) F G p

mutual
 hn-right-i : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t α) (F : Form Γ-t β) (G : Form Γ-t α) → Γ ⊢ α ∋ G ↔ S (headNorm m F) → Γ ⊢ α ∋ G ↔ S F
 hn-right-i m S (app F H) G p = hn-right-i m (λ x → S (app x H)) F G (hn-right-i' m S (headNorm m F) H G p)
 hn-right-i _ _ (var _ _) _ p = p
 hn-right-i _ _ N _ p = p
 hn-right-i _ _ A _ p = p
 hn-right-i _ _ Π _ p = p
 hn-right-i _ _ i _ p = p
 hn-right-i _ _ (lam _ _) _ p = p

 hn-right-i' : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β γ : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t α) (F : Form Γ-t (γ > β)) (H : Form Γ-t γ) (G : Form Γ-t α) → Γ ⊢ α ∋ G ↔ S (headNorm' m F H) → Γ ⊢ α ∋ G ↔ S (app F H)
 hn-right-i' (suc m) S (lam _ F) H G p with hn-right-i m S (sub H F) G p
 hn-right-i' (suc _) S (lam _ _) _ _ _ |    p' = reduce-r {_} {_} {_} {_} {_} {_} {S} p'
 hn-right-i' 0 _ (lam _ _) _ _ p = p
 hn-right-i' zero _ (var _ _) _ _ p = p
 hn-right-i' (suc _) _ (var _ _) _ _ p = p
 hn-right-i' zero _ N _ _ p = p
 hn-right-i' (suc _) _ N _ _ p = p
 hn-right-i' zero _ A _ _ p = p
 hn-right-i' (suc _) _ A _ _ p = p
 hn-right-i' zero _ Π _ _ p = p
 hn-right-i' (suc _) _ Π _ _ p = p
 hn-right-i' zero _ i _ _ p = p
 hn-right-i' (suc _) _ i _ _ p = p
 hn-right-i' zero _ (app _ _) _ _ p = p
 hn-right-i' (suc _) _ (app _ _) _ _ p = p

hn-right : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α : Type n} (m : ℕ) (F : Form Γ-t α) (G : Form Γ-t α) → Γ ⊢ α ∋ G ↔ headNorm m F → Γ ⊢ α ∋ G ↔ F
hn-right m F G p = hn-right-i m (λ x → x) F G p

mutual
 hn-succ-i : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {β : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t β) → Γ ⊢ S (headNorm m F) → Γ ⊢ S F
 hn-succ-i m S (app F H) p = hn-succ-i m (λ x → S (app x H)) F (hn-succ-i' m S (headNorm m F) H p)
 hn-succ-i _ _ (var _ _) p = p
 hn-succ-i _ _ N p = p
 hn-succ-i _ _ A p = p
 hn-succ-i _ _ Π p = p
 hn-succ-i _ _ i p = p
 hn-succ-i _ _ (lam _ _) p = p

 hn-succ-i' : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {β γ : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t (γ > β)) (H : Form Γ-t γ) → Γ ⊢ S (headNorm' m F H) → Γ ⊢ S (app F H)
 hn-succ-i' (suc m) S (lam _ F) H p with hn-succ-i m S (sub H F) p
 hn-succ-i' (suc _) S (lam _ _) _ _ |    p' = reduce {_} {_} {_} {_} {_} {S} p'
 hn-succ-i' 0 _ (lam _ _) _ p = p
 hn-succ-i' zero _ (var _ _) _ p = p
 hn-succ-i' (suc _) _ (var _ _) _ p = p
 hn-succ-i' zero _ N _ p = p
 hn-succ-i' (suc _) _ N _ p = p
 hn-succ-i' zero _ A _ p = p
 hn-succ-i' (suc _) _ A _ p = p
 hn-succ-i' zero _ Π _ p = p
 hn-succ-i' (suc _) _ Π _ p = p
 hn-succ-i' zero _ i _ p = p
 hn-succ-i' (suc _) _ i _ p = p
 hn-succ-i' zero _ (app _ _) _ p = p
 hn-succ-i' (suc _) _ (app _ _) _ p = p

hn-succ : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} (m : ℕ) (F : Form Γ-t $o) → Γ ⊢ headNorm m F → Γ ⊢ F
hn-succ m F p = hn-succ-i m (λ x → x) F p

mutual
 hn-ante-i : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {β : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t β) (G : Form Γ-t $o) → Γ , S (headNorm m F) ⊢ G → Γ , S F ⊢ G
 hn-ante-i m S (app F H) G p = hn-ante-i m (λ x → S (app x H)) F G (hn-ante-i' m S (headNorm m F) H G p)
 hn-ante-i _ _ (var _ _) _ p = p
 hn-ante-i _ _ N _ p = p
 hn-ante-i _ _ A _ p = p
 hn-ante-i _ _ Π _ p = p
 hn-ante-i _ _ i _ p = p
 hn-ante-i _ _ (lam _ _) _ p = p

 hn-ante-i' : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {β γ : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t (γ > β)) (H : Form Γ-t γ) (G : Form Γ-t $o) → Γ , S (headNorm' m F H) ⊢ G → Γ , S (app F H) ⊢ G
 hn-ante-i' (suc m) S (lam _ F) H G p with hn-ante-i m S (sub H F) G p
 hn-ante-i' (suc _) S (lam _ _) _ _ _ |    p' = reduce {_} {_} {_} {_} {_} {S} p'
 hn-ante-i' 0 _ (lam _ _) _ _ p = p
 hn-ante-i' zero _ (var _ _) _ _ p = p
 hn-ante-i' (suc _) _ (var _ _) _ _ p = p
 hn-ante-i' zero _ N _ _ p = p
 hn-ante-i' (suc _) _ N _ _ p = p
 hn-ante-i' zero _ A _ _ p = p
 hn-ante-i' (suc _) _ A _ _ p = p
 hn-ante-i' zero _ Π _ _ p = p
 hn-ante-i' (suc _) _ Π _ _ p = p
 hn-ante-i' zero _ i _ _ p = p
 hn-ante-i' (suc _) _ i _ _ p = p
 hn-ante-i' zero _ (app _ _) _ _ p = p
 hn-ante-i' (suc _) _ (app _ _) _ _ p = p

hn-ante : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} (m : ℕ) (F : Form Γ-t $o) (G : Form Γ-t $o) → Γ , headNorm m F ⊢ G → Γ , F ⊢ G
hn-ante m F G p = hn-ante-i m (λ x → x) F G p

mutual
 hn-ante-eq-i : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t β) (G H : Form Γ-t α) → Γ , S (headNorm m F) ⊢ G == H → Γ , S F ⊢ G == H
 hn-ante-eq-i m S (app F I) G H p = hn-ante-eq-i m (λ x → S (app x I)) F G H (hn-ante-eq-i' m S (headNorm m F) I G H p)
 hn-ante-eq-i _ _ (var _ _) _ _ p = p
 hn-ante-eq-i _ _ N _ _ p = p
 hn-ante-eq-i _ _ A _ _ p = p
 hn-ante-eq-i _ _ Π _ _ p = p
 hn-ante-eq-i _ _ i _ _ p = p
 hn-ante-eq-i _ _ (lam _ _) _ _ p = p

 hn-ante-eq-i' : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α β γ : Type n} (m : ℕ) (S : Form Γ-t β → Form Γ-t $o) (F : Form Γ-t (γ > β)) (I : Form Γ-t γ) (G H : Form Γ-t α) → Γ , S (headNorm' m F I) ⊢ G == H → Γ , S (app F I) ⊢ G == H
 hn-ante-eq-i' (suc m) S (lam _ F) I G H p with hn-ante-eq-i m S (sub I F) G H p
 hn-ante-eq-i' (suc _) S (lam _ _) _ _ _ _ |    p' = reduce {_} {_} {_} {_} {_} {_} {S} p'
 hn-ante-eq-i' 0 _ (lam _ _) _ _ _ p = p
 hn-ante-eq-i' zero _ (var _ _) _ _ _ p = p
 hn-ante-eq-i' (suc _) _ (var _ _) _ _ _ p = p
 hn-ante-eq-i' zero _ N _ _ _ p = p
 hn-ante-eq-i' (suc _) _ N _ _ _ p = p
 hn-ante-eq-i' zero _ A _ _ _ p = p
 hn-ante-eq-i' (suc _) _ A _ _ _ p = p
 hn-ante-eq-i' zero _ Π _ _ _ p = p
 hn-ante-eq-i' (suc _) _ Π _ _ _ p = p
 hn-ante-eq-i' zero _ i _ _ _ p = p
 hn-ante-eq-i' (suc _) _ i _ _ _ p = p
 hn-ante-eq-i' zero _ (app _ _) _ _ _ p = p
 hn-ante-eq-i' (suc _) _ (app _ _) _ _ _ p = p

hn-ante-eq : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α : Type n} (m : ℕ) (F : Form Γ-t $o) (G H : Form Γ-t α) → Γ , headNorm m F ⊢ G == H → Γ , F ⊢ G == H
hn-ante-eq m F G H p = hn-ante-eq-i m (λ x → x) F G H p

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

head-& : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {F₁ F₂ G₁ G₂ : Form Γ-t $o} →
 Γ ⊢ $o ∋ F₁ == F₂ → Γ ⊢ $o ∋ G₁ == G₂ →
 Γ ⊢ $o ∋ (F₁ & G₁) ↔ (F₂ & G₂)
head-& p₁ p₂ = head-app _ _ _ _ _ _ (simp (head-const _ N)) (simp (head-app _ _ _ _ _ _ (simp (head-app _ _ _ _ _ _ (simp (head-const _ A)) (simp (head-app _ _ _ _ _ _ (simp (head-const _ N)) p₁)))) (simp (head-app _ _ _ _ _ _ (simp (head-const _ N)) p₂))))

head-|| : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {F₁ F₂ G₁ G₂ : Form Γ-t $o} →
 Γ ⊢ $o ∋ F₁ == F₂ → Γ ⊢ $o ∋ G₁ == G₂ →
 Γ ⊢ $o ∋ (F₁ || G₁) ↔ (F₂ || G₂)
head-|| p₁ p₂ = head-app _ _ _ _ _ _ (simp (head-app _ _ _ _ _ _ (simp (head-const _ A)) p₁)) p₂

head-=> : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {F₁ F₂ G₁ G₂ : Form Γ-t $o} →
 Γ ⊢ $o ∋ F₁ == F₂ → Γ ⊢ $o ∋ G₁ == G₂ →
 Γ ⊢ $o ∋ (F₁ => G₁) ↔ (F₂ => G₂)
head-=> p₁ p₂ = head-app _ _ _ _ _ _ (simp (head-app _ _ _ _ _ _ (simp (head-const _ A)) (simp (head-app _ _ _ _ _ _ (simp (head-const _ N)) p₁)))) p₂

head-~ : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {F₁ F₂ : Form Γ-t $o} →
 Γ ⊢ $o ∋ F₁ == F₂ →
 Γ ⊢ $o ∋ (~ F₁) ↔ (~ F₂)
head-~ p = head-app _ _ _ _ _ _ (simp (head-const _ N)) p

head-== : {n : ℕ} {Γ-t : Ctx n} {Γ : FSC-Ctx n Γ-t} {α : Type n} {F₁ F₂ G₁ G₂ : Form Γ-t α} →
 Γ ⊢ α ∋ F₁ == F₂ → Γ ⊢ α ∋ G₁ == G₂ →
 Γ ⊢ $o ∋ (F₁ == G₁) ↔ (F₂ == G₂)
head-== p₁ p₂ = head-app _ _ _ _ _ _ (simp (head-app _ _ _ _ _ _ (simp (head-const _ _)) p₁)) p₂


-- We show Gausssian Integers forms an Euclidean domain. The proofs
-- are straightforward.

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

module GauInt.EucDomain where

-- imports from local.

-- Hiding the usual div and mod function. We will the new instance in
-- Integer.EucDomain2
import Instances hiding (DMℤ)
open Instances

open import Integer.EucDomain2
  renaming (div' to divℤ ; mod' to modℤ ; euc-eq' to euc-eqℤ ; euc-rank' to euc-rankℤ)
open import Integer.Properties

open import GauInt.Base
  using (𝔾 ; _+_i ; _ᶜ ; Re ; Im ; _+0i ; _+0i' ; 0𝔾 ; 1𝔾)
open import GauInt.Properties
open import GauInt.Instances

-- imports from stdlib and Agda.
open import Relation.Nullary using (yes ; no ; ¬_)
open import Relation.Binary.PropositionalEquality

open import Data.Product as P using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Sum as S renaming ([_,_]′ to ⊎-elim)

open import Data.Nat as Nat using (ℕ ; suc ; zero ; z≤n)
import Data.Nat.Properties as NatP
open import Data.Integer as Int
  using (0ℤ ; +0 ; +_ ; _≥_ ; +≤+ ; +[1+_] ; -[1+_] ; ℤ ; ∣_∣)
import Data.Integer.Properties as IntP

import Data.Nat.Solver as NS
import Data.Integer.Solver as IS
import GauInt.Solver as GS
open import Algebra.Properties.Ring +-*-ring
open import Algebra.Definitions (_≡_ {A = 𝔾}) using (AlmostLeftCancellative)

open import Function.Base using (_$_)

-- ----------------------------------------------------------------------
-- Euclidean Structure on 𝔾

-- As explained in the imports part, we will use the div and mod
-- function defined in Integer.EucDomain2.

-- A special case when the divisor is a positive natural number. The proof:
-- Let x = a + b i, and y = d. By integer euc-eq and euc-rank we have
-- step-a : a = ra + qa * d, with rank ra ≤ d / 2.
-- step-b : b = rb + qb * d, with rank rb ≤ d / 2.
-- We let q = qa + qb i, r = ra + rb i. Easy to check that
-- eq : x = r + q y. Slightly harder to check
-- le : rank r ≤ d / 2 (see below).

div' : 𝔾 -> (d : ℕ) -> ¬ d ≡ 0# -> 𝔾
div' n zero n0 with n0 refl
... | ()
div' (a + b i) d@(suc e) n0 = qa + qb i
  where
    qa = a / + d
    qb = b / + d

mod' : 𝔾 -> (d : ℕ) -> ¬ d ≡ 0# -> 𝔾
mod' n zero n0 with n0 refl
... | ()
mod' (a + b i) d@(suc e) n0 = ra + rb i
  where
    ra = a % + d
    rb = b % + d

div : (x y : 𝔾) -> ¬ y ≡ 0# -> 𝔾
div x y n0 = div' (x * y ᶜ) y*yᶜ n0'
  where
    y*yᶜ : ℕ
    y*yᶜ = rank y

    n0' :  ¬ rank y ≡ 0#
    n0' = y≠0#⇒rank≠0 n0

mod : (x y : 𝔾) -> ¬ y ≡ 0# -> 𝔾
mod x y n0 = (x - q * y)
  where
    q = div x y n0

-- ----------------------------------------------------------------------
-- euc-eq and euc-rank property for div' and mod'

-- Dividend = reminder + quotient * divisor.
euc-eq' : ∀ (x : 𝔾) (d : ℕ) (n0 : ¬ d ≡ 0) ->
             let r = mod' x d n0 in let q = div' x d n0 in
             x ≡ r + q * (d +0i)
euc-eq' n zero n0 with n0 refl
... | ()
euc-eq' x@(a + b i) d@(suc e) n0 = eq
  where
    -- setting up q and r.
    n0' : ¬ + d ≡ 0#
    n0' p = n0 (IntP.+-injective p)

    qa = a / + d
    qb = b / + d
    ra = a % + d
    rb = b % + d

    ea : a ≡ ra + qa * + d
    ea = euc-eqℤ a (+ d) n0'
    eb : b ≡ rb + qb * + d
    eb = euc-eqℤ b (+ d) n0'

    q : 𝔾
    q = qa + qb i

    r : 𝔾
    r = ra + rb i

    -- Inject natural number d to Gaussian integer.
    y = d +0i

    -- Proving x = r + q * y.
    eq : x ≡ r + q * y
    eq = begin
        x ≡⟨ refl ⟩
        a + b i ≡⟨ cong (λ x -> x + b i) ea ⟩
        (ra + qa * (+ d)) + b i ≡⟨ cong (λ x -> (ra + qa * (+ d)) + x i) eb ⟩
        (ra + qa * (+ d)) + (rb + qb * (+ d)) i ≡⟨ refl ⟩
        (ra + rb i) + ((qa * (+ d)) + (qb * (+ d)) i) ≡⟨ cong (λ x → (ra + rb i) + ((qa * (+ d)) + x i)) ((solve 3 (λ qa d qb → qb :* d := qa :* con 0ℤ :+ qb :* d) refl) qa (+ d) qb) ⟩
        (ra + rb i) + ((qa * (+ d)) + (qa * 0ℤ + qb * (+ d)) i) ≡⟨ cong (λ x → (ra + rb i) + (x + (qa * 0ℤ + qb * (+ d)) i)) ((solve 3 (λ qa d qb → qa :* d := qa :* d :- qb :* con 0ℤ) refl) qa (+ d) qb) ⟩
        (ra + rb i) + ((qa * (+ d) - qb * 0ℤ) + (qa * 0ℤ + qb * (+ d)) i) ≡⟨ refl ⟩
        (ra + rb i) + (qa + qb i) * y ≡⟨ refl ⟩
        r + q * y ∎
          where
            open IS.+-*-Solver
            open ≡-Reasoning

-- rank r < rank (inj d)
euc-rank' : ∀ (x : 𝔾) (d : ℕ) (n0 : ¬ d ≡ 0) ->
             let r = mod' x d n0 in let q = div' x d n0 in
             rank r < rank (d +0i)
euc-rank' n zero n0 with n0 refl
... | ()
euc-rank' x@(a + b i) d@(suc e) n0 = le
  where
    -- setting up q and r.
    n0' : ¬ + d ≡ 0#
    n0' p = n0 (IntP.+-injective p)

    r : 𝔾
    r = mod' x d n0
    ra = Re r
    rb = Im r

    q : 𝔾
    q = div' x d n0
    qa = Re q
    qb = Im q

    lea : ∣ ra ∣ ≤ d / 2
    lea = euc-rankℤ a (+ d) n0'

    leb : ∣ rb ∣ ≤ d / 2
    leb = euc-rankℤ b (+ d) n0'

    y = d +0i

    -- Proving rank r < rank y.
    -- Some auxillary lemmas.
    lem1 : ∀ {d : ℕ} -> d / 2 + d / 2 ≤ d
    lem1 {d} = begin
      d / 2 + d / 2  ≡⟨ solve 1 (λ x → x :+ x := x :* con 2) refl (d / 2) ⟩
      d / 2 * 2      ≤⟨ NatP.m≤n+m (d / 2 * 2) (d % 2) ⟩
      d % 2 + d / 2 * 2  ≡⟨ (sym $ NatESR.euc-eq d 2 (λ ())) ⟩
      d  ∎
        where
          open NatP.≤-Reasoning
          open NS.+-*-Solver

    lem2 : ∀ {d : Nat.ℕ} -> d / 2 ≤ d
    lem2 {d} = begin
      d / 2  ≤⟨ NatP.m≤n+m (d / 2) (d / 2) ⟩
      d / 2 + d / 2      ≤⟨ lem1 {d} ⟩
      d  ∎
        where
          open NatP.≤-Reasoning
          open NS.+-*-Solver

    lem2-strict : ∀ {d : Nat.ℕ} .{{_ : NonZero d}} -> (d / 2) < d
    lem2-strict {x@(suc d)} with x / 2 Nat.≟ 0
    ... | no ¬p = begin-strict
      x / 2  <⟨ NatP.m<n+m (x / 2) x/2>0 ⟩
      x / 2 + x / 2      ≤⟨ lem1 {x} ⟩
      x  ∎
      where
        open NatP.≤-Reasoning
        open NS.+-*-Solver
        open import Relation.Binary.Definitions
        open import Data.Empty

        x/2>0 : 0 < (x / 2)
        x/2>0 with NatP.<-cmp 0 (x / 2)
        ... | tri< a ¬b ¬c = a
        ... | tri≈ ¬a b ¬c = ⊥-elim (¬p (sym b))
    ... | yes p rewrite p = Nat.s≤s Nat.z≤n

    lem3 : rank y ≡ d * d
    lem3 = begin
      rank y ≡⟨ refl ⟩
      ∣ (+ d) * (+ d) + 0ℤ * 0ℤ ∣  ≡⟨ cong ∣_∣ (solve 1 (λ x → x :* x :+ con 0ℤ :* con 0ℤ := x :* x) refl (+ d)) ⟩
      ∣ (+ d) * (+ d) ∣     ≡⟨ IntP.abs-*-commute (+ d) (+ d) ⟩
      ∣ (+ d) ∣ * ∣ (+ d) ∣     ≡⟨ refl ⟩
      d * d  ∎
        where
          open IS.+-*-Solver
          open ≡-Reasoning

    -- The proof idea:
    -- rank r = ∣ ra * ra + rb * rb ∣ = ∣ ra ∣ * ∣ ra ∣ + ∣ rb ∣ * ∣ rb ∣
    -- ≤ d / 2 * d / 2 + d / 2 * d / 2 by the integer divmod property.
    -- ≤ d * d
    -- = rank y

    le : rank r < rank y
    le = begin-strict
      rank r                ≡⟨ refl ⟩
      let (sa , sae) = (a*a=+b ra) in let (sb , sbe) = a*a=+b rb in
      ∣ ra * ra + rb * rb ∣  ≡⟨ tri-eq' ra rb ⟩
      ∣ ra * ra ∣ + ∣ rb * rb ∣ ≡⟨ cong₂ _+_ (IntP.abs-*-commute ra ra) (IntP.abs-*-commute rb rb) ⟩
      ∣ ra ∣ * ∣ ra ∣ + ∣ rb ∣ * ∣ rb ∣  ≤⟨ NatP.+-mono-≤ (NatP.*-mono-≤ lea lea) (NatP.*-mono-≤ leb leb) ⟩
      (d / 2) * (d / 2) + (d / 2) * (d / 2) ≡⟨ solve 1 (λ x → (x :* x) :+ (x :* x) := x :* (x :+ x)) refl (d / 2) ⟩
      (d / 2) * ((d / 2) + (d / 2)) ≤⟨ NatP.*-monoʳ-≤ (d / 2) lem1 ⟩
      (d / 2) * d <⟨ NatP.*-monoˡ-< d (lem2-strict {d}) ⟩
      d * d                ≡⟨ sym lem3 ⟩
      rank y  ∎
        where
          open NatP.≤-Reasoning
          open NS.+-*-Solver

-- ----------------------------------------------------------------------
-- euc-eq and euc-rank property for div and mod

-- This is the case when the divisor y = c + d i is an arbitrary
-- non-zero Gaussian integer. Easy to see rank y ᶜ = rank y = y * y
-- ᶜ = ∣ c * c + d * d ∣ ≠ 0. Notice that by the previous spcial
-- case (when the divisor is a positive natural number) we have

-- eq' : x * y ᶜ = r' + q' * (y * y ᶜ), and
-- le' : rank r' < rank (y * y ᶜ) = rank y * rank y ᶜ
-- (eq') ⇒ r' = x * y ᶜ - q' * (y * y ᶜ) = (x - q' * y) * y ᶜ
-- ⇒ eqr: rank r' = rank (x - q' * y) * rank y ᶜ
-- (le') & (eqr) ⇒ rank (x - q' * y) < rank y since rank y ᶜ ≠ 0.

-- So setting q = q', and r = x - q' * y as div and mod functions do,
-- then check the euc-rank property holds.

-- Dividend = reminder + quotient * divisor.
euc-eq : ∀ (x y : 𝔾) (n0 : ¬ y ≡ 0𝔾) ->
             let r = mod x y n0 in let q = div x y n0 in
             x ≡ r + q * y
euc-eq x y n0 = claim
  where
    -- Setting up r and q.
    r : 𝔾
    r = mod x y n0
    q : 𝔾
    q = div x y n0

    claim : x ≡ (x - q * y) + q * y
    claim = begin
      x ≡⟨ solve 2 (\ x qy -> x := (x :- qy) :+ qy) refl x (q * y) ⟩
      (x - q * y) + q * y  ∎
      where
        open GS.+-*-Solver
        open ≡-Reasoning

-- rank r < rank y.
euc-rank : ∀ (x y : 𝔾) (n0 : ¬ y ≡ 0#) ->
             let r = mod x y n0 in let q = div x y n0 in
             rank r < rank y
euc-rank x y n0 = claim
  where
    n0' : ¬ rank y ≡ 0#
    n0' = y≠0#⇒rank≠0 n0

    r : 𝔾
    r = mod x y n0
    q : 𝔾
    q = div x y n0

    eq : x ≡ r + q * y
    eq = euc-eq x y n0

    r' : 𝔾
    r' = mod' (x * y ᶜ) (rank y) n0'
    q' : 𝔾
    q' = div' (x * y ᶜ) (rank y) n0'

    eq' : x * y ᶜ ≡ r' + q' * (rank y +0i)
    eq' = euc-eq' (x * y ᶜ) (rank y) n0'

    le' : rank r' < rank (rank y +0i)
    le' = euc-rank' (x * y ᶜ) (rank y) n0'

    q=q' : q ≡ q'
    q=q' = refl

    -- eqr : rank r' = rank (x - q' * y) * rank y ᶜ ---- (3)
    eqr : rank r' ≡ rank (x - q' * y) * rank (y ᶜ)
    eqr = begin
      rank r' ≡⟨ cong rank step ⟩
      rank ((x - q' * y) * y ᶜ) ≡⟨ rank-*-commute (x - q * y) (y ᶜ) ⟩
      rank (x - q' * y) * rank (y ᶜ) ∎
        where
          open ≡-Reasoning
          step : r' ≡ (x - q' * y) * y ᶜ
          step = begin
            r' ≡⟨ solve 2 (λ r x → r := r :+ x :- x) refl r' (q' * (rank y +0i)) ⟩
            r' + q' * (rank y +0i) - q' * (rank y +0i) ≡⟨ cong (_- q' * (rank y +0i)) (sym eq') ⟩
            x * y ᶜ - q' * (rank y +0i) ≡⟨ cong (λ z → x * y ᶜ - q' * z) (sym $ y*yᶜ=rank {y}) ⟩
            x * y ᶜ - q' * (y * y ᶜ) ≡⟨ solve 4 (\ x yc q y -> x :* yc :- q :* ( y :* yc) := (x :- q :* y) :* yc) refl x (y ᶜ) q' y ⟩
            (x - q' * y) * y ᶜ ∎
              where
                open GS.+-*-Solver
                open ≡-Reasoning

    -- (le') & (eqr) ⇒ rank (x - q' * y) < rank y since rank y ᶜ ≠ 0.
    claim : rank (x - q' * y) < rank y
    claim = NatP.*-cancelʳ-< {rank (y ᶜ)} (rank (x - q * y)) (rank y) eqr'
      where
        eqr' : rank (x - q' * y) * rank (y ᶜ) < rank y * rank (y ᶜ)
        eqr' = begin-strict
            rank (x - q' * y) * rank (y ᶜ) ≡⟨ sym eqr ⟩
            rank r' <⟨ le' ⟩
            rank (rank y +0i) ≡⟨ cong rank (sym $ y*yᶜ=rank {y}) ⟩
            rank (y * y ᶜ) ≡⟨ rank-*-commute y (y ᶜ) ⟩
            rank y * rank (y ᶜ) ∎
              where
                open GS.+-*-Solver
                open NatP.≤-Reasoning

-- ----------------------------------------------------------------------
-- 𝔾 is an Euclidean Domain.

import EuclideanDomain
open   EuclideanDomain.Structures (_≡_ {A = 𝔾}) using (IsEuclideanDomain)
open   EuclideanDomain.Bundles using (EuclideanDomainBundle)

+-*-isEuclideanDomain : IsEuclideanDomain _+_ _*_ -_ 0𝔾 1𝔾
+-*-isEuclideanDomain = record
                              { isCommutativeRing = +-*-isCommutativeRing
                              ; *-alc = *-alc-𝔾
                              ; div = div
                              ; mod = mod
                              ; rank = rank
                              ; euc-eq = euc-eq
                              ; euc-rank = euc-rank
                              }

-- Bundle.
+-*-euclideanDomain : EuclideanDomainBundle _ _
+-*-euclideanDomain = record
  { isEuclideanDomain = +-*-isEuclideanDomain'
  }

-- ----------------------------------------------------------------------
-- Making 𝔾 an DivMod instance, overloading div and mod.

-- Translation between two nonzeros.
nz𝔾 : ∀ (x : 𝔾) -> .{{NonZero x}} -> ¬ x ≡ 0#
nz𝔾 (+_ zero + +[1+ n ] i) {{n0}} i0 with i0
... | ()

instance
  g-divmod : DivMod 𝔾
  DivMod.NZT g-divmod = NZT𝔾
  (g-divmod DivMod./ n) d = div n d (nz𝔾 d)
  (g-divmod DivMod.% n) d = mod n d (nz𝔾 d)


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

module PiPointed where

open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product renaming (map to map×)
open import Relation.Binary.PropositionalEquality

open import Singleton
open import PlainPi

infixr 90 _#_

------------------------------------------------------------------------------
-- Pointed types and singleton types

data ∙𝕌 : Set where
  _#_ : (t : 𝕌) → (v : ⟦ t ⟧) → ∙𝕌
  _∙×ᵤ_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  _∙+ᵤl_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  _∙+ᵤr_ : ∙𝕌 → ∙𝕌 → ∙𝕌
  Singᵤ : ∙𝕌 → ∙𝕌

∙⟦_⟧ : ∙𝕌 → Σ[ A ∈ Set ] A
∙⟦ t # v ⟧ = ⟦ t ⟧ , v
∙⟦ T₁ ∙×ᵤ T₂ ⟧ = zip _×_ _,_ ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ T₁ ∙+ᵤl T₂ ⟧ = zip _⊎_ (λ x _ → inj₁ x) ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ T₁ ∙+ᵤr T₂ ⟧ = zip _⊎_ (λ _ y → inj₂ y) ∙⟦ T₁ ⟧ ∙⟦ T₂ ⟧
∙⟦ Singᵤ T ⟧ = < uncurry Singleton , (λ y → proj₂ y , refl) > ∙⟦ T ⟧

data _∙⟶_ : ∙𝕌 → ∙𝕌 → Set where
  ∙c :  {t₁ t₂ : 𝕌} {v : ⟦ t₁ ⟧} → (c : t₁ ⟷ t₂) →
        t₁ # v ∙⟶ t₂ # (eval c v)
  ∙id⟷ : {T : ∙𝕌} → T ∙⟶ T
  _∙⊚_ : {T₁ T₂ T₃ : ∙𝕌} → (T₁ ∙⟶ T₂) → (T₂ ∙⟶ T₃) → (T₁ ∙⟶ T₃)
  ∙Singᵤ : (T₁ T₂ : ∙𝕌) → (T₁ ∙⟶ T₂) → (Singᵤ T₁ ∙⟶ Singᵤ T₂)
  -- monad
  return : (T : ∙𝕌) → T ∙⟶ Singᵤ T
  join : (T : ∙𝕌) → Singᵤ (Singᵤ T) ∙⟶ Singᵤ T
  tensorl : (T₁ T₂ : ∙𝕌) → (Singᵤ T₁ ∙×ᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
  tensorr : (T₁ T₂ : ∙𝕌) → (T₁ ∙×ᵤ Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
  tensor : (T₁ T₂ : ∙𝕌) → (Singᵤ T₁ ∙×ᵤ Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙×ᵤ T₂)
  untensor : (T₁ T₂ : ∙𝕌) → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (Singᵤ T₁ ∙×ᵤ Singᵤ T₂)
  plusl : (T₁ T₂ : ∙𝕌) → (Singᵤ T₁ ∙+ᵤl T₂) ∙⟶ Singᵤ (T₁ ∙+ᵤl T₂)
  plusr : (T₁ T₂ : ∙𝕌) → (T₁ ∙+ᵤr Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙+ᵤr T₂)
  --    plus : (T₁ T₂ : ∙𝕌) → (Singᵤ T₁ ∙+ᵤl Singᵤ T₂) ∙⟶ Singᵤ (T₁ ∙+ᵤl T₂)  -- lobsided, feels wrong
  -- comonad
  extract : (T : ∙𝕌) → Singᵤ T ∙⟶ T
  duplicate : (T : ∙𝕌) → Singᵤ T ∙⟶ Singᵤ (Singᵤ T)
  cotensorl : (T₁ T₂ : ∙𝕌) → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (Singᵤ T₁ ∙×ᵤ T₂)
  cotensorr : (T₁ T₂ : ∙𝕌) → Singᵤ (T₁ ∙×ᵤ T₂) ∙⟶ (T₁ ∙×ᵤ Singᵤ T₂)
  coplusl : (T₁ T₂ : ∙𝕌) → Singᵤ (T₁ ∙+ᵤl T₂) ∙⟶ (Singᵤ T₁ ∙+ᵤl T₂)
  coplusr : (T₁ T₂ : ∙𝕌) → Singᵤ (T₁ ∙+ᵤr T₂) ∙⟶ (T₁ ∙+ᵤr Singᵤ T₂)

∙eval : {T₁ T₂ : ∙𝕌} → (C : T₁ ∙⟶ T₂) →
  let (t₁ , v₁) = ∙⟦ T₁ ⟧
      (t₂ , v₂) = ∙⟦ T₂ ⟧
  in Σ (t₁ → t₂) (λ f → f v₁ ≡ v₂)
∙eval ∙id⟷ = (λ x → x) , refl
∙eval (∙c c) = eval c , refl
∙eval (C₁ ∙⊚ C₂) with ∙eval C₁ | ∙eval C₂
... | (f , p) | (g , q) = (λ x → g (f x)) , trans (cong g p) q
∙eval (∙Singᵤ T₁ T₂ C) with ∙⟦ T₁ ⟧ | ∙⟦ T₂ ⟧ | ∙eval C
... | t₁ , v₁ | t₂ , .(f v₁) | f , refl = (λ {(x , refl) → f x , refl}) , refl
∙eval (return T) = (λ _ → proj₂ ∙⟦ T ⟧ , refl) , refl
∙eval (join T) = (λ { (._ , refl) → (proj₂ ∙⟦ T ⟧) , refl} ) , refl
∙eval (tensorl T₁ T₂) = (λ {_ → (proj₂ ∙⟦ T₁ ⟧ , proj₂ ∙⟦ T₂ ⟧) , refl}) , refl
∙eval (tensorr T₁ T₂) = (λ {_ → (proj₂ ∙⟦ T₁ ⟧ , proj₂ ∙⟦ T₂ ⟧) , refl}) , refl
∙eval (tensor T₁ T₂) = (λ {_ → (proj₂ ∙⟦ T₁ ⟧ , proj₂ ∙⟦ T₂ ⟧) , refl}) , refl
∙eval (untensor T₁ T₂) = (λ _ → ((proj₂ ∙⟦ T₁ ⟧ , refl) , (proj₂ ∙⟦ T₂ ⟧ , refl))) , refl
∙eval (plusl T₁ T₂) = (λ _ → inj₁ (proj₂ ∙⟦ T₁ ⟧) , refl) , refl
∙eval (plusr T₁ T₂) = (λ _ → inj₂ (proj₂ ∙⟦ T₂ ⟧) , refl) , refl
-- ∙eval (plus T₁ T₂) with ∙⟦ T₁ ⟧ | ∙⟦ T₂ ⟧
-- ... | t₁ , v₁ | t₂ , v₂ = (λ _ → inj₁ v₁ , refl) , refl
∙eval (extract T) = (λ {(w , refl) → w}) , refl
∙eval (duplicate T) = (λ {(w , refl) → (w , refl) , refl}) , refl
∙eval (cotensorl T₁ T₂) = (λ _ → ((proj₂ ∙⟦ T₁ ⟧ , refl) , proj₂ ∙⟦ T₂ ⟧)) , refl
∙eval (cotensorr T₁ T₂) = (λ _ → (proj₂ ∙⟦ T₁ ⟧ , (proj₂ ∙⟦ T₂ ⟧) , refl)) , refl
∙eval (coplusl T₁ T₂) = (λ _ → inj₁ (proj₂ ∙⟦ T₁ ⟧ , refl)) , refl
∙eval (coplusr T₁ T₂) = (λ _ → inj₂ (proj₂ ∙⟦ T₂ ⟧ , refl)) , refl

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


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.Instances.Initial where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Unit
open import Cubical.Data.Sigma.Properties using (Σ≡Prop)

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Algebra.Base using (IsAlgebraHom)
open import Cubical.Algebra.Algebra.Properties
open import Cubical.Algebra.CommAlgebra
import Cubical.Algebra.Algebra.Properties

open AlgebraHoms

private
  variable
    ℓ : Level

module _ (R : CommRing ℓ) where

  module _ where
    open CommRingStr (snd R)

    initialCAlg : CommAlgebra R ℓ
    initialCAlg .fst = fst R
    initialCAlg .snd .CommAlgebraStr.0a = _
    initialCAlg .snd .CommAlgebraStr.1a = _
    initialCAlg .snd .CommAlgebraStr._+_ = _
    initialCAlg .snd .CommAlgebraStr._·_ = _
    initialCAlg .snd .CommAlgebraStr.-_ = _
    initialCAlg .snd .CommAlgebraStr._⋆_ r x = r · x
    initialCAlg .snd .CommAlgebraStr.isCommAlgebra =
      makeIsCommAlgebra (isSetRing (CommRing→Ring R))
                         +Assoc +Rid +Rinv +Comm
                         ·Assoc ·Lid
                         ·Ldist+ ·Comm
                          (λ x y z → sym (·Assoc x y z)) ·Ldist+ ·Rdist+ ·Lid
                           λ x y z → sym (·Assoc x y z)

  module _ (A : CommAlgebra R ℓ) where
    open CommAlgebraStr ⦃... ⦄
    private
      instance
        _ : CommAlgebraStr R (fst A)
        _ = snd A
        _ : CommAlgebraStr R (fst R)
        _ = snd initialCAlg

    _*_ : fst R → (fst A) → (fst A)
    r * a = CommAlgebraStr._⋆_ (snd A) r a

    initialMap : CommAlgebraHom initialCAlg A
    initialMap =
      makeCommAlgebraHom {M = initialCAlg} {N = A}
        (λ r → r * 1a)
        (⋆-lid _)
        (λ x y → ⋆-ldist x y 1a)
        (λ x y →  (x · y) * 1a ≡⟨ ⋆-assoc _ _ _ ⟩
                           x * (y * 1a)                   ≡[ i ]⟨ x * (·Lid (y * 1a) (~ i)) ⟩
                           x * (1a · (y * 1a))            ≡⟨ sym (⋆-lassoc _ _ _) ⟩
                           (x * 1a) · (y * 1a) ∎)
        (λ r x → (r · x) * 1a   ≡⟨ ⋆-assoc _ _ _ ⟩
                         (r * (x * 1a)) ∎)

    initialMapEq : (f : CommAlgebraHom initialCAlg A)
                   → f ≡ initialMap
    initialMapEq f =
      let open IsAlgebraHom (snd f)
      in Σ≡Prop
           (isPropIsCommAlgebraHom {M = initialCAlg} {N = A})
             λ i x →
               ((fst f) x                              ≡⟨ cong (fst f) (sym (·Rid _)) ⟩
               fst f (x · 1a)                          ≡⟨ pres⋆ x 1a ⟩
               CommAlgebraStr._⋆_ (snd A) x (fst f 1a) ≡⟨ cong
                                                           (λ u → (snd A CommAlgebraStr.⋆ x) u)
                                                           pres1 ⟩
               (CommAlgebraStr._⋆_ (snd A) x 1a) ∎) i

    initialMapProp : (f g : CommAlgebraHom initialCAlg A)
                     → f ≡ g
    initialMapProp f g = initialMapEq f ∙ sym (initialMapEq g)

    initialityIso : Iso (CommAlgebraHom initialCAlg A) (Unit* {ℓ = ℓ})
    initialityIso = iso (λ _ → tt*)
                        (λ _ → initialMap)
                        (λ {tt*x → refl})
                        λ f → sym (initialMapEq f)

    initialityPath : CommAlgebraHom initialCAlg A ≡ Unit*
    initialityPath = isoToPath initialityIso

    initialityContr : isContr (CommAlgebraHom initialCAlg A)
    initialityContr = initialMap , λ ϕ → sym (initialMapEq ϕ)

  {-
    Show that any R-Algebra with the same universal property
    as the initial R-Algebra, is isomorphic to the initial
    R-Algebra.
  -}
  module _ (A : CommAlgebra R ℓ) where
    equivByInitiality :
      (isInitial : (B : CommAlgebra R ℓ) → isContr (CommAlgebraHom A B))
      → CommAlgebraEquiv A (initialCAlg)
    equivByInitiality isInitial = isoToEquiv asIso , snd to
      where
        open CommAlgebraHoms
        to : CommAlgebraHom A initialCAlg
        to = fst (isInitial initialCAlg)

        from : CommAlgebraHom initialCAlg A
        from = initialMap A

        asIso : Iso (fst A) (fst initialCAlg)
        Iso.fun asIso = fst to
        Iso.inv asIso = fst from
        Iso.rightInv asIso =
          λ x i → cong
                    fst
                    (isContr→isProp (initialityContr initialCAlg) (to ∘a from) (idCAlgHom initialCAlg))
                    i x
        Iso.leftInv asIso =
          λ x i → cong
                    fst
                    (isContr→isProp (isInitial A) (from ∘a to) (idCAlgHom A))
                    i x


-- Evidence producing divmod.
module Numeric.Nat.DivMod where

open import Prelude
open import Control.WellFounded
open import Tactic.Nat
open import Tactic.Nat.Reflect
open import Tactic.Nat.Exp
open import Numeric.Nat.Properties

private
  lemModAux′ : ∀ k m b j → modAux k m (suc j + b) j ≡ modAux 0 m b m
  lemModAux′ k m b  zero   = refl
  lemModAux′ k m b (suc j) = lemModAux′ (suc k) m b j

  lemModAux : ∀ k m b j → modAux k m (suc b + j) j ≡ modAux 0 m b m
  lemModAux k m b j = (λ z → modAux k m (suc z) j) $≡ auto ⟨≡⟩ lemModAux′ k m b j

  lemDivAux′ : ∀ k m b j → divAux k m (suc j + b) j ≡ divAux (suc k) m b m
  lemDivAux′ k m b  zero   = refl
  lemDivAux′ k m b (suc j) = lemDivAux′ k m b j

  lemDivAux : ∀ k m b j → divAux k m (suc b + j) j ≡ divAux (suc k) m b m
  lemDivAux k m b j = (λ z → divAux k m (suc z) j) $≡ auto ⟨≡⟩ lemDivAux′ k m b j

  modLessAux : ∀ k m n j → k + j < suc m → modAux k m n j < suc m
  modLessAux k m  zero    j      lt = by lt
  modLessAux k m (suc n)  zero   _  = modLessAux 0 m n m auto
  modLessAux k m (suc n) (suc j) lt = modLessAux (suc k) m n j (by lt)

  modLess : ∀ a b → a mod suc b < suc b
  modLess a b = fast-diff $ modLessAux 0 b a b auto

  divAuxGt : ∀ k a b j → a ≤ j → divAux k b a j ≡ k
  divAuxGt k  zero   b  j      lt = refl
  divAuxGt k (suc a) b  zero   lt = refute lt
  divAuxGt k (suc a) b (suc j) lt = divAuxGt k a b j (by lt)

  modAuxGt : ∀ k a b j → a ≤ j → modAux k b a j ≡ k + a
  modAuxGt k  zero   b  j      lt = auto
  modAuxGt k (suc a) b  zero   lt = refute lt
  modAuxGt k (suc a) b (suc j) lt = by (modAuxGt (suc k) a b j (by lt))

  qr-mul : (b q r : Nat) → Nat
  qr-mul b q r = q * suc b + r

  divmodAux : ∀ k a b → Acc _<_ a → qr-mul b (divAux k b a b) (modAux 0 b a b) ≡ qr-mul b k a
  divmodAux k a  b wf    with compare b a
  divmodAux k a  b wf       | greater lt =
    let leq : a ≤ b
        leq = by lt in
    qr-mul b $≡ divAuxGt k a b b leq
             *≡ modAuxGt 0 a b b leq
  divmodAux k a .a wf       | equal refl =
    qr-mul a $≡ divAuxGt k a a a (diff! 0)
             *≡ modAuxGt 0 a a a (diff! 0)
  divmodAux k ._ b (acc wf) | less (diff! j) =
    qr-mul b $≡ lemDivAux k b j b *≡ lemModAux 0 b j b ⟨≡⟩
    by (divmodAux (suc k) j b (wf j auto))

  divmod-spec : ∀ a b′ → let b = suc b′ in a div b * b + a mod b ≡ a
  divmod-spec a b = eraseEquality (divmodAux 0 a b (wfNat a))

--- Public definitions ---

data DivMod (a b : Nat) : Set where
  qr : ∀ q r → r < b → q * b + r ≡ a → DivMod a b

quot : ∀ {a b} → DivMod a b → Nat
quot (qr q _ _ _) = q

rem : ∀ {a b} → DivMod a b → Nat
rem (qr _ r _ _) = r

rem-less : ∀ {a b} (d : DivMod a b) → rem d < b
rem-less (qr _ _ lt _) = lt

quot-rem-sound : ∀ {a b} (d : DivMod a b) → quot d * b + rem d ≡ a
quot-rem-sound (qr _ _ _ eq) = eq

syntax divMod b a = a divmod b
divMod : ∀ b {{_ : NonZero b}} a → DivMod a b
divMod zero {{}} a
divMod (suc b) a = qr (a div suc b) (a mod suc b) (modLess a b) (divmod-spec a b)

{-# INLINE divMod #-}

--- Properties ---

mod-less : ∀ b {{_ : NonZero b}} a → a mod b < b
mod-less zero {{}} _
mod-less (suc b) a = rem-less (a divmod suc b)

divmod-sound : ∀ b {{_ : NonZero b}} a → (a div b) * b + a mod b ≡ a
divmod-sound zero {{}} _
divmod-sound (suc b) a = quot-rem-sound (a divmod suc b)

private
  divmod-unique′ : (b q₁ q₂ r₁ r₂ : Nat) → r₁ < b → r₂ < b → q₁ * b + r₁ ≡ q₂ * b + r₂ → q₁ ≡ q₂ × r₁ ≡ r₂
  divmod-unique′ b  zero     zero    r₁ r₂ lt₁ lt₂ eq   = refl , eq
  divmod-unique′ b  zero    (suc q₂) ._ r₂ lt₁ lt₂ refl = refute lt₁
  divmod-unique′ b (suc q₁)  zero    r₁ ._ lt₁ lt₂ refl = refute lt₂
  divmod-unique′ b (suc q₁) (suc q₂) r₁ r₂ lt₁ lt₂ eq   =
    first (cong suc) $ divmod-unique′ b q₁ q₂ r₁ r₂ lt₁ lt₂ (by eq)

divmod-unique : ∀ {a b} (d₁ d₂ : DivMod a b) → quot d₁ ≡ quot d₂ × rem d₁ ≡ rem d₂
divmod-unique (qr q₁ r₁ lt₁ eq₁) (qr q₂ r₂ lt₂ eq₂) =
  case divmod-unique′ _ q₁ q₂ r₁ r₂ lt₁ lt₂ (eq₁ ⟨≡⟩ʳ eq₂) of
  λ p → eraseEquality (fst p) , eraseEquality (snd p)

quot-unique : ∀ {a b} (d₁ d₂ : DivMod a b) → quot d₁ ≡ quot d₂
quot-unique d₁ d₂ = fst (divmod-unique d₁ d₂)

rem-unique : ∀ {a b} (d₁ d₂ : DivMod a b) → rem d₁ ≡ rem d₂
rem-unique d₁ d₂ = snd (divmod-unique d₁ d₂)

instance
  ShowDivMod : ∀ {a b} → Show (DivMod a b)
  showsPrec {{ShowDivMod {a} {b}}} p (qr q r _ _) =
      showParen (p >? 0) $ shows a ∘ showString " == "
                         ∘ shows q ∘ showString " * " ∘ shows b ∘ showString " + " ∘ shows r


-- {-# OPTIONS -v interaction.give:20 #-}

-- Reported by stevan.andjelkovic, Yesterday (17 hours ago)

-- Trying to give the expression in the goal gives the following error:

--   tt != tt p a of type Prop
--   when checking that the expression (λ x y → ?) has type
--   ({o : ⊤} (p : ⊤) → ⊥ → ⊤)

record _▷_ (I O : Set) : Set₁ where
  constructor _◃_/_
  field
    Parameter  : (o : O) → Set
    Arity      : ∀ {o} (p : Parameter o) → Set
    input      : ∀ {o} (p : Parameter o) (a : Arity p) → I

open _▷_ public

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

--data ⊤ : Set where
--  tt : ⊤

Abort : ⊤ ▷ ⊤
Abort = (λ _ → ⊤) ◃ (λ _ → ⊥) / {!!λ x y → {!!}!}


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

open import Basics
open import lib.Basics
open import Flat

module Axiom.C0 {@♭ i j : ULevel} (@♭ I : Type i) (@♭ R : I → Type j) where
    postulate C0 : {@♭ k : ULevel} (@♭ A : Type k)
                   (p : (index : I) → (is-equiv (λ (a : A) → λ (r : R index) → a)))
                   → A is-discrete


------------------------------------------------------------------------------
-- Well-founded induction on the relation LTC
------------------------------------------------------------------------------

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

module FOTC.Data.List.WF-Relation.LT-Cons.Induction.Acc.WF-I where

open import FOTC.Base
open import FOTC.Data.List
open import FOTC.Data.List.WF-Relation.LT-Cons
open import FOTC.Data.List.WF-Relation.LT-Cons.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Length
open import FOTC.Data.List.WF-Relation.LT-Length.Induction.Acc.WF-I
open import FOTC.Induction.WF

-- Parametrized modules
open module S = FOTC.Induction.WF.Subrelation {List} {LTC} LTC→LTL

------------------------------------------------------------------------------
-- The relation LTL is well-founded (using the subrelation combinator).
LTC-wf : WellFounded LTC
LTC-wf Lxs = well-founded LTL-wf Lxs

-- Well-founded induction on the relation LTC.
LTC-wfind : (A : D → Set) →
            (∀ {xs} → List xs → (∀ {ys} → List ys → LTC ys xs → A ys) → A xs) →
            ∀ {xs} → List xs → A xs
LTC-wfind A = WellFoundedInduction LTC-wf


------------------------------------------------------------------------------
-- Mirror example
------------------------------------------------------------------------------

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

module FOTC.Program.Mirror.Example where

open import FOTC.Base
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Program.Mirror.Mirror
open import FOTC.Program.Mirror.Type
open import FOTC.Program.Mirror.PropertiesI

------------------------------------------------------------------------------
-- Example
--       1
--    / / \ \
--   2 3   4 5
--  / \
-- 6   7

t : D
t = node 1' (node 2' (node 6' [] ∷ node 7' [] ∷ []) ∷
             node 3' [] ∷
             node 4' [] ∷
             node 5' [] ∷
             []
            )

tTree : Tree t
tTree = tree 1' (fcons (tree 2' (fcons (tree 6' fnil)
                                (fcons (tree 7' fnil)
                                fnil)))
                (fcons (tree 3' fnil)
                (fcons (tree 4' fnil)
                (fcons (tree 5' fnil)
                fnil))))

test : t ≡ mirror · (mirror · t)
test = sym (mirror-involutive tTree)


-- Andreas, 2015-05-28 example by Andrea Vezzosi

open import Common.Size

data Nat (i : Size) : Set where
  zero : ∀ (j : Size< i) → Nat i
  suc  : ∀ (j : Size< i) → Nat j → Nat i

{-# TERMINATING #-}
-- This definition is fine, the termination checker is too strict at the moment.
fix : ∀ {C : Size → Set} → (∀ i → (∀ (j : Size< i) → Nat j -> C j) → Nat i → C i) → ∀ i → Nat i → C i
fix t i (zero j)  = t i (λ (j : Size< i) → fix t j) (zero j)
fix t i (suc j n) = t i (λ (j : Size< i) → fix t j) (suc j n)

case : ∀ i {C : Set} (n : Nat i) (z : C) (s : ∀ (j : Size< i) → Nat j → C) → C
case i (zero j)  z s = z
case i (suc j n) z s = s j n

applyfix : ∀ {C : Size → Set} i (n : Nat i)
  → (∀ i → (∀ (j : Size< i) → Nat j -> C j) → Nat i → C i)
  → C i
applyfix i n f = fix f i n

module M (i0 : Size) (bot : ∀{i} → Nat i) (A : Set) (default : A) where

  loops : A
  loops = applyfix (↑ i0) (zero i0) λ i r (_ : Nat i) →
      case i bot default λ (j : Size< i) (n : Nat j) →   -- Size< i is possibly empty, should be rejected
      case j n   default λ (h : Size< j) (_ : Nat h) →
      r (↑ h) (zero h)

  -- loops
  -- --> fix t (↑ i0) (zero i0)
  -- --> t (↑ i0) (fix t) (zero i0)
  -- --> case i0 bot default λ j n → case j n default λ h _ → fix t (↑ h) (zero h)
  -- and we have reproduced (modulo [h/i0]) what we started with

  -- The above needs this inference to typecheck
  -- h < j,   j < i
  -- ---------------------
  -- ↑ h < i


module Structure.Operator.Group where

import      Lvl
open import Logic
open import Logic.IntroInstances
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function
open import Structure.Operator.Monoid using (Monoid)
open import Structure.Operator.Properties hiding (commutativity)
open import Type
open import Type.Size

-- A type and a binary operator using this type is a group when:
-- • It is a monoid.
-- • The operator have an inverse in both directions.
record Group {ℓ ℓₑ} {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) : Stmt{ℓ Lvl.⊔ ℓₑ} where
  constructor intro
  field
    ⦃ monoid ⦄ : Monoid(_▫_)
  open Monoid(monoid) public

  field
    ⦃ inverse-existence ⦄ : ∃(InverseFunction(_▫_) ⦃ identity-existence ⦄)

  inv = [∃]-witness inverse-existence

  field
    ⦃ inv-function ⦄ : Function(inv)

  instance
    inverse : InverseFunction (_▫_) inv
    inverse = [∃]-proof inverse-existence

  instance
    inverseₗ : InverseFunctionₗ (_▫_) inv
    inverseₗ = InverseFunction.left(inverse)

  instance
    inverseᵣ : InverseFunctionᵣ (_▫_) inv
    inverseᵣ = InverseFunction.right(inverse)

  inv-op : T → T → T
  inv-op x y = x ▫ inv y

record CommutativeGroup {ℓ ℓₑ} {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) : Stmt{ℓ Lvl.⊔ ℓₑ} where
  constructor intro
  field
    ⦃ group ⦄         : Group (_▫_)
    ⦃ commutativity ⦄ : Commutativity (_▫_)
  open Group(group) public

{- TODO: See Monoid for how this should be rewritten to fit how it is done in Category
module Morphism where
  module _ {ℓ₁ ℓ₂} {X : Type{ℓ₁}} ⦃ _ : Equiv(X) ⦄ {_▫X_ : X → X → X} ⦃ structureₗ : Group(_▫X_) ⦄ {Y : Type{ℓ₂}} ⦃ _ : Equiv(Y) ⦄ {_▫Y_ : Y → Y → Y} ⦃ structureᵣ : Group(_▫Y_) ⦄ (f : X → Y) where
    -- Group homomorphism
    record Homomorphism : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro

      idₗ = Group.id(structureₗ)
      idᵣ = Group.id(structureᵣ)

      invₗ = Group.inv(structureₗ)
      invᵣ = Group.inv(structureᵣ)

      field
        preserve-op  : ∀{x y : X} → (f(x ▫X y) ≡ f(x) ▫Y f(y))
        -- TODO: These may be unneccessary because they follow from preserve-op when Function(f)
        preserve-inv : ∀{x : X} → (f(invₗ x) ≡ invᵣ(f(x)))
        preserve-id  : (f(idₗ) ≡ idᵣ)

    -- Group monomorphism (Injective homomorphism)
    record Monomorphism : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        ⦃ homomorphism ⦄ : Homomorphism
        ⦃ size ⦄         : (X ≼ Y)

    -- Group epimorphism (Surjective homomorphism)
    record Epimorphism : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        ⦃ homomorphism ⦄ : Homomorphism
        ⦃ size ⦄         : (X ≽ Y)

    -- Group isomorphism (Bijective homomorphism)
    record Isomorphism : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        ⦃ homomorphism ⦄ : Homomorphism
        ⦃ size ⦄         : (X ≍ Y)

  _↣_ : ∀{ℓ₁ ℓ₂} → {X : Type{ℓ₁}} → ⦃ _ : Equiv(X) ⦄ → (_▫X_ : X → X → X) → ⦃ structureₗ : Group(_▫X_) ⦄ → {Y : Type{ℓ₂}} → ⦃ _ : Equiv(Y) ⦄ → (_▫Y_ : Y → Y → Y) → ⦃ structureᵣ : Group(_▫Y_) ⦄ → Stmt{ℓ₁ Lvl.⊔ ℓ₂}
  (_▫X_) ↣ (_▫Y_) = ∃(Monomorphism{_▫X_ = _▫X_}{_▫Y_ = _▫Y_})

  _↠_ : ∀{ℓ₁ ℓ₂} → {X : Type{ℓ₁}} → ⦃ _ : Equiv(X) ⦄ → (_▫X_ : X → X → X) → ⦃ structureₗ : Group(_▫X_) ⦄ → {Y : Type{ℓ₂}} → ⦃ _ : Equiv(Y) ⦄ → (_▫Y_ : Y → Y → Y) → ⦃ structureᵣ : Group(_▫Y_) ⦄ → Stmt{ℓ₁ Lvl.⊔ ℓ₂}
  (_▫X_) ↠ (_▫Y_) = ∃(Epimorphism{_▫X_ = _▫X_}{_▫Y_ = _▫Y_})

  _⤖_ : ∀{ℓ₁ ℓ₂} → {X : Type{ℓ₁}} → ⦃ _ : Equiv(X) ⦄ → (_▫X_ : X → X → X) → ⦃ structureₗ : Group(_▫X_) ⦄ → {Y : Type{ℓ₂}} → ⦃ _ : Equiv(Y) ⦄ → (_▫Y_ : Y → Y → Y) → ⦃ structureᵣ : Group(_▫Y_) ⦄ → Stmt{ℓ₁ Lvl.⊔ ℓ₂}
  (_▫X_) ⤖ (_▫Y_) = ∃(Isomorphism{_▫X_ = _▫X_}{_▫Y_ = _▫Y_})
-}


module Rationals where

open import Nats renaming (_+_ to _:+:_; _*_ to _:*:_)
open import Equality
open import Data.Product
open import Agda.Builtin.TrustMe

infixl 7 _÷_
infixr 5 _→ℕ
infixr 7 _÷_↓_
infixr 7 _÷_↑_
infixl 6 _+_

data ℚ : Set where
  _÷_ : (a b : ℕ) → ℚ

_→ℕ : {a : ℕ} → ℚ → ∃ (λ m → m ≡ a)
_→ℕ {a} _ = a , refl

-- of course.
_÷_↓_ : ∀ a b n → (a :*: n ÷ (b :*: n)) ≡ a ÷ b
_ ÷ _ ↓ _ = primTrustMe

_÷_↑_ : ∀ a b n → a ÷ b ≡ (a :*: n ÷ (b :*: n))
a ÷ b ↑ n = sym (a ÷ b ↓ n)

_+_ : ℚ → ℚ → ℚ
a ÷ c + b ÷ d = (a :*: d :+: b :*: c) ÷ (c :*: d)

_*_ : ℚ → ℚ → ℚ
(a ÷ c) * (b ÷ d) = a :*: b ÷ (c :*: d)

_/_ : ℚ → ℚ → ℚ
(a ÷ c) / (b ÷ d) = a :*: d ÷ (c :*: b)


module Thesis.SIRelBigStep.DLangDerive where

open import Thesis.SIRelBigStep.DSyntax public

derive-const : ∀ {Δ σ} → (c : Const σ) → DSVal Δ σ
derive-const (lit n) = dconst (lit 0)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ

derive-dsval : ∀ {Δ σ} → (t : SVal Δ σ) → DSVal Δ σ
derive-dsval (var x) = dvar x
derive-dsval (abs t) = dabs (derive-dterm t)
derive-dsval (cons sv1 sv2) = dcons (derive-dsval sv1) (derive-dsval sv2)
derive-dsval (const c) = derive-const c

derive-dterm (val x) = dval (derive-dsval x)
derive-dterm (primapp p sv) = dprimapp p sv (derive-dsval sv)
derive-dterm (app vs vt) = dapp (derive-dsval vs) vt (derive-dsval vt)
derive-dterm (lett s t) = dlett s (derive-dterm s) (derive-dterm t)

-- Nontrivial because of unification problems in pattern matching. I wanted to
-- use it to define ⊕ on closures purely on terms of the closure change.

-- Instead, I decided to use decidable equality on contexts: that's a lot of
-- tedious boilerplate, but not too hard, but the proof that validity and ⊕
-- agree becomes easier.
-- -- Define a DVar and be done?
-- underive-dvar :  ∀ {Δ σ} → Var (ΔΔ Δ) (Δτ σ) → Var Δ σ
-- underive-dvar {∅} ()
-- underive-dvar {τ • Δ} x = {!!}

--underive-dvar {σ • Δ} (that x) = that (underive-dvar x)


open import Prelude
open import dynamics-core

module lemmas-consistency where
  -- type consistency is symmetric
  ~sym : {t1 t2 : htyp} → t1 ~ t2 → t2 ~ t1
  ~sym TCRefl = TCRefl
  ~sym TCHole1 = TCHole2
  ~sym TCHole2 = TCHole1
  ~sym (TCArr p1 p2) = TCArr (~sym p1) (~sym p2)
  ~sym (TCSum p1 p2) = TCSum (~sym p1) (~sym p2)
  ~sym (TCProd p1 p2) = TCProd (~sym p1) (~sym p2)

  -- type consistency isn't transitive
  not-trans : ((t1 t2 t3 : htyp) → t1 ~ t2 → t2 ~ t3 → t1 ~ t3) → ⊥
  not-trans t with t (num ==> num) ⦇-⦈ num TCHole1 TCHole2
  ... | ()

  --  every pair of types is either consistent or not consistent
  ~dec : (t1 t2 : htyp) → ((t1 ~ t2) + (t1 ~̸ t2))
    -- this takes care of all hole cases, so we don't consider them below
  ~dec _ ⦇-⦈ = Inl TCHole1
  ~dec ⦇-⦈ _ = Inl TCHole2
  ~dec num num = Inl TCRefl
  ~dec num (t2 ==> t3) = Inr (λ ())
  ~dec num (t2 ⊕ t3) = Inr (λ ())
  ~dec (t1 ==> t3) num = Inr (λ ())
  ~dec (t1 ==> t3) (t2 ==> t4)
    with ~dec t1 t2 | ~dec t3 t4
  ... | Inl x | Inl x₁ = Inl (TCArr x x₁)
  ... | Inl x | Inr x₁ = Inr λ{ TCRefl → x₁ TCRefl ; (TCArr x₂ x₃) → x₁ x₃}
  ... | Inr x | w = Inr λ{ TCRefl → x TCRefl ; (TCArr x₁ x₂) → x x₁}
  ~dec (t1 ==> t3) (t2 ⊕ t4) = Inr (λ ())
  ~dec (t1 ⊕ t3) num = Inr (λ ())
  ~dec (t1 ⊕ t3) (t2 ==> t4) = Inr (λ ())
  ~dec (t1 ⊕ t3) (t2 ⊕ t4)
    with ~dec t1 t2 | ~dec t3 t4
  ... | Inl x | Inl x₁ = Inl (TCSum x x₁)
  ... | Inl x | Inr x₁ = Inr λ{ TCRefl → x₁ TCRefl ; (TCSum x₂ x₃) → x₁ x₃}
  ... | Inr x | w = Inr λ{ TCRefl → x TCRefl ; (TCSum x₁ x₂) → x x₁}
  ~dec num (t2 ⊠ t4) = Inr (λ ())
  ~dec (t1 ==> t3) (t2 ⊠ t4) = Inr (λ ())
  ~dec (t1 ⊕ t3) (t2 ⊠ t4) = Inr (λ ())
  ~dec (t1 ⊠ t3) num = Inr (λ ())
  ~dec (t1 ⊠ t3) (t2 ==> t4) = Inr (λ ())
  ~dec (t1 ⊠ t3) (t2 ⊕ t4) = Inr (λ ())
  ~dec (t1 ⊠ t3) (t2 ⊠ t4)
    with ~dec t1 t2 | ~dec t3 t4
  ... | Inl x | Inl x₁ = Inl (TCProd x x₁)
  ... | Inl x | Inr x₁ = Inr λ{ TCRefl → x₁ TCRefl ; (TCProd x₂ x₃) → x₁ x₃}
  ... | Inr x | w = Inr λ{ TCRefl → x TCRefl ; (TCProd x₁ x₂) → x x₁}

  -- if arrows are consistent, their components are consistent
  ~arr : ∀{τ1 τ2 τ3 τ4} →
         (τ1 ==> τ2) ~ (τ3 ==> τ4) →
         (τ1 ~ τ3) × (τ2 ~ τ4)
  ~arr TCRefl = TCRefl , TCRefl
  ~arr (TCArr con con₁) = con , con₁

  -- if sums are consistent, their components are consistent
  ~sum : ∀{τ1 τ2 τ3 τ4} →
         (τ1 ⊕ τ2) ~ (τ3 ⊕ τ4) →
         (τ1 ~ τ3) × (τ2 ~ τ4)
  ~sum TCRefl = TCRefl , TCRefl
  ~sum (TCSum con con₁) = con , con₁

   -- if products are consistent, their components are consistent
  ~prod : ∀{τ1 τ2 τ3 τ4} →
          (τ1 ⊠ τ2) ~ (τ3 ⊠ τ4) →
          (τ1 ~ τ3) × (τ2 ~ τ4)
  ~prod TCRefl = TCRefl , TCRefl
  ~prod (TCProd con con₁) = con , con₁


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

module Cubical.Codata.M.AsLimit.itree where

open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.Data.Nat as ℕ using (ℕ ; suc ; _+_ )
open import Cubical.Data.Sum
open import Cubical.Data.Empty
open import Cubical.Data.Bool

open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude

open import Cubical.Codata.M.AsLimit.Container
open import Cubical.Codata.M.AsLimit.M
open import Cubical.Codata.M.AsLimit.Coalg

-- Delay monad defined as an M-type
delay-S : (R : Type₀) -> Container ℓ-zero
delay-S R = (Unit ⊎ R) , λ { (inr _) -> ⊥ ; (inl tt) -> Unit }

delay : (R : Type₀) -> Type₀
delay R = M (delay-S R)

delay-ret : {R : Type₀} -> R -> delay R
delay-ret r = in-fun (inr r , λ ())

delay-tau : {R : Type₀} -> delay R -> delay R
delay-tau S = in-fun (inl tt , λ x → S)

-- Bottom element raised
data ⊥₁ : Type₁ where

-- TREES
tree-S : (E : Type₀ -> Type₁) (R : Type₀) -> Container (ℓ-suc ℓ-zero)
tree-S E R = (R ⊎ (Σ[ A ∈ Type₀ ] (E A))) , (λ { (inl _) -> ⊥₁ ; (inr (A , e)) -> Lift A } )

tree : (E : Type₀ -> Type₁) (R : Type₀) -> Type₁
tree E R = M (tree-S E R)

tree-ret : ∀ {E} {R}  -> R -> tree E R
tree-ret {E} {R} r = in-fun (inl r , λ ())

tree-vis : ∀ {E} {R}  -> ∀ {A} -> E A -> (A -> tree E R) -> tree E R
tree-vis {A = A} e k = in-fun (inr (A , e) , λ { (lift x) -> k x } )

-- ITrees (and buildup examples)
-- https://arxiv.org/pdf/1906.00046.pdf
-- Interaction Trees: Representing Recursive and Impure Programs in Coq
-- Li-yao Xia, Yannick Zakowski, Paul He, Chung-Kil Hur, Gregory Malecha, Benjamin C. Pierce, Steve Zdancewic

itree-S : ∀ (E : Type₀ -> Type₁) (R : Type₀) -> Container (ℓ-suc ℓ-zero)
itree-S E R = ((Unit ⊎ R) ⊎ (Σ[ A ∈ Type₀ ] (E A))) , (λ { (inl (inl _)) -> Lift Unit ; (inl (inr _)) -> ⊥₁ ; (inr (A , e)) -> Lift A } )

itree :  ∀ (E : Type₀ -> Type₁) (R : Type₀) -> Type₁
itree E R = M (itree-S E R)

ret' : ∀ {E} {R}  -> R -> P₀ (itree-S E R) (itree E R)
ret' {E} {R} r = inl (inr r) , λ ()

tau' : {E : Type₀ -> Type₁} -> {R : Type₀} -> itree E R -> P₀ (itree-S E R) (itree E R)
tau' t = inl (inl tt) , λ x → t

vis' : ∀ {E} {R}  -> ∀ {A : Type₀} -> E A -> (A -> itree E R) -> P₀ (itree-S E R) (itree E R)
vis' {A = A} e k = inr (A , e) , λ { (lift x) -> k x }

ret : ∀ {E} {R}  -> R -> itree E R
ret = in-fun ∘ ret'

tau : {E : Type₀ -> Type₁} -> {R : Type₀} -> itree E R -> itree E R
tau = in-fun ∘ tau'

vis : ∀ {E} {R}  -> ∀ {A : Type₀} -> E A -> (A -> itree E R) -> itree E R
vis {A = A} e = in-fun ∘ (vis' {A = A} e)


-- Solver for Category

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

open import Categories.Category

module Experiment.Categories.AnotherSolver.Category
  {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Relation.Binary using (Rel)
import Function.Base as Fun

open import Categories.Functor renaming (id to idF)
open import Categories.NaturalTransformation renaming (id to idN)
import Categories.Morphism.Reasoning as MR
import Categories.Category.Equivalence as Eq

open Category 𝒞
open HomReasoning
open MR 𝒞

private
  variable
    A B C D E : Obj

infixr 9 _:∘_

data Expr : Rel Obj (o ⊔ ℓ) where
  :id  : Expr A A
  _:∘_ : Expr B C → Expr A B → Expr A C
  ∥_∥  : A ⇒ B → Expr A B

data NExpr : Rel Obj (o ⊔ ℓ) where
  :id  : NExpr A A
  _:∘_ : B ⇒ C → NExpr A B → NExpr A C

-- Semantics
⟦_⟧ : Expr A B → A ⇒ B
⟦ :id      ⟧ = id
⟦ e₁ :∘ e₂ ⟧ = ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧
⟦ ∥ f ∥    ⟧ = f

⟦_⟧N : NExpr A B → A ⇒ B
⟦ :id    ⟧N = id
⟦ f :∘ e ⟧N = f ∘ ⟦ e ⟧N

_∘N_ : NExpr B C → NExpr A B → NExpr A C
:id       ∘N e₂ = e₂
(f :∘ e₁) ∘N e₂ = f :∘ (e₁ ∘N e₂)

linear : NExpr A B → Expr A B
linear :id      = :id
linear (f :∘ e) = ∥ f ∥ :∘ linear e

normalise : Expr A B → NExpr A B
normalise :id        = :id
normalise (e₁ :∘ e₂) = normalise e₁ ∘N normalise e₂
normalise ∥ f ∥      = f :∘ :id

∘N-homo : (e₁ : NExpr B C) (e₂ : NExpr A B) → ⟦ e₁ ∘N e₂ ⟧N ≈ ⟦ e₁ ⟧N ∘ ⟦ e₂ ⟧N
∘N-homo :id       e₂ = sym identityˡ
∘N-homo (f :∘ e₁) e₂ = pushʳ (∘N-homo e₁ e₂)

NExpr-assoc : {f : NExpr A B} {g : NExpr B C} {h : NExpr C D} →
              ⟦ (h ∘N g) ∘N f ⟧N ≈ ⟦ h ∘N (g ∘N f) ⟧N
NExpr-assoc {f = f} {g} {:id}    = refl
NExpr-assoc {f = f} {g} {x :∘ h} = ∘-resp-≈ʳ (NExpr-assoc {f = f} {g} {h})

NExpr-identityʳ : {f : NExpr A B} → ⟦ f ∘N :id ⟧N ≈ ⟦ f ⟧N
NExpr-identityʳ {f = :id}    = refl
NExpr-identityʳ {f = x :∘ f} = ∘-resp-≈ʳ (NExpr-identityʳ {f = f})

normalise-correct : (e : Expr A B) → ⟦ normalise e ⟧N ≈ ⟦ e ⟧
normalise-correct :id        = refl
normalise-correct (e₁ :∘ e₂) = begin
  ⟦ normalise e₁ ∘N normalise e₂ ⟧N     ≈⟨ ∘N-homo (normalise e₁) (normalise e₂) ⟩
  ⟦ normalise e₁ ⟧N ∘ ⟦ normalise e₂ ⟧N ≈⟨ normalise-correct e₁ ⟩∘⟨ normalise-correct e₂ ⟩
  ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧                       ∎
normalise-correct ∥ f ∥      = identityʳ

normalise-cong : (e₁ e₂ : Expr A B) →
                 ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧ → ⟦ normalise e₁ ⟧N ≈ ⟦ normalise e₂ ⟧N
normalise-cong e₁ e₂ eq = trans (normalise-correct e₁) (trans eq (sym (normalise-correct e₂)))

normalise-inj : (e₁ e₂ : Expr A B) →
                ⟦ normalise e₁ ⟧N ≈ ⟦ normalise e₂ ⟧N → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
normalise-inj e₁ e₂ eq = trans (sym (normalise-correct e₁)) (trans eq (normalise-correct e₂))

linear-correct : (e : NExpr A B) → ⟦ linear e ⟧ ≈ ⟦ e ⟧N
linear-correct :id      = refl
linear-correct (f :∘ e) = ∘-resp-≈ʳ (linear-correct e)

Expr-category : Category o (o ⊔ ℓ) e
Expr-category = categoryHelper record
  { Obj       = Obj
  ; _⇒_       = Expr
  ; _≈_       = λ e₁ e₂ → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
  ; id        = :id
  ; _∘_       = _:∘_
  ; assoc     = assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; equiv     = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  ; ∘-resp-≈  = ∘-resp-≈
  }

NExpr-category : Category o (o ⊔ ℓ) e
NExpr-category = categoryHelper record
  { Obj       = Obj
  ; _⇒_       = NExpr
  ; _≈_       = λ e₁ e₂ → ⟦ e₁ ⟧N ≈ ⟦ e₂ ⟧N
  ; id        = :id
  ; _∘_       = _∘N_
  ; assoc     = λ {_} {_} {_} {_} {f = f} {g} {h} → NExpr-assoc {f = f} {g} {h}
  ; identityˡ = refl
  ; identityʳ = λ {_} {_} {f = f} → NExpr-identityʳ {f = f}
  ; equiv     = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  ; ∘-resp-≈  = λ {_} {_} {_} {f} {h} {g} {i} f≈h g≈i →
    trans (∘N-homo f g) (trans (∘-resp-≈ f≈h g≈i) (sym (∘N-homo h i)))
  }

⟦⟧-functor : Functor Expr-category 𝒞
⟦⟧-functor = record
  { F₀           = Fun.id
  ; F₁           = ⟦_⟧
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = Fun.id
  }

⟦⟧N-functor : Functor NExpr-category 𝒞
⟦⟧N-functor = record
  { F₀           = Fun.id
  ; F₁           = ⟦_⟧N
  ; identity     = refl
  ; homomorphism = λ {_} {_} {_} {f} {g} → ∘N-homo g f
  ; F-resp-≈     = Fun.id
  }

normalise-functor : Functor Expr-category NExpr-category
normalise-functor = record
  { F₀           = Fun.id
  ; F₁           = normalise
  ; identity     = refl
  ; homomorphism = λ {_} {_} {_} {f = f} {g} → refl
  ; F-resp-≈     = λ {_} {_} {f} {g} f≈g → normalise-cong f g f≈g
  }

linear-functor : Functor NExpr-category Expr-category
linear-functor = record
  { F₀           = Fun.id
  ; F₁           = linear
  ; identity     = refl
  ; homomorphism = λ {_} {_} {_} {f} {g} → begin
    ⟦ linear (g ∘N f) ⟧         ≈⟨ linear-correct (g ∘N f) ⟩
    ⟦ g ∘N f ⟧N                 ≈⟨ ∘N-homo g f ⟩
    ⟦ g ⟧N ∘ ⟦ f ⟧N             ≈⟨ sym (linear-correct g) ⟩∘⟨ sym (linear-correct f) ⟩
    ⟦ linear g ⟧ ∘ ⟦ linear f ⟧ ∎
  ; F-resp-≈     = λ {_} {_} {f} {g} eq → begin
    ⟦ linear f ⟧ ≈⟨ linear-correct f ⟩
    ⟦ f ⟧N       ≈⟨ eq ⟩
    ⟦ g ⟧N       ≈⟨ sym (linear-correct g) ⟩
    ⟦ linear g ⟧ ∎
  }

normalise-functor-Faithful : Faithful normalise-functor
normalise-functor-Faithful = normalise-inj

linear-functor-Faithful : Faithful linear-functor
linear-functor-Faithful = λ f g x → trans (sym (linear-correct f)) (trans x (linear-correct g))

⟦⟧n-functor : Functor Expr-category 𝒞
⟦⟧n-functor = ⟦⟧N-functor ∘F normalise-functor

⟦⟧l-functor : Functor NExpr-category 𝒞
⟦⟧l-functor = ⟦⟧-functor ∘F linear-functor

normalise-natural : NaturalTransformation ⟦⟧n-functor ⟦⟧-functor
normalise-natural = ntHelper record
    { η       = λ X → id
    ; commute = λ e → begin
      id ∘ ⟦ normalise e ⟧N ≈⟨ identityˡ ⟩
      ⟦ normalise e ⟧N      ≈⟨ normalise-correct e ⟩
      ⟦ e ⟧                 ≈⟨ sym identityʳ ⟩
      ⟦ e ⟧ ∘ id           ∎
    }

linear-natural : NaturalTransformation ⟦⟧l-functor ⟦⟧N-functor
linear-natural = ntHelper record
  { η       = λ X → id
  ; commute = λ e → trans identityˡ (trans (linear-correct e) (sym identityʳ))
  }

embedExpr : Functor 𝒞 Expr-category
embedExpr = record
  { F₀           = Fun.id
  ; F₁           = ∥_∥
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = Fun.id
  }

embedNExpr : Functor 𝒞 NExpr-category
embedNExpr = record
  { F₀           = Fun.id
  ; F₁           = λ e → e :∘ :id
  ; identity     = identity²
  ; homomorphism = λ {_} {_} {_} {f} {g} → assoc
  ; F-resp-≈     = λ f≈g → trans identityʳ (trans f≈g (sym identityʳ))
  }

{-
solve : (e₁ e₂ : Expr A B) → ⟦ e₁ ⟧N ≈ ⟦ e₂ ⟧N → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
solve e₁ e₂ eq = begin
  ⟦ e₁ ⟧  ≈˘⟨ ⟦e⟧N≈⟦e⟧ e₁ ⟩
  ⟦ e₁ ⟧N ≈⟨ eq ⟩
  ⟦ e₂ ⟧N ≈⟨ ⟦e⟧N≈⟦e⟧ e₂ ⟩
  ⟦ e₂ ⟧  ∎

∥-∥ : ∀ {f : A ⇒ B} → Expr A B
∥-∥ {f = f} = ∥ f ∥
-}


-- Omniscience principles

-- https://ncatlab.org/nlab/show/principle+of+omniscience
-- http://math.fau.edu/lubarsky/Separating%20LLPO.pdf
-- https://arxiv.org/pdf/1804.05495.pdf
-- https://www.cs.bham.ac.uk/~mhe/papers/omniscient-journal-revised.pdf
-- https://www.jaist.ac.jp/~t-nemoto/WMP.pdf
-- http://math.fau.edu/lubarsky/Separating%20LLPO.pdf

-- TODO
-- WKL: weak Koning's lemma
-- BE: Every real number in [0,1] has binary expansion
-- IVT: intermediate value theorem
-- BD-N
-- LLPOₙ

-- WKL <=> LLPO

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

module Constructive.Axiom where

-- agda-stdlib
open import Level renaming (suc to lsuc; zero to lzero)
open import Data.Bool using (Bool; true; false)
open import Data.Empty using (⊥)
open import Data.Sum as Sum
open import Data.Product as Prod
open import Data.List using (List; []; _∷_; length)
open import Data.List.Relation.Binary.Prefix.Heterogeneous using (Prefix)
open import Data.Nat using (ℕ; _≤_; _<_; _+_; _*_)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Function

-- agda-misc
open import Constructive.Common
open import TypeTheory.HoTT.Base using (isProp)

---------------------------------------------------------------------------
-- Axioms
-- -i indicates instance

-- Law of Excluded middle
-- LEM
EM : ∀ a → Set (lsuc a)
EM a = ∀ {A : Set a} → Dec⊎ A

-- Double negation elimination
DNE : ∀ a → Set (lsuc a)
DNE a = ∀ {A : Set a} → Stable A

-- Peirce's law
Peirce-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
Peirce-i A B = ((A → B) → A) → A

Peirce : ∀ a b → Set (lsuc (a ⊔ b))
Peirce a b = {A : Set a} {B : Set b} → Peirce-i A B

-- Material implication
MI-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
MI-i A B = (A → B) → ¬ A ⊎ B

MI : ∀ a b → Set (lsuc (a ⊔ b))
MI a b = {A : Set a} {B : Set b} → MI-i A B

-- De Morgan's laws
-- DML
DEM₁-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
DEM₁-i A B = ¬ (¬ A × ¬ B) → A ⊎ B

DEM₂-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
DEM₂-i A B = ¬ (¬ A ⊎ ¬ B) → A × B

DEM₃-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
DEM₃-i A B = ¬ (A × B) → ¬ A ⊎ ¬ B

DEM₁ : ∀ a b → Set (lsuc (a ⊔ b))
DEM₁ a b = {A : Set a} {B : Set b} → DEM₁-i A B

DEM₂ : ∀ a b → Set (lsuc (a ⊔ b))
DEM₂ a b = {A : Set a} {B : Set b} → DEM₂-i A B

DEM₃ : ∀ a b → Set (lsuc (a ⊔ b))
DEM₃ a b = {A : Set a} {B : Set b} → DEM₃-i A B

-- call/cc
Call/CC-i : ∀ {a} → Set a → Set a
Call/CC-i A = Peirce-i A ⊥

Call/CC : ∀ a → Set (lsuc a)
Call/CC a = ∀ {A : Set a} → Call/CC-i A

-- Gödel-Dummett logic
-- Dirk Gently's Principle (DGP)
DGP-i : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
DGP-i A B = (A → B) ⊎ (B → A)

DGP : ∀ a b → Set (lsuc (a ⊔ b))
DGP a b = {A : Set a} {B : Set b} → DGP-i A B

-- Weak excluded middle
-- https://ncatlab.org/nlab/show/weak+excluded+middle
-- WLEM WPEM
WEM-i : ∀ {a} → Set a → Set a
WEM-i A = Dec⊎ (¬ A)

WEM : ∀ a → Set (lsuc a)
WEM a = {A : Set a} → WEM-i A

-- Double-negation shift
-- if domain of P is finite this can be proved.
-- https://ncatlab.org/nlab/show/double-negation+shift
DNS-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
DNS-i P = (∀ x → ¬ ¬ P x) → ¬ ¬ (∀ x → P x)

DNS : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
DNS A p = {P : A → Set p} → DNS-i P

-- Independence-of-premise
IP : ∀ p q r → Set (lsuc (p ⊔ q ⊔ r))
IP p q r = ∀ {P : Set p} {Q : Set q} {R : Q → Set r} →
           Q → (P → Σ Q R) → (Σ Q λ x → (P → R x))

private
  toPred : ∀ {a} {A : Set a} → (A → Bool) → (A → Set)
  toPred P x = P x ≡ true

-- Searchable set
Searchable-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
Searchable-i P = DecU P → (∃ λ x₀ → P x₀ → ∀ x → P x)

Searchable : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Searchable A p = {P : A → Set p} → Searchable-i P

Searchable-Bool : ∀ {a} → Set a → Set a
Searchable-Bool A = Σ ((A → Bool) → A)
                      λ ε → (P : A → Bool) → P (ε P) ≡ true → (x : A) → P x ≡ true

-- The limited principle of omniscience
-- https://ncatlab.org/nlab/show/principle+of+omniscience
-- Omniscient type
LPO-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
LPO-i P = DecU P → ∃ P ⊎ ¬ ∃ P

LPO : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
LPO A p = {P : A → Set p} → LPO-i P

LPO-Bool-i : ∀ {a} {A : Set a} → (A → Bool) → Set a
LPO-Bool-i P = ∃ (toPred P) ⊎ ¬ ∃ (toPred P)

LPO-Bool : ∀ {a} → Set a → Set a
LPO-Bool A = (P : A → Bool) → LPO-Bool-i P

-- http://www.cs.bham.ac.uk/~mhe/papers/omniscient-2011-07-06.pdf
LPO-Bool-Alt-i : ∀ {a} {A : Set a} → (A → Bool) → Set a
LPO-Bool-Alt-i P = (∃ λ x → P x ≡ false) ⊎ (∀ x → P x ≡ true)

LPO-Bool-Alt : ∀ {a} → Set a → Set a
LPO-Bool-Alt A = (P : A → Bool) → LPO-Bool-Alt-i P

-- Weak limited principle of omniscience
-- https://www.cs.bham.ac.uk/~mhe/papers/omniscient-journal-revised.pdf
-- http://math.fau.edu/lubarsky/Separating%20LLPO.pdf
-- ∀-PEM
WLPO-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
WLPO-i P = DecU P → (∀ x → P x) ⊎ ¬ (∀ x → P x)

WLPO : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
WLPO A p = {P : A → Set p} → WLPO-i P

-- Alternative form of WLPO
WLPO-Alt-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
WLPO-Alt-i P = DecU P → ¬ ∃ P ⊎ ¬ ¬ ∃ P

WLPO-Alt : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
WLPO-Alt A p = {P : A → Set p} → WLPO-Alt-i P

-- The lesser limited principle of omniscience
-- Σ⁰₁-DML
LLPO-i : ∀ {a p} {A : Set a} → (P Q : A → Set p) → Set (a ⊔ p)
LLPO-i P Q = DecU P → DecU Q → ¬ (∃ P × ∃ Q) → ¬ ∃ P ⊎ ¬ ∃ Q

LLPO : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
LLPO A p = {P Q : A → Set p} → LLPO-i P Q

LLPO-Alt-i : ∀ {a p} {A : Set a} → (P Q : A → Set p) → Set (a ⊔ p)
LLPO-Alt-i P Q = DecU P → DecU Q →
                 ¬ ¬ ((∀ x → P x) ⊎ (∀ x → Q x)) → (∀ x → P x) ⊎ (∀ x → Q x)

LLPO-Alt : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
LLPO-Alt A p = {P Q : A → Set p} → LLPO-Alt-i P Q

LLPO-Bool-i : ∀ {a} {A : Set a} → (P Q : A → Bool) → Set a
LLPO-Bool-i P Q = ¬ (∃ (toPred P) × ∃ (toPred Q)) → ¬ ∃ (toPred P) ⊎ ¬ ∃ (toPred Q)

LLPO-Bool : ∀ {a} → Set a → Set a
LLPO-Bool A = (P Q : A → Bool) → LLPO-Bool-i P Q

LLPO-ℕ : ∀ p → Set (lsuc p)
LLPO-ℕ p = {P : ℕ → Set p} → DecU P → (∀ m n → m ≢ n → P m ⊎ P n) →
           (∀ n → P (2 * n)) ⊎ (∀ n → P (1 + 2 * n))

-- Markov's principle
-- LPE
-- https://ncatlab.org/nlab/show/Markov%27s+principle
MP-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
MP-i P = DecU P → ¬ (∀ x → P x) → ∃ λ x → ¬ P x

MP : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
MP A p = {P : A → Set p} → MP-i P

-- Markov's rule
MR-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ p)
MR-i P = DecU P → ¬ ¬ ∃ P → ∃ P

MR : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
MR A p = {P : A → Set p} → MR-i P

-- Weak Markov's principle
-- https://ncatlab.org/nlab/show/Markov%27s+principle
WMP-i : ∀ {a p} {A : Set a} → (A → Set p) → Set (a ⊔ lsuc p)
WMP-i {p = p} {A = A} P =
  DecU P →
  ({Q : A → Set p} → DecU Q → ¬ ¬ ∃ Q ⊎ (¬ ¬ ∃ λ x → P x × ¬ Q x)) →
  ∃ P

WMP : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
WMP A p  = {P : A → Set p} → WMP-i P

WMP-Bool-i : ∀ {a} {A : Set a} → (A → Bool) → Set a
WMP-Bool-i {A = A} P =
  ((Q : A → Bool) →
    ¬ ¬ ∃ (λ x → Q x ≡ true) ⊎ (¬ ¬ ∃ λ x → P x ≡ true × Q x ≢ true)) →
  ∃ λ x → P x ≡ true

WMP-Bool : ∀ {a} (A : Set a) → Set a
WMP-Bool A = (P : A → Bool) → WMP-Bool-i P

-- Disjunctive Markov’s principle
MP⊎-i : ∀ {a p} {A : Set a} → (P Q : A → Set p) → Set (a ⊔ p)
MP⊎-i P Q = DecU P → DecU Q → ¬ (¬ ∃ P × ¬ ∃ Q) → ¬ ¬ ∃ P ⊎ ¬ ¬ ∃ Q

MP⊎ : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
MP⊎ A p = {P Q : A → Set p} → MP⊎-i P Q

MP⊎-Bool-i : ∀ {a} {A : Set a} → (P Q : A → Bool) → Set a
MP⊎-Bool-i P Q = ¬ (¬ ∃ (toPred P) × ¬ ∃ (toPred Q)) →
                 ¬ ¬ ∃ (toPred P) ⊎ ¬ ¬ ∃ (toPred Q)

MP⊎-Bool : ∀ {a} → Set a → Set a
MP⊎-Bool A = (P Q : A → Bool) → MP⊎-Bool-i P Q

MP⊎-Alt-i : ∀ {a p} {A : Set a} → (P Q : A → Set p) → Set (a ⊔ p)
MP⊎-Alt-i P Q = DecU P → DecU Q →
                ¬ ((∀ x → P x) × (∀ x → Q x)) → ¬ (∀ x → P x) ⊎ ¬ (∀ x → Q x)

MP⊎-Alt : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
MP⊎-Alt A p = {P Q : A → Set p} → MP⊎-Alt-i P Q

MP∨-i : ∀ {a p} {A : Set a} → (P Q : A → Set p) → Set (a ⊔ p)
MP∨-i P Q = DecU P → DecU Q →
            ¬ ¬ (∃ λ x → P x ⊎ Q x) → ¬ ¬ ∃ P ⊎ ¬ ¬ ∃ Q

MP∨ : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
MP∨ A p = {P Q : A → Set p} → MP∨-i P Q

-- Σ-DGP
-- Equivalent to LLPO
Σ-DGP-i : ∀ {a p} {A : Set a} (P Q : A → Set p) → Set (a ⊔ p)
Σ-DGP-i P Q = DecU P → DecU Q → DGP-i (∃ P) (∃ Q)

Σ-DGP : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Σ-DGP A p = {P Q : A → Set p} → Σ-DGP-i P Q

-- Π-DGP
Π-DGP-i : ∀ {a p} {A : Set a} (P Q : A → Set p) → Set (a ⊔ p)
Π-DGP-i P Q = DecU P → DecU Q → DGP-i (∀ x → P x) (∀ x → Q x)

Π-DGP : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Π-DGP A p = {P Q : A → Set p} → Π-DGP-i P Q

-- Σ-Π-DGP
Σ-Π-DGP-i : ∀ {a p} {A : Set a} (P Q : A → Set p) → Set (a ⊔ p)
Σ-Π-DGP-i P Q = DecU P → DecU Q → DGP-i (∃ P) (∀ x → Q x)

Σ-Π-DGP : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Σ-Π-DGP A p = {P Q : A → Set p} → Σ-Π-DGP-i P Q

-- Σ-Call/CC
Σ-Call/CC-i : ∀ {a p} {A : Set a} (P : A → Set p) → Set (a ⊔ p)
Σ-Call/CC-i P = DecU P → Call/CC-i (∃ P)

Σ-Call/CC : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Σ-Call/CC A p = {P : A → Set p} → Σ-Call/CC-i P

-- Σ-Σ-Peirce
Σ-Σ-Peirce-i : ∀ {a p} {A : Set a} (P Q : A → Set p) → Set (a ⊔ p)
Σ-Σ-Peirce-i P Q = DecU P → DecU Q → Peirce-i (∃ P) (∃ Q)

Σ-Σ-Peirce : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Σ-Σ-Peirce A p = {P Q : A → Set p} → Σ-Σ-Peirce-i P Q

-- Σ-Π-Peirce
Σ-Π-Peirce-i : ∀ {a p} {A : Set a} (P Q : A → Set p) → Set (a ⊔ p)
Σ-Π-Peirce-i P Q = DecU P → DecU Q → Peirce-i (∃ P) (∀ x → Q x)

Σ-Π-Peirce : ∀ {a} (A : Set a) p → Set (a ⊔ lsuc p)
Σ-Π-Peirce A p = {P Q : A → Set p} → Σ-Π-Peirce-i P Q

-- Kripke's Schema
KS : ∀ {a} (A : Set a) p q → Set (a ⊔ lsuc p ⊔ lsuc q)
KS A p q = ∀ (P : Set p) → Σ (A → Set q) λ Q → DecU Q × (P <=> ∃ Q)

-- Principle of Finite Possiblity
-- Principle of inverse Decision (PID)
PFP : ∀ {a} (A : Set a) p q → Set (a ⊔ lsuc p ⊔ lsuc q)
PFP A p q = {P : A → Set p} → DecU P →
            Σ (A → Set q) λ Q → DecU Q × ((∀ x → P x) <=> ∃ Q)

PFP-Bool-ℕ : Set
PFP-Bool-ℕ =
  (α : ℕ → Bool) →
  Σ (ℕ → Bool) (λ β → (∀ n → α n ≡ false) <=> ∃ λ n → β n ≡ true)

-- Weak Principle of Finite Possiblity
WPFP : ∀ {a} (A : Set a) p q → Set (a ⊔ lsuc p ⊔ lsuc q)
WPFP A p q = {P : A → Set p} → DecU P →
             Σ (A → Set q) λ Q → DecU Q × ((∀ x → P x) <=> (¬ (∀ x → Q x)))

WPFP-Bool-ℕ : Set
WPFP-Bool-ℕ =
  (α : ℕ → Bool) →
  Σ (ℕ → Bool) λ β → (∀ n → α n ≡ false) <=> (¬ (∀ n → β n ≡ false))

-- https://plato.stanford.edu/entries/axiom-choice/choice-and-type-theory.html
ACLT : ∀ {a b} → Set a → Set b → ∀ p → Set (a ⊔ b ⊔ lsuc p)
ACLT A B p = {P : A → B → Set p} →
             ((x : A) → ∃ λ y → P x y) → Σ (A → B) λ f → (x : A) → P x (f x)

-- HoTT
EM⁻¹ : ∀ a → Set (lsuc a)
EM⁻¹ a = {A : Set a} → isProp A → Dec⊎ A

DNE⁻¹ : ∀ a → Set (lsuc a)
DNE⁻¹ a = {A : Set a} → isProp A → Stable A

-- WKL
takeT : ℕ → (ℕ → Bool) → List Bool
takeT ℕ.zero    α = []
takeT (ℕ.suc n) α = α 0 ∷ takeT n (λ m → α (ℕ.suc m))

-- "THE WEAK KONIG LEMMA, BROUWER’S FAN THEOREM, DE MORGAN’S LAW, AND DEPENDENT CHOICE"
2^Bool* : Set₁
2^Bool* = List Bool → Set

IsDetachable : 2^Bool* → Set
IsDetachable T = DecU T

-- closed under restrictions
IsClosed : 2^Bool* → Set
IsClosed T = ∀ u v → Prefix _≡_ v u → T u → T v

IsInfinite : 2^Bool* → Set
IsInfinite T = ∀ n → ∃ λ u → T u × n ≡ length u

IsFinite : 2^Bool* → Set
IsFinite T = ∃ λ n → ∀ u → ¬ T u × n ≡ length u

IsWellFounded : 2^Bool* → Set
IsWellFounded T = Σ (ℕ → Bool) λ α → ∃ λ n → ¬ T (takeT n α)

HasInfinitePath : 2^Bool* → Set
HasInfinitePath T = Σ (ℕ → Bool) λ α → ∀ n → T (takeT n α)

IsTree : 2^Bool* → Set
IsTree T = IsDetachable T × IsClosed T

-- Weak Kőnig Lemma
WKL : Set₁
WKL = ∀ T → IsTree T → IsInfinite T → HasInfinitePath T

-- Brouwer’s Fan Theorem
FAN : Set₁
FAN = ∀ T → IsTree T → IsWellFounded T → IsFinite T

-- BD-N
Peseudobounded : (ℕ → Set) → Set
Peseudobounded S = (s : ℕ → ℕ) → (∀ n → S (s n)) → ∃ λ N → s N < N


------------------------------------------------------------------------
-- The Agda standard library
--
-- Integer Literals
------------------------------------------------------------------------

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

module Data.Integer.Literals where

open import Agda.Builtin.FromNat
open import Agda.Builtin.FromNeg
open import Data.Unit
open import Data.Integer

number : Number ℤ
number = record
  { Constraint = λ _ → ⊤
  ; fromNat    = λ n → + n
  }

negative : Negative ℤ
negative = record
  { Constraint = λ _ → ⊤
  ; fromNeg    = λ n → - (+ n)
  }