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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Functions.FunExtEquiv

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Bool
open import Cubical.Data.Nat hiding (_+_ ; +-comm ; +-assoc)
open import Cubical.Data.Vec
open import Cubical.Data.Sigma.Base
open import Cubical.Data.FinData
open import Cubical.Relation.Nullary

open import Cubical.Algebra.Group hiding (⟨_⟩)
open import Cubical.Algebra.AbGroup hiding (⟨_⟩)
open import Cubical.Algebra.Monoid hiding (⟨_⟩)
open import Cubical.Algebra.Ring

open Iso

private
  variable
    ℓ : Level
    A : Type ℓ

-- Equivalence between Vec matrix and Fin function matrix

FinMatrix : (A : Type ℓ) (m n : ℕ) → Type ℓ
FinMatrix A m n = FinVec (FinVec A n) m

VecMatrix : (A : Type ℓ) (m n : ℕ) → Type ℓ
VecMatrix A m n = Vec (Vec A n) m

FinMatrix→VecMatrix : {m n : ℕ} → FinMatrix A m n → VecMatrix A m n
FinMatrix→VecMatrix M = FinVec→Vec (λ fm → FinVec→Vec (M fm))

VecMatrix→FinMatrix : {m n : ℕ} → VecMatrix A m n → FinMatrix A m n
VecMatrix→FinMatrix M fn fm = lookup fm (lookup fn M)

FinMatrix→VecMatrix→FinMatrix : {m n : ℕ} (M : FinMatrix A m n)
                              → VecMatrix→FinMatrix (FinMatrix→VecMatrix M) ≡ M
FinMatrix→VecMatrix→FinMatrix {m = zero} M = funExt (⊥.rec ∘ ¬Fin0)
FinMatrix→VecMatrix→FinMatrix {n = zero} M = funExt₂ (λ _ → ⊥.rec ∘ ¬Fin0)
FinMatrix→VecMatrix→FinMatrix {m = suc m} {n = suc n} M = funExt₂ goal
  where
  goal : (fm : Fin (suc m)) (fn : Fin (suc n))
       → VecMatrix→FinMatrix (_ ∷ FinMatrix→VecMatrix (M ∘ suc)) fm fn ≡ M fm fn
  goal zero zero       = refl
  goal zero (suc fn) i = FinVec→Vec→FinVec (M zero ∘ suc) i fn
  goal (suc fm) fn i   = FinMatrix→VecMatrix→FinMatrix (M ∘ suc) i fm fn

VecMatrix→FinMatrix→VecMatrix : {m n : ℕ} (M : VecMatrix A m n)
                              → FinMatrix→VecMatrix (VecMatrix→FinMatrix M) ≡ M
VecMatrix→FinMatrix→VecMatrix {m = zero} [] = refl
VecMatrix→FinMatrix→VecMatrix {m = suc m} (M ∷ MS) i =
  Vec→FinVec→Vec M i ∷ VecMatrix→FinMatrix→VecMatrix MS i

FinMatrixIsoVecMatrix : (A : Type ℓ) (m n : ℕ) → Iso (FinMatrix A m n) (VecMatrix A m n)
fun (FinMatrixIsoVecMatrix A m n)      = FinMatrix→VecMatrix
inv (FinMatrixIsoVecMatrix A m n)      = VecMatrix→FinMatrix
rightInv (FinMatrixIsoVecMatrix A m n) = VecMatrix→FinMatrix→VecMatrix
leftInv (FinMatrixIsoVecMatrix A m n)  = FinMatrix→VecMatrix→FinMatrix

FinMatrix≃VecMatrix : {m n : ℕ} → FinMatrix A m n ≃ VecMatrix A m n
FinMatrix≃VecMatrix {_} {A} {m} {n} = isoToEquiv (FinMatrixIsoVecMatrix A m n)

FinMatrix≡VecMatrix : (A : Type ℓ) (m n : ℕ) → FinMatrix A m n ≡ VecMatrix A m n
FinMatrix≡VecMatrix _ _ _ = ua FinMatrix≃VecMatrix

-- Define abelian group structure on matrices
module FinMatrixAbGroup (G' : AbGroup {ℓ}) where

  open AbGroup G' renaming ( Carrier to G ; is-set to isSetG )

  zeroFinMatrix : ∀ {m n} → FinMatrix G m n
  zeroFinMatrix _ _ = 0g

  negFinMatrix : ∀ {m n} → FinMatrix G m n → FinMatrix G m n
  negFinMatrix M i j = - M i j

  addFinMatrix : ∀ {m n} → FinMatrix G m n → FinMatrix G m n → FinMatrix G m n
  addFinMatrix M N i j = M i j + N i j

  isSetFinMatrix : ∀ {m n} → isSet (FinMatrix G m n)
  isSetFinMatrix = isSetΠ2 λ _ _ → isSetG

  addFinMatrixAssoc : ∀ {m n} → (M N K : FinMatrix G m n)
                    → addFinMatrix M (addFinMatrix N K) ≡ addFinMatrix (addFinMatrix M N) K
  addFinMatrixAssoc M N K i j k = assoc (M j k) (N j k) (K j k) i

  addFinMatrix0r : ∀ {m n} → (M : FinMatrix G m n)
                 → addFinMatrix M zeroFinMatrix ≡ M
  addFinMatrix0r M i j k = rid (M j k) i

  addFinMatrix0l : ∀ {m n} → (M : FinMatrix G m n)
                 → addFinMatrix zeroFinMatrix M ≡ M
  addFinMatrix0l M i j k = lid (M j k) i

  addFinMatrixNegMatrixr : ∀ {m n} → (M : FinMatrix G m n)
                         → addFinMatrix M (negFinMatrix M) ≡ zeroFinMatrix
  addFinMatrixNegMatrixr M i j k = invr (M j k) i

  addFinMatrixNegMatrixl : ∀ {m n} → (M : FinMatrix G m n)
                         → addFinMatrix (negFinMatrix M) M ≡ zeroFinMatrix
  addFinMatrixNegMatrixl M i j k = invl (M j k) i

  addFinMatrixComm : ∀ {m n} → (M N : FinMatrix G m n)
                   → addFinMatrix M N ≡ addFinMatrix N M
  addFinMatrixComm M N i k l = comm (M k l) (N k l) i

  FinMatrixAbGroup : (m n : ℕ) → AbGroup {ℓ}
  FinMatrixAbGroup m n =
    makeAbGroup {G = FinMatrix G m n} zeroFinMatrix addFinMatrix negFinMatrix
                isSetFinMatrix addFinMatrixAssoc addFinMatrix0r
                addFinMatrixNegMatrixr addFinMatrixComm

-- Define a abelian group structure on vector matrices and prove that
-- it is equal to FinMatrixAbGroup using the SIP
module _ (G' : AbGroup {ℓ}) where

  open AbGroup G' renaming ( Carrier to G )

  zeroVecMatrix : ∀ {m n} → VecMatrix G m n
  zeroVecMatrix = replicate (replicate 0g)

  negVecMatrix : ∀ {m n} → VecMatrix G m n → VecMatrix G m n
  negVecMatrix = map (map (λ x → - x))

  addVec : ∀ {m} → Vec G m → Vec G m → Vec G m
  addVec [] [] = []
  addVec (x ∷ xs) (y ∷ ys) = x + y ∷ addVec xs ys

  addVecMatrix : ∀ {m n} → VecMatrix G m n → VecMatrix G m n → VecMatrix G m n
  addVecMatrix [] [] = []
  addVecMatrix (M ∷ MS) (N ∷ NS) = addVec M N ∷ addVecMatrix MS NS

  open FinMatrixAbGroup

  -- Proof that FinMatrix→VecMatrix is a group homorphism
  FinMatrix→VecMatrixHomAdd : (m n : ℕ) (M N : FinMatrix G m n)
    → FinMatrix→VecMatrix (addFinMatrix G' M N) ≡
      addVecMatrix (FinMatrix→VecMatrix M) (FinMatrix→VecMatrix N)
  FinMatrix→VecMatrixHomAdd zero n M N = refl
  FinMatrix→VecMatrixHomAdd (suc m) n M N =
    λ i → lem n (M zero) (N zero) i
        ∷ FinMatrix→VecMatrixHomAdd m n (λ i j → M (suc i) j) (λ i j → N (suc i) j) i
     where
     lem : (n : ℕ) (V W : FinVec G n)
       → FinVec→Vec (λ j → V j + W j) ≡ addVec (FinVec→Vec V) (FinVec→Vec W)
     lem zero V W = refl
     lem (suc n) V W = λ i → V zero + W zero ∷ lem n (V ∘ suc) (W ∘ suc) i

  -- Combine everything to get an induced abelian group structure of
  -- VecMatrix that is equal to the one on FinMatrix
  VecMatrixAbGroup : (m n : ℕ) → AbGroup
  VecMatrixAbGroup m n =
    InducedAbGroup (FinMatrixAbGroup G' m n) (_ , addVecMatrix)
                    FinMatrix≃VecMatrix (FinMatrix→VecMatrixHomAdd m n)

  FinMatrixAbGroup≡VecMatrixAbGroup : (m n : ℕ) → FinMatrixAbGroup G' m n ≡ VecMatrixAbGroup m n
  FinMatrixAbGroup≡VecMatrixAbGroup m n =
    InducedAbGroupPath (FinMatrixAbGroup G' m n) (_ , addVecMatrix)
                        FinMatrix≃VecMatrix (FinMatrix→VecMatrixHomAdd m n)

-- Define identity matrix and matrix multiplication for FinMatrix and
-- prove that square matrices form a ring
module _ (R' : Ring {ℓ}) where

  open Ring R' renaming ( Carrier to R ; is-set to isSetR )
  open Theory R'
  open FinMatrixAbGroup (abgroup R _ _ _ (R' .Ring.+-isAbGroup))

  oneFinMatrix : ∀ {n} → FinMatrix R n n
  oneFinMatrix i j = if i == j then 1r else 0r

  -- TODO: upstream and state for monoids
  ∑ : ∀ {n} → FinVec R n → R
  ∑ = foldrFin _+_ 0r

  mulFinMatrix : ∀ {m1 m2 m3} → FinMatrix R m1 m2 → FinMatrix R m2 m3 → FinMatrix R m1 m3
  mulFinMatrix M N i k = ∑ λ j → M i j · N j k

  -- Properties
  sumVecExt : ∀ {n} → {V W : FinVec R n} → ((i : Fin n) → V i ≡ W i) → ∑ V ≡ ∑ W
  sumVecExt {n = zero} _    = refl
  sumVecExt {n = suc n} h i = h zero i + sumVecExt (h ∘ suc) i

  sumVecSplit : ∀ {n} → (V W : FinVec R n) → ∑ (λ i → V i + W i) ≡ ∑ V + ∑ W
  sumVecSplit {n = zero}  V W = sym (+-rid 0r)
  sumVecSplit {n = suc n} V W =
    V zero + W zero + ∑ (λ i → V (suc i) + W (suc i)) ≡⟨ (λ i → V zero + W zero + sumVecSplit (V ∘ suc) (W ∘ suc) i) ⟩
    V zero + W zero + (∑ (V ∘ suc) + ∑ (W ∘ suc))     ≡⟨ sym (+-assoc _ _ _) ⟩
    V zero + (W zero + (∑ (V ∘ suc) + ∑ (W ∘ suc)))   ≡⟨ cong (λ x → V zero + x) (+-assoc-comm1 _ _ _) ⟩
    V zero + (∑ (V ∘ suc) + (W zero + (∑ (W ∘ suc)))) ≡⟨ +-assoc _ _ _ ⟩
    V zero + ∑ (V ∘ suc) + (W zero + ∑ (W ∘ suc))     ∎

  sumVec0r : (n : ℕ) → ∑ (λ (i : Fin n) → 0r) ≡ 0r
  sumVec0r zero    = refl
  sumVec0r (suc n) = cong (λ x → 0r + x) (sumVec0r n) ∙ +-rid 0r

  sumVecExchange : ∀ {m n} → (M : FinMatrix R m n) → ∑ (λ i → ∑ (λ j → M i j)) ≡ ∑ (λ j → ∑ (λ i → M i j))
  sumVecExchange {m = zero}  {n = n}     M = sym (sumVec0r n)
  sumVecExchange {m = suc m} {n = zero}  M = cong (λ x → 0r + x) (sumVec0r m) ∙ +-rid 0r
  sumVecExchange {m = suc m} {n = suc n} M =
     let a  = M zero zero
         L  = ∑ λ j → M zero (suc j)
         C  = ∑ λ i → M (suc i) zero
         N  = ∑ λ i → ∑ λ j → M (suc i) (suc j)
         -- N reindexed
         N' = ∑ λ j → ∑ λ i → M (suc i) (suc j)
     in a + L + ∑ (λ i → ∑ (λ j → M (suc i) j)) ≡⟨ (λ k → a + L + sumVecSplit (λ i → M (suc i) zero) (λ i → ∑ (λ j → M (suc i) (suc j))) k) ⟩
        a + L + (C + N)                         ≡⟨ (λ k → a + L + (C + sumVecExchange (λ i j → M (suc i) (suc j)) k)) ⟩
        a + L + (C + N')                        ≡⟨ sym (+-assoc _ _ _) ⟩
        a + (L + (C + N'))                      ≡⟨ (λ k → a + +-assoc-comm1 L C N' k) ⟩
        a + (C + (L + N'))                      ≡⟨ +-assoc _ _ _ ⟩
        a + C + (L + N')                        ≡⟨ (λ k → a + C + sumVecSplit (λ j → M zero (suc j)) (λ j → ∑ (λ i → M (suc i) (suc j))) (~ k)) ⟩
        a + C + ∑ (λ j → ∑ (λ i → M i (suc j))) ∎

  sumVecMulrdist : ∀ {n} → (x : R) → (V : FinVec R n)
                 → x · ∑ V ≡ ∑ λ i → x · V i
  sumVecMulrdist {n = zero}  x _ = 0-rightNullifies x
  sumVecMulrdist {n = suc n} x V =
    x · (V zero + ∑ (V ∘ suc))           ≡⟨ ·-rdist-+ _ _ _ ⟩
    x · V zero + x · ∑ (V ∘ suc)         ≡⟨ (λ i → x · V zero + sumVecMulrdist x (V ∘ suc) i) ⟩
    x · V zero + ∑ (λ i → x · V (suc i)) ∎

  sumVecMulldist : ∀ {n} → (x : R) → (V : FinVec R n)
                 → (∑ V) · x ≡ ∑ λ i → V i · x
  sumVecMulldist {n = zero}  x _ = 0-leftNullifies x
  sumVecMulldist {n = suc n} x V =
    (V zero + ∑ (V ∘ suc)) · x           ≡⟨ ·-ldist-+ _ _ _ ⟩
    V zero · x + (∑ (V ∘ suc)) · x       ≡⟨ (λ i → V zero · x + sumVecMulldist x (V ∘ suc) i) ⟩
    V zero · x + ∑ (λ i → V (suc i) · x) ∎

  sumVecMulr0 : ∀ {n} → (V : FinVec R n) → ∑ (λ i → V i · 0r) ≡ 0r
  sumVecMulr0 V = sym (sumVecMulldist 0r V) ∙ 0-rightNullifies _

  sumVecMul0r : ∀ {n} → (V : FinVec R n) → ∑ (λ i → 0r · V i) ≡ 0r
  sumVecMul0r V = sym (sumVecMulrdist 0r V) ∙ 0-leftNullifies _

  sumVecMulr1 : (n : ℕ) (V : FinVec R n) → (j : Fin n) → ∑ (λ i → V i · (if i == j then 1r else 0r)) ≡ V j
  sumVecMulr1 (suc n) V zero = (λ k → ·-rid (V zero) k + sumVecMulr0 (V ∘ suc) k) ∙ +-rid (V zero)
  sumVecMulr1 (suc n) V (suc j) =
     (λ i → 0-rightNullifies (V zero) i + ∑ (λ x → V (suc x) · (if x == j then 1r else 0r)))
     ∙∙ +-lid _ ∙∙ sumVecMulr1 n (V ∘ suc) j

  sumVecMul1r : (n : ℕ) (V : FinVec R n) → (j : Fin n) → ∑ (λ i → (if j == i then 1r else 0r) · V i) ≡ V j
  sumVecMul1r (suc n) V zero = (λ k → ·-lid (V zero) k + sumVecMul0r (V ∘ suc) k) ∙ +-rid (V zero)
  sumVecMul1r (suc n) V (suc j) =
    (λ i → 0-leftNullifies (V zero) i + ∑ (λ i → (if j == i then 1r else 0r) · V (suc i)))
    ∙∙ +-lid _ ∙∙ sumVecMul1r n (V ∘ suc) j

  mulFinMatrixAssoc : ∀ {m n k l} → (M : FinMatrix R m n) → (N : FinMatrix R n k) → (K : FinMatrix R k l)
                   → mulFinMatrix M (mulFinMatrix N K) ≡ mulFinMatrix (mulFinMatrix M N) K
  mulFinMatrixAssoc M N K = funExt₂ λ i j →
    ∑ (λ k → M i k · ∑ (λ l → N k l · K l j))   ≡⟨ sumVecExt (λ k → sumVecMulrdist (M i k) (λ l → N k l · K l j)) ⟩
    ∑ (λ k → ∑ (λ l → M i k · (N k l · K l j))) ≡⟨ sumVecExt (λ k → sumVecExt (λ l → ·-assoc (M i k) (N k l) (K l j))) ⟩
    ∑ (λ k → ∑ (λ l → M i k · N k l · K l j))   ≡⟨ sumVecExchange (λ k l → M i k · N k l · K l j) ⟩
    ∑ (λ l → ∑ (λ k → M i k · N k l · K l j))   ≡⟨ sumVecExt (λ l → sym (sumVecMulldist (K l j) (λ k → M i k · N k l))) ⟩
    ∑ (λ l → ∑ (λ k → M i k · N k l) · K l j)   ∎

  mulFinMatrixr1 : ∀ {m n} → (M : FinMatrix R m n) → mulFinMatrix M oneFinMatrix ≡ M
  mulFinMatrixr1 M = funExt₂ λ i j → sumVecMulr1 _ (M i) j

  mulFinMatrix1r : ∀ {m n} → (M : FinMatrix R m n) → mulFinMatrix oneFinMatrix M ≡ M
  mulFinMatrix1r M = funExt₂ λ i j → sumVecMul1r _ (λ x → M x j) i

  mulFinMatrixrDistrAddFinMatrix : ∀ {n} (M N K : FinMatrix R n n)
                                 → mulFinMatrix M (addFinMatrix N K) ≡ addFinMatrix (mulFinMatrix M N) (mulFinMatrix M K)
  mulFinMatrixrDistrAddFinMatrix M N K = funExt₂ λ i j →
    ∑ (λ k → M i k · (N k j + K k j))                 ≡⟨ sumVecExt (λ k → ·-rdist-+ (M i k) (N k j) (K k j)) ⟩
    ∑ (λ k → M i k · N k j + M i k · K k j)           ≡⟨ sumVecSplit (λ k → M i k · N k j) (λ k → M i k · K k j) ⟩
    ∑ (λ k → M i k · N k j) + ∑ (λ k → M i k · K k j) ∎

  mulFinMatrixlDistrAddFinMatrix : ∀ {n} (M N K : FinMatrix R n n)
                                 → mulFinMatrix (addFinMatrix M N) K ≡ addFinMatrix (mulFinMatrix M K) (mulFinMatrix N K)
  mulFinMatrixlDistrAddFinMatrix M N K = funExt₂ λ i j →
    ∑ (λ k → (M i k + N i k) · K k j)                 ≡⟨ sumVecExt (λ k → ·-ldist-+ (M i k) (N i k) (K k j)) ⟩
    ∑ (λ k → M i k · K k j + N i k · K k j)           ≡⟨ sumVecSplit (λ k → M i k · K k j) (λ k → N i k · K k j) ⟩
    ∑ (λ k → M i k · K k j) + ∑ (λ k → N i k · K k j) ∎

  FinMatrixRing : (n : ℕ) → Ring {ℓ}
  FinMatrixRing n =
    makeRing {R = FinMatrix R n n} zeroFinMatrix oneFinMatrix addFinMatrix
             mulFinMatrix negFinMatrix isSetFinMatrix addFinMatrixAssoc
             addFinMatrix0r addFinMatrixNegMatrixr addFinMatrixComm
             mulFinMatrixAssoc mulFinMatrixr1 mulFinMatrix1r
             mulFinMatrixrDistrAddFinMatrix mulFinMatrixlDistrAddFinMatrix


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

module Fin where

open import Cubical.Core.Everything using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)

open import Cubical.Foundations.Prelude     using (refl; sym; _∙_; cong; transport; subst; funExt; transp; I; i0; i1)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Isomorphism using (iso; Iso; isoToPath; section; retract)

open import Data.Fin   using (Fin; toℕ; fromℕ<; #_; _≟_) renaming (zero to fz; suc to fs)
open import Data.Nat   using (ℕ; zero; suc; _<_; _>_; z≤n; s≤s)

-- Alternate representation of Fin as a number and proof of its upper bound.
record Fin1 (n : ℕ) : Type where
  constructor fin1
  field
    r   : ℕ
    r<n : r < n

fin1suc : {n : ℕ} → Fin1 n → Fin1 (suc n)
fin1suc (fin1 r r<n) = fin1 (suc r) (s≤s r<n)

-- From Data.Fin.Properites
-- They need to be re-defined here since Cubical uses a different ≡

fromℕ<-toℕ : ∀ {m} (i : Fin m) (i<m : toℕ i < m) → fromℕ< i<m ≡ i
fromℕ<-toℕ fz     (s≤s z≤n)       = refl
fromℕ<-toℕ (fs i) (s≤s (s≤s m≤n)) = cong fs (fromℕ<-toℕ i (s≤s m≤n))

toℕ-fromℕ< : ∀ {m n} (m<n : m < n) → toℕ (fromℕ< m<n) ≡ m
toℕ-fromℕ< (s≤s z≤n)       = refl
toℕ-fromℕ< (s≤s (s≤s m<n)) = cong suc (toℕ-fromℕ< (s≤s m<n))

toℕ<n : ∀ {n} (i : Fin n) → toℕ i < n
toℕ<n fz     = s≤s z≤n
toℕ<n (fs i) = s≤s (toℕ<n i)

-------------------
-- Equivalence of Fin and Fin1

fin→fin1 : {n : ℕ} → Fin n → Fin1 n
fin→fin1 fz     = fin1 0 (s≤s z≤n)
fin→fin1 (fs x) = let fin1 r r<n = fin→fin1 x in fin1 (suc r) (s≤s r<n)

fin1→fin : {n : ℕ} → Fin1 n → Fin n
fin1→fin (fin1 _ r<n) = fromℕ< r<n

fin→fin1→fin : {n : ℕ} → (r : Fin n) → (fin1→fin ∘ fin→fin1) r ≡ r
fin→fin1→fin fz     = refl
fin→fin1→fin (fs r) = cong fs (fin→fin1→fin r)

fin1→fin→fin1 : {n : ℕ} → (r : Fin1 n) → (fin→fin1 ∘ fin1→fin) r ≡ r
fin1→fin→fin1 (fin1 zero    (s≤s z≤n))       = refl
fin1→fin→fin1 (fin1 (suc r) (s≤s (s≤s r<n))) = cong fin1suc (fin1→fin→fin1 (fin1 r (s≤s r<n)))

fin≃fin1 : {n : ℕ} → Iso (Fin n) (Fin1 n)
fin≃fin1 = iso fin→fin1 fin1→fin fin1→fin→fin1 fin→fin1→fin

fin≡fin1 : {n : ℕ} → Fin n ≡ Fin1 n
fin≡fin1 = isoToPath fin≃fin1

-- Equivalence of toℕ and Fin1.r

toℕ≡Fin1r1 : {n : ℕ} → (r : Fin n) → toℕ r ≡ Fin1.r (fin→fin1 r)
toℕ≡Fin1r1 fz     = refl
toℕ≡Fin1r1 (fs r) = cong suc (toℕ≡Fin1r1 r)

toℕ≡Fin1r : {n : ℕ} → toℕ {n} ≡ Fin1.r ∘ fin→fin1
toℕ≡Fin1r = funExt toℕ≡Fin1r1

Fin1r≡toℕ1 : {n : ℕ} → (r : Fin1 n) → toℕ (fin1→fin r) ≡ Fin1.r r
Fin1r≡toℕ1 (fin1 r r<n) = toℕ-fromℕ< r<n

Fin1r≡toℕ : {n : ℕ} → toℕ {n} ∘ fin1→fin ≡ Fin1.r
Fin1r≡toℕ = funExt Fin1r≡toℕ1


open import FRP.JS.Bool using ( Bool ; true ; false ; not ; _∨_ )
open import FRP.JS.True using ( True )
open import FRP.JS.Maybe using ( Maybe ; just ; nothing )
open import FRP.JS.Primitive using ( ℤ ; String )

module FRP.JS.Float where

infixr 4 _≤_ _<_ _≟_ _≠_
infixl 6 _+_ _-_
infixl 7 _*_ _/_ _/?_

open import FRP.JS.Primitive public using ( ℝ )

primitive
  primFloatPlus      : ℝ -> ℝ -> ℝ
  primFloatMinus     : ℝ -> ℝ -> ℝ
  primFloatTimes     : ℝ -> ℝ -> ℝ
  primFloatDiv       : ℝ -> ℝ -> ℝ
  primFloatLess      : ℝ -> ℝ -> Bool
  primFloor          : ℝ -> ℤ
  primCeiling        : ℝ -> ℤ
  primExp            : ℝ -> ℝ
  primLog            : ℝ -> ℝ
  primSin            : ℝ -> ℝ
  primShowFloat      : ℝ -> String
  primShowInteger    : ℤ → String
  primIntegerToFloat : ℤ → ℝ

_+_   = primFloatPlus
_-_   = primFloatMinus
_*_   = primFloatTimes
_<_   = primFloatLess
⌊_⌋   = primFloor
⌈_⌉   = primCeiling
exp   = primExp
log   = primLog
sin   = primSin

{-# COMPILED_JS _+_   function(x) { return function(y) { return x + y; }; } #-}
{-# COMPILED_JS _-_   function(x) { return function(y) { return x - y; }; } #-}
{-# COMPILED_JS _*_   function(x) { return function(y) { return x * y; }; } #-}
{-# COMPILED_JS _<_   function(x) { return function(y) { return x < y; }; } #-}
{-# COMPILED_JS ⌊_⌋   Math.floor #-}
{-# COMPILED_JS ⌈_⌉   Math.ceil #-}
{-# COMPILED_JS exp   Math.exp #-}
{-# COMPILED_JS log   Math.log #-}
{-# COMPILED_JS sin   Math.sin #-}

-_ : ℝ → ℝ
- x = 0.0 - x

_≠_ : ℝ → ℝ → Bool
(x ≠ y) = (x < y) ∨ (y < x)

_≟_ : ℝ → ℝ → Bool
(x ≟ y) = not (x ≠ y)

_≤_ : ℝ → ℝ → Bool
(x ≤ y) = not (y < x)

-- Some hoop-jumping to avoid division by zero, so we don't end up with
-- Infinity, -Infinity or NaN.

_/_ : (x y : ℝ) → {y≠0 : True (y ≠ 0.0)} → ℝ
x / y = primFloatDiv x y

_/?_ : ℝ → ℝ → Maybe ℝ
x /? 0.0 = nothing
x /? y   = just (primFloatDiv x y)

show : ℝ → String
show x
 with (x ≟ primIntegerToFloat ⌊ x ⌋)
... | true  = primShowInteger ⌊ x ⌋
... | false = primShowFloat x

{-# COMPILED_JS -_   function(x) { return -x; } #-}
{-# COMPILED_JS _≠_ function(x) { return function(y) { return x !== y; }; } #-}
{-# COMPILED_JS _≟_ function(x) { return function(y) { return x === y; }; } #-}
{-# COMPILED_JS _≤_  function(x) { return function(y) { return x <= y; }; } #-}
{-# COMPILED_JS _/_  function(x) { return function(y) { return function() { return x / y; }; }; } #-}
{-# COMPILED_JS _/?_  function(x) { return function(y) { if (y === 0) { return null; } else { return x / y; } }; } #-}
{-# COMPILED_JS show  function(x) { return x.toString(); } #-}


-- Andreas, 2011-05-30
-- {-# OPTIONS -v tc.lhs.unify:50 #-}
module Issue292 where

data Bool  : Set where true  false  : Bool
data Bool2 : Set where true2 false2 : Bool2

data ⊥ : Set where

infix 3 ¬_

¬_ : Set → Set
¬ P = P → ⊥

infix 4 _≅_

data _≅_ {A : Set} (x : A) : ∀ {B : Set} → B → Set where
  refl : x ≅ x

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

P : Set -> Set
P S = Σ S (\s → s ≅ true)

pbool : P Bool
pbool = true , refl

-- the following should fail:
¬pbool2 : ¬ P Bool2
¬pbool2 ( true2 , () )
¬pbool2 ( false2 , () )

{- using subst, one could now prove distinctness of types, which we don't want
tada : ¬ (Bool ≡ Bool2)
tada eq = ¬pbool2 (subst (\ S → P S) eq pbool )
-}


{-

This file contains:

- Definition of propositional truncation

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.PropositionalTruncation.Base where

open import Cubical.Core.Primitives

-- Propositional truncation as a higher inductive type:

data ∥_∥ {ℓ} (A : Type ℓ) : Type ℓ where
  ∣_∣ : A → ∥ A ∥
  squash : ∀ (x y : ∥ A ∥) → x ≡ y

-- Mere existence

∃ : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃ A B = ∥ Σ A B ∥

infix 2 ∃-syntax

∃-syntax : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃-syntax = ∃

syntax ∃-syntax A (λ x → B) = ∃[ x ∈ A ] B


module Bound.Lower (A : Set) where

data Bound : Set where
  bot : Bound
  val : A → Bound


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

open import Bundles

module Properties.AlmostOrderedField {ℓ ℓ'} (AOF : AlmostOrderedField {ℓ} {ℓ'}) where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`

open import Function.Base using (_∋_)
open import Function.Base using (it) -- instance search

import MoreLogic
open MoreLogic.Reasoning
import MoreAlgebra

-- Lemma 4.1.11.
-- In the presence of the first five axioms of Definition 4.1.10, conditions (†) and (∗) are together equivalent to the condition that for all x, y, z : F,
--  1. x ≤ y ⇔ ¬(y < x),
--  2. x # y ⇔ (x < y) ∨ (y < x)
--  3. x ≤ y ⇔ x + z ≤ y + z,
--  4. x < y ⇔ x + z < y + z,
--  5. 0 < x + y ⇒ 0 < x ∨ 0 < y,
--  6. x < y ≤ z ⇒ x < z,
--  7. x ≤ y < z ⇒ x < z,
--  8. x ≤ y ∧ 0 ≤ z ⇒ x z ≤ y z,
--  9. 0 < z ⇒ (x < y ⇔ x z < y z),
-- 10. 0 < 1.

open AlmostOrderedField AOF renaming (Carrier to F)
import Cubical.Structures.Ring
open Cubical.Structures.Ring.Theory (record {AlmostOrderedField AOF})
open MoreAlgebra.Properties.Group   (record {AlmostOrderedField AOF renaming (+-isGroup to isGroup )})

-- NOTE: ported from Cubical.Structures.Group.GroupLemmas
-- NOTE: these versions differ from the Group-versions because they are defined w.r.t. an appartness relation _#_ that is not present for the Group
simplR : {a b : F} (c : F) {{_ : c # 0f}} → a · c ≡ b · c → a ≡ b
simplR {a} {b} c {{_}} a·c≡b·c =
   a                ≡⟨ sym (fst (·-identity a)) ∙ cong (a ·_) (sym (·-rinv c it)) ∙ ·-assoc _ _ _ ⟩
  (a · c) · (c ⁻¹ᶠ) ≡⟨ cong (_· c ⁻¹ᶠ) a·c≡b·c ⟩
  (b · c) · (c ⁻¹ᶠ) ≡⟨ sym (·-assoc _ _ _) ∙ cong (b ·_) (·-rinv c it) ∙ fst (·-identity b)  ⟩
   b ∎

·-preserves-≡ʳ : {a b : F} (c : F) {{_ : c # 0f}} → a · c ≡ b · c → a ≡ b
·-preserves-≡ʳ = simplR

-- ·-linv-unique : (x y : F) (x·y≡1 : (x ·₁ y) ≡ 1f) → x ≡ (y ⁻¹ᶠ₁)
module _ (x y : F) (x·y≡1 : x · y ≡ 1f) where
  y#0 = snd (·-inv-back _ _ x·y≡1) -- duplicated inhabitant (see notes)
  instance _ = y # 0f ∋ y#0
  import Cubical.Structures.Group

  -- NOTE: ported from Cubical.Structures.Group.GroupLemmas
  abstract
    ·-linv-unique' : Σ[ p ∈ y # 0f ] (x ≡ _⁻¹ᶠ y {{p}})
    ·-linv-unique' = it , (
      x · y ≡ 1f        ⇒⟨ transport (λ i → x · y ≡ ·-linv y it (~ i)) ⟩
      x · y ≡ y ⁻¹ᶠ · y ⇒⟨ simplR _  ⟩
      x     ≡ y ⁻¹ᶠ     ◼) x·y≡1

·-linv-unique : (x y : F) → ((x · y) ≡ 1f) → Σ[ p ∈ y # 0f ] x ≡ (_⁻¹ᶠ y {{p}})
·-linv-unique = ·-linv-unique'

-- ⁻¹ᶠ-involutive : (x : F) (z#0 : x #' 0f) → ((x ⁻¹ᶠ₁) ⁻¹ᶠ₁) ≡ x
module _ (z : F) (z#0 : z # 0f) where
  private
    instance _ = z#0
    z⁻¹ = z ⁻¹ᶠ -- NOTE: interestingly, the instance argument is not applied and y remains normalized in terms of z
              --       so we get `y : {{ _ : z #' 0f }} → F` here
    z⁻¹#0 = snd (·-inv-back z z⁻¹ (·-rinv z it))
    -- NOTE: for some reason I get "There are instances whose type is still unsolved when checking that the expression it has type z #' 0f"
    --       typing `y : F` did not help much. therefore this goes in two lines
    instance _ = z⁻¹#0
    z⁻¹⁻¹ = z⁻¹ ⁻¹ᶠ

  -- NOTE: this should be similar to `right-helper` + `-involutive`
  ⁻¹ᶠ-involutive : (z ⁻¹ᶠ) ⁻¹ᶠ ≡ z
  ⁻¹ᶠ-involutive = (
     z⁻¹⁻¹              ≡⟨ sym (fst (·-identity _)) ⟩
     z⁻¹⁻¹ ·      1f    ≡⟨ (λ i →  z⁻¹⁻¹ · ·-linv _ it (~ i)) ⟩
     z⁻¹⁻¹ · (z⁻¹  · z) ≡⟨ ·-assoc _ _ _ ⟩
    (z⁻¹⁻¹ ·  z⁻¹) · z  ≡⟨ (λ i → ·-linv z⁻¹ it i · z) ⟩
          1f       · z  ≡⟨  snd (·-identity _)  ⟩
                     z  ∎)

module forward -- 6. ⇒ 1. 2. 3. 4. 5.
  -- 6. (†)
  (+-<-extensional : ∀ w x y z → (x + y) < (z + w) → (x < z) ⊎ (y < w))
  -- 6. (∗)
  (·-preserves-< : ∀ x y z → 0f < z → x < y → (x · z) < (y · z))
  where
  -- abstract
    --  1. x ≤ y ⇔ ¬(y < x),
    item-1 : ∀ x y → x ≤ y → ¬(y < x)
    item-1 = λ _ _ x≤y → x≤y -- holds definitionally

    item-1-back : ∀ x y → ¬(y < x) → x ≤ y
    item-1-back = λ _ _ ¬[y<x] → ¬[y<x]

    --  2. x # y ⇔ (x < y) ∨ (y < x)
    item-2 : ∀ x y → x # y → (x < y) ⊎ (y < x)
    item-2 = λ _ _ x#y → x#y -- holds definitionally

    item-2-back : ∀ x y → (x < y) ⊎ (y < x) → x # y
    item-2-back = λ _ _ [x<y]⊎[y<x] → [x<y]⊎[y<x] -- holds definitionally

    -- NOTE: just a plain copy of the previous proof
    +-preserves-< : ∀ a b x → a < b → a + x < b + x
    +-preserves-< a b x a<b = (
       a            <  b            ⇒⟨ transport (λ i → sym (fst (+-identity a)) i < sym (fst (+-identity b)) i) ⟩
       a +    0f    <  b +    0f    ⇒⟨ transport (λ i → a + sym (+-rinv x) i < b + sym (+-rinv x) i) ⟩
       a + (x  - x) <  b + (x  - x) ⇒⟨ transport (λ i → +-assoc a x (- x) i < +-assoc b x (- x) i) ⟩
      (a +  x) - x  < (b +  x) - x  ⇒⟨ +-<-extensional (- x) (a + x) (- x) (b + x) ⟩
      (a + x < b + x) ⊎ (- x < - x) ⇒⟨ (λ{ (inl a+x<b+x) → a+x<b+x -- somehow ⊥-elim needs a hint in the next line
                                         ; (inr  -x<-x ) → ⊥-elim {A = λ _ → (a + x < b + x)} (<-irrefl (- x) -x<-x) }) ⟩
       a + x < b + x ◼) a<b

    +-preserves-<-back : ∀ x y z → x + z < y + z → x < y
    +-preserves-<-back x y z =
      ( x + z < y + z              ⇒⟨ +-preserves-< _ _ (- z) ⟩
        (x + z) - z  < (y + z) - z ⇒⟨ transport (λ i → +-assoc x z (- z) (~ i) < +-assoc y z (- z) (~ i)) ⟩
        x + (z - z) < y + (z - z)  ⇒⟨ transport (λ i → x + +-rinv z i < y + +-rinv z i) ⟩
        x + 0f < y + 0f            ⇒⟨ transport (λ i → fst (+-identity x) i < fst (+-identity y) i) ⟩
        x < y ◼)

    --  3. x ≤ y ⇔ x + z ≤ y + z,
    item-3 : ∀ x y z → x ≤ y → x + z ≤ y + z
    item-3 x y z = (
       x     ≤ y          ⇒⟨ (λ z → z) ⟩ -- unfold the definition
      (y     < x     → ⊥) ⇒⟨ (λ f → f ∘ (+-preserves-<-back y x z) ) ⟩
      (y + z < x + z → ⊥) ⇒⟨ (λ z → z) ⟩ -- refold the definition
       x + z ≤ y + z ◼)

    item-3-back : ∀ x y z → x + z ≤ y + z → x ≤ y
    item-3-back x y z = (
       x + z ≤ y + z      ⇒⟨ (λ z → z) ⟩ -- unfold the definition
      (y + z < x + z → ⊥) ⇒⟨ (λ f p → f (+-preserves-< y x z p)) ⟩ -- just a variant of the above
      (y     < x     → ⊥) ⇒⟨ (λ z → z) ⟩ -- refold the definition
       x     ≤ y ◼)

    --  4. x < y ⇔ x + z < y + z,
    item-4 : ∀ x y z → x < y → x + z < y + z
    item-4 = +-preserves-<

    item-4-back : ∀ x y z → x + z < y + z → x < y
    item-4-back = +-preserves-<-back

    --  5. 0 < x + y ⇒ 0 < x ∨ 0 < y,
    item-5 : ∀ x y → 0f < x + y → (0f < x) ⊎ (0f < y)
    item-5 x y = (
      (0f      < x + y) ⇒⟨ transport (λ i → fst (+-identity 0f) (~ i) < x + y) ⟩
      (0f + 0f < x + y) ⇒⟨ +-<-extensional y 0f 0f x ⟩
      (0f < x) ⊎ (0f < y) ◼)

    --  6. x < y ≤ z ⇒ x < z,
    item-6 : ∀ x y z → x < y → y ≤ z → x < z
    item-6 x y z x<y y≤z = (
       x      <  y      ⇒⟨ +-preserves-< _ _ _ ⟩
       x + z  <  y + z  ⇒⟨ transport (λ i → x + z < +-comm y z i) ⟩
       x + z  <  z + y  ⇒⟨ +-<-extensional y x z z  ⟩
      (x < z) ⊎ (z < y) ⇒⟨ (λ{ (inl x<z) → x<z
                             ; (inr z<y) → ⊥-elim (y≤z z<y) }) ⟩
       x < z  ◼) x<y

    --  7. x ≤ y < z ⇒ x < z,
    item-7 : ∀ x y z → x ≤ y → y < z → x < z
    item-7 x y z x≤y = ( -- very similar to the previous one
       y      <  z      ⇒⟨ +-preserves-< y z x ⟩
       y + x  <  z + x  ⇒⟨ transport (λ i → +-comm y x i < z + x) ⟩
       x + y  <  z + x  ⇒⟨ +-<-extensional x x y z ⟩
      (x < z) ⊎ (y < x) ⇒⟨ (λ{ (inl x<z) → x<z
                             ; (inr y<x) → ⊥-elim (x≤y y<x)}) ⟩
       x < z  ◼)

    item-10 : 0f < 1f

    module _ (z : F) (0<z : 0f < z) where
      private
        instance _ = z # 0f ∋ inr 0<z
        z⁻¹ = z ⁻¹ᶠ
        z⁻¹#0 = snd (·-inv-back z z⁻¹ (·-rinv z it))
      abstract
        ⁻¹ᶠ-preserves-sign : 0f < z ⁻¹ᶠ
        ⁻¹ᶠ-preserves-sign with z⁻¹#0
        ... | inl z⁻¹<0 = (
          z⁻¹     < 0f     ⇒⟨ ·-preserves-< _ _ z 0<z ⟩
          z⁻¹ · z < 0f · z ⇒⟨ transport (λ i → ·-linv z it i <  0-leftNullifies z i) ⟩
          1f      < 0f     ⇒⟨ <-trans _ _ _ item-10 ⟩
          0f      < 0f     ⇒⟨ <-irrefl _ ⟩
                  ⊥        ⇒⟨ ⊥-elim ⟩ _ ◼) z⁻¹<0
        ... | inr 0<z⁻¹ = 0<z⁻¹

    --  8. x ≤ y ∧ 0 ≤ z ⇒ x z ≤ y z,
    item-8 : ∀ x y z → x ≤ y → 0f ≤ z → x · z ≤ y · z
    -- For item 8, suppose x ≤ y and 0 ≤ z and yz < xz.
    item-8 x y z x≤y 0≤z y·z<x·z = let
      -- Then 0 < z (x − y) by (†),
      i   = (  y · z            <  x · z                ⇒⟨ transport (λ i → ·-comm y z i < ·-comm x z i) ⟩
               z · y            <  z · x                ⇒⟨ +-preserves-< _ _ _ ⟩
              (z · y) - (z · y) < (z · x) - (z ·    y ) ⇒⟨ transport (cong₂ _<_ (+-rinv (z · y))
                                                             ( λ i → (z · x) + sym (-commutesWithRight-· z y) i )) ⟩
                             0f < (z · x) + (z · (- y)) ⇒⟨ transport (cong₂ _<_ refl (sym (fst (dist z x (- y))))) ⟩ -- [XX]
                             0f <  z · (x - y) ◼) y·z<x·z
      instance _ = z · (x - y) # 0f ∋ inr i
      -- and so, being apart from 0, z (x − y) has a multiplicative inverse w.
      w   = (z · (x - y)) ⁻¹ᶠ
      ii  : 1f ≡ (z · (x - y)) · w
      ii  = sym (·-rinv _ _)
      -- Hence z itself has a multiplicative inverse w (x − y),
      iii : 1f ≡ z · ((x - y) · w)
      iii = transport (λ i → 1f ≡ ·-assoc z (x - y) w (~ i)) ii
      instance z#0f = z # 0f ∋ fst (·-inv-back _ _ (sym iii))
      -- and so 0 < z ∨ z < 0, where the latter case contradicts the assumption 0 ≤ z, so that we have 0 < z.
      instance _    = 0f < z ∋ case z#0f of λ where
                      (inl z<0) → ⊥-elim (0≤z z<0)
                      (inr 0<z) → 0<z
      -- Now w (x − y) has multiplicative inverse z, so it is apart from 0,
      iv  :  (x - y) · w # 0f
      iv  = snd (·-inv-back _ _ (sym iii))
      -- that is (0 < w (x − y)) ∨ (w (x − y) < 0).
      in case iv of λ where
        -- By (∗), from 0 < w (x − y) and yz < xz we get yzw (x − y) < xzw (x − y), so y < x, contradicting our assumption that x ≤ y.
        (inr 0<[x-y]·w) → (
           y ·  z                   <  x ·  z                    ⇒⟨ ·-preserves-< _ _ _ 0<[x-y]·w ⟩
          (y ·  z) · ((x - y) · w)  < (x ·  z) · ((x - y) · w)   ⇒⟨ transport (λ i →
                                                                        (·-assoc y z ((x - y) · w)) (~ i)
                                                                      < (·-assoc x z ((x - y) · w)) (~ i)) ⟩
           y · (z  · ((x - y) · w)) <  x · (z  · ((x - y) · w))  ⇒⟨ transport (λ i →
                                                                       y · (iii (~ i)) < x · (iii (~ i))) ⟩
           y · 1f                   <  x · 1f                    ⇒⟨ transport (cong₂ _<_
                                                                      (fst (·-identity y)) (fst (·-identity x))) ⟩
           y                        <  x                         ⇒⟨ x≤y ⟩
          ⊥ ◼) y·z<x·z
        -- In the latter case, from (∗) we get zw (x − y) < 0, i.e.
        -- 1 < 0 which contradicts item 10, so that we have 0 < w (x − y).
        (inl p) → (
               (x - y) · w      < 0f     ⇒⟨ ·-preserves-< _ _ _ it ⟩
              ((x - y) · w) · z < 0f · z ⇒⟨ transport (cong₂ _<_ (·-comm _ _) (0-leftNullifies z)) ⟩
          z · ((x - y) · w)     < 0f     ⇒⟨ ( transport λ i → iii (~ i) < 0f) ⟩
                             1f < 0f     ⇒⟨ <-trans _ _ _  item-10 ⟩
                             0f < 0f     ⇒⟨ <-irrefl _ ⟩
          ⊥ ◼) p

    --  9. 0 < z ⇒ (x < y ⇔ x z < y z),
    item-9 : ∀ x y z → 0f < z → (x < y → x · z < y · z)
    item-9 = ·-preserves-<

    item-9-back : ∀ x y z → 0f < z → (x · z < y · z → x < y)
    -- For the other direction of item 9, assume 0 < z and xz < yz,
    item-9-back x y z 0<z x·z<y·z = let
      instance _ = (          x · z  <  y · z            ⇒⟨ +-preserves-< _ _ _ ⟩
                   (x · z) - (x · z) < (y · z) - (x · z) ⇒⟨ transport (cong₂ _<_ (+-rinv (x · z)) refl) ⟩
                                  0f < (y · z) - (x · z) ◼) x·z<y·z
               _ = (y · z) - (x · z) # 0f ∋ inr it
      -- so that yz − xz has a multiplicative inverse w,
      w = ((y · z) - (x · z)) ⁻¹ᶠ
      o = ( (y · z) - (   x  · z) ≡⟨ ( λ i → (y · z) + (-commutesWithLeft-· x z) (~ i)) ⟩
            (y · z) + ((- x) · z) ≡⟨ sym (snd (dist y (- x) z)) ⟩
            (y - x) · z ∎)
      instance _ = (y - x) · z # 0f ∋  transport (λ i → o i # 0f) it
      -- and so z itself has multiplicative inverse w (y − x).
      1≡z·[w·[y-x]] = γ
      iii = 1≡z·[w·[y-x]]
      1≡[w·[y-x]]·z : 1f ≡ (w · (y - x)) · z
      1≡[w·[y-x]]·z = transport (λ i → 1f ≡ ·-comm z (w · (y - x)) i) 1≡z·[w·[y-x]]
      -- Then since 0 < z and xz < yz, by (∗), we get xzw (y − x) < yzw (y − x), and hence x < y.
      instance _ = z # 0f ∋ inr 0<z
      z⁻¹ = w · (y - x)
      z⁻¹≡w·[y-x] : z ⁻¹ᶠ ≡ (w · (y - x))
      z⁻¹≡w·[y-x] = let tmp = sym (snd (·-linv-unique (w · (y - x)) z (sym 1≡[w·[y-x]]·z)))
                    in transport (cong (λ z#0 → _⁻¹ᶠ z {{z#0}} ≡ (w · (y - x))) (#-isProp z 0f _ _)) tmp
      0<z⁻¹ : 0f < z ⁻¹ᶠ
      0<z⁻¹ = ⁻¹ᶠ-preserves-sign z 0<z
      instance _ = 0f < w · (y - x) ∋ transport (λ i → 0f < z⁻¹≡w·[y-x] i) 0<z⁻¹
      -- instance _ = 0f < z⁻¹ ∋ ?
      in (  x ·  z         <  y ·  z         ⇒⟨ ·-preserves-< _ _ z⁻¹ it ⟩
           (x ·  z) · z⁻¹  < (y ·  z) · z⁻¹  ⇒⟨ transport (λ i → ·-assoc x z z⁻¹ (~ i) < ·-assoc y z z⁻¹ (~ i)) ⟩
            x · (z  · z⁻¹) <  y · (z  · z⁻¹) ⇒⟨ transport (λ i → x · iii (~ i) < y · iii (~ i)) ⟩
            x · 1f         <  y · 1f         ⇒⟨ transport (cong₂ _<_ (fst (·-identity x)) (fst (·-identity y))) ⟩
            x              <  y              ◼) x·z<y·z
      where
        abstract -- NOTE: `abstract` is only allowed in `where` blocks and `where` blocks are not allowed in `let` blocks
          γ =
            let -- NOTE: for some reason the instance resolution does only work in let-blocks
            -- I get a "Terms marked as eligible for instance search should end with a name, so `instance' is ignored here. when checking the definition of my-instance"
            instance my-instance = (          x · z  <  y · z            ⇒⟨ +-preserves-< _ _ _ ⟩
                         (x · z) - (x · z) < (y · z) - (x · z) ⇒⟨ transport (cong₂ _<_ (+-rinv (x · z)) refl) ⟩
                                        0f < (y · z) - (x · z) ◼) x·z<y·z
                     _ = (y · z) - (x · z) # 0f ∋ inr it
            -- so that yz − xz has a multiplicative inverse w,
            w = ((y · z) - (x · z)) ⁻¹ᶠ
            o = ( (y · z) - (   x  · z) ≡⟨ ( λ i → (y · z) + (-commutesWithLeft-· x z) (~ i)) ⟩
                  (y · z) + ((- x) · z) ≡⟨ sym (snd (dist y (- x) z)) ⟩
                  (y - x) · z ∎)
            instance _ = (y - x) · z # 0f ∋  transport (λ i → o i # 0f) it
            in (
              1f                      ≡⟨ (λ i → ·-linv ((y · z) - (x · z)) it (~ i)) ⟩
              w · ((y · z) - (x · z)) ≡⟨ (λ i → w · o i) ⟩
              w · ((y - x) · z)       ≡⟨ (λ i → w · ·-comm (y - x) z i ) ⟩
              w · (z · (y - x))       ≡⟨ (λ i → ·-assoc w z (y - x) i) ⟩
              (w · z) · (y - x)       ≡⟨ (λ i → ·-comm w z i · (y - x)) ⟩
              (z · w) · (y - x)       ≡⟨ (λ i → ·-assoc z w (y - x) (~ i)) ⟩
              z · (w · (y - x))       ∎)

    -- 10. 0 < 1.
    item-10 with snd (·-inv-back _ _ (fst (·-identity 1f)))
    -- For item 10, since 1 has multiplicative inverse 1, it is apart from 0, hence 0 < 1 ∨ 1 < 0.
    ... | inl 1<0 =
      -- If 1 < 0 then by item 4 we have 0 < −1 and so by (∗) we get 0 < (−1) · (−1), that is, 0 < 1, so by transitivity 1 < 1, contradicting irreflexivity of <.
       (1f          < 0f                ⇒⟨ +-preserves-< 1f 0f (- 1f) ⟩
        1f    - 1f  < 0f - 1f           ⇒⟨ transport (λ i → +-rinv 1f i < snd (+-identity (- 1f)) i) ⟩
        0f          <    - 1f           ⇒⟨ ( λ 0<-1 → ·-preserves-< 0f (- 1f) (- 1f) 0<-1 0<-1) ⟩
        0f · (- 1f) <   (- 1f) · (- 1f) ⇒⟨ transport (cong₂ _<_ (0-leftNullifies (- 1f)) refl) ⟩
        0f          <   (- 1f) · (- 1f) ⇒⟨ transport (λ i → 0f < -commutesWithRight-· (- 1f) (1f)   i ) ⟩
        0f          < -((- 1f) ·    1f )⇒⟨ transport (λ i → 0f < -commutesWithLeft-·  (- 1f)  1f (~ i)) ⟩
        0f          < (-(- 1f))·    1f  ⇒⟨ transport (λ i → 0f < -involutive 1f i · 1f) ⟩
        0f          <      1f  ·    1f  ⇒⟨ transport (λ i → 0f < fst (·-identity 1f) i) ⟩
        0f          <      1f           ⇒⟨ <-trans _ _ _ 1<0 ⟩
        1f          <      1f           ⇒⟨ <-irrefl 1f ⟩
                    ⊥                   ⇒⟨ ⊥-elim ⟩ _ ◼) 1<0
    ... | inr 0<1 = 0<1

-- Conversely, assume the 10 listed items—in particular, items 4, 5 and 9.
module back -- 1. 2. 3. 4. 5. ⇒ 6.
  -- (item-1      : ∀ x y → x ≤ y → ¬(y < x))
  -- (item-1-back : ∀ x y → ¬(y < x) → x ≤ y)
  -- (item-2      : ∀ x y → x # y → (x < y) ⊎ (y < x))
  -- (item-2-back : ∀ x y → (x < y) ⊎ (y < x) → x # y)
  -- (item-3      : ∀ x y z → x ≤ y → x + z ≤ y + z)
  -- (item-3-back : ∀ x y z → x + z ≤ y + z → x ≤ y)
     (item-4      : ∀ x y z → x < y → x + z < y + z)
  -- (item-4-back : ∀ x y z → x + z < y + z → x < y)
     (item-5      : ∀ x y → 0f < x + y → (0f < x) ⊎ (0f < y))
  -- (item-6      : ∀ x y z → x < y → y ≤ z → x < z)
  -- (item-7      : ∀ x y z → x ≤ y → y < z → x < z)
  -- (item-8      : ∀ x y z → x ≤ y → 0f ≤ z → x · z ≤ y · z)
     (item-9      : ∀ x y z → 0f < z → (x < y → x · z < y · z))
  -- (item-9-back : ∀ x y z → 0f < z → (x · z < y · z → x < y))
  -- (item-10     : 0f < 1f)
  where

  item-4' : ∀ x y → 0f < x - y → y < x
  item-4' x y = (
    0f     <  x - y         ⇒⟨ item-4 0f (x + (- y)) y ⟩
    0f + y < (x - y) + y    ⇒⟨ transport (λ i → snd (+-identity y) i < sym (+-assoc x (- y) y) i) ⟩
         y <  x + (- y + y) ⇒⟨ transport (λ i → y < x + snd (+-inv y) i) ⟩
         y <  x + 0f        ⇒⟨ transport (λ i → y < fst (+-identity x) i)  ⟩
         y <  x ◼)

  lemma : ∀ x y z w → (z +   w) + ((- x)  + (- y)) ≡ (z - x) + (w - y)
  lemma x y z w = (
    -- NOTE: there has to be a shorter way to to this kind of calculations ...
    --       also I got not much introspection while creating the paths
    (z +   w) + ((- x)  + (- y))   ≡⟨ ( λ i → +-assoc z w ((- x)  + (- y)) (~ i)) ⟩
    (z + ( w  + ((- x)  + (- y)))) ≡⟨ ( λ i → z + (+-assoc w (- x) (- y) i)) ⟩
    (z + ((w  +  (- x)) + (- y)))  ≡⟨ ( λ i → z + ((+-comm w (- x) i) + (- y)) ) ⟩
    (z + (((- x) +  w)  + (- y)))  ≡⟨ ( λ i → z + (+-assoc (- x) w (- y) (~ i))) ⟩
    (z + (( - x) + (w - y)))       ≡⟨ ( λ i → +-assoc z (- x) (w  - y) i ) ⟩
    (z - x) + (w - y) ∎)

  -- 6. (†)
  -- In order to show (†), suppose x + y < z + w.
  -- So, by item 4, we get (x + y) − (x + y) < (z + w) − (x + y), that is, 0 < (z − x) + (w − y).
  -- By item 5, (0 < z − x) ∨ (0 < w − y), and so by item 4 in either case, we get x < z ∨ y < w.
  +-<-extensional : ∀ w x y z → (x + y) < (z + w) → (x < z) ⊎ (y < w)
  +-<-extensional w x y z = (
    (x + y)           < (z + w)           ⇒⟨ item-4 (x + y) (z + w) (- (x + y)) ⟩
    (x + y) - (x + y) < (z + w) - (x + y)
      ⇒⟨ transport (λ i → +-rinv (x + y) i < (z + w) + (-isDistributive x y) (~ i))    ⟩

                   0f < (z +   w) + ((- x)  + (- y))   ⇒⟨ transport (λ i → 0f < lemma x y z w i) ⟩
                   0f < (z - x) + (w - y) ⇒⟨ item-5 (z - x) (w - y) ⟩
    (0f < z - x) ⊎ (0f < w - y)           ⇒⟨ (λ{ (inl p) → inl (item-4' z x p)
                                               ; (inr p) → inr (item-4' w y p)}) ⟩
    ( x < z    ) ⊎ ( y < w    ) ◼)

  -- 6. (∗)
  ·-preserves-< : ∀ x y z → 0f < z → x < y → (x · z) < (y · z)
  ·-preserves-< = item-9


module Categories.Initial where

open import Library
open import Categories
open import Categories.Sets
open Cat

record Init {a b} (C : Cat {a}{b})(I : Obj C) : Set (a ⊔ b) where
  constructor init
  field i : ∀{X} → Hom C I X
        law : ∀{X}{f : Hom C I X} → i {X} ≅ f

ZeroSet : Init Sets ⊥
ZeroSet = record {i = λ(); law = ext λ()}


Finite : Domain → Formula
Finite(s) = ∃ₛ(ℕ)(n ↦ s ≼ 𝕟(n)) -- TODO: Now this means that there is an injection (s → 𝕟(n)), which is equivalent to the existance of an surjection (𝕟(n) → s) because stuff that follows from excluded middle (more specifically ((s ≼ 𝕟(n)) ↔ (𝕟(n) ≽ s))). Define ∑ (summation over finite sets) by using the existance of a finite sequence

-- reduce : (_▫_ : Domain → Domain → Domain) → ⦃ _ : Commutativity(_▫_) ⦄ → ⦃ _ : Associativity(_▫_) ⦄ → ⦃ _ : Identity(_▫_) ⦄ → (s : Domain) → ⦃ _ : Finite(s) ⦄ → Domain
-- reduce₀ : (_▫_ : Domain → Domain → Domain) → ⦃ _ : Commutativity(_▫_) ⦄ → ⦃ _ : Associativity(_▫_) ⦄ → (s : Domain) → ⦃ _ : Finite(s) ⦄ → Domain → Domain


module TermUnification where

open import OscarPrelude
open import Delay
open import VariableName
open import FunctionName
open import Arity
open import Vector
open import Term

mutual
  substituteTerm⇑ : VariableName → Term → ∀ {i} → Term → Delay i Term
  substituteTerm⇑ 𝑥ₛ τₛ τ@(variable 𝑥)  = now $ ifYes 𝑥ₛ ≟ 𝑥 then τₛ else τ
  substituteTerm⇑ 𝑥ₛ τₛ (function 𝑓 τs) =
    substituteTerms⇑ 𝑥ₛ τₛ τs >>= λ τsₛ →
    now $ function 𝑓 τsₛ

  substituteTerms⇑ : VariableName → Term → ∀ {i} → Terms → Delay i Terms
  substituteTerms⇑ 𝑥ₛ τₛ ⟨ ⟨ [] ⟩ ⟩ = now ⟨ ⟨ [] ⟩ ⟩
  substituteTerms⇑ 𝑥ₛ τₛ ⟨ ⟨ τ ∷ τs ⟩ ⟩ =
    let τs = substituteTerms⇑ 𝑥ₛ τₛ ⟨ ⟨ τs ⟩ ⟩
        τ = substituteTerm⇑ 𝑥ₛ τₛ τ in
    τs >>= λ { ⟨ ⟨ τs ⟩ ⟩ →
    τ >>= λ { τ →
    now $ ⟨ ⟨ τ ∷ τs ⟩ ⟩ } }

substituteTerms⇓ : (𝑥ₛ : VariableName) → (τₛ : Term) → (τs : Terms) → substituteTerms⇑ 𝑥ₛ τₛ τs ⇓
substituteTerms⇓ 𝑥ₛ τₛ ⟨ ⟨ [] ⟩ ⟩ = _ , now⇓
substituteTerms⇓ 𝑥ₛ τₛ ⟨ ⟨ (variable 𝑥) ∷ τs ⟩ ⟩ = _ , substituteTerms⇓ 𝑥ₛ τₛ ⟨ ⟨ τs ⟩ ⟩ ⇓>>=⇓ now⇓
substituteTerms⇓ 𝑥ₛ τₛ ⟨ ⟨ (function 𝑓 τs₁) ∷ τs ⟩ ⟩ = _ , substituteTerms⇓ 𝑥ₛ τₛ ⟨ ⟨ τs ⟩ ⟩ ⇓>>=⇓ ((substituteTerms⇓ 𝑥ₛ τₛ τs₁ ⇓>>=⇓ now⇓) >>=⇓ now⇓)

substituteTerm⇓ : (𝑥ₛ : VariableName) → (τₛ : Term) → (τ : Term) → substituteTerm⇑ 𝑥ₛ τₛ τ ⇓
substituteTerm⇓ 𝑥ₛ τₛ (variable 𝑥) = _ , now⇓
substituteTerm⇓ 𝑥ₛ τₛ (function 𝑓 τs) = _ , substituteTerms⇓ 𝑥ₛ τₛ τs ⇓>>=⇓ now⇓

substitute : VariableName → Term → Term → Term
substitute 𝑥ₛ τₛ τ = fst $ substituteTerm⇓ 𝑥ₛ τₛ τ

data AListOfSubstitutions : Set
 where
  [] : AListOfSubstitutions
  _∷_ : VariableName × Term → AListOfSubstitutions → AListOfSubstitutions

substituteA : AListOfSubstitutions → Term → Term
substituteA [] τ = τ
substituteA ((𝑥ₛ , τₛ) ∷ as) τ = substituteA as (substitute 𝑥ₛ τₛ τ)

record Unifier (τ₁ τ₂ : Term) : Set
 where
  field
    u₁ u₂ : AListOfSubstitutions
    unifier-law : substituteA u₁ τ₁ ≡ substituteA u₂ τ₂

unify? : (τ₁ τ₂ : Term) → Dec $ Unifier τ₁ τ₂
unify? (variable x) (variable x₁) = {!!}
unify? (variable x) (function x₁ x₂) = {!!}
unify? (function x x₁) (variable x₂) = {!!}
unify? (function 𝑓₁ x₁) (function 𝑓₂ x₃) with 𝑓₁ ≟ 𝑓₂
unify? (function 𝑓₁ x₁) (function .𝑓₁ x₃) | yes refl = {!!}
unify? (function 𝑓₁ x₁) (function 𝑓₂ x₃) | no 𝑓₁≢𝑓₂ = no (λ { record { u₁ = u₁ ; u₂ = u₂ ; unifier-law = unifier-law } → {!!}})


module MetaOccursInItself where

data List (A : Set) : Set where
  nil  : List A
  _::_ : A -> List A -> List A

data One : Set where one : One

postulate
  f : (A : Set) -> (A -> List A) -> One

err : One
err = f _ (\x -> x)


{-# OPTIONS --safe #-}
module Cubical.Algebra.DirectSum.DirectSumFun.Base where

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

open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.Algebra.AbGroup

private variable
  ℓ : Level

open AbGroupStr

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

AlmostNullProof : (G : ℕ → Type ℓ) → (Gstr : (n : ℕ) → AbGroupStr (G n))
                  → (f : (n : ℕ) → G n) → (k : ℕ) → Type ℓ
AlmostNullProof G Gstr f k = (n : ℕ) → k < n → f n ≡ 0g (Gstr n)

AlmostNull : (G : ℕ → Type ℓ) → (Gstr : (n : ℕ) → AbGroupStr (G n))
             → (f : (n : ℕ) → G n) → Type ℓ
AlmostNull G Gstr f = Σ[ k ∈ ℕ ] AlmostNullProof G Gstr f k

AlmostNullP : (G : ℕ → Type ℓ) → (Gstr : (n : ℕ) → AbGroupStr (G n))
             → (f : (n : ℕ) → G n) → Type ℓ
AlmostNullP G Gstr f = ∥ (AlmostNull G Gstr f) ∥₁

⊕Fun : (G : ℕ → Type ℓ) → (Gstr : (n : ℕ) → AbGroupStr (G n)) → Type ℓ
⊕Fun G Gstr = Σ[ f ∈ ((n : ℕ) → G n) ] AlmostNullP G Gstr f


-- Copyright 2019, Xuanrui Qi
-- Original algorithm by: Jacques Garrigue, Xuanrui Qi & Kazunari Tanaka
open import Data.Nat hiding (compare)
open import Data.Nat.Properties
open import Relation.Binary
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; subst; sym; inspect; [_])
open Eq.≡-Reasoning
open import Data.Product
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Unit using (⊤; tt)

module RedBlack
  {c r} {A : Set c} {_<_ : Rel A r}
  (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_)
  where

  open IsStrictTotalOrder isStrictTotalOrder

  data Color : Set where
    Red : Color
    Black : Color

  incr-Black : ℕ → Color → ℕ
  incr-Black d Black = suc d
  incr-Black d Red   = d

  color-valid : Color → Color → Set
  color-valid Red Red = ⊥
  color-valid _ _ = ⊤

  inv : Color → Color
  inv Red = Black
  inv Black = Red

  valid-*-Black : ∀ c → color-valid c Black
  valid-*-Black Red = tt
  valid-*-Black Black = tt

  data Tree : ℕ → Color → Set c where
    Leaf : Tree 0 Black
    Node : ∀ {d cₗ cᵣ} c → color-valid c cₗ → color-valid c cᵣ →
           Tree d cₗ → A → Tree d cᵣ → Tree (incr-Black d c) c

  RNode : ∀ {d} → Tree d Black → A → Tree d Black → Tree d Red
  RNode = Node Red tt tt

  BNode : ∀ {d cₗ cᵣ} → Tree d cₗ → A → Tree d cᵣ → Tree (suc d) Black
  BNode = Node Black tt tt

  -- Insertion algorithm
  data InsTree : ℕ → Color → Set c where
    Fix : ∀ {d} → Tree d Black → A → Tree d Black → A → Tree d Black → InsTree d Red
    T : ∀ {d c} cₚ → Tree d c → InsTree d cₚ

  InsTree-color : ∀ {d c} → InsTree d c → Color
  InsTree-color (Fix _ _ _ _ _) = Red
  InsTree-color (T _ _) = Black

  fix-color : ∀ {d c} → InsTree d c → Color
  fix-color (Fix _ _ _ _ _) = Black
  fix-color (T {c = c} _ _) = c

  fix-InsTree : ∀ {d c} → (t : InsTree d c) → Tree (incr-Black d (inv (InsTree-color t))) (fix-color t)
  fix-InsTree (Fix t₁ x t₂ y t₃) = BNode (RNode t₁ x t₂) y t₃
  fix-InsTree (T _ t) = t

  balanceₗ : ∀ {d cₗ cᵣ} c → (l : InsTree d cₗ) → A → Tree d cᵣ → color-valid c (InsTree-color l) → color-valid c cᵣ → InsTree (incr-Black d c) c
  balanceₗ Black (Fix t₁ x t₂ y t₃) z t₄ _ _ = T Black (RNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  balanceₗ Black (T _ l) v r _ _ = T Black (BNode l v r)
  balanceₗ {cᵣ = Black} Red (T _ (Node {cₗ = Black} {cᵣ = Black} Red _ _ t₁ x t₂)) y t₃ _ _ = Fix t₁ x t₂ y t₃
  balanceₗ {cᵣ = Black} Red (T {c = Black} _ l) v r _ _ = T Red (RNode l v r)

  balanceᵣ : ∀ {d cₗ cᵣ} c → Tree d cₗ → A → (r : InsTree d cᵣ) → color-valid c cₗ → color-valid c (InsTree-color r) → InsTree (incr-Black d c) c
  balanceᵣ Black t₁ x (Fix t₂ y t₃ z t₄) _ _ = T Black (RNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  balanceᵣ Black l v (T _ r) _ _ = T Black (BNode l v r)
  balanceᵣ {cₗ = Black} Red t₁ x (T _ (Node {cₗ = Black} {cᵣ = Black} Red _ _ t₂ y t₃)) _ _ = Fix t₁ x t₂ y t₃
  balanceᵣ {cₗ = Black} Red l v (T {c = Black} _ r) _ _ = T Red (RNode l v r)

  ins : ∀ {d c} → A → Tree d c → InsTree d c
  ins x Leaf = T Black (RNode Leaf x Leaf)
  ins x (Node c _ _ l v r) with (compare x v)
  ins x (Node c _ _ l v r)    | tri< x<v _ _ with ins x l | inspect (ins x) l
  ins x (Node Black _ validᵣ l v r) | _ | Fix _ _ _ _ _   | [ insₗ ] = balanceₗ Black (ins x l) v r tt tt
  ins x (Node c     _ validᵣ l v r) | _ | T _ _           | [ insₗ ] = balanceₗ c (ins x l) v r validₗ validᵣ
    where
      validₗ = subst (λ t → color-valid c (InsTree-color t)) (sym insₗ) (valid-*-Black c)
  ins x t@(Node c _ _ l v r)  | tri≈ _ x≡v _ = T _ t
  ins x (Node c _ _ l v r)    | tri> _ _ x>v with ins x r | inspect (ins x) r
  ins x (Node Black validₗ _ l v r) | _ | Fix _ _ _ _ _   | [ insᵣ ] = balanceᵣ Black l v (ins x r) tt tt
  ins x (Node c     validₗ _ l v r) | _ | T _ _           | [ insᵣ ] = balanceᵣ c l v (ins x r) validₗ validᵣ
    where
      validᵣ = subst (λ t → color-valid c (InsTree-color t)) (sym insᵣ) (valid-*-Black c)

  blacken : ∀ {d c} → Tree d c → Tree (incr-Black d (inv c)) Black
  blacken Leaf = Leaf
  blacken (Node Black _ _ l v r) = BNode l v r
  blacken (Node Red _ _ l v r) = BNode l v r

  insert : ∀ {d} → A → Tree d Black → ∃ (λ d' → Tree d' Black)
  insert {d = d} x t with ins x t
  ... | T {c = c} _ t' = (incr-Black d (inv c) , blacken t')

  -- Deletion algorithm
  data DelTree : ℕ → Color → Set c where
    Stay : ∀ {d c} cₚ → color-valid c (inv cₚ) → Tree d c → DelTree d cₚ
    Down : ∀ {d} → Tree d Black → DelTree (suc d) Black

  bal-right : ∀ {d cₗ cᵣ} c → Tree d cₗ → A → DelTree d cᵣ → color-valid c cₗ → color-valid c cᵣ → DelTree (incr-Black d c) c
  bal-right {cₗ = Black} Red l v (Stay {c = Black} _ _ r) _ _ = Stay Red tt (RNode l v r)
  bal-right {cₗ = Black} Red l v (Stay {c = Red} Red _ _) _ ()
  bal-right Red (Node {cᵣ = Black} Black _ _ t₁ x t₂) y (Down t₃) _ _ = Stay Red tt (BNode t₁ x (RNode t₂ y t₃))
  bal-right Red (Node {cᵣ = Red} Black _ _ t₁ x (Node _ _ _ t₂ y t₃)) z (Down t₄) _ _ = Stay Red tt (RNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  bal-right Black l v (Stay _ _ r) _ _ = Stay Black tt (BNode l v r)
  bal-right Black (Node {cᵣ = Red} Black _ _ t₁ x (Node _ _ _ t₂ y t₃)) z (Down t₄) _ _ = Stay Black tt (BNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  bal-right Black (Node {cₗ = Black} {cᵣ = Black} Red _ _ t₁ x (Node {cᵣ = Black} _ _ _ t₂ y t₃)) z (Down t₄) _ _ =
    Stay Black tt (BNode t₁ x (BNode t₂ y (RNode t₃ z t₄)))
  bal-right Black (Node {cₗ = Black} {cᵣ = Black} Red _ _ t₁ x (Node {cᵣ = Red} _ _ _ t₂ y (Node {cₗ = Black} {cᵣ = Black} _ _ _ t₃ z t₄))) w (Down t₅) _ _ =
    Stay Black tt (BNode t₁ x (RNode (BNode t₂ y t₃) z (BNode t₄ w t₅)))
  bal-right Black (Node {cᵣ = Black} Black _ _ t₁ x t₂) y (Down t₃) _ _ = Down (BNode t₁ x (RNode t₂ y t₃))

  bal-left : ∀ {d cₗ cᵣ} c → DelTree d cₗ → A → Tree d cᵣ → color-valid c cₗ → color-valid c cᵣ → DelTree (incr-Black d c) c
  bal-left {cₗ = Black} {cᵣ = Black} Red (Stay {c = Black} _ _ l) v r _ _ = Stay Red tt (RNode l v r)
  bal-left {cₗ = Black} {cᵣ = Black} Red (Stay {c = Red} _ () l) v r _ _
  bal-left {cₗ = Black} {cᵣ = Black} Red (Down t₁) x (Node {cₗ = Red} _ _ _ (Node {cₗ = Black} {cᵣ = Black} _ _ _ t₂ y t₃) z t₄) _ _ =
    Stay Red tt (RNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  bal-left {cₗ = Black} {cᵣ = Black} Red (Down t₁) x (Node {cₗ = Black} _ _ _ t₂ y t₃) _ _ = Stay Red tt (BNode (RNode t₁ x t₂) y t₃)
  bal-left Black (Stay _ _ l) v r _ _ = Stay Black tt (BNode l v r)
  bal-left {cᵣ = Black} Black (Down t₁) x (Node {cₗ = Red} Black _ _ (Node {cₗ = Black} {cᵣ = Black} _ _ _ t₂ y t₃) z t₄) _ _ =
    Stay Black tt (BNode (BNode t₁ x t₂) y (BNode t₃ z t₄))
  bal-left {cᵣ = Red} Black (Down t₁) x (Node {cₗ = Black} {cᵣ = Black} _ _ _ (Node {cₗ = Red} Black _ _ (Node {cₗ = Black} {cᵣ = Black} _ _ _ t₂ y t₃) z t₄) w t₅) _ _ =
    Stay Black tt (BNode (BNode t₁ x t₂) y (RNode (BNode t₃ z t₄) w t₅))
  bal-left {cᵣ = Red} Black (Down t₁) x (Node {cₗ = Black} {cᵣ = Black} _ _ _ (Node {cₗ = Black} _ _ _ t₂ y t₃) z t₄) _ _ =
    Stay Black tt (BNode (BNode (RNode t₁ x t₂) y t₃) z t₄)
  bal-left {cᵣ = Black} Black (Down t₁) x (Node {cₗ = Black} _ _ _ t₂ y t₃) _ _ = Down (BNode (RNode t₁ x t₂) y t₃)


module 14-implicitConfigurations where

postulate
  Integral : Set → Set
  add : ∀ {A} {{ intA : Integral A }} → A → A → A
  mul : ∀ {A} {{ intA : Integral A }} → A → A → A
  mod : ∀ {A} {{ intA : Integral A }} → A → A → A

  N : Set
  zero one two three : N
  nInt : Integral N

private postulate Token : Set

record Modulus (s : Token) (A : Set) : Set where
  field modulus : A

data M (s : Token) (A : Set) : Set where
  MkM : A → M s A

unMkM : ∀ {A s} → M s A → A
unMkM (MkM a) = a

private postulate theOnlyToken : Token

withModulus :
  ∀ {A} → {{ intA : Integral A }} → (modulus : A) →
  (∀ {s} → {{ mod : Modulus s A }} → M s A) → A
withModulus modulus f = unMkM
  (f {theOnlyToken} {{  record { modulus = modulus }  }})

open Modulus {{...}}

normalize : ∀ {s A} {{intA : Integral A}} {{mod : Modulus s A}} →
            A → M s A
normalize a = MkM (mod modulus a)

_+_ : ∀ {s A} {{intA : Integral A}} {{mod : Modulus s A}} →
      M s A → M s A → M s A
(MkM a) + (MkM b) = normalize (add a b)

_*_ : ∀ {s A} → {{intA : Integral A}} → {{mod : Modulus s A}} →
      M s A → M s A → M s A
(MkM a) * (MkM b) = normalize (mul a b)

test₁ : N
test₁ = withModulus two (let o = MkM one in (o + o)*(o + o))

testExpr : ∀ {s} → {{mod : Modulus s N}} → M s N
testExpr = let o = MkM one ; t = MkM two in
           (o + t) * t

test₂ : N
test₂ = withModulus three testExpr


{-# OPTIONS --safe #-}

module Cubical.Relation.Binary.Extensionality where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Data.Sigma
open import Cubical.Relation.Binary.Base

module _ {ℓ ℓ'} {A : Type ℓ} (_≺_ : Rel A A ℓ') where

  ≡→≺Equiv : (x y : A) → x ≡ y → ∀ z → (z ≺ x) ≃ (z ≺ y)
  ≡→≺Equiv _ _ p z = substEquiv (z ≺_) p

  isWeaklyExtensional : Type _
  isWeaklyExtensional = ∀ {x y} → isEquiv (≡→≺Equiv x y)

  isPropIsWeaklyExtensional : isProp isWeaklyExtensional
  isPropIsWeaklyExtensional = isPropImplicitΠ2 λ _ _ → isPropIsEquiv _


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

open import HoTT

module homotopy.SuspAdjointLoop where

module SuspAdjointLoop {i j} (X : Ptd i) (Y : Ptd j) where

  private
    A = fst X; a₀ = snd X
    B = fst Y; b₀ = snd Y

  R : {b : B}
    → Σ (Suspension A → B) (λ h → h (north A) == b)
    → Σ (A → (b == b)) (λ k → k a₀ == idp)
  R (h , idp) =
    (λ a → ap h (merid A a ∙ ! (merid A a₀))) ,
    ap (ap h) (!-inv-r (merid A a₀))

  L : {b : B}
    → Σ (A → (b == b)) (λ k → k a₀ == idp)
    → Σ (Suspension A → B) (λ h → h (north A) == b)
  L {b} (k , _) = (SuspensionRec.f A b b k) , idp

  {- Show that R ∘ L ∼ idf -}

  R-L : {b : B} → ∀ K → R {b} (L K) == K
  R-L {b} (k , kpt) = ⊙λ= R-L-fst R-L-snd
    where
    R-L-fst : (a : A)
      → ap (SuspensionRec.f A b b k) (merid A a ∙ ! (merid A a₀)) == k a
    R-L-fst a =
      ap-∙ (SuspensionRec.f A b b k) (merid A a) (! (merid A a₀))
      ∙ ap2 _∙_ (SuspensionRec.glue-β A b b k a)
                (ap-! (SuspensionRec.f A b b k) (merid A a₀)
                 ∙ ap ! (SuspensionRec.glue-β A b b k a₀ ∙ kpt))
      ∙ ∙-unit-r (k a)

    -- lemmas generalize to do some path induction for R-L-snd
    lemma₁ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a₁ a₂ : A}
      (p : a₁ == a₂) {q r : f a₁ == f a₂} {s : f a₁ == f a₁}
      (α : ap f p == q) (β : q == r) (γ : q ∙ ! r == s) (δ : s == idp)
      (σ : !-inv-r r == transport (λ t → t ∙ ! r == idp) β (γ ∙ δ))
      → ap (ap f) (!-inv-r p)
        == (ap-∙ f p (! p) ∙ ap2 _∙_ α (ap-! f p ∙ ap ! (α ∙ β)) ∙ γ) ∙ δ
    lemma₁ f idp idp idp γ idp σ = σ

    lemma₂ : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
      → idp == transport (λ t → t ∙ idp == idp) α (∙-unit-r p ∙ α)
    lemma₂ idp = idp

    R-L-snd : ap (ap (SuspensionRec.f A b b k)) (!-inv-r (merid A a₀))
           == R-L-fst a₀ ∙ kpt
    R-L-snd =
      ap (ap (SuspensionRec.f A b b k)) (!-inv-r (merid A a₀))
        =⟨ lemma₁ (SuspensionRec.f A b b k) (merid A a₀)
             (SuspensionRec.glue-β A b b k a₀)
             kpt (∙-unit-r (k a₀)) kpt (lemma₂ kpt) ⟩
      R-L-fst a₀ ∙ kpt ∎

  {- Show that L ∘ R ∼ idf -}

  L-R : {b : B} → ∀ H → L {b} (R H) == H
  L-R (h , idp) = ⊙λ= L-R-fst idp
    where
    fst-lemma : ∀ {i j} {A : Type i} {B : Type j} {x y z : A}
      (f : A → B) (p : x == y) (q : z == y)
      → ap f p == ap f (p ∙ ! q) ∙' ap f q
    fst-lemma _ idp idp = idp

    L-R-fst : (σ : Suspension A) →
      SuspensionRec.f A (h (north _)) (h (north _)) (fst (R (h , idp))) σ == h σ
    L-R-fst = Suspension-elim A
      idp
      (ap h (merid A a₀))
      (λ a → ↓-='-in $
        ap h (merid A a)
          =⟨ fst-lemma h (merid A a) (merid A a₀) ⟩
        ap h (merid A a ∙ ! (merid A a₀)) ∙' ap h (merid A a₀)
          =⟨ ! (SuspensionRec.glue-β A _ _ (fst (R (h , idp))) a)
             |in-ctx (λ w → w ∙' (ap h (merid A a₀))) ⟩
        ap (fst (L (R (h , idp)))) (merid A a) ∙' ap h (merid A a₀)
        ∎)

  {- Show that R respects basepoint -}

  pres-ident : {b : B}
    → R {b} ((λ _ → b) , idp) == ((λ _ → idp) , idp)
  pres-ident {b} = ⊙λ=
    (λ a → ap-cst b (merid A a ∙ ! (merid A a₀)))
    (ap (ap (λ _ → b)) (!-inv-r (merid A a₀))
       =⟨ lemma (merid A a₀) b ⟩
     ap-cst b (merid A a₀ ∙ ! (merid A a₀))
       =⟨ ! (∙-unit-r _) ⟩
     ap-cst b (merid A a₀ ∙ ! (merid A a₀)) ∙ idp ∎)
    where
    lemma : ∀ {i j} {A : Type i} {B : Type j} {x y : A} (p : x == y) (b : B)
      → ap (ap (λ _ → b)) (!-inv-r p) == ap-cst b (p ∙ ! p)
    lemma idp b = idp

  {- Show that if there is a composition operation ⊙ on B, then R respects
     that composition, that is R {b ⊙ c} (F ⊙ G) == R {b} F ∙ R {c} G -}

  -- lift a composition operation on the codomain to the function space
  comp-lift : ∀ {i j} {A : Type i} {B C D : Type j}
    (a : A) (b : B) (c : C) (_⊙_ : B → C → D)
    → Σ (A → B) (λ f → f a == b)
    → Σ (A → C) (λ g → g a == c)
    → Σ (A → D) (λ h → h a == b ⊙ c)
  comp-lift a b c _⊙_ (f , fpt) (g , gpt) =
    (λ x → f x ⊙ g x) , ap2 _⊙_ fpt gpt

  pres-comp-fst : ∀ {i j} {A : Type i} {B : Type j} (f g : A → B)
    (_⊙_ : B → B → B) {a₁ a₂ : A} (p : a₁ == a₂)
    → ap (λ x → f x ⊙ g x) p == ap2 _⊙_ (ap f p) (ap g p)
  pres-comp-fst f g _⊙_ idp = idp

  pres-comp-snd : ∀ {i j} {A : Type i} {B : Type j} (f g : A → B)
    (_⊙_ : B → B → B) {a₁ a₂ : A} (q : a₁ == a₂)
    → ap (ap (λ x → f x ⊙ g x)) (!-inv-r q)
      == pres-comp-fst f g _⊙_ (q ∙ ! q)
         ∙ ap2 (ap2 _⊙_) (ap (ap f) (!-inv-r q)) (ap (ap g) (!-inv-r q))
  pres-comp-snd f g _⊙_ idp = idp

  pres-comp : {b c : B} (_⊙_ : B → B → B)
    (F : Σ (Suspension A → B) (λ f → f (north A) == b))
    (G : Σ (Suspension A → B) (λ f → f (north A) == c))
    → R (comp-lift (north A) b c _⊙_ F G)
      == comp-lift a₀ idp idp (ap2 _⊙_) (R F) (R G)
  pres-comp _⊙_ (f , idp) (g , idp) = ⊙λ=
    (λ a → pres-comp-fst f g _⊙_ (merid A a ∙ ! (merid A a₀)))
    (pres-comp-snd f g _⊙_ (merid A a₀))

  eqv : fst (⊙Susp X ⊙→ Y) ≃ fst (X ⊙→ ⊙Ω Y)
  eqv = equiv R L R-L L-R

  ⊙path : (⊙Susp X ⊙→ Y) == (X ⊙→ ⊙Ω Y)
  ⊙path = ⊙ua eqv pres-ident


--
-- Created by Dependently-Typed Lambda Calculus on 2020-10-07
-- Isomorphism
-- Author: dplaindoux
--

{-# OPTIONS --without-K --no-sized-types --no-guardedness bbbbb#-}

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; cong-app)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm)

module Isomorphism where

_∘_ : ∀ {A B C : Set} → (B → C) → (A → B) → (A → C)
(g ∘ f) = λ x → g (f x)

-- Extensionality and function equivalence

_+′_ : ℕ → ℕ → ℕ
m +′ zero  = m
m +′ suc n = suc (m +′ n)

same-app : ∀ (m n : ℕ) → m +′ n ≡ m + n
same-app m n rewrite +-comm m n = helper m n
  where
  helper : ∀ (m n : ℕ) → m +′ n ≡ n + m
  helper m zero    = refl
  helper m (suc n) = cong suc (helper m n)

postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

postulate
  ∀-extensionality : ∀ {A : Set} {B : A → Set} {f g : ∀(x : A) → B x}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

same : _+′_ ≡ _+_
same = ∀-extensionality (λ m → ∀-extensionality (λ n → same-app m n))

-- Isomorphism definition

infix 0 _≃_

record _≃_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y

open _≃_

≃-refl : ∀ {A : Set}
    -----
  → A ≃ A
≃-refl =
  record
    { to      = λ{x → x}
    ; from    = λ{y → y}
    ; from∘to = λ{x → refl}
    ; to∘from = λ{y → refl}
    }

≃-sym : ∀ {A B : Set}
  → A ≃ B
    -----
  → B ≃ A
≃-sym A≃B =
  record
    { to      = from A≃B
    ; from    = to   A≃B
    ; from∘to = to∘from A≃B
    ; to∘from = from∘to A≃B
    }

≃-trans : ∀ {A B C : Set}
  → A ≃ B
  → B ≃ C
    -----
  → A ≃ C
≃-trans A≃B B≃C =
  record
    { to       = to   B≃C ∘ to   A≃B
    ; from     = from A≃B ∘ from B≃C
    ; from∘to  = λ{x →
        begin
          ((from A≃B ∘ from B≃C) ∘ (to B≃C ∘ to A≃B)) x
        ≡⟨⟩
          (from A≃B ∘ from B≃C) ((to B≃C ∘ to A≃B) x)
        ≡⟨⟩
          from A≃B (from B≃C (to B≃C (to A≃B x)))
        ≡⟨ cong (from A≃B) (from∘to B≃C (to A≃B x)) ⟩
          from A≃B (to A≃B x)
        ≡⟨ from∘to A≃B x ⟩
          x
        ∎}
    ; to∘from = λ{y →
        begin
          ((to B≃C ∘ to A≃B) ∘ (from A≃B ∘ from B≃C)) y
        ≡⟨⟩
          (to B≃C ∘ to A≃B) ((from A≃B ∘ from B≃C) y)
        ≡⟨⟩
          to B≃C (to A≃B (from A≃B (from B≃C y)))
        ≡⟨ cong (to B≃C) (to∘from A≃B (from B≃C y)) ⟩
          to B≃C (from B≃C y)
        ≡⟨ to∘from B≃C y ⟩
          y
        ∎}
     }

module ≃-Reasoning where

  infix  1 ≃-begin_
  infixr 2 _≃⟨_⟩_
  infix  3 _≃-∎

  ≃-begin_ : ∀ {A B : Set}
    → A ≃ B
      -----
    → A ≃ B
  ≃-begin A≃B = A≃B

  _≃⟨_⟩_ : ∀ (A : Set) {B C : Set}
    → A ≃ B
    → B ≃ C
      -----
    → A ≃ C
  A ≃⟨ A≃B ⟩ B≃C = ≃-trans A≃B B≃C

  _≃-∎ : ∀ (A : Set)
      -----
    → A ≃ A
  A ≃-∎ = ≃-refl

open ≃-Reasoning

infix 0 _≲_

record _≲_ (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x

open _≲_

≲-refl : ∀ {A : Set}
    -----
  → A ≲ A
≲-refl =
  record
    { to      = λ{x → x}
    ; from    = λ{y → y}
    ; from∘to = λ{x → refl}
    }

≲-trans : ∀ {A B C : Set}
  → A ≲ B
  → B ≲ C
    -----
  → A ≲ C
≲-trans A≲B B≲C =
  record
    { to      = λ{x → to   B≲C (to   A≲B x)}
    ; from    = λ{y → from A≲B (from B≲C y)}
    ; from∘to = λ{x →
        begin
          ((from A≲B ∘ from B≲C) ∘ (to B≲C ∘ to A≲B)) x
        ≡⟨⟩
          (from A≲B ∘ from B≲C) ((to B≲C ∘ to A≲B) x)
        ≡⟨⟩
          from A≲B (from B≲C (to B≲C (to A≲B x)))
        ≡⟨ cong (from A≲B) (from∘to B≲C (to A≲B x)) ⟩
          from A≲B (to A≲B x)
        ≡⟨ from∘to A≲B x ⟩
          x
        ∎}
     }

≲-antisym : ∀ {A B : Set}
  → (A≲B : A ≲ B)
  → (B≲A : B ≲ A)
  → (to A≲B ≡ from B≲A)
  → (from A≲B ≡ to B≲A)
    -------------------
  → A ≃ B
≲-antisym A≲B B≲A to≡from from≡to =
  record
    { to      = to A≲B
    ; from    = from A≲B
    ; from∘to = from∘to A≲B
    ; to∘from = λ{y →
        begin
          (to A≲B ∘ from A≲B) y
        ≡⟨⟩
          to A≲B (from A≲B y)
        ≡⟨ cong (to A≲B) (cong-app from≡to y) ⟩
          to A≲B (to B≲A y)
        ≡⟨ cong-app to≡from (to B≲A y) ⟩
          from B≲A (to B≲A y)
        ≡⟨ from∘to B≲A y ⟩
          y
        ∎}
    }


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

open import Level
open import Algebra.Structures
open import Relation.Binary
open import Algebra.FunctionProperties

module Comb (K : Set) (_≈_ : Rel K zero)
         (_+_ _⋆_ : Op₂ K) (-_ : Op₁ K) (0# 1# : K)
         (isRing : IsRing _≈_ _+_ _⋆_ -_ 0# 1#) where

open import Size
open import Function hiding (const)
open import Relation.Nullary
open import Stream
open import Data.Nat renaming (_+_ to _+ℕ_)
open import Data.Fin hiding (_+_)
open import Data.Product hiding (_×_)
open import Data.Empty
open import Relation.Binary.PropositionalEquality as P
  using (_≡_) --; refl; sym; trans; cong; module ≡-Reasoning)

K-setoid : Setoid _ _
K-setoid = record { Carrier = K
                  ; _≈_ = _≈_
                  ; isEquivalence = IsRing.isEquivalence isRing }

open Bisim K-setoid
import Relation.Binary.EqReasoning as EqR
open EqR (K-setoid) public hiding (_≡⟨_⟩_)
--open IsEquivalence (IsRing.isEquivalence isRing)
open ∼-Reasoning renaming (begin_ to begin∼_; _∎ to _∎∼)

open IsRing isRing -- using (+-cong ; +-identity)
+-identityˡ = proj₁ +-identity
+-identityʳ = proj₂ +-identity

-- zeroʳ : RightZero 0# _⋆_
-- zeroʳ = ?

----------------------
--- Basic operators --
----------------------

const : ∀ {A} → A → Str A
hd (const x) = x
tl (const x) = const x

-- | Point-wise unary operations
pw₁ : ∀ {A i} → Op₁ A → Op₁ (Str {i} A)
hd (pw₁ f σ) = f (hd σ)
tl (pw₁ f σ) = pw₁ f (tl σ)

-- | Point-wise binary operations
pw₂ : ∀ {A i} → Op₂ A → Op₂ (Str {i} A)
hd (pw₂ f σ τ) = f (hd σ) (hd τ)
tl (pw₂ f σ τ) = pw₂ f (tl σ) (tl τ)

[_] : K → Str K
hd [ r ] = r
tl [ r ] = [ 0# ]

-- | Can, in conjunction with _×_, delay stream.
X : Str K
hd X = 0#
tl X = [ 1# ]

_⊕_ : ∀{i} → Str {i} K → Str {i} K → Str {i} K
_⊕_ = pw₂ _+_

⊝_ : ∀{i} → Str {i} K → Str {i} K
⊝_ = pw₁ (-_)

_×_ : ∀ {i} → Str {i} K → Str {i} K → Str {i} K
hd (σ × τ) = hd σ ⋆ hd τ
tl (σ × τ) = (tl σ × τ) ⊕ ([ hd σ ] × tl τ)

-- | We restrict attention to the case where the head is 1,
-- which is trivially invertible in any ring.
hasInv : ∀ {i} → Str {i} K → Set
hasInv σ = hd σ ≈ 1#

-- | Construct convolution inverse, if it exists.
inv : ∀ {i} → (σ : Str {i} K) → hasInv σ → Str {i} K
hd (inv σ p) = hd σ
tl (inv σ p) = ⊝ (tl σ × inv σ p)

-- | Powers of delay stream
X^_ : ℕ → Str K
X^ 0 = [ 1# ]
X^ (suc k) = X × (X^ k)

{-
record Summable (σ : Str (Str K)) : Set where
  coinductive
  field
    hd-smble : ∃ λ n → δ n (hd σ) ∼ [ 0# ]
    tl-smble : Summable (tl σ)
open Summable
-}

SummableDiag : {A : Set} (f : A → K) → Set
SummableDiag {A} f =
  ∃ λ n →
  Σ (Fin n → A) (λ g →
  (a : A) → ¬ ((f a) ≈ 0#) → ∃ λ i → a ≡ g i)

record Summable {A : Set} (f : A → Str K) : Set where
  coinductive
  field
    hd-smble : SummableDiag (hd ∘ f)
    tl-smble : Summable (tl' ∘ f)
open Summable

-- | Sum a finitely indexed family of elements of K.
-- This relies on commutativity etc. of addition in K.
sum : {n : ℕ} → (Fin n → K) → K
sum {ℕ.zero}  f = 0#
sum {ℕ.suc n} f = f Fin.zero + sum (f ∘ Fin.suc)

-- | Sum a family of streams.
∑ : ∀ {A} → (f : A → Str K) → Summable f → Str K
hd (∑ f p) =
  let (_ , g , _) = hd-smble p
  in  sum (hd ∘ f ∘ g)
tl (∑ f p) = ∑ (tl' ∘ f) (tl-smble p)

-- | Constant family of zero streams is summable
zero-summable : Summable {ℕ} (λ n → [ 0# ])
hd-smble zero-summable
  = (0 , f , q)
  where
    f : Fin 0 → ℕ
    f ()

    q : (n : ℕ) → ¬ (hd [ 0# ] ≈ 0#) → ∃ λ i → n ≡ f i
    q n p = ⊥-elim (p (IsRing.refl isRing))
tl-smble zero-summable = zero-summable

polySeq : ∀{i} → Str {i} (Str K) → Str {i} (Str K)
hd (polySeq σ) = hd σ × (X^ 0)
tl (polySeq σ) = pw₂ _×_ (polySeq (tl σ)) (const X)

polySeq₁ : Str (Str K) → (ℕ → Str K)
polySeq₁ σ = _at_ (polySeq σ)

polySeq₂ : (ℕ → Str K) → (ℕ → Str K)
polySeq₂ f = polySeq₁ (toStr f)

polySeq-summable : (σ : Str (Str K)) → Summable (polySeq₁ σ)
hd-smble (polySeq-summable σ) = q
  where
    q : SummableDiag (hd ∘ polySeq₁ σ)
    q = {!!}
tl-smble (polySeq-summable σ) = {!!}

{-
polySeq-expl : (σ : Str (Str K)) → (i : ℕ) → (polySeq σ at i) ≡ (σ at i) × (X^ i)
polySeq-expl σ zero    = refl
polySeq-expl σ (suc i) =
  polySeq σ at (ℕ.suc i)
    ≡⟨ ? ⟩
  (σ at (ℕ.suc i)) × (X × (X^ i))
    ∎
-}

-- lem : {f : ℕ → Str K} {k n : ℕ} → ¬ (polySeq f k at n) ≈ 0# → k ≡ n
-- lem = {!!}

{-
polySeq-summable-aux : {f : ℕ → Str K} →
                       (n : ℕ) → (g : ℕ → Str K) → Summable (polySeq f)
hd-smble (polySeq-summable-aux f n) = (1 , supp , {!!})
  where
    p = polySeq f

    supp : Fin 1 → ℕ
    supp Fin.zero = n
    supp (Fin.suc ())

    is-supp : (k : ℕ) → ¬ (hd (p k) ≈ 0#) → ∃ λ i → k ≡ supp i
    is-supp k q = (Fin.zero , {!!})

tl-smble (polySeq-summable-aux f n) = {!!}
-}

hd-delay-zero : (σ : Str K) → hd (X × σ) ≈ 0#
hd-delay-zero σ = zeroˡ (hd σ)
  where
    open IsNearSemiring (IsRing.isNearSemiring isRing)

⊕-cong : ∀ {i s t u v} → s ∼[ i ] t → u ∼[ i ] v → (s ⊕ u) ∼[ i ] (t ⊕ v)
hd≈ (⊕-cong s~t u~v) = +-cong (hd≈ s~t) (hd≈ u~v)
tl∼ (⊕-cong s~t u~v) = ⊕-cong (tl∼ s~t) (tl∼ u~v)

⊕-unitˡ : ∀ {i} → LeftIdentity (_∼_ {i}) [ 0# ] _⊕_
hd≈ (⊕-unitˡ s) = proj₁ +-identity (hd s)
tl∼ (⊕-unitˡ s) = ⊕-unitˡ (tl s)

⊕-comm : ∀ {i} → Commutative (_∼_ {i}) _⊕_
hd≈ (⊕-comm s t) = +-comm (hd s) (hd t)
tl∼ (⊕-comm s t) = ⊕-comm (tl s) (tl t)

⊕-unitʳ : ∀ {i} → RightIdentity (_∼_ {i}) [ 0# ] _⊕_
⊕-unitʳ s =
  s-bisim-trans
  (⊕-comm s [ 0# ])
  (⊕-unitˡ s)

×-zeroˡ : ∀ {i} → LeftZero (_∼_ {i}) [ 0# ] _×_
hd≈ (×-zeroˡ s) = zeroˡ (hd s)
  where
    open IsNearSemiring (IsRing.isNearSemiring isRing)
tl∼ (×-zeroˡ s) {j} =
  s-bisim-trans
  (⊕-cong {j} (×-zeroˡ s) (×-zeroˡ (tl s)))
  (⊕-unitˡ [ 0# ])

×-unitˡ : ∀ {i} → LeftIdentity (_∼_ {i}) [ 1# ] _×_
hd≈ (×-unitˡ s) = proj₁ *-identity (hd s)
tl∼ (×-unitˡ s) {j} =
  s-bisim-trans
  (⊕-cong {j} (×-zeroˡ s) (×-unitˡ (tl s)))
  (⊕-unitˡ (tl s))

tl-delay-id : (σ : Str K) → tl (X × σ) ∼ σ
tl-delay-id σ =
  begin∼
    tl (X × σ)
  ∼⟨ S.refl ⟩
    (tl X × σ) ⊕ ([ hd X ] × tl σ)
  ∼⟨ S.refl ⟩
    ([ 1# ] × σ) ⊕ ([ 0# ] × tl σ)
  ∼⟨ ⊕-cong (×-unitˡ σ) (×-zeroˡ (tl σ)) ⟩
    σ ⊕ [ 0# ]
  ∼⟨ ⊕-unitʳ σ ⟩
    σ
  ∎∼
  where
    module S = Setoid stream-setoid

-- | The analogue of the fundamental theorem
decomp-str : (σ : Str K) → σ ∼ ([ hd σ ] ⊕ (X × tl σ))
hd≈ (decomp-str σ) =
    begin
  hd σ
    ≈⟨ sym (+-identityʳ (hd σ)) ⟩
  hd σ + 0#
    ≈⟨ sym (+-cong refl (hd-delay-zero (tl σ))) ⟩
  hd [ hd σ ] + hd (X × tl σ)
    ≈⟨ refl ⟩
  hd ([ hd σ ] ⊕ (X × tl σ))
    ∎
tl∼ (decomp-str σ) =
  begin∼
    tl σ
  ∼⟨ S.sym (tl-delay-id (tl σ)) ⟩
    tl (X × tl σ)
  ∼⟨ S.sym (⊕-unitˡ (tl (X × tl σ))) ⟩
    [ 0# ] ⊕ tl (X × tl σ)
  ∼⟨ S.refl ⟩
    tl ([ hd σ ] ⊕ (X × tl σ))
  ∎∼
  where
    module S = Setoid stream-setoid


------------------------------------------------------------------------
-- Extension The Agda standard library
--
-- Properties of indexed binary relations
------------------------------------------------------------------------

module Relation.Binary.Indexed.Extra where

open import Data.Product
open import Data.Sum
open import Function
open import Level
-- import Relation.Binary.PropositionalEquality.Core as PropEq
-- open import Relation.Binary.Consequences as Consequences
open import Relation.Binary.Core as Core using (_≡_)
open import Relation.Binary.Indexed.Core
open import Relation.Binary.Indexed
import Relation.Binary as B

------------------------------------------------------------------------
-- Simple properties and equivalence relations

-- open Core public hiding (_≡_; refl; _≢_)
--
-- open Consequences public using (Total)

------------------------------------------------------------------------
-- Simple properties of indexed binary relations

-- Implication/containment. Could also be written ⊆.
[_][_]_⇒_ : ∀ {i₁ i₂ a b ℓ₁ ℓ₂} {I₁ : Set i₁} {I₂ : Set i₂}
    (A : I₁ → Set a) (B : I₂ → Set b)
    → REL A B ℓ₁ → REL A B ℓ₂ → Set _
[ A ][ B ] P ⇒ Q = ∀ {i₁ i₂} {x : A i₁} {y : B i₂} → P x y → Q x y

-- _Preserves_⟶_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : A → Set b} →
--           ((x : A) → B x) → B.Rel A ℓ₁ → Rel B ℓ₂ → Set (ℓ₂ ⊔ (ℓ₁ ⊔ a))
-- f Preserves P ⟶ Q = P =[ f ]⇒ Q

_Respects_ : ∀ {𝒾 a ℓ₁ ℓ₂} {I : Set 𝒾} {A : I → Set a} {i : I}
    → (A i → Set ℓ₁) → Rel A ℓ₂ → Set (ℓ₂ ⊔ (ℓ₁ ⊔ a))
P Respects _∼_ = ∀ {x y} → x ∼ y → P x → P y

[_]_Respects₂_ : ∀ {𝒾 a ℓ₁ ℓ₂} {I : Set 𝒾} (A : I → Set a)
    → Rel A ℓ₁ → Rel A ℓ₂ → Set (ℓ₂ ⊔ (ℓ₁ ⊔ (a ⊔ 𝒾)))
[ A ] P Respects₂ _∼_ =
      (∀ {i} {x : A i} → _Respects_ {A = A} {i = i} (P x) _∼_) ×
      (∀ {i} {y : A i} → _Respects_ {A = A} {i = i} (flip P y) _∼_)

------------------------------------------------------------------------
-- Preorders

record IsPreorder {𝒾 a ℓ₁ ℓ₂} {I : Set 𝒾} (A : I → Set a)
                  (_≈_ : Rel A ℓ₁) -- The underlying equality.
                  (_∼_ : Rel A ℓ₂) -- The relation.
                  : Set (𝒾 ⊔ a ⊔ ℓ₁ ⊔ ℓ₂) where
    field
        isEquivalence : IsEquivalence A _≈_
        -- Reflexivity is expressed in terms of an underlying equality:
        reflexive     : [ A ][ A ] _≈_ ⇒ _∼_
        trans         : Transitive A _∼_

    module Eq = IsEquivalence isEquivalence

    refl : Reflexive A _∼_
    refl = reflexive Eq.refl

    ∼-resp-≈ : [ A ] _∼_ Respects₂ _≈_
    ∼-resp-≈ = (λ x≈y z∼x → trans z∼x (reflexive x≈y))
           , (λ x≈y x∼z → trans (reflexive $ Eq.sym x≈y) x∼z)

record Preorder {i} (I : Set i) c ℓ₁ ℓ₂ : Set (suc (i ⊔ c ⊔ ℓ₁ ⊔ ℓ₂)) where
    infix 4 _≈_ _∼_
    field
        Carrier    : I → Set c
        _≈_        : Rel Carrier ℓ₁  -- The underlying equality.
        _∼_        : Rel Carrier ℓ₂  -- The relation.
        isPreorder : IsPreorder Carrier _≈_ _∼_

    open IsPreorder isPreorder public

SetoidIsPreorder : ∀ {𝒾} {I : Set 𝒾} {c ℓ} (S : Setoid I c ℓ) → IsPreorder (Setoid.Carrier S) (Setoid._≈_ S) (Setoid._≈_ S)
SetoidIsPreorder {𝒾} {I} S = record
    { isEquivalence = isEquivalence
    ; reflexive = id
    ; trans = IsEquivalence.trans isEquivalence
    }
    where
        open Setoid S

Setoid⇒Preorder : ∀ {𝒾} {I : Set 𝒾} {c ℓ} (S : Setoid I c ℓ) → Preorder I c ℓ ℓ
Setoid⇒Preorder S = record { isPreorder = SetoidIsPreorder S }
    -- record
    -- { Carrier = {!   !}
    -- ; _≈_ = {!   !}
    -- ; _∼_ = {!   !}
    -- ; isPreorder = {!   !}
    -- }

    -- IsEquivalence.reflexive (Setoid.isEquivalence S)
    -- where   open IsEquivalence {!   !}
    --
    -- isPreorder : IsPreorder _≡_ _≈_
    -- isPreorder = record
    --     { isEquivalence = PropEq.isEquivalence
    --     ; reflexive     = reflexive
    --     ; trans         = trans
    --     }
      --
      -- preorder : Preorder c c ℓ
      -- preorder = record { isPreorder = isPreorder }


open import Data.Nat --using (ℕ; suc; zero; _≤?_; _≤_; s≤s; z≤n)
open import Data.Bool using (true; false)
--open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary -- using (Dec; yes; no; _because_)
open import Relation.Nullary.Decidable --using (True; fromWitness)
--open import Data.Unit using (tt)

-- stack exec -- agda -c --ghc-dont-call-ghc --no-main nats.agda

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : (x : A) → Maybe A
{-# COMPILE GHC Maybe = data Maybe (Nothing | Just) #-}

n-3 : (n : ℕ) → .{3≤n : True (3 ≤? n)} → ℕ
n-3 (suc (suc (suc n))) = n

exportFunc : ℕ → Maybe ℕ
exportFunc n with 3 ≤? n
... | yes 3≤n = just (n-3 n {fromWitness 3≤n})
... | no ¬3≤n = nothing
{-# COMPILE GHC exportFunc as exportFunc #-}


module AndOrNot where

open import Data.Bool
open import Data.Product

test : Bool → Bool → Bool × Bool × Bool
test x y = x ∧ y , x ∨ y , not x


open import Relation.Nullary.Decidable using (False)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; cong₂)
open import Relation.Binary.PropositionalEquality.WithK using (≡-erase)

module AKS.Nat.Divisibility where

open import Data.Nat.Divisibility using (_∣_) public
open import Agda.Builtin.Nat using () renaming (mod-helper to modₕ; div-helper to divₕ) public
open import Data.Nat.DivMod using (_/_; _%_; %-distribˡ-+) public
open import Data.Nat.DivMod.Core using (a≤n⇒a[modₕ]n≡a)
open import Data.Nat.DivMod using (/-congˡ; /-congʳ) renaming (m≡m%n+[m/n]*n to div-lemma)

open import AKS.Nat.Base using (ℕ; _+_; _*_; _∸_; _≟_; lte; _≤_; _<_)
open ℕ
open import AKS.Nat.Properties using (+-suc)
open import AKS.Nat.Properties using (m≤m+n; m≤n+m; suc-mono-≤; ∸-mono-≤ˡ; +-lower-≤; ≤-refl; ≢⇒¬≟; module ≤-Reasoning)
open import AKS.Nat.Properties using (*-comm; +-identityʳ)
open ≤-Reasoning
import Data.Nat.DivMod as Nat
import Data.Nat.Properties as Nat
open import Data.Nat.Properties using (*-zeroʳ)

open import Polynomial.Simple.AlmostCommutativeRing.Instances using (module Nat)
open import Polynomial.Simple.Reflection using (solve)

a[modₕ]n≤n : ∀ acc d n → modₕ acc (acc + n) d n ≤ acc + n
a[modₕ]n≤n acc zero n = m≤m+n
a[modₕ]n≤n acc (suc d) zero = a[modₕ]n≤n zero d (acc + 0)
a[modₕ]n≤n acc (suc d) (suc n) rewrite +-suc acc n = a[modₕ]n≤n (suc acc) d n

n%m<m : ∀ n m {≢0 : False (m ≟ 0)} → (n % m) {≢0} < m
n%m<m n (suc m) = suc-mono-≤ (a[modₕ]n≤n 0 n m)

a[modₕ]n≤a : ∀ acc a n → modₕ acc (acc + n) a n ≤ acc + a
a[modₕ]n≤a acc zero n rewrite +-identityʳ acc = ≤-refl
a[modₕ]n≤a acc (suc a) (suc n) = begin
  modₕ acc (acc + suc n) (suc a) (suc n) ≡⟨ cong (λ v → modₕ acc v (suc a) (suc n)) (+-suc acc n) ⟩
  modₕ acc (suc acc + n) (suc a) (suc n) ≤⟨ a[modₕ]n≤a (suc acc) a n ⟩
  suc acc + a                            ≡⟨ sym (+-suc acc a) ⟩
  acc + suc a                            ∎
a[modₕ]n≤a acc (suc a) zero    = begin
  modₕ acc (acc + 0) (suc a) 0 ≡⟨ cong (λ v → modₕ acc v (suc a) 0) (+-identityʳ acc) ⟩
  modₕ acc acc (suc a) 0       ≤⟨ a[modₕ]n≤a 0 a acc ⟩
  a                            ≤⟨ m≤n+m ⟩
  suc a                        ≤⟨ m≤n+m ⟩
  acc + suc a                  ∎

n%m≤n : ∀ n m {≢0} → (n % m) {≢0} ≤ n
n%m≤n n (suc m) = a[modₕ]n≤a 0 n m

n<m⇒n%m≡n : ∀ {n m} {≢0 : False (m ≟ 0)} → n < m → (n % m) {≢0} ≡ n
n<m⇒n%m≡n {n} {suc m} (lte k refl) = ≡-erase (a≤n⇒a[modₕ]n≡a 0 (n + k) n k)

0%m≡0 : ∀ m {≢0 : False (m ≟ 0)} → (0 % m) {≢0} ≡ 0
0%m≡0 (suc m) = refl

1%m≡1 : ∀ {m} {≢0} → 1 < m → (1 % m) {≢0} ≡ 1
1%m≡1 {suc (suc m)} 1<m = refl

record Euclidean (n : ℕ) (m : ℕ) : Set where
  constructor Euclidean✓
  field
    q : ℕ
    r : ℕ
    division : n ≡ r + m * q
    r<m : r < m

m≡m%n+[m/n]*n : ∀ m n {n≢0 : False (n ≟ 0)} → m ≡ (m % n) {n≢0} + (m / n) {n≢0} * n
m≡m%n+[m/n]*n m (suc n) = div-lemma m n

m%n≡m∸m/n*n : ∀ m n {n≢0 : False (n ≟ 0)} → (m % n) {n≢0} ≡ m ∸ (m / n) {n≢0} * n
m%n≡m∸m/n*n m (suc n) = Nat.m%n≡m∸m/n*n m n

m%n%n≡m%n : ∀ m n {n≢0 : False (n ≟ 0)} → ((m % n) {n≢0} % n) {n≢0} ≡ (m % n) {n≢0}
m%n%n≡m%n m (suc n) = Nat.m%n%n≡m%n m n

n%n≡0 : ∀ n {n≢0 : False (n ≟ 0)} → (n % n) {n≢0} ≡ 0
n%n≡0 (suc n) = Nat.n%n≡0 n

[m+kn]%n≡m%n : ∀ m k n {n≢0 : False (n ≟ 0)} → ((m + k * n) % n) {n≢0} ≡ (m % n) {n≢0}
[m+kn]%n≡m%n m k (suc n) = Nat.[m+kn]%n≡m%n m k n

%-distribˡ-* : ∀ m n d {≢0} → ((m * n) % d) {≢0} ≡ (((m % d) {≢0} * (n % d) {≢0}) % d) {≢0}
%-distribˡ-* m n (suc d) = begin-equality
  (m * n) % suc d                                                           ≡⟨ cong (λ x → (x * n) % suc d) (m≡m%n+[m/n]*n m (suc d)) ⟩
  ((m % suc d + m / suc d * suc d) * n) % suc d                             ≡⟨ cong (λ x → x % suc d) (Nat.*-distribʳ-+ n (m % suc d) (m / suc d * suc d)) ⟩
  ((m % suc d) * n + (m / suc d * suc d) * n) % suc d                       ≡⟨ cong (λ x → ((m % suc d) * n + x) % suc d) (lemma (m / suc d) (suc d) n) ⟩
  ((m % suc d) * n + (m / suc d * n) * suc d) % suc d                       ≡⟨ Nat.[m+kn]%n≡m%n ((m % suc d) * n) (m / suc d * n) d ⟩
  ((m % suc d) * n) % suc d                                                 ≡⟨ cong (λ x → ((m % suc d) * x) % suc d) (m≡m%n+[m/n]*n n (suc d)) ⟩
  ((m % suc d) * (n % suc d + n / suc d * suc d)) % suc d                   ≡⟨ cong (λ x → x % suc d) (Nat.*-distribˡ-+ (m % suc d) (n % suc d) (n / suc d * suc d)) ⟩
  ((m % suc d) * (n % suc d) + (m % suc d) * (n / suc d * suc d)) % suc d   ≡⟨ cong (λ x → ((m % suc d) * (n % suc d) + x) % suc d) (sym (Nat.*-assoc (m % suc d) (n / suc d) (suc d))) ⟩
  ((m % suc d) * (n % suc d) + ((m % suc d) * (n / suc d)) * suc d) % suc d ≡⟨ Nat.[m+kn]%n≡m%n ((m % suc d) * (n % suc d)) ((m % suc d) * (n / suc d)) d ⟩
  ((m % suc d) * (n % suc d)) % suc d                                       ∎
  where
  lemma : ∀ x y z → (x * y) * z ≡ (x * z) * y
  lemma = solve Nat.ring

[m∸n]%n≡m%n : ∀ m n {n≢0 : False (n ≟ 0)} → n ≤ m → ((m ∸ n) % n) {n≢0} ≡ (m % n) {n≢0}
[m∸n]%n≡m%n (suc .(n + k)) (suc n) (lte k refl) = begin-equality
  ((suc n + k) ∸ suc n) % suc n ≡⟨ cong (λ t → t % suc n) (Nat.m+n∸m≡n (suc n) k) ⟩
  k % suc n                     ≡⟨ sym (Nat.[m+n]%n≡m%n k n) ⟩
  (k + suc n) % suc n           ≡⟨ cong (λ t → t % suc n) (Nat.+-comm k (suc n)) ⟩
  (suc n + k) % suc n           ∎

[m∸kn]%n≡m%n : ∀ m k n {n≢0 : False (n ≟ 0)} → k * n ≤ m → ((m ∸ k * n) % n) {n≢0} ≡ (m % n) {n≢0}
[m∸kn]%n≡m%n m zero (suc n) n≤m = refl
[m∸kn]%n≡m%n m (suc k) (suc n) k*n≤m = begin-equality
  (m ∸ (suc n + k * suc n)) % suc n ≡⟨ cong (λ t → t % suc n) (sym (Nat.∸-+-assoc m (suc n) (k * suc n)))  ⟩
  ((m ∸ suc n) ∸ k * suc n) % suc n ≡⟨ [m∸kn]%n≡m%n (m ∸ suc n) k (suc n) k*n≤m∸n ⟩
  (m ∸ suc n) % suc n               ≡⟨ [m∸n]%n≡m%n m (suc n) (+-lower-≤ (k * suc n) k*n≤m) ⟩
  m % suc n                         ∎
  where
  k*n≤m∸n : k * suc n ≤ m ∸ suc n
  k*n≤m∸n = begin
    k * suc n                   ≡⟨ sym (Nat.m+n∸m≡n (suc n) (k * suc n)) ⟩
    (suc n + k * suc n) ∸ suc n ≤⟨ ∸-mono-≤ˡ {suc n} m≤m+n k*n≤m ⟩
    m ∸ suc n                   ∎

%-distribˡ-∸ : ∀ m n d {≢0} → n ≤ m → ((m ∸ n) % d) {≢0} ≡ ((m ∸ (n % d) {≢0}) % d) {≢0}
%-distribˡ-∸ m n (suc d) n≤m = begin-equality
  (m ∸ n) % suc d                               ≡⟨ cong (λ t → (m ∸ t) % suc d) (m≡m%n+[m/n]*n n (suc d)) ⟩
  (m ∸ (n % suc d + n / suc d * suc d)) % suc d ≡⟨ cong (λ t → t % suc d) (sym (Nat.∸-+-assoc m (n % suc d) (n / suc d * suc d))) ⟩
  ((m ∸ n % suc d) ∸ n / suc d * suc d) % suc d ≡⟨ [m∸kn]%n≡m%n (m ∸ n % suc d) (n / suc d) (suc d) n/d*d≤m∸n%d ⟩
  (m ∸ n % suc d) % suc d                       ∎
  where
  n/d*d≤m∸n%d : n / suc d * suc d ≤ m ∸ n % suc d
  n/d*d≤m∸n%d = begin
    n / suc d * suc d                           ≡⟨ sym (Nat.m+n∸m≡n (n % suc d) (n / suc d * suc d)) ⟩
    (n % suc d + n / suc d * suc d) ∸ n % suc d ≡⟨ cong (λ t → t ∸ n % suc d) (sym (m≡m%n+[m/n]*n n (suc d))) ⟩
    n ∸ n % suc d                               ≤⟨ ∸-mono-≤ˡ {n % suc d} (n%m≤n n (suc d)) n≤m ⟩
    m ∸ n % suc d                               ∎

open import AKS.Unsafe using (trustMe)

/-cancelˡ : ∀ c a b {b≢0} {b*c≢0} → ((c * a) / (c * b)) {b*c≢0} ≡ (a / b) {b≢0}
/-cancelˡ (suc c) a (suc b) {b≢0} {b*c≢0} = trustMe

/-cancelʳ : ∀ c a b {b≢0} {b*c≢0} → ((a * c) / (b * c)) {b*c≢0} ≡ (a / b) {b≢0}
/-cancelʳ c a b {b≢0} {b*c≢0} = begin-equality
  (a * c) / (b * c) ≡⟨ /-congˡ {o≢0 = b*c≢0} (*-comm a c) ⟩
  (c * a) / (b * c) ≡⟨ /-congʳ (*-comm b c) ⟩
  (c * a) / (c * b) ≡⟨ /-cancelˡ c a b {b≢0} {c*b≢0} ⟩
  a / b ∎
  where
  c*b≢0 : False (c * b ≟ 0)
  c*b≢0 rewrite *-comm b c = b*c≢0

_div_ : ∀ n m {≢0 : False (m ≟ 0)} → Euclidean n m
n div suc m = Euclidean✓ (n / suc m) (n % suc m) (≡-erase div-proof) (n%m<m n (suc m))
  where
  div-proof : n ≡ n % suc m + suc m * (n / suc m)
  div-proof rewrite *-comm (suc m) (n / suc m) = m≡m%n+[m/n]*n n (suc m)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Order morphisms
------------------------------------------------------------------------

module Relation.Binary.OrderMorphism where

open import Relation.Binary
open Poset
import Function as F
open import Level

record _⇒-Poset_ {p₁ p₂ p₃ p₄ p₅ p₆}
                 (P₁ : Poset p₁ p₂ p₃)
                 (P₂ : Poset p₄ p₅ p₆) : Set (p₁ ⊔ p₃ ⊔ p₄ ⊔ p₆) where
  field
    fun      : Carrier P₁ → Carrier P₂
    monotone : _≤_ P₁ =[ fun ]⇒ _≤_ P₂

_⇒-DTO_ : ∀ {p₁ p₂ p₃ p₄ p₅ p₆} →
          DecTotalOrder p₁ p₂ p₃ →
          DecTotalOrder p₄ p₅ p₆ → Set _
DTO₁ ⇒-DTO DTO₂ = poset DTO₁ ⇒-Poset poset DTO₂
  where open DecTotalOrder

open _⇒-Poset_

id : ∀ {p₁ p₂ p₃} {P : Poset p₁ p₂ p₃} → P ⇒-Poset P
id = record
  { fun      = F.id
  ; monotone = F.id
  }

_∘_ : ∀ {p₁ p₂ p₃ p₄ p₅ p₆ p₇ p₈ p₉}
        {P₁ : Poset p₁ p₂ p₃}
        {P₂ : Poset p₄ p₅ p₆}
        {P₃ : Poset p₇ p₈ p₉} →
      P₂ ⇒-Poset P₃ → P₁ ⇒-Poset P₂ → P₁ ⇒-Poset P₃
f ∘ g = record
  { fun      = F._∘_ (fun f)      (fun g)
  ; monotone = F._∘_ (monotone f) (monotone g)
  }

const : ∀ {p₁ p₂ p₃ p₄ p₅ p₆}
          {P₁ : Poset p₁ p₂ p₃}
          {P₂ : Poset p₄ p₅ p₆} →
        Carrier P₂ → P₁ ⇒-Poset P₂
const {P₂ = P₂} x = record
  { fun      = F.const x
  ; monotone = F.const (refl P₂)
  }


module Pi.Syntax where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product

infixr 12 _×ᵤ_
infixr 11 _+ᵤ_
infixr 50 _⨾_
infixr 10 _↔_
infix  99 !_

-- Types
data 𝕌 : Set where
  𝟘       : 𝕌
  𝟙       : 𝕌
  _+ᵤ_    : 𝕌 → 𝕌 → 𝕌
  _×ᵤ_    : 𝕌 → 𝕌 → 𝕌

⟦_⟧ : (A : 𝕌) → Set
⟦ 𝟘 ⟧ = ⊥
⟦ 𝟙 ⟧ = ⊤
⟦ t₁ +ᵤ t₂ ⟧ = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
⟦ t₁ ×ᵤ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧

-- Combinators
data _↔_ : 𝕌 → 𝕌 → Set where
  unite₊l  : {t : 𝕌} → 𝟘 +ᵤ t ↔ t
  uniti₊l  : {t : 𝕌} → t ↔ 𝟘 +ᵤ t
  swap₊    : {t₁ t₂ : 𝕌} → t₁ +ᵤ t₂ ↔ t₂ +ᵤ t₁
  assocl₊  : {t₁ t₂ t₃ : 𝕌} → t₁ +ᵤ (t₂ +ᵤ t₃) ↔ (t₁ +ᵤ t₂) +ᵤ t₃
  assocr₊  : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) +ᵤ t₃ ↔ t₁ +ᵤ (t₂ +ᵤ t₃)
  unite⋆l  : {t : 𝕌} → 𝟙 ×ᵤ t ↔ t
  uniti⋆l  : {t : 𝕌} → t ↔ 𝟙 ×ᵤ t
  swap⋆    : {t₁ t₂ : 𝕌} → t₁ ×ᵤ t₂ ↔ t₂ ×ᵤ t₁
  assocl⋆  : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ ×ᵤ t₃) ↔ (t₁ ×ᵤ t₂) ×ᵤ t₃
  assocr⋆  : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₂) ×ᵤ t₃ ↔ t₁ ×ᵤ (t₂ ×ᵤ t₃)
  absorbr  : {t : 𝕌} → 𝟘 ×ᵤ t ↔ 𝟘
  factorzl : {t : 𝕌} → 𝟘 ↔ 𝟘 ×ᵤ t
  dist     : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) ×ᵤ t₃ ↔ (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃)
  factor   : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃) ↔ (t₁ +ᵤ t₂) ×ᵤ t₃
  id↔      : {t : 𝕌} → t ↔ t
  _⨾_      : {t₁ t₂ t₃ : 𝕌} → (t₁ ↔ t₂) → (t₂ ↔ t₃) → (t₁ ↔ t₃)
  _⊕_      : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ↔ t₃) → (t₂ ↔ t₄) → (t₁ +ᵤ t₂ ↔ t₃ +ᵤ t₄)
  _⊗_      : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ↔ t₃) → (t₂ ↔ t₄) → (t₁ ×ᵤ t₂ ↔ t₃ ×ᵤ t₄)

-- Some useful combinators
unite₊r  : {t : 𝕌} → t +ᵤ 𝟘 ↔ t
unite₊r  = swap₊ ⨾ unite₊l

uniti₊r  : {t : 𝕌} → t ↔ t +ᵤ 𝟘
uniti₊r  = uniti₊l ⨾ swap₊

unite⋆r  : {t : 𝕌} → t ×ᵤ 𝟙 ↔ t
unite⋆r  = swap⋆ ⨾ unite⋆l

uniti⋆r  : {t : 𝕌} → t ↔ t ×ᵤ 𝟙
uniti⋆r  = uniti⋆l ⨾ swap⋆

absorbl  : {t : 𝕌} → t ×ᵤ 𝟘 ↔ 𝟘
absorbl  = swap⋆ ⨾ absorbr

factorzr : {t : 𝕌} → 𝟘 ↔ t ×ᵤ 𝟘
factorzr = factorzl ⨾ swap⋆

distl    : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ +ᵤ t₃) ↔ (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃)
distl    = swap⋆ ⨾ dist ⨾ (swap⋆ ⊕ swap⋆)

factorl  : {t₁ t₂ t₃ : 𝕌 } → (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃) ↔ t₁ ×ᵤ (t₂ +ᵤ t₃)
factorl  = (swap⋆ ⊕ swap⋆) ⨾ factor ⨾ swap⋆

-- Inverses of combinators
!_ : {A B : 𝕌} → A ↔ B → B ↔ A
! unite₊l = uniti₊l
! uniti₊l = unite₊l
! swap₊ = swap₊
! assocl₊ = assocr₊
! assocr₊ = assocl₊
! unite⋆l = uniti⋆l
! uniti⋆l = unite⋆l
! swap⋆ = swap⋆
! assocl⋆ = assocr⋆
! assocr⋆ = assocl⋆
! absorbr = factorzl
! factorzl = absorbr
! dist = factor
! factor = dist
! id↔ = id↔
! (c₁ ⨾ c₂) = ! c₂ ⨾ ! c₁
! (c₁ ⊕ c₂) = (! c₁) ⊕ (! c₂)
! (c₁ ⊗ c₂) = (! c₁) ⊗ (! c₂)


-- Andreas, 2017-01-12, issue #2386

id : ∀{a}{A : Set a} → A → A
id x = x

data Eq (A : Set) : (x y : id A) → Set where
  refl : (x : A) → Eq A x x

{-# BUILTIN EQUALITY Eq #-}

-- Should be accepted.


-- Andreas, 2016-10-12 AIM XXIV, issue #2256

open import Common.Equality

module _ a (A : Set a) where

data ⊥ : Set where

abs : ⊥ → Set a
abs = λ()

test : (x : ⊥) → abs x ≡ A
test x = refl

-- ERROR WAS:
-- (λ ()) a A x != A of type Set a
-- when checking that the expression refl has type abs x ≡ A

-- EXPECTED:
-- (λ ()) x != A of type Set a
-- when checking that the expression refl has type abs x ≡ A


module Container.Traversable where

open import Prelude

record Traversable {a} (T : Set a → Set a) : Set (lsuc a) where
  field
    traverse : ∀ {F : Set a → Set a} {A B} {{AppF : Applicative F}} → (A → F B) → T A → F (T B)
    overlap {{super}} : Functor T

open Traversable {{...}} public

record Traversable′ {a b} (T : ∀ {a} → Set a → Set a) : Set (lsuc (a ⊔ b)) where
  field
    traverse′ : ∀ {F : Set b → Set b} {A : Set a} {B : Set b}
                  {{AppF : Applicative F}} → (A → F B) → T A → F (T B)
    overlap {{super}} : Functor′ {a} {b} T

open Traversable′ {{...}} public

{-# DISPLAY Traversable.traverse   _ = traverse #-}
{-# DISPLAY Traversable′.traverse′ _ = traverse′ #-}

--- Instances ---

instance
  TraversableMaybe : ∀ {a} → Traversable {a} Maybe
  traverse {{TraversableMaybe}} f m = maybe (pure nothing) (λ x -> pure just <*> f x) m

  TraversableList : ∀ {a} → Traversable {a} List
  traverse {{TraversableList}} f xs = foldr (λ x fxs → pure _∷_ <*> f x <*> fxs) (pure []) xs

  TraversableVec : ∀ {a n} → Traversable {a} (λ A → Vec A n)
  traverse {{TraversableVec}} f []       = pure []
  traverse {{TraversableVec}} f (x ∷ xs) = ⦇ f x ∷ traverse f xs ⦈

  Traversable′Maybe : ∀ {a b} → Traversable′ {a} {b} Maybe
  traverse′ {{Traversable′Maybe}} f m = maybe (pure nothing) (λ x -> pure just <*> f x) m

  Traversable′List : ∀ {a b} → Traversable′ {a} {b} List
  traverse′ {{Traversable′List}} f xs = foldr (λ x fxs → pure _∷_ <*> f x <*> fxs) (pure []) xs

  Traversable′Vec : ∀ {a b n} → Traversable′ {a} {b} (λ A → Vec A n)
  traverse′ {{Traversable′Vec}} f []       = pure []
  traverse′ {{Traversable′Vec}} f (x ∷ xs) = ⦇ f x ∷ traverse′ f xs ⦈

mapM : ∀ {a b} {F : Set b → Set b} {A : Set a} {B : Set b} {{AppF : Applicative F}} →
         (A → F B) → List A → F (List B)
mapM = traverse′

mapM! : ∀ {a} {F : Set → Set} {A : Set a} {{AppF : Applicative F}} →
          (A → F ⊤) → List A → F ⊤
mapM! f xs = _ <$ mapM f xs


module Lib.Maybe where

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : A -> Maybe A

{-# COMPILE GHC Maybe = data Maybe (Nothing | Just) #-}


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

module Examples.Exp2 where

open import Calf.CostMonoid
open import Calf.CostMonoids using (ℕ²-ParCostMonoid)

parCostMonoid = ℕ²-ParCostMonoid
open ParCostMonoid parCostMonoid

open import Calf costMonoid
open import Calf.ParMetalanguage parCostMonoid
open import Calf.Types.Bool
open import Calf.Types.Nat
open import Calf.Types.Bounded costMonoid
open import Calf.Types.BigO costMonoid

open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning)
open import Data.Nat as Nat using (_+_; pred; _*_; _^_; _⊔_)
import Data.Nat.Properties as N
open import Data.Nat.PredExp2
open import Data.Product
open import Data.Empty

Correct : cmp (Π nat λ _ → F nat) → Set
Correct exp₂ = (n : ℕ) → ◯ (exp₂ n ≡ ret (2 ^ n))

module Slow where
  exp₂ : cmp (Π nat λ _ → F nat)
  exp₂ zero = ret (suc zero)
  exp₂ (suc n) =
    bind (F nat) (exp₂ n & exp₂ n) λ (r₁ , r₂) →
      step (F nat) (1 , 1) (ret (r₁ + r₂))

  exp₂/correct : Correct exp₂
  exp₂/correct zero    u = refl
  exp₂/correct (suc n) u =
    begin
      exp₂ (suc n)
    ≡⟨⟩
      (bind (F nat) (exp₂ n & exp₂ n) λ (r₁ , r₂) →
        step (F nat) (1 , 1) (ret (r₁ + r₂)))
    ≡⟨ Eq.cong (bind (F nat) (exp₂ n & exp₂ n)) (funext (λ (r₁ , r₂) → step/ext (F nat) _ (1 , 1) u)) ⟩
      (bind (F nat) (exp₂ n & exp₂ n) λ (r₁ , r₂) →
        ret (r₁ + r₂))
    ≡⟨ Eq.cong (λ e → bind (F nat) (e & e) _) (exp₂/correct n u) ⟩
      step (F nat) (𝟘 ⊗ 𝟘) (ret (2 ^ n + 2 ^ n))
    ≡⟨⟩
      ret (2 ^ n + 2 ^ n)
    ≡⟨ Eq.cong ret (lemma/2^suc n) ⟩
      ret (2 ^ suc n)
    ∎
      where open ≡-Reasoning

  exp₂/cost : cmp (Π nat λ _ → cost)
  exp₂/cost zero    = 𝟘
  exp₂/cost (suc n) =
    bind cost (exp₂ n & exp₂ n) λ (r₁ , r₂) → (exp₂/cost n ⊗ exp₂/cost n) ⊕
      ((1 , 1) ⊕ 𝟘)

  exp₂/cost/closed : cmp (Π nat λ _ → cost)
  exp₂/cost/closed n = pred[2^ n ] , n

  exp₂/cost≤exp₂/cost/closed : ∀ n → ◯ (exp₂/cost n ≤ exp₂/cost/closed n)
  exp₂/cost≤exp₂/cost/closed zero    u = ≤-refl
  exp₂/cost≤exp₂/cost/closed (suc n) u =
    let ≡ = exp₂/correct n u in
    let open ≤-Reasoning in
    begin
      exp₂/cost (suc n)
    ≡⟨⟩
      (bind cost (exp₂ n & exp₂ n) λ (r₁ , r₂) → (exp₂/cost n ⊗ exp₂/cost n) ⊕
        ((1 , 1) ⊕ 𝟘))
    ≡⟨ Eq.cong₂ (λ e₁ e₂ → bind cost (e₁ & e₂) λ (r₁ , r₂) → (exp₂/cost n ⊗ exp₂/cost n) ⊕ _) (≡) (≡) ⟩
      (exp₂/cost n ⊗ exp₂/cost n) ⊕ ((1 , 1) ⊕ 𝟘)
    ≡⟨ Eq.cong ((exp₂/cost n ⊗ exp₂/cost n) ⊕_) (⊕-identityʳ _) ⟩
      (exp₂/cost n ⊗ exp₂/cost n) ⊕ (1 , 1)
    ≤⟨ ⊕-monoˡ-≤ (1 , 1) (⊗-mono-≤ (exp₂/cost≤exp₂/cost/closed n u) (exp₂/cost≤exp₂/cost/closed n u)) ⟩
      (exp₂/cost/closed n ⊗ exp₂/cost/closed n) ⊕ (1 , 1)
    ≡⟨ Eq.cong₂ _,_ arithmetic/work arithmetic/span ⟩
        exp₂/cost/closed (suc n)
      ∎
      where
        arithmetic/work : proj₁ (exp₂/cost/closed n ⊗ exp₂/cost/closed n ⊕ (1 , 1)) ≡ proj₁ (exp₂/cost/closed (suc n))
        arithmetic/work =
          begin
            proj₁ (exp₂/cost/closed n ⊗ exp₂/cost/closed n ⊕ (1 , 1))
          ≡⟨⟩
            proj₁ (exp₂/cost/closed n) + proj₁ (exp₂/cost/closed n) + 1
          ≡⟨ N.+-comm _ 1 ⟩
            suc (proj₁ (exp₂/cost/closed n) + proj₁ (exp₂/cost/closed n))
          ≡⟨⟩
            suc (pred[2^ n ] + pred[2^ n ])
          ≡⟨ pred[2^suc[n]] n ⟩
            pred[2^ suc n ]
          ≡⟨⟩
            proj₁ (exp₂/cost/closed (suc n))
          ∎
            where open ≡-Reasoning

        arithmetic/span : proj₂ (exp₂/cost/closed n ⊗ exp₂/cost/closed n ⊕ (1 , 1)) ≡ proj₂ (exp₂/cost/closed (suc n))
        arithmetic/span =
          begin
            proj₂ (exp₂/cost/closed n ⊗ exp₂/cost/closed n ⊕ (1 , 1))
          ≡⟨⟩
            proj₂ (exp₂/cost/closed n) ⊔ proj₂ (exp₂/cost/closed n) + 1
          ≡⟨⟩
            n ⊔ n + 1
          ≡⟨ Eq.cong (_+ 1) (N.⊔-idem n) ⟩
            n + 1
          ≡⟨ N.+-comm _ 1 ⟩
            suc n
          ≡⟨⟩
            proj₂ (exp₂/cost/closed (suc n))
          ∎
            where open ≡-Reasoning

  exp₂≤exp₂/cost : ∀ n → IsBounded nat (exp₂ n) (exp₂/cost n)
  exp₂≤exp₂/cost zero    = bound/ret
  exp₂≤exp₂/cost (suc n) =
    bound/bind (exp₂/cost n ⊗ exp₂/cost n) _ (bound/par (exp₂≤exp₂/cost n) (exp₂≤exp₂/cost n)) λ (r₁ , r₂) →
      bound/step (1 , 1) 𝟘 bound/ret

  exp₂≤exp₂/cost/closed : ∀ n → IsBounded nat (exp₂ n) (exp₂/cost/closed n)
  exp₂≤exp₂/cost/closed n = bound/relax (exp₂/cost≤exp₂/cost/closed n) (exp₂≤exp₂/cost n)

  exp₂/asymptotic : given nat measured-via (λ n → n) , exp₂ ∈𝓞(λ n → 2 ^ n , n)
  exp₂/asymptotic = 0 ≤n⇒f[n]≤g[n]via λ n _ → bound/relax (λ u → N.pred[n]≤n , N.≤-refl) (exp₂≤exp₂/cost/closed n)

module Fast where

  exp₂ : cmp (Π nat λ _ → F nat)
  exp₂ zero = ret (suc zero)
  exp₂ (suc n) =
    bind (F nat) (exp₂ n) λ r →
      step (F nat) (1 , 1) (ret (r + r))

  exp₂/correct : Correct exp₂
  exp₂/correct zero    u = refl
  exp₂/correct (suc n) u =
    begin
      exp₂ (suc n)
    ≡⟨⟩
      (bind (F nat) (exp₂ n) λ r →
        step (F nat) (1 , 1) (ret (r + r)))
    ≡⟨ Eq.cong (bind (F nat) (exp₂ n)) (funext (λ r → step/ext (F nat) _ (1 , 1) u)) ⟩
      (bind (F nat) (exp₂ n) λ r →
        ret (r + r))
    ≡⟨ Eq.cong (λ e → bind (F nat) e _) (exp₂/correct n u) ⟩
      (bind (F nat) (ret {nat} (2 ^ n)) λ r →
        ret (r + r))
    ≡⟨⟩
      ret (2 ^ n + 2 ^ n)
    ≡⟨ Eq.cong ret (lemma/2^suc n) ⟩
      ret (2 ^ suc n)
    ∎
      where open ≡-Reasoning

  exp₂/cost : cmp (Π nat λ _ → cost)
  exp₂/cost zero    = 𝟘
  exp₂/cost (suc n) =
    bind cost (exp₂ n) λ r → exp₂/cost n ⊕
      ((1 , 1) ⊕ 𝟘)

  exp₂/cost/closed : cmp (Π nat λ _ → cost)
  exp₂/cost/closed n = n , n

  exp₂/cost≤exp₂/cost/closed : ∀ n → ◯ (exp₂/cost n ≤ exp₂/cost/closed n)
  exp₂/cost≤exp₂/cost/closed zero    u = ≤-refl
  exp₂/cost≤exp₂/cost/closed (suc n) u =
    let open ≤-Reasoning in
    begin
      exp₂/cost (suc n)
    ≡⟨⟩
      (bind cost (exp₂ n) λ r → exp₂/cost n ⊕
        ((1 , 1) ⊕ 𝟘))
    ≡⟨ Eq.cong (λ e → bind cost e λ r → exp₂/cost n ⊕ _) (exp₂/correct n u) ⟩
      exp₂/cost n ⊕ ((1 , 1) ⊕ 𝟘)
    ≤⟨ ⊕-monoˡ-≤ ((1 , 1) ⊕ 𝟘) (exp₂/cost≤exp₂/cost/closed n u) ⟩
      exp₂/cost/closed n ⊕ ((1 , 1) ⊕ 𝟘)
    ≡⟨ Eq.cong (exp₂/cost/closed n ⊕_) (⊕-identityʳ _) ⟩
      exp₂/cost/closed n ⊕ (1 , 1)
    ≡⟨ Eq.cong₂ _,_ (N.+-comm _ 1) (N.+-comm _ 1) ⟩
      exp₂/cost/closed (suc n)
    ∎

  exp₂≤exp₂/cost : ∀ n → IsBounded nat (exp₂ n) (exp₂/cost n)
  exp₂≤exp₂/cost zero    = bound/ret
  exp₂≤exp₂/cost (suc n) =
    bound/bind (exp₂/cost n) _ (exp₂≤exp₂/cost n) λ r →
      bound/step (1 , 1) 𝟘 bound/ret

  exp₂≤exp₂/cost/closed : ∀ n → IsBounded nat (exp₂ n) (exp₂/cost/closed n)
  exp₂≤exp₂/cost/closed n = bound/relax (exp₂/cost≤exp₂/cost/closed n) (exp₂≤exp₂/cost n)

  exp₂/asymptotic : given nat measured-via (λ n → n) , exp₂ ∈𝓞(λ n → n , n)
  exp₂/asymptotic = 0 ≤n⇒f[n]≤ 1 g[n]via λ n _ → Eq.subst (IsBounded _ _) (Eq.sym (⊕-identityʳ _)) (exp₂≤exp₂/cost/closed n)

slow≡fast : ◯ (Slow.exp₂ ≡ Fast.exp₂)
slow≡fast u = funext λ n →
  begin
    Slow.exp₂ n
  ≡⟨ Slow.exp₂/correct n u ⟩
    ret (2 ^ n)
  ≡˘⟨ Fast.exp₂/correct n u ⟩
    Fast.exp₂ n
  ∎
    where open ≡-Reasoning