-- Andreas, 2015-06-11
-- testing with in copattern matching with dependent record

-- {-# OPTIONS -v tc.with:20 #-}

open import Common.Prelude
open import Common.Equality

data Dec P : Set where
  yes : (p : P) → Dec P
  no  : (¬p : P → ⊥) → Dec P

postulate
  _≟_ : (n m : Nat) → Dec (n ≡ m)
  boring : {A : Set} → A

record R : Set₁ where
  field
    Car  : Set
    el   : Car
    same : (x : Car) → Dec (x ≡ el)

test : (n : Nat) → R
R.Car  (test n) = Nat
R.el   (test n) = n
R.same (test zero) zero = yes refl
R.same (test zero) (suc x) = no λ()
R.same (test (suc n)) zero = no λ()
R.same (test (suc n)) (suc x) with n ≟ x
R.same (test (suc n)) (suc .n) | yes refl = yes refl
R.same (test (suc n)) (suc x) | no ¬p = no boring


module Homogenous.Nat where

import PolyDepPrelude
open PolyDepPrelude using (zero; one; _::_; nil; right; left; pair; unit)

import Homogenous.Base

open Homogenous.Base using (Sig; T; Intro)

-- The code for natural numbers is [0 1]

codeNat : Sig
codeNat = zero :: (one :: nil)

iNat : Set
iNat = T codeNat

-- Short-hand notation for the normal Nat constructors

izero : iNat
izero = Intro (left unit)

isucc : iNat -> iNat
isucc = \(h : iNat) -> Intro (right (left (pair h unit)))
-- the pair with the dummy unit component comes from the 1-tuple
--   representation as A*()

ione : iNat
ione = isucc izero

{-
main : Set
main = {!!}
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties for Conats
------------------------------------------------------------------------

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

module Codata.Conat.Properties where

open import Size
open import Data.Nat.Base using (ℕ; zero; suc)
open import Codata.Thunk
open import Codata.Conat
open import Codata.Conat.Bisimilarity
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable using (map′)
open import Relation.Binary

private
  variable
    i : Size

0∸m≈0 : ∀ m → i ⊢ zero ∸ m ≈ zero
0∸m≈0 zero    = refl
0∸m≈0 (suc m) = 0∸m≈0 m

sℕ≤s⁻¹ : ∀ {m n} → suc m ℕ≤ suc n → m ℕ≤ n .force
sℕ≤s⁻¹ (sℕ≤s p) = p

_ℕ≤?_ : Decidable _ℕ≤_
zero  ℕ≤? n     = yes zℕ≤n
suc m ℕ≤? zero  = no (λ ())
suc m ℕ≤? suc n = map′ sℕ≤s sℕ≤s⁻¹ (m ℕ≤? n .force)

0ℕ+-identity : ∀ {n} → i ⊢ 0 ℕ+ n ≈ n
0ℕ+-identity = refl

+ℕ0-identity : ∀ {n} → i ⊢ n +ℕ 0 ≈ n
+ℕ0-identity {n = zero}  = zero
+ℕ0-identity {n = suc n} = suc λ where .force → +ℕ0-identity


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

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

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

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

private
  variable
    ℓ : Level

module _ ((R , str) : CommRing ℓ) where

  initialCAlg : CommAlgebra (R , str) ℓ
  initialCAlg =
    let open CommRingStr str
    in  (R , commalgebrastr _ _ _ _ _ (λ r x → r · x)
                    (makeIsCommAlgebra (isSetRing (CommRing→Ring (R , str)))
                       +Assoc +Rid +Rinv +Comm
                       ·Assoc ·Lid
                       ·Ldist+ ·Comm
                        (λ x y z → sym (·Assoc x y z)) ·Ldist+ ·Rdist+ ·Lid
                         λ x y z → sym (·Assoc x y z)))

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

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

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

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

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

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


{-# OPTIONS --universe-polymorphism #-}
module Categories.Morphism.Cartesian where

open import Level

open import Categories.Category
open import Categories.Functor hiding (_≡_; _∘_)

record CartesianProperties {o₀ ℓ₀ e₀} {o₁ ℓ₁ e₁}
                           {E : Category o₀ ℓ₀ e₀} {B : Category o₁ ℓ₁ e₁}
                           {p : Functor E B} {e′ e} {φ : E [ e′ , e ]}
                           {e′′ : Category.Obj E} {ψ : E [ e′′ , e ]}
                           {g : B [ Functor.F₀ p e′′ , Functor.F₀ p e′ ]}
                           (pf : Category._≡_ B (Category._∘_ B (Functor.F₁ p φ) g) (Functor.F₁ p ψ)) : Set (o₀ ⊔ ℓ₀ ⊔ e₀ ⊔ ℓ₁ ⊔ e₁) where
  private module E = Category E
  private module B = Category B
  open B using (_∘_; _≡_)
  open E using () renaming (_∘_ to _∘E_; _≡_ to _≡E_)
  open Functor p renaming (F₀ to p₀; F₁ to p₁)

  field
    χ        : E [ e′′ , e′ ]
    ψ≡φ∘χ    : ψ ≡E φ ∘E χ
    p₁[χ]≡g  : p₁ χ ≡ g

    χ-unique : (f : E [ e′′ , e′ ]) → ψ ≡E φ ∘E f → p₁ f ≡ g → f ≡E χ

record Cartesian {o₀ ℓ₀ e₀} {o₁ ℓ₁ e₁} {E : Category o₀ ℓ₀ e₀} {B : Category o₁ ℓ₁ e₁} (p : Functor E B) {e′ e} (φ : E [ e′ , e ]) : Set (o₀ ⊔ ℓ₀ ⊔ e₀ ⊔ ℓ₁ ⊔ e₁) where
  private module E = Category E
  private module B = Category B
  open B using (_∘_; _≡_)
  open E using () renaming (_∘_ to _∘E_; _≡_ to _≡E_)
  open Functor p renaming (F₀ to p₀; F₁ to p₁)

  field
    properties : ∀ {e′′} (ψ : E [ e′′ , e ]) (g : B [ p₀ e′′ , p₀ e′ ]) (pf : p₁ φ ∘ g ≡ p₁ ψ) → CartesianProperties {p = p} pf


module Structure.Operator.Field.VectorSpace where

import      Lvl
open import Structure.Setoid
open import Structure.Operator.Field
open import Structure.Operator.Properties using (associativity ; identityₗ ; distributivityᵣ)
open import Structure.Operator.Vector
open import Structure.Operator
open import Type

private variable ℓ ℓₑ ℓₗ ℓₗₑ : Lvl.Level
private variable T : Type{ℓ}
private variable _+_ _⋅_ : T → T → T

module _
  ⦃ equiv : Equiv{ℓₑ}(T) ⦄
  ⦃ [+]-oper : BinaryOperator(_+_) ⦄
  ⦃ [⋅]-oper : BinaryOperator(_⋅_) ⦄
  (field-structure : Field{T = T}(_+_)(_⋅_))
  where
  open Field(field-structure)

  fieldVectorSpace : VectorSpace(_+_)(_⋅_)(_+_)(_⋅_)
  VectorSpace.scalarField                   fieldVectorSpace = field-structure
  VectorSpace.[⋅ₛᵥ]-binaryOperator          fieldVectorSpace = [⋅]-oper
  VectorSpace.[⋅ₛ][⋅ₛᵥ]-compatibility       fieldVectorSpace = associativity(_⋅_)
  VectorSpace.[⋅ₛᵥ][+ᵥ]-distributivityₗ     fieldVectorSpace = [⋅][+]-distributivityₗ
  VectorSpace.[⋅ₛᵥ][+ₛ][+ᵥ]-distributivityᵣ fieldVectorSpace = distributivityᵣ(_⋅_)(_+_)


module Simple where

open import Data.Nat renaming (_≟_ to _≟ℕ_)
open import Data.Fin hiding (_+_; inject)
open import Data.String hiding (_++_) renaming (_≟_ to _≟S_)
open import Relation.Nullary using (¬_; yes; no)
open import Relation.Binary.PropositionalEquality using (refl; _≡_)

open import Data.List

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

FName : Set
FName = String

FNames : Set
FNames = List FName

data Expr : ℕ → Set where
   num : ∀ {n} → ℕ → Expr n
   bv  : ∀ {n} → (i : Fin n) → Expr n
   fv  : ∀ {n} → (x : FName) → Expr n
   ƛ   : ∀ {n} → (e : Expr (suc n)) → Expr n
   _·_ : ∀ {n} → (f : Expr n) → (e : Expr n) → Expr n

-- This idx indicates the amount of existence of lambda
-- out of current express

Expr0 : Set
Expr0 = Expr zero

↓ℕ≠ℕ : ∀ {n m} {i : Fin m}
     → ¬ (suc n ≡ toℕ (suc i))
     → ¬ (n ≡ toℕ i)
↓ℕ≠ℕ {n} {m} {i} sn≠si n≡i rewrite n≡i = sn≠si refl
-- ↓ℕ≠ℕ {n} {m} {i} sn≠si n≡i with n≡i
-- ↓ℕ≠ℕ sn≠si n≡i | refl = sn≠si refl

↓fin : ∀ {n} → (i : Fin (suc n)) → ¬ (n ≡ toℕ i) → Fin n
↓fin {zero} zero 0≠0 with 0≠0 refl
↓fin {zero} zero 0≠0 | ()
↓fin {zero} (suc ()) 0≠n
↓fin {suc n} zero i≠0 = zero
↓fin {suc n} (suc i) sn≠si = suc (↓fin i (↓ℕ≠ℕ sn≠si))

↑expr : ∀ {n} → Expr n → Expr (suc n)
↑expr (num i) = num i
↑expr (bv i)   = bv (inject₁ i)
-- inject₁ : ∀ {m} → Fin m → Fin (suc m)
↑expr (fv x)   = fv x
↑expr (ƛ e)    = ƛ (↑expr e)
↑expr (e · e₁) = ↑expr e · ↑expr e₁

{- substitution for bounded and free variable-}

[_↦_] : ∀ n → Expr n → Expr (suc n) → Expr n
[ m ↦ t ] (num i) = num i
[ m ↦ t ] (bv i) with m ≟ℕ toℕ i
... | yes m=i = t
... | no  m≠i = bv (↓fin i m≠i)
[ m ↦ t ] (fv x) = fv x
[ m ↦ t ] (ƛ e) = ƛ ([ suc m ↦ ↑expr t ] e)
[ m ↦ t ] (e · e₁) = [ m ↦ t ] e · [ m ↦ t ] e₁

[_↤_] : ∀ n → FName → Expr n → Expr (suc n)
[ m ↤ name ] (num x)  = num x
[ m ↤ name ] (bv i)   = ↑expr (bv i)
[ m ↤ name ] (fv x)   with x ≟S name
[ m ↤ name ] (fv x) | yes p = bv (fromℕ m)
[ m ↤ name ] (fv x) | no ¬p = fv x
[ m ↤ name ] (ƛ t)    = ƛ ([ suc m ↤ name ] t)
[ m ↤ name ] (t · t₁) = [ m ↤ name ] t · [ m ↤ name ] t₁

[_↝_] : ∀ {n} → FName → Expr n → Expr n → Expr n
[ n ↝ t ] (num i) = num i
[ n ↝ t ] (bv i) = bv i
[ n ↝ t ] (fv x) with n ≟S x
[ n ↝ t ] (fv x) | yes p = t
[ n ↝ t ] (fv x) | no ¬p = fv x
[ n ↝ t ] (ƛ x) = ƛ ([ n ↝ ↑expr t ] x)
[ n ↝ t ] (x · y) = [ n ↝ t ] x · [ n ↝ t ] y

_₀↦_ : Expr 1 → Expr 0 → Expr 0
m ₀↦ t = [ 0 ↦ t ] m

_↦₀_ : FName → Expr 0 → Expr 1
name ↦₀ t = [ 0 ↤ name ] t

_₀↤_ : Expr 0 → FName → Expr 1
t ₀↤ x = [ 0 ↤ x ] t

_₀↝_ : Expr 1 → FName → Expr 0
x ₀↝ s = x ₀↦ (fv s)

fvars : ∀ {n} → Expr n → FNames
fvars (num x) = []
fvars (bv i)  = []
fvars (fv x)  = x ∷ []
fvars (ƛ f)   = fvars f
fvars (f · x) = fvars f ++ fvars x

-- ############################## --
{-         locally closed         -}
-- ############################## --

open import Data.List.Any as Any
open Any.Membership-≡ using (_∈_; _∉_)
open import Data.Product

data LC : ∀ {n} → Expr n → Set where
   numᶜ : ∀ {n} → (i : ℕ) → LC {n} (num i)
   fvᶜ  : ∀ {n}
       → (x : FName)
       → LC {n} (fv x)
   _·ᶜ_ : ∀ {n} {f x}
       → LC {n} f
       → LC {n} x
       → LC {n} (f · x)
   ƛᶜ   : ∀ {e}
       → (ns : FNames)
       → ( ∀ {x} → x ∉ ns → LC {0} (e ₀↦ fv x) )
       → LC {0} (ƛ e)

postulate fresh-gen      : FNames → FName
postulate fresh-gen-spec : ∀ ns → fresh-gen ns ∉ ns

genName : (ns : FNames) → ∃ (λ x → x ∉ ns)
genName ns = fresh-gen ns , fresh-gen-spec ns

orz : ∀ {e} {nn} → nn ↦₀ (e ₀↦ fv nn) ≡ e
orz = {!   !}

foo : ∀ {nn} → (e : Expr 1) → LC {0} (e ₀↦ fv nn) → LC {1} e
foo (num i) lcp = {!   !}
foo (bv i)  lcp = {!   !}
foo (fv y)  lcp = {!   !}
foo (ƛ e)   lcp = {!   !}
foo (f · x) lcp = {!   !}

absᶜ  : ∀ {e} → LC {0} (ƛ e) → LC {1} e
absᶜ (ƛᶜ ns lcex) = {!   !}
   where nn    = proj₁ (genName ns)
         nn∉ns = proj₂ (genName ns)
         x     = lcex {nn} nn∉ns

appᶜ₁ : ∀ {n} {f x} → LC {n} (f · x) → LC {n} f
appᶜ₁ (lcf ·ᶜ lcx) = lcf

appᶜ₂ : ∀ {n} {f x} → LC {n} (f · x) → LC {n} x
appᶜ₂ (lcf ·ᶜ lcx) = lcx

lc? : ∀ {n} → (e : Expr n) → (LC {n} e ⊎ ¬ LC {n} e)
lc? (num x) = inj₁ (numᶜ x)
lc? (bv i)  = inj₂ (λ ())
lc? (fv x)  = inj₁ (fvᶜ x)
lc? (ƛ e)   with lc? e
lc? (ƛ e) | inj₁ x = inj₁ {!   !}
lc? (ƛ e) | inj₂ y = inj₂ {!   !}
lc? (f · x) with lc? f | lc? x
lc? (f · x) | inj₁ f' | inj₁ x' = inj₁ (f' ·ᶜ x')
lc? (f · x) | inj₁ f' | inj₂ x' = inj₂ (λ p → x' (appᶜ₂ p))
lc? (f · x) | inj₂ f' | _       = inj₂ (λ p → f' (appᶜ₁ p))

-- ############################## --
{-       value and semantics      -}
-- ############################## --

data Val : Expr0 → Set where
   num⁰ : ∀ n → Val (num n)
   ƛ⁰   : ∀ e → Val (ƛ e)

var? : (e : Expr0) → (Val e ⊎ ¬ (Val e))
var? (num i) = inj₁ (num⁰ i)
var? (bv i) = inj₂ (λ ())
var? (fv x) = inj₂ (λ ())
var? (ƛ x) = inj₁ (ƛ⁰ x)
var? (x · y) = inj₂ (λ ())

-- don't know what the hell this shit is
data _⟼_ : Expr 0 → Expr 0 → Set where
   app : ∀ {body para}
       → ((ƛ body) · para) ⟼ (body ₀↦ para)


-- Very simple facts about natural numbers
module NatSimple where

import Data.Fin as F

open import Data.Empty
open import Data.Unit
open import Data.Unit.Core
open import Data.Nat renaming (_⊔_ to _⊔ℕ_)
open import Data.Sum renaming (map to _⊎→_)
open import Data.Product renaming (map to _×→_)
open import Function renaming (_∘_ to _○_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import FT

------------------------------------------------------------------------------
-- Equivalences (not used)

data Dec (A : Set) : Set where
  yes : A → Dec A
  no : (A → ⊥) → Dec A

sucEq : {n : ℕ} → (i j : F.Fin n) → (F.suc i) ≡ (F.suc j) → i ≡ j
sucEq i .i refl = refl

_=F=_ : {n : ℕ} → (i j : F.Fin n) → Dec (i ≡ j)
F.zero    =F= F.zero                     = yes refl
(F.suc i) =F= F.zero                     = no (λ ())
F.zero    =F= (F.suc j)                  = no (λ ())
(F.suc i) =F= (F.suc j) with i =F= j
(F.suc i) =F= (F.suc .i) | yes refl      = yes refl
(F.suc i) =F= (F.suc j) | no p           = no (λ q → p (sucEq i j q))

------------------------------------------------------------------
-- Finite Types and the natural numbers are intimately related.

toℕ : FT → ℕ
toℕ ZERO = zero
toℕ ONE = suc zero
toℕ (PLUS b₀ b₁) = (toℕ b₀) + (toℕ b₁)
toℕ (TIMES b₀ b₁) = (toℕ b₀) * (toℕ b₁)

fromℕ : ℕ → FT
fromℕ zero    = ZERO
fromℕ (suc n) = PLUS ONE (fromℕ n)

normalize : FT → FT
normalize = fromℕ ○ toℕ

assocr : {m : ℕ} (n : ℕ) → (PLUS (fromℕ n) (fromℕ m)) ⇛ fromℕ (n + m)
assocr zero = unite₊⇛
assocr (suc n) = assocr₊⇛ ◎ (id⇛ ⊕ (assocr n))

distr : (n₀ : ℕ) {n₁ : ℕ} → TIMES (fromℕ n₀) (fromℕ n₁) ⇛ fromℕ (n₀ * n₁)
distr zero = distz⇛
distr (suc n) {m} = dist⇛ ◎ (unite⋆⇛ ⊕ distr n) ◎ assocr m

normal : (b : FT) → b ⇛ normalize b
normal ZERO = id⇛
normal ONE = uniti₊⇛ ◎ swap₊⇛
normal (PLUS b₀ b₁) = (normal b₀ ⊕ normal b₁) ◎ assocr (toℕ b₀)
normal (TIMES b₀ b₁) = (normal b₀ ⊗ normal b₁) ◎ distr (toℕ b₀)

-- normalize a finite type to (1 + (1 + (1 + ... + (1 + 0) ... )))
-- a bunch of ones ending with zero with left biased + in between

⟦_⟧ℕ : ℕ → Set
⟦ zero ⟧ℕ  = ⊥
⟦ suc n ⟧ℕ = ⊤ ⊎ ⟦ n ⟧ℕ

-- Take a natural number n, and a value of the type represented by that n,
-- and return the canonical finite set of size n.
fromNormalNat : (n : ℕ) → ⟦ n ⟧ℕ → F.Fin n
fromNormalNat zero     ()
fromNormalNat (suc n) (inj₁ tt) = F.zero
fromNormalNat (suc n) (inj₂ x) = F.suc (fromNormalNat n x)

-- Take a natural number n, a finite set of size n, and return a
-- (canonical) value of the type represented by n
toNormalNat : (n : ℕ) → F.Fin n → ⟦ n ⟧ℕ
toNormalNat zero     ()
toNormalNat (suc n) F.zero = inj₁ tt
toNormalNat (suc n) (F.suc f) = inj₂ (toNormalNat n f)

-- BEGIN CODE COPIED (AND SOMEWHAT MODIFIED) FROM Nat.Properties
-- (for some reason +-comm is a private field so I can't get to it without
-- importing superfluous files and going through a bunch of administrative
-- garbage that isn't worth my time)

m+1+n≡1+m+n : ∀ m n → m + suc n ≡ suc (m + n)
m+1+n≡1+m+n zero    n = refl
m+1+n≡1+m+n (suc m) n = cong suc (m+1+n≡1+m+n m n)

+-identity : {n : ℕ} → n + zero ≡ n
+-identity = n+0≡n _
  where
  n+0≡n : (n : ℕ) → n + zero ≡ n
  n+0≡n zero    = refl
  n+0≡n (suc n) = cong suc (n+0≡n n)

+-comm : (m n : ℕ) → m + n ≡ n + m
+-comm zero    n = sym +-identity
+-comm (suc m) n = begin
    suc m + n
  ≡⟨ refl ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨ sym (m+1+n≡1+m+n n m) ⟩
    n + suc m
  ∎

-- END CODE COPIED FROM Nat.Properties

--
add1modn : ℕ → ℕ → ℕ → ℕ
add1modn zero zero acc = zero
add1modn zero (suc n) acc = (suc n) + acc
add1modn (suc max) zero acc = suc acc
add1modn (suc max) (suc n) acc = add1modn max n (suc acc)

-- Useful for testing
one : ℕ
one = suc (zero)

two : ℕ
two = suc one

three : ℕ
three = suc two

four : ℕ
four = suc three

five : ℕ
five = suc four

six : ℕ
six = suc five


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

open import LogicalFormulae
open import Semirings.Definition
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Semiring
open import Orders.Total.Definition
open import Orders.Partial.Definition

module Numbers.Naturals.Order where
open Semiring ℕSemiring
open import Decidable.Lemmas ℕDecideEquality

private
  infix 5 _<NLogical_
  _<NLogical_ : ℕ → ℕ → Set
  zero <NLogical zero = False
  zero <NLogical (succ n) = True
  (succ n) <NLogical zero = False
  (succ n) <NLogical (succ m) = n <NLogical m

infix 5 _<N_
record _<N_ (a : ℕ) (b : ℕ) : Set where
  constructor le
  field
    x : ℕ
    proof : (succ x) +N a ≡ b

infix 5 _<N'_
record _<N'_ (a : ℕ) (b : ℕ) : Set where
  constructor le'
  field
    x : ℕ
    .proof : (succ x) +N a ≡ b

infix 5 _≤N_
_≤N_ : ℕ → ℕ → Set
a ≤N b = (a <N b) || (a ≡ b)

succIsPositive : (a : ℕ) → zero <N succ a
succIsPositive a = le a (applyEquality succ (Semiring.commutative ℕSemiring a 0))

aLessSucc : (a : ℕ) → (a <NLogical succ a)
aLessSucc zero = record {}
aLessSucc (succ a) = aLessSucc a

private
  succPreservesInequalityLogical : {a b : ℕ} → (a <NLogical b) → (succ a <NLogical succ b)
  succPreservesInequalityLogical {a} {b} prAB = prAB

  lessTransitiveLogical : {a b c : ℕ} → (a <NLogical b) → (b <NLogical c) → (a <NLogical c)
  lessTransitiveLogical {a} {zero} {zero} prAB prBC = prAB
  lessTransitiveLogical {a} {(succ b)} {zero} prAB ()
  lessTransitiveLogical {zero} {zero} {(succ c)} prAB prBC = record {}
  lessTransitiveLogical {(succ a)} {zero} {(succ c)} () prBC
  lessTransitiveLogical {zero} {(succ b)} {(succ c)} prAB prBC = record {}
  lessTransitiveLogical {(succ a)} {(succ b)} {(succ c)} prAB prBC = lessTransitiveLogical {a} {b} {c} prAB prBC

  aLessXPlusSuccA : (a x : ℕ) → (a <NLogical x +N succ a)
  aLessXPlusSuccA a zero = aLessSucc a
  aLessXPlusSuccA zero (succ x) = record {}
  aLessXPlusSuccA (succ a) (succ x) = lessTransitiveLogical {a} {succ a} {x +N succ (succ a)} (aLessXPlusSuccA a zero) (aLessXPlusSuccA (succ a) x)

  leImpliesLogical<N : {a b : ℕ} → (a <N b) → (a <NLogical b)
  leImpliesLogical<N {zero} {zero} (le x ())
  leImpliesLogical<N {zero} {(succ b)} (le x proof) = record {}
  leImpliesLogical<N {(succ a)} {zero} (le x ())
  leImpliesLogical<N {(succ a)} {(succ .(succ a))} (le zero refl) = aLessSucc a
  leImpliesLogical<N {(succ a)} {(succ .(succ (x +N succ a)))} (le (succ x) refl) = succPreservesInequalityLogical {a} {succ (x +N succ a)} (lessTransitiveLogical {a} {succ a} {succ (x +N succ a)} (aLessSucc a) (aLessXPlusSuccA a x))

  logical<NImpliesLe : {a b : ℕ} → (a <NLogical b) → (a <N b)
  logical<NImpliesLe {zero} {zero} ()
  _<N_.x (logical<NImpliesLe {zero} {succ b} prAB) = b
  _<N_.proof (logical<NImpliesLe {zero} {succ b} prAB) = applyEquality succ (sumZeroRight b)
  logical<NImpliesLe {(succ a)} {zero} ()
  logical<NImpliesLe {(succ a)} {(succ b)} prAB with logical<NImpliesLe {a} prAB
  logical<NImpliesLe {(succ a)} {(succ .(succ (x +N a)))} prAB | le x refl = le x (applyEquality succ (transitivity (commutative x _) (applyEquality succ (commutative a _))))

lessTransitive : {a b c : ℕ} → (a <N b) → (b <N c) → (a <N c)
lessTransitive {a} {b} {c} prab prbc = logical<NImpliesLe (lessTransitiveLogical {a} {b} {c} (leImpliesLogical<N prab) (leImpliesLogical<N prbc))

lessIrreflexive : {a : ℕ} → (a <N a) → False
lessIrreflexive {zero} pr = leImpliesLogical<N pr
lessIrreflexive {succ a} pr = lessIrreflexive {a} (logical<NImpliesLe {a} {a} (leImpliesLogical<N {succ a} {succ a} pr))

succPreservesInequality : {a b : ℕ} → (a <N b) → (succ a <N succ b)
succPreservesInequality {a} {b} prAB = logical<NImpliesLe (succPreservesInequalityLogical {a} {b} (leImpliesLogical<N prAB))

canRemoveSuccFrom<N : {a b : ℕ} → (succ a <N succ b) → (a <N b)
canRemoveSuccFrom<N {a} {b} (le x proof) rewrite commutative x (succ a) | commutative a x = le x (succInjective proof)

a<SuccA : (a : ℕ) → a <N succ a
a<SuccA a = le zero refl

<NWellDefined : {a b : ℕ} → (p1 : a <N b) → (p2 : a <N b) → _<N_.x p1 ≡ _<N_.x p2
<NWellDefined {a} {b} (le x proof) (le y proof1) = equalityCommutative r
  where
    q : y +N a ≡ x +N a
    q = succInjective {y +N a} {x +N a} (transitivity proof1 (equalityCommutative proof))
    r : y ≡ x
    r = canSubtractFromEqualityRight q

canAddToOneSideOfInequality : {a b : ℕ} (c : ℕ) → a <N b → a <N (b +N c)
canAddToOneSideOfInequality {a} {b} c (le x proof) = le (x +N c) (transitivity (applyEquality succ (equalityCommutative (+Associative x c a))) (transitivity (applyEquality (λ i → (succ x) +N i) (commutative c a)) (transitivity (applyEquality succ (+Associative x a c)) (applyEquality (_+N c) proof))))

canAddToOneSideOfInequality' : {a b : ℕ} (c : ℕ) → a <N b → a <N (c +N b)
canAddToOneSideOfInequality' {a} {b} c (le x proof) = le (x +N c) ans
  where
    ans : succ ((x +N c) +N a) ≡ c +N b
    ans rewrite (equalityCommutative (+Associative x c a)) | commutative c a | (+Associative x a c) = transitivity (applyEquality (_+N c) proof) (commutative b c)

addingIncreases : (a b : ℕ) → a <N a +N succ b
addingIncreases zero b = succIsPositive b
addingIncreases (succ a) b = succPreservesInequality (addingIncreases a b)

zeroNeverGreater : {a : ℕ} → (a <N zero) → False
zeroNeverGreater {a} (le x ())

noIntegersBetweenXAndSuccX : {a : ℕ} (x : ℕ) → (x <N a) → (a <N succ x) → False
noIntegersBetweenXAndSuccX {zero} x x<a a<sx = zeroNeverGreater x<a
noIntegersBetweenXAndSuccX {succ a} x (le y proof) (le z proof1) with succInjective proof1
... | ah rewrite (equalityCommutative proof) | (succExtracts z (y +N x)) | +Associative (succ z) y x | commutative (succ (z +N y)) x = lessIrreflexive {x} (le (z +N y) (transitivity (commutative _ x) ah))

private
  orderIsTotal : (a b : ℕ) → ((a <N b) || (b <N a)) || (a ≡ b)
  orderIsTotal zero zero = inr refl
  orderIsTotal zero (succ b) = inl (inl (logical<NImpliesLe (record {})))
  orderIsTotal (succ a) zero = inl (inr (logical<NImpliesLe (record {})))
  orderIsTotal (succ a) (succ b) with orderIsTotal a b
  orderIsTotal (succ a) (succ b) | inl (inl x) = inl (inl (logical<NImpliesLe (leImpliesLogical<N x)))
  orderIsTotal (succ a) (succ b) | inl (inr x) = inl (inr (logical<NImpliesLe (leImpliesLogical<N x)))
  orderIsTotal (succ a) (succ b) | inr x = inr (applyEquality succ x)

  orderIsIrreflexive : {a b : ℕ} → (a <N b) → (b <N a) → False
  orderIsIrreflexive {zero} {b} prAB (le x ())
  orderIsIrreflexive {(succ a)} {zero} (le x ()) prBA
  orderIsIrreflexive {(succ a)} {(succ b)} prAB prBA = orderIsIrreflexive {a} {b} (logical<NImpliesLe (leImpliesLogical<N prAB)) (logical<NImpliesLe (leImpliesLogical<N prBA))

  orderIsTransitive : {a b c : ℕ} → (a <N b) → (b <N c) → (a <N c)
  orderIsTransitive {a} {.(succ (x +N a))} {.(succ (y +N succ (x +N a)))} (le x refl) (le y refl) = le (y +N succ x) (applyEquality succ (equalityCommutative (+Associative y (succ x) a)))

ℕTotalOrder : TotalOrder ℕ
PartialOrder._<_ (TotalOrder.order ℕTotalOrder) = _<N_
PartialOrder.irreflexive (TotalOrder.order ℕTotalOrder) = lessIrreflexive
PartialOrder.<Transitive (TotalOrder.order ℕTotalOrder) = orderIsTransitive
TotalOrder.totality ℕTotalOrder = orderIsTotal

cannotAddAndEnlarge : (a b : ℕ) → a <N succ (a +N b)
cannotAddAndEnlarge a b = le b (applyEquality succ (commutative b a))

cannotAddAndEnlarge' : {a b : ℕ} → a +N b <N a → False
cannotAddAndEnlarge' {a} {zero} pr rewrite sumZeroRight a = lessIrreflexive pr
cannotAddAndEnlarge' {a} {succ b} pr rewrite (succExtracts a b) = lessIrreflexive {a} (lessTransitive {a} {succ (a +N b)} {a} (cannotAddAndEnlarge a b) pr)

cannotAddAndEnlarge'' : {a b : ℕ} → a +N succ b ≡ a → False
cannotAddAndEnlarge'' {a} {b} pr = naughtE (equalityCommutative inter)
  where
    inter : succ b ≡ 0
    inter rewrite commutative a (succ b) = canSubtractFromEqualityRight pr

naturalsAreNonnegative : (a : ℕ) → (a <N zero) → False
naturalsAreNonnegative zero ()
naturalsAreNonnegative (succ x) ()

lessRespectsAddition : {a b : ℕ} (c : ℕ) → (a <N b) → ((a +N c) <N (b +N c))
lessRespectsAddition {a} {b} zero prAB rewrite commutative a 0 | commutative b 0 = prAB
lessRespectsAddition {a} {b} (succ c) prAB rewrite commutative a (succ c) | commutative b (succ c) | commutative c a | commutative c b = succPreservesInequality (lessRespectsAddition c prAB)

lessRespectsMultiplicationLeft : (a b c : ℕ) → (a <N b) → (zero <N c) → (c *N a <N c *N b)
lessRespectsMultiplicationLeft zero zero c (le x ()) cPos
lessRespectsMultiplicationLeft zero (succ b) zero prAB (le x ())
lessRespectsMultiplicationLeft zero (succ b) (succ c) prAB cPos = i
  where
    productNonzeroIsNonzero : {a b : ℕ} → zero <N a → zero <N b → zero <N a *N b
    productNonzeroIsNonzero {zero} {b} prA prB = prA
    productNonzeroIsNonzero {succ a} {zero} prA ()
    productNonzeroIsNonzero {succ a} {succ b} prA prB = le (b +N a *N succ b) (applyEquality succ (Semiring.sumZeroRight ℕSemiring _))

    j : zero <N succ c *N succ b
    j = productNonzeroIsNonzero cPos prAB
    i : succ c *N zero <N succ c *N succ b
    i = identityOfIndiscernablesLeft _<N_ j (equalityCommutative (productZeroRight c))
lessRespectsMultiplicationLeft (succ a) zero c (le x ()) cPos
lessRespectsMultiplicationLeft (succ a) (succ b) c prAB cPos = m
  where
    h : c *N a <N c *N b
    h = lessRespectsMultiplicationLeft a b c (canRemoveSuccFrom<N prAB) cPos
    j : c *N a +N c <N c *N b +N c
    j = lessRespectsAddition c h
    i : c *N succ a <N c *N b +N c
    i = identityOfIndiscernablesLeft _<N_ j (equalityCommutative (transitivity (multiplicationNIsCommutative c _) (transitivity (applyEquality (c +N_) (multiplicationNIsCommutative a _)) (commutative c _))))
    m : c *N succ a <N c *N succ b
    m = identityOfIndiscernablesRight _<N_ i (equalityCommutative (transitivity (multiplicationNIsCommutative c _) (transitivity (commutative c _) (applyEquality (_+N c) (multiplicationNIsCommutative b _)))))

canFlipMultiplicationsInIneq : {a b c d : ℕ} → (a *N b <N c *N d) → b *N a <N d *N c
canFlipMultiplicationsInIneq {a} {b} {c} {d} pr = identityOfIndiscernablesRight _<N_ (identityOfIndiscernablesLeft _<N_ pr (multiplicationNIsCommutative a b)) (multiplicationNIsCommutative c d)

lessRespectsMultiplication : (a b c : ℕ) → (a <N b) → (zero <N c) → (a *N c <N b *N c)
lessRespectsMultiplication a b c prAB cPos = canFlipMultiplicationsInIneq {c} {a} {c} {b} (lessRespectsMultiplicationLeft a b c prAB cPos)

squash<N : {a b : ℕ} → .(a <N b) → a <N b
squash<N {a} {b} a<b with orderIsTotal a b
... | inl (inl x) = x
... | inl (inr x) = exFalso (lessIrreflexive (orderIsTransitive x a<b))
squash<N {a} {b} a<b | inr refl = exFalso (lessIrreflexive a<b)

<NTo<N' : {a b : ℕ} → a <N b → a <N' b
<NTo<N' (le x proof) = le' x proof

<N'To<N : {a b : ℕ} → a <N' b → a <N b
<N'To<N {a} {b} (le' x proof) = le x (squash proof)

<N'Refl : {a b : ℕ} → (p1 p2 : a <N' b) → p1 ≡ p2
<N'Refl p1 p2 with <NWellDefined (<N'To<N p1) (<N'To<N p2)
... | refl = refl


{-# OPTIONS --safe #-}
module Cubical.Algebra.NatSolver.HornerForms where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat hiding (isZero)
open import Cubical.Data.FinData
open import Cubical.Data.Vec
open import Cubical.Data.Bool using (Bool; true; false; if_then_else_)

private
  variable
    ℓ : Level

{-
  This defines the type of multivariate Polynomials over ℕ.
  The construction is based on the algebraic fact

    ℕ[X₀][X₁]⋯[Xₙ] ≅ ℕ[X₀,⋯,Xₙ]

  BUT: Contrary to algebraic convetions, we will give 'Xₙ' the lowest index
  in the definition of 'Variable' below. So if 'Variable n k' is identified
  with 'Xₖ', what we construct should rather be denoted with

    ℕ[Xₙ][Xₙ₋₁]⋯[X₀]

  or, to be precise about the evaluation order:

    (⋯((ℕ[Xₙ])[Xₙ₋₁])⋯)[X₀]

-}

data IteratedHornerForms : ℕ → Type ℓ-zero where
  const : ℕ → IteratedHornerForms ℕ.zero
  0H : {n : ℕ} → IteratedHornerForms (ℕ.suc n)
  _·X+_ : {n : ℕ} → IteratedHornerForms (ℕ.suc n) → IteratedHornerForms n
                  → IteratedHornerForms (ℕ.suc n)

eval : {n : ℕ} (P : IteratedHornerForms n)
       → Vec ℕ n → ℕ
eval (const r) [] = r
eval 0H (_ ∷ _) = 0
eval (P ·X+ Q) (x ∷ xs) =
  (eval P (x ∷ xs)) · x + eval Q xs

module IteratedHornerOperations where

  private
    1H' : (n : ℕ) → IteratedHornerForms n
    1H' ℕ.zero = const 1
    1H' (ℕ.suc n) = 0H ·X+ 1H' n

    0H' : (n : ℕ) → IteratedHornerForms n
    0H' ℕ.zero = const 0
    0H' (ℕ.suc n) = 0H

  1ₕ : {n : ℕ} → IteratedHornerForms n
  1ₕ {n = n} = 1H' n

  0ₕ : {n : ℕ} → IteratedHornerForms n
  0ₕ {n = n} = 0H' n

  X : (n : ℕ) (k : Fin n) → IteratedHornerForms n
  X (ℕ.suc m) zero = 1ₕ ·X+ 0ₕ
  X (ℕ.suc m) (suc k) = 0ₕ ·X+ X m k

  _+ₕ_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms n
               → IteratedHornerForms n
  (const r) +ₕ (const s) = const (r + s)
  0H +ₕ Q = Q
  (P ·X+ r) +ₕ 0H = P ·X+ r
  (P ·X+ r) +ₕ (Q ·X+ s) = (P +ₕ Q) ·X+ (r +ₕ s)

  isZero : {n : ℕ} → IteratedHornerForms (ℕ.suc n)
                   → Bool
  isZero 0H = true
  isZero (P ·X+ P₁) = false

  _⋆_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms (ℕ.suc n)
                → IteratedHornerForms (ℕ.suc n)
  _·ₕ_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms n
                → IteratedHornerForms n
  r ⋆ 0H = 0H
  r ⋆ (P ·X+ Q) = (r ⋆ P) ·X+ (r ·ₕ Q)

  const x ·ₕ const y = const (x · y)
  0H ·ₕ Q = 0H
  (P ·X+ Q) ·ₕ S =
     let
        z = (P ·ₕ S)
     in if (isZero z)
        then (Q ⋆ S)
        else (z ·X+ 0ₕ) +ₕ (Q ⋆ S)

Variable : (n : ℕ) (k : Fin n) → IteratedHornerForms n
Variable n k = IteratedHornerOperations.X n k

Constant : (n : ℕ) (r : ℕ) → IteratedHornerForms n
Constant ℕ.zero r = const r
Constant (ℕ.suc n) r = IteratedHornerOperations.0ₕ ·X+ Constant n r


import      Lvl
open import Structure.Setoid
open import Type

module Automaton.TuringMachine where

open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Data.Either as Either using (_‖_)
open import Data.Either.Setoid
open import Data.Option as Option
open import Data.Option.Functions as Option
open import Data.Option.Setoid
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Equivalence
open import Data.List renaming (∅ to ε ; _⊰_ to _·_)
open import Data.List.Setoid
open import Functional
open import Logic
open import Relator.Equals.Proofs.Equivalence
open import Structure.Operator
open import Structure.Relator
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type.Size.Finite

private variable ℓₚ ℓₛ ℓₐ ℓₑₛ ℓₑₐ : Lvl.Level
private variable Alphabet : Type{ℓₐ}

data Direction : Type{Lvl.𝟎} where
  Backward : Direction
  Stay     : Direction
  Forward  : Direction
private instance _ = [≡]-equiv {T = Direction}

record Tape (Alphabet : Type{ℓₐ}) : Type{ℓₐ} where
  coinductive
  field
    back    : Tape(Alphabet)
    current : Alphabet
    front   : Tape(Alphabet)

  update : (Alphabet → Alphabet) → Tape(Alphabet)
  back   (update _) = back
  current(update f) = f(current)
  front  (update _) = front

stepBackward : Tape(Alphabet) → Tape(Alphabet)
Tape.back   (stepBackward t) = Tape.back(Tape.back t)
Tape.current(stepBackward t) = Tape.current(Tape.back t)
Tape.front  (stepBackward t) = t

stepForward : Tape(Alphabet) → Tape(Alphabet)
Tape.back   (stepForward t) = t
Tape.current(stepForward t) = Tape.current(Tape.front t)
Tape.front  (stepForward t) = Tape.front(Tape.front t)

stepInDirection : Direction → Tape(Alphabet) → Tape(Alphabet)
stepInDirection Backward = stepBackward
stepInDirection Stay     = id
stepInDirection Forward  = stepForward

module _ ⦃ equiv-alphabet : Equiv{ℓₑₐ}(Alphabet) ⦄ where
  step-inverseₗᵣ : ∀{t : Tape(Alphabet)} → (Tape.current(stepBackward(stepForward(t))) ≡ Tape.current(t))
  step-inverseₗᵣ = reflexivity(_≡_ ⦃ equiv-alphabet ⦄)

  step-inverseᵣₗ : ∀{t : Tape(Alphabet)} → (Tape.current(stepBackward(stepForward(t))) ≡ Tape.current(t))
  step-inverseᵣₗ = reflexivity(_≡_ ⦃ equiv-alphabet ⦄)

module _
  (State : Type{ℓₛ})    ⦃ equiv-state : Equiv{ℓₑₛ}(State) ⦄
  (Alphabet : Type{ℓₐ}) ⦃ equiv-alphabet : Equiv{ℓₑₐ}(Alphabet) ⦄
  where

  private instance _ = [≡]-equiv {T = Bool}

  -- Turing machine
  -- `State`      (Q)  is the set of states.
  -- `Alphabet`   (Σ)  is the set of symbols/the alphabet.
  -- `transition` (δ)  is the transition function.
  -- `start`      (q₀) is the start state.
  -- `Final`      (F)  is the subset of State which are the final/accepting states.
  record TuringMachine : Type{ℓₛ Lvl.⊔ ℓₑₐ Lvl.⊔ ℓₑₛ Lvl.⊔ ℓₐ Lvl.⊔ Lvl.𝐒(ℓₚ)} where
    constructor turingMachine
    field
      ⦃ State-finite ⦄              : Finite(State)
      ⦃ Alphabet-finite ⦄           : Finite(Alphabet)
      transition                    : State → Option(Alphabet) → Option(State ⨯ Alphabet ⨯ Direction)
      ⦃ transition-binaryOperator ⦄ : BinaryOperator(transition)
      start                         : State
      Final                         : State → Type{ℓₚ}
      ⦃ Final-unaryRelator ⦄        : UnaryRelator(Final)

    -- isFinal : State → Bool

  -- TODO: Not sure what the best (most easy to use) formalization of a TM would be or if this is correct
  Configuration = State ⨯ Tape(Option(Alphabet))
  module Configuration where
    step : TuringMachine{ℓₚ} → (Configuration → Option(Configuration))
    step tm (s , t) = Option.map (\(ns , nx , dir) → (ns , stepInDirection dir (Tape.update t (Some ∘ const nx)))) (TuringMachine.transition tm s (Tape.current t))


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

module ConcretePermutationProperties where

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; module ≡-Reasoning; proof-irrelevance)

--

-- open import FinVecProperties using (∘̂-assoc; ∘̂-lid; ∘̂-rid)
open import ConcretePermutation
------------------------------------------------------------------------------
-- Properties of vectors where are only used to prove some properties
-- of concrete permutations -> do not export them.
private
  open import Data.Nat using (ℕ)
  open import Data.Fin using (Fin)
  open import Data.Vec using (Vec)
  open import Data.Vec.Properties using (lookup-allFin)
  open import Proofs using (finext; lookupassoc; _!!_)

  ∘̂-assoc : {m₁ m₂ m₃ m₄ : ℕ} →
           (a : Vec (Fin m₂) m₁) (b : Vec (Fin m₃) m₂) (c : Vec (Fin m₄) m₃) →
           a ∘̂ (b ∘̂ c) ≡ (a ∘̂ b) ∘̂ c
  ∘̂-assoc a b c = finext (lookupassoc a b c)

  ∘̂-rid : {m n : ℕ} → (π : Vec (Fin m) n) → π ∘̂ 1C ≡ π
  ∘̂-rid π = trans (finext (λ i → lookup-allFin (π !! i))) (cauchyext π)

  ∘̂-lid : {m n : ℕ} → (π : Vec (Fin m) n) → 1C ∘̂ π ≡ π
  ∘̂-lid π = trans (finext (λ i → cong (_!!_ π) (lookup-allFin i))) (cauchyext π)

------------------------------------------------------------------------------
-- Properties of concrete permutations that are needed to show that
-- this is also a symmetric rig groupoid

-- If the forward components are equal, then so are the backward ones

πᵒ≡ : ∀ {m n} → (π₁ π₂ : CPerm m n) → (CPerm.π π₁ ≡ CPerm.π π₂) →
      (CPerm.πᵒ π₁ ≡ CPerm.πᵒ π₂)
πᵒ≡ {n} (cp π πᵒ αp βp) (cp .π πᵒ₁ αp₁ βp₁) refl =
  begin (
    πᵒ                  ≡⟨ sym (∘̂-rid πᵒ) ⟩
    πᵒ ∘̂ 1C          ≡⟨  cong (_∘̂_ πᵒ) (sym αp₁)  ⟩
    πᵒ ∘̂ (π ∘̂ πᵒ₁)      ≡⟨ ∘̂-assoc πᵒ π πᵒ₁ ⟩
    (πᵒ ∘̂ π) ∘̂ πᵒ₁      ≡⟨ cong (λ x → x ∘̂ πᵒ₁) βp ⟩
    1C ∘̂ πᵒ₁            ≡⟨ ∘̂-lid πᵒ₁ ⟩
    πᵒ₁ ∎)
  where open ≡-Reasoning

-- If the forward components are equal, then so are the entire
-- concrete permutations

p≡ : ∀ {m n} → {π₁ π₂ : CPerm m n} → (CPerm.π π₁ ≡ CPerm.π π₂) → π₁ ≡ π₂
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π πᵒ₁ αp₁ βp₁} refl with
  πᵒ≡ (cp π πᵒ αp βp) (cp π πᵒ₁ αp₁ βp₁) refl
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π .πᵒ αp₁ βp₁} refl | refl
  with proof-irrelevance αp αp₁ | proof-irrelevance βp βp₁
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π .πᵒ .αp .βp} refl | refl | refl | refl = refl

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


{-# OPTIONS --cubical #-}
module Cubical.Foundations.Equiv.Fiberwise where

open import Cubical.Core.Everything

open import Cubical.Foundations.Everything

module _ {a p q} {A : Type a} (P : A → Type p) (Q : A → Type q)
         (f : ∀ x → P x → Q x)
         where
  private
    total : (Σ A P) → (Σ A Q)
    total = (\ p → p .fst , f (p .fst) (p .snd))

  -- Thm 4.7.6
  fibers-total : ∀ {xv} → Iso (fiber total (xv)) (fiber (f (xv .fst)) (xv .snd))
  fibers-total {xv} = iso h g h-g g-h
   where
    h : ∀ {xv} → fiber total xv → fiber (f (xv .fst)) (xv .snd)
    h {xv} (p , eq) = J (\ xv eq → fiber (f (xv .fst)) (xv .snd)) ((p .snd) , refl) eq
    g : ∀ {xv} → fiber (f (xv .fst)) (xv .snd) → fiber total xv
    g {xv} (p , eq) = (xv .fst , p) , (\ i → _ , eq i)
    h-g : ∀ {xv} y → h {xv} (g {xv} y) ≡ y
    h-g {x , v} (p , eq) = J (λ _ eq₁ → h (g (p , eq₁)) ≡ (p , eq₁)) (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) ((p , refl))) (eq)
    g-h : ∀ {xv} y → g {xv} (h {xv} y) ≡ y
    g-h {xv} ((a , p) , eq) = J (λ _ eq₁ → g (h ((a , p) , eq₁)) ≡ ((a , p) , eq₁))
                                (cong g (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) (p , refl)))
                                eq
  -- half of Thm 4.7.7 (fiberwise equivalences)
  fiberEquiv : ([tf] : isEquiv total)
               → ∀ x → isEquiv (f x)
  fiberEquiv [tf] x .equiv-proof y = retractIsContr (fibers-total .Iso.inv) (fibers-total .Iso.fun) (fibers-total .Iso.rightInv)
                                                    ([tf] .equiv-proof (x , y))

module _ {ℓ : Level} {U : Type ℓ} {ℓr} (_~_ : U → U → Type ℓr)
         (idTo~ : ∀ {A B} → A ≡ B → A ~ B)
         (c : ∀ A → isContr (Σ U \ X → A ~ X))
       where

  isContrToUniv : ∀ {A B} → isEquiv (idTo~ {A} {B})
  isContrToUniv {A} {B}
    = fiberEquiv (λ z → A ≡ z) (λ z → A ~ z) (\ B → idTo~ {A} {B})
                 (λ { .equiv-proof y
                    → isContrSigma ((_ , refl) , (\ z → contrSingl (z .snd)))
                                   \ a → isContrPath (c A) _ _
                    })
                 B


module Sets.PredicateSet.Filter {ℓₒ} {ℓₒₗ} where

import      Lvl
open import Functional
open import Logic.Propositional
-- open import Sets.PredicateSet
open import Type{ℓₒ Lvl.⊔ ℓₒₗ}

-- An element in Filter(T) is in the subset of T.
-- Something of type Filter(T) is of a restricted part of T.
-- Note: The level of Stmt inside P is lower than Type.
-- TODO: Is this the same as (⊤ ∩ P) in "Sets.PredicateSet"?
record Filter {T : Type} (P : T → Stmt{ℓₒₗ}) : Type where
  constructor subelem
  field
    elem             : T
    ⦃ satisfaction ⦄ : P(elem)

-- postulate nested-subset : ∀{T}{φ₁}{φ₂} → (Tₛ₁ : Filter{T}(φ₁)) → (Tₛ₂ : Filter{Filter{T}(φ₁)}(φ₂)) → Filter{T}(x ↦ φ₁(x) ∧ φ₂(subelem (x) ⦃ ⦄))
-- postulate nested-subset : ∀{T}{φ₁}{φ₂} → (Tₛ₁ : Filter{T}(φ₁)) → (Tₛ₂ : Filter{Filter{T}(φ₁)}(φ₂ ∘ Filter.elem)) → Filter{T}(x ↦ φ₁(x) ∧ φ₂(x))
-- postulate nested-subset : ∀{T}{φ₁}{φ₂} → (Filter{Filter{T}(φ₁)}(φ₂ ∘ Filter.elem) ≡ Filter{T}(x ↦ φ₁(x) ∧ φ₂(x)))


module Numeral.Natural.UnclosedOper where

import Lvl
open import Data
open import Data.Boolean.Stmt
open import Data.Option as Option using (Option)
open import Data.Option.Functions as Option
open import Logic.Propositional
open import Numeral.Finite as 𝕟
  using (𝕟)
import      Numeral.Finite.Bound as 𝕟bound
open import Numeral.Integer as ℤ
  using (ℤ)
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Oper.Modulo.Proofs
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Decidable
open import Numeral.Natural.Relation.Order.Proofs
import      Numeral.Sign as Sign
open import Type.Properties.Decidable.Proofs

infix  10010 _−_

-- TODO _/_ : ℕ → ℕ → ℚ

-- Unclosed total subtraction from natural numbers to an optional natural number.
-- When the subtraction gives a negative number semantically, this operation gives Option.None.
_−?_ : ℕ → ℕ → Option(ℕ)
a    −? 𝟎    = Option.Some(a)
𝟎    −? 𝐒(b) = Option.None
𝐒(a) −? 𝐒(b) = a −? b

-- Unclosed total floored division
{-# TERMINATING #-}
_⌊/₀⌋_ : ℕ → ℕ → ℕ
𝐒(x) ⌊/₀⌋ 𝐒(y) with (𝐒(x) −? 𝐒(y))
... | Option.Some(𝐒x𝐒y) = 𝐒(𝐒x𝐒y ⌊/₀⌋ 𝐒(y))
... | Option.None       = 𝟎
{-# CATCHALL #-}
_    ⌊/₀⌋ _    = 𝟎

-- Unclosed total subtraction from natural numbers to an optional natural number.
-- When dividing by 0, this operation gives Option.None.
{-# TERMINATING #-}
_⌊/⌋?_ : ℕ → ℕ → Option(ℕ)
_    ⌊/⌋? 𝟎    = Option.None
𝟎    ⌊/⌋? 𝐒(_) = Option.Some(𝟎)
𝐒(x) ⌊/⌋? 𝐒(y) with (𝐒(x) −? 𝐒(y))
... | Option.Some(𝐒x𝐒y) = Option.map 𝐒(𝐒x𝐒y ⌊/⌋? 𝐒(y))
... | Option.None       = Option.Some(𝟎)

-- Unclosed total subtraction from natural numbers to an optional natural number.
-- When dividing by 0 or the division gives a rational number semantically, this operation gives Option.None.
{-# TERMINATING #-}
_/?_ : ℕ → ℕ → Option(ℕ)
_    /? 𝟎    = Option.None
𝟎    /? 𝐒(_) = Option.Some(𝟎)
𝐒(x) /? 𝐒(y) with (𝐒(x) −? 𝐒(y))
... | Option.Some(𝐒x𝐒y) = Option.map 𝐒(𝐒x𝐒y /? 𝐒(y))
... | Option.None       = Option.None

-- Unclosed total subtraction from natural numbers to finite natural numbers
_−₀fin_ : (x : ℕ) → ℕ → 𝕟(𝐒(x))
𝟎    −₀fin _    = 𝕟.𝟎
𝐒(x) −₀fin 𝟎    = 𝕟.𝐒(x −₀fin 𝟎)
𝐒(x) −₀fin 𝐒(y) = 𝕟bound.bound-𝐒 (x −₀fin y)

-- Unclosed total subtraction from a natural number and a finite natural number to a finite natural number
_−fin_ : (x : ℕ) → 𝕟(𝐒(x)) → 𝕟(𝐒(x))
𝟎    −fin 𝕟.𝟎    = 𝕟.𝟎
𝐒(x) −fin 𝕟.𝟎    = 𝕟.𝐒(x −fin 𝕟.𝟎)
𝐒(x) −fin 𝕟.𝐒(y) = 𝕟bound.bound-𝐒 (x −fin y)

-- Modulo operation to upper bounded natural numbers.
_modfin_ : ℕ → (b : ℕ) → ⦃ _ : IsTrue(b ≢? 𝟎) ⦄ → 𝕟(b)
a modfin 𝐒 b = 𝕟.ℕ-to-𝕟 (a mod 𝐒(b)) ⦃ [↔]-to-[→] decider-true (mod-maxᵣ{a}{𝐒 b}) ⦄


------------------------------------------------------------------------
-- The Agda standard library
--
-- Half adjoint equivalences
------------------------------------------------------------------------

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

module Function.HalfAdjointEquivalence where

open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Level
open import Relation.Binary.PropositionalEquality

-- Half adjoint equivalences (see the HoTT book).

record _≃_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  field
    to               : A → B
    from             : B → A
    left-inverse-of  : ∀ x → from (to x) ≡ x
    right-inverse-of : ∀ x → to (from x) ≡ x
    left-right       :
      ∀ x → cong to (left-inverse-of x) ≡ right-inverse-of (to x)

  -- Half adjoint equivalences can be turned into inverses.

  inverse : A ↔ B
  inverse = Inv.inverse to from left-inverse-of right-inverse-of

  -- The forward direction of a half adjoint equivalence is injective.

  injective : ∀ {x y} → to x ≡ to y → x ≡ y
  injective {x} {y} to-x≡to-y =
    x            ≡⟨ sym (left-inverse-of _) ⟩
    from (to x)  ≡⟨ cong from to-x≡to-y ⟩
    from (to y)  ≡⟨ left-inverse-of _ ⟩
    y            ∎
    where
    open ≡-Reasoning

-- Inverses can be turned into half adjoint equivalences.
--
-- (This proof is based on one in the HoTT book.)

↔→≃ : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → A ≃ B
↔→≃ A↔B = record
  { to               = to   ⟨$⟩_
  ; from             = from ⟨$⟩_
  ; left-inverse-of  = left-inverse-of
  ; right-inverse-of = right-inverse-of
  ; left-right       = left-right
  }
  where
  open ≡-Reasoning
  open module A↔B = Inverse A↔B using (to; from; left-inverse-of)

  right-inverse-of : ∀ x → to ⟨$⟩ (from ⟨$⟩ x) ≡ x
  right-inverse-of x =
    to ⟨$⟩ (from ⟨$⟩ x)                      ≡⟨ sym (A↔B.right-inverse-of _) ⟩
    to ⟨$⟩ (from ⟨$⟩ (to ⟨$⟩ (from ⟨$⟩ x)))  ≡⟨ cong (to ⟨$⟩_) (left-inverse-of _) ⟩
    to ⟨$⟩ (from ⟨$⟩ x)                      ≡⟨ A↔B.right-inverse-of _ ⟩
    x                                        ∎

  left-right :
    ∀ x →
    cong (to ⟨$⟩_) (left-inverse-of x) ≡ right-inverse-of (to ⟨$⟩ x)
  left-right x =
    cong (to ⟨$⟩_) (left-inverse-of x)               ≡⟨⟩

    trans refl (cong (to ⟨$⟩_) (left-inverse-of _))  ≡⟨ cong (λ p → trans p (cong (to ⟨$⟩_) _))
                                                          (sym (trans-symˡ (A↔B.right-inverse-of _))) ⟩
    trans (trans (sym (A↔B.right-inverse-of _))
               (A↔B.right-inverse-of _))
      (cong (to ⟨$⟩_) (left-inverse-of _))           ≡⟨ trans-assoc (sym (A↔B.right-inverse-of _)) ⟩

    trans (sym (A↔B.right-inverse-of _))
      (trans (A↔B.right-inverse-of _)
         (cong (to ⟨$⟩_) (left-inverse-of _)))       ≡⟨ cong (trans (sym (A↔B.right-inverse-of _))) lemma ⟩

    trans (sym (A↔B.right-inverse-of _))
      (trans (cong (to ⟨$⟩_) (left-inverse-of _))
         (trans (A↔B.right-inverse-of _) refl))      ≡⟨⟩

    right-inverse-of (to ⟨$⟩ x)                      ∎
    where
    lemma =
      trans (A↔B.right-inverse-of _)
        (cong (to ⟨$⟩_) (left-inverse-of _))             ≡⟨ cong (trans (A↔B.right-inverse-of _)) (sym (cong-id _)) ⟩

      trans (A↔B.right-inverse-of _)
        (cong id (cong (to ⟨$⟩_) (left-inverse-of _)))   ≡⟨ sym (naturality A↔B.right-inverse-of) ⟩

      trans (cong ((to ⟨$⟩_) ∘ (from ⟨$⟩_))
                 (cong (to ⟨$⟩_) (left-inverse-of _)))
        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans p (A↔B.right-inverse-of _))
                                                              (sym (cong-∘ _)) ⟩
      trans (cong ((to ⟨$⟩_) ∘ (from ⟨$⟩_) ∘ (to ⟨$⟩_))
                      (left-inverse-of _))
        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans p (A↔B.right-inverse-of _))
                                                              (cong-∘ _) ⟩
      trans (cong (to ⟨$⟩_)
                 (cong ((from ⟨$⟩_) ∘ (to ⟨$⟩_))
                    (left-inverse-of _)))
        (A↔B.right-inverse-of _)                         ≡⟨ cong (λ p → trans (cong (to ⟨$⟩_) p) _)
                                                              (cong-≡id left-inverse-of) ⟩
      trans (cong (to ⟨$⟩_) (left-inverse-of _))
        (A↔B.right-inverse-of _)                         ≡⟨ cong (trans (cong (to ⟨$⟩_) (left-inverse-of _)))
                                                              (sym (trans-reflʳ _)) ⟩
      trans (cong (to ⟨$⟩_) (left-inverse-of _))
        (trans (A↔B.right-inverse-of _) refl)            ∎


-- Andreas, 2012-02-24 example by Ramana Kumar
{-# OPTIONS --sized-types #-}
-- {-# OPTIONS --show-implicit -v tc.size.solve:20 -v tc.conv.size:15 #-}
module SizeInconsistentMeta4 where

open import Data.Nat using (ℕ;zero;suc) renaming (_<_ to _N<_)
open import Data.Product using (_,_;_×_)
open import Data.Product.Relation.Binary.Lex.Strict using (×-Lex; ×-transitive)
open import Data.List using (List)
open import Data.List.Relation.Binary.Lex.Strict using (Lex-<) renaming (<-transitive to Lex<-trans)
open import Relation.Binary using (Rel;_Respects₂_;Transitive;IsEquivalence)

open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)

open import Level using (0ℓ)
open import Size using (Size;↑_)

-- keeping the definition of Vec for the positivity check
infixr 5 _∷_
data Vec {a} (A : Set a) : ℕ → Set a where
  []  : Vec A zero
  _∷_ : ∀ {n} (x : A) (xs : Vec A n) → Vec A (suc n)

{- produces different error
data Lex-< {A : _} (_≈_ _<_ : Rel A Level.zero) : Rel (List A) Level.zero where
postulate
  Lex<-trans : ∀ {P _≈_ _<_} →
               IsEquivalence _≈_ → _<_ Respects₂ _≈_ → Transitive _<_ →
               Transitive (Lex-< _≈_ _<_)
-}

postulate
  N<-trans : Transitive _N<_
  -- Vec : ∀ {a} (A : Set a) → ℕ → Set a
  Vec→List : ∀ {a n} {A : Set a} → Vec A n → List A

data Type : Size → Set where
  TyApp : {z : Size} (n : ℕ) → (as : Vec (Type z) n) → Type (↑ z)

<-transf : ∀ {z} → Rel (Type z) 0ℓ → Rel (ℕ × List (Type z)) 0ℓ
<-transf _<_ = ×-Lex _≡_ _N<_ (Lex-< _≡_ _<_)

infix 4 _<_
data _<_ : {z : Size} → Rel (Type z) 0ℓ where
  TyApp<TyApp : ∀ {z} {n₁} {as₁} {n₂} {as₂} →
                <-transf (_<_ {z}) (n₁ , Vec→List as₁) (n₂ , Vec→List as₂) →
                _<_ {↑ z} (TyApp n₁ as₁) (TyApp n₂ as₂)

<-trans : ∀ {z} → Transitive (_<_ {z})
<-trans (TyApp<TyApp p) (TyApp<TyApp q) =
  TyApp<TyApp (×-transitive {_<₂_ = Lex-< _≡_ _<_}
                 PropEq.isEquivalence
                (PropEq.resp₂ _N<_)
                N<-trans
                (Lex<-trans PropEq.isEquivalence (PropEq.resp₂ _<_) <-trans)
                p q)


{-# OPTIONS --cubical #-}
module leibniz where

open import Cubical.Data.Equality
open import Cubical.Foundations.Function using (_∘_)

module Martin-Löf {ℓ} {A : Set ℓ} where

  reflexive≡ : {a : A} → a ≡p a
  reflexive≡ = reflp

  symmetric≡ : {a b : A} → a ≡p b → b ≡p a
  symmetric≡ reflp = reflp

  transitive≡ : {a b c : A} → a ≡p b → b ≡p c → a ≡p c
  transitive≡ reflp reflp = reflp

open Martin-Löf public

ext : ∀ {ℓ ℓ′} {A : Set ℓ} {B : A → Set ℓ′} {f g : (a : A) → B a} →
            (∀ (a : A) → f a ≡p g a) → f ≡p g
ext p = ctop (funExt (ptoc ∘ p))

module Leibniz {A : Set} where

  _≐_ : (a b : A) → Set₁
  a ≐ b = (P : A → Set) → P a → P b

  reflexive≐ : {a : A} → a ≐ a
  reflexive≐ P Pa = Pa

  transitive≐ : {a b c : A} → a ≐ b → b ≐ c → a ≐ c
  transitive≐ a≐b b≐c P Pa = b≐c P (a≐b P Pa)

  symmetric≐ : {a b : A} → a ≐ b → b ≐ a
  symmetric≐ {a} {b} a≐b P = Qb
    where
      Q : A → Set
      Q c = P c → P a
      Qa : Q a
      Qa = reflexive≐ P
      Qb : Q b
      Qb = a≐b Q Qa

open Leibniz

T : Set → Set₁
T A = ∀ (X : Set) → (A → X) → X

module WarmUp (A : Set) where

  postulate
    paramT : (t : T A) → (X X′ : Set) (R : X → X′ → Set) →
             (k : A → X) (k′ : A → X′) (kR : (a : A) → R (k a) (k′ a)) →
             R (t X k) (t X′ k′)

  i : A → T A
  i a X k = k a

  id : A → A
  id a = a

  j : T A → A
  j t = t A id

  ji : (a : A) → (j (i a) ≡p a)
  ji a = reflp

  ijₑₓₜ : (t : T A) (X : Set) (k : A → X) → (i (j t) X k ≡p t X k)
  ijₑₓₜ t X k = paramT t A X R id k (λ a → reflp)
    where
      R : A → X → Set
      R a x = k a ≡p x

  ij : (t : T A) → (i (j t) ≡p t)
  ij t = ext (λ X → ext (λ k → ijₑₓₜ t X k))

module MainResult (A : Set) where

  postulate
    param≐ : {a b : A} (a≐b : a ≐ b) →
             (P P′ : A → Set) → (R : (c : A) → P c → P′ c → Set) →
                (Pa : P a) (P′a : P′ a) → R a Pa P′a →
                    R b (a≐b P Pa) (a≐b P′ P′a)

  i : {a b : A} (a≡b : a ≡p b) → a ≐ b
  i reflp P Pa = Pa

  j : {a b : A} → a ≐ b → a ≡p b
  j {a} {b} a≐b = Qb
    where
      Q : A → Set
      Q c = a ≡p c
      Qa : Q a
      Qa = reflexive≡
      Qb : Q b
      Qb = a≐b Q Qa

  ji : {a b : A} (a≡b : a ≡p b) → j (i a≡b) ≡p a≡b
  ji reflp = reflp

  ijₑₓₜ : {a b : A} (a≐b : a ≐ b) →
    (P : A → Set) (Pa : P a) → i (j a≐b) P Pa ≡p a≐b P Pa
  ijₑₓₜ {a} a≐b P Pa = param≐ a≐b Q P R reflp Pa reflp
    where
      Q : A → Set
      Q c = a ≡p c
      R : (c : A) (Qc : Q c) (Pc : P c) → Set
      R c Qc Pc = i Qc P Pa ≡p Pc
  ij : {a b : A} (a≐b : a ≐ b) → i (j a≐b) ≡p a≐b
  ij a≐b = ext (λ P → ext (ijₑₓₜ a≐b P))


{-# OPTIONS --safe --without-K #-}
module Data.List.Membership.Propositional.Disjoint {ℓ} {A : Set ℓ} where
import Relation.Binary.PropositionalEquality as P
open import Data.List.Membership.Setoid.Disjoint (P.setoid A) public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Operations on nullary relations (like negation and decidability)
------------------------------------------------------------------------

-- Some operations on/properties of nullary relations, i.e. sets.

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

module Relation.Nullary where

open import Data.Empty hiding (⊥-elim)
open import Data.Empty.Irrelevant
open import Level

-- Negation.

infix 3 ¬_

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ P = P → ⊥

-- Decidable relations.

data Dec {p} (P : Set p) : Set p where
  yes : ( p :   P) → Dec P
  no  : (¬p : ¬ P) → Dec P

-- Given an irrelevant proof of a decidable type, a proof can
-- be recomputed and subsequently used in relevant contexts.
recompute : ∀ {a} {A : Set a} → Dec A → .A → A
recompute (yes x) _ = x
recompute (no ¬p) x = ⊥-elim (¬p x)


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

module FinNatLemmas where

open import Data.Empty using (⊥-elim)
open import Data.Product using (_×_; _,_)

open import Data.Nat
  using (ℕ; zero; suc; _+_; _*_; _<_; _≤_; _∸_; z≤n; s≤s; module ≤-Reasoning)
open import Data.Nat.Properties
  using (m+n∸n≡m; m≤m+n; +-∸-assoc; cancel-+-left)
open import Data.Nat.Properties.Simple
  using (+-comm; +-assoc; *-comm; distribʳ-*-+; +-right-identity)

open import Data.Fin
  using (Fin; zero; suc; toℕ; raise; fromℕ≤; reduce≥; inject+)
open import Data.Fin.Properties
  using (bounded; toℕ-injective; toℕ-raise; toℕ-fromℕ≤; inject+-lemma)

open import Relation.Binary using (module StrictTotalOrder)
open import Relation.Binary.Core using (_≢_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; subst; refl; sym; cong; cong₂; trans; module ≡-Reasoning)

------------------------------------------------------------------------------
-- Fin and Nat lemmas

toℕ-fin : (m n : ℕ) → (eq : m ≡ n) (fin : Fin m) →
  toℕ (subst Fin eq fin) ≡ toℕ fin
toℕ-fin m .m refl fin = refl

∸≡ : (m n : ℕ) (i j : Fin (m + n)) (i≥ : m ≤ toℕ i) (j≥ : m ≤ toℕ j) →
  toℕ i ∸ m ≡ toℕ j ∸ m → i ≡ j
∸≡ m n i j i≥ j≥ p = toℕ-injective pr
  where pr = begin (toℕ i
                    ≡⟨ sym (m+n∸n≡m (toℕ i) m) ⟩
                    (toℕ i + m) ∸ m
                    ≡⟨ cong (λ x → x ∸ m) (+-comm (toℕ i) m) ⟩
                    (m + toℕ i) ∸ m
                    ≡⟨ +-∸-assoc m i≥ ⟩
                    m + (toℕ i ∸ m)
                    ≡⟨ cong (λ x → m + x) p ⟩
                    m + (toℕ j ∸ m)
                    ≡⟨ sym (+-∸-assoc m j≥) ⟩
                    (m + toℕ j) ∸ m
                    ≡⟨ cong (λ x → x ∸ m) (+-comm m (toℕ j)) ⟩
                    (toℕ j + m) ∸ m
                    ≡⟨ m+n∸n≡m (toℕ j) m ⟩
                    toℕ j ∎)
             where open ≡-Reasoning

cancel-right∸ : (m n k : ℕ) (k≤m : k ≤ m) (k≤n : k ≤ n) →
  (m ∸ k ≡ n ∸ k) → m ≡ n
cancel-right∸ m n k k≤m k≤n mk≡nk =
  begin (m
         ≡⟨ sym (m+n∸n≡m m k) ⟩
         (m + k) ∸ k
         ≡⟨ cong (λ x → x ∸ k) (+-comm m k) ⟩
         (k + m) ∸ k
         ≡⟨ +-∸-assoc k k≤m ⟩
         k + (m ∸ k)
         ≡⟨ cong (λ x → k + x) mk≡nk ⟩
         k + (n ∸ k)
         ≡⟨ sym (+-∸-assoc k k≤n) ⟩
         (k + n) ∸ k
         ≡⟨ cong (λ x → x ∸ k) (+-comm k n) ⟩
         (n + k) ∸ k
         ≡⟨ m+n∸n≡m n k ⟩
         n ∎)
  where open ≡-Reasoning

raise< : (m n : ℕ) (i : Fin (m + n)) (i< : toℕ i < m) →
         toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ i<))) ≡ n + toℕ i
raise< m n i i< =
  begin (toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ i<)))
         ≡⟨ toℕ-fin (n + m) (m + n) (+-comm n m) (raise n (fromℕ≤ i<)) ⟩
         toℕ (raise n (fromℕ≤ i<))
         ≡⟨ toℕ-raise n (fromℕ≤ i<) ⟩
         n + toℕ (fromℕ≤ i<)
         ≡⟨ cong (λ x → n + x) (toℕ-fromℕ≤ i<) ⟩
         n + toℕ i ∎)
  where open ≡-Reasoning

toℕ-reduce≥ : (m n : ℕ) (i : Fin (m + n)) (i≥ : m ≤ toℕ i) →
               toℕ (reduce≥ i i≥) ≡ toℕ i ∸ m
toℕ-reduce≥ 0 n i _ = refl
toℕ-reduce≥ (suc m) n zero ()
toℕ-reduce≥ (suc m) n (suc i) (s≤s i≥) = toℕ-reduce≥ m n i i≥

inject≥ : (m n : ℕ) (i : Fin (m + n)) (i≥ : m ≤ toℕ i) →
        toℕ (subst Fin (+-comm n m) (inject+ m (reduce≥ i i≥))) ≡ toℕ i ∸ m
inject≥ m n i i≥ =
  begin (toℕ (subst Fin (+-comm n m) (inject+ m (reduce≥ i i≥)))
         ≡⟨ toℕ-fin (n + m) (m + n) (+-comm n m) (inject+ m (reduce≥ i i≥)) ⟩
         toℕ (inject+ m (reduce≥ i i≥))
         ≡⟨ sym (inject+-lemma m (reduce≥ i i≥)) ⟩
         toℕ (reduce≥ i i≥)
         ≡⟨ toℕ-reduce≥ m n i i≥ ⟩
         toℕ i ∸ m ∎)
  where open ≡-Reasoning

fromℕ≤-inj : (m n : ℕ) (i j : Fin n) (i< : toℕ i < m) (j< : toℕ j < m) →
  fromℕ≤ i< ≡ fromℕ≤ j< → i ≡ j
fromℕ≤-inj m n i j i< j< fi≡fj =
  toℕ-injective
    (trans (sym (toℕ-fromℕ≤ i<)) (trans (cong toℕ fi≡fj) (toℕ-fromℕ≤ j<)))

reduce≥-inj : (m n : ℕ) (i j : Fin (m + n)) (i≥ : m ≤ toℕ i) (j≥ : m ≤ toℕ j) →
  reduce≥ i i≥ ≡ reduce≥ j j≥ → i ≡ j
reduce≥-inj m n i j i≥ j≥ ri≡rj =
  toℕ-injective
    (cancel-right∸ (toℕ i) (toℕ j) m i≥ j≥
      (trans (sym (toℕ-reduce≥ m n i i≥))
      (trans (cong toℕ ri≡rj) (toℕ-reduce≥ m n j j≥))))

inj₁-toℕ≡ : {m n : ℕ} (i : Fin (m + n)) (i< : toℕ i < m) →
            toℕ i ≡ toℕ (inject+ n (fromℕ≤ i<))
inj₁-toℕ≡ {0} _ ()
inj₁-toℕ≡ {suc m} zero (s≤s z≤n) = refl
inj₁-toℕ≡ {suc (suc m)} (suc i) (s≤s (s≤s i<)) = cong suc (inj₁-toℕ≡ i (s≤s i<))

inj₁-≡ : {m n : ℕ} (i : Fin (m + n)) (i< : toℕ i < m) → i ≡ inject+ n (fromℕ≤ i<)
inj₁-≡ i i< = toℕ-injective (inj₁-toℕ≡ i i<)

inj₂-toℕ≡ :  {m n : ℕ} (i : Fin (m + n)) (i≥ : m ≤ toℕ i ) →
             toℕ i ≡ toℕ (raise m (reduce≥ i i≥))
inj₂-toℕ≡ {Data.Nat.zero} i i≥ = refl
inj₂-toℕ≡ {suc m} zero ()
inj₂-toℕ≡ {suc m} (suc i) (s≤s i≥) = cong suc (inj₂-toℕ≡ i i≥)

inj₂-≡ :  {m n : ℕ} (i : Fin (m + n)) (i≥ : m ≤ toℕ i ) → i ≡ raise m (reduce≥ i i≥)
inj₂-≡ i i≥ = toℕ-injective (inj₂-toℕ≡ i i≥)

inject+-injective : {m n : ℕ} (i j : Fin m) → (inject+ n i ≡ inject+ n j) → i ≡ j
inject+-injective {m} {n} i j p = toℕ-injective pf
  where
    open ≡-Reasoning
    pf : toℕ i ≡ toℕ j
    pf = begin (
      toℕ i
          ≡⟨ inject+-lemma n i ⟩
      toℕ (inject+ n i)
          ≡⟨ cong toℕ p ⟩
      toℕ (inject+ n j)
          ≡⟨ sym (inject+-lemma n j) ⟩
      toℕ j ∎)

raise-injective : {m n : ℕ} (i j : Fin n) → (raise m i ≡ raise m j) → i ≡ j
raise-injective {m} {n} i j p = toℕ-injective (cancel-+-left m pf)
  where
    open ≡-Reasoning
    pf : m + toℕ i ≡ m + toℕ j
    pf = begin (
      m + toℕ i
        ≡⟨ sym (toℕ-raise m i)  ⟩
      toℕ (raise m i)
        ≡⟨ cong toℕ p ⟩
      toℕ (raise m j)
        ≡⟨ toℕ-raise m j ⟩
      m + toℕ j ∎)

toℕ-invariance : ∀ {n n'} → (i : Fin n) → (eq : n ≡ n') → toℕ (subst Fin eq i) ≡ toℕ i
toℕ-invariance i refl = refl

-- see FinEquiv for the naming

inject+0≡uniti+ : ∀ {m} → (n : Fin m) → (eq : m ≡ m + 0) → inject+ 0 n ≡ subst Fin eq n
inject+0≡uniti+ {m} n eq = toℕ-injective pf
  where
    open ≡-Reasoning
    pf : toℕ (inject+ 0 n) ≡ toℕ (subst Fin eq n)
    pf = begin (
      toℕ (inject+ 0 n)
        ≡⟨ sym (inject+-lemma 0 n) ⟩
      toℕ n
        ≡⟨ sym (toℕ-invariance n eq) ⟩
      toℕ (subst Fin eq n) ∎)

-- Following code taken from
-- https://github.com/copumpkin/derpa/blob/master/REPA/Index.agda#L210

-- the next few bits are lemmas to prove uniqueness of euclidean division

-- first : for nonzero divisors, a nonzero quotient would require a larger
-- dividend than is consistent with a zero quotient, regardless of
-- remainders.

large : ∀ {d} {r : Fin (suc d)} x (r′ : Fin (suc d)) →
        toℕ r ≢ suc x * suc d + toℕ r′
large {d} {r} x r′ pf = irrefl pf (
    start
      suc (toℕ r)
    ≤⟨ bounded r ⟩
      suc d
    ≤⟨ m≤m+n (suc d) (x * suc d) ⟩
      suc d + x * suc d -- same as (suc x * suc d)
    ≤⟨ m≤m+n (suc x * suc d) (toℕ r′) ⟩
      suc x * suc d + toℕ r′ -- clearer in two steps; we'd need assoc anyway
    □)
  where
  open ≤-Reasoning
    renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≡⟨_⟩'_)
  open Relation.Binary.StrictTotalOrder Data.Nat.Properties.strictTotalOrder

-- a raw statement of the uniqueness, in the arrangement of terms that's
-- easiest to work with computationally

addMul-lemma′ : ∀ x x′ d (r r′ : Fin (suc d)) →
  x * suc d + toℕ r ≡ x′ * suc d + toℕ r′ → r ≡ r′ × x ≡ x′
addMul-lemma′ zero zero d r r′ hyp = (toℕ-injective hyp) , refl
addMul-lemma′ zero (suc x′) d r r′ hyp = ⊥-elim (large x′ r′ hyp)
addMul-lemma′ (suc x) zero d r r′ hyp = ⊥-elim (large x r (sym hyp))
addMul-lemma′ (suc x) (suc x′) d r r′ hyp
                      rewrite +-assoc (suc d) (x * suc d) (toℕ r)
                            | +-assoc (suc d) (x′ * suc d) (toℕ r′)
                      with addMul-lemma′ x x′ d r r′ (cancel-+-left (suc d) hyp)
... | pf₁ , pf₂ = pf₁ , cong suc pf₂

-- and now rearranged to the order that Data.Nat.DivMod uses

addMul-lemma : ∀ x x′ d (r r′ : Fin (suc d)) →
  toℕ r + x * suc d ≡ toℕ r′ + x′ * suc d → r ≡ r′ × x ≡ x′
addMul-lemma x x′ d r r′ hyp rewrite +-comm (toℕ r) (x * suc d)
                                   | +-comm (toℕ r′) (x′ * suc d)
  = addMul-lemma′ x x′ d r r′ hyp

-- purely about Nat, but still not in Data.Nat.Properties.Simple

distribˡ-*-+ : ∀ m n o → m * (n + o)  ≡ m * n + m * o
distribˡ-*-+ m n o =
  trans (*-comm m (n + o)) (
  trans (distribʳ-*-+ m n o) (
        (cong₂ _+_ (*-comm n m) (*-comm o m))))

*-right-identity : ∀ n → n * 1 ≡ n
*-right-identity n = trans (*-comm n 1) (+-right-identity n)

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


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

open import Setoids.Orders.Partial.Definition
open import Setoids.Setoids
open import LogicalFormulae
open import Rings.Definition
open import Numbers.Rationals.Definition
open import Functions.Definition

module Numbers.Reals.Definition where

open import Fields.CauchyCompletion.Definition ℚOrdered ℚField
open import Fields.CauchyCompletion.Setoid ℚOrdered ℚField
open import Fields.CauchyCompletion.Addition ℚOrdered ℚField
open import Fields.CauchyCompletion.Multiplication ℚOrdered ℚField
open import Fields.CauchyCompletion.Ring ℚOrdered ℚField
open import Fields.CauchyCompletion.Comparison ℚOrdered ℚField

ℝ : Set
ℝ = CauchyCompletion

_+R_ : ℝ → ℝ → ℝ
_+R_ = _+C_

_*R_ : ℝ → ℝ → ℝ
_*R_ = _*C_

ℝSetoid = cauchyCompletionSetoid

_=R_ : ℝ → ℝ → Set
a =R b = Setoid._∼_ cauchyCompletionSetoid a b

ℝRing : Ring cauchyCompletionSetoid _+R_ _*R_
ℝRing = CRing

injectionR : ℚ → ℝ
injectionR = injection

injectionRInjective : Injection injectionR
injectionRInjective = CInjection'

0R : ℝ
0R = injection 0Q

_<R_ : ℝ → ℝ → Set
_<R_ = _<C_

ℝPartialOrder : SetoidPartialOrder cauchyCompletionSetoid _<C_
ℝPartialOrder = <COrder


module UnifyFin where

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
open import Function using (_∘_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (∃; _,_; _×_)
open import Data.Empty using (⊥-elim)

thin : ∀ {n} -> (x : Fin (suc n)) (y : Fin n) -> Fin (suc n)
thin zero y = suc y
thin (suc x) zero = zero
thin (suc x) (suc y) = suc (thin x y)

p : ∀ {n} -> Fin (suc (suc n)) -> Fin (suc n)
p (suc x) = x
p zero = zero

module Thin where
  fact1 : ∀ {n} x y z -> thin {n} x y ≡ thin x z -> y ≡ z
  fact1 zero y .y refl = refl
  fact1 (suc x) zero zero r = refl
  fact1 (suc x) zero (suc z) ()
  fact1 (suc x) (suc y) zero ()
  fact1 (suc x) (suc y) (suc z) r = cong suc (fact1 x y z (cong p r))

  fact2 : ∀ {n} x y -> ¬ thin {n} x y ≡ x
  fact2 zero y ()
  fact2 (suc x) zero ()
  fact2 (suc x) (suc y) r = fact2 x y (cong p r)

  fact3 : ∀{n} x y -> ¬ x ≡ y -> ∃ λ y' -> thin {n} x y' ≡ y
  fact3 zero zero ne = ⊥-elim (ne refl)
  fact3 zero (suc y) _ = y , refl
  fact3 {zero} (suc ()) _ _
  fact3 {suc n} (suc x) zero ne = zero , refl
  fact3 {suc n} (suc x) (suc y) ne with y | fact3 x y (ne ∘ cong suc)
  ... | .(thin x y') | y' , refl = suc y' , refl

open import Data.Maybe
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

thick : ∀ {n} -> (x y : Fin (suc n)) -> Maybe (Fin n)
thick zero zero = nothing
thick zero (suc y) = just y
thick {zero} (suc ()) _
thick {suc _} (suc x) zero = just zero
thick {suc _} (suc x) (suc y) = suc <$> (thick x y)

open import Data.Sum

_≡Fin_ : ∀ {n} -> (x y : Fin n) -> Dec (x ≡ y)
zero ≡Fin zero = yes refl
zero ≡Fin suc y = no λ ()
suc x ≡Fin zero = no λ ()
suc {suc _} x ≡Fin suc y with x ≡Fin y
...              | yes r = yes (cong suc r)
...              | no r = no λ e -> r (cong p e)
suc {zero} () ≡Fin _

module Thick where
  half1 : ∀ {n} (x : Fin (suc n)) -> thick x x ≡ nothing
  half1 zero = refl
  half1 {suc _} (suc x) = cong (_<$>_ suc) (half1 x)
  half1 {zero} (suc ())

  half2 : ∀ {n} (x : Fin (suc n)) y -> ∀ y' -> thin x y' ≡ y -> thick x y ≡ just y'
  half2 zero zero y' ()
  half2 zero (suc y) .y refl = refl
  half2 {suc n} (suc x) zero zero refl = refl
  half2 {suc _} (suc _) zero (suc _) ()
  half2 {suc n} (suc x) (suc y) zero ()
  half2 {suc n} (suc x) (suc .(thin x y')) (suc y') refl with thick x (thin x y') | half2 x (thin x y') y' refl
  ...                                                       | .(just y')          | refl = refl
  half2 {zero} (suc ()) _ _ _

  fact1 : ∀ {n} (x : Fin (suc n)) y r
    -> thick x y ≡ r
    -> x ≡ y × r ≡ nothing ⊎ ∃ λ y' -> thin x y' ≡ y × r ≡ just y'
  fact1 x y .(thick x y) refl with x ≡Fin y
  fact1 x .x ._ refl | yes refl = inj₁ (refl , half1 x)
  ... | no el with Thin.fact3 x y el
  ...            | y' , thinxy'=y = inj₂ (y' , ( thinxy'=y , half2 x y y' thinxy'=y ))


{-# OPTIONS --universe-polymorphism #-}

-- Proof that 'Free' is a functor
module Categories.Free.Functor where

open import Categories.Support.PropositionalEquality

open import Categories.Categories
open import Categories.Category
  renaming (_[_∼_] to _[_~C_])
open import Categories.Free.Core
open import Categories.Functor
  using (Functor)
  renaming (_≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.Graphs
open import Data.Product
open import Graphs.Graph
  renaming (_[_~_] to _[_~G_]; module Heterogeneous to HeterogeneousG)
open import Graphs.GraphMorphism
  renaming (_∘_ to _∘G_)
open import Data.Star
open import Data.Star.Properties
  using (gmap-◅◅; gmap-id)
open import Categories.Support.StarEquality
open import Level using (_⊔_)

ε∼ε : ∀{o₁ ℓ₁ e₁}{X : Graph o₁ ℓ₁ e₁}
       {o₂ ℓ₂ e₂}{Y : Graph o₂ ℓ₂ e₂}
  → (F G : GraphMorphism X Y)
  → F ≈ G
  → {x : Graph.Obj X}
  → Free₀ Y [ ε {x = GraphMorphism.F₀ F x} ~C ε {x = GraphMorphism.F₀ G x} ]
ε∼ε {Y = Y} F G (F≈G₀ , F≈G₁) {x} = ≣-subst (λ z → Free₀ Y [ ε {x = GraphMorphism.F₀ F x} ~C ε {x = z} ]) (F≈G₀ x) (Heterogeneous.refl (Free₀ Y))
-- the below should probably work, but there's an agda bug
-- XXX bug id?  mokus?  anybody?  bueller?
{-
ε∼ε {Y = Y} F G F≈G {x} rewrite proj₁ F≈G x = refl
  where open Heterogeneous (Free₀ Y)
-}

_◅~◅_ :
  ∀ {o ℓ e}{G : Graph o ℓ e}
    {a₀ a₁ b₀ b₁ c₀ c₁ : Graph.Obj G}
    {f  :       G [ a₀ ↝ b₀ ]}
    {g  :       G [ a₁ ↝ b₁ ]}
    {fs : Free₀ G [ b₀ , c₀ ]}
    {gs : Free₀ G [ b₁ , c₁ ]}
  →       G [ f  ~G g  ]
  → Free₀ G [ fs ~C gs ]
  → Free₀ G [ (f ◅ fs) ~C (g ◅ gs) ]
_◅~◅_ {G = G} (HeterogeneousG.≈⇒~ hd) (Heterogeneous.≡⇒∼ tl)
  = ≡⇒∼ (hd ◅-cong tl)
  where
    open Heterogeneous (Free₀ G)
    open PathEquality G

Free : ∀ {o ℓ e} → Functor (Graphs o ℓ e) (Categories o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e))
Free {o}{ℓ}{e} = record
  { F₀            = Free₀
  ; F₁            = Free₁
  ; identity      = λ {A} f → Heterogeneous.reflexive (Free₀ A) (gmap-id f)
  ; homomorphism  = λ {X}{Y}{Z}{f}{g} → homomorphism {X}{Y}{Z}{f}{g}
  ; F-resp-≡      = λ {X}{Y}{F G : GraphMorphism X Y} → Free₁-resp-≡ {X}{Y}{F}{G}
  }
  where
    module Graphs     = Category (Graphs o ℓ e)
    module Categories = Category (Categories o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e))

    .homomorphism : ∀ {X Y Z} {f : GraphMorphism X Y} {g : GraphMorphism Y Z}
                  → Free₁ (g ∘G f) ≡F (Free₁ g ∘F Free₁ f)
    homomorphism ε = Heterogeneous.refl _
    homomorphism {X}{Y}{Z}{f}{g}{S}{U} (_◅_ {.S}{T}{.U} h hs) =
      HeterogeneousG.refl Z ◅~◅ homomorphism {X}{Y}{Z}{f}{g}{T}{U} hs

    .Free₁-resp-≡ : ∀ {X Y} {F G : GraphMorphism X Y}
      → F ≈ G
      → Free₁ F ≡F Free₁ G
    Free₁-resp-≡ {X}{Y}{F}{G} F≈G {S}{.S} ε = ε∼ε F G F≈G
    Free₁-resp-≡ {X}{Y}{F}{G} F≈G {S}{U} (_◅_ {.S}{T}{.U} h hs)
      = proj₂ F≈G h ◅~◅ Free₁-resp-≡ {X}{Y}{F}{G} F≈G {T}{U} hs


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

module Level where

open import Agda.Primitive
  using (Level)
  renaming ( _⊔_ to _ℓ⊔_
           ; lzero to ℓzero
           ; lsuc  to ℓsuc )
  public

Type : (ℓ : Level) → Set (ℓsuc ℓ)
Type ℓ = Set ℓ

Type₀ = Type ℓzero
Type₁ = Type (ℓsuc ℓzero)
Type₂ = Type (ℓsuc (ℓsuc ℓzero))
Type₃ = Type (ℓsuc (ℓsuc (ℓsuc ℓzero)))

variable
  a b c : Level
  A : Type a
  B : Type b
  C : Type c


------------------------------------------------------------------------
-- Properties of homogeneous binary relations
------------------------------------------------------------------------

module Relation.Binary where

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

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

open Core public hiding (_≡_; refl; _≢_)

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

record IsPreorder {a : Set}
                  (_≈_ : Rel a) -- The underlying equality.
                  (_∼_ : Rel a) -- The relation.
                  : Set where
  field
    isEquivalence : IsEquivalence _≈_
    -- Reflexivity is expressed in terms of an underlying equality:
    reflexive     : _≈_ ⇒ _∼_
    trans         : Transitive _∼_
    ∼-resp-≈      : _∼_ Respects₂ _≈_

  module Eq = IsEquivalence isEquivalence

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

record Preorder : Set₁ where
  infix 4 _≈_ _∼_
  field
    carrier    : Set
    _≈_        : Rel carrier  -- The underlying equality.
    _∼_        : Rel carrier  -- The relation.
    isPreorder : IsPreorder _≈_ _∼_

  open IsPreorder isPreorder public

------------------------------------------------------------------------
-- Setoids

-- Equivalence relations are defined in Relation.Binary.Core.

record Setoid : Set₁ where
  infix 4 _≈_
  field
    carrier       : Set
    _≈_           : Rel carrier
    isEquivalence : IsEquivalence _≈_

  open IsEquivalence isEquivalence public

  isPreorder : IsPreorder _≡_ _≈_
  isPreorder = record
    { isEquivalence = PropEq.isEquivalence
    ; reflexive     = reflexive
    ; trans         = trans
    ; ∼-resp-≈      = PropEq.resp₂ _≈_
    }

  preorder : Preorder
  preorder = record { isPreorder = isPreorder }

------------------------------------------------------------------------
-- Decidable equivalence relations

record IsDecEquivalence {a : Set} (_≈_ : Rel a) : Set where
  field
    isEquivalence : IsEquivalence _≈_
    _≟_           : Decidable _≈_

  open IsEquivalence isEquivalence public

record DecSetoid : Set₁ where
  infix 4 _≈_
  field
    carrier          : Set
    _≈_              : Rel carrier
    isDecEquivalence : IsDecEquivalence _≈_

  open IsDecEquivalence isDecEquivalence public

  setoid : Setoid
  setoid = record { isEquivalence = isEquivalence }

  open Setoid setoid public using (preorder)

------------------------------------------------------------------------
-- Partial orders

record IsPartialOrder {a : Set} (_≈_ _≤_ : Rel a) : Set where
  field
    isPreorder : IsPreorder _≈_ _≤_
    antisym    : Antisymmetric _≈_ _≤_

  open IsPreorder isPreorder public
         renaming (∼-resp-≈ to ≤-resp-≈)

record Poset : Set₁ where
  infix 4 _≈_ _≤_
  field
    carrier        : Set
    _≈_            : Rel carrier
    _≤_            : Rel carrier
    isPartialOrder : IsPartialOrder _≈_ _≤_

  open IsPartialOrder isPartialOrder public

  preorder : Preorder
  preorder = record { isPreorder = isPreorder }

------------------------------------------------------------------------
-- Strict partial orders

record IsStrictPartialOrder {a : Set} (_≈_ _<_ : Rel a) : Set where
  field
    isEquivalence : IsEquivalence _≈_
    irrefl        : Irreflexive _≈_ _<_
    trans         : Transitive _<_
    <-resp-≈      : _<_ Respects₂ _≈_

  module Eq = IsEquivalence isEquivalence

record StrictPartialOrder : Set₁ where
  infix 4 _≈_ _<_
  field
    carrier              : Set
    _≈_                  : Rel carrier
    _<_                  : Rel carrier
    isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_

  open IsStrictPartialOrder isStrictPartialOrder public

------------------------------------------------------------------------
-- Total orders

record IsTotalOrder {a : Set} (_≈_ _≤_ : Rel a) : Set where
  field
    isPartialOrder : IsPartialOrder _≈_ _≤_
    total          : Total _≤_

  open IsPartialOrder isPartialOrder public

record TotalOrder : Set₁ where
  infix 4 _≈_ _≤_
  field
    carrier      : Set
    _≈_          : Rel carrier
    _≤_          : Rel carrier
    isTotalOrder : IsTotalOrder _≈_ _≤_

  open IsTotalOrder isTotalOrder public

  poset : Poset
  poset = record { isPartialOrder = isPartialOrder }

  open Poset poset public using (preorder)

------------------------------------------------------------------------
-- Decidable total orders

record IsDecTotalOrder {a : Set} (_≈_ _≤_ : Rel a) : Set where
  field
    isTotalOrder : IsTotalOrder _≈_ _≤_
    _≟_          : Decidable _≈_
    _≤?_         : Decidable _≤_

  private
    module TO = IsTotalOrder isTotalOrder
  open TO public hiding (module Eq)

  module Eq where

    isDecEquivalence : IsDecEquivalence _≈_
    isDecEquivalence = record
      { isEquivalence = TO.isEquivalence
      ; _≟_           = _≟_
      }

    open IsDecEquivalence isDecEquivalence public

record DecTotalOrder : Set₁ where
  infix 4 _≈_ _≤_
  field
    carrier         : Set
    _≈_             : Rel carrier
    _≤_             : Rel carrier
    isDecTotalOrder : IsDecTotalOrder _≈_ _≤_

  private
    module DTO = IsDecTotalOrder isDecTotalOrder
  open DTO public hiding (module Eq)

  totalOrder : TotalOrder
  totalOrder = record { isTotalOrder = isTotalOrder }

  open TotalOrder totalOrder public using (poset; preorder)

  module Eq where

    decSetoid : DecSetoid
    decSetoid = record { isDecEquivalence = DTO.Eq.isDecEquivalence }

    open DecSetoid decSetoid public

------------------------------------------------------------------------
-- Strict total orders

-- Note that these orders are decidable (see compare).

record IsStrictTotalOrder {a : Set} (_≈_ _<_ : Rel a) : Set where
  field
    isEquivalence : IsEquivalence _≈_
    trans         : Transitive _<_
    compare       : Trichotomous _≈_ _<_
    <-resp-≈      : _<_ Respects₂ _≈_

  _≟_ : Decidable _≈_
  _≟_ = tri⟶dec≈ compare

  isDecEquivalence : IsDecEquivalence _≈_
  isDecEquivalence = record
    { isEquivalence = isEquivalence
    ; _≟_           = _≟_
    }

  module Eq = IsDecEquivalence isDecEquivalence

  isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_
  isStrictPartialOrder = record
    { isEquivalence = isEquivalence
    ; irrefl        = tri⟶irr <-resp-≈ Eq.sym compare
    ; trans         = trans
    ; <-resp-≈      = <-resp-≈
    }

  open IsStrictPartialOrder isStrictPartialOrder using (irrefl)

record StrictTotalOrder : Set₁ where
  infix 4 _≈_ _<_
  field
    carrier            : Set
    _≈_                : Rel carrier
    _<_                : Rel carrier
    isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_

  open IsStrictTotalOrder isStrictTotalOrder public
    hiding (module Eq)

  strictPartialOrder : StrictPartialOrder
  strictPartialOrder =
    record { isStrictPartialOrder = isStrictPartialOrder }

  decSetoid : DecSetoid
  decSetoid = record { isDecEquivalence = isDecEquivalence }

  module Eq = DecSetoid decSetoid


------------------------------------------------------------------------------
-- Terminating mirror function
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.MirrorListTerminatingSL where

open import Data.List

------------------------------------------------------------------------------
-- The rose tree type.
data Tree (A : Set) : Set where
  tree : A → List (Tree A) → Tree A

------------------------------------------------------------------------------
-- An alternative and terminating definition of mirror. Adapted from
-- http://stackoverflow.com/questions/9146928/termination-of-structural-induction

-- The mirror function.
mirror       : {A : Set} → Tree A → Tree A
mirrorBranch : {A : Set} → List (Tree A) → List (Tree A)

mirror       (tree a ts) = tree a (reverse (mirrorBranch ts))
mirrorBranch []          = []
mirrorBranch (t ∷ ts)    = mirror t ∷ mirrorBranch ts


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of sums (disjoint unions)
------------------------------------------------------------------------

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

module Data.Sum.Properties where

open import Data.Sum
open import Function
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

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

  inj₁-injective : ∀ {x y} → (A ⊎ B ∋ inj₁ x) ≡ inj₁ y → x ≡ y
  inj₁-injective refl = refl

  inj₂-injective : ∀ {x y} → (A ⊎ B ∋ inj₂ x) ≡ inj₂ y → x ≡ y
  inj₂-injective refl = refl

  ≡-dec : Decidable _≡_ → Decidable _≡_ → Decidable {A = A ⊎ B} _≡_
  ≡-dec dec₁ dec₂ (inj₁ x) (inj₁ y) with dec₁ x y
  ... | yes refl = yes refl
  ... | no  x≢y  = no (x≢y ∘ inj₁-injective)
  ≡-dec dec₁ dec₂ (inj₁ x) (inj₂ y) = no λ()
  ≡-dec dec₁ dec₂ (inj₂ x) (inj₁ y) = no λ()
  ≡-dec dec₁ dec₂ (inj₂ x) (inj₂ y) with dec₂ x y
  ... | yes refl = yes refl
  ... | no  x≢y  = no (x≢y ∘ inj₂-injective)

  swap-involutive : swap {A = A} {B} ∘ swap ≗ id
  swap-involutive = [ (λ _ → refl) , (λ _ → refl) ]


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

open import lib.Basics hiding (_⊔_)
open import lib.types.Sigma
open import lib.types.Bool
open import lib.types.Empty

open import Preliminaries
open import Truncation_Level_Criteria
open import Anonymous_Existence_CollSplit
open import Anonymous_Existence_Populatedness

module Anonymous_Existence_Comparison where

-- Chapter 4.3: Comparison of Notions of Existence

-- Section 4.3.1: Inhabited and Merely Inhabited

-- Lemma 4.3.1
coll-family-dec : ∀ {i} {X : Type i} → (x₁ x₂ : X) → ((x : X) → coll (Coprod (x₁ == x) (x₂ == x))) → Coprod (x₁ == x₂) (¬(x₁ == x₂))
coll-family-dec {i} {X} x₁ x₂ coll-fam = solution where
  f₋ : (x : X) → Coprod (x₁ == x) (x₂ == x) → Coprod (x₁ == x) (x₂ == x)
  f₋ x = fst (coll-fam x)

  E₋ : X → Type i
  E₋ x = fix (f₋ x)

  E : Type i
  E = Σ X λ x → (E₋ x)

  E-fst-determines-eq : (e₁ e₂ : E) → (fst e₁ == fst e₂) → e₁ == e₂
  E-fst-determines-eq e₁ e₂ p = second-comp-triv (λ x → fixed-point (f₋ x) (snd (coll-fam x))) _ _ p

  r : Bool → E
  r true = x₁ , to-fix (f₋ x₁) (snd (coll-fam x₁)) (inl idp)
  r false = x₂ , to-fix (f₋ x₂) (snd (coll-fam x₂)) (inr idp)

  about-r : (r true == r false) ↔ (x₁ == x₂)
  about-r = (λ p → ap fst p) , (λ p → E-fst-determines-eq _ _ p)

  s : E → Bool
  s (_ , inl _ , _) = true
  s (_ , inr _ , _) = false

  s-section-of-r : (e : E) → r(s e) == e
  s-section-of-r (x , inl p , q) = E-fst-determines-eq _ _ p
  s-section-of-r (x , inr p , q) = E-fst-determines-eq _ _ p

  about-s : (e₁ e₂ : E) → (s e₁ == s e₂) ↔ (e₁ == e₂)
  about-s e₁ e₂ = one , two where
    one : (s e₁ == s e₂) → (e₁ == e₂)
    one p =
      e₁       =⟨ ! (s-section-of-r e₁) ⟩
      r(s(e₁)) =⟨ ap r p ⟩
      r(s(e₂)) =⟨ s-section-of-r e₂ ⟩
      e₂       ∎
    two : (e₁ == e₂) → (s e₁ == s e₂)
    two p = ap s p

  combine : (s (r true) == s (r false)) ↔ (x₁ == x₂)
  combine = (about-s _ _) ◎ about-r

  check-bool : Coprod (s (r true) == s (r false)) (¬(s (r true) == s (r false)))
  check-bool = Bool-has-dec-eq _ _

  solution : Coprod (x₁ == x₂) (¬(x₁ == x₂))
  solution with check-bool
  solution | inl p = inl (fst combine p)
  solution | inr np = inr (λ p → np (snd combine p))

-- definition: "all types have a weakly constant endofunction".
-- this assumption is, if we have ∣∣_∣∣, logically equivalent to saying that
-- every type has split support.
all-coll : ∀ {i} → Type (lsucc i)
all-coll {i} = (X : Type i) → coll X

-- Proposition 4.3.2
all-coll→dec-eq : ∀ {i} → all-coll {i} → (X : Type i) → has-dec-eq X
all-coll→dec-eq all-coll X x₁ x₂ = coll-family-dec x₁ x₂ (λ x → all-coll _)

open with-weak-trunc
open wtrunc

--  Proposition 4.3.3
module functional-subrelation {i : ULevel} (ac : all-coll {i}) (X : Type i) (R : X × X → Type i) where

  all-sets : (Y : Type i) → is-set Y
  all-sets Y = pathColl→isSet (λ y₁ y₂ → ac _)

  R₋ : (x : X) → Type i
  R₋ x = Σ X λ y → R(x , y)

  k : (x : X) → (R₋ x) → (R₋ x)
  k x = fst (ac _)

  kc : (x : X) → const (k x)
  kc x = snd (ac _)

  SS : X × X → Type i
  SS (x , y) = Σ (R(x , y)) λ a →
                (y , a) == k x (y , a)

  -- the relation S
  SS₋ : (x : X) → Type i
  SS₋ x = Σ X λ y → SS(x , y)

  -- fix kₓ is equivalent to Sₓ
  -- This is just Σ-assoc. We try to make it more readable by adding some (trivial) steps.
  fixk-SS : (x : X) → (fix (k x)) ≃ SS₋ x
  fixk-SS x =
      (fix (k x))                                           ≃⟨ ide _ ⟩
      (Σ (Σ X λ y → R(x , y)) λ a → a == k x a)             ≃⟨ Σ-assoc ⟩
      (Σ X λ y → Σ (R(x , y)) λ r → (y , r) == k x (y , r)) ≃⟨ ide _ ⟩
      (SS₋ x)                                                ≃∎

  -- claim (0)
  subrelation : (x y : X) → SS(x , y) →  R(x , y)
  subrelation x y (r , _) = r

   -- claim (1)
  prop-SSx : (x : X) → is-prop (SS₋ x)
  prop-SSx x = equiv-preserves-level {A = fix (k x)} {B = (SS₋ x)} (fixk-SS x) (fixed-point _ (kc x))

  -- claim (2)
  same-domain : (x : X) → (R₋ x) ↔ (SS₋ x)
  same-domain x = rs , sr where
    rs : (R₋ x) → (SS₋ x)
    rs a = –> (fixk-SS x) (to-fix (k x) (kc x) a)
    sr : (SS₋ x) → (R₋ x)
    sr (y , r , _) = y , r

  -- claim (3)
  prop-SS : (x y : X) → is-prop (SS (x , y))
  prop-SS x y = all-paths-is-prop all-paths where
    all-paths : (s₁ s₂ : SS(x , y)) → s₁ == s₂
    all-paths s₁ s₂ = ss where

      yss : (y , s₁) == (y , s₂)
      yss = prop-has-all-paths (prop-SSx x) _ _

      ss : s₁ == s₂
      ss = set-lemma (all-sets _) y s₁ s₂ yss

-- intermediate definition
-- see the caveat about the notion 'epimorphism' in the article
is-split-epimorphism : ∀ {i j} {U : Type i} {V : Type j} → (U → V) → Type (i ⊔ j)
is-split-epimorphism {U = U} {V = V} e = Σ (V → U) λ s → (v : V) → e (s v) == v

is-epimorphism : ∀ {i j} {U : Type i} {V : Type j} → (U → V) → Type (lsucc (i ⊔ j))
is-epimorphism {i} {j} {U = U} {V = V} e = (W : Type (i ⊔ j)) → (f g : V → W) → ((u : U) → f (e u) == g (e u)) → (v : V) → f v == g v

-- Lemma 4.3.4
path-trunc-epi→set : ∀ {i} {Y : Type i} → ((y₁ y₂ : Y) → is-epimorphism (∣_∣ {X = y₁ == y₂})) → is-set Y
path-trunc-epi→set {Y = Y} path-epi = reminder special-case where

  f : (y₁ y₂ : Y) → ∣∣ y₁ == y₂ ∣∣ → Y
  f y₁ _ _ = y₁

  g : (y₁ y₂ : Y) → ∣∣ y₁ == y₂ ∣∣ → Y
  g _ y₂ _ = y₂

  special-case : (y₁ y₂ : Y) → ∣∣ y₁ == y₂ ∣∣ → y₁ == y₂
  special-case y₁ y₂ = path-epi y₁ y₂ Y (f y₁ y₂) (g y₁ y₂) (idf _)

  -- we know that hSeparated(X) implies that X is a set,
  -- from the previous Proposition 3.1.9;
  -- however, we have proved it in such a way which forces
  -- us to combine three directions:
  reminder : hSeparated Y → is-set Y
  reminder = (fst (set-characterisations Y)) ∘ (fst (snd (snd (set-characterisations Y)))) ∘ (snd (snd (snd (snd (set-characterisations Y)))))

-- Proposition 4.3.5 (1)
all-split→all-deceq : ∀ {i} → ((X : Type i) → is-split-epimorphism (∣_∣ {X = X})) → (X : Type i) → has-dec-eq X
all-split→all-deceq {i} all-split = all-coll→dec-eq ac where
  ac : (X : Type i) → coll X
  ac X = snd coll↔splitSup (fst (all-split X))

-- Proposition 4.3.5 (2)
all-epi→all-set : ∀ {i} → ((X : Type i) → is-epimorphism (∣_∣ {X = X})) → (X : Type i) → is-set X
all-epi→all-set all-epi X = path-trunc-epi→set (λ y₁ y₂ → all-epi (y₁ == y₂))

-- Section 4.3.2: Merely Inhabited and Populated

-- Lemma 4.3.6, first proof
pop-hstable-1 : ∀ {i} {X : Type i} → ⟪ splitSup X ⟫
pop-hstable-1 {X = X} f c = to-fix f c (coll→splitSup (g , gc)) where

  g : X → X
  g x = f (λ _ → x) ∣ x ∣

  gc : const g
  gc x₁ x₂ =
    g x₁               =⟨ idp ⟩
    f (λ _ → x₁) ∣ x₁ ∣ =⟨ ap (λ k → k ∣ x₁ ∣) (c (λ _ → x₁) (λ _ → x₂)) ⟩
    f (λ _ → x₂) ∣ x₁ ∣ =⟨ ap (f (λ _ → x₂)) (prop-has-all-paths tr-is-prop ∣ x₁ ∣ ∣ x₂ ∣) ⟩
    f (λ _ → x₂) ∣ x₂ ∣ =⟨ idp ⟩
    g x₂               ∎

-- Lemma 4.3.6, second proof
pop-hstable-2 : ∀ {i} {X : Type i} → ⟪ splitSup X ⟫
pop-hstable-2 {i} {X} = snd (pop-alt₂ {X = splitSup X}) get-P where
  get-P : (P : Type i) → is-prop P → splitSup X ↔ P → P
  get-P P pp (hstp , phst) = hstp free-hst where

    xp : X → P
    xp x = hstp (λ _ → x)

    zp : ∣∣ X ∣∣ → P
    zp = tr-rec pp xp

    free-hst : splitSup X
    free-hst z = phst (zp z) z

-- Lemma 4.3.6, third proof
pop-hstable-3 : ∀ {i} {X : Type i} → ⟪ splitSup X ⟫
pop-hstable-3 {X = X} = snd pop-alt translation where

  translation-aux : splitSup (splitSup X) → splitSup X
  translation-aux = λ hsthst z → hsthst (trunc-functorial {X = X} {Y = splitSup X} (λ x _ → x) z) z

  translation :  ∣∣ splitSup (splitSup X) ∣∣ → ∣∣ splitSup X ∣∣
  translation = trunc-functorial translation-aux

-- Lemma 4.3.7
module tlem437 {i : ULevel} where

  One = (X : Type i) → ⟪ X ⟫ → ∣∣ X ∣∣

  Two = (X : Type i) → ∣∣ splitSup X ∣∣

  Three = (P : Type i) → is-prop P → (Y : P → Type i) → ((p : P) → ∣∣ Y p ∣∣) → ∣∣ ((p : P) → Y p) ∣∣

  Four = (X Y : Type i) → (X → Y) → (⟪ X ⟫ → ⟪ Y ⟫)

  One→Two : One → Two
  One→Two poptr X = poptr (splitSup X) pop-hstable-1

  Two→One : Two → One
  Two→One trhst X pop = fst pop-alt pop (trhst X)

  One→Four : One → Four
  One→Four poptr X Y f = Trunc→Pop ∘ (trunc-functorial f) ∘ (poptr X)

  Four→One : Four → One
  Four→One funct X px = prop-pop tr-is-prop pz where -- (tr-rec _) pz where
    pz : ⟪ ∣∣ X ∣∣ ⟫
    pz  =  funct X (∣∣ X ∣∣) ∣_∣ px

  -- only very slightly different to the proof in the article
  One→Three : One → Three
  One→Three poptr P pp Y = λ py → poptr _ (snd pop-alt' (λ hst p₀ → hst (contr-trick p₀ py) p₀)) where
    contr-trick : (p₀ : P) → ((p : P) → ∣∣ Y p ∣∣) → ∣∣ ((p : P) → Y p) ∣∣
    contr-trick p₀ py = tr-rec {X = Y p₀}
                               {P = ∣∣ ((p : P) → Y p) ∣∣}
                               tr-is-prop
                               (λ y₀ → ∣ (λ p → transport Y (prop-has-all-paths pp p₀ p) y₀) ∣)
                               (py p₀)

  Three→Two : Three → Two
  Three→Two proj X = proj (∣∣ X ∣∣) tr-is-prop (λ _ → X) (idf _)

-- Section 4.3.3: Populated and Non-Empty

-- We now need function extensionality. We
-- start with some very simple auxiliary
-- lemmata (not numbered in the thesis).

-- If P is a proposition, so is P + ¬ P
dec-is-prop : ∀ {i} {P : Type i} → is-prop P → is-prop (Coprod P (¬ P))
dec-is-prop {P = P} pp = all-paths-is-prop (λ { (inl p₁) (inl p₂) → ap inl (prop-has-all-paths pp _ _) ;
                                (inl p₁) (inr np₂) → Empty-elim {P = λ _ → inl p₁ == inr np₂} (np₂ p₁) ;
                                (inr np₁) (inl p₂) → Empty-elim {P = λ _ → inr np₁ == inl p₂} (np₁ p₂) ;
                                (inr np₁) (inr np₂) → ap inr (λ= (λ x → prop-has-all-paths Empty-is-prop _ _ )) })

-- Proposition 4.3.8
nonempty-pop→LEM : ∀ {i} → ((X : Type i) → (¬(¬ X) → ⟪ X ⟫)) → LEM {i}
nonempty-pop→LEM {i} nn-pop P pp = from-fix {X = dec} (idf _) (nn-pop dec nndec (idf _) idc) where
  dec : Type i
  dec = Coprod P (¬ P)

  idc : const (idf dec)
  idc = λ _ _ → prop-has-all-paths (dec-is-prop {P = P} pp) _ _

  nndec : ¬(¬ dec)
  nndec ndec = (λ np → ndec (inr np)) λ p → ndec (inl p)

-- Corollary 4.3.9
nonempty-pop↔lem : ∀ {i} → ((X : Type i) → (¬(¬ X) → ⟪ X ⟫)) ↔ LEM {i}
nonempty-pop↔lem {i} = nonempty-pop→LEM , other where
  other : LEM {i} → ((X : Type i) → (¬(¬ X) → ⟪ X ⟫))
  other lem X nnX = p where
    pnp : Coprod ⟪ X ⟫ (¬ ⟪ X ⟫)
    pnp = lem ⟪ X ⟫ pop-property₂

    p : ⟪ X ⟫
    p = match pnp withl idf _ withr (λ np → Empty-elim {P = λ _ → ⟪ X ⟫} (nnX (λ x → np (pop-property₁ x))))


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

module Categories.Category.Instance.Quivers where

-- The Category of Quivers

open import Level using (Level; suc; _⊔_)
open import Relation.Binary.PropositionalEquality.Core using (refl)
open import Data.Quiver using (Quiver)
open import Data.Quiver.Morphism using (Morphism; id; _∘_; _≃_; ≃-Equivalence; ≃-resp-∘)

open import Categories.Category.Core using (Category)

private
  variable
    o ℓ e o′ ℓ′ e′ : Level

Quivers : ∀ o ℓ e → Category (suc (o ⊔ ℓ ⊔ e)) (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e)
Quivers o ℓ e = record
  { Obj       = Quiver o ℓ e
  ; _⇒_       = Morphism
  ; _≈_       = _≃_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = λ {_ _ _ G} → record { F₀≡ = refl ; F₁≡ = Equiv.refl G }
  ; sym-assoc = λ {_ _ _ G} → record { F₀≡ = refl ; F₁≡ = Equiv.refl G }
  ; identityˡ = λ {_ G}     → record { F₀≡ = refl ; F₁≡ = Equiv.refl G }
  ; identityʳ = λ {_ G}     → record { F₀≡ = refl ; F₁≡ = Equiv.refl G }
  ; identity² = λ {G}       → record { F₀≡ = refl ; F₁≡ = Equiv.refl G }
  ; equiv     = ≃-Equivalence
  ; ∘-resp-≈  = ≃-resp-∘
  }
  where open Quiver using (module Equiv)


module _ where

record Pair (A B : Set) : Set where
  field
    π₁ : A
    π₂ : B

open Pair

foo : {A B : Set} → Pair A B  → Pair A B
foo = λ { x → {!x!} }
{- Case splitting on x produces:
   foo = λ { record { π₁ = π₃ ; π₂ = π₃ } → ? }
   Repeated variables in pattern: π₃
-}


module EqBase where
import PolyDepPrelude
open PolyDepPrelude using
  ( Bool; true; false; _&&_
  ; Unit; unit
  ; Pair; pair
  ; Either; left; right
  ; Absurd
  ; Datoid; datoid; pElem
  ; True )

-- import And
And = Pair

-- import Sigma
data Sigma (A : Set)(B : A -> Set) : Set where
  si : (a : A) -> (b : B a) -> Sigma A B

Eq : Set -> Set -> Set
Eq a b = a -> b -> Bool

eqEmpty : Eq Absurd Absurd
eqEmpty () -- empty

eqUnit : Eq Unit Unit
eqUnit unit unit = true

eqPair : {A1 A2 B1 B2 : Set} ->
         (Eq     A1          A2) ->
         (Eq        B1          B2) ->
         Eq (And A1 B1) (And A2 B2)
eqPair ea eb (pair a b) (pair a' b') = ea a a' && eb b b'

caseOn : (D : Datoid)
         {B1 B2 : pElem D -> Set}
         (ifTrue : (b : pElem D) -> B1 b -> B2 b -> Bool)
         (a b : pElem D)
         (pa : B1 a)
         (pb : B2 b)
         (e : Bool)
         (cast : True e -> B1 a -> B1 b)
         -> Bool
caseOn D ifTrue a b pa pb (false) cast = false
caseOn D ifTrue a b pa pb (true)  cast = ifTrue b (cast unit pa) pb

eqEither : {A1 A2 B1 B2 : Set}
           (eq1 : A1 -> B1 -> Bool)
           (eq2 : A2 -> B2 -> Bool)
         -> Either A1 A2 -> Either B1 B2 -> Bool
eqEither eq1 eq2 (left  a1) (left  b1) = eq1 a1 b1
eqEither eq1 eq2 (right a2) (right b2) = eq2 a2 b2
eqEither eq1 eq2 _          _          = false

{-
            case x of {
              (inl x') ->
                case y of {
                  (inl x0) -> eq1 x' x0;
                  (inr y') -> false@_;};
              (inr y') ->
                case y of {
                  (inl x') -> false@_;
                  (inr y0) -> eq2 y' y0;};}
-}
{-

eqSigma2 (D : Datoid)
         (|B1 |B2 : pElem D -> Set)
         (ifTrue : (b : pElem D) -> Eq (B1 b) (B2 b))
         (x : Sigma pElem D B1)
         (y : Sigma pElem D B2)
  : Bool
  = case x of {
      (si a pa) ->
        case y of {
          (si b pb) ->
            caseOn D ifTrue a b pa pb (D.eq a b) (D.subst B1);};}

eqSigma (D : Datoid)(|B1 : (a : pElem D) -> Set)(|B2 : (a : pElem D) -> Set)
  : ((a : pElem D) -> Eq (B1 a) (B2 a)) ->
     Eq (Sigma pElem D B1) (Sigma pElem D B2)
  = eqSigma2 D
-- More readable but less useful definition of eqSigma :

eqSigmaLocalLet (D : Datoid)
                (|B1 |B2 : pElem D -> Set)
                (ifTrue : (b : pElem D) -> Eq (B1 b) (B2 b))
                (x : Sigma pElem D B1)
                (y : Sigma pElem D B2)
  : Bool
  = case x of {
      (si a pa) ->
        case y of {
          (si b pb) ->
            let caseOn (e : Bool)(cast : True e -> B1 a -> B1 b) : Bool
                  = case e of {
                      (false) -> false@_;
                      (true) -> ifTrue b (cast tt@_ pa) pb;}
            in  caseOn (D.eq a b) (D.subst B1);};}

eqSum' (D : Datoid)
     (|B1 |B2 : (a : pElem D) -> Set)
  : ((a : pElem D) -> Eq (B1 a) (B2 a)) ->
     Eq (Sum pElem D B1) (Sum pElem D B2)
  = \(e : (a : pElem D) -> Eq (B1 a) (B2 a)) ->
    \(p1 : Sum pElem D B1) ->
    \(p2 : Sum pElem D B2) ->
    caseOn D e p1.fst p2.fst p1.snd p2.snd (D.eq p1.fst p2.fst)
      (D.subst B1)

eqSum : (D : Datoid)
        {B1 B2 : (a : pElem D) -> Set}
  -> ((a : pElem D) -> Eq (B1 a) (B2 a)) ->
     Eq (Sum pElem D B1) (Sum pElem D B2)
eqSum e p1 p2 =
    caseOn D e p1.fst p2.fst p1.snd p2.snd (D.eq p1.fst p2.fst)
      (D.subst B1)
-}


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.GradedRing.Instances.Polynomials where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

open import Cubical.Data.Unit
open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Monoid.Instances.NatVec
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.Unit
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.GradedRing.Base
open import Cubical.Algebra.GradedRing.DirectSumHIT

private variable
  ℓ : Level

open Iso
open GradedRing-⊕HIT-index
open GradedRing-⊕HIT-⋆

module _
  (ARing@(A , Astr) : Ring ℓ)
  (n : ℕ)
  where

  open RingStr Astr
  open RingTheory ARing

  PolyGradedRing : GradedRing ℓ-zero ℓ
  PolyGradedRing = makeGradedRingSelf
                   (NatVecMonoid n)
                   (λ _ → A)
                   (λ _ → snd (Ring→AbGroup ARing))
                   1r _·_ 0LeftAnnihilates 0RightAnnihilates
                   (λ a b c → ΣPathP ((+n-vec-assoc _ _ _) , (·Assoc _ _ _)))
                   (λ a → ΣPathP ((+n-vec-rid _) , (·IdR _)))
                   (λ a → ΣPathP ((+n-vec-lid _) , (·IdL _)))
                   ·DistR+
                   ·DistL+


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

module Substream (A : Set) where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PE
open import PropsAsTypes
open import Stream

open Bisim A
open ~-Reasoning

mutual
  record Sel : Set where
    coinductive
    field out : Selμ

  data Selμ : Set where
    pres  : Sel → Selμ
    drop  : Selμ → Selμ

open Sel public

filterμ  : Selμ → Stream A → Stream A
filter   : Sel → Stream A → Stream A

filter x = filterμ (x .out)

filterμ (pres x) s .hd  = s .hd
filterμ (pres x) s .tl  = filter x (s .tl)
filterμ (drop u) s      = filterμ u (s .tl)

_≤[_]_ : Stream A → Sel → Stream A → Prop
s ≤[ x ] t = s ~ filter x t

_≤μ[_]_ : Stream A → Selμ → Stream A → Prop
s ≤μ[ u ] t = s ~ filterμ u t

_≤'_ : Stream A → Stream A → Prop
s ≤' t = ∃[ x ∈ Sel ] (s ≤[ x ] t)

_•_   : Sel → Sel → Sel
_•μ_  : Selμ → Selμ → Selμ

(x • y) .out = (x .out) •μ (y .out)

(pres x')  •μ (pres y')  = pres (x' • y')
(drop u')  •μ (pres y')  = drop (u' •μ (y' .out))
u          •μ (drop v')  = drop (u •μ v')

filter-hom   : ∀ x y s → filter (y • x) s ~ filter y (filter x s)
filterμ-hom  : ∀ u v s → filterμ (v •μ u) s ~ filterμ v (filterμ u s)

filter-hom x y s = filterμ-hom (x .out) (y .out) s

filterμ-hom (pres x) (pres y)  s .hd≡  = refl
filterμ-hom (pres x) (pres y)  s .tl~  = filter-hom x y (s .tl)
filterμ-hom (pres x) (drop v)  s       = filterμ-hom (x .out) v (s .tl)
filterμ-hom (drop u) (pres x)  s       = filterμ-hom u (pres x) (s .tl)
filterμ-hom (drop u) (drop v)  s       = filterμ-hom u (drop v) (s .tl)

filter-resp~   : ∀{s t} (x : Sel)  → s ~ t → filter x s ~ filter x t
filterμ-resp~  : ∀{s t} (u : Selμ) → s ~ t → filterμ u s ~ filterμ u t

filter-resp~ x p = filterμ-resp~ (x .out) p

filterμ-resp~ (pres x)  p .hd≡  = p .hd≡
filterμ-resp~ (pres x)  p .tl~  = filter-resp~ x (p .tl~)
filterμ-resp~ (drop u)  p       = filterμ-resp~ u (p .tl~)

≤-witness-trans : ∀{r s t} {x y} → r ≤[ x ] s → s ≤[ y ] t → r ≤[ x • y ] t
≤-witness-trans {r} {s} {t} {x} {y} p q =
  begin
    r
  ~⟨ p ⟩
    filter x s
  ~⟨ filter-resp~ x q ⟩
    filter x (filter y t)
  ~⟨ S.sym (filter-hom y x t) ⟩
    filter (x • y) t
  ∎
  where
    module S = Setoid stream-setoid

≤'-trans : ∀{r s t} → r ≤' s → s ≤' t → r ≤' t
≤'-trans = ∃₂-elim  (λ x y p q →
                    ∃-intro (x • y) (≤-witness-trans {x = x} {y} p q))

mutual
  record _≤_ (s t : Stream A) : Prop where
    coinductive
    field out≤ : s ≤μ t

  data _≤μ_ (s t : Stream A) : Prop where
    match : (s .hd ≡ t .hd) → (s .tl ≤ t .tl) → s ≤μ t
    skip  : (s ≤μ t .tl) → s ≤μ t

open _≤_ public

witness   : {s t : Stream A} → s ≤ t → Sel
witnessμ  : {s t : Stream A} → s ≤μ t → Selμ

witness p .out = witnessμ (p .out≤)

witnessμ (match _ t≤)  = pres (witness t≤)
witnessμ (skip u)      = drop (witnessμ u)

≤-implies-witnessed≤    : ∀{s t} → (p : s ≤ t) → s ≤[ witness p ] t
≤μ-implies-witnessed≤μ  : ∀{s t} → (p : s ≤μ t) → s ≤μ[ witnessμ p ] t

≤-implies-witnessed≤ {s} {t} p = ≤μ-implies-witnessed≤μ (p .out≤)

≤μ-implies-witnessed≤μ (match h≡ t≤) .hd≡  = h≡
≤μ-implies-witnessed≤μ (match h≡ t≤) .tl~  = ≤-implies-witnessed≤ t≤
≤μ-implies-witnessed≤μ (skip q)            = ≤μ-implies-witnessed≤μ q

≤-implies-≤' : _≤_ ⊑ _≤'_
≤-implies-≤' p = ∃-intro (witness p) (≤-implies-witnessed≤ p)

witnessed≤-implies-≤    : ∀{s t} (x : Sel) → s ≤[ x ] t → s ≤ t
witnessed≤μ-implies-≤μ  : ∀{s t} (u : Selμ) → s ≤μ[ u ] t → s ≤μ t

witnessed≤-implies-≤ x p .out≤ = witnessed≤μ-implies-≤μ (x .out) p

witnessed≤μ-implies-≤μ (pres x) p  = match (p .hd≡) (witnessed≤-implies-≤ x (p .tl~))
witnessed≤μ-implies-≤μ (drop u) p  = skip (witnessed≤μ-implies-≤μ u p)

≤'-implies-≤ : _≤'_ ⊑ _≤_
≤'-implies-≤ = ∃-elim witnessed≤-implies-≤

≤-and-≤'-equivalent : ∀ {s t} → s ≤ t ⇔ s ≤' t
≤-and-≤'-equivalent = equivalence ≤-implies-≤' ≤'-implies-≤

≤-trans : ∀{r s t} → r ≤ s → s ≤ t → r ≤ t
≤-trans p q = ≤'-implies-≤ (≤'-trans (≤-implies-≤' p) (≤-implies-≤' q))