open import Level
open import Ordinals
open import logic
open import Relation.Nullary
module LEMC {n : Level } (O : Ordinals {n} ) (p∨¬p : ( p : Set n) → p ∨ ( ¬ p )) where

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

open import nat
import OD

open inOrdinal O
open OD O
open OD.OD
open OD._==_
open ODAxiom odAxiom
import OrdUtil
import ODUtil
open Ordinals.Ordinals  O
open Ordinals.IsOrdinals isOrdinal
open Ordinals.IsNext isNext
open OrdUtil O
open ODUtil O

open import zfc

open HOD

open _⊆_

decp : ( p : Set n ) → Dec p   -- assuming axiom of choice
decp  p with p∨¬p p
decp  p | case1 x = yes x
decp  p | case2 x = no x

∋-p : (A x : HOD ) → Dec ( A ∋ x )
∋-p A x with p∨¬p ( A ∋ x)  -- LEM
∋-p A x | case1 t  = yes t
∋-p A x | case2 t  = no (λ x → t x)

double-neg-eilm : {A : Set n} → ¬ ¬ A → A      -- we don't have this in intutionistic logic
double-neg-eilm  {A} notnot with decp  A                         -- assuming axiom of choice
... | yes p = p
... | no ¬p = ⊥-elim ( notnot ¬p )

power→⊆ :  ( A t : HOD) → Power A ∋ t → t ⊆ A
power→⊆ A t  PA∋t = record { incl = λ {x} t∋x → double-neg-eilm (λ not → t1 t∋x (λ x → not x) ) } where
   t1 : {x : HOD }  → t ∋ x → ¬ ¬ (A ∋ x)
   t1 = power→ A t PA∋t

--- With assuption of HOD is ordered,  p ∨ ( ¬ p ) <=> axiom of choice
---
record choiced  ( X : Ordinal ) : Set n where
  field
     a-choice : Ordinal
     is-in : odef (* X) a-choice

open choiced

-- ∋→d : ( a : HOD  ) { x : HOD } → * (& a) ∋ x → X ∋ * (a-choice (choice-func X not))
-- ∋→d a lt = subst₂ (λ j k → odef j k) *iso (sym &iso) lt

oo∋ : { a : HOD} {  x : Ordinal } → odef (* (& a)) x → a ∋ * x
oo∋ lt = subst₂ (λ j k → odef j k) *iso (sym &iso) lt

∋oo : { a : HOD} {  x : Ordinal } → a ∋ * x → odef (* (& a)) x
∋oo lt = subst₂ (λ j k → odef j k ) (sym *iso) &iso lt

OD→ZFC : ZFC
OD→ZFC   = record {
    ZFSet = HOD
    ; _∋_ = _∋_
    ; _≈_ = _=h=_
    ; ∅  = od∅
    ; Select = Select
    ; isZFC = isZFC
 } where
    -- infixr  200 _∈_
    -- infixr  230 _∩_ _∪_
    isZFC : IsZFC (HOD )  _∋_  _=h=_ od∅ Select
    isZFC = record {
       choice-func = λ A {X} not A∋X → * (a-choice (choice-func X not) );
       choice = λ A {X} A∋X not → oo∋ (is-in (choice-func X not))
     } where
         --
         -- the axiom choice from LEM and OD ordering
         --
         choice-func :  (X : HOD ) → ¬ ( X =h= od∅ ) → choiced (& X)
         choice-func  X not = have_to_find where
                 ψ : ( ox : Ordinal ) → Set n
                 ψ ox = (( x : Ordinal ) → x o< ox  → ( ¬ odef X x )) ∨ choiced (& X)
                 lemma-ord : ( ox : Ordinal  ) → ψ ox
                 lemma-ord  ox = TransFinite0 {ψ} induction ox where
                    ∀-imply-or :  {A : Ordinal  → Set n } {B : Set n }
                        → ((x : Ordinal ) → A x ∨ B) →  ((x : Ordinal ) → A x) ∨ B
                    ∀-imply-or  {A} {B} ∀AB with p∨¬p ((x : Ordinal ) → A x) -- LEM
                    ∀-imply-or  {A} {B} ∀AB | case1 t = case1 t
                    ∀-imply-or  {A} {B} ∀AB | case2 x  = case2 (lemma (λ not → x not )) where
                         lemma : ¬ ((x : Ordinal ) → A x) →  B
                         lemma not with p∨¬p B
                         lemma not | case1 b = b
                         lemma not | case2 ¬b = ⊥-elim  (not (λ x → dont-orb (∀AB x) ¬b ))
                    induction : (x : Ordinal) → ((y : Ordinal) → y o< x → ψ y) → ψ x
                    induction x prev with ∋-p X ( * x)
                    ... | yes p = case2 ( record { a-choice = x ; is-in = ∋oo  p } )
                    ... | no ¬p = lemma where
                         lemma1 : (y : Ordinal) → (y o< x → odef X y → ⊥) ∨ choiced (& X)
                         lemma1 y with ∋-p X (* y)
                         lemma1 y | yes y<X = case2 ( record { a-choice = y ; is-in = ∋oo y<X } )
                         lemma1 y | no ¬y<X = case1 ( λ lt y<X → ¬y<X (d→∋ X y<X) )
                         lemma :  ((y : Ordinal) → y o< x → odef X y → ⊥) ∨ choiced (& X)
                         lemma = ∀-imply-or lemma1
                 odef→o< :  {X : HOD } → {x : Ordinal } → odef X x → x o< & X
                 odef→o<  {X} {x} lt = o<-subst  {_} {_} {x} {& X} ( c<→o< ( subst₂ (λ j k → odef j k )  (sym *iso) (sym &iso)  lt )) &iso &iso
                 have_to_find : choiced (& X)
                 have_to_find = dont-or  (lemma-ord (& X )) ¬¬X∋x where
                     ¬¬X∋x : ¬ ((x : Ordinal) → x o< (& X) → odef X x → ⊥)
                     ¬¬X∋x nn = not record {
                            eq→ = λ {x} lt → ⊥-elim  (nn x (odef→o< lt)  lt)
                          ; eq← = λ {x} lt → ⊥-elim ( ¬x<0 lt )
                        }

         --
         --  axiom regurality from ε-induction (using axiom of choice above)
         --
         --  from https://math.stackexchange.com/questions/2973777/is-it-possible-to-prove-regularity-with-transfinite-induction-only
         --
         -- FIXME : don't use HOD make this level n, so we can remove ε-induction1
         record Minimal (x : HOD)  : Set (suc n) where
           field
               min : HOD
               x∋min :   x ∋ min
               min-empty :  (y : HOD ) → ¬ ( min ∋ y) ∧ (x ∋ y)
         open Minimal
         open _∧_
         induction : {x : HOD} → ({y : HOD} → x ∋ y → (u : HOD ) → (u∋x : u ∋ y) → Minimal u )
              →  (u : HOD ) → (u∋x : u ∋ x) → Minimal u
         induction {x} prev u u∋x with p∨¬p ((y : Ordinal ) → ¬ (odef x y) ∧ (odef u y))
         ... | case1 P =
              record { min = x
                ;     x∋min = u∋x
                ;     min-empty = λ y → P (& y)
              }
         ... | case2 NP =  min2 where
              p : HOD
              p  = record { od = record { def = λ y1 → odef x  y1 ∧ odef u y1 } ; odmax = omin (odmax x) (odmax u) ; <odmax = lemma } where
                 lemma : {y : Ordinal} → OD.def (od x) y ∧ OD.def (od u) y → y o< omin (odmax x) (odmax u)
                 lemma {y} lt = min1 (<odmax x (proj1 lt)) (<odmax u (proj2 lt))
              np : ¬ (p =h= od∅)
              np p∅ =  NP (λ y p∋y → ∅< {p} {_} (d→∋ p p∋y) p∅ )
              y1choice : choiced (& p)
              y1choice = choice-func p np
              y1 : HOD
              y1 = * (a-choice y1choice)
              y1prop : (x ∋ y1) ∧ (u ∋ y1)
              y1prop = oo∋ (is-in y1choice)
              min2 : Minimal u
              min2 = prev (proj1 y1prop) u (proj2 y1prop)
         Min2 : (x : HOD) → (u : HOD ) → (u∋x : u ∋ x) → Minimal u
         Min2 x u u∋x = (ε-induction {λ y →  (u : HOD ) → (u∋x : u ∋ y) → Minimal u  } induction x u u∋x )
         cx : {x : HOD} →  ¬ (x =h= od∅ ) → choiced (& x )
         cx {x} nx = choice-func x nx
         minimal : (x : HOD  ) → ¬ (x =h= od∅ ) → HOD
         minimal x ne = min (Min2 (* (a-choice (cx {x} ne) )) x ( oo∋ (is-in (cx ne))) )
         x∋minimal : (x : HOD  ) → ( ne : ¬ (x =h= od∅ ) ) → odef x ( & ( minimal x ne ) )
         x∋minimal x ne = x∋min (Min2 (* (a-choice (cx {x} ne) )) x ( oo∋ (is-in (cx ne))) )
         minimal-1 : (x : HOD  ) → ( ne : ¬ (x =h= od∅ ) ) → (y : HOD ) → ¬ ( odef (minimal x ne) (& y)) ∧ (odef x (&  y) )
         minimal-1 x ne y = min-empty (Min2 (* (a-choice (cx ne) )) x ( oo∋ (is-in (cx ne)))) y


-- Convert between `X` and `X-Bool`

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

module Constructive.Axiom.Properties.Bool where

-- agda-stdlib
open import Level renaming (suc to lsuc; zero to lzero)
open import Data.Empty
open import Data.Unit using (⊤; tt)
open import Data.Bool using (Bool; true; false; not)
open import Data.Sum as Sum
open import Data.Product as Prod
open import Function.Base
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl; subst; sym; cong)

-- agda-misc
open import Constructive.Axiom
open import Constructive.Combinators
open import Constructive.Common

private
  toBool : ∀ {a p} {A : Set a} {P : A → Set p} →
           DecU P → (A → Bool)
  toBool P? x = ⌊ dec⊎⇒dec (P? x) ⌋

  toDecU : ∀ {a} p {A : Set a} (P : A → Bool) →
           DecU (λ x → lift {ℓ = p} (P x) ≡ lift true)
  toDecU p P x with P x
  ... | false = inj₂ (λ ())
  ... | true  = inj₁ refl

  lift-injective : ∀ {a ℓ} {A : Set a} {x y : A} →
                   lift {ℓ = ℓ} x ≡ lift y → x ≡ y
  lift-injective refl = refl

  lift-injective′ : ∀ {a ℓ} {A : Set a} {P : A → Bool} →
                    ∃ (λ x → lift {ℓ = ℓ} (P x) ≡ lift true) →
                    ∃ (λ x → P x ≡ true)
  lift-injective′ = Prod.map₂ lift-injective

  lift-cong′ : ∀ {a p} {A : Set a} {P : A → Bool} →
               ∃ (λ x → P x ≡ true) → ∃ (λ x → lift (P x) ≡ lift true)
  lift-cong′ {p = p} (x , y) = x , cong (lift {ℓ = p}) y

  module _ {a p} {A : Set a} {P : A → Set p} (P? : DecU P) where
    from-eq : ∀ x → toBool P? x ≡ true → P x
    from-eq x eq with P? x
    from-eq x eq | inj₁ Px = Px
    from-eq x () | inj₂ ¬Px

    equal-refl : (∃P : ∃ P) → toBool P? (proj₁ ∃P) ≡ true
    equal-refl (x , Px) with P? x
    ... | inj₁ _   = refl
    ... | inj₂ ¬Px = ⊥-elim $ ¬Px Px

    ∃eq⇒∃P : (∃ λ x → toBool P? x ≡ true) → ∃ P
    ∃eq⇒∃P (x , eq) = x , from-eq x eq

    ∃P⇒∃eq : ∃ P → ∃ λ x → toBool P? x ≡ true
    ∃P⇒∃eq ∃P@(x , Px) = x , equal-refl ∃P

-- LPO <=> LPO-Bool
lpo⇒lpo-Bool : ∀ {a p} {A : Set a} → LPO A p → LPO-Bool A
lpo⇒lpo-Bool {a} {p} lpo P =
  Sum.map lift-injective′ (contraposition lift-cong′) $ lpo (toDecU p P)

lpo-Bool⇒lpo : ∀ {a} p {A : Set a} → LPO-Bool A → LPO A p
lpo-Bool⇒lpo p lpo-Bool P? =
  Sum.map (∃eq⇒∃P P?) (contraposition (∃P⇒∃eq P?)) $
          lpo-Bool (toBool P?)

-- LLPO <=> LLPO-Bool
llpo⇒llpo-Bool : ∀ {a p} {A : Set a} → LLPO A p → LLPO-Bool A
llpo⇒llpo-Bool {a} {p} llpo P Q h =
  Sum.map (contraposition lift-cong′) (contraposition lift-cong′) $
          llpo (toDecU p P) (toDecU p Q)
          (contraposition (Prod.map lift-injective′ lift-injective′) h)

llpo-Bool⇒llpo : ∀ {a} p {A : Set a} → LLPO-Bool A → LLPO A p
llpo-Bool⇒llpo p llpo-Bool P? Q? ¬[∃P×∃Q] =
  Sum.map (contraposition (∃P⇒∃eq P?)) (contraposition (∃P⇒∃eq Q?)) $
          llpo-Bool (toBool P?) (toBool Q?)
                    (contraposition (Prod.map (∃eq⇒∃P P?) (∃eq⇒∃P Q?)) ¬[∃P×∃Q])

-- MP⊎ <=> MP⊎-Bool
mp⊎⇒mp⊎-Bool : ∀ {a p} {A : Set a} → MP⊎ A p → MP⊎-Bool A
mp⊎⇒mp⊎-Bool {a} {p} mp⊎ P Q ¬[¬∃Peq×¬∃Qeq] =
  Sum.map
    (DN-map lift-injective′) (DN-map lift-injective′) $ mp⊎
      (toDecU p P) (toDecU p Q) (contraposition (λ {(u , v) →
      contraposition lift-cong′ u , contraposition lift-cong′ v}) ¬[¬∃Peq×¬∃Qeq])

mp⊎-Bool⇒mp⊎ : ∀ {a} p {A : Set a} → MP⊎-Bool A → MP⊎ A p
mp⊎-Bool⇒mp⊎ p mp⊎-Bool P? Q? ¬[¬∃P×¬Q] =
  Sum.map (DN-map (∃eq⇒∃P P?)) (DN-map (∃eq⇒∃P Q?)) $
          mp⊎-Bool (toBool P?) (toBool Q?) (contraposition (Prod.map
            (contraposition (∃P⇒∃eq P?)) (contraposition (∃P⇒∃eq Q?))) ¬[¬∃P×¬Q])

-- LPO-Bool <=> LPO-Bool-Alt
private
  not-injective : ∀ {x y} → not x ≡ not y → x ≡ y
  not-injective {false} {false} refl = refl
  not-injective {false} {true}  ()
  not-injective {true}  {false} ()
  not-injective {true}  {true}  refl = refl

  x≡false⇒x≢true : ∀ {x} → x ≡ false → x ≢ true
  x≡false⇒x≢true {false} refl ()

  not[x]≢true⇒x≡true : ∀ {x} → not x ≢ true → x ≡ true
  not[x]≢true⇒x≡true {false} neq = ⊥-elim $ neq refl
  not[x]≢true⇒x≡true {true}  _   = refl

  not[x]≡true→x≢true : ∀ {x} → not x ≡ true → x ≢ true
  not[x]≡true→x≢true notx≡true = x≡false⇒x≢true (not-injective notx≡true)

  x≢true⇒x≡false : ∀ {x} → x ≢ true → x ≡ false
  x≢true⇒x≡false {false} neq = refl
  x≢true⇒x≡false {true}  neq = ⊥-elim $ neq refl

lpo-Bool⇒lpo-Bool-Alt : ∀ {a} {A : Set a} → LPO-Bool A → LPO-Bool-Alt A
lpo-Bool⇒lpo-Bool-Alt lpo-Bool P =
  Sum.map (Prod.map₂ not-injective)
          (λ ¬∃notPx≡true x → not[x]≢true⇒x≡true $ ¬∃P→∀¬P ¬∃notPx≡true x) $
            lpo-Bool (not ∘ P)

lpo-Bool-Alt⇒lpo-Bool : ∀ {a} {A : Set a} → LPO-Bool-Alt A → LPO-Bool A
lpo-Bool-Alt⇒lpo-Bool lpo-Bool-Alt P =
  Sum.map (Prod.map₂ not-injective)
          (λ ∀x→notPx≡true → ∀¬P→¬∃P λ x → not[x]≡true→x≢true $ ∀x→notPx≡true x) $
            lpo-Bool-Alt (not ∘ P)


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

module HITs.PropositionalTruncation.Equivalence where

open import Prelude
open import Relation.Binary
open import HITs.PropositionalTruncation
open import HITs.PropositionalTruncation.Sugar

trunc-equivalence : ∀ {a} {A : Type a} → Equivalence A a → Equivalence A a
trunc-equivalence e .Equivalence._≋_ x y = ∥ Equivalence._≋_ e x y ∥
trunc-equivalence e .Equivalence.sym = _∥$∥_ (Equivalence.sym e)
trunc-equivalence e .Equivalence.refl = ∣ Equivalence.refl e ∣
trunc-equivalence e .Equivalence.trans xy yz = ⦇ (Equivalence.trans e) xy yz ⦈


module Binding where

open import Agda.Primitive

data Freer {ℓ} (F : Set ℓ → Set (lsuc ℓ)) (A : Set (lsuc ℓ)) : Set (lsuc ℓ) where
  pure : A → Freer F A
  free : ∀ {a : Set ℓ} → (a → Freer F A) → F a → Freer F A


open import Common.Prelude
open import Common.Equality
open import Common.Reflection

pattern _`+_ a b = def (quote _+_) (vArg a ∷ vArg b ∷ [])

`_ : Term → Term
` con c [] = con (quote Term.con) (vArg (lit (qname c)) ∷ vArg (con (quote []) []) ∷ [])
` _        = unknown

-- Prevent quotation
data WrapTerm : Set where
  wrap : Term → WrapTerm

macro
  eval : WrapTerm → Tactic
  eval (wrap u) hole = bindTC (normalise u) λ u → unify hole (` u)

t : Term
t = lam visible (abs "n" (lit (nat 1) `+ var 0 []))

lem : eval (wrap t) ≡ Term.con (quote suc) []
lem = refl


open import Oscar.Prelude
open import Oscar.Class

module Oscar.Class.Hmap where

module Hmap
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  {𝔯₁} {𝔯₂}
  (ℜ₁ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁)
  (ℜ₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₂)
  = ℭLASS (ℜ₁ , ℜ₂)
          (∀ x y
           → ℜ₁ x y → ℜ₂ x y)

module _
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  {𝔯₁} {𝔯₂}
  {ℜ₁ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁}
  {ℜ₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₂}
  where
  hmap = Hmap.method ℜ₁ ℜ₂

module _
  {𝔵} {𝔛 : Ø 𝔵}
  {𝔯₁} {𝔯₂}
  {ℜ₁ : 𝔛 → 𝔛 → Ø 𝔯₁}
  {ℜ₂ : 𝔛 → 𝔛 → Ø 𝔯₂}
  where
  smap : ⦃ _ : Hmap.class ℜ₁ ℜ₂ ⦄ → ∀ {x y} → ℜ₁ x y → ℜ₂ x y
  smap = Hmap.method ℜ₁ ℜ₂ _ _
  § = smap

module _
  {𝔵} {𝔛 : Ø 𝔵}
  {𝔯₁} {𝔯₂}
  {ℜ₁ : 𝔛 → 𝔛 → Ø 𝔯₁}
  (ℜ₂ : 𝔛 → 𝔛 → Ø 𝔯₂)
  where
  smap[_] : ⦃ _ : Hmap.class ℜ₁ ℜ₂ ⦄ → ∀ {x y} → ℜ₁ x y → ℜ₂ x y
  smap[_] = Hmap.method ℜ₁ ℜ₂ _ _
  §[_] = smap[_]


module Type.Properties.Decidable.Proofs where

open import Data
open import Data.Proofs
open import Data.Boolean using (if_then_else_)
open import Data.Boolean.Stmt
open import Data.Either as Either using (_‖_)
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
import      Lvl
open import Data.Boolean using (Bool ; 𝑇 ; 𝐹)
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Lang.Inspect
open import Logic
open import Logic.Classical
open import Logic.Predicate
open import Logic.Propositional
open import Numeral.Natural
open import Relator.Equals.Proofs.Equiv
open import Type.Properties.Decidable
open import Type.Properties.Empty
open import Type.Properties.Inhabited
open import Type.Properties.Singleton.Proofs
open import Type

private variable ℓ ℓₚ : Lvl.Level
private variable A B C P Q R T : Type{ℓ}
private variable b b₁ b₂ d : Bool
private variable f : A → B

module _ (P : Stmt{ℓ}) where
  decider-classical : ⦃ dec : Decider₀(P)(d) ⦄ → Classical(P)
  Classical.excluded-middle (decider-classical ⦃ dec = dec ⦄) = elim(\_ → (P ∨ (¬ P))) [∨]-introₗ [∨]-introᵣ dec

  classical-decidable : ⦃ classical : Classical(P) ⦄ → Decidable(0)(P)
  ∃.witness classical-decidable = Either.isLeft(excluded-middle(P))
  ∃.proof   classical-decidable with excluded-middle(P) | inspect Either.isLeft(excluded-middle(P))
  ... | Either.Left  p  | _ = true  p
  ... | Either.Right np | _ = false np

  module _ {ℓ₂} {x y : R} {Pred : (P ∨ (¬ P)) → R → Type{ℓ₂}} where
    decider-if-intro : ∀{f} ⦃ dec : Decider₀(P)(f) ⦄ → ((p : P) → Pred(Either.Left p)(x)) → ((np : (¬ P)) → Pred(Either.Right np)(y)) → Pred(excluded-middle(P) ⦃ decider-classical ⦄)(if f then x else y)
    decider-if-intro {f = 𝑇} ⦃ true  p  ⦄ fp _   = fp  p
    decider-if-intro {f = 𝐹} ⦃ false np ⦄ _  fnp = fnp np

decider-to-classical : ⦃ dec : Decider₀(P)(d) ⦄ → Classical(P)
decider-to-classical{P = P} = decider-classical(P)

classical-to-decidable : ⦃ classical : Classical(P) ⦄ → Decidable(0)(P)
classical-to-decidable{P = P} = classical-decidable(P)

classical-to-decider : ⦃ classical : Classical(P) ⦄ → Decider(0)(P)([∃]-witness classical-to-decidable)
classical-to-decider{P = P} = [∃]-proof classical-to-decidable

decider-true : ⦃ dec : Decider₀(P)(b) ⦄ → (P ↔ IsTrue(b))
decider-true ⦃ dec = true  p ⦄  = [↔]-intro (const p) (const <>)
decider-true ⦃ dec = false np ⦄ = [↔]-intro empty (empty ∘ np)

decider-false : ⦃ dec : Decider₀(P)(b) ⦄ → ((P → Empty{ℓ}) ↔ IsFalse(b))
decider-false ⦃ dec = true  p ⦄  = [↔]-intro empty (empty ∘ apply p)
decider-false ⦃ dec = false np ⦄ = [↔]-intro (const(empty ∘ np)) (const <>)

isempty-decider : ⦃ empty : IsEmpty(P) ⦄ → Decider₀(P)(𝐹)
isempty-decider ⦃ intro p ⦄ = false (empty ∘ p)

inhabited-decider : ⦃ inhab : (◊ P) ⦄ → Decider₀(P)(𝑇)
inhabited-decider ⦃ intro ⦃ p ⦄ ⦄ = true p

empty-decider : Decider₀(Empty{ℓ})(𝐹)
empty-decider = isempty-decider

unit-decider : Decider₀(Unit{ℓ})(𝑇)
unit-decider = inhabited-decider ⦃ unit-is-pos ⦄

instance
  tuple-decider : ⦃ dec-P : Decider₀(P)(b₁) ⦄ → ⦃ dec-Q : Decider₀(Q)(b₂) ⦄ → Decider₀(P ⨯ Q)(b₁ && b₂)
  tuple-decider ⦃ true  p ⦄  ⦃ true  q ⦄  = true(p , q)
  tuple-decider ⦃ true  p ⦄  ⦃ false nq ⦄ = false(nq ∘ Tuple.right)
  tuple-decider ⦃ false np ⦄ ⦃ true  q ⦄  = false(np ∘ Tuple.left)
  tuple-decider ⦃ false np ⦄ ⦃ false nq ⦄ = false(np ∘ Tuple.left)

instance
  either-decider : ⦃ dec-P : Decider₀(P)(b₁) ⦄ → ⦃ dec-Q : Decider₀(Q)(b₂) ⦄ → Decider₀(P ‖ Q)(b₁ || b₂)
  either-decider ⦃ true  p ⦄  ⦃ true  q ⦄  = true (Either.Left p)
  either-decider ⦃ true  p ⦄  ⦃ false nq ⦄ = true (Either.Left p)
  either-decider ⦃ false np ⦄ ⦃ true  q ⦄  = true (Either.Right q)
  either-decider ⦃ false np ⦄ ⦃ false nq ⦄ = false (Either.elim np nq)

instance
  function-decider : ⦃ dec-P : Decider₀(P)(b₁) ⦄ → ⦃ dec-Q : Decider₀(Q)(b₂) ⦄ → Decider₀(P → Q)((! b₁) || b₂)
  function-decider ⦃ true  p ⦄  ⦃ true  q ⦄  = true (const q)
  function-decider ⦃ true  p ⦄  ⦃ false nq ⦄ = false (apply p ∘ (nq ∘_))
  function-decider ⦃ false np ⦄ ⦃ true  q ⦄  = true (const q)
  function-decider ⦃ false np ⦄ ⦃ false nq ⦄ = true (empty ∘ np)

instance
  not-decider : ⦃ dec : Decider₀(P)(b) ⦄ → Decider₀(¬ P)(! b)
  not-decider = function-decider {b₂ = 𝐹} ⦃ dec-Q = empty-decider ⦄

instance
  IsTrue-decider : Decider₀(IsTrue(b))(b)
  IsTrue-decider {𝑇} = true <>
  IsTrue-decider {𝐹} = false id


module Homotopy where

infixr 20 _◎_

open import Data.Product

------------------------------------------------------------------------------
-- Level 0
-- Start with this set and its elements

data B : Set where
  ZERO  : B
  ONE   : B
  PLUS  : B → B → B
  TIMES : B → B → B

------------------------------------------------------------------------------
-- Level 1
-- Now we introduce Id_B. Given b1 : B, b2 : B, we have the types
-- Id_B(b1,b2) of equivalences

data Id_B : B × B → Set where
  unite₊  : { b : B } → Id_B (PLUS ZERO b , b)
  uniti₊  : { b : B } → Id_B (b , PLUS ZERO b)
  swap₊   : { b₁ b₂ : B } → Id_B (PLUS b₁ b₂ , PLUS b₂ b₁)
  assocl₊ : { b₁ b₂ b₃ : B } → Id_B (PLUS b₁ (PLUS b₂ b₃) , PLUS (PLUS b₁ b₂) b₃)
  assocr₊ : { b₁ b₂ b₃ : B } → Id_B (PLUS (PLUS b₁ b₂) b₃ , PLUS b₁ (PLUS b₂ b₃))
  unite⋆  : { b : B } → Id_B (TIMES ONE b , b)
  uniti⋆  : { b : B } → Id_B (b , TIMES ONE b)
  swap⋆   : { b₁ b₂ : B } → Id_B (TIMES b₁ b₂ , TIMES b₂ b₁)
  assocl⋆ : { b₁ b₂ b₃ : B } →
            Id_B (TIMES b₁ (TIMES b₂ b₃) , TIMES (TIMES b₁ b₂) b₃)
  assocr⋆ : { b₁ b₂ b₃ : B } →
            Id_B (TIMES (TIMES b₁ b₂) b₃ , TIMES b₁ (TIMES b₂ b₃))
  dist    : { b₁ b₂ b₃ : B } →
            Id_B (TIMES (PLUS b₁ b₂) b₃ , PLUS (TIMES b₁ b₃) (TIMES b₂ b₃))
  factor  : { b₁ b₂ b₃ : B } →
            Id_B (PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) , TIMES (PLUS b₁ b₂) b₃)
  id⟷   : { b : B } → Id_B (b , b)
  sym    : { b₁ b₂ : B } → Id_B (b₁ , b₂) → Id_B (b₂ , b₁)
  _◎_    : { b₁ b₂ b₃ : B } → Id_B (b₁ , b₂) → Id_B (b₂ , b₃) → Id_B (b₁ , b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : B } →
           Id_B (b₁ , b₃) → Id_B (b₂ , b₄) → Id_B (PLUS b₁ b₂ , PLUS b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : B } →
           Id_B (b₁ , b₃) → Id_B (b₂ , b₄) → Id_B (TIMES b₁ b₂ , TIMES b₃ b₄)

-- values

data BVAL : B → Set where
  UNIT : BVAL ONE
  LEFT : {b₁ b₂ : B} → BVAL b₁ → BVAL (PLUS b₁ b₂)
  RIGHT : {b₁ b₂ : B} → BVAL b₂ → BVAL (PLUS b₁ b₂)
  PAIR : {b₁ b₂ : B} → BVAL b₁ → BVAL b₂ → BVAL (TIMES b₁ b₂)

mutual

  eval : {b₁ b₂ : B} → Id_B (b₁ , b₂) → BVAL b₁ → BVAL b₂
  eval unite₊ (LEFT ())
  eval unite₊ (RIGHT v) = v
  eval uniti₊ v = RIGHT v
  eval swap₊ (LEFT v) = RIGHT v
  eval swap₊ (RIGHT v) = LEFT v
  eval assocl₊ (LEFT v) = LEFT (LEFT v)
  eval assocl₊ (RIGHT (LEFT v)) = LEFT (RIGHT v)
  eval assocl₊ (RIGHT (RIGHT v)) = RIGHT v
  eval assocr₊ (LEFT (LEFT v)) = LEFT v
  eval assocr₊ (LEFT (RIGHT v)) = RIGHT (LEFT v)
  eval assocr₊ (RIGHT v) = RIGHT (RIGHT v)
  eval unite⋆ (PAIR UNIT v) = v
  eval uniti⋆ v = PAIR UNIT v
  eval swap⋆ (PAIR v1 v2) = PAIR v2 v1
  eval assocl⋆ (PAIR v1 (PAIR v2 v3)) = PAIR (PAIR v1 v2) v3
  eval assocr⋆ (PAIR (PAIR v1 v2) v3) = PAIR v1 (PAIR v2 v3)
  eval dist (PAIR (LEFT v1) v3) = LEFT (PAIR v1 v3)
  eval dist (PAIR (RIGHT v2) v3) = RIGHT (PAIR v2 v3)
  eval factor (LEFT (PAIR v1 v3)) = PAIR (LEFT v1) v3
  eval factor (RIGHT (PAIR v2 v3)) = PAIR (RIGHT v2) v3
  eval id⟷ v = v
  eval (sym c) v = evalB c v
  eval (c₁ ◎ c₂) v = eval c₂ (eval c₁ v)
  eval (c₁ ⊕ c₂) (LEFT v) = LEFT (eval c₁ v)
  eval (c₁ ⊕ c₂) (RIGHT v) = RIGHT (eval c₂ v)
  eval (c₁ ⊗ c₂) (PAIR v₁ v₂) = PAIR (eval c₁ v₁) (eval c₂ v₂)

  evalB : {b₁ b₂ : B} → Id_B (b₁ , b₂) → BVAL b₂ → BVAL b₁
  evalB unite₊ v = RIGHT v
  evalB uniti₊ (LEFT ())
  evalB uniti₊ (RIGHT v) = v
  evalB swap₊ (LEFT v) = RIGHT v
  evalB swap₊ (RIGHT v) = LEFT v
  evalB assocl₊ (LEFT (LEFT v)) = LEFT v
  evalB assocl₊ (LEFT (RIGHT v)) = RIGHT (LEFT v)
  evalB assocl₊ (RIGHT v) = RIGHT (RIGHT v)
  evalB assocr₊ (LEFT v) = LEFT (LEFT v)
  evalB assocr₊ (RIGHT (LEFT v)) = LEFT (RIGHT v)
  evalB assocr₊ (RIGHT (RIGHT v)) = RIGHT v
  evalB unite⋆ v = PAIR UNIT v
  evalB uniti⋆ (PAIR UNIT v) = v
  evalB swap⋆ (PAIR v1 v2) = PAIR v2 v1
  evalB assocl⋆ (PAIR (PAIR v1 v2) v3) = PAIR v1 (PAIR v2 v3)
  evalB assocr⋆ (PAIR v1 (PAIR v2 v3)) = PAIR (PAIR v1 v2) v3
  evalB dist (LEFT (PAIR v1 v3)) = PAIR (LEFT v1) v3
  evalB dist (RIGHT (PAIR v2 v3)) = PAIR (RIGHT v2) v3
  evalB factor (PAIR (LEFT v1) v3) = LEFT (PAIR v1 v3)
  evalB factor (PAIR (RIGHT v2) v3) = RIGHT (PAIR v2 v3)
  evalB id⟷ v = v
  evalB (sym c) v = eval c v
  evalB (c₁ ◎ c₂) v = evalB c₁ (evalB c₂ v)
  evalB (c₁ ⊕ c₂) (LEFT v) = LEFT (evalB c₁ v)
  evalB (c₁ ⊕ c₂) (RIGHT v) = RIGHT (evalB c₂ v)
  evalB (c₁ ⊗ c₂) (PAIR v₁ v₂) = PAIR (evalB c₁ v₁) (evalB c₂ v₂)

------------------------------------------------------------------------------
-- Level 2

-- Now we introduce Id_{Id_B}. Given c1 : Id_B(b1,b2) and c2 :
-- Id_B(b1,b2), we have the type of equivalences that show that c1 and
-- c2 are isomorphic.
--
-- We want:
--
-- data Id_Id_B : {b₁ b₂ : B} → Id_B (b₁ , b₂) × Id_B (b₁ , b₂) → Set where
--  ...
-- but before we do that we need to embed the combinators as values that can
-- be manipulated using combinators

-- define the category Int C whose objects are pairs (B,B) and which has an
-- inverse recip sending (B1,B2) to (B2,B1) and then the compact closed
-- eta/epsilon where eta : I -> (A+,A-) * (recip (A+,A-))

-- the embedding send B to (B,I)

-- INT B has as objects pairs of B objects

{--
data Id_BB : (B × B) × (B × B) → Set where
  intarr : { b₁ b₂ b₃ b₄ : B } → Id_BB ((b₁ , b₂) , (b₃ , b₄))

embedArr : { b₁ b₂ b₃ b₄ : B } →
           Id_BB ((b₁ , b₂) , (b₃ , b₄)) → Id_B ((b₁ , b₄) , (b₂ , b₃))
embedArr x = ?

  Iuniti₊  : { b : B } → Id_BB (b , PLUS ZERO b)
  Iswap₊   : { b₁ b₂ : B } → Id_BB (PLUS b₁ b₂ , PLUS b₂ b₁)
  Iassocl₊ : { b₁ b₂ b₃ : B } → Id_BB (PLUS b₁ (PLUS b₂ b₃) , PLUS (PLUS b₁ b₂) b₃)
  Iassocr₊ : { b₁ b₂ b₃ : B } → Id_BB (PLUS (PLUS b₁ b₂) b₃ , PLUS b₁ (PLUS b₂ b₃))
  Iunite⋆  : { b : B } → Id_BB (TIMES ONE b , b)
  Iuniti⋆  : { b : B } → Id_BB (b , TIMES ONE b)
  Iswap⋆   : { b₁ b₂ : B } → Id_BB (TIMES b₁ b₂ , TIMES b₂ b₁)
  Iassocl⋆ : { b₁ b₂ b₃ : B } →
            Id_BB (TIMES b₁ (TIMES b₂ b₃) , TIMES (TIMES b₁ b₂) b₃)
  Iassocr⋆ : { b₁ b₂ b₃ : B } →
            Id_BB (TIMES (TIMES b₁ b₂) b₃ , TIMES b₁ (TIMES b₂ b₃))
  Idist    : { b₁ b₂ b₃ : B } →
            Id_BB (TIMES (PLUS b₁ b₂) b₃ , PLUS (TIMES b₁ b₃) (TIMES b₂ b₃))
  Ifactor  : { b₁ b₂ b₃ : B } →
            Id_BB (PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) , TIMES (PLUS b₁ b₂) b₃)
  Iid⟷   : { b : B } → Id_BB (b , b)
  Isym    : { b₁ b₂ : B } → Id_BB (b₁ , b₂) → Id_BB (b₂ , b₁)
  _I◎_    : { b₁ b₂ b₃ : B } → Id_BB (b₁ , b₂) → Id_BB (b₂ , b₃) → Id_BB (b₁ , b₃)
  _I⊕_    : { b₁ b₂ b₃ b₄ : B } →
           Id_BB (b₁ , b₃) → Id_BB (b₂ , b₄) → Id_BB (PLUS b₁ b₂ , PLUS b₃ b₄)
  _I⊗_    : { b₁ b₂ b₃ b₄ : B } →
           Id_BB (b₁ , b₃) → Id_BB (b₂ , b₄) → Id_BB (TIMES b₁ b₂ , TIMES b₃ b₄)

data BRVAL : BR → Set where
  UNITR : BRVAL ONER
  LEFTR : {b₁ b₂ : BR} → BRVAL b₁ → BRVAL (PLUSR b₁ b₂)
  RIGHTR : {b₁ b₂ : BR} → BRVAL b₂ → BRVAL (PLUSR b₁ b₂)
  PAIRR : {b₁ b₂ : BR} → BRVAL b₁ → BRVAL b₂ → BRVAL (TIMESR b₁ b₂)
  RECIPR : {b : BR} → BRVAL b → BRVAL (RECIP b)

embedT : B → BR
embedT ZERO = ZEROR
embedT ONE = ONER
embedT (PLUS b₁ b₂) = PLUSR (embedT b₁) (embedT b₂)
embedT (TIMES b₁ b₂) = TIMESR (embedT b₁) (embedT b₂)

embedV : {b : B} → BVAL b → BRVAL (embedT b)
embedV UNIT = UNITR
embedV (LEFT v) = LEFTR (embedV v)
embedV (RIGHT v) = RIGHTR (embedV v)
embedV (PAIR v₁ v₂) = PAIRR (embedV v₁) (embedV v₂)

embedC : {b₁ b₂ : B} →
         Id_B (b₁ , b₂) → BRVAL (TIMESR (RECIP (embedT b₁)) (embedT b₂))
embedC unite₊ = ?
embedC uniti₊ = ?
embedC swap₊ = ?
embedC assocl₊ = ?
embedC assocr₊ = ?
embedC unite⋆ = ?
embedC uniti⋆ = ?
embedC swap⋆ = ?
embedC assocl⋆ = ?
embedC assocr⋆ = ?
embedC dist = ?
embedC factor = ?
embedC id⟷ = ?
embedC (sym c) = ?
embedC (c₁ ◎ c₂) = ?
embedC (c₁ ⊕ c₂) = ?
embedC (c₁ ⊗ c₂) = ?
--}


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

open import lib.Basics
open import lib.types.Group
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Truncation
open import lib.groups.GroupProduct
open import lib.groups.Homomorphisms

module lib.groups.TruncationGroup where

module _ {i} {El : Type i} (GS : GroupStructure El) where

  Trunc-group-struct : GroupStructure (Trunc 0 El)
  Trunc-group-struct = record {
    ident = [ ident GS ];
    inv = Trunc-fmap (inv GS);
    comp = _⊗_;
    unitl = t-unitl;
    unitr = t-unitr;
    assoc = t-assoc;
    invl = t-invl;
    invr = t-invr}
    where
    open GroupStructure
    infix 80 _⊗_
    _⊗_ = Trunc-fmap2 (comp GS)

    abstract
      t-unitl : (t : Trunc 0 El) → [ ident GS ] ⊗ t == t
      t-unitl = Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
        (ap [_] ∘ unitl GS)

      t-unitr : (t : Trunc 0 El) → t ⊗ [ ident GS ] == t
      t-unitr = Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
        (ap [_] ∘ unitr GS)

      t-assoc : (t₁ t₂ t₃ : Trunc 0 El) → (t₁ ⊗ t₂) ⊗ t₃ == t₁ ⊗ (t₂ ⊗ t₃)
      t-assoc = Trunc-elim
        (λ _ → Π-level (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level)))
        (λ a → Trunc-elim
          (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level))
          (λ b → Trunc-elim
             (λ _ → =-preserves-level _ Trunc-level)
             (λ c → ap [_] (assoc GS a b c))))

      t-invl : (t : Trunc 0 El) → Trunc-fmap (inv GS) t ⊗ t == [ ident GS ]
      t-invl = Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
        (ap [_] ∘ invl GS)

      t-invr : (t : Trunc 0 El) → t ⊗ Trunc-fmap (inv GS) t == [ ident GS ]
      t-invr = Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
        (ap [_] ∘ invr GS)

  Trunc-group : Group i
  Trunc-group = record {
    El = Trunc 0 El;
    El-level = Trunc-level;
    group-struct = Trunc-group-struct }

Trunc-group-× : ∀ {i j} {A : Type i} {B : Type j}
  (GS : GroupStructure A) (HS : GroupStructure B)
  → Trunc-group (×-group-struct GS HS) == Trunc-group GS ×ᴳ Trunc-group HS
Trunc-group-× GS HS = group-ua
  (record {
    f = Trunc-rec (×-level Trunc-level Trunc-level)
          (λ {(a , b) → ([ a ] , [ b ])});
    pres-comp =
      Trunc-elim
        (λ _ → (Π-level (λ _ → =-preserves-level _
                                 (×-level Trunc-level Trunc-level))))
        (λ a → Trunc-elim
          (λ _ → =-preserves-level _ (×-level Trunc-level Trunc-level))
          (λ b → idp))} ,
   is-eq _
    (uncurry (Trunc-rec (→-level Trunc-level)
               (λ a → Trunc-rec Trunc-level (λ b → [ a , b ]))))
    (uncurry (Trunc-elim
               (λ _ → Π-level (λ _ → =-preserves-level _
                                       (×-level Trunc-level Trunc-level)))
               (λ a → Trunc-elim
                        (λ _ → =-preserves-level _
                                 (×-level Trunc-level Trunc-level))
                        (λ b → idp))))
    (Trunc-elim (λ _ → =-preserves-level _ Trunc-level) (λ _ → idp)))

Trunc-group-hom : ∀ {i j} {A : Type i} {B : Type j}
  {GS : GroupStructure A} {HS : GroupStructure B} (f : A → B)
  → ((a₁ a₂ : A) → f (GroupStructure.comp GS a₁ a₂)
                   == GroupStructure.comp HS (f a₁) (f a₂))
  → (Trunc-group GS →ᴳ Trunc-group HS)
Trunc-group-hom {A = A} {GS = GS} {HS = HS} f p =
  record {f = Trunc-fmap f; pres-comp = pres-comp}
  where
  abstract
    pres-comp : (t₁ t₂ : Trunc 0 A) →
      Trunc-fmap f (Trunc-fmap2 (GroupStructure.comp GS) t₁ t₂)
      == Trunc-fmap2 (GroupStructure.comp HS)
           (Trunc-fmap f t₁) (Trunc-fmap f t₂)
    pres-comp =
      Trunc-elim (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level))
        (λ a₁ → Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
          (λ a₂ → ap [_] (p a₁ a₂)))

Trunc-group-iso : ∀ {i} {A B : Type i}
  {GS : GroupStructure A} {HS : GroupStructure B} (f : A → B)
  → ((a₁ a₂ : A) → f (GroupStructure.comp GS a₁ a₂)
                   == GroupStructure.comp HS (f a₁) (f a₂))
  → is-equiv f → Trunc-group GS ≃ᴳ Trunc-group HS
Trunc-group-iso f pres-comp ie =
  (Trunc-group-hom f pres-comp ,
   is-eq _ (Trunc-fmap (is-equiv.g ie))
     (Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
       (λ b → ap [_] (is-equiv.f-g ie b)))
     (Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
       (λ a → ap [_] (is-equiv.g-f ie a))))

Trunc-group-abelian : ∀ {i} {A : Type i} (GS : GroupStructure A)
  → ((a₁ a₂ : A) → GroupStructure.comp GS a₁ a₂ == GroupStructure.comp GS a₂ a₁)
  → is-abelian (Trunc-group GS)
Trunc-group-abelian GS ab =
  Trunc-elim (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level)) $
    λ a₁ → Trunc-elim (λ _ → =-preserves-level _ Trunc-level) $
      λ a₂ → ap [_] (ab a₁ a₂)


-- An ATP local hint can be only a postulate, function or a data
-- constructor.

-- This error is detected by Syntax.Translation.ConcreteToAbstract.

module ATPBadLocalHint3 where

postulate
  D    : Set
  _≡_  : D → D → Set
  zero : D
  succ : D → D

data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

refl : ∀ n → N n → n ≡ n
refl n Nn = prf
  where
    postulate prf : n ≡ n
    {-# ATP prove prf Nn #-}


open import Data.Product using ( _,_ )
open import Data.Sum using ( _⊎_ )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; _*_ )
open import Web.Semantic.DL.ABox.Model using ( _⊨a_ ; _⊨b_ ; *-resp-⟨ABox⟩ )
open import Web.Semantic.DL.Category.Object using ( Object ; _,_ ; IN )
open import Web.Semantic.DL.Category.Morphism using ( _⇒_ ; _,_ ; BN ; impl )
open import Web.Semantic.DL.Category.Tensor using
  ( _⟨⊗⟩_ ; ⊨a-intro-⟨&⟩ ; ⊨b-intro-⟨&⟩ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.Util using ( _⊕_⊕_ ; up ; down )

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

tensor-up : ∀ {A₁ A₂ B₁ B₂ : Object S T} (F₁ : A₁ ⇒ B₁) (F₂ : A₂ ⇒ B₂) I →
  (I ⊨a impl (F₁ ⟨⊗⟩ F₂)) → (up * I ⊨a impl F₁)
tensor-up {X₁ , X₁∈Fin , A₁} {X₂ , X₂∈Fin , A₂} {Y₁ , Y₁∈Fin , B₁} {Y₂ , Y₂∈Fin , B₂}
  (V₁ , F₁ , F₁✓) (V₂ , F₂ , F₂✓) I (I⊨F₁ , I⊨F₂) = *-resp-⟨ABox⟩ up I F₁ I⊨F₁

tensor-down : ∀ {A₁ A₂ B₁ B₂ : Object S T} (F₁ : A₁ ⇒ B₁) (F₂ : A₂ ⇒ B₂) I →
  (I ⊨a impl (F₁ ⟨⊗⟩ F₂)) → (down * I ⊨a impl F₂)
tensor-down  {X₁ , X₁∈Fin , A₁} {X₂ , X₂∈Fin , A₂} {Y₁ , Y₁∈Fin , B₁} {Y₂ , Y₂∈Fin , B₂}
  (V₁ , F₁ , F₁✓) (V₂ , F₂ , F₂✓) I (I⊨F₁ , I⊨F₂) = *-resp-⟨ABox⟩ down I F₂ I⊨F₂

tensor-resp-⊨a : ∀ {A₁ A₂ B₁ B₂ : Object S T}
  (F₁ : A₁ ⇒ B₁) (F₂ : A₂ ⇒ B₂) →
    (I : Interp Σ ((IN A₁ ⊎ IN A₂) ⊕ (BN F₁ ⊎ BN F₂) ⊕ (IN B₁ ⊎ IN B₂))) →
      (up * I ⊨a impl F₁) → (down * I ⊨a impl F₂) → (I ⊨a impl (F₁ ⟨⊗⟩ F₂))
tensor-resp-⊨a  {X₁ , X₁∈Fin , A₁} {X₂ , X₂∈Fin , A₂} {Y₁ , Y₁∈Fin , B₁} {Y₂ , Y₂∈Fin , B₂}
  (V₁ , F₁ , F₁✓) (V₂ , F₂ , F₂✓) I I₁⊨F₁ I₂⊨F₂ =
    ⊨a-intro-⟨&⟩ I F₁ F₂ I₁⊨F₁ I₂⊨F₂

tensor-resp-⊨b : ∀ {A₁ A₂ B₁ B₂ : Object S T} {V₁ V₂ : Set}
  (F₁ : A₁ ⇒ B₁) (F₂ : A₂ ⇒ B₂) →
    (I : Interp Σ ((IN A₁ ⊎ IN A₂) ⊕ (V₁ ⊎ V₂) ⊕ (IN B₁ ⊎ IN B₂))) →
      (up * I ⊨b impl F₁) → (down * I ⊨b impl F₂) → (I ⊨b impl (F₁ ⟨⊗⟩ F₂))
tensor-resp-⊨b  {X₁ , X₁∈Fin , A₁} {X₂ , X₂∈Fin , A₂} {Y₁ , Y₁∈Fin , B₁} {Y₂ , Y₂∈Fin , B₂}
    (V₁ , F₁ , F₁✓) (V₂ , F₂ , F₂✓) I I⊨F₁ I⊨F₂ =
      ⊨b-intro-⟨&⟩ I F₁ F₂ I⊨F₁ I⊨F₂


module Relation.Path where

open import Relation.Path.Operation


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

open import homotopy.3x3.Common
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose

module homotopy.JoinAssoc3x3 {i} (A B C : Type i) where

open M using (Pushout^2)

join-assoc-span^2 : Span^2 {i}
join-assoc-span^2 =
  span^2 A (A × C) (A × C) (A × B) ((A × B) × C) (A × C) B (B × C) C
         fst (idf _) fst (λ u → fst (fst u) , snd u) fst snd fst snd (λ u → fst (fst u) , snd u) (λ u → snd (fst u) , snd u) (idf _) snd
         (λ _ → idp) (λ _ → idp) (λ _ → idp) (λ _ → idp)

open import homotopy.3x3.Commutes join-assoc-span^2 as PP

module _ (A B : Type i) (f : B → A) where

  lemma3-fun : Pushout (span A B B f (idf _)) → A
  lemma3-fun = Lemma3Fun.f  module _ where

    module Lemma3Fun = PushoutRec (idf _) f (λ _ → idp)

  lemma3-eq : (x : Pushout (span A B B f (idf _))) → left (lemma3-fun x) == x
  lemma3-eq = Pushout-elim (λ _ → idp) glue (λ b → ↓-∘=idf-in left lemma3-fun (idp,=□idp,-in idp ∙□-i/ idp / ! (ap (ap left) (Lemma3Fun.glue-β b)) /))

  lemma3 : Pushout (span A B B f (idf _)) ≃ A
  lemma3 = equiv lemma3-fun left (λ _ → idp) lemma3-eq

module _ (A B : Type i) (f : B → A) where

  lemma3'-fun : Pushout (span B A B (idf _) f) → A
  lemma3'-fun = Lemma3'Fun.f  module _ where

    module Lemma3'Fun = PushoutRec f (idf _) (λ _ → idp)

  lemma3'-eq : (x : Pushout (span B A B (idf _) f)) → right (lemma3'-fun x) == x
  lemma3'-eq = ! ∘ (Pushout-elim glue (λ _ → idp) (λ b → ↓-idf=∘-in right lemma3'-fun (,idp=□,idp-in idp ∙□-i/ ap (ap right) (Lemma3'Fun.glue-β b) / idp /)))

  lemma3' : Pushout (span B A B (idf _) f) ≃ A
  lemma3' = equiv lemma3'-fun right (λ _ → idp) lemma3'-eq

module _ (X Y Z T : Type i) (f : Z → X) (g : Z → Y) where

  private
    P1 : Type i
    P1 = Pushout (span X Y Z f g)

    P2 : Type i
    P2 = Pushout (span (X × T) (Y × T) (Z × T) (λ u → (f (fst u) , snd u)) (λ u → (g (fst u) , snd u)))

  lemma4 : P2 ≃ (P1 × T)
  lemma4 = equiv to from to-from from-to  module Lemma4 where

    to : P2 → P1 × T
    to = To.f  module _ where

      module To = PushoutRec (λ u → (left (fst u) , snd u)) (λ u → (right (fst u) , snd u)) (λ u → pair×= (glue (fst u)) idp)

    from-curr : T → (P1 → P2)
    from-curr t = FromCurr.f  module _ where

      module FromCurr = PushoutRec {D = P2} (λ x → left (x , t)) (λ y → right (y , t)) (λ z → glue (z , t))

    from : P1 × T → P2
    from (x , t) = from-curr t x

    to-from : (u : P1 × T) → to (from u) == u
    to-from (x , t) = to-from-curr t x  where

      ap-idf,×cst : ∀ {i j} {A : Type i} {B : Type j}
        {x y : A} (p : x == y) {b : B}
        → ap (λ v → v , b) p == pair×= p idp
      ap-idf,×cst idp = idp

      to-from-curr : (t : T) (x : P1) → to (from-curr t x) == (x , t)
      to-from-curr t = Pushout-elim (λ _ → idp) (λ _ → idp) (λ z → ↓-='-in (ap-idf,×cst (glue z) ∙ ! (To.glue-β (z , t)) ∙ ! (ap (ap to) (FromCurr.glue-β t z)) ∙ ∘-ap to (from-curr t) (glue z)))

    from-to : (u : P2) → from (to u) == u
    from-to = Pushout-elim (λ _ → idp) (λ _ → idp) (λ c → ↓-∘=idf-in from to (! (ap (ap from) (To.glue-β c) ∙ ap-pair×= from (glue (fst c)) ∙ FromCurr.glue-β (snd c) (fst c))))  where

      ap-pair×= : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : A × B → C)
        {a a' : A} (p : a == a') {b : B}
        → ap f (pair×= p idp) == ap (λ a → f (a , b)) p
      ap-pair×= f {a = a} {a' = .a} idp = idp

module _ (X Y T : Type i) where

  private
    P1 : Type i
    P1 = Pushout (span X Y (X × Y) fst snd)

    P2 : Type i
    P2 = Pushout (span (T × X) (T × Y) ((T × X) × Y) fst (λ u → (fst (fst u) , snd u)))

  lemma4' : P2 ≃ (T × P1)
  lemma4' = equiv to from to-from from-to  module Lemma4' where

    to : P2 → T × P1
    to = To.f  module _ where

      module To = PushoutRec {D = T × P1} (λ u → (fst u , left (snd u))) (λ u → (fst u , right (snd u))) (λ c → pair×= idp (glue (snd (fst c) , snd c)))

    from-curr : T → (P1 → P2)
    from-curr t = FromCurr.f  module _ where

      module FromCurr = PushoutRec {D = P2} (λ x → left (t , x)) (λ y → right (t , y)) (λ z → glue ((t , fst z) , snd z))

    from : T × P1 → P2
    from (t , x) = from-curr t x

    to-from : (u : T × P1) → to (from u) == u
    to-from (t , x) = to-from-curr t x  where

      to-from-curr : (t : T) (x : P1) → to (from-curr t x) == (t , x)
      to-from-curr t = Pushout-elim (λ _ → idp) (λ _ → idp) (λ c → ↓-='-in (ap-cst,id (λ _ → _) (glue c) ∙ ! (lemma5 c)))  where

        lemma5 : (c : X × Y) → ap (to ∘ from-curr t) (glue c) == pair×= idp (glue c)
        lemma5 (x , y) =
          ap (to ∘ from-curr t) (glue (x , y))
            =⟨ ap-∘ to (from-curr t) (glue (x , y)) ⟩
          ap to (ap (from-curr t) (glue (x , y)))
            =⟨ FromCurr.glue-β t (x , y) |in-ctx ap to ⟩
          ap to (glue ((t , x) , y))
            =⟨ To.glue-β ((t , x) , y) ⟩
          pair×= idp (glue (x , y)) ∎

    from-to : (x : P2) → from (to x) == x
    from-to = Pushout-elim (λ _ → idp) (λ _ → idp) (λ c → ↓-∘=idf-in from to (! (lemma42 c)))  where

      ap-pair×= : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : A × B → C)
        {a : A} {b b' : B} (p : b == b')
        → ap f (pair×= idp p) == ap (λ b → f (a , b)) p
      ap-pair×= f {b = b} {b' = .b} idp = idp

      lemma42 : (c : (T × X) × Y) → ap from (ap to (glue c)) == glue c
      lemma42 ((t , x) , y) =
        ap from (ap to (glue ((t , x) , y)))
          =⟨ To.glue-β ((t , x) , y) |in-ctx ap from ⟩
        ap from (pair×= idp (glue (x , y)))
          =⟨ ap-pair×= from (glue (x , y)) ⟩
        ap (from-curr t) (glue (x , y))
          =⟨ FromCurr.glue-β t (x , y) ⟩
        glue ((t , x) , y) ∎

lemma2 : M.v-h-span join-assoc-span^2 == *-span A (B * C)
lemma2 = span= (lemma3 A (A × C) fst) (ide _) (lemma4' B C A)
               (Pushout-elim (λ _ → idp) (λ _ → idp) (λ x → ↓-='-in (lemma2-1 x ∙ ! (lemma2-2 x))))
               (Pushout-elim (λ _ → idp) (λ _ → idp) (λ x → ↓-='-in (lemma2-3 x ∙ ! (M.F₃∙.glue-β join-assoc-span^2 _ ∙ ∙-unit-r (glue _))))) where

  lemma2-1 : (x : (A × B) × C) → _
  lemma2-1 ((a , b) , c) =
    ap (fst ∘ Lemma4'.to B C A) (glue ((a , b) , c))
      =⟨ ap-∘ fst (Lemma4'.to B C A) (glue ((a , b) , c)) ⟩
    ap fst (ap (Lemma4'.to B C A) (glue ((a , b) , c)))
      =⟨ Lemma4'.To.glue-β B C A ((a , b) , c) |in-ctx fst×= ⟩
    fst×= (pair×= idp (glue (b , c)))
      =⟨ fst×=-β idp (glue (b , c)) ⟩
    idp ∎

  lemma2-2 : (x : (A × B) × C) → _
  lemma2-2 ((a , b) , c) =
    ap (lemma3-fun A (A × C) fst ∘ M.f₁∙ join-assoc-span^2) (glue ((a , b) , c))
      =⟨ ap-∘ (lemma3-fun A (A × C) fst) (M.f₁∙ join-assoc-span^2) (glue ((a , b) , c)) ⟩
    ap (lemma3-fun A (A × C) fst) (ap (M.f₁∙ join-assoc-span^2) (glue ((a , b) , c)))
      =⟨ M.F₁∙.glue-β join-assoc-span^2 ((a , b) , c) |in-ctx ap (lemma3-fun A (A × C) fst) ⟩
    ap (lemma3-fun A (A × C) fst) (glue (a , c) ∙ idp)
      =⟨ ∙-unit-r (glue (a , c)) |in-ctx ap (lemma3-fun A (A × C) fst) ⟩
    ap (lemma3-fun A (A × C) fst) (glue (a , c))
      =⟨ Lemma3Fun.glue-β A (A × C) fst (a , c) ⟩
    idp ∎

  lemma2-3 : (x : (A × B) × C) → _
  lemma2-3 ((a , b) , c) =
    ap (snd ∘ Lemma4'.to B C A) (glue ((a , b) , c))
      =⟨ ap-∘ snd (Lemma4'.to B C A) (glue ((a , b) , c)) ⟩
    ap snd (ap (Lemma4'.to B C A) (glue ((a , b) , c)))
      =⟨ Lemma4'.To.glue-β B C A ((a , b) , c) |in-ctx snd×= ⟩
    snd×= (pair×= idp (glue (b , c)))
      =⟨ snd×=-β idp (glue (b , c)) ⟩
    glue (b , c) ∎

lemma2' : M.v-h-span (transpose join-assoc-span^2) == *-span (A * B) C
lemma2' = span= (ide _) (lemma3' C (A × C) snd) (lemma4 A B (A × B) C fst snd)
          (Pushout-elim (λ _ → idp) (λ _ → idp) (λ c → ↓-='-in (ap-∘ fst (Lemma4.to A B (A × B) C fst snd) (glue c) ∙ ap (ap fst) (Lemma4.To.glue-β A B (A × B) C fst snd c) ∙ fst×=-β (glue (fst c)) idp ∙ ! (∙-unit-r (glue (fst c))) ∙ ! (M.F₁∙.glue-β (transpose join-assoc-span^2) c))))
          (Pushout-elim (λ _ → idp) (λ _ → idp) (λ u → ↓-='-in (lemma2'-1 u ∙ ! (lemma2'-2 u))))  where

  lemma2'-1 : (u : (A × B) × C) → ap (snd ∘ Lemma4.to A B (A × B) C fst snd) (glue u) == idp
  lemma2'-1 u =
    ap (snd ∘ Lemma4.to A B (A × B) C fst snd) (glue u)
      =⟨ ap-∘ snd (Lemma4.to A B (A × B) C fst snd) (glue u) ⟩
    ap snd (ap (Lemma4.to A B (A × B) C fst snd) (glue u))
      =⟨ Lemma4.To.glue-β A B (A × B) C fst snd u |in-ctx snd×= ⟩
    snd×= (pair×= (glue (fst u)) idp)
      =⟨ snd×=-β (glue (fst u)) idp ⟩
    idp ∎

  lemma2'-2 : (u : (A × B) × C) → ap (lemma3'-fun C (A × C) snd ∘ M.f₃∙ (transpose join-assoc-span^2)) (glue u) == idp
  lemma2'-2 u =
    ap (lemma3'-fun C (A × C) snd ∘ M.f₃∙ (transpose join-assoc-span^2)) (glue u)
      =⟨ ap-∘ (lemma3'-fun C (A × C) snd) (M.f₃∙ (transpose join-assoc-span^2)) (glue u) ⟩
    ap (lemma3'-fun C (A × C) snd) (ap (M.f₃∙ (transpose join-assoc-span^2)) (glue u))
      =⟨ M.F₃∙.glue-β (transpose join-assoc-span^2) u |in-ctx ap (lemma3'-fun C (A × C) snd) ⟩
    ap (lemma3'-fun C (A × C) snd) (glue (fst (fst u) , snd u) ∙ idp)
      =⟨ ∙-unit-r (glue (fst (fst u) , snd u)) |in-ctx ap (lemma3'-fun C (A × C) snd) ⟩
    ap (lemma3'-fun C (A × C) snd) (glue (fst (fst u) , snd u))
      =⟨ Lemma3'Fun.glue-β C (A × C) snd (fst (fst u) , snd u) ⟩
    idp ∎

lemma1 : Pushout^2 join-assoc-span^2 == A * (B * C)
lemma1 = ap Pushout lemma2

lemma1' : Pushout^2 (transpose join-assoc-span^2) == (A * B) * C
lemma1' = ap Pushout lemma2'

*-assoc : A * (B * C) == (A * B) * C
*-assoc = ! lemma1 ∙ ua PP.theorem ∙ lemma1'


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

module Experiment.ListRelationProperties where

open import Level

open import Data.Bool hiding (_≤_; _≤?_; _<_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List
import Data.List.Properties as Listₚ
import      Data.Nat as ℕ
import Data.Nat.Properties as ℕₚ
open import Data.Product hiding (swap)

import      Data.List.Relation.Binary.Equality.Setoid as ListSetoidEquality
import Data.List.Relation.Binary.Permutation.Setoid as PermutationSetoid
import Data.List.Relation.Binary.Permutation.Setoid.Properties
  as PermutationSetoidProperties
open import Data.List.Relation.Unary.All as All
import      Data.List.Relation.Unary.All.Properties as Allₚ
open import Data.List.Relation.Unary.Any as Any
open import Data.List.Relation.Unary.Linked
import      Data.List.Relation.Unary.Linked.Properties as Linkedₚ
open import Data.List.Relation.Unary.AllPairs as AllPairs
import      Data.List.Relation.Unary.AllPairs.Properties as AllPairsₚ
open import Data.List.Membership.Propositional

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

open import Relation.Binary as B
import      Relation.Binary.Properties.DecTotalOrder as DecTotalOrderProperties
open import Relation.Binary.PropositionalEquality using (_≡_)
import      Relation.Binary.PropositionalEquality as ≡ hiding ([_])
import      Relation.Binary.Reasoning.Setoid as SetoidReasoning
open import Relation.Nullary
open import Relation.Unary as U hiding (_∈_)

-- stdlib
foldr-preservesʳ : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p} {f : A → B → B}
  → (∀ x {y} → P y → P (f x y))
  → ∀ {e} → P e → ∀ xs → P (foldr f e xs)
foldr-preservesʳ pres Pe []       = Pe
foldr-preservesʳ pres Pe (x ∷ xs) = pres _ (foldr-preservesʳ pres Pe xs)

-- stdlib
module _ {a p q} {A : Set a} {P : U.Pred A p} {Q : U.Pred A q} where
  All-mapWith∈ : ∀ {xs : List A} → (∀ {x} → x ∈ xs → P x → Q x) → All P xs → All Q xs
  All-mapWith∈          f []         = []
  All-mapWith∈ {x ∷ xs} f (px ∷ pxs) =
    f (here ≡.refl) px ∷ All-mapWith∈ (λ x∈xs Px → f (there x∈xs) Px) pxs

module _ {a p} {A : Set a} {P : U.Pred A p} where
  All-singleton⁺ : ∀ {x} → P x → All P [ x ]
  All-singleton⁺ px = px ∷ []

  All-reverse⁺ : ∀ {xs} → All P xs → All P (reverse xs)
  All-reverse⁺ {[]}     []         = []
  All-reverse⁺ {x ∷ xs} (px ∷ pxs) =
    ≡.subst (All P) (≡.sym $ Listₚ.unfold-reverse x xs)
            (Allₚ.++⁺ (All-reverse⁺ pxs) (All-singleton⁺ px))

module _ {a r} {A : Set a} {R : Rel A r} where

  -- AllPairs-map⁻
  -- AllPairs-mapMaybe⁺ : (∀ x y → R x y → R (f x) (f y)) → AllPairs R xs → AllPairs R (mapMaybe f xs)
  -- AllPairs mapMaybe⁻

  AllPairs-singleton⁺ : ∀ x → AllPairs R [ x ]
  AllPairs-singleton⁺ x = [] ∷ []

  AllPairs-pair : ∀ {x y} → R x y → AllPairs R (x ∷ y ∷ [])
  AllPairs-pair Rxy = All-singleton⁺ Rxy ∷ AllPairs-singleton⁺ _

  AllPairs-++⁻ʳ : ∀ xs {ys} → AllPairs R (xs ++ ys) → AllPairs R ys
  AllPairs-++⁻ʳ []       rxs        = rxs
  AllPairs-++⁻ʳ (x ∷ xs) (rx ∷ rxs) = AllPairs-++⁻ʳ xs rxs

  AllPairs-++⁻ˡ : ∀ xs {ys} → AllPairs R (xs ++ ys) → AllPairs R xs
  AllPairs-++⁻ˡ []       rxs        = []
  AllPairs-++⁻ˡ (x ∷ xs) (rx ∷ rxs) = Allₚ.++⁻ˡ xs rx ∷ AllPairs-++⁻ˡ xs rxs

  AllPairs-++⁻-AllAll : ∀ xs {ys} →
    AllPairs R (xs ++ ys) → All (λ x → All (R x) ys) xs
  AllPairs-++⁻-AllAll []       rxs        = []
  AllPairs-++⁻-AllAll (x ∷ xs) (rx ∷ rxs) = Allₚ.++⁻ʳ _ rx ∷ AllPairs-++⁻-AllAll xs rxs

  AllPairs-++⁻ : ∀ xs {ys} → AllPairs R (xs ++ ys) →
                 AllPairs R xs × AllPairs R ys × All (λ x → All (R x) ys) xs
  AllPairs-++⁻ xs rxs = AllPairs-++⁻ˡ xs rxs , AllPairs-++⁻ʳ xs rxs , AllPairs-++⁻-AllAll xs rxs

  AllPairs-∷ʳ⁺ : ∀ {x xs} → AllPairs R xs → All (flip R x) xs → AllPairs R (xs ∷ʳ x)
  AllPairs-∷ʳ⁺ {x} {xs} rxs px =
    AllPairsₚ.++⁺ rxs (AllPairs-singleton⁺ x) (All.map All-singleton⁺ px)

  AllPairs-∷ʳ⁻ : ∀ {x xs} → AllPairs R (xs ∷ʳ x) → AllPairs R xs × All (flip R x) xs
  AllPairs-∷ʳ⁻ {x} {xs} rxs with AllPairs-++⁻ xs rxs
  ... | rxs′ , _ , pxs = rxs′ , All.map Allₚ.singleton⁻ pxs

  AllPairs-reverse⁺ : ∀ {xs} → AllPairs (flip R) xs → AllPairs R (reverse xs)
  AllPairs-reverse⁺ {[]}     []         = []
  AllPairs-reverse⁺ {x ∷ xs} (rx ∷ rxs) =
    ≡.subst (AllPairs R) (≡.sym $ Listₚ.unfold-reverse x xs)
            (AllPairs-∷ʳ⁺ (AllPairs-reverse⁺ rxs) (All-reverse⁺ rx))

module _ {a r} {A : Set a} {R : Rel A r} where
  AllPairs-sym-reverse⁺ : Symmetric R → ∀ {xs} → AllPairs R xs → AllPairs R (reverse xs)
  AllPairs-sym-reverse⁺ sym = AllPairs.map sym ∘ AllPairs-reverse⁺

AllAll : ∀ {a b r} {A : Set a} {B : Set b} → REL A B r → List A → List B → Set _
AllAll R xs ys = All (λ x → All (R x) ys) xs

module _ {a r} {A : Set a} {R : Rel A r} where
  AllPairs-reverse⁻ : ∀ {xs} → AllPairs R (reverse xs) → AllPairs (flip R) xs
  AllPairs-reverse⁻ {xs} rxs =
    ≡.subst (AllPairs (flip R)) (Listₚ.reverse-involutive xs)
            (AllPairs-reverse⁺ rxs)

  -- concat⁻
{-
  AllPairs-concat⁺ : ∀ {xss} → AllAll (AllAll R) xss xss →
                     All (AllPairs R) xss → AllPairs R (concat xss)
  AllPairs-concat⁺ {[]}       rxss         pxss         = []
  AllPairs-concat⁺ {xs ∷ xss} (rxs ∷ rxss) (pxs ∷ pxss) =
    AllPairsₚ.++⁺ {xs = xs} pxs (AllPairs-concat⁺ {! proj₂ (unconsʳ rxs)  !} pxss) {!   !}
-}
  AllPairs-universal : B.Universal R → U.Universal (AllPairs R)
  AllPairs-universal u []       = []
  AllPairs-universal u (x ∷ xs) = All.universal (u _) _ ∷ AllPairs-universal u xs

  AllPairs-replicate⁺ : ∀ n {x} → R x x → AllPairs R (replicate n x)
  AllPairs-replicate⁺ ℕ.zero    Rxx = []
  AllPairs-replicate⁺ (ℕ.suc n) Rxx = Allₚ.replicate⁺ n Rxx ∷ AllPairs-replicate⁺ n Rxx

  AllPairs-replicate⁻ : ∀ {n x} → AllPairs R (replicate (ℕ.suc (ℕ.suc n)) x) → R x x
  AllPairs-replicate⁻ (pxs ∷ rxs) = Allₚ.replicate⁻ pxs

  -- AllPairs-drop⁺

  -- AllPairs-zipWith⁺ :

module _ {c e} (S : Setoid c e) where
  open Setoid S
  open ListSetoidEquality S
  Linked-resp-≋ : ∀ {r} {R : Rel Carrier r} →
                  R Respects₂ _≈_ → (Linked R) Respects _≋_
  Linked-resp-≋ resp [] [] = []
  Linked-resp-≋ resp (_ ∷ []) [-] = [-]
  Linked-resp-≋ resp (e₁ ∷ e₂ ∷ xs≋ys) (x ∷ l) =
   (proj₂ resp e₁ $ proj₁ resp e₂ x) ∷ Linked-resp-≋ resp (e₂ ∷ xs≋ys) l

module _ {a r} {A : Set a} {R : Rel A r} where

-- Linked-pair : R x y →

  Linked-++⁻ʳ : ∀ xs {ys} → Linked R (xs ++ ys) → Linked R ys
  Linked-++⁻ʳ []               rxs       = rxs
  Linked-++⁻ʳ (x ∷ []) {[]}    rxs       = []
  Linked-++⁻ʳ (x ∷ []) {_ ∷ _} (y ∷ rxs) = rxs
  Linked-++⁻ʳ (x ∷ y ∷ xs)     (_ ∷ rxs) = Linked-++⁻ʳ (y ∷ xs) rxs

  Linked-++⁻ˡ : ∀ xs {ys} → Linked R (xs ++ ys) → Linked R xs
  Linked-++⁻ˡ []           rxs        = []
  Linked-++⁻ˡ (x ∷ [])     rxs        = [-]
  Linked-++⁻ˡ (x ∷ y ∷ xs) (rx ∷ rxs) = rx ∷ Linked-++⁻ˡ (y ∷ xs) rxs

  Linked-∷⁻ʳ : ∀ {x xs} → Linked R (x ∷ xs) → Linked R xs
  Linked-∷⁻ʳ {x = x} = Linked-++⁻ʳ [ x ]

  Linked-∷ʳ⁻ˡ : ∀ {xs x} → Linked R (xs ∷ʳ x) → Linked R xs
  Linked-∷ʳ⁻ˡ {xs = xs} = Linked-++⁻ˡ xs
{-
  Linked-∷ʳ₂⁺ : ∀ {xs x y} → Linked R (xs ∷ʳ x) → R x y → Linked R (xs ∷ʳ x ∷ʳ y)
  Linked-∷ʳ₂⁺ {[]} {x} {y} [-] Rxy = Rxy ∷ [-]
  Linked-∷ʳ₂⁺ {x′ ∷ xs} {x} {y} l Rxy = {!   !}

  Linked-reverse⁺ : ∀ {xs} → Linked (flip R) xs → Linked R (reverse xs)
  Linked-reverse⁺ {[]} l = []
  Linked-reverse⁺ {x ∷ []} l = [-]
  Linked-reverse⁺ {x ∷ y ∷ xs} (Rxy ∷ l) = {! Rxy ∷   !}
-}

  -- Linked-inits⁺
  -- respects

  -- Linked-++⁻-middle : ∀ xs {ys} → Linked R (xs ++ ys) → Last (λ x → First (R x) ys) xs

  Linked-universal : B.Universal R → U.Universal (Linked R)
  Linked-universal u [] = []
  Linked-universal u (x ∷ []) = [-]
  Linked-universal u (x ∷ x₁ ∷ xs) = u x x₁ ∷ Linked-universal u (x₁ ∷ xs)

  module _ (R-trans : Transitive R) where
    private
      L⇒A : ∀ {xs} → Linked R xs → AllPairs R xs
      L⇒A = Linkedₚ.Linked⇒AllPairs R-trans
    Linked-trans-∷ : ∀ {x xs} → All (R x) xs → Linked R xs → Linked R (x ∷ xs)
    Linked-trans-∷ a l = Linkedₚ.AllPairs⇒Linked (a ∷ L⇒A l)

    Linked-trans-head : ∀ {x xs} → Linked R (x ∷ xs) → All (R x) xs
    Linked-trans-head = AllPairs.head ∘ L⇒A

{-
Linked-++⁺ : Linked R xs → Linked R ys → Frist (λ x → Last (λ y → R xy) ys) xs → Linked R (xs ++ ys)
-}

-- stdlib?
AllPairs-trans-∷₂ : ∀ {a r} {A : Set a} {R : Rel A r} {x y ys} →
  Transitive R →
  R x y → AllPairs R (y ∷ ys) → AllPairs R (x ∷ y ∷ ys)
AllPairs-trans-∷₂ R-trans Rxy rxs@(px ∷ _) =
  (Rxy ∷ All.map (λ {z} Ryz → R-trans Rxy Ryz) px) ∷ rxs
  -- Transitive R → AllPairs R (xs ∷ʳ v) → AllPairs R (v ∷ ys)
  -- AllPairs R (xs ++ [ v ] ++ ys)

  -- Transitive R → length ys ≥ 1 → AllPairs R (xs ++ ys) → AllPairs R (ys ++ zs) →
  -- AllPairs (xs ++ ys ++ zs)


module PiFrac.Examples where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Nat
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Maybe

open import PiFrac.Syntax
open import PiFrac.Opsem
open import PiFrac.Eval

-----------------------------------------------------------------------------
-- Patterns and data definitions

pattern 𝔹 = 𝟙 +ᵤ 𝟙
pattern 𝔽 = inj₁ tt
pattern 𝕋 = inj₂ tt

𝔹^ : ℕ → 𝕌
𝔹^ 0 = 𝟙
𝔹^ 1 = 𝔹
𝔹^ (suc (suc n)) = 𝔹 ×ᵤ 𝔹^ (suc n)

-----------------------------------------------------------------------------
-- Adaptors

[A+B]+C=[C+B]+A : ∀ {A B C} → (A +ᵤ B) +ᵤ C ↔ (C +ᵤ B) +ᵤ A
[A+B]+C=[C+B]+A = assocr₊ ⨾ (id↔ ⊕ swap₊) ⨾ swap₊

[A+B]+C=[A+C]+B : ∀ {A B C} → (A +ᵤ B) +ᵤ C ↔ (A +ᵤ C) +ᵤ B
[A+B]+C=[A+C]+B = assocr₊ ⨾ (id↔ ⊕ swap₊) ⨾ assocl₊

[A+B]+[C+D]=[A+C]+[B+D] : {A B C D : 𝕌} → (A +ᵤ B) +ᵤ (C +ᵤ D) ↔ (A +ᵤ C) +ᵤ (B +ᵤ D)
[A+B]+[C+D]=[A+C]+[B+D] = assocl₊ ⨾ (assocr₊ ⊕ id↔) ⨾ ((id↔ ⊕ swap₊) ⊕ id↔) ⨾ (assocl₊ ⊕ id↔) ⨾ assocr₊

Ax[BxC]=Bx[AxC] : {A B C : 𝕌} → A ×ᵤ (B ×ᵤ C) ↔ B ×ᵤ (A ×ᵤ C)
Ax[BxC]=Bx[AxC] = assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾  assocr⋆

[AxB]×C=[A×C]xB : ∀ {A B C} → (A ×ᵤ B) ×ᵤ C ↔ (A ×ᵤ C) ×ᵤ B
[AxB]×C=[A×C]xB = assocr⋆ ⨾ (id↔ ⊗ swap⋆) ⨾ assocl⋆

[A×B]×[C×D]=[A×C]×[B×D] : {A B C D : 𝕌} → (A ×ᵤ B) ×ᵤ (C ×ᵤ D) ↔ (A ×ᵤ C) ×ᵤ (B ×ᵤ D)
[A×B]×[C×D]=[A×C]×[B×D] = assocl⋆ ⨾ (assocr⋆ ⊗ id↔) ⨾ ((id↔ ⊗ swap⋆) ⊗ id↔) ⨾ (assocl⋆ ⊗ id↔) ⨾ assocr⋆

-- CNOT(b₁,b₂) = (b₁,b₁ xor b₂)
CNOT : 𝔹 ×ᵤ 𝔹 ↔ 𝔹 ×ᵤ 𝔹
CNOT = dist ⨾ (id↔ ⊕ (id↔ ⊗ swap₊)) ⨾ factor

-- Trace
trace⋆ : ∀ {A B C} → (c : ⟦ C ⟧) → A ×ᵤ C ↔ B ×ᵤ C → A ↔ B
trace⋆ c f = uniti⋆r ⨾ (id↔ ⊗ ηₓ c) ⨾ assocl⋆ ⨾
             (f ⊗ id↔) ⨾
             assocr⋆ ⨾ (id↔ ⊗ εₓ _) ⨾ unite⋆r

ex1 ex2 : Maybe ⟦ 𝟙 +ᵤ 𝟙 ⟧
ex1 = eval (trace⋆ (inj₁ tt) swap⋆) (inj₁ tt) -- just (inj₁ tt)
ex2 = eval (trace⋆ (inj₁ tt) swap⋆) (inj₂ tt) -- nothing

-----------------------------------------------------------------------------
-- Higher-Order Combinators
hof/ : {A B : 𝕌} → (A ↔ B) → (v : ⟦ A ⟧) → (𝟙 ↔ 𝟙/ v ×ᵤ B)
hof/ c v = ηₓ v ⨾ (c ⊗ id↔) ⨾ swap⋆

comp/ : {A B C : 𝕌} {v : ⟦ A ⟧} → (w : ⟦ B ⟧) →
        (𝟙/ v ×ᵤ B) ×ᵤ (𝟙/ w ×ᵤ C) ↔ (𝟙/ v ×ᵤ C)
comp/ w = assocl⋆ ⨾ (assocr⋆ ⊗ id↔) ⨾ ((id↔ ⊗ εₓ w) ⊗ id↔) ⨾ (unite⋆r ⊗ id↔)

app/ : {A B : 𝕌} → (v : ⟦ A ⟧) → (𝟙/ v ×ᵤ B) ×ᵤ A ↔ B
app/ v = swap⋆ ⨾ assocl⋆ ⨾ (εₓ _ ⊗ id↔) ⨾ unite⋆l

curry/ : {A B C : 𝕌} → (A ×ᵤ B ↔ C) → (v : ⟦ B ⟧) → (A ↔ 𝟙/ v ×ᵤ C)
curry/ c v = uniti⋆l ⨾ (ηₓ v ⊗ id↔) ⨾ swap⋆ ⨾ assocl⋆ ⨾ (c ⊗ id↔) ⨾ swap⋆

-- h.o. version of cnot specialized to input input (v , w)

htf : ∀ (v w : _) → 𝟙 ↔ 𝟙/ (v , w) ×ᵤ (𝔹 ×ᵤ 𝔹)
htf v w = hof/ CNOT (v , w)

-- applying htf to incoming input
htfc : ∀ (v w : _) → (𝔹 ×ᵤ 𝔹) ↔ (𝔹 ×ᵤ 𝔹)
htfc v w = uniti⋆l ⨾ (htf v w ⊗ id↔) ⨾ app/ (v , w)

htfca : ⟦ 𝔹 ×ᵤ 𝔹 ⟧ → Maybe ⟦ 𝔹 ×ᵤ 𝔹 ⟧
htfca (v , w) = eval (htfc v w) (v , w)

x1 x2 x3 x4 : Maybe ⟦ 𝔹 ×ᵤ 𝔹 ⟧
x1 = htfca (𝔽 , 𝔽) -- just (𝔽 , 𝔽)
x2 = htfca (𝔽 , 𝕋) -- just (𝔽 , 𝕋)
x3 = htfca (𝕋 , 𝔽) -- just (𝕋 , 𝕋)
x4 = htfca (𝕋 , 𝕋) -- just (𝕋 , 𝔽)

-----------------------------------------------------------------------------
-- Algebraic Identities
inv/ : {A : 𝕌} {v : ⟦ A ⟧} → A ↔ (𝟙/_ {𝟙/ v} ↻)
inv/ = uniti⋆r ⨾ (id↔ ⊗ ηₓ _) ⨾ assocl⋆ ⨾ (εₓ _ ⊗ id↔) ⨾ unite⋆l

dist/ : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → 𝟙/ (a , b) ↔ 𝟙/ a ×ᵤ 𝟙/ b
dist/ {A} {B} {a} {b} =
  uniti⋆l ⨾ (ηₓ b ⊗ id↔) ⨾ uniti⋆l ⨾ (ηₓ a ⊗ id↔) ⨾ assocl⋆ ⨾
  ([A×B]×[C×D]=[A×C]×[B×D] ⊗ id↔) ⨾
  (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾ (id↔ ⊗ εₓ (a , b)) ⨾ unite⋆r

neg/ : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → (A ↔ B) → (𝟙/ a ↔ 𝟙/ b)
neg/ {A} {B} {a} {b} c =
  uniti⋆r ⨾ (id↔ ⊗ ηₓ _) ⨾
  (id↔ ⊗ (! c) ⊗ id↔) ⨾ assocl⋆ ⨾
  ((swap⋆ ⨾ εₓ _) ⊗ id↔) ⨾ unite⋆l

fracDist : ∀ {A B} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → 𝟙/ a ×ᵤ 𝟙/ b ↔ 𝟙/ (a , b)
fracDist =
  uniti⋆l ⨾ ((ηₓ _ ⨾ swap⋆) ⊗ id↔) ⨾ assocr⋆ ⨾
  (id↔ ⊗ ([A×B]×[C×D]=[A×C]×[B×D] ⨾ (εₓ _ ⊗ εₓ _) ⨾ unite⋆l)) ⨾ unite⋆r

mulFrac : ∀ {A B C D} {b : ⟦ B ⟧} {d : ⟦ D ⟧}
        → (A ×ᵤ 𝟙/ b) ×ᵤ (C ×ᵤ 𝟙/ d) ↔ (A ×ᵤ C) ×ᵤ (𝟙/ (b , d))
mulFrac = [A×B]×[C×D]=[A×C]×[B×D] ⨾ (id↔ ⊗ fracDist)

addFracCom : ∀ {A B C} {v : ⟦ C ⟧}
        → (A ×ᵤ 𝟙/ v) +ᵤ (B ×ᵤ 𝟙/ v) ↔ (A +ᵤ B) ×ᵤ (𝟙/ v)
addFracCom = factor

addFrac : ∀ {A B C D} → (v : ⟦ C ⟧) → (w : ⟦ D ⟧)
        → (A ×ᵤ 𝟙/_ {C} v) +ᵤ (B ×ᵤ 𝟙/_ {D} w) ↔
         ((A ×ᵤ D) +ᵤ (C ×ᵤ B)) ×ᵤ (𝟙/_ {C ×ᵤ D} (v , w))
addFrac v w = ((uniti⋆r ⨾ (id↔ ⊗ ηₓ w)) ⊕ (uniti⋆l  ⨾ (ηₓ v ⊗ id↔))) ⨾
              [A×B]×[C×D]=[A×C]×[B×D] ⊕ [A×B]×[C×D]=[A×C]×[B×D] ⨾
              ((id↔ ⊗ fracDist) ⊕ (id↔ ⊗ fracDist)) ⨾ factor


{-# OPTIONS --with-K #-}

open import Level using (Level)

open import Axiom.UniquenessOfIdentityProofs.WithK using (uip)

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Data.Nat using (ℕ)
open import Data.Vec using (Vec)

open import FLA.Axiom.Extensionality.Propositional
open import FLA.Algebra.Structures
open import FLA.Algebra.LinearAlgebra
open import FLA.Algebra.LinearAlgebra.Properties
open import FLA.Algebra.LinearMap

module FLA.Algebra.LinearMap.Properties where

private
  variable
    ℓ : Level
    A : Set ℓ
    m n p q : ℕ
    ⦃ F ⦄ : Field A

-------------------------------------------------------------------------------
--                  LinearMap without the proofs: LinearMap↓                 --
-------------------------------------------------------------------------------

private
  data _⊸↓_ {A : Set ℓ} ⦃ F : Field A ⦄ (m n : ℕ) : Set ℓ where
    LM↓ : (Vec A m → Vec A n) → m ⊸↓ n

  _·ˡᵐ↓_ : ⦃ F : Field A ⦄ → m ⊸↓ n → Vec A m → Vec A n
  _·ˡᵐ↓_ (LM↓ f) = f

  -- Choose 20 since function application is assumed higher than almost anything
  infixr 20 _·ˡᵐ↓_

  L→L↓ : ⦃ F : Field A ⦄ → m ⊸ n → m ⊸↓ n
  L→L↓ record { f = f } = LM↓ f

  L↓→L : ⦃ F : Field A ⦄
        → (L↓ : m ⊸↓ n)
        → (f[u+v]≡f[u]+f[v] : (u v : Vec A m)
                             → L↓ ·ˡᵐ↓ (u +ⱽ v) ≡ L↓ ·ˡᵐ↓ u +ⱽ L↓ ·ˡᵐ↓ v)
        → (f[c*v]≡c*f[v] : (c : A) → (v : Vec A m)
                          → L↓ ·ˡᵐ↓ (c ∘ⱽ v) ≡ c ∘ⱽ (L↓ ·ˡᵐ↓ v))
        → m ⊸ n
  L↓→L (LM↓ f) f[u+v]≡f[u]+f[v] f[c*v]≡c*f[v] =
    record
      { f = f
      ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]
      ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]
      }

  f[u+v]≡f[u]+f[v]-UIP : {ℓ : Level} {A : Set ℓ} {m n : ℕ} → ⦃ F : Field A ⦄
    → (f : Vec A m → Vec A n)
    → (p q : (u v : Vec A m)
            → f (u +ⱽ v) ≡ f u +ⱽ f v)
    → p ≡ q
  f[u+v]≡f[u]+f[v]-UIP f p q =
    extensionality (λ u → extensionality (λ v → t f p q u v))
    where
      t : {ℓ : Level} {A : Set ℓ} {m n : ℕ} → ⦃ F : Field A ⦄
        → (f : Vec A m → Vec A n)
        → (p q : (u v : Vec A m)
                → f (u +ⱽ v) ≡ f u +ⱽ f v)
        → (u v : Vec A m) → p u v ≡ q u v
      t f p q u v = uip (p u v) (q u v)

  f[c*v]≡c*f[v]-UIP : {ℓ : Level} {A : Set ℓ} {m n : ℕ} → ⦃ F : Field A ⦄
                    → (f : Vec A m → Vec A n)
                    → (p q : (c : A) (v : Vec A m) → f (c ∘ⱽ v) ≡ c ∘ⱽ (f v))
                    → p ≡ q
  f[c*v]≡c*f[v]-UIP f p q =
    extensionality (λ c → extensionality (λ v → t f p q c v))
    where
      t : {ℓ : Level} {A : Set ℓ} {m n : ℕ} → ⦃ F : Field A ⦄
        → (f : Vec A m → Vec A n)
        → (p q : (c : A) (v : Vec A m) → f (c ∘ⱽ v) ≡ c ∘ⱽ (f v))
        → (c : A) (v : Vec A m) → p c v ≡ q c v
      t f p q c v = uip (p c v) (q c v)

  L↓≡→L≡ : ⦃ F : Field A ⦄ → (C D : m ⊸ n)
          → (L→L↓ C ≡ L→L↓ D) → C ≡ D
  L↓≡→L≡ record { f = f
                 ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]ᶜ
                 ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]ᶜ
                 }
          record { f = .f
                 ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]ᵈ
                 ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]ᵈ
                 }
          refl
    rewrite
      f[u+v]≡f[u]+f[v]-UIP f f[u+v]≡f[u]+f[v]ᶜ f[u+v]≡f[u]+f[v]ᵈ
    | f[c*v]≡c*f[v]-UIP f f[c*v]≡c*f[v]ᶜ f[c*v]≡c*f[v]ᵈ
    = refl

-------------------------------------------------------------------------------
--                   LinearMap Proofs via LinearMap↓ Proofs                  --
-------------------------------------------------------------------------------

module _ {ℓ : Level} {A : Set ℓ} ⦃ F : Field A ⦄ where
  open Field F
  open _⊸_

  +ˡᵐ-comm : (L R : m ⊸ n)
          → L +ˡᵐ R ≡ R +ˡᵐ L
  +ˡᵐ-comm L R = L↓≡→L≡ (L +ˡᵐ R) (R +ˡᵐ L) (+ˡᵐ-comm↓ L R)
    where
      +ⱽ-comm-ext : (f g : Vec A m → Vec A n)
        → (λ v → f v +ⱽ g v) ≡ (λ v → g v +ⱽ f v)
      +ⱽ-comm-ext f g = extensionality (λ v → +ⱽ-comm (f v) (g v))

      +ˡᵐ-comm↓ : (L R : m ⊸ n)
              → L→L↓ (L +ˡᵐ R) ≡ L→L↓ (R +ˡᵐ L)
      +ˡᵐ-comm↓ L R = cong LM↓ (+ⱽ-comm-ext (L ·ˡᵐ_) (R ·ˡᵐ_))

  *ˡᵐ-distr-+ˡᵐₗ : (X : n ⊸ m) → (Y Z : p ⊸ n)
                → (X *ˡᵐ (Y +ˡᵐ Z)) ≡ (X *ˡᵐ Y +ˡᵐ X *ˡᵐ Z)
  *ˡᵐ-distr-+ˡᵐₗ X Y Z = L↓≡→L≡ (X *ˡᵐ (Y +ˡᵐ Z)) ((X *ˡᵐ Y +ˡᵐ X *ˡᵐ Z))
                                (*ˡᵐ-distr-+ˡᵐₗ↓ X Y Z)
    where
      *-distr-+ⱽ : (X : n ⊸ m) → (Y Z : p ⊸ n)
        → (λ v → X ·ˡᵐ (Y ·ˡᵐ v +ⱽ Z ·ˡᵐ v)) ≡
          (λ v → X ·ˡᵐ (Y ·ˡᵐ v) +ⱽ X ·ˡᵐ (Z ·ˡᵐ v))
      *-distr-+ⱽ X Y Z = extensionality
        (λ v → f[u+v]≡f[u]+f[v] X (Y ·ˡᵐ v) (Z ·ˡᵐ v))

      *ˡᵐ-distr-+ˡᵐₗ↓ : (X : n ⊸ m) → (Y Z : p ⊸ n)
                      → L→L↓ (X *ˡᵐ (Y +ˡᵐ Z)) ≡ L→L↓ (X *ˡᵐ Y +ˡᵐ X *ˡᵐ Z)
      *ˡᵐ-distr-+ˡᵐₗ↓ X Y Z = cong LM↓ (*-distr-+ⱽ X Y Z)

  *ˡᵐ-distr-+ˡᵐᵣ : (X Y : n ⊸ m) → (Z : p ⊸ n)
                → (X +ˡᵐ Y) *ˡᵐ Z ≡ X *ˡᵐ Z +ˡᵐ Y *ˡᵐ Z
  *ˡᵐ-distr-+ˡᵐᵣ X Y Z = L↓≡→L≡ ((X +ˡᵐ Y) *ˡᵐ Z) (X *ˡᵐ Z +ˡᵐ Y *ˡᵐ Z)
                                (*ˡᵐ-distr-+ˡᵐᵣ↓ X Y Z)
    where
      *ˡᵐ-distr-+ˡᵐᵣ↓ : (X Y : n ⊸ m) → (Z : p ⊸ n)
                      → L→L↓ ((X +ˡᵐ Y) *ˡᵐ Z) ≡ L→L↓ (X *ˡᵐ Z +ˡᵐ Y *ˡᵐ Z)
      *ˡᵐ-distr-+ˡᵐᵣ↓ X Y Z = cong LM↓ refl


module L.Base.Empty.Core where

open import Agda.Primitive

-- Introducing the empty type
data ⊥ : Set where

exfalso : ∀{c} (C : ⊥ → Set c) → (a : ⊥) → C a
exfalso = λ C ()


{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.ANormalUntyped where

open import Agda.Primitive
open import Data.Empty
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Nat
import Data.Integer.Base as I
open I using (ℤ)
open import Data.Integer.Base using (ℤ)
open import Relation.Binary.PropositionalEquality

{- Typed deBruijn indexes for untyped languages. -}

-- Using a record gives an eta rule saying that all types are equal.
record Type : Set where
  constructor Uni

record DType : Set where
  constructor DUni

open import Base.Syntax.Context Type public
import Base.Syntax.Context DType as DC

data Term (Γ : Context) : Set where
  var : (x : Var Γ Uni) →
    Term Γ
  lett : (f : Var Γ Uni) → (x : Var Γ Uni) → Term (Uni • Γ) → Term Γ

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = DUni • ΔΔ Γ

derive-dvar : ∀ {Δ} → (x : Var Δ Uni) → DC.Var (ΔΔ Δ) DUni
derive-dvar this = DC.this
derive-dvar (that x) = DC.that (derive-dvar x)

data DTerm : (Δ : Context) → Set where
  dvar : ∀ {Δ} (x : DC.Var (ΔΔ Δ) DUni) →
    DTerm Δ
  dlett : ∀ {Δ} →
    (f : Var Δ Uni) →
    (x : Var Δ Uni) →
    (t : Term (Uni • Δ)) →
    (df : DC.Var (ΔΔ Δ) DUni) →
    (dx : DC.Var (ΔΔ Δ) DUni) →
    (dt : DTerm (Uni • Δ)) →
    DTerm Δ

derive-dterm : ∀ {Δ} → (t : Term Δ) → DTerm Δ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

{-
deriveC Δ (lett f x t) = dlett df x dx
-}

-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
--   cvar : (x : Var Γ τ) Δ →
--     ΔCTerm Γ τ Δ
--   clett : ∀ {σ τ₁ κ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
--     ΔCTerm (τ₁ • Γ) τ (? • Δ) →
--     ΔCTerm Γ τ Δ

weaken-term : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ →
  Term Γ₂
weaken-term Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken-term Γ₁≼Γ₂ (lett f x t) = lett (weaken-var Γ₁≼Γ₂ f) (weaken-var Γ₁≼Γ₂ x) (weaken-term (keep _ • Γ₁≼Γ₂) t)

-- I don't necessarily recommend having a separate syntactic category for
-- functions, but we should prove a fundamental lemma for them too, somehow.
-- I'll probably end up with some ANF allowing lambdas to do the semantics.
data Fun (Γ : Context) : Set where
  term : Term Γ → Fun Γ
  abs : ∀ {σ} → Fun (σ • Γ) → Fun Γ

data DFun (Δ : Context) : Set where
  dterm : DTerm Δ → DFun Δ
  dabs : DFun (Uni • Δ) → DFun Δ

derive-dfun : ∀ {Δ} → (t : Fun Δ) → DFun Δ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

weaken-fun : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Fun Γ₁ →
  Fun Γ₂
weaken-fun Γ₁≼Γ₂ (term x) = term (weaken-term Γ₁≼Γ₂ x)
weaken-fun Γ₁≼Γ₂ (abs f) = abs (weaken-fun (keep _ • Γ₁≼Γ₂) f)

data Val : Type → Set
data DVal : DType → Set
-- data Val (τ : Type) : Set

open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

import Base.Denotation.Environment DType DVal as D

-- data Val (τ : Type) where
data Val where
  closure : ∀ {Γ} → (t : Fun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → Val Uni
  intV : ∀ (n : ℕ) → Val Uni

data DVal where
  dclosure : ∀ {Γ} → (dt : DFun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → (dρ : D.⟦ ΔΔ Γ ⟧Context) → DVal DUni
  dintV : ∀ (n : ℤ) → DVal DUni

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = D.⟦ ΔΔ Δ ⟧Context

-- ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
-- ⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
-- ⟦ lett f x t ⟧Term ρ = ⟦ t ⟧Term (⟦ f ⟧Var ρ (⟦ x ⟧Var ρ) • ρ)

-- XXX separate syntax is a bit dangerous. Also, do I want to be so accurate relative to the original model?
data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Term Γ → ℕ → Val Uni → Set

data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ
  term : ∀ {v} n (t : Term Γ) →
    ρ ⊢ t ↓[ n ] v →
    ρ F⊢ term t ↓[ n ] v

data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) where
  var : ∀ (x : Var Γ Uni) →
    ρ ⊢ var x ↓[ 0 ] (⟦ x ⟧Var ρ)
  lett : ∀ n1 n2 {Γ' ρ′ v1 v2 v3} {f x t t'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    ρ ⊢ lett f x t ↓[ suc (suc (n1 + n2)) ] v3
  -- lit : ∀ n →
  --   ρ ⊢ const (lit n) ↓[ 0 ] intV n

-- data _D_⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : D.⟦ ΔΔ Γ ⟧Context) : DTerm Γ → ℕ → DVal DUni → Set where
--   dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
--     ρ D dρ ⊢ dvar x ↓[ 0 ] (D.⟦ x ⟧Var dρ)
--   dlett : ∀ n1 n2 n3 n4 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
--     ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
--     ρ ⊢ var x ↓[ 0 ] v1 →
--     (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
--     (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
--     -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
--     -- definitions.
--     ρ D dρ ⊢ dvar df ↓[ 0 ] dclosure {Γ'} dt' ρ'' dρ' →
--     ρ D dρ ⊢ dvar dx ↓[ 0 ] dv1 →
--     (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓[ n3 ] dv2 →
--     (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓[ n4 ] dv3 →
--     ρ D dρ ⊢ dlett f x t df dx dt ↓[ suc (suc (n1 + n2)) ] dv3

-- Do I need to damn count steps here? No.

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set

data _D_F⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DFun Γ → DVal DUni → Set where
  dabs : ∀ {dt : DFun (Uni • Γ)} →
    ρ D dρ F⊢ dabs dt ↓ dclosure dt ρ dρ
  dterm : ∀ {dv} (dt : DTerm Γ) →
    ρ D dρ ⊢ dt ↓ dv →
    ρ D dρ F⊢ dterm dt ↓ dv

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) where
  dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
    ρ D dρ ⊢ dvar x ↓ (D.⟦ x ⟧Var dρ)
  dlett : ∀ n1 n2 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
    -- definitions.
    ρ D dρ ⊢ dvar df ↓ dclosure {Γ'} dt' ρ'' dρ' →
    ρ D dρ ⊢ dvar dx ↓ dv1 →
    (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓ dv2 →
    (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓ dv3 →
    ρ D dρ ⊢ dlett f x t df dx dt ↓ dv3

open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Relation.Binary hiding (_⇒_)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

suc∸suc : ∀ m n → n < m → suc (m ∸ suc n) ≡ m ∸ n
suc∸suc (suc m) zero (s≤s n<m) = refl
suc∸suc (suc m) (suc n) (s≤s n<m) = suc∸suc m n n<m

lemlt : ∀ j k → suc j < k → k ∸ suc j < k
lemlt j (suc k) (s≤s j<k) = s≤s (∸-mono {k} {k} {j} {0} ≤-refl z≤n)

lemlt′ : ∀ j k → suc j <′ k → k ∸ suc j <′ k
lemlt′ j k j<′k = ≤⇒≤′ (lemlt j k (≤′⇒≤ j<′k))

open import Induction.WellFounded
open import Induction.Nat
rrelT3-Type : ℕ → Set₁
rrelT3-Type n =
  ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set

rrelV3-Type : ℕ → Set₁
rrelV3-Type n = ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set

rrelTV3-Type : ℕ → Set₁
rrelTV3-Type n = rrelT3-Type n × rrelV3-Type n

-- The type of the function availalbe for recursive calls.
rrelTV3-recSubCallsT : ℕ → Set₁
rrelTV3-recSubCallsT n = (k : ℕ) → k < n → rrelTV3-Type k

mutual
  -- Assemble together
  rrelTV3-step : ∀ n → rrelTV3-recSubCallsT n → rrelTV3-Type n
  rrelTV3-step n rec-rrelTV3 =
    let rrelV3-n = rrelV3-step n rec-rrelTV3
    in rrelT3-step n rec-rrelTV3 rrelV3-n , rrelV3-n
  rrelTV3 =  <-rec rrelTV3-Type rrelTV3-step
  rrelT3 : ∀ n → rrelT3-Type n
  rrelT3 n =  proj₁ (rrelTV3 n)
  rrelV3 : ∀ n → rrelV3-Type n
  rrelV3 n =  proj₂ (rrelTV3 n)

  s-rrelV3 :
    ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
    ∀ j → j < k → rrelV3-Type (k ∸ j)
  s-rrelV3 k rec-rrelTV3 rrelV3-k 0 _ = rrelV3-k
  s-rrelV3 k rec-rrelTV3 rrelV3-k (suc j) sucj<k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt j k sucj<k))
  -- Have the same context for t1, dt and t2? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3-step : ∀ k → rrelTV3-recSubCallsT k →
    rrelV3-Type k →
    -- rrelV3-Type n
    ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
      (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
  rrelT3-step k rec-rrelTV3 rrelV3-k =
    λ t1 dt t2 ρ1 dρ ρ2 →
    ∀ j (j<k : j < k) n2 →
    (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    s-rrelV3 k rec-rrelTV3 rrelV3-k j j<k v1 dv v2
    -- where
    --   s-rrelV3 : ∀ j → j <′ k → rrelV3-Type (k ∸ j)
    --   -- If j = 0, we can't do a recursive call on (k - j) because that's not
    --   -- well-founded. Luckily, we don't need to, just use relV as defined at
    --   -- the same level.
    --   -- Yet, this will be a pain in proofs.
    --   s-rrelV3 0 _ = rrelV3-k
    --   s-rrelV3 (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))

  rrelV3-step : ∀ n → rrelTV3-recSubCallsT n →
    -- rrelV3-Type n
    ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set
  rrelV3-step n rec-rrelTV3 (intV v1) (dintV dv) (intV v2) = dv I.+ (I.+ v1) ≡ (I.+ v2)
  rrelV3-step n rec-rrelTV3 (intV v1) (dintV n₁) (closure t ρ) = ⊥
  rrelV3-step n rec-rrelTV3 (intV v1) (dclosure dt ρ dρ) c = ⊥
  rrelV3-step n rec-rrelTV3 (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) =
      -- Require a proof that the two contexts match:
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        proj₂ (rec-rrelTV3 k k<n) v1 dv v2 →
        proj₁ (rec-rrelTV3 k k<n)
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-step n rec-rrelTV3 (closure t ρ) (dclosure dt ρ₁ dρ) (intV n₁) = ⊥
  rrelV3-step n rec-rrelTV3 (closure t ρ) (dintV n₁) c = ⊥

open import Postulate.Extensionality
mutual
  rrelT3-equiv : ∀ k {Γ} {t1 : Fun Γ} {dt t2 ρ1 dρ ρ2} →
    rrelT3 k t1 dt t2 ρ1 dρ ρ2 ≡
    ∀ j (j<k : j < k) n2 →
    ∀ (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 j v1 dv v2
  rrelT3-equiv k {Γ} {t1} {dt} {t2} {ρ1} {dρ} {ρ2} =
    cong (λ □ → ∀ j → □ j) (ext
      λ {
        zero -> cong {lsuc lzero} {lsuc lzero} {{!!}} {{!!}} {!!} {{!!}} {{! !}} {!cong!}
        -- cong {{!!}} {{!!}}
        -- (λ (□ : zero < k → ∀ (n2 : ℕ) (v1 v2 : Val Uni) (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ zero ] v1)  → {!(ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) → ? !})→
        --              ∀ (j<k : zero < k) n2 →
        --              (v1 v2 : Val Uni) →
        --              (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ zero ] v1) →
        --              (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
        --              Σ-syntax (DVal DUni)
        --              λ dv → Σ-syntax ℕ λ dn → (ρ1 D dρ F⊢ dt ↓ dv) × □ j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2)
        --           {!!}
        ;
        (suc j') -> {!!}})
    -- cong (λ □ →
    --      (j : ℕ) (j<k : j < k) (n2 : ℕ)
    --      (v1 v2 : Val Uni) →
    --      (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    --      -- (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    --        □ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1
    --     -- □ j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
    --     ) (ext³ λ j j<k n2 → {!ext³!})

  rrelV3-equiv : ∀ n {Γ1 Γ2 ΔΓ t1 dt t2 ρ1 ρ' dρ ρ2} →
    rrelV3 n (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) ≡ Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        rrelV3 k v1 dv v2 →
        rrelT3 k
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-equiv n = cong (λ □ → Σ (_ ≡ _ × _ ≡ _) □) (ext (λ { (eq1 , eq2) →
    cong
      (λ □ →
         (λ { (refl , refl)
                → ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 → □ k k<n v1 dv v2
            })
         eq1 eq2)
      (ext (λ x → ext {!!}))}))
  --
  -- cong (λ □ → ∀ k → (k<n : k <′ n) → □ k k<n)
  -- rrelV3-equiv k

rrelρ3 : ℕ → ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3 n ∅ ∅ ∅ ∅ = ⊤
rrelρ3 n (Uni • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) = rrelV3 n v1 dv v2 × rrelρ3 n Γ ρ1 dρ ρ2

--
rfundamental3 : ∀ {Γ} (t : Fun Γ) → ∀ k ρ1 dρ ρ2 → (ρρ : rrelρ3 k Γ ρ1 dρ ρ2) → rrelT3 k t (derive-dfun t) t ρ1 dρ ρ2
rfundamental3 (term x) k ρ1 dρ ρ2 ρρ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 = {!!}
rfundamental3 {Γ} (abs t) k ρ1 dρ ρ2 ρρ .0 j<k .0 (closure .t .ρ1) (closure .t .ρ2) abs abs = dclosure (derive-dfun t) ρ1 dρ , 0 , dabs , (refl , refl) , {!body !}
  where
    body1 : ∀ k₁ (k₁<k : k₁ <′ k) → (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → rrelV3 k₁ v1 dv v2 → rrelT3 k₁ t (derive-dfun t) t (v1 • ρ1) (dv • dρ) (v2 • ρ2)
    body1 = λ k₁ k₁<k v1 dv v2 x v3 v4 j n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
    rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
    !}
  -- λ
  -- { k₁ k<n v1 dv v2 vv v3 v4 0 n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- !}
  -- -- (Some.wfRec-builder rrelTV3-Type rrelTV3-step k₁
  --                     -- (<-well-founded′ k k₁ k<n))

  -- -- All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k k₁ k<n : rrelTV3-Type k₁
  -- --
  -- ; k₁ k<n v1 dv v2 vv v3 v4 (suc j) n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- !}
  -- -- rfundamental3 t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 {!suc j !} n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- }

  --   -- ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
  --   -- ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  --   foo : s-rrelV3 k
  --     (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k)
  --     (rrelV3-step k (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k))
  --     j j<k v1 (dclosure (derive-dfun t) ρ1 dρ) v2
  --   foo with j
  --   ... | s = {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Either type which calls out to Haskell via the FFI
------------------------------------------------------------------------

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

module Foreign.Haskell.Either where

open import Level
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)

private
  variable
    a b : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- Definition

data Either (A : Set a) (B : Set b) : Set (a ⊔ b) where
  left  : A → Either A B
  right : B → Either A B

{-# FOREIGN GHC type AgdaEither l1 l2 a b = Either a b #-}
{-# COMPILE GHC Either = data MAlonzo.Code.Foreign.Haskell.Either.AgdaEither (Left | Right) #-}

------------------------------------------------------------------------
-- Conversion

toForeign : A ⊎ B → Either A B
toForeign (inj₁ a) = left a
toForeign (inj₂ b) = right b

fromForeign : Either A B → A ⊎ B
fromForeign (left a)  = inj₁ a
fromForeign (right b) = inj₂ b


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Group.Algebra where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphism
open import Cubical.Algebra.Group.MorphismProperties

open import Cubical.HITs.PropositionalTruncation hiding (map)

-- open import Cubical.Data.Group.Base

open Iso
open Group
open GroupHom

private
  variable
    ℓ ℓ₁ ℓ₂ ℓ₃ : Level

------- elementary properties of morphisms --------

-- (- 0) = 0
-0≡0 : ∀ {ℓ} {G : Group {ℓ}} → (- G) (0g G) ≡ (0g G) --  - 0 ≡ 0
-0≡0 {G = G} =  sym (IsGroup.lid (isGroup G) _) ∙ fst (IsGroup.inverse (isGroup G) _)

-- ϕ(0) ≡ 0
morph0→0 : ∀ {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) (f : GroupHom G H)
           → fun f (0g G) ≡ 0g H
morph0→0 G H f =
  (fun f) (0g G)                                        ≡⟨ sym (IsGroup.rid (isGroup H) _) ⟩
  (f' (0g G) H.+ 0g H)                                  ≡⟨ (λ i → f' (0g G) H.+ invr H (f' (0g G)) (~ i)) ⟩
  (f' (0g G) H.+ (f' (0g G) H.+ (H.- f' (0g G))))       ≡⟨ (Group.assoc H (f' (0g G)) (f' (0g G)) (H.- (f' (0g G)))) ⟩
  ((f' (0g G) H.+ f' (0g G)) H.+ (H.- f' (0g G)))       ≡⟨ sym (cong (λ x → x H.+ (H.- f' (0g G))) (sym (cong f' (IsGroup.lid (isGroup G) _)) ∙ isHom f (0g G) (0g G))) ⟩
  (f' (0g G)) H.+ (H.- (f' (0g G)))                     ≡⟨ invr H (f' (0g G)) ⟩
  0g H ∎
  where
  module G = Group G
  module H = Group H
  f' = fun f

-- ϕ(- x) = - ϕ(x)
morphMinus : ∀ {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) → (ϕ : GroupHom G H)
            → (g : ⟨ G ⟩) → fun ϕ ((- G) g) ≡ (- H) (fun ϕ g)
morphMinus G H ϕ g =
  f (G.- g)                             ≡⟨ sym (IsGroup.rid (isGroup H) (f (G.- g))) ⟩
  (f (G.- g) H.+ 0g H)                  ≡⟨ cong (f (G.- g) H.+_) (sym (invr H (f g))) ⟩
  (f (G.- g) H.+ (f g H.+ (H.- f g)))   ≡⟨ Group.assoc H (f (G.- g)) (f g) (H.- f g) ⟩
  ((f (G.- g) H.+ f g) H.+ (H.- f g))   ≡⟨ cong (H._+ (H.- f g)) helper ⟩
  (0g H H.+ (H.- f g))                  ≡⟨ IsGroup.lid (isGroup H) (H.- (f g))⟩
  H.- (f g) ∎
  where
  module G = Group G
  module H = Group H
  f = fun ϕ
  helper : (f (G.- g) H.+ f g) ≡ 0g H
  helper = sym (isHom ϕ (G.- g) g) ∙∙ cong f (invl G g) ∙∙ morph0→0 G H ϕ

-- ----------- Alternative notions of isomorphisms --------------
record GroupIso {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  no-eta-equality
  constructor iso
  field
    map : GroupHom G H
    inv : ⟨ H ⟩ → ⟨ G ⟩
    rightInv : section (GroupHom.fun map) inv
    leftInv : retract (GroupHom.fun map) inv

record BijectionIso {ℓ ℓ'} (A : Group {ℓ}) (B : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  constructor bij-iso
  field
    map' : GroupHom A B
    inj : isInjective A B map'
    surj : isSurjective A B map'

-- "Very" short exact sequences
-- i.e. an exact sequence A → B → C → D where A and D are trivial
record vSES {ℓ ℓ' ℓ'' ℓ'''} (A : Group {ℓ}) (B : Group {ℓ'}) (leftGr : Group {ℓ''}) (rightGr : Group {ℓ'''})
           : Type (ℓ-suc (ℓ-max ℓ (ℓ-max ℓ' (ℓ-max ℓ'' ℓ''')))) where
  constructor ses
  field
    isTrivialLeft : isProp ⟨ leftGr ⟩
    isTrivialRight : isProp ⟨ rightGr ⟩

    left : GroupHom leftGr A
    right : GroupHom B rightGr
    ϕ : GroupHom A B

    Ker-ϕ⊂Im-left : (x : ⟨ A ⟩)
                  → isInKer A B ϕ x
                  → isInIm leftGr A left x
    Ker-right⊂Im-ϕ : (x : ⟨ B ⟩)
                   → isInKer B rightGr right x
                   → isInIm A B ϕ x

open BijectionIso
open GroupIso
open vSES

compGroupIso : {G : Group {ℓ}} {H : Group {ℓ₁}} {A : Group {ℓ₂}} → GroupIso G H → GroupIso H A → GroupIso G A
map (compGroupIso iso1 iso2) = compGroupHom (map iso1) (map iso2)
inv (compGroupIso iso1 iso2) = inv iso1 ∘ inv iso2
rightInv (compGroupIso iso1 iso2) a = cong (fun (map iso2)) (rightInv iso1 _) ∙ rightInv iso2 a
leftInv (compGroupIso iso1 iso2) a = cong (inv iso1) (leftInv iso2 _) ∙ leftInv iso1 a

isGroupHomInv' : {G : Group {ℓ}} {H : Group {ℓ₁}} (f : GroupIso G H) → isGroupHom H G (inv f)
isGroupHomInv' {G = G} {H = H}  f h h' = isInj-f _ _ (
  f' (g (h ⋆² h')) ≡⟨ (rightInv f) _ ⟩
  (h ⋆² h') ≡⟨ sym (cong₂ _⋆²_ (rightInv f h) (rightInv f h')) ⟩
  (f' (g h) ⋆² f' (g h')) ≡⟨ sym (isHom (map f) _ _) ⟩ -- sym (isHom (hom f) _ _) ⟩
  f' (g h ⋆¹ g h') ∎)
  where
  f' = fun (map f)
  _⋆¹_ = Group._+_ G
  _⋆²_ = Group._+_ H
  g = inv f -- invEq (eq f)

  isInj-f : (x y : ⟨ G ⟩) → f' x ≡ f' y → x ≡ y
  isInj-f x y p = sym (leftInv f _) ∙∙ cong g p ∙∙ leftInv f _

invGroupIso : {G : Group {ℓ}} {H : Group {ℓ₁}} → GroupIso G H → GroupIso H G
fun (map (invGroupIso iso1)) = inv iso1
isHom (map (invGroupIso iso1)) = isGroupHomInv' iso1
inv (invGroupIso iso1) = fun (map iso1)
rightInv (invGroupIso iso1) = leftInv iso1
leftInv (invGroupIso iso1) = rightInv iso1

dirProdGroupIso : {G : Group {ℓ}} {H : Group {ℓ₁}} {A : Group {ℓ₂}} {B : Group {ℓ₃}}
               → GroupIso G H → GroupIso A B → GroupIso (dirProd G A) (dirProd H B)
fun (map (dirProdGroupIso iso1 iso2)) prod = fun (map iso1) (fst prod) , fun (map iso2) (snd prod)
isHom (map (dirProdGroupIso iso1 iso2)) a b = ΣPathP (isHom (map iso1) (fst a) (fst b) , isHom (map iso2) (snd a) (snd b))
inv (dirProdGroupIso iso1 iso2) prod = (inv iso1) (fst prod) , (inv iso2) (snd prod)
rightInv (dirProdGroupIso iso1 iso2) a = ΣPathP (rightInv iso1 (fst a) , (rightInv iso2 (snd a)))
leftInv (dirProdGroupIso iso1 iso2) a = ΣPathP (leftInv iso1 (fst a) , (leftInv iso2 (snd a)))

GrIsoToGrEquiv : {G : Group {ℓ}} {H : Group {ℓ₂}} → GroupIso G H → GroupEquiv G H
GroupEquiv.eq (GrIsoToGrEquiv i) = isoToEquiv (iso (fun (map i)) (inv i) (rightInv i) (leftInv i))
GroupEquiv.isHom (GrIsoToGrEquiv i) = isHom (map i)

--- Proofs that BijectionIso and vSES both induce isomorphisms ---
BijectionIsoToGroupIso : {A : Group {ℓ}} {B : Group {ℓ₂}} → BijectionIso A B → GroupIso A B
BijectionIsoToGroupIso {A = A} {B = B} i = grIso
  where
  module A = Group A
  module B = Group B
  f = fun (map' i)

  helper : (b : _) → isProp (Σ[ a ∈ ⟨ A ⟩ ] f a ≡ b)
  helper _ a b =
    Σ≡Prop (λ _ → isSetCarrier B _ _)
           (fst a ≡⟨ sym (IsGroup.rid (isGroup A) (fst a)) ⟩
           ((fst a) A.+ 0g A) ≡⟨ cong ((fst a) A.+_) (sym (invl A (fst b))) ⟩
           ((fst a) A.+ ((A.- fst b) A.+ fst b)) ≡⟨ Group.assoc A _ _ _ ⟩
           (((fst a) A.+ (A.- fst b)) A.+ fst b) ≡⟨ cong (A._+ fst b) idHelper ⟩
           (0g A A.+ fst b) ≡⟨ IsGroup.lid (isGroup A) (fst b) ⟩
           fst b ∎)
    where
    idHelper : fst a A.+ (A.- fst b) ≡ 0g A
    idHelper =
      inj i _
           (isHom (map' i) (fst a) (A.- (fst b))
         ∙ (cong (f (fst a) B.+_) (morphMinus A B (map' i) (fst b))
         ∙∙ cong (B._+ (B.- f (fst b))) (snd a ∙ sym (snd b))
         ∙∙ invr B (f (fst b))))

  grIso : GroupIso A B
  map grIso = map' i
  inv grIso b = (rec (helper b) (λ a → a) (surj i b)) .fst
  rightInv grIso b = (rec (helper b) (λ a → a) (surj i b)) .snd
  leftInv grIso b j = rec (helper (f b)) (λ a → a) (propTruncIsProp (surj i (f b)) ∣ b , refl ∣ j) .fst

BijectionIsoToGroupEquiv : {A : Group {ℓ}} {B : Group {ℓ₂}} → BijectionIso A B → GroupEquiv A B
BijectionIsoToGroupEquiv i = GrIsoToGrEquiv (BijectionIsoToGroupIso i)

vSES→GroupIso : ∀ {ℓ ℓ' ℓ'' ℓ'''} {A : Group {ℓ}} {B : Group {ℓ'}} (leftGr : Group {ℓ''}) (rightGr : Group {ℓ'''})
                → vSES A B leftGr rightGr
                → GroupIso A B
vSES→GroupIso {A = A} lGr rGr vses = BijectionIsoToGroupIso theIso
  where
  theIso : BijectionIso _ _
  map' theIso = vSES.ϕ vses
  inj theIso a inker = rec (isSetCarrier A _ _)
                            (λ (a , p) → sym p
                                        ∙∙ cong (fun (left vses)) (isTrivialLeft vses a _)
                                        ∙∙ morph0→0 lGr A (left vses))
                            (Ker-ϕ⊂Im-left vses a inker)
  surj theIso a = Ker-right⊂Im-ϕ vses a (isTrivialRight vses _ _)

vSES→GroupEquiv : {A : Group {ℓ}} {B : Group {ℓ₁}} (leftGr : Group {ℓ₂}) (rightGr : Group {ℓ₃})
        → vSES A B leftGr rightGr
        → GroupEquiv A B
vSES→GroupEquiv {A = A} lGr rGr vses = GrIsoToGrEquiv (vSES→GroupIso lGr rGr vses)

-- The trivial group is a unit.
lUnitGroupIso : ∀ {ℓ} {G : Group {ℓ}} → GroupEquiv (dirProd trivialGroup G) G
lUnitGroupIso =
  GrIsoToGrEquiv
    (iso (grouphom snd (λ a b → refl))
         (λ g → tt , g)
         (λ _ → refl)
         λ _ → refl)

rUnitGroupIso : ∀ {ℓ} {G : Group {ℓ}} → GroupEquiv (dirProd G trivialGroup) G
rUnitGroupIso =
  GrIsoToGrEquiv
    (iso
      (grouphom fst λ _ _ → refl)
      (λ g → g , tt)
      (λ _ → refl)
      λ _ → refl)

contrGroup≅trivialGroup : {G : Group {ℓ}} → isContr ⟨ G ⟩ → GroupEquiv G trivialGroup
GroupEquiv.eq (contrGroup≅trivialGroup contr) = isContr→≃Unit contr
GroupEquiv.isHom (contrGroup≅trivialGroup contr) _ _ = refl


module Type.Properties.Singleton.Proofs where

import      Data.Tuple as Tuple
open import Data.Proofs
open import Function.Axioms
open import Logic.Classical
open import Logic
import      Lvl
open import Type.Properties.Empty
open import Type.Properties.Inhabited
open import Type.Properties.MereProposition
open import Type.Properties.Singleton
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Type.Identity
open import Syntax.Function
open import Type.Dependent
open import Type

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ ℓₑ₅ : Lvl.Level
private variable A B T U P : Type{ℓ}

module _ ⦃ equiv : Equiv{ℓₑ}(U) ⦄ where
  unit-is-pos : ⦃ proof : IsUnit(U) ⦄ → ◊(U)
  unit-is-pos ⦃ intro unit uniqueness ⦄ = intro ⦃ unit ⦄

  unit-is-prop : ⦃ proof : IsUnit(U) ⦄ → MereProposition(U)
  unit-is-prop ⦃ intro unit uniqueness ⦄ = intro (\{x}{y} → transitivity(_≡_) (uniqueness{x}) (symmetry(_≡_)(uniqueness{y})))

  pos-prop-is-unit : ⦃ _ : (◊ U) ⦄ → ⦃ _ : MereProposition(U) ⦄ → IsUnit(U)
  pos-prop-is-unit ⦃ intro ⦃ unit ⦄ ⦄ ⦃ intro uniqueness ⦄ = intro unit (\{x} → uniqueness{x}{unit})

module _ ⦃ equiv-p : Equiv{ℓₑ}(P) ⦄ ⦃ prop-p : MereProposition(P) ⦄ ⦃ equiv-a : Equiv{ℓₑ₁}(A) ⦄ where
  prop-fn-unique-value : ∀{f : P → A} → ⦃ _ : Function(f) ⦄ → (∀{x y} → (f(x) ≡ f(y)))
  prop-fn-unique-value {f = f}{x}{y} = congruence₁(f) (MereProposition.uniqueness(prop-p){x}{y})

module _ ⦃ equiv-u : Equiv{ℓₑ}(U) ⦄ ⦃ unit-u : IsUnit(U) ⦄ ⦃ equiv-a : Equiv{ℓₑ₁}(A) ⦄ where
  unit-fn-unique-value : ∀{f : U → A} → ⦃ _ : Function(f) ⦄ → (∀{x y} → (f(x) ≡ f(y)))
  unit-fn-unique-value = prop-fn-unique-value ⦃ prop-p = unit-is-prop ⦃ proof = unit-u ⦄ ⦄

module _
  ⦃ equiv-a : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-b : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-ab : Equiv{ℓₑ₃}(A ∧ B) ⦄
  ⦃ op : BinaryOperator([∧]-intro) ⦄ where
  instance
    prop-conjunction : ⦃ prop-a : MereProposition(A) ⦄ ⦃ prop-b : MereProposition(B) ⦄ → MereProposition(A ∧ B)
    MereProposition.uniqueness prop-conjunction {[∧]-intro a₁ b₁} {[∧]-intro a₂ b₂} = congruence₂([∧]-intro) (uniqueness(A)) (uniqueness(B))

module _
  ⦃ equiv-b : Equiv{ℓₑ₁}(B) ⦄
  ⦃ equiv-ab : Equiv{ℓₑ₂}(A → B) ⦄
  ⦃ funcExt : FunctionExtensionality(A)(B) ⦄
  where
  prop-implication : ⦃ prop-b : MereProposition(B) ⦄ → MereProposition(A → B)
  MereProposition.uniqueness prop-implication = functionExtensionality(A)(B) (uniqueness(B))

module _
  {B : A → Type{ℓ}}
  ⦃ equiv-b : ∀{a} → Equiv{ℓₑ₁}(B(a)) ⦄
  ⦃ equiv-ab : Equiv{ℓₑ₂}((a : A) → B(a)) ⦄
  ⦃ funcExt : DependentFunctionExtensionality(A)(B) ⦄
  where
  prop-dependent-implication : ⦃ prop-b : ∀{a} → MereProposition(B(a)) ⦄ → MereProposition((a : A) → B(a))
  MereProposition.uniqueness prop-dependent-implication = dependentFunctionExtensionality(A)(B)(\{a} → uniqueness(B(a)))

module _ ⦃ equiv-top : Equiv{ℓₑ}(⊤) ⦄ where
  instance
    prop-top : MereProposition(⊤) ⦃ equiv-top ⦄
    prop-top = unit-is-prop

module _ ⦃ equiv-bottom : Equiv{ℓₑ}(⊥) ⦄ where
  instance
    prop-bottom : MereProposition(⊥) ⦃ equiv-bottom ⦄
    MereProposition.uniqueness prop-bottom {}

module _
  {P : A → Type{ℓ}} ⦃ equiv-p : ∀{x} → Equiv{ℓₑ₁}(P(x)) ⦄
  ⦃ equiv-ap : Equiv{ℓₑ₂}(∀ₗ P) ⦄
  ⦃ funcExt : DependentImplicitFunctionExtensionality(A)(P) ⦄
  where
  prop-universal : ⦃ prop-p : ∀{x} → MereProposition(P(x)) ⦄ → MereProposition(∀ₗ P)
  MereProposition.uniqueness prop-universal = dependentImplicitFunctionExtensionality(A)(P) (\{x} → uniqueness(P(x)))

module _
  ⦃ equiv-a : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-b : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-ba : Equiv{ℓₑ₃}(A ← B) ⦄
  ⦃ equiv-ab : Equiv{ℓₑ₄}(A → B) ⦄
  ⦃ equiv-eq : Equiv{ℓₑ₅}(A ↔ B) ⦄
  ⦃ op : BinaryOperator([↔]-intro) ⦄
  ⦃ funcExtₗ : FunctionExtensionality(B)(A) ⦄
  ⦃ funcExtᵣ : FunctionExtensionality(A)(B) ⦄
  where
  prop-equivalence : ⦃ prop-a : MereProposition(A) ⦄ → ⦃ prop-b : MereProposition(B) ⦄ → MereProposition(A ↔ B)
  prop-equivalence = prop-conjunction ⦃ prop-a = prop-implication ⦄ ⦃ prop-b = prop-implication ⦄

module _
  ⦃ equiv-a      : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-bottom : Equiv{ℓₑ₂}(⊥) ⦄
  ⦃ equiv-na     : Equiv{ℓₑ₃}(¬ A) ⦄
  ⦃ funcExt : FunctionExtensionality (A)(⊥) ⦃ equiv-bottom ⦄ ⦄
  where
  prop-negation : MereProposition(¬ A)
  prop-negation = prop-implication

module _
  ⦃ equiv-a : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-b : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-ab : Equiv{ℓₑ₃}(A ∨ B) ⦄
  (left-right-neq : ∀{a : A}{b : B} → ([∨]-introₗ a ≢ [∨]-introᵣ b))
  where
  not-prop-disjunction : MereProposition(A ∨ B) → IsEmpty(A ∧ B)
  IsEmpty.empty (not-prop-disjunction (intro uniqueness)) ([∧]-intro a b) with () ← left-right-neq(uniqueness{[∨]-introₗ a}{[∨]-introᵣ b})

{-
module _ {B : A → Type{ℓ}} where
  open import Type.Identity
  open import Relator.Equals.Proofs.Equiv
  open import Structure.Relator
  open import Structure.Setoid.Uniqueness
  open import Syntax.Transitivity

  congruence₁-dependent : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : A → Type{ℓ₂}}{a₁ a₂ : A} → (f : (a : A) → B(a)) → (pa : a₁ ≡ a₂) → (substitute₁(B) pa (f a₁) ≡ f a₂)
  congruence₁-dependent _ intro = intro

  -- congruence₂-dependent : ∀{C : (a : A) → B(a) → Type{ℓ}}{a₁ a₂ : A}{b₁ : B(a₁)}{b₂ : B(a₂)}{f : (a : A) → (b : B(a)) → C a b} → (pa : a₁ ≡ a₂) → (f a₁ b₁ ≡ f a₂ b₂)
  -- (substitute₁(B) ? b₁)

  prop-sigma : Unique(B) → (∀{a} → MereProposition(B(a))) → MereProposition(Σ A B)
  MereProposition.uniqueness (prop-sigma unique-B prop-B) {intro xa xb} {intro ya yb} =
    intro xa xb                                   🝖[ _≡_ ]-[ {!(congruence₁-dependent(intro) (unique-B xb yb))!} ]
    intro ya (substitute₁(B) (unique-B xb yb) xb) 🝖[ _≡_ ]-[ {!intro xa xb!} ]
    intro ya yb                                   🝖-end
-}

{- TODO
module _
  ⦃ equiv-a : Equiv(A) ⦄
  {B : A → Type{ℓ}} ⦃ equiv-b : ∀{x} → Equiv(B(x)) ⦄
  ⦃ equiv-sigma : Equiv(Σ A B) ⦄ -- TODO: Not an arbitrary one
  where
  prop-sigma : MereProposition(Σ A B) → ? -- TODO: Maybe MereProposition(B) → MereProposition(A)
  prop-sigma (intro uniqueness₁) = {!!}
-}

{- TODO: Maybe generalize and move the stuff from Data.Proofs to here
-- Any binary relation on Unit is an equivalence given that it is reflexive.
module _ ⦃ equiv-u : Equiv(U) ⦄ ⦃ is-unit : IsUnit(U) ⦄ {_▫_ : U → U → Stmt} where
  unit-equiv : Equiv(U)
  Equiv._≡_ unit-equiv = (_▫_)
  Reflexivity.proof  (Equivalence.reflexivity  (Equiv.equivalence unit-equiv))       = {!!}
  Symmetry.proof     (Equivalence.symmetry     (Equiv.equivalence unit-equiv)) _     = {!!}
  Transitivity.proof (Equivalence.transitivity (Equiv.equivalence unit-equiv)) _ _   = {!!}
-}


module Everything where

import Prelude
import Category

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

-- The syntax of STLC.
import STLC.Syntax

-- A simplification of Coquand 2002,
-- with de Bruijn indices and implicit substitutions.
import STLC.Coquand.Renaming
import STLC.Coquand.Substitution
import STLC.Coquand.Normalisation   -- TODO: Fill postulates
import STLC.Coquand.Convertibility  -- TODO: Simplify β-reduction rule
import STLC.Coquand.Completeness    -- TODO: Fill postulates
import STLC.Coquand.Soundness       -- TODO: Fill postulates

-- A restyling of Kovacs 2017.
import STLC.Kovacs.Embedding
import STLC.Kovacs.Substitution
import STLC.Kovacs.NormalForm
import STLC.Kovacs.Normalisation
import STLC.Kovacs.Convertibility
import STLC.Kovacs.Completeness
import STLC.Kovacs.PresheafRefinement
import STLC.Kovacs.Soundness

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

-- The syntax of STLC, with simple products.
import STLC1.Syntax

-- An extension of Kovacs 2017.
import STLC1.Kovacs.Embedding
import STLC1.Kovacs.Substitution
import STLC1.Kovacs.NormalForm
import STLC1.Kovacs.Normalisation
import STLC1.Kovacs.Convertibility
import STLC1.Kovacs.Completeness
import STLC1.Kovacs.PresheafRefinement
import STLC1.Kovacs.Soundness

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

-- The syntax of STLC, with simple products and coproducts.
import STLC2.Syntax

-- An extension of Kovacs 2017.
import STLC2.Kovacs.Embedding
import STLC2.Kovacs.Substitution
import STLC2.Kovacs.NormalForm
import STLC2.Kovacs.Normalisation.SoundNotComplete
import STLC2.Kovacs.Normalisation.Experimental
import STLC2.Kovacs.Normalisation
import STLC2.Kovacs.Convertibility
import STLC2.Kovacs.Completeness           -- TODO: Finish this
-- import STLC2.Kovacs.PresheafRefinement  -- TODO: Start this
-- import STLC2.Kovacs.Soundness           -- TODO: Start this

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


{-# OPTIONS --rewriting --prop #-}

open import Agda.Builtin.Nat

data ⊥ : Prop where

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x
{-# BUILTIN REWRITE _≡_ #-}

infix 4 _≡_

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

ok : (n : Nat) (p : ⊥) → (n + n) ≡ 0
ok n p = ⊥-elim p

{-# REWRITE ok #-}

notok : (n : Nat) → n + n ≡ 0
notok n = refl

absurd : 2 ≡ 0
absurd = notok 1