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

open import Setoids.Setoids
open import Rings.Definition
open import Rings.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Fields.Fields
open import Sets.EquivalenceRelations
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas

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

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

open import Fields.Lemmas F
open import Rings.Orders.Partial.Lemmas pRing
open import Rings.Orders.Total.Lemmas order
open import Rings.Orders.Total.Cauchy order
open import Rings.Orders.Total.AbsoluteValue order
open import Fields.CauchyCompletion.Definition order F
open import Fields.CauchyCompletion.Setoid order F
open import Fields.CauchyCompletion.Approximation order F

0!=1 : {e : A} → (0G < e) → 0R ∼ 1R → False
0!=1 {e} 0<e 0=1 = irreflexive (<WellDefined (Equivalence.reflexive eq) (oneZeroImpliesAllZero R 0=1) 0<e)

private
  littleLemma : {a b c d : A} → ((a * b) + inverse (c * d)) ∼ ((a * (b + inverse d)) + (d * (a + inverse c)))
  littleLemma {a} {b} {c} {d} = Equivalence.transitive eq (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq identLeft) (+WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq (+WellDefined (Equivalence.transitive eq (ringMinusExtracts R) (inverseWellDefined additiveGroup *Commutative)) (Equivalence.reflexive eq)) (invLeft {d * a}))) (Equivalence.transitive eq (Equivalence.symmetric eq (ringMinusExtracts' R)) *Commutative))) (Equivalence.symmetric eq +Associative))) (+Associative)) (Equivalence.symmetric eq (+WellDefined (*DistributesOver+) (*DistributesOver+)))

  timesConverges : (a b : CauchyCompletion) → cauchy (apply _*_ (CauchyCompletion.elts a) (CauchyCompletion.elts b))
  timesConverges record { elts = a ; converges = aConv } record { elts = b ; converges = bConv } e 0<e with boundModulus record { elts = a ; converges = aConv }
  ... | aBound , (Na , prABound) with boundModulus record { elts = b ; converges = bConv }
  ... | bBound , (Nb , prBBound) = N , ans
    where
      boundBoth : A
      boundBoth = aBound + bBound
      abstract
        ab<bb : aBound < boundBoth
        ab<bb = <WellDefined identLeft groupIsAbelian (orderRespectsAddition {0R} {bBound} (greaterThanAbsImpliesGreaterThan0 (prBBound (succ Nb) (le 0 refl))) aBound)
        bb<bb : bBound < boundBoth
        bb<bb = <WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition {0R} {aBound} (greaterThanAbsImpliesGreaterThan0 (prABound (succ Na) (le 0 refl))) bBound)
        0<boundBoth : 0R < boundBoth
        0<boundBoth = <WellDefined identLeft (Equivalence.reflexive eq) (ringAddInequalities (greaterThanAbsImpliesGreaterThan0 (prABound (succ Na) (le 0 refl))) (greaterThanAbsImpliesGreaterThan0 (prBBound (succ Nb) (le 0 refl))))
      abstract
        1/boundBoothAndPr : Sg A λ i → i * (aBound + bBound) ∼ 1R
        1/boundBoothAndPr = allInvertible boundBoth λ pr → irreflexive (<WellDefined (Equivalence.reflexive eq) pr 0<boundBoth)
        1/boundBooth : A
        1/boundBooth with 1/boundBoothAndPr
        ... | a , _ = a
        1/boundBoothPr : 1/boundBooth * (aBound + bBound) ∼ 1R
        1/boundBoothPr with 1/boundBoothAndPr
        ... | _ , pr = pr
        0<1/boundBooth : 0G < 1/boundBooth
        0<1/boundBooth = inversePositiveIsPositive 1/boundBoothPr 0<boundBoth
      abstract
        miniEAndPr : Sg A (λ i → (i + i) ∼ (e * 1/boundBooth))
        miniEAndPr = halve charNot2 (e * 1/boundBooth)
        miniE : A
        miniE with miniEAndPr
        ... | a , _ = a
        miniEPr : (miniE + miniE) ∼ (e * 1/boundBooth)
        miniEPr with miniEAndPr
        ... | _ , pr = pr
        0<miniE : 0R < miniE
        0<miniE = halvePositive miniE (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq miniEPr) (orderRespectsMultiplication 0<e 0<1/boundBooth))
      abstract
        reallyNAAndPr : Sg ℕ (λ N → {m n : ℕ} → N <N m → N <N n → abs (index a m + inverse (index a n)) < miniE)
        reallyNAAndPr = aConv miniE 0<miniE
        reallyNa : ℕ
        reallyNa with reallyNAAndPr
        ... | a , _ = a
        reallyNaPr : {m n : ℕ} → reallyNa <N m → reallyNa <N n → abs (index a m + inverse (index a n)) < miniE
        reallyNaPr with reallyNAAndPr
        ... | _ , pr = pr
        reallyNBAndPr : Sg ℕ (λ N → {m n : ℕ} → N <N m → N <N n → abs (index b m + inverse (index b n)) < miniE)
        reallyNBAndPr = bConv miniE 0<miniE
        reallyNb : ℕ
        reallyNb with reallyNBAndPr
        ... | a , _ = a
        reallyNbPr : {m n : ℕ} → reallyNb <N m → reallyNb <N n → abs (index b m + inverse (index b n)) < miniE
        reallyNbPr with reallyNBAndPr
        ... | _ , pr = pr
      N : ℕ
      N = (Na +N (Nb +N (reallyNa +N reallyNb)))
      ans : {m : ℕ} {n : ℕ} → N <N m → N <N n → abs (index (apply _*_ a b) m + inverse (index (apply _*_ a b) n)) < e
      ans {m} {n} N<m N<n rewrite indexAndApply a b _*_ {m} | indexAndApply a b _*_ {n} = ans'''
        where
          Na<m : Na <N m
          Na<m = inequalityShrinkLeft N<m
          Nb<n : Nb <N n
          Nb<n = inequalityShrinkLeft (inequalityShrinkRight {Na} N<n)
          abstract
            sum : {m n : ℕ} → (reallyNa +N reallyNb) <N m → (reallyNa +N reallyNb) <N n → (boundBoth * ((abs (index b m + inverse (index b n))) + (abs (index a m + inverse (index a n))))) < e
            sum {m} {n} <m <n = <WellDefined *Commutative (Equivalence.transitive eq (*WellDefined miniEPr (Equivalence.reflexive eq)) (Equivalence.transitive eq (Equivalence.symmetric eq *Associative) (Equivalence.transitive eq (Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) 1/boundBoothPr) *Commutative) (identIsIdent)))) (ringCanMultiplyByPositive {c = boundBoth} 0<boundBoth (ringAddInequalities (reallyNbPr {m} {n} (inequalityShrinkRight <m) (inequalityShrinkRight <n)) (reallyNaPr {m} {n} (inequalityShrinkLeft <m) (inequalityShrinkLeft <n))))
          q : ((boundBoth * (abs (index b m + inverse (index b n)))) + (boundBoth * (abs (index a m + inverse (index a n))))) < e
          q = <WellDefined *DistributesOver+ (Equivalence.reflexive eq) (sum {m} {n} (inequalityShrinkRight {Nb} (inequalityShrinkRight {Na} N<m)) (inequalityShrinkRight {Nb} (inequalityShrinkRight {Na} N<n)))
          p : ((abs (index a m) * abs (index b m + inverse (index b n))) + (abs (index b n) * abs (index a m + inverse (index a n)))) < e
          p with totality 0R (index b m + inverse (index b n))
          p | inl (inl 0<bm-bn) with totality 0R (index a m + inverse (index a n))
          p | inl (inl 0<bm-bn) | inl (inl 0<am-an) = SetoidPartialOrder.<Transitive pOrder (ringAddInequalities (<WellDefined (Equivalence.reflexive eq) (*WellDefined (Equivalence.reflexive eq) (greaterZeroImpliesEqualAbs 0<bm-bn)) (ringCanMultiplyByPositive 0<bm-bn (SetoidPartialOrder.<Transitive pOrder (prABound m Na<m) ab<bb))) (<WellDefined (Equivalence.reflexive eq) (*WellDefined (Equivalence.reflexive eq) (greaterZeroImpliesEqualAbs 0<am-an)) (ringCanMultiplyByPositive 0<am-an (SetoidPartialOrder.<Transitive pOrder (prBBound n Nb<n) bb<bb)))) q
          p | inl (inl 0<bm-bn) | inl (inr am-an<0) = SetoidPartialOrder.<Transitive pOrder (ringAddInequalities (<WellDefined (*WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq (greaterZeroImpliesEqualAbs 0<bm-bn))) (Equivalence.reflexive eq) (ringCanMultiplyByPositive (<WellDefined (Equivalence.reflexive eq) (greaterZeroImpliesEqualAbs 0<bm-bn) 0<bm-bn) (SetoidPartialOrder.<Transitive pOrder (prABound m Na<m) ab<bb))) (<WellDefined (*WellDefined (Equivalence.reflexive eq) (lessZeroImpliesEqualNegAbs am-an<0)) (Equivalence.reflexive eq) (ringCanMultiplyByPositive (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq (lessZeroImpliesEqualNegAbs am-an<0)) (lemm2 _ am-an<0)) (SetoidPartialOrder.<Transitive pOrder (prBBound n Nb<n) bb<bb)))) q
          p | inl (inl 0<bm-bn) | inr 0=am-an = <WellDefined (+WellDefined (Equivalence.reflexive eq) (*WellDefined (Equivalence.reflexive eq) 0=am-an)) (Equivalence.reflexive eq) (<WellDefined (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq timesZero)) (Equivalence.reflexive eq) (<WellDefined (Equivalence.symmetric eq identRight) (Equivalence.reflexive eq) (SetoidPartialOrder.<Transitive pOrder (<WellDefined (Equivalence.reflexive eq) (+WellDefined (Equivalence.reflexive eq) (*WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq (Equivalence.symmetric eq absZeroIsZero) (absWellDefined _ _ 0=am-an)))) (<WellDefined (Equivalence.reflexive eq) (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq timesZero)) (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq identRight) (<WellDefined (*WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq (greaterZeroImpliesEqualAbs 0<bm-bn))) (Equivalence.reflexive eq) (ringCanMultiplyByPositive (<WellDefined (Equivalence.reflexive eq) (greaterZeroImpliesEqualAbs 0<bm-bn) 0<bm-bn) (SetoidPartialOrder.<Transitive pOrder (prABound m Na<m) ab<bb)))))) q)))
          p | inl (inr bm-bn<0) = SetoidPartialOrder.<Transitive pOrder ans'' q
            where
              bar : ((abs (index a m)) * (inverse (index b m + inverse (index b n)))) < (boundBoth * abs (index b m + inverse (index b n)))
              bar = <WellDefined (*WellDefined (Equivalence.reflexive eq) (lessZeroImpliesEqualNegAbs bm-bn<0)) (Equivalence.reflexive eq) (ringCanMultiplyByPositive (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq (lessZeroImpliesEqualNegAbs bm-bn<0)) (lemm2 _ bm-bn<0)) (SetoidPartialOrder.<Transitive pOrder (prABound m Na<m) (ab<bb)))
              foo : (((abs (index b n)) * (abs (index a m + inverse (index a n)))) < (boundBoth * abs (index a m + inverse (index a n)))) || (((abs (index b n)) * (abs (index a m + inverse (index a n)))) ∼ (boundBoth * abs (index a m + inverse (index a n))))
              foo with totality 0R (index a m + inverse (index a n))
              foo | inl (inl 0<am-an) = inl (ringCanMultiplyByPositive 0<am-an (SetoidPartialOrder.<Transitive pOrder (prBBound n Nb<n) bb<bb))
              foo | inl (inr am-an<0) = inl (ringCanMultiplyByPositive (lemm2 _ am-an<0) (SetoidPartialOrder.<Transitive pOrder (prBBound n Nb<n) bb<bb))
              foo | inr 0=am-an = inr (Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=am-an)) (Equivalence.transitive eq (Equivalence.transitive eq timesZero (Equivalence.symmetric eq timesZero)) (*WellDefined (Equivalence.reflexive eq) 0=am-an)))
              ans'' : _
              ans'' with foo
              ... | inl pr = ringAddInequalities bar pr
              ... | inr pr = <WellDefined (Equivalence.reflexive eq) (+WellDefined (Equivalence.reflexive eq) pr) (orderRespectsAddition bar ((abs (index b n)) * (abs (index a m + inverse (index a n)))))
          p | inr 0=bm-bn = ans''
            where
              bar : (boundBoth * abs (index b m + inverse (index b n))) ∼ 0R
              bar = Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq (absWellDefined _ _ (Equivalence.symmetric eq 0=bm-bn)) (absZeroIsZero))) timesZero
              bar' : (abs (index a m) * (index b m + inverse (index b n))) ∼ 0R
              bar' = Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=bm-bn)) timesZero
              foo : (((abs (index b n)) * (abs (index a m + inverse (index a n)))) < (boundBoth * abs (index a m + inverse (index a n)))) || (0R ∼ (index a m + inverse (index a n)))
              foo with totality 0R (index a m + inverse (index a n))
              foo | inl (inl 0<am-an) = inl (SetoidPartialOrder.<Transitive pOrder (ringCanMultiplyByPositive 0<am-an (prBBound n Nb<n)) (ringCanMultiplyByPositive 0<am-an bb<bb))
              foo | inl (inr am-an<0) = inl (SetoidPartialOrder.<Transitive pOrder (ringCanMultiplyByPositive (lemm2 _ am-an<0) (prBBound n Nb<n)) (ringCanMultiplyByPositive (lemm2 _ am-an<0) bb<bb))
              foo | inr 0=am-an = inr 0=am-an
              ans'' : _
              ans'' with foo
              ... | inl pr = SetoidPartialOrder.<Transitive pOrder (<WellDefined groupIsAbelian groupIsAbelian (<WellDefined (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq bar')) (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq bar)) (orderRespectsAddition pr 0R))) q
              ... | inr pr = <WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq identRight) (+WellDefined (Equivalence.symmetric eq bar') (Equivalence.symmetric eq (Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq (absWellDefined _ _ (Equivalence.symmetric eq pr)) absZeroIsZero)) timesZero)))) (Equivalence.reflexive eq) 0<e
          ans''' : abs ((index a m * index b m) + inverse (index a n * index b n)) < e
          ans''' with triangleInequality (index a m * (index b m + inverse (index b n))) (index b n * (index a m + inverse (index a n)))
          ... | inl less = <WellDefined (Equivalence.symmetric eq (absWellDefined ((index a m * index b m) + (inverse (index a n * index b n))) (((index a m) * (index b m + (inverse (index b n)))) + ((index b n) * (index a m + inverse (index a n)))) littleLemma)) (Equivalence.reflexive eq) (SetoidPartialOrder.<Transitive pOrder less (<WellDefined (+WellDefined (Equivalence.symmetric eq (absRespectsTimes (index a m) _)) (Equivalence.symmetric eq (absRespectsTimes (index b n) _))) (Equivalence.reflexive eq) p))
          ... | inr equal = <WellDefined {_ + _} {abs _} {e} {e} (symmetric (transitive (transitive (absWellDefined ((index a m * index b m) + (inverse (index a n * index b n))) (((index a m) * (index b m + (inverse (index b n)))) + ((index b n) * (index a m + inverse (index a n)))) littleLemma) equal) (+WellDefined (absRespectsTimes (index a m) _) (absRespectsTimes (index b n) _)))) reflexive p

_*C_ : CauchyCompletion → CauchyCompletion → CauchyCompletion
CauchyCompletion.elts (record { elts = a ; converges = aConv } *C record { elts = b ; converges = bConv }) = apply _*_ a b
CauchyCompletion.converges (a *C b) = timesConverges a b

*CCommutative : {a b : CauchyCompletion} → Setoid._∼_ cauchyCompletionSetoid (a *C b) (b *C a)
*CCommutative {a} {b} ε 0<e = 0 , ans
  where
    foo : {x y : A} → (x * y) + inverse (y * x) ∼ 0G
    foo = Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) (inverseWellDefined additiveGroup *Commutative)) invRight
    ans : {m : ℕ} → 0 <N m → abs (index (apply _+_ (CauchyCompletion.elts (a *C b)) (map inverse (CauchyCompletion.elts (b *C a)))) m) < ε
    ans {m} 0<m rewrite indexAndApply (apply _*_ (CauchyCompletion.elts a) (CauchyCompletion.elts b)) (map inverse (apply _*_ (CauchyCompletion.elts b) (CauchyCompletion.elts a))) _+_ {m} | indexAndApply (CauchyCompletion.elts a) (CauchyCompletion.elts b) _*_ {m} | equalityCommutative (mapAndIndex (apply _*_ (CauchyCompletion.elts b) (CauchyCompletion.elts a)) inverse m) | indexAndApply (CauchyCompletion.elts b) (CauchyCompletion.elts a) _*_ {m} = <WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq (absWellDefined _ _ foo) (identityOfIndiscernablesRight _∼_ (Equivalence.reflexive eq) absZero))) (Equivalence.reflexive eq) 0<e

private

  multiplicationWellDefinedLeft' : (0!=1 : 0R ∼ 1R → False) (a b c : CauchyCompletion) → Setoid._∼_ cauchyCompletionSetoid a b → Setoid._∼_ cauchyCompletionSetoid (a *C c) (b *C c)
  multiplicationWellDefinedLeft' 0!=1 a b c a=b ε 0<e = N , ans
    where
      abstract
        cBoundAndPr : Sg A (λ b → Sg ℕ (λ N → (m : ℕ) → (N <N m) → (abs (index (CauchyCompletion.elts c) m)) < b))
        cBoundAndPr = boundModulus c
        cBound : A
        cBound with cBoundAndPr
        ... | a , _ = a
        cBoundN : ℕ
        cBoundN with cBoundAndPr
        ... | _ , (N , _) = N
        cBoundPr : (m : ℕ) → (cBoundN <N m) → (abs (index (CauchyCompletion.elts c) m)) < cBound
        cBoundPr with cBoundAndPr
        ... | _ , (_ , pr) = pr
      0<cBound : 0G < cBound
      0<cBound with totality 0G cBound
      0<cBound | inl (inl 0<cBound) = 0<cBound
      0<cBound | inl (inr cBound<0) = exFalso (absNonnegative (SetoidPartialOrder.<Transitive pOrder (cBoundPr (succ cBoundN) (le 0 refl)) cBound<0))
      0<cBound | inr 0=cBound = exFalso (absNonnegative (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=cBound) (cBoundPr (succ cBoundN) (le 0 refl))))
      e/c : A
      e/c with allInvertible cBound (λ pr → irreflexive (<WellDefined (Equivalence.reflexive eq) pr 0<cBound))
      ... | (1/c , _) = ε * 1/c
      e/cPr : e/c * cBound ∼ ε
      e/cPr with allInvertible cBound (λ pr → irreflexive (<WellDefined (Equivalence.reflexive eq) pr 0<cBound))
      ... | (1/c , pr) = Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq *Associative) (*WellDefined (Equivalence.reflexive eq) pr)) *Commutative) (identIsIdent)
      0<e/c : 0G < e/c
      0<e/c = ringCanCancelPositive {0G} {e/c} 0<cBound (<WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq *Commutative timesZero)) (Equivalence.symmetric eq e/cPr) 0<e)
      abBound : ℕ
      abBound with a=b e/c 0<e/c
      ... | Na=b , _ = Na=b
      abPr : {m : ℕ} → (abBound <N m) → abs (index (apply _+_ (CauchyCompletion.elts a) (map inverse (CauchyCompletion.elts b))) m) < e/c
      abPr with a=b e/c 0<e/c
      ... | Na=b , pr = pr
      N : ℕ
      N = abBound +N cBoundN
      cBounded : (m : ℕ) → (N <N m) → abs (index (CauchyCompletion.elts c) m) < cBound
      cBounded m N<m = cBoundPr m (inequalityShrinkRight N<m)
      a-bSmall : (m : ℕ) → N <N m → abs ((index (CauchyCompletion.elts a) m) + inverse (index (CauchyCompletion.elts b) m)) < e/c
      a-bSmall m N<m = <WellDefined (absWellDefined _ _ (transitive (identityOfIndiscernablesLeft _∼_ reflexive (equalityCommutative (indexAndApply (CauchyCompletion.elts a) (map inverse (CauchyCompletion.elts b)) _+_ {m}))) (+WellDefined reflexive (identityOfIndiscernablesLeft _∼_ reflexive (mapAndIndex (CauchyCompletion.elts b) inverse m))))) reflexive (abPr {m} (inequalityShrinkLeft N<m))
      ans : {m : ℕ} → N <N m → abs (index (apply _+_ (apply _*_ (CauchyCompletion.elts a) (CauchyCompletion.elts c)) (map inverse (apply _*_ (CauchyCompletion.elts b) (CauchyCompletion.elts c)))) m) < ε
      ans {m} N<m = <WellDefined (absWellDefined _ _ (transitive (+WellDefined (identityOfIndiscernablesLeft _∼_ reflexive (indexAndApply _ _ _*_ {m})) (transitive (transitive (ringMinusExtracts' R) (inverseWellDefined additiveGroup (identityOfIndiscernablesRight _∼_ reflexive (equalityCommutative (indexAndApply _ _ _*_ {m}))))) (identityOfIndiscernablesLeft _∼_ reflexive (equalityCommutative (mapAndIndex _ inverse m))))) (identityOfIndiscernablesLeft _∼_ reflexive (indexAndApply _ _ _+_ {m})))) reflexive (<WellDefined (absWellDefined ((index (CauchyCompletion.elts a) m + inverse (index (CauchyCompletion.elts b) m)) * index (CauchyCompletion.elts c) m) _ (Equivalence.transitive eq (Equivalence.transitive eq *Commutative *DistributesOver+) (+WellDefined *Commutative *Commutative))) (Equivalence.reflexive eq) (<WellDefined (Equivalence.symmetric eq (absRespectsTimes _ _)) (Equivalence.reflexive eq) (<WellDefined (Equivalence.reflexive eq) e/cPr (ans' (index (CauchyCompletion.elts a) m) (index (CauchyCompletion.elts b) m) (index (CauchyCompletion.elts c) m) (a-bSmall m N<m) (cBounded m N<m)))))
        where
          ans' : (a b c : A) → abs (a + inverse b) < e/c → abs c < cBound → (abs (a + inverse b) * abs c) < (e/c * cBound)
          ans' a b c a-b<e/c c<bound with totality 0R c
          ans' a b c a-b<e/c c<bound | inl (inl 0<c) with totality 0G (a + inverse b)
          ans' a b c a-b<e/c c<bound | inl (inl 0<c) | inl (inl 0<a-b) = ringMultiplyPositives 0<a-b 0<c a-b<e/c c<bound
          ans' a b c a-b<e/c c<bound | inl (inl 0<c) | inl (inr a-b<0) = ringMultiplyPositives (lemm2 (a + inverse b) a-b<0) 0<c a-b<e/c c<bound
          ans' a b c a-b<e/c c<bound | inl (inl 0<c) | inr 0=a-b = <WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq (*WellDefined (Equivalence.symmetric eq 0=a-b) (Equivalence.reflexive eq)) (Equivalence.transitive eq *Commutative timesZero))) (Equivalence.reflexive eq) (orderRespectsMultiplication 0<e/c 0<cBound)
          ans' a b c a-b<e/c c<bound | inl (inr c<0) with totality 0G (a + inverse b)
          ans' a b c a-b<e/c c<bound | inl (inr c<0) | inl (inl 0<a-b) = ringMultiplyPositives 0<a-b (lemm2 c c<0) a-b<e/c c<bound
          ans' a b c a-b<e/c c<bound | inl (inr c<0) | inl (inr a-b<0) = ringMultiplyPositives (lemm2 (a + inverse b) a-b<0) (lemm2 c c<0) a-b<e/c c<bound
          ans' a b c a-b<e/c c<bound | inl (inr c<0) | inr 0=a-b = <WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq (*WellDefined (Equivalence.symmetric eq 0=a-b) (Equivalence.reflexive eq)) (Equivalence.transitive eq *Commutative timesZero))) (Equivalence.reflexive eq) (orderRespectsMultiplication 0<e/c 0<cBound)
          ans' a b c a-b<e/c c<bound | inr 0=c = <WellDefined (Equivalence.symmetric eq (Equivalence.transitive eq (*WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=c)) timesZero)) (Equivalence.reflexive eq) (orderRespectsMultiplication 0<e/c 0<cBound)

  multiplicationWellDefinedLeft : (a b c : CauchyCompletion) → Setoid._∼_ cauchyCompletionSetoid a b → Setoid._∼_ cauchyCompletionSetoid (a *C c) (b *C c)
  multiplicationWellDefinedLeft with totality 0R 1R
  ... | inl (inl 0<1') = multiplicationWellDefinedLeft' (λ pr → irreflexive {0G} (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq pr) 0<1'))
  ... | inl (inr 1<0) = multiplicationWellDefinedLeft' (λ pr → irreflexive {0G} (<WellDefined (Equivalence.symmetric eq pr) (Equivalence.reflexive eq) 1<0))
  ... | inr (0=1) = λ a b c a=b → Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {a *C c} {injection 0G} {b *C c} (Equivalence.symmetric (Setoid.eq cauchyCompletionSetoid) {injection 0G} {a *C c} (trivialIfInputTrivial 0=1 (a *C c))) (trivialIfInputTrivial 0=1 (b *C c))

  multiplicationPreservedLeft : {a b : A} {c : CauchyCompletion} → (a ∼ b) → Setoid._∼_ cauchyCompletionSetoid (injection a *C c) (injection b *C c)
  multiplicationPreservedLeft {a} {b} {c} a=b = multiplicationWellDefinedLeft (injection a) (injection b) c (injectionPreservesSetoid a b a=b)

  multiplicationPreservedRight : {a b : A} {c : CauchyCompletion} → (a ∼ b) → Setoid._∼_ cauchyCompletionSetoid (c *C injection a) (c *C injection b)
  multiplicationPreservedRight {a} {b} {c} a=b = Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {c *C injection a} {injection a *C c} {c *C injection b} (*CCommutative {c} {injection a}) (Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {injection a *C c} {injection b *C c} {c *C injection b} (multiplicationPreservedLeft {a} {b} {c} a=b) (*CCommutative {injection b} {c}))

multiplicationPreserved : {a b c d : A} → (a ∼ b) → (c ∼ d) → Setoid._∼_ cauchyCompletionSetoid (injection a *C injection c) (injection b *C injection d)
multiplicationPreserved {a} {b} {c} {d} a=b c=d = Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {injection a *C injection c} {injection a *C injection d} {injection b *C injection d} (multiplicationPreservedRight {c} {d} {injection a} c=d) (multiplicationPreservedLeft {a} {b} {injection d} a=b)

private
  multiplicationWellDefinedRight : (a b c : CauchyCompletion) → Setoid._∼_ cauchyCompletionSetoid b c → Setoid._∼_ cauchyCompletionSetoid (a *C b) (a *C c)
  multiplicationWellDefinedRight a b c b=c = Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {a *C b} {b *C a} {a *C c} (*CCommutative {a} {b}) (Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {b *C a} {c *C a} {a *C c} (multiplicationWellDefinedLeft b c a b=c) (*CCommutative {c} {a}))

multiplicationWellDefined : {a b c d : CauchyCompletion} → Setoid._∼_ cauchyCompletionSetoid a b → Setoid._∼_ cauchyCompletionSetoid c d → Setoid._∼_ cauchyCompletionSetoid (a *C c) (b *C d)
multiplicationWellDefined {a} {b} {c} {d} a=b c=d = Equivalence.transitive (Setoid.eq cauchyCompletionSetoid) {a *C c} {a *C d} {b *C d} (multiplicationWellDefinedRight a c d c=d) (multiplicationWellDefinedLeft a b d a=b)


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

module TNT.Base where

open import Data.Nat
open import Data.Nat.DivMod
open import Data.Nat.Divisibility
open import Data.Nat.Properties
open import Agda.Builtin.Equality
open import Relation.Nullary.Decidable
open import Data.Empty

-- defination of congruence modulo

_≡_⟨mod_⟩ : ℕ → ℕ → (n : ℕ) → {≢0 : False (n ≟ 0)} → Set
(a ≡ b ⟨mod 0 ⟩){}
a ≡ b ⟨mod suc n ⟩ = a % suc n ≡ b % suc n

-- commutative

≡-comm : ∀ {ℓ} {A : Set ℓ} {a b : A} → a ≡ b → b ≡ a
≡-comm refl = refl

≡-mod-comm : ∀ {a b n : ℕ} → a ≡ b ⟨mod suc n ⟩ → b ≡ a ⟨mod suc n ⟩
≡-mod-comm refl₁ = ≡-comm refl₁

-- divisibility

a≡b⟨modn⟩⇒a%n-b%n≡0 : ∀ {a b n : ℕ} → a ≡ b ⟨mod suc n ⟩ → ∣ a % suc n - b % suc n ∣ ≡ 0
a≡b⟨modn⟩⇒a%n-b%n≡0 refl₁ = n≡m⇒∣n-m∣≡0 refl₁

a%n-b%n≡0⇒⟨a-b⟩%n≡0 : ∀ {a b n : ℕ} → ∣ a % suc n - b % suc n ∣ ≡ 0 → ∣ a - b ∣ % suc n ≡ 0
a%n-b%n≡0⇒⟨a-b⟩%n≡0 = {!!}

≡-mod-div : ∀ {a b n : ℕ} → a ≡ b ⟨mod suc n ⟩ → suc n ∣ ∣ a - b ∣
≡-mod-div {a} {b} {n} refl₁ = m%n≡0⇒n∣m ∣ a - b ∣ n (a%n-b%n≡0⇒⟨a-b⟩%n≡0 {a} {b} {n} (a≡b⟨modn⟩⇒a%n-b%n≡0 {a} {b} {n} refl₁))

-- transitivity

≡-trans : ∀ {ℓ} {A : Set ℓ} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
≡-trans refl refl = refl

≡-mod-trans : ∀ {a b c n : ℕ} → a ≡ b ⟨mod suc n ⟩ → b ≡ c ⟨mod suc n ⟩ → a ≡ c ⟨mod suc n ⟩
≡-mod-trans refl₁ refl₂ = ≡-trans refl₁ refl₂


{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.Pointed.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed.Base
open import Cubical.Data.Prod

Π∙ : ∀ {ℓ ℓ'} (A : Type ℓ) (B∙ : A → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Π∙ A B∙ = (∀ a → typ (B∙ a)) , (λ a → pt (B∙ a))

Σ∙ : ∀ {ℓ ℓ'} (A∙ : Pointed ℓ) (B∙ : typ A∙ → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Σ∙ A∙ B∙ = (Σ[ a ∈ typ A∙ ] typ (B∙ a)) , (pt A∙ , pt (B∙ (pt A∙)))

_×∙_ : ∀ {ℓ ℓ'} (A∙ : Pointed ℓ) (B∙ : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
A∙ ×∙ B∙ = ((typ A∙) × (typ B∙)) , (pt A∙ , pt B∙)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Greatest common divisor
------------------------------------------------------------------------

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

module Data.Nat.GCD where

open import Data.Nat
open import Data.Nat.Divisibility
open import Data.Nat.GCD.Lemmas
open import Data.Nat.Properties using (+-suc)
open import Data.Product
open import Function
open import Induction
open import Induction.Nat using (<′-Rec; <′-recBuilder)
open import Induction.Lexicographic
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_; subst)
open import Relation.Nullary using (Dec; yes; no)

------------------------------------------------------------------------
-- Greatest common divisor

module GCD where

  -- Specification of the greatest common divisor (gcd) of two natural
  -- numbers.

  record GCD (m n gcd : ℕ) : Set where
    constructor is
    field
      -- The gcd is a common divisor.
      commonDivisor : gcd ∣ m × gcd ∣ n

      -- All common divisors divide the gcd, i.e. the gcd is the
      -- greatest common divisor according to the partial order _∣_.
      greatest : ∀ {d} → d ∣ m × d ∣ n → d ∣ gcd

  open GCD public

  -- The gcd is unique.

  unique : ∀ {d₁ d₂ m n} → GCD m n d₁ → GCD m n d₂ → d₁ ≡ d₂
  unique d₁ d₂ = ∣-antisym (GCD.greatest d₂ (GCD.commonDivisor d₁))
                           (GCD.greatest d₁ (GCD.commonDivisor d₂))

  -- The gcd relation is "symmetric".

  sym : ∀ {d m n} → GCD m n d → GCD n m d
  sym g = is (swap $ GCD.commonDivisor g) (GCD.greatest g ∘ swap)

  -- The gcd relation is "reflexive".

  refl : ∀ {n} → GCD n n n
  refl = is (∣-refl , ∣-refl) proj₁

  -- The GCD of 0 and n is n.

  base : ∀ {n} → GCD 0 n n
  base {n} = is (n ∣0 , ∣-refl) proj₂

  -- If d is the gcd of n and k, then it is also the gcd of n and
  -- n + k.

  step : ∀ {n k d} → GCD n k d → GCD n (n + k) d
  step g with GCD.commonDivisor g
  step {n} {k} {d} g | (d₁ , d₂) = is (d₁ , ∣m∣n⇒∣m+n d₁ d₂) greatest′
    where
    greatest′ : ∀ {d′} → d′ ∣ n × d′ ∣ n + k → d′ ∣ d
    greatest′ (d₁ , d₂) = GCD.greatest g (d₁ , ∣m+n∣m⇒∣n d₂ d₁)

open GCD public using (GCD) hiding (module GCD)

------------------------------------------------------------------------
-- Calculating the gcd

-- The calculation also proves Bézout's lemma.

module Bézout where

  module Identity where

    -- If m and n have greatest common divisor d, then one of the
    -- following two equations is satisfied, for some numbers x and y.
    -- The proof is "lemma" below (Bézout's lemma).
    --
    -- (If this identity was stated using integers instead of natural
    -- numbers, then it would not be necessary to have two equations.)

    data Identity (d m n : ℕ) : Set where
      +- : (x y : ℕ) (eq : d + y * n ≡ x * m) → Identity d m n
      -+ : (x y : ℕ) (eq : d + x * m ≡ y * n) → Identity d m n

    -- Various properties about Identity.

    sym : ∀ {d} → Symmetric (Identity d)
    sym (+- x y eq) = -+ y x eq
    sym (-+ x y eq) = +- y x eq

    refl : ∀ {d} → Identity d d d
    refl = -+ 0 1 P.refl

    base : ∀ {d} → Identity d 0 d
    base = -+ 0 1 P.refl

    private
      infixl 7 _⊕_

      _⊕_ : ℕ → ℕ → ℕ
      m ⊕ n = 1 + m + n

    step : ∀ {d n k} → Identity d n k → Identity d n (n + k)
    step {d}     (+-  x  y       eq) with compare x y
    step {d}     (+- .x .x       eq) | equal x     = +- (2 * x)     x       (lem₂ d x   eq)
    step {d}     (+- .x .(x ⊕ i) eq) | less x i    = +- (2 * x ⊕ i) (x ⊕ i) (lem₃ d x   eq)
    step {d} {n} (+- .(y ⊕ i) .y eq) | greater y i = +- (2 * y ⊕ i) y       (lem₄ d y n eq)
    step {d}     (-+  x  y       eq) with compare x y
    step {d}     (-+ .x .x       eq) | equal x     = -+ (2 * x)     x       (lem₅ d x   eq)
    step {d}     (-+ .x .(x ⊕ i) eq) | less x i    = -+ (2 * x ⊕ i) (x ⊕ i) (lem₆ d x   eq)
    step {d} {n} (-+ .(y ⊕ i) .y eq) | greater y i = -+ (2 * y ⊕ i) y       (lem₇ d y n eq)

  open Identity public using (Identity; +-; -+) hiding (module Identity)

  module Lemma where

    -- This type packs up the gcd, the proof that it is a gcd, and the
    -- proof that it satisfies Bézout's identity.

    data Lemma (m n : ℕ) : Set where
      result : (d : ℕ) (g : GCD m n d) (b : Identity d m n) → Lemma m n

    -- Various properties about Lemma.

    sym : Symmetric Lemma
    sym (result d g b) = result d (GCD.sym g) (Identity.sym b)

    base : ∀ d → Lemma 0 d
    base d = result d GCD.base Identity.base

    refl : ∀ d → Lemma d d
    refl d = result d GCD.refl Identity.refl

    stepˡ : ∀ {n k} → Lemma n (suc k) → Lemma n (suc (n + k))
    stepˡ {n} {k} (result d g b) =
      subst (Lemma n) (+-suc n k) $
        result d (GCD.step g) (Identity.step b)

    stepʳ : ∀ {n k} → Lemma (suc k) n → Lemma (suc (n + k)) n
    stepʳ = sym ∘ stepˡ ∘ sym

  open Lemma public using (Lemma; result) hiding (module Lemma)

  -- Bézout's lemma proved using some variant of the extended
  -- Euclidean algorithm.

  lemma : (m n : ℕ) → Lemma m n
  lemma m n = build [ <′-recBuilder ⊗ <′-recBuilder ] P gcd (m , n)
    where
    P : ℕ × ℕ → Set
    P (m , n) = Lemma m n

    gcd : ∀ p → (<′-Rec ⊗ <′-Rec) P p → P p
    gcd (zero  , n                 ) rec = Lemma.base n
    gcd (suc m , zero              ) rec = Lemma.sym (Lemma.base (suc m))
    gcd (suc m , suc n             ) rec with compare m n
    gcd (suc m , suc .m            ) rec | equal .m     = Lemma.refl (suc m)
    gcd (suc m , suc .(suc (m + k))) rec | less .m k    =
                      -- "gcd (suc m) (suc k)"
      Lemma.stepˡ $ proj₁ rec (suc k) (lem₁ k m)
    gcd (suc .(suc (n + k)) , suc n) rec | greater .n k =
                      -- "gcd (suc k) (suc n)"
      Lemma.stepʳ $ proj₂ rec (suc k) (lem₁ k n) (suc n)

  -- Bézout's identity can be recovered from the GCD.

  identity : ∀ {m n d} → GCD m n d → Identity d m n
  identity {m} {n} g with lemma m n
  ... | result d g′ b with GCD.unique g g′
  ...   | P.refl = b

-- Calculates the gcd of the arguments.

gcd : (m n : ℕ) → ∃ λ d → GCD m n d
gcd m n with Bézout.lemma m n
... | Bézout.result d g _ = (d , g)

-- gcd as a proposition is decidable

gcd? : (m n d : ℕ) → Dec (GCD m n d)
gcd? m n d with gcd m n
... | d′ , p with d′ ≟ d
...   | no ¬g = no (¬g ∘ GCD.unique p)
...   | yes g = yes (subst (GCD m n) g p)


module RTN where

  data Nat : Set where
    zero : Nat
    suc  : Nat -> Nat

  {-# BUILTIN NATURAL Nat #-}
  {-# BUILTIN SUC suc #-}
  {-# BUILTIN ZERO zero #-}


-- Transport properties

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

module Constructive.Axiom.Properties.Transport where

-- agda-stdlib
open import Level renaming (suc to lsuc; zero to lzero)
open import Data.Sum as Sum
open import Data.Product as Prod
open import Relation.Binary.PropositionalEquality
open import Function.Base
import Function.LeftInverse as LInv -- TODO use new packages
import Function.Equality as Eq

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

module Transport
  {a b p} {A : Set a} {B : Set b}
  (f : A → B) (g : B → A) (inv : ∀ x → f (g x) ≡ x)
  where
  private
    ∃Pf→∃P : {P : B → Set p} → ∃ (λ x → P (f x)) → ∃ P
    ∃Pf→∃P (x , Pfx) = (f x , Pfx)

    ∃P→∃Pf : {P : B → Set p} → ∃ P → ∃ (λ x → P (f x))
    ∃P→∃Pf {P = P} (x , Px) = g x , subst P (sym (inv x)) Px

    ∃Qg→∃Q : {Q : A → Set p} → ∃ (λ x → Q (g x)) → ∃ Q
    ∃Qg→∃Q (x , Qgx) = g x , Qgx

  lpo-transport : LPO A p → LPO B p
  lpo-transport lpo P? =
    Sum.map ∃Pf→∃P (contraposition ∃P→∃Pf) $ lpo (DecU-map f P?)

  llpo-transport : LLPO A p → LLPO B p
  llpo-transport llpo P? Q? w =
    Sum.map (contraposition ∃P→∃Pf) (contraposition ∃P→∃Pf) $
            llpo (DecU-map f P?) (DecU-map f Q?)
                 (contraposition (Prod.map ∃Pf→∃P ∃Pf→∃P) w)

  wlpo-Alt-transport : WLPO-Alt A p → WLPO-Alt B p
  wlpo-Alt-transport wlpo-Alt P? =
    Sum.map (contraposition ∃P→∃Pf) (DN-map ∃Pf→∃P) $ wlpo-Alt (DecU-map f P?)

  wlpo-transport : WLPO A p → WLPO B p
  wlpo-transport = wlpo-Alt⇒wlpo ∘′ wlpo-Alt-transport ∘′ wlpo⇒wlpo-Alt

  mr-transport : MR A p → MR B p
  mr-transport mr P? ¬¬∃P =
    ∃Pf→∃P $ mr (DecU-map f P?) (DN-map ∃P→∃Pf ¬¬∃P)

  mp-transport : MP A p → MP B p
  mp-transport = mr⇒mp ∘′ mr-transport ∘′ mp⇒mr

  wmp-transport : WMP A p → WMP B p
  wmp-transport wmp {P = P} P? hyp =
    ∃Pf→∃P $ wmp (DecU-map f P?)
    λ Q? → Sum.map (DN-map ∃Qg→∃Q) (DN-map λ {(x , Px , ¬Qgx) →
      g x , (subst P (sym (inv x)) Px) , ¬Qgx }) $ hyp (DecU-map g Q?)

  mp⊎-transport : MP⊎ A p → MP⊎ B p
  mp⊎-transport mp⊎ P? Q? w =
    Sum.map (DN-map ∃Pf→∃P) (DN-map ∃Pf→∃P) $
            mp⊎ (DecU-map f P?) (DecU-map f Q?)
                (contraposition (Prod.map (contraposition ∃P→∃Pf)
                                          (contraposition ∃P→∃Pf)) w)

open Transport public

module TransportByLeftInverse
  {a b p} {A : Set a} {B : Set b} (linv : B LInv.↞ A) =
  Transport {p = p} (LInv.LeftInverse.from linv Eq.⟨$⟩_)
    (LInv.LeftInverse.to linv Eq.⟨$⟩_) (LInv.LeftInverse.left-inverse-of linv)


{-# OPTIONS --cubical #-}

module Type.Cubical.SubtypeSet where

open import Function.Axioms
open import Functional
open import Logic.Predicate as PTLogic using () renaming ([∃]-intro to intro)
import      Lvl
open import Structure.Function.Domain using (intro ; Inverseₗ ; Inverseᵣ)
open import Structure.Relator.Properties
open import Structure.Type.Identity
open import Type.Cubical.Equiv
import      Type.Cubical.Logic as Logic
open import Type.Cubical.Path.Equality
open import Type.Cubical.Univalence
open import Type.Cubical
open import Type.Properties.MereProposition
open import Type.Properties.Singleton.Proofs
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ : Lvl.Level
private variable T A B P Q : Type{ℓ}

{-
module _ {P Q : T → Type} ⦃ prop-P : ∀{x} → MereProposition{ℓ}(P(x)) ⦄ ⦃ prop-Q : ∀{x} → MereProposition{ℓ}(Q(x)) ⦄ where
  prop-set-extensionalityₗ : (P ≡ Q) ← (∀{x} → P(x) ↔ Q(x))
  prop-set-extensionalityₗ pq = functionExtensionalityOn P Q (propositional-extensionalityₗ pq)
-}

--data Prop{ℓ} : Type{Lvl.𝐒(ℓ)} where
--  intro : (T : Type{ℓ}) → ⦃ MereProposition(T) ⦄ → Prop
Prop = \{ℓ} → PTLogic.∃{Obj = Type{ℓ}} (T ↦ MereProposition(T))

⊤ : Prop
⊤ = intro(Logic.⊤) ⦃ prop-top ⦄

⊥ : Prop
⊥ = intro(Logic.⊥) ⦃ prop-bottom ⦄

¬_ : Prop{ℓ} → Prop
¬(intro A) = intro(Logic.¬ A) ⦃ prop-negation ⦄

_⟶_ : Prop{ℓ₁} → Prop{ℓ₂} → Prop
(intro A) ⟶ (intro B) = intro(A → B) ⦃ prop-implication ⦄

_∨_ : Prop{ℓ₁} → Prop{ℓ₂} → Prop
(intro A) ∨ (intro B) = intro(A Logic.∨ B)

_∧_ : Prop{ℓ₁} → Prop{ℓ₂} → Prop
(intro A) ∧ (intro B) = intro(A Logic.∧ B) ⦃ prop-conjunction ⦄

∃ : (T → Prop{ℓ}) → Prop
∃ P = intro(Logic.∃(PTLogic.[∃]-witness ∘ P))

-- ∀ₚ : (T → Prop{ℓ}) → Prop
-- ∀ₚ P = intro(PTLogic.∀ₗ(PTLogic.[∃]-witness ∘ P)) ⦃ {!prop-universal!} ⦄

record SubtypeSet {ℓₑ ℓ} (T : Type{ℓ}) : Type{ℓ Lvl.⊔ Lvl.𝐒(ℓₑ)} where
  constructor filter
  field _∋_ : T → Prop{ℓₑ}
open SubtypeSet using (_∋_) public

{- TODO: When Structure is generalized to arbitrary logic symbols
import      Structure.Sets.Names
open        Structure.Sets.Names.From-[∋] (_∋_) public
-}

_∈_ : T → SubtypeSet{ℓ}(T) → Prop
_∈_ = swap(_∋_)

_∉_ : T → SubtypeSet{ℓ}(T) → Prop
_∉_ = (¬_) ∘₂ (_∈_)

_∌_ : SubtypeSet{ℓ}(T) → T → Prop
_∌_ = (¬_) ∘₂ (_∋_)

∅ : SubtypeSet(T)
∅ ∋ _ = ⊥

𝐔 : SubtypeSet(T)
𝐔 ∋ _ = ⊤

∁ : SubtypeSet{ℓ}(T) → SubtypeSet(T)
(∁ A) ∋ x = A ∌ x

_∪_ : SubtypeSet{ℓ₁}(T) → SubtypeSet{ℓ₂}(T) → SubtypeSet(T)
(A ∪ B) ∋ x = (A ∋ x) ∨ (B ∋ x)

_∩_ : SubtypeSet{ℓ₁}(T) → SubtypeSet{ℓ₂}(T) → SubtypeSet(T)
(A ∩ B) ∋ x = (A ∋ x) ∧ (B ∋ x)

_∖_ : SubtypeSet{ℓ₁}(T) → SubtypeSet{ℓ₂}(T) → SubtypeSet(T)
(A ∖ B) ∋ x = (A ∋ x) ∧ (B ∌ x)

unmap : (A → B) → SubtypeSet{ℓ}(B) → SubtypeSet(A)
unmap f(A) ∋ x = A ∋ f(x)

-- map : (A → B) → SubtypeSet{ℓ}(A) → SubtypeSet(B)
-- map f(A) ∋ y = ∃(x ↦ (A ∋ x) ∧ (f(x) ≡ y))

-- TODO: Maybe SubtypeSet should require that the witness is a HSet?
-- ⊶ : (A → B) → SubtypeSet(B)
-- (⊶ f) ∋ y = ∃(x ↦ PTLogic.[∃]-intro (f(x) ≡ y) ⦃ {!!} ⦄)


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

module PiIter where

open import Level using (_⊔_) renaming (zero to l0; suc to lsuc)
open import Universe using (Universe)

open import Categories.Category using (Category)
open import Categories.Groupoid using (Groupoid)
open import Categories.Functor using (Functor)

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum hiding ([_,_])
open import Data.Product
open import Relation.Binary.PropositionalEquality as P
open import Function using (flip)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Nat.Properties.Simple using (+-right-identity)
open import Data.Integer using (ℤ;+_;-[1+_]) renaming (suc to ℤsuc; -_ to ℤ-; _+_ to _ℤ+_)

open import PiU using (U; ZERO; ONE; PLUS; TIMES; toℕ)
open import PiLevel0
open import PiLevel1
open import PiEquiv renaming (eval to ap; evalB to apB)
open import Equiv

infix 40 _^_

_^_ : {τ : U} → (p : τ ⟷ τ) → (k : ℤ) → (τ ⟷ τ)
p ^ (+ 0) = id⟷
p ^ (+ (suc k)) = p ◎ (p ^ (+ k))
p ^ -[1+ 0 ] = ! p
p ^ (-[1+ (suc k) ]) = (! p) ◎ (p ^ -[1+ k ])

-- useful properties of ^
-- because ^ is iterated composition of the same thing,
-- then by associativity, we can hive off compositions
-- from left or right

assoc1 : {τ : U} → {p : τ ⟷ τ} → (m : ℕ) →
  (p ◎ (p ^ (+ m))) ⇔ ((p ^ (+ m)) ◎ p)
assoc1 ℕ.zero = trans⇔ idr◎l idl◎r
assoc1 (suc m) = trans⇔ (id⇔ ⊡ assoc1 m) assoc◎l

assoc1- : {τ : U} → {p : τ ⟷ τ} → (m : ℕ) →
  ((! p) ◎ (p ^ -[1+ m ])) ⇔ ((p ^ -[1+ m ]) ◎ (! p))
assoc1- ℕ.zero = id⇔
assoc1- (suc m) = trans⇔ (id⇔ ⊡ assoc1- m) assoc◎l

-- more generally
assoc1g : {τ : U} → {p : τ ⟷ τ} → (i : ℤ) →
  (p ◎ (p ^ i)) ⇔ ((p ^ i) ◎ p)
assoc1g (+_ n) = assoc1 n
assoc1g (-[1+_] zero) = trans⇔ linv◎l rinv◎r
assoc1g (-[1+_] (suc n)) = trans⇔ assoc◎l (trans⇔ (linv◎l ⊡ id⇔) (
  trans⇔ idl◎l (2! (trans⇔ (assoc1- n ⊡ id⇔) (trans⇔ assoc◎r
  (trans⇔ (id⇔ ⊡ rinv◎l) idr◎l))))))

-- Property of ^: negating exponent is same as
-- composing in the other direction, then reversing.
^⇔! : {τ : U} → {p : τ ⟷ τ} → (k : ℤ) →
  (p ^ (ℤ- k)) ⇔ ! (p ^ k)
^⇔! (+_ ℕ.zero) = id⇔
-- need to dig deeper, as we end up negating
^⇔! (+_ (suc ℕ.zero)) = idl◎r
^⇔! (+_ (suc (suc n))) = trans⇔ (assoc1- n) (^⇔! (+ suc n) ⊡ id⇔)
^⇔! {p = p} (-[1+_] ℕ.zero) = trans⇔ idr◎l (2! !!⇔id) -- (!!⇔id {c = p})
^⇔! {p = p} (-[1+_] (suc n)) =
  trans⇔ (assoc1 (suc n)) ((^⇔! -[1+ n ]) ⊡ 2! !!⇔id) -- (!!⇔id p))

-- first match on m, n, then proof is purely PiLevel1
lower : {τ : U} {p : τ ⟷ τ} (m n : ℤ) →
  p ^ (m ℤ+ n) ⇔ ((p ^ m) ◎ (p ^ n))
lower (+_ ℕ.zero) (+_ n) = idl◎r
lower (+_ ℕ.zero) (-[1+_] n) = idl◎r
lower (+_ (suc m)) (+_ n) =
  trans⇔ (id⇔ ⊡ lower (+ m) (+ n)) assoc◎l
lower {p = p} (+_ (suc m)) (-[1+_] ℕ.zero) =
  trans⇔ idr◎r (trans⇔ (id⇔ ⊡ linv◎r) (
  trans⇔ assoc◎l (2! (assoc1 m) ⊡ id⇔)))  -- p ^ ((m + 1) -1)
lower (+_ (suc m)) (-[1+_] (suc n)) = -- p ^ ((m + 1) -(1+1+n)
  trans⇔ (lower (+ m) (-[1+ n ])) (
  trans⇔ ((trans⇔ idr◎r (id⇔ ⊡ linv◎r))  ⊡ id⇔) (
  trans⇔ assoc◎r (trans⇔ (id⇔ ⊡ assoc◎r) (
  trans⇔ assoc◎l (2! (assoc1 m) ⊡ id⇔)))))
lower (-[1+_] m) (+_ ℕ.zero) = idr◎r
lower (-[1+_] ℕ.zero) (+_ (suc n)) = 2! (trans⇔ assoc◎l (
  trans⇔ (rinv◎l ⊡ id⇔) idl◎l))
lower (-[1+_] (suc m)) (+_ (suc n)) = -- p ^ (-(1+m) + (n+1))
  trans⇔ (lower (-[1+ m ]) (+ n)) (
    trans⇔ ((trans⇔ idr◎r (id⇔ ⊡ rinv◎r))  ⊡ id⇔) (
  trans⇔ assoc◎r (trans⇔ (id⇔ ⊡ assoc◎r) (
  trans⇔ assoc◎l ((2! (assoc1- m)) ⊡ id⇔)))))
lower (-[1+_] ℕ.zero) (-[1+_] n) = id⇔
lower (-[1+_] (suc m)) (-[1+_] n) = -- p ^ (-(1+1+m) - (1+n))
  trans⇔ (id⇔ ⊡ lower (-[1+ m ]) (-[1+ n ])) assoc◎l

-- i.e. Iter is: for all i, any p' such that
-- p' ⇔ p ^ i

record Iter {τ : U} (p : τ ⟷ τ) : Set where
  constructor iter
  field
    i : ℤ
    p' : τ ⟷ τ
    p'⇔p^i : p' ⇔ (p ^ i)

-- Equality of Iter.
record _≡c_ {τ : U} {p : τ ⟷ τ} (q r : Iter p) : Set where
  constructor eqc
  field
    iter≡ : Iter.i q ≡ Iter.i r
    p⇔ : Iter.p' q ⇔ Iter.p' r

-- Iterates of id⟷
id^i≡id : {t : U} (i : ℤ) → (id⟷ ^ i) ⇔ (id⟷ {t})
id^i≡id (+_ zero) = id⇔
id^i≡id (+_ (suc n)) = trans⇔ idl◎l (id^i≡id (+ n))
id^i≡id (-[1+_] zero) = id⇔
id^i≡id (-[1+_] (suc n)) = trans⇔ idl◎l (id^i≡id -[1+ n ])


module _ where

open import Agda.Builtin.String

_&_ = primStringAppend

record Show (A : Set) : Set where
  field
    show : A → String

open Show {{...}} public

data Bin : Set where
  []  : Bin
  0:_ : Bin → Bin
  1:_ : Bin → Bin

five : Bin
five = 1: 0: 1: []

instance
  ShowBin : Show Bin
  show {{ShowBin}} [] = ""
  show {{ShowBin}} (0: b) = "0" & show b
  show {{ShowBin}} (1: b) = "1" & show b

hole : Bin → Bin
hole x = {!!}


module CombinatoryLogic.Semantics where

open import Relation.Binary using (Rel)

open import CombinatoryLogic.Syntax

-- Kapitel 1, Abschnitt C, §5 (Axiome)
data Axiom : Combinator → Set where
  Q : Axiom (Π ∙ (W ∙ (C ∙ Q)))
  B : Axiom (C ∙ (B ∙ B ∙ (B ∙ B ∙ B)) ∙ B == B ∙ (B ∙ B) ∙ B)
  C : Axiom (C ∙ (B ∙ B ∙ (B ∙ B ∙ B)) ∙ W ∙ C == B ∙ (B ∙ C) ∙ (B ∙ B ∙ B))
  W : Axiom (C ∙ (B ∙ B ∙ B) ∙ W == B ∙ (B ∙ W) ∙ (B ∙ B ∙ B))
  -- NOTE (Curry): this axiom can be proved from the others.
  I₁ : Axiom (C ∙ (B ∙ B ∙ B) ∙ K == B ∙ (B ∙ K) ∙ I)
  BC : Axiom (B ∙ B ∙ C == B ∙ (B ∙ (B ∙ C) ∙ C) ∙ (B ∙ B))
  BW : Axiom (B ∙ B ∙ W == B ∙ (B ∙ (B ∙ (B ∙ (B ∙ W) ∙ W) ∙ (B ∙ C)) ∙ B ∙ (B ∙ B)) ∙ B)
  BK : Axiom (B ∙ B ∙ K == B ∙ K ∙ K)
  CC₁ : Axiom (B ∙ C ∙ C ∙ B ∙ (B ∙ I))
  CC₂ : Axiom (B ∙ (B ∙ (B ∙ C) ∙ C) ∙ (B ∙ C) == B ∙ (B ∙ C ∙ (B ∙ C)) ∙ C)
  CW : Axiom (B ∙ C ∙ W == B ∙ (B ∙ (B ∙ W) ∙ C) ∙ (B ∙ C))
  CK : Axiom (B ∙ C ∙ K == B ∙ K)
  WC : Axiom (B ∙ W ∙ C == W)
  WW : Axiom (B ∙ W ∙ W == B ∙ W ∙ (B ∙ W))
  WK : Axiom (B ∙ W ∙ K == B ∙ I)
  I₂ : Axiom (B ∙ I == I)

-- Kapitel 1, Abschnitt C, §4 (Symbolische Festsetzungen), Festsetzung 1
infix 4 ⊢_
data ⊢_ : Combinator → Set where
  ax : ∀ {X} → Axiom X → ⊢ X

  -- Kapitel 1, Abschnitt C, §6 (Regeln)
  Q₁ : ∀ {X Y} → ⊢ X → ⊢ X == Y → ⊢ Y
  Q₂ : ∀ {X Y Z} → ⊢ X == Y → ⊢ Z ∙ X == Z ∙ Y
  Π : ∀ {X Y} → ⊢ Π ∙ X → ⊢ X ∙ Y
  B : ∀ {X Y Z} → ⊢ B ∙ X ∙ Y ∙ Z == X ∙ (Y ∙ Z)
  C : ∀ {X Y Z} → ⊢ C ∙ X ∙ Y ∙ Z == X ∙ Z ∙ Y
  W : ∀ {X Y} → ⊢ W ∙ X ∙ Y == X ∙ Y ∙ Y
  K : ∀ {X Y} → ⊢ K ∙ X ∙ Y == X
  P : ∀ {X Y} → ⊢ X → ⊢ P ∙ X ∙ Y → ⊢ Y
  ∧ : ∀ {X Y} → ⊢ X → ⊢ Y → ⊢ ∧ ∙ X ∙ Y

-- We introduce convenience notation for the equality defined in Kapitel 1,
-- Abschnitt C, §4 (Symbolische Festsetzungen), Festsetzung 3 (Gleichheit).
_≈_ : Rel Combinator _
X ≈ Y = ⊢ X == Y

infix 0 _[_]

-- An operator that helps write proofs in the style of Curry. Where Curry writes
--   ⟨statement⟩ (⟨rule⟩)
-- we write
--   ⟨statement⟩ [ ⟨rule⟩ ]
--
-- Later, we can also use the Agda standard library's reasoning combinators
-- (e.g. _≈⟨_⟩_) for proving equalities, but not before it is shown that the
-- equality _≈_ is an equivalence relation, which Curry does in propositions 1,
-- 2 and 3 of Kapitel 1, Abschnitt D (Die Eigenschaften der Gleichheit).
_[_] : ∀ {a} (A : Set a) (x : A) → A
_ [ x ] = x


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

-- Monoidal natural transformations between lax and strong symmetric
-- monoidal functors.
--
-- NOTE. Symmetric monoidal natural transformations are really just
-- monoidal natural transformations that happen to go between
-- symmetric monoidal functors.  No additional conditions are
-- necessary.  Nevertheless, the definitions in this module are useful
-- when one is working in a symmetric monoidal setting.  They also
-- help Agda's type checker by bundling the (symmetric monoidal)
-- categories and functors involved.
--
-- See
--  * John Baez, Some definitions everyone should know,
--    https://math.ucr.edu/home/baez/qg-fall2004/definitions.pdf
--  * https://ncatlab.org/nlab/show/monoidal+natural+transformation

module Categories.NaturalTransformation.Monoidal.Symmetric where

open import Level

open import Categories.Category.Monoidal using (SymmetricMonoidalCategory)
import Categories.Functor.Monoidal.Symmetric as BMF
open import Categories.Functor.Monoidal.Properties using ()
  renaming (∘-SymmetricMonoidal to _∘Fˡ_; ∘-StrongSymmetricMonoidal to _∘Fˢ_)
open import Categories.NaturalTransformation as NT using (NaturalTransformation)
import Categories.NaturalTransformation.Monoidal as MNT

module Lax where
  open BMF.Lax using (SymmetricMonoidalFunctor)
  open MNT.Lax using (IsMonoidalNaturalTransformation)
  open SymmetricMonoidalFunctor using ()
    renaming (F to UF; monoidalFunctor to MF)

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Monoidal natural transformations between symmetric monoidal functors.

    record SymmetricMonoidalNaturalTransformation
           (F G : SymmetricMonoidalFunctor C D) : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where

      field
        U          : NaturalTransformation (UF F) (UF G)
        isMonoidal : IsMonoidalNaturalTransformation (MF F) (MF G) U

      open NaturalTransformation           U          public
      open IsMonoidalNaturalTransformation isMonoidal public

  -- To shorten some definitions

  private
    _⇛_ = SymmetricMonoidalNaturalTransformation
    module U = MNT.Lax

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Conversions

    ⌊_⌋ : {F G : SymmetricMonoidalFunctor C D} →
          F ⇛ G → U.MonoidalNaturalTransformation (MF F) (MF G)
    ⌊ α ⌋ = record { U = U ; isMonoidal = isMonoidal }
      where open SymmetricMonoidalNaturalTransformation α

    ⌈_⌉ : {F G : SymmetricMonoidalFunctor C D} →
          U.MonoidalNaturalTransformation (MF F) (MF G) → F ⇛ G
    ⌈ α ⌉ = record { U = U ; isMonoidal = isMonoidal }
      where open U.MonoidalNaturalTransformation α

    -- Identity and compositions

    infixr 9 _∘ᵥ_

    id : {F : SymmetricMonoidalFunctor C D} → F ⇛ F
    id = ⌈ U.id ⌉

    _∘ᵥ_ : {F G H : SymmetricMonoidalFunctor C D} → G ⇛ H → F ⇛ G → F ⇛ H
    α ∘ᵥ β   = ⌈ ⌊ α ⌋ U.∘ᵥ ⌊ β ⌋ ⌉

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {E : SymmetricMonoidalCategory o″ ℓ″ e″} where

    infixr 9 _∘ₕ_ _∘ˡ_ _∘ʳ_

    _∘ₕ_ : {F G : SymmetricMonoidalFunctor C D}
           {H I : SymmetricMonoidalFunctor D E} →
           H ⇛ I → F ⇛ G → (H ∘Fˡ F) ⇛ (I ∘Fˡ G)
    α ∘ₕ β = ⌈ ⌊ α ⌋ U.∘ₕ ⌊ β ⌋ ⌉

    _∘ˡ_ : {F G : SymmetricMonoidalFunctor C D}
           (H : SymmetricMonoidalFunctor D E) → F ⇛ G → (H ∘Fˡ F) ⇛ (H ∘Fˡ G)
    H ∘ˡ α = id {F = H} ∘ₕ α

    _∘ʳ_ : {G H : SymmetricMonoidalFunctor D E} →
           G ⇛ H → (F : SymmetricMonoidalFunctor C D) → (G ∘Fˡ F) ⇛ (H ∘Fˡ F)
    α ∘ʳ F = α ∘ₕ id {F = F}

module Strong where
  open BMF.Strong using (SymmetricMonoidalFunctor)
  open MNT.Strong using (IsMonoidalNaturalTransformation)
  open SymmetricMonoidalFunctor using () renaming
    ( F                         to UF
    ; monoidalFunctor           to MF
    ; laxSymmetricMonoidalFunctor to laxBMF
    )

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Monoidal natural transformations between symmetric strong
    -- monoidal functors.

    record SymmetricMonoidalNaturalTransformation
           (F G : SymmetricMonoidalFunctor C D) : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where

      field
        U          : NaturalTransformation (UF F) (UF G)
        isMonoidal : IsMonoidalNaturalTransformation (MF F) (MF G) U

      laxBNT : Lax.SymmetricMonoidalNaturalTransformation (laxBMF F) (laxBMF G)
      laxBNT = record { U = U ; isMonoidal = isMonoidal }
      open Lax.SymmetricMonoidalNaturalTransformation laxBNT public
        hiding (U; isMonoidal)

  -- To shorten some definitions

  private
    _⇛_ = SymmetricMonoidalNaturalTransformation
    module U = MNT.Strong

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Conversions

    ⌊_⌋ : {F G : SymmetricMonoidalFunctor C D} →
          F ⇛ G → U.MonoidalNaturalTransformation (MF F) (MF G)
    ⌊ α ⌋ = record { U = U ; isMonoidal = isMonoidal }
      where open SymmetricMonoidalNaturalTransformation α

    ⌈_⌉ : {F G : SymmetricMonoidalFunctor C D} →
          U.MonoidalNaturalTransformation (MF F) (MF G) → F ⇛ G
    ⌈ α ⌉ = record { U = U ; isMonoidal = isMonoidal }
      where open U.MonoidalNaturalTransformation α

    -- Identity and compositions

    infixr 9 _∘ᵥ_

    id : {F : SymmetricMonoidalFunctor C D} → F ⇛ F
    id = ⌈ U.id ⌉

    _∘ᵥ_ : {F G H : SymmetricMonoidalFunctor C D} → G ⇛ H → F ⇛ G → F ⇛ H
    α ∘ᵥ β   = ⌈ ⌊ α ⌋ U.∘ᵥ ⌊ β ⌋ ⌉

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {E : SymmetricMonoidalCategory o″ ℓ″ e″} where

    infixr 9 _∘ₕ_ _∘ˡ_ _∘ʳ_

    _∘ₕ_ : {F G : SymmetricMonoidalFunctor C D}
           {H I : SymmetricMonoidalFunctor D E} →
           H ⇛ I → F ⇛ G → (H ∘Fˢ F) ⇛ (I ∘Fˢ G)
    -- NOTE: this definition is clearly equivalent to
    --
    --   α ∘ₕ β = ⌈ ⌊ α ⌋ U.∘ₕ ⌊ β ⌋ ⌉
    --
    -- but the latter takes an unreasonably long time to typecheck,
    -- while the unfolded version typechecks almost immediately.
    α ∘ₕ β = record
      { U               = C.U
      ; isMonoidal      = record
        { ε-compat      = C.ε-compat
        ; ⊗-homo-compat = C.⊗-homo-compat
        }
      }
      where module C = U.MonoidalNaturalTransformation (⌊ α ⌋ U.∘ₕ ⌊ β ⌋)

    _∘ˡ_ : {F G : SymmetricMonoidalFunctor C D}
           (H : SymmetricMonoidalFunctor D E) → F ⇛ G → (H ∘Fˢ F) ⇛ (H ∘Fˢ G)
    H ∘ˡ α = id {F = H} ∘ₕ α

    _∘ʳ_ : {G H : SymmetricMonoidalFunctor D E} →
           G ⇛ H → (F : SymmetricMonoidalFunctor C D) → (G ∘Fˢ F) ⇛ (H ∘Fˢ F)
    α ∘ʳ F = α ∘ₕ id {F = F}


------------------------------------------------------------------------
-- This file contains the definition the category of functors indexed --
-- by two categories.                                                 --
------------------------------------------------------------------------
module Category.CatFunc where

open import Level

open import Category.NatTrans public

CatFunc : {l₁ l₂ : Level} → Cat {l₁} → Cat {l₂} → Cat {l₁ ⊔ l₂}
CatFunc ℂ₁ ℂ₂ = record
                  { Obj = Functor ℂ₁ ℂ₂
                  ; Hom = λ F G → record { el = NatTrans F G ; eq = λ α₁ α₂ → {!!} ; eqRpf = {!!} }
                  ; comp = {!!}
                  ; id = {!!}
                  ; assocPf = {!!}
                  ; idPfCom = {!!}
                  ; idPf = {!!}
                  }


open import Relation.Binary.Core

module PLRTree.Everything {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import PLRTree.Complete.Correctness.Base {A}
open import PLRTree.Drop.Complete _≤_ tot≤
open import PLRTree.Drop.Heap _≤_ tot≤ trans≤
open import PLRTree.Drop.Permutation _≤_ tot≤
open import PLRTree.Heap.Correctness _≤_
open import PLRTree.Insert.Complete _≤_ tot≤
open import PLRTree.Insert.Heap _≤_ tot≤ trans≤
open import PLRTree.Insert.Permutation _≤_ tot≤


module AbstractInterfaces where

open import Prelude public

-- Process identifiers.

record IsProc : Set₁ where
  field
    Proc    : Set
    _≡ₚ?_   : Decidable (_≡_ {A = Proc})
    _<ₚ_    : Proc → Proc → Set
    trans<ₚ : Transitive _<ₚ_
    tri<ₚ   : Trichotomous _≡_ _<ₚ_

  _≮ₚ_ : Proc → Proc → Set
  P ≮ₚ P′ = ¬ (P <ₚ P′)

open IsProc {{…}} public

-- Process clocks, message timestamps, and event timestamps.

record IsTime : Set₁ where
  field
    Time      : Set
    _≡ₜ?_     : Decidable (_≡_ {A = Time})
    _<ₜ_      : Time → Time → Set
    trans<ₜ   : Transitive _<ₜ_
    tri<ₜ     : Trichotomous _≡_ _<ₜ_
    irrefl<ₜ  : Irreflexive _<ₜ_
    sucₜ      : Time → Time
    _⊔ₜ_      : Time → Time → Time
    n<s[n⊔m]ₜ : ∀ T T′ → T <ₜ sucₜ (T ⊔ₜ T′)

  _≮ₜ_ : Time → Time → Set
  T ≮ₜ T′ = ¬ (T <ₜ T′)

open IsTime {{…}} public

-- Messages.

record IsMsg {{_ : IsProc}} {{_ : IsTime}} : Set₁ where
  field
    Msg : (Pᵢ Pⱼ : Proc) (Tₘ : Time) → Set

open IsMsg {{…}} public

-- Events within one process.

record IsEvent {{_ : IsProc}} {{_ : IsTime}} {{_ : IsMsg}} : Set₁ where
  field
    Event   : Proc → Time → Set

    isSendₑ : ∀ {Cᵢ Pᵢ Pⱼ Tₘ} {{_ : Tₘ ≡ sucₜ Cᵢ}} →
              Msg Pᵢ Pⱼ Tₘ → Event Pᵢ Tₘ → Set

    isRecvₑ : ∀ {Cⱼ Pᵢ Pⱼ Tₘ Tⱼ} {{_ : Tⱼ ≡ sucₜ (Tₘ ⊔ₜ Cⱼ)}} →
              Msg Pᵢ Pⱼ Tₘ → Event Pⱼ Tⱼ → Set

    absurdₑ : ∀ {Cᵢ Cⱼ P T} {m : Msg P P T} {a : Event P T} →
              {{_ : T ≡ sucₜ Cᵢ}} {{_ : T ≡ sucₜ (T ⊔ₜ Cⱼ)}} →
              ¬ (isSendₑ {Cᵢ} m a × isRecvₑ {Cⱼ} m a)

open IsEvent {{…}} public


open import Relation.Nullary.Decidable using (False)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; module ≡-Reasoning)

open import Data.List using (List)
open List
open import Data.Unit using (tt)

module AKS.Binary.Base where

open import Polynomial.Simple.AlmostCommutativeRing using (AlmostCommutativeRing)
open import Polynomial.Simple.AlmostCommutativeRing.Instances using (module Nat)
open Nat.Reflection using (∀⟨_⟩)

open import AKS.Nat using (ℕ; _+_; _*_; _≟_; _<_; lte; suc-mono-≤)
open ℕ
open import AKS.Nat using (ℕ⁺; ℕ+; ⟅_⇑⟆)
open import AKS.Nat using (Euclidean; Euclidean✓; _div_)
open import AKS.Nat using (Acc; acc; <-well-founded)

2* : ℕ → ℕ
2* n = n + n

infixl 5 _0ᵇ _1ᵇ
data 𝔹⁺ : Set where
  𝕓1ᵇ : 𝔹⁺
  _0ᵇ _1ᵇ : 𝔹⁺ → 𝔹⁺

infixr 4 +_
data 𝔹 : Set where
  𝕓0ᵇ : 𝔹
  +_ : 𝔹⁺ → 𝔹

⟦_⇓⟧⁺ : 𝔹⁺ → ℕ
⟦ 𝕓1ᵇ  ⇓⟧⁺ = 1
⟦ x 0ᵇ ⇓⟧⁺ = 2* ⟦ x ⇓⟧⁺
⟦ x 1ᵇ ⇓⟧⁺ = 1 + 2* ⟦ x ⇓⟧⁺

⟦_⇓⟧ : 𝔹 → ℕ
⟦ 𝕓0ᵇ ⇓⟧ = 0
⟦ + x ⇓⟧ = ⟦ x ⇓⟧⁺

private
  lemma₁ : ∀ {q} → suc q < suc (q + suc (q + zero))
  lemma₁ {q} = lte q (∀⟨ q ∷ [] ⟩)
  lemma₂ : ∀ {q} → suc q < suc (suc (q + suc (q + zero)))
  lemma₂ {q} = lte (suc q) (∀⟨ q ∷ [] ⟩)

⟦_⇑_⟧ʰ : ∀ n → Acc _<_ n → ∀ {≢0 : False (n ≟ 0)} → 𝔹⁺
⟦ suc n ⇑ acc downward ⟧ʰ with suc n div 2
... | Euclidean✓ (suc q) 0 refl r<m = ⟦ suc q ⇑ downward lemma₁ ⟧ʰ 0ᵇ
... | Euclidean✓ zero 1 refl r<m = 𝕓1ᵇ
... | Euclidean✓ (suc q) 1 refl r<m = ⟦ suc q ⇑ downward lemma₂ ⟧ʰ 1ᵇ

⟦_⇑⟧⁺ : ℕ⁺ → 𝔹⁺
⟦ ℕ+ n ⇑⟧⁺ = ⟦ suc n ⇑ <-well-founded ⟧ʰ

⟦_⇑⟧ : ℕ → 𝔹
⟦ zero ⇑⟧ = 𝕓0ᵇ
⟦ suc n ⇑⟧ = + ⟦ ℕ+ n ⇑⟧⁺

ℕ→𝔹→ℕ : ∀ n → ⟦ ⟦ n ⇑⟧ ⇓⟧ ≡ n
ℕ→𝔹→ℕ zero = refl
ℕ→𝔹→ℕ (suc n) = ℕ⁺→𝔹⁺→ℕ (suc n) <-well-founded
  where
  ℕ⁺→𝔹⁺→ℕ : ∀ (n : ℕ) (rec : Acc _<_ n) {≢0 : False (n ≟ 0)} → ⟦ ⟦ n ⇑ rec ⟧ʰ {≢0} ⇓⟧⁺ ≡ n
  ℕ⁺→𝔹⁺→ℕ (suc n) (acc downward) with suc n div 2
  ... | Euclidean✓ (suc q) 0 refl r<m rewrite ℕ⁺→𝔹⁺→ℕ (suc q) (downward lemma₁) {tt} = ∀⟨ q ∷ [] ⟩
  ... | Euclidean✓ zero 1 refl r<m = refl
  ... | Euclidean✓ (suc q) 1 refl r<m rewrite ℕ⁺→𝔹⁺→ℕ (suc q) (downward lemma₂) {tt} = ∀⟨ q ∷ [] ⟩

⌈log₂_⌉⁺ : 𝔹⁺ → ℕ
⌈log₂ 𝕓1ᵇ ⌉⁺ = 1
⌈log₂ (b 0ᵇ) ⌉⁺ = 1 + ⌈log₂ b ⌉⁺
⌈log₂ (b 1ᵇ) ⌉⁺ = 1 + ⌈log₂ b ⌉⁺

⌈log₂_⌉ : 𝔹 → ℕ
⌈log₂ 𝕓0ᵇ ⌉ = 0
⌈log₂ + b ⌉ = ⌈log₂ b ⌉⁺

⌊_/2⌋⁺ : 𝔹⁺ → 𝔹⁺
⌊ 𝕓1ᵇ /2⌋⁺ = 𝕓1ᵇ
⌊ b 0ᵇ /2⌋⁺ = b
⌊ b 1ᵇ /2⌋⁺ = b

⌊_/2⌋ : 𝔹 → 𝔹
⌊ 𝕓0ᵇ /2⌋ = 𝕓0ᵇ
⌊ + b /2⌋ = + ⌊ b /2⌋⁺

-- _+ᵇ_ : 𝔹 → 𝔹 → 𝔹
-- n +ᵇ m = ⟦ ⟦ n ⇓⟧ + ⟦ m ⇓⟧ ⇑⟧

-- -- data Bit : Set where
-- --   0𝑏 : Bit
-- --   1𝑏 : Bit

-- -- _+ᵇ⁺_ : 𝔹⁺ → 𝔹⁺ → 𝔹⁺
-- -- n +ᵇ⁺ m = ⟦ ⟦ n ⇓⟧⁺ ⇑⟧⁺
--   -- where
--   -- loop : Bit → 𝔹⁺ → 𝔹⁺ → 𝔹⁺
--   -- loop carry x y = ?

-- -- unique⁺ : ∀ x y → ⟦ x ⇓⟧⁺ ≡ ⟦ y ⇓⟧⁺ → x ≡ y
-- -- unique⁺ 1ᵇ 1ᵇ p = refl
-- -- unique⁺ 1ᵇ (y 0ᵇ) p = {!!}
-- -- unique⁺ 1ᵇ (y 1ᵇ) p = {!!}
-- -- unique⁺ (x 0ᵇ) 1ᵇ p = {!!}
-- -- unique⁺ (x 0ᵇ) (y 0ᵇ) p = {!!}
-- -- unique⁺ (x 0ᵇ) (y 1ᵇ) p = {!!}
-- -- unique⁺ (x 1ᵇ) y p = {!!}

-- -- unique : ∀ x y → ⟦ x ⇓⟧ ≡ ⟦ y ⇓⟧ → x ≡ y
-- -- unique 𝕓0ᵇ 𝕓0ᵇ p = refl
-- -- unique 𝕓0ᵇ (𝕓 y) p = {!!}
-- -- unique (𝕓 x) 𝕓0ᵇ p = {!!}
-- -- unique (𝕓 x) (𝕓 y) p = {!!}

module Test where
  eval-unit₁ : ⟦ + 𝕓1ᵇ 0ᵇ 1ᵇ 0ᵇ ⇓⟧ ≡ 10
  eval-unit₁ = refl

  log-unit₁ : ⌈log₂ ⟦ 15 ⇑⟧ ⌉ ≡ 4
  log-unit₁ = refl


{-# OPTIONS --cubical-compatible #-}
open import Common.Prelude
open import Common.Equality

KNat : {x : Nat} (e : x ≡ x) → e ≡ refl
KNat refl = refl

KEqNat : {x : Nat} {e : x ≡ x} (p : e ≡ e) → p ≡ refl
KEqNat refl = refl

KListNat : {x : List Nat} (e : x ≡ x) → e ≡ refl
KListNat refl = refl

data D (A : Set) : Nat → Set where
  c : (x : A)(y : Nat) → D A y

-- Jesper 2015-12-18: this test case doesn't work yet with the new unifier
-- We need generalization of indices when applying the injectivity rule
--test : {A : Set} {x₁ x₂ : A} {y : Nat} → c x₁ y ≡ c x₂ y → Set
--test refl = Nat


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

open import Size
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

open import Algebra.Structures using (IsCommutativeSemiring; IsCommutativeMonoid)

open import Data.Nat
open import Data.Nat.Properties using (isCommutativeSemiring)
open import Stream
open ∼ˢ∞-Reasoning

⟦_⟧ : ℕ → Str ℕ
hd (⟦ n ⟧) = n
tl (⟦ n ⟧) = ⟦ 0 ⟧

_⊕_ : ∀{i} → Str {i} ℕ → Str {i} ℕ → Str {i} ℕ
hd (s ⊕ t) = (hd s) + (hd t)
tl (s ⊕ t) = (tl s) ⊕ (tl t)

_×_ : ∀{i} → Str {i} ℕ → Str {i} ℕ → Str {i} ℕ
hd (s × t) = hd s * hd t
tl (s × t)= ((tl s) × t) ⊕ (⟦ hd s ⟧ × (tl t))

comm-* : ∀ m n → m * n ≡ n * m
comm-* = IsCommutativeMonoid.comm
         (IsCommutativeSemiring.*-isCommutativeMonoid isCommutativeSemiring)

comm-+ : ∀ m n → m + n ≡ n + m
comm-+ = IsCommutativeMonoid.comm
         (IsCommutativeSemiring.+-isCommutativeMonoid isCommutativeSemiring)

Bisim = _∼ˢ_

{-
mutual
  comm-× : ∀{i} →
           (s t : Str {i} ℕ) → Bisim {ℕ} {i} (s × t) (t × s)
  hd≡ (comm-× s t) = comm-* (hd s) (hd t)
  tl∼ (comm-× s t) = lem-comm-× s t

  lem-comm-× : ∀{i} → ∀{j : Size< i} →
               (s t : Str {i} ℕ) →
               Bisim {ℕ} {j}
                 ((tl s × t) ⊕ (⟦ hd s ⟧ × tl t))
                 ((tl t × s) ⊕ (⟦ hd t ⟧ × tl s))
  hd≡ (lem-comm-× {i} {j} s t) =
    begin
      hd s' * hd t + hd s * hd t'
    ≡⟨ comm-+ (hd s' * hd t) (hd s * hd t') ⟩
      hd s * hd t' + hd s' * hd t
    ≡⟨ cong (λ x → x + hd s' * hd t) (comm-* (hd s) (hd t')) ⟩
      hd t' * hd s + hd s' * hd t
    ≡⟨ cong (λ x → hd t' * hd s + x) (comm-* (hd s') (hd t)) ⟩
      hd t' * hd s + hd t * hd s'
    ∎
    where
      s' = tl s {j}
      t' = tl t {j}

  tl∼ (lem-comm-× {i} {j} s t) {k} = lem {k}
    where
      s' = tl s {j}
      t' = tl t {j}

      lem : ∀{k : Size< j} → Bisim {ℕ} {k}
        (((tl s' × t) ⊕ (⟦ hd s' ⟧ × t')) ⊕ ((⟦ 0 ⟧ × t') ⊕ (⟦ hd s ⟧ × tl t')))
        (((tl t' × s) ⊕ (⟦ hd t' ⟧ × s')) ⊕ ((⟦ 0 ⟧ × s') ⊕ (⟦ hd t ⟧ × tl s')))
      lem = {!!}
        where
          s'' = tl s' {k}
          t'' = tl t' {k}
-}

zero-⊕-unit-l : (s : Str ℕ) → (⟦ 0 ⟧ ⊕ s) ∼ˢ∞ s
hd≡∞ (zero-⊕-unit-l s) = refl
tl∼∞ (zero-⊕-unit-l s) = zero-⊕-unit-l (tl s)

zero-⊕-unit-r : (s : Str ℕ) → (s ⊕ ⟦ 0 ⟧) ∼ˢ∞ s
hd≡∞ (zero-⊕-unit-r s) = comm-+ (hd s) 0
tl∼∞ (zero-⊕-unit-r s) = zero-⊕-unit-r (tl s)

zero-×-annihil-l : (s : Str ℕ) → (⟦ 0 ⟧ × s) ∼ˢ∞ ⟦ 0 ⟧
hd≡∞ (zero-×-annihil-l s) = refl
tl∼∞ (zero-×-annihil-l s) =
  beginˢ∞
    tl (⟦ 0 ⟧ × s)
  ∼ˢ∞⟨ s-bisim∞-refl ⟩
    (⟦ 0 ⟧ × s) ⊕ (⟦ 0 ⟧ × tl s)
  ∼ˢ∞⟨ {!!} ⟩
    tl (⟦ 0 ⟧)
  ∎ˢ∞

mutual
  comm-× : (s t : Str ℕ) → (s × t) ∼ˢ∞ (t × s)
  hd≡∞ (comm-× s t) = comm-* (hd s) (hd t)
  tl∼∞ (comm-× s t) = lem-comm-× s t

  lem-comm-× : (s t : Str ℕ) →
               ((tl s × t) ⊕ (⟦ hd s ⟧ × tl t))
               ∼ˢ∞ ((tl t × s) ⊕ (⟦ hd t ⟧ × tl s))
  hd≡∞ (lem-comm-× s t) =
    begin
      hd s' * hd t + hd s * hd t'
    ≡⟨ comm-+ (hd s' * hd t) (hd s * hd t') ⟩
      hd s * hd t' + hd s' * hd t
    ≡⟨ cong (λ x → x + hd s' * hd t) (comm-* (hd s) (hd t')) ⟩
      hd t' * hd s + hd s' * hd t
    ≡⟨ cong (λ x → hd t' * hd s + x) (comm-* (hd s') (hd t)) ⟩
      hd t' * hd s + hd t * hd s'
    ∎
    where
      s' = tl s
      t' = tl t

  tl∼∞ (lem-comm-× s t) = lem
    where
      s' = tl s
      t' = tl t

      lem :
        (((tl s' × t) ⊕ (⟦ hd s' ⟧ × t')) ⊕ ((⟦ 0 ⟧ × t') ⊕ (⟦ hd s ⟧ × tl t')))
        ∼ˢ∞ (((tl t' × s) ⊕ (⟦ hd t' ⟧ × s')) ⊕ ((⟦ 0 ⟧ × s') ⊕ (⟦ hd t ⟧ × tl s')))
      lem = {!!}
        where
          s'' = tl s'
          t'' = tl t'


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

open import LogicalFormulae
open import Orders.Total.Definition
open import Orders.Partial.Definition
open import Setoids.Setoids
open import Functions

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

module Setoids.Orders where

partialOrderToSetoidPartialOrder : {a b : _} {A : Set a} (P : PartialOrder {a} A {b}) → SetoidPartialOrder (reflSetoid A) (PartialOrder._<_ P)
SetoidPartialOrder.<WellDefined (partialOrderToSetoidPartialOrder P) a=b c=d a<c rewrite a=b | c=d = a<c
SetoidPartialOrder.irreflexive (partialOrderToSetoidPartialOrder P) = PartialOrder.irreflexive P
SetoidPartialOrder.<Transitive (partialOrderToSetoidPartialOrder P) = PartialOrder.<Transitive P

totalOrderToSetoidTotalOrder : {a b : _} {A : Set a} (T : TotalOrder {a} A {b}) → SetoidTotalOrder (partialOrderToSetoidPartialOrder (TotalOrder.order T))
SetoidTotalOrder.totality (totalOrderToSetoidTotalOrder T) = TotalOrder.totality T


open import Categories
open import Functors
import RMonads

module RMonads.RKleisli
  {a b c d}
  {C : Cat {a}{b}}
  {D : Cat {c}{d}}
  {J : Fun C D}
  (M : RMonads.RMonad J) where

open import Library
open RMonads.RMonad M
open Cat
open Fun

Kl : Cat
Kl = record{
  Obj  = Obj C;
  Hom  = λ X Y → Hom D (OMap J X) (T Y);
  iden = η;
  comp = λ f g → comp D (bind f) g;
  idl  = λ{X}{Y}{f} →
    proof
    comp D (bind η) f
    ≅⟨ cong (λ g → comp D g f) law1 ⟩
    comp D (iden D) f
    ≅⟨ idl D ⟩
    f
    ∎;
  idr  = law2;
  ass  =  λ{_ _ _ _ f g h} →
    proof
    comp D (bind (comp D (bind f) g)) h
    ≅⟨ cong (λ f → comp D f h) law3 ⟩
    comp D (comp D (bind f) (bind g)) h
    ≅⟨ ass D ⟩
    comp D (bind f) (comp D (bind g) h)
    ∎}


import      Structure.Logic.Classical.NaturalDeduction
-- TODO: Seems like Constructive does not work, but why?

module Structure.Logic.Constructive.Syntax.Algebra {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicalLogic : _ ⦄ where
open Structure.Logic.Classical.NaturalDeduction.ClassicalLogic {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (classicalLogic)

import      Lvl
open import Syntax.Function
open import Type

-- Transitivitity through an operation on proofs
record Transitivable{ℓ}{T : Type{ℓ}}(_▫_ : T → T → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₒ Lvl.⊔ ℓ} where
  field
    _🝖_ : ∀{a b c} → Proof(a ▫ b) → Proof(b ▫ c) → Proof(a ▫ c)
open Transitivable ⦃ ... ⦄ public

Transitivity-to-Transitivable : ∀{_▫_ : Domain → Domain → Formula} → Proof(∀ₗ(a ↦ ∀ₗ(b ↦ ∀ₗ(c ↦ (a ▫ b)∧(b ▫ c) ⟶ (a ▫ c))))) → Transitivable(_▫_)
_🝖_ ⦃ Transitivity-to-Transitivable proof ⦄ {a}{b}{c} ab bc =
  ([→].elim
    ([∀].elim ([∀].elim ([∀].elim proof {a}){b}){c})
    ([∧].intro ab bc)
  )

instance
  [⟶]-transitivable : Transitivable(_⟶_)
  _🝖_ ⦃ [⟶]-transitivable ⦄ = [→].transitivity

instance
  [⟷]-transitivable : Transitivable(_⟷_)
  _🝖_ ⦃ [⟷]-transitivable ⦄ = [↔].transitivity


{-# OPTIONS --allow-unsolved-metas #-}

record ⊤ : Set where
  constructor tt

data I : Set where
  i : ⊤ → I

data D : I → Set where
  d : D (i tt)

postulate
  P : (x : I) → D x → Set

foo : (y : _) → P _ y
foo d = {!!}


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

module Container.Fixpoint where

open import Container
open import Prelude

data μ {s p} (C : Container s p) : Type (s ℓ⊔ p) where
  sup : ⟦ C ⟧ (μ C) → μ C

record ν {s p} (C : Container s p) : Type (s ℓ⊔ p) where
  coinductive
  field inf : ⟦ C ⟧ (ν C)
open ν public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bounded vectors
------------------------------------------------------------------------

-- Vectors of a specified maximum length.

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

module Data.BoundedVec where

open import Data.Nat
open import Data.List.Base as List using (List)
open import Data.Vec as Vec using (Vec)
import Data.BoundedVec.Inefficient as Ineff
open import Relation.Binary.PropositionalEquality
open import Data.Nat.Solver
open +-*-Solver

------------------------------------------------------------------------
-- The type

abstract

  data BoundedVec {a} (A : Set a) : ℕ → Set a where
    bVec : ∀ {m n} (xs : Vec A n) → BoundedVec A (n + m)

  [] : ∀ {a n} {A : Set a} → BoundedVec A n
  [] = bVec Vec.[]

  infixr 5 _∷_

  _∷_ : ∀ {a n} {A : Set a} →
        A → BoundedVec A n → BoundedVec A (suc n)
  x ∷ bVec xs = bVec (Vec._∷_ x xs)

------------------------------------------------------------------------
-- Pattern matching

infixr 5 _∷v_

data View {a} (A : Set a) : ℕ → Set a where
  []v  : ∀ {n} → View A n
  _∷v_ : ∀ {n} (x : A) (xs : BoundedVec A n) → View A (suc n)

abstract

  view : ∀ {a n} {A : Set a} → BoundedVec A n → View A n
  view (bVec Vec.[])         = []v
  view (bVec (Vec._∷_ x xs)) = x ∷v bVec xs

------------------------------------------------------------------------
-- Increasing the bound

abstract

  ↑ : ∀ {a n} {A : Set a} → BoundedVec A n → BoundedVec A (suc n)
  ↑ {A = A} (bVec {m = m} {n = n} xs) =
    subst (BoundedVec A) lemma
            (bVec {m = suc m} xs)
    where
    lemma : n + (1 + m) ≡ 1 + (n + m)
    lemma = solve 2 (λ m n → n :+ (con 1 :+ m)  :=  con 1 :+ (n :+ m))
                    refl m n

------------------------------------------------------------------------
-- Conversions

module _ {a} {A : Set a} where

 abstract

  fromList : (xs : List A) → BoundedVec A (List.length xs)
  fromList xs =
    subst (BoundedVec A) lemma
            (bVec {m = zero} (Vec.fromList xs))
    where
    lemma : List.length xs + 0 ≡ List.length xs
    lemma = solve 1 (λ m → m :+ con 0  :=  m) refl _

  toList : ∀ {n} → BoundedVec A n → List A
  toList (bVec xs) = Vec.toList xs

  toInefficient : ∀ {n} → BoundedVec A n → Ineff.BoundedVec A n
  toInefficient xs with view xs
  ... | []v     = Ineff.[]
  ... | y ∷v ys = y Ineff.∷ toInefficient ys

  fromInefficient : ∀ {n} → Ineff.BoundedVec A n → BoundedVec A n
  fromInefficient Ineff.[]       = []
  fromInefficient (x Ineff.∷ xs) = x ∷ fromInefficient xs


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module BBHeap.Height.Log {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_ ) where

open import BBHeap _≤_ hiding (#)
open import BBHeap.Height _≤_
open import BBHeap.Properties _≤_
open import Bound.Lower A
open import Data.Sum renaming (_⊎_ to _∨_)
open import SNat
open import SNat.Log
open import SNat.Order
open import SNat.Order.Properties
open import SNat.Properties
open import SNat.Sum
open import Relation.Binary.PropositionalEquality

lemma-height-≃ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ≃ r → height l ≡ height r
lemma-height-≃ ≃lf = refl
lemma-height-≃ (≃nd _ _ _ _ _ _ l≃l') rewrite lemma-height-≃ l≃l' = refl

lemma-height'-≃ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ≃ r → height' l ≡ height' r
lemma-height'-≃ ≃lf = refl
lemma-height'-≃ (≃nd _ _ _ _ l≃r l'≃r' l≃l') rewrite lemma-height'-≃ (trans≃ (trans≃ (sym≃ l≃r) l≃l') l'≃r') = refl

lemma-height-height'-⋗ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋗ r → height l ≡ succ (height' r)
lemma-height-height'-⋗ (⋗lf _) = refl
lemma-height-height'-⋗ (⋗nd _ _ _ _ _ l'≃r' l⋗l') rewrite lemma-height-height'-⋗ l⋗l' | lemma-height'-≃ l'≃r' = refl

lemma-height-height'-⋘ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋘ r → height l ≡ height' r ∨ height l ≡ succ (height' r)
lemma-height-height'-⋘ lf⋘ = inj₁ refl
lemma-height-height'-⋘ (ll⋘ _ _ l⋘r _ l'≃r' r≃l')
    with lemma-height-height'-⋘ l⋘r
... | inj₁ hl≡h'r rewrite hl≡h'r | lemma-height'-≃ (trans≃ r≃l' l'≃r') = inj₁ refl
... | inj₂ hl≡h'r+1 rewrite hl≡h'r+1 | lemma-height'-≃ (trans≃ r≃l' l'≃r') = inj₂ refl
lemma-height-height'-⋘ (lr⋘ _ _ _  _ l'≃r' l⋗l') rewrite lemma-height-height'-⋗ (lemma⋗≃ l⋗l' l'≃r')= inj₂ refl

lemma-height-height'-⋙ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋙ r → height l ≡ height' r ∨ height l ≡ succ (height' r)
lemma-height-height'-⋙ (⋙lf _) = inj₂ refl
lemma-height-height'-⋙ (⋙rl _ _ _ _ _ l⋗r')  rewrite lemma-height-height'-⋗ l⋗r' = inj₂ refl
lemma-height-height'-⋙ (⋙rr _ _ _ _ l'⋙r' l≃l')
    with lemma-height-height'-⋙ l'⋙r'
... | inj₁ hl'≡h'r' rewrite lemma-height-≃ l≃l' | hl'≡h'r' = inj₁ refl
... | inj₂ hl'≡h'r'+1  rewrite lemma-height-≃ l≃l' | hl'≡h'r'+1 = inj₂ refl

lemma-height-height' : {b : Bound}(h : BBHeap b) → height h ≡ height' h ∨ height h ≡ succ (height' h)
lemma-height-height' leaf = inj₁ refl
lemma-height-height' (left _ l⋘r)
    with lemma-height-height'-⋘ l⋘r
... | inj₁ hl≡h'r rewrite hl≡h'r = inj₁ refl
... | inj₂ hl≡h'r+1 rewrite hl≡h'r+1 = inj₂ refl
lemma-height-height' (right _ l⋙r)
    with lemma-height-height'-⋙ l⋙r
... | inj₁ hl≡h'r rewrite hl≡h'r = inj₁ refl
... | inj₂ hl≡h'r+1 rewrite hl≡h'r+1 = inj₂ refl

lemma-#-≃ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ≃ r → # l ≡ # r
lemma-#-≃ ≃lf = refl
lemma-#-≃ (≃nd _ _ _ _ l≃r l'≃r' l≃l')
                   rewrite lemma-#-≃ (sym≃ l≃r)
                            | lemma-#-≃ l≃l'
                            | lemma-#-≃ l'≃r' = refl

lemma-#-⋗ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋗ r → # l ≡ succ (# r + # r)
lemma-#-⋗ (⋗lf _) = refl
lemma-#-⋗ (⋗nd _ _ _ _ l≃r l'≃r' l⋗l')
                   rewrite  lemma-#-≃ (sym≃ l≃r)
                            | lemma-#-⋗ l⋗l'
                            | lemma-#-≃ l'≃r' = refl

lemma-⋘-# : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋘ r → # r ≤′ # l
lemma-⋘-# lf⋘ = refl≤′
lemma-⋘-# (ll⋘ {r' = r'} _ _ l⋘r _ l'≃r' r≃l')
                   rewrite lemma-#-≃ r≃l'
                             | lemma-#-≃ l'≃r' = lemma-s≤′s (+-right-monotony-≤′ (# r') (lemma-≡-≤′ (lemma-#-≃ (sym≃ (trans≃ r≃l' l'≃r'))) (lemma-⋘-# l⋘r)))
lemma-⋘-# (lr⋘ {r = r} {r' = r'} _ _ _ _ l'≃r' l⋗l')
                   rewrite lemma-#-⋗ l⋗l'
                             | lemma-#-≃ l'≃r' = lemma-s≤′s (≤′-step (lemma-m≤′m+n (# r' + # r') (# r)))

lemma-#-⋙ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋙ r → # l ≤′ succ (# r + # r)
lemma-#-⋙ (⋙lf _) = refl≤′
lemma-#-⋙ (⋙rl {l' = l'}{r' = r'} _ _ _ l≃r l'⋘r' l⋗r')
                   rewrite lemma-#-≃ (sym≃ l≃r)
                             | lemma-#-⋗ l⋗r'
                             | +-assoc-succ (# r' + # r') (# r' + # r')
                             | +-assoc-succ (# l' + # r') (# l' + # r') = lemma-s≤′s (lemma-s≤′s (lemma-s≤′s (lemma-4m≤′n+m+n+m (lemma-⋘-# l'⋘r'))))
lemma-#-⋙ (⋙rr {l' = l'} {r' = r'} _ _ _ l≃r _ l≃l')
                   rewrite lemma-#-≃ (sym≃ l≃r)
                             | lemma-#-≃ l≃l'
                             | +-assoc-succ (# l' + # r') (# l' + # r') = lemma-s≤′s (≤′-step (≤′-step (lemma-2m≤′m+n+m+n (# l') (# r'))))

mutual
  lemma-⋙-# : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋙ r → # r ≤′ # l
  lemma-⋙-# (⋙lf _) = ≤′-step refl≤′
  lemma-⋙-# (⋙rl {r' = r'} _ _ _ l≃r l'⋘r' l⋗r')
                   rewrite lemma-#-≃ (sym≃ l≃r)
                             | lemma-#-⋗ l⋗r' = lemma-s≤′s (trans≤′ (+-right-monotony-≤′ (# r') (lemma-#-⋘ l'⋘r')) (lemma-s≤′s (+-left-monotony-≤′ (# r' + # r') (≤′-step (lemma-n≤′2n (# r'))))))
  lemma-⋙-# (⋙rr {l' = l'} {r' = r'} _ _ _ l≃r l'⋙r' l≃l')
                   rewrite lemma-#-≃ (sym≃ l≃r)
                             | lemma-#-≃ l≃l'
                             | +-comm (# l') (# r') = lemma-s≤′s (+-right-monotony-≤′ (# l') (lemma-⋙-# l'⋙r'))

  lemma-#-⋘ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋘ r → # l ≤′ succ (# r + # r)
  lemma-#-⋘ lf⋘ = ≤′-step refl≤′
  lemma-#-⋘ (ll⋘ {r = r} _ _ l⋘r _ l'≃r' r≃l')
                   rewrite lemma-#-≃ (sym≃ l'≃r')
                             | lemma-#-≃ (sym≃ r≃l')
                             | +-assoc-succ (# r + # r) (# r + # r)
                             | +-assoc-left (# r + # r) (# r) (# r) = lemma-s≤′s (≤′-step (trans≤′ (+-right-monotony-≤′ (# r) (lemma-#-⋘ l⋘r)) (lemma-s≤′s (lemma-m≤′m+n ((# r + # r) + # r) (# r)))))
  lemma-#-⋘ (lr⋘ {r' = r'} _ _ l⋙r _ l'≃r' l⋗l')
                   rewrite lemma-#-⋗ l⋗l'
                             | lemma-#-≃ l'≃r' = lemma-s≤′s (lemma-s≤′s (+-left-monotony-≤′ (# r' + # r') (trans≤′ (lemma-⋙-# l⋙r) (lemma-≡-≤′ (lemma-#-⋗ (lemma⋗≃ l⋗l' l'≃r')) refl≤′))))

lemma-#-#' : {b : Bound}(h : BBHeap b) → #' h ≤′ # h
lemma-#-#' leaf = refl≤′
lemma-#-#' (left {r = r} _ l⋘r) = lemma-s≤′s (trans≤′ (lemma-2m≤′2n (lemma-#-#' r)) (+-right-monotony-≤′ (# r) (lemma-⋘-# l⋘r)))
lemma-#-#' (right {r = r} _ l⋙r) = lemma-s≤′s (trans≤′ (lemma-2m≤′2n (lemma-#-#' r)) (+-right-monotony-≤′ (# r) (lemma-⋙-# l⋙r)))

lemma-height'-#' : {b : Bound}(h : BBHeap b) → height' h ≤′ log₂ (#' h + #' h)
lemma-height'-#' leaf = refl≤′
lemma-height'-#' (left {r = r} _ _) = trans≤′ (lemma-s≤′s (trans≤′ (lemma-height'-#' r) (lemma-≤′-log (≤′-step (refl≤′ {#' r + #' r}))))) (lemma-1+logn≤′log2n (#' r + #' r))
lemma-height'-#' (right {r = r} _ _) = trans≤′ (lemma-s≤′s (trans≤′ (lemma-height'-#' r) (lemma-≤′-log (≤′-step (refl≤′ {#' r + #' r}))))) (lemma-1+logn≤′log2n (#' r + #' r))

lemma-height'-# : {b : Bound}(h : BBHeap b) → height' h ≤′ succ (log₂ (# h))
lemma-height'-# h = trans≤′ (trans≤′ (lemma-height'-#' h) (lemma-log2n≤′1+logn (#' h))) (lemma-s≤′s (lemma-≤′-log (lemma-#-#' h)))

theorem-height-# : {b : Bound}(h : BBHeap b) → height h ≤′ succ (succ (log₂ (# h)))
theorem-height-# h
    with lemma-height-height' h
... | inj₁ hh≡h'h rewrite hh≡h'h = ≤′-step (lemma-height'-# h)
... | inj₂  hh≡h'h+1 rewrite hh≡h'h+1 = lemma-s≤′s (lemma-height'-# h)


module Spire.Operational where

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

data Level : Set where
  zero : Level
  suc : Level → Level

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

data Context : Set
data Type (Γ : Context) : Set
data Value (Γ : Context) : Type Γ → Set
data Neutral (Γ : Context) : Type Γ → Set

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

data Context where
  ∅ : Context
  _,_ : (Γ : Context) → Type Γ → Context

data Type Γ where
  `⊥ `⊤ `Bool : Type Γ
  `Desc `Type : (ℓ : Level) → Type Γ
  `Π `Σ : (A : Type Γ) (B : Type (Γ , A)) → Type Γ
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Type Γ
  `⟦_⟧ : ∀{ℓ} → Neutral Γ (`Type ℓ) → Type Γ
  `⟦_⟧ᵈ : ∀{ℓ} → Neutral Γ (`Desc ℓ) → Type Γ → Type Γ

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

⟦_⟧ : ∀{Γ ℓ} → Value Γ (`Type ℓ) →  Type Γ
⟦_⟧ᵈ : ∀{Γ ℓ} → Value Γ (`Desc ℓ) → Type Γ →  Type Γ

postulate
  wknT : ∀{Γ A} → Type Γ → Type (Γ , A)
  subT : ∀{Γ A} → Type (Γ , A) → Value Γ A → Type Γ
  subV : ∀{Γ A B} → Value (Γ , A) B → (x : Value Γ A) → Value Γ (subT B x)

data Var : (Γ : Context) (A : Type Γ) → Set where
  here : ∀{Γ A} → Var (Γ , A) (wknT A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (wknT A)

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

data Value Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Desc `Type : ∀{ℓ} → Value Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Value Γ (`Type ℓ)) (B : Value (Γ , ⟦ A ⟧) (`Type ℓ)) → Value Γ (`Type ℓ)
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Value Γ (`Type ℓ) → Value Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ) → Value Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Value Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Value Γ (`Type ℓ))
    (B : Value (Γ , ⟦ A ⟧) (`Desc (suc ℓ)))
    → Value Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Value Γ (⟦ D ⟧ᵈ (`μ D)) → Value Γ (`μ D)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

data Neutral Γ where
  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Neutral Γ A
  `if_`then_`else_ : ∀{C} (b : Neutral Γ `Bool) (c₁ c₂ : Value Γ C) → Neutral Γ C
  `elim⊥ : ∀{A} → Neutral Γ `⊥ → Neutral Γ A
  `elimBool : ∀{ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
    (pt : Value Γ (subT ⟦ P ⟧ `true))
    (pf : Value Γ (subT ⟦ P ⟧ `false))
    (b : Neutral Γ `Bool) → Neutral Γ (subT ⟦ P ⟧ (`neut b))
  `proj₁ : ∀{A B} → Neutral Γ (`Σ A B) → Neutral Γ A
  `proj₂ : ∀{A B} (ab : Neutral Γ (`Σ A B)) → Neutral Γ (subT B (`neut (`proj₁ ab)))
  _`$_ : ∀{A B} (f : Neutral Γ (`Π A B)) (a : Value Γ A) → Neutral Γ (subT B a)
  `des : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Neutral Γ (`μ D) → Neutral Γ (⟦ D ⟧ᵈ (`μ D))

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `μ D ⟧ = `μ D
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `Desc {ℓ} ⟧ = `Desc ℓ
⟦ `⟦ D ⟧ᵈ X ⟧ = ⟦ D ⟧ᵈ ⟦ X ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

⟦ `⊤ᵈ ⟧ᵈ X = `⊤
⟦ `Xᵈ ⟧ᵈ X = X
⟦ `Πᵈ A D ⟧ᵈ X = `Π ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `Σᵈ A D ⟧ᵈ X = `Σ ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `neut D ⟧ᵈ X = `⟦ D ⟧ᵈ X

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

elim⊥ : ∀{Γ A} → Value Γ `⊥ → Value Γ A
elim⊥ (`neut bot) = `neut (`elim⊥ bot)

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

if_then_else_ : ∀{Γ C} (b : Value Γ `Bool) (c₁ c₂ : Value Γ C) → Value Γ C
if `true then c₁ else c₂ = c₁
if `false then c₁ else c₂ = c₂
if `neut b then c₁ else c₂ = `neut (`if b `then c₁ `else c₂)

elimBool : ∀{Γ ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
  (pt : Value Γ (subT ⟦ P ⟧ `true))
  (pf : Value Γ (subT ⟦ P ⟧ `false))
  (b : Value Γ `Bool)
  → Value Γ (subT ⟦ P ⟧ b)
elimBool P pt pf `true = pt
elimBool P pt pf `false = pf
elimBool P pt pf (`neut b) = `neut (`elimBool P pt pf b)

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

proj₁ : ∀{Γ A B} → Value Γ (`Σ A B) → Value Γ A
proj₁ (a `, b) = a
proj₁ (`neut ab) = `neut (`proj₁ ab)

proj₂ : ∀{Γ A B} (ab : Value Γ (`Σ A B)) → Value Γ (subT B (proj₁ ab))
proj₂ (a `, b) = b
proj₂ (`neut ab) = `neut (`proj₂ ab)

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

des : ∀{Γ ℓ} {D : Value Γ (`Desc ℓ)} → Value Γ (`μ D) → Value Γ (⟦ D ⟧ᵈ (`μ D))
des (`con x) = x
des (`neut x) = `neut (`des x)

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

_$_ : ∀{Γ A B} → Value Γ (`Π A B) → (a : Value Γ A) → Value Γ (subT B a)
`λ b $ a = subV b a
`neut f $ a = `neut (f `$ a)

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

data Term (Γ : Context) : Type Γ → Set
eval : ∀{Γ A} → Term Γ A → Value Γ A

data Term Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Term Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Term Γ (`Type ℓ)) (B : Term (Γ , ⟦ eval A ⟧) (`Type ℓ)) → Term Γ (`Type ℓ)
  `μ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Term Γ (`Type ℓ) → Term Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ) → Term Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Term Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Term Γ (`Type ℓ))
    (D : Term (Γ , ⟦ eval A ⟧) (`Desc (suc ℓ)))
    → Term Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)
  `λ : ∀{A B}
    (b : Term (Γ , A) B)
    → Term Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Term Γ (⟦ D ⟧ᵈ (`μ D)) → Term Γ (`μ D)

  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Term Γ A
  `if_`then_`else_ : ∀{C}
    (b : Term Γ `Bool)
    (c₁ c₂ : Term Γ C)
    → Term Γ C
  _`$_ : ∀{A B} (f : Term Γ (`Π A B)) (a : Term Γ A) → Term Γ (subT B (eval a))
  `proj₁ : ∀{A B} → Term Γ (`Σ A B) → Term Γ A
  `proj₂ : ∀{A B} (ab : Term Γ (`Σ A B)) → Term Γ (subT B (proj₁ (eval ab)))
  `elim⊥ : ∀{A} → Term Γ `⊥ → Term Γ A
  `elimBool : ∀{ℓ} (P : Term (Γ , `Bool) (`Type ℓ))
    (pt : Term Γ (subT ⟦ eval P ⟧ `true))
    (pf : Term Γ (subT ⟦ eval P ⟧ `false))
    (b : Term Γ `Bool)
    → Term Γ (subT ⟦ eval P ⟧ (eval b))
  `des : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Term Γ (`μ D) → Term Γ (⟦ D ⟧ᵈ (`μ D))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (eval B)
eval (`Σ A B) = `Σ (eval A) (eval B)
eval (`μ D) = `μ (eval D)
eval `⟦ A ⟧ = `⟦ eval A ⟧
eval (`⟦ D ⟧ᵈ X) = `⟦ eval D ⟧ᵈ (eval X)

{- Desc introduction -}
eval `⊤ᵈ = `⊤ᵈ
eval `Xᵈ = `Xᵈ
eval (`Πᵈ A D) = `Πᵈ (eval A) (eval D)
eval (`Σᵈ A D) = `Σᵈ (eval A) (eval D)

{- Value introduction -}
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (a `, b) = eval a `, eval b
eval (`λ b) = `λ (eval b)
eval (`con x) = `con (eval x)

{- Value elimination -}
eval (`var i) = `neut (`var i)
eval (`if b `then c₁ `else c₂) = if eval b then eval c₁ else eval c₂
eval (f `$ a) = eval f $ eval a
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)
eval (`elim⊥ bot) = elim⊥ (eval bot)
eval (`elimBool P pt pf b) = elimBool (eval P) (eval pt) (eval pf) (eval b)
eval (`des x) = des (eval x)

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


{-# OPTIONS --cubical --safe #-}
module Cubical.Relation.Nullary.DecidableEq where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Empty

open import Cubical.Relation.Nullary

-- Proof of Hedberg's theorem: a type with decidable equality is an h-set

Dec→Stable : ∀ {ℓ} (A : Type ℓ) → Dec A → Stable A
Dec→Stable A (yes x) = λ _ → x
Dec→Stable A (no x) = λ f → ⊥-elim (f x)

Stable≡→isSet : ∀ {ℓ} {A : Type ℓ} → (st : ∀ (a b : A) → Stable (a ≡ b)) → isSet A
Stable≡→isSet {A = A} st a b p q j i =
  let f : (x : A) → a ≡ x → a ≡ x
      f x p = st a x (λ h → h p)
      fIsConst : (x : A) → (p q : a ≡ x) → f x p ≡ f x q
      fIsConst = λ x p q i → st a x (isProp¬ _ (λ h → h p) (λ h → h q) i)
      rem : (p : a ≡ b) → PathP (λ i → a ≡ p i) (f a refl) (f b p)
      rem p j = f (p j) (λ i → p (i ∧ j))
  in hcomp (λ k → λ { (i = i0) → f a refl k
                    ; (i = i1) → fIsConst b p q j k
                    ; (j = i0) → rem p i k
                    ; (j = i1) → rem q i k }) a

-- Hedberg's theorem
Discrete→isSet : ∀ {ℓ} {A : Type ℓ} → Discrete A → isSet A
Discrete→isSet d = Stable≡→isSet (λ x y → Dec→Stable (x ≡ y) (d x y))


{-# OPTIONS --allow-unsolved-metas #-}
open import Agda.Builtin.Size

mutual

  data Nat (i : Size) : Set where
    zero : Nat i
    suc  : Nat′ i → Nat i

  data Nat′ (i : Size) : Set where
    [_] : {j : Size< i} → Nat j → Nat′ i

size : ∀ {i} → Nat′ i → Size
size ([_] {j} _) = {!j!}

unbox : ∀ {i} (n : Nat′ i) → Nat (size n)
unbox [ n ] = n

postulate
  _ _ _ _ _ _ : Set


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sizes for Agda's sized types
------------------------------------------------------------------------

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

module Size where

open import Agda.Builtin.Size public
  renaming ( SizeU to SizeUniv ) --  sort SizeUniv
  using    ( Size                --  Size   : SizeUniv
           ; Size<_              --  Size<_ : Size → SizeUniv
           ; ↑_                  --  ↑_     : Size → Size
           ; ∞ )                 --  ∞      : Size


module Abstract where

data Bool : Set where
  true false : Bool

not : Bool → Bool
not true  = false
not false = true

abstract
  Answer : Set
  Answer = Bool

  yes : Answer
  yes = true

  no : Answer
  no = false

  contradict : Answer → Answer
  contradict x = not x

counter-contradict : Answer → Answer
counter-contradict x = contradict (contradict x)

no-way : Answer
no-way = contradict yes

data Answers : Set where
  one-answer   : Answer → Answers
  more-answers : Answer → Answers → Answers

yes-or-no : Answers
yes-or-no = more-answers yes (one-answer no)


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Unit

module Oscar.Class.SimilaritySingleton where

module SimilaritySingleton
  {𝔞} {𝔄 : Ø 𝔞}
  {𝔟} {𝔅 : Ø 𝔟}
  {𝔣} {𝔉 : Ø 𝔣}
  {𝔞̇ 𝔟̇}
  (∼₁ : Ø 𝔞̇)
  (_∼₂_ : 𝔅 → 𝔅 → Ø 𝔟̇) (let _∼₂_ = _∼₂_; infix 4 _∼₂_)
  (_◃_ : 𝔉 → 𝔄 → 𝔅) (let _◃_ = _◃_; infix 16 _◃_)
  (x y : 𝔄)
  (f : 𝔉)
  = ℭLASS (_◃_ , _∼₂_ , x , y) (∼₁ → f ◃ x ∼₂ f ◃ y)

module _
  {𝔞} {𝔄 : Ø 𝔞}
  {𝔟} {𝔅 : Ø 𝔟}
  {𝔣} {𝔉 : Ø 𝔣}
  {𝔞̇ 𝔟̇}
  {∼₁ : Ø 𝔞̇}
  {_∼₂_ : 𝔅 → 𝔅 → Ø 𝔟̇} (let _∼₂_ = _∼₂_; infix 4 _∼₂_)
  {_◃_ : 𝔉 → 𝔄 → 𝔅} (let _◃_ = _◃_; infix 16 _◃_)
  {x y : 𝔄}
  {f : 𝔉}
  where
  similaritySingleton = SimilaritySingleton.method ∼₁ _∼₂_ _◃_ x y f
  module _ ⦃ _ : SimilaritySingleton.class ∼₁ _∼₂_ _◃_ x y f ⦄ where
    instance
      toUnit : Unit.class (∼₁ → f ◃ x ∼₂ f ◃ y)
      toUnit .⋆ = similaritySingleton


open import Nat
open import Prelude
open import contexts
open import dynamics-core

module canonical-value-forms where
  canonical-value-forms-num : ∀{Δ d} →
                              Δ , ∅ ⊢ d :: num →
                              d val →
                              Σ[ n ∈ Nat ] (d == N n)
  canonical-value-forms-num TANum VNum = _ , refl
  canonical-value-forms-num (TAVar x₁) ()
  canonical-value-forms-num (TAAp wt wt₁) ()
  canonical-value-forms-num (TAEHole x x₁) ()
  canonical-value-forms-num (TANEHole x wt x₁) ()
  canonical-value-forms-num (TACast wt x) ()
  canonical-value-forms-num (TAFailedCast wt x x₁ x₂) ()

  canonical-value-forms-arr : ∀{Δ d τ1 τ2} →
                              Δ , ∅ ⊢ d :: (τ1 ==> τ2) →
                              d val →
                              Σ[ x ∈ Nat ] Σ[ d' ∈ ihexp ]
                                ((d == (·λ x ·[ τ1 ] d')) ×
                                 (Δ , ■ (x , τ1) ⊢ d' :: τ2))
  canonical-value-forms-arr (TAVar x₁) ()
  canonical-value-forms-arr {Δ = Δ} {d = ·λ x ·[ τ1 ] d} {τ1 = τ1} {τ2 = τ2} (TALam _ wt) VLam
    = _ , _ , refl , tr (λ Γ → Δ , Γ ⊢ d :: τ2) (extend-empty x τ1) wt
  canonical-value-forms-arr (TAAp wt wt₁) ()
  canonical-value-forms-arr (TAEHole x x₁) ()
  canonical-value-forms-arr (TANEHole x wt x₁) ()
  canonical-value-forms-arr (TACast wt x) ()
  canonical-value-forms-arr (TAFailedCast x x₁ x₂ x₃) ()

  canonical-value-form-sum : ∀{Δ d τ1 τ2} →
                              Δ , ∅ ⊢ d :: (τ1 ⊕ τ2) →
                              d val →
                              (Σ[ d' ∈ ihexp ] ((d == (inl τ2 d')) × (Δ , ∅ ⊢ d' :: τ1))) +
                              (Σ[ d' ∈ ihexp ] ((d == (inr τ1 d')) × (Δ , ∅ ⊢ d' :: τ2)))
  canonical-value-form-sum (TAInl wt) (VInl v) = Inl (_ , refl , wt)
  canonical-value-form-sum (TAInr wt) (VInr v) = Inr (_ , refl , wt)

  canonical-value-form-prod : ∀{Δ d τ1 τ2} →
                              Δ , ∅ ⊢ d :: (τ1 ⊠ τ2) →
                              d val →
                              Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ]
                                ((d == ⟨ d1 , d2 ⟩) ×
                                 (Δ , ∅ ⊢ d1 :: τ1) ×
                                 (Δ , ∅ ⊢ d2 :: τ2))
  canonical-value-form-prod (TAVar x) ()
  canonical-value-form-prod (TAAp wt wt₁) ()
  canonical-value-form-prod (TACase wt x wt₁ x₁ wt₂) ()
  canonical-value-form-prod (TAPair wt wt₁) (VPair v v₁) = _ , _ , refl , wt , wt₁
  canonical-value-form-prod (TAFst wt) ()
  canonical-value-form-prod (TASnd wt) ()
  canonical-value-form-prod (TAEHole x x₁) ()
  canonical-value-form-prod (TANEHole x wt x₁) ()
  canonical-value-form-prod (TACast wt x) ()
  canonical-value-form-prod (TAFailedCast wt x x₁ x₂) ()

  -- this argues (somewhat informally, because you still have to inspect
  -- the types of the theorems above and manually verify this property)
  -- that we didn't miss any cases above; this intentionally will make this
  -- file fail to typecheck if we added more types, hopefully forcing us to
  -- remember to add canonical forms lemmas as appropriate
  canonical-value-forms-coverage1 : ∀{Δ d τ} →
                                   Δ , ∅ ⊢ d :: τ →
                                   d val →
                                   τ ≠ num →
                                   ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) →
                                   ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ⊕ τ2)) →
                                   ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ⊠ τ2)) →
                                   ⊥
  canonical-value-forms-coverage1 TANum val nn na ns np = nn refl
  canonical-value-forms-coverage1 (TALam x wt) val nn na ns np = na _ _ refl
  canonical-value-forms-coverage1 (TAInl wt) val nn na ns np = ns _ _ refl
  canonical-value-forms-coverage1 (TAInr wt) val nn na ns np = ns _ _ refl
  canonical-value-forms-coverage1 (TAPair wt wt₁) val nn na ns np = np _ _ refl

  canonical-value-forms-coverage2 : ∀{Δ d} →
                                   Δ , ∅ ⊢ d :: ⦇-⦈ →
                                   d val →
                                   ⊥
  canonical-value-forms-coverage2 (TAVar x₁) ()
  canonical-value-forms-coverage2 (TAAp wt wt₁) ()
  canonical-value-forms-coverage2 (TAEHole x x₁) ()
  canonical-value-forms-coverage2 (TANEHole x wt x₁) ()
  canonical-value-forms-coverage2 (TACast wt x) ()
  canonical-value-forms-coverage2 (TAFailedCast wt x x₁ x₂) ()


module BasicIS4.Metatheory.DyadicGentzen-BasicKripkeBozicDosen where

open import BasicIS4.Syntax.DyadicGentzen public
open import BasicIS4.Semantics.BasicKripkeBozicDosen public hiding (_⊨_) -- TODO

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊨ A
eval (var i)           γ δ = lookup i γ
eval (lam t)           γ δ = λ ξ a → eval t (mono⊩⋆ ξ γ , a) (λ ζ →
                               let _ , (ζ′ , ξ′) = ≤⨾R→R⨾≤ (_ , (ξ , ζ))
                               in  mono⊩⋆ ξ′ (δ ζ′))
eval (app {A} {B} t u) γ δ = _⟪$⟫_ {A} {B} (eval t γ δ) (eval u γ δ)
eval (mvar i)          γ δ = lookup i (δ reflR)
eval (box t)           γ δ = λ ζ → eval t ∙ (λ ζ′ → δ (transR ζ ζ′))
eval (unbox t u)       γ δ = eval u γ (λ ζ → δ ζ , (eval t γ δ) ζ)
eval (pair t u)        γ δ = eval t γ δ , eval u γ δ
eval (fst t)           γ δ = π₁ (eval t γ δ)
eval (snd t)           γ δ = π₂ (eval t γ δ)
eval unit              γ δ = ∙

-- TODO: Correctness of evaluation with respect to conversion.