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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Naturals
open import Numbers.Naturals.EuclideanAlgorithm
open import Semirings.Definition
open import Orders.Total.Definition

module Numbers.Modulo.ModuloFunction where

open TotalOrder ℕTotalOrder

private
  notBigger : (a : ℕ) {n : ℕ} → succ a +N n ≡ a → False
  notBigger (succ a) {n} pr = notBigger a {n} (succInjective pr)

  notBigger' : (a : ℕ) {n : ℕ} → succ a +N n ≡ n → False
  notBigger' (succ a) {succ n} pr rewrite Semiring.commutative ℕSemiring a (succ n) | Semiring.commutative ℕSemiring n a = notBigger' _ (succInjective pr)

mod : (n : ℕ) → .(pr : 0 <N n) → (a : ℕ) → ℕ
mod (succ n) 0<n a = divisionAlgResult.rem (divisionAlg (succ n) a)

abstract
  modIsMod : {n : ℕ} → .(pr : 0 <N n) → (a : ℕ) → a <N n → mod n pr a ≡ a
  modIsMod {succ n} 0<n a a<n with divisionAlg (succ n) a
  modIsMod {succ n} 0<n a a<n | record { quot = zero ; rem = rem ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } rewrite multiplicationNIsCommutative n 0 = pr
  modIsMod {succ n} 0<n a (le x proof) | record { quot = succ quot ; rem = rem ; pr = pr ; remIsSmall = inl rem<sn ; quotSmall = quotSmall } = exFalso (notBigger a v)
    where
      t : ((succ (a +N x)) *N succ quot) +N rem ≡ a
      t rewrite Semiring.commutative ℕSemiring a x = transitivity (applyEquality (λ i → (i *N succ quot) +N rem) proof) pr
      u : (succ quot *N succ (a +N x)) +N rem ≡ a
      u = transitivity (applyEquality (_+N rem) (multiplicationNIsCommutative (succ quot) _)) t
      v : succ a +N ((x +N quot *N succ (a +N x)) +N rem) ≡ a
      v = transitivity (applyEquality succ (transitivity (Semiring.+Associative ℕSemiring a _ rem) (applyEquality (_+N rem) (Semiring.+Associative ℕSemiring a x _)))) u

  mod<N : {n : ℕ} → .(pr : 0 <N n) → (a : ℕ) → (mod n pr a) <N n
  mod<N {succ n} pr a with divisionAlg (succ n) a
  mod<N {succ n} 0<n a | record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl x ; quotSmall = quotSmall } = x

  modIdempotent : {n : ℕ} → .(pr : 0 <N n) → (a : ℕ) → mod n pr (mod n pr a) ≡ mod n pr a
  modIdempotent 0<n a = modIsMod 0<n (mod _ 0<n a) (mod<N 0<n a)

  modAnd+n : {n : ℕ} → .(pr : 0 <N n) → (a : ℕ) → mod n pr (n +N a) ≡ mod n pr a
  modAnd+n {succ n} 0<sn a with divisionAlg (succ n) (succ n +N a)
  modAnd+n {succ n} 0<sn a | record { quot = 0 ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl q } rewrite multiplicationNIsCommutative n 0 | pr = exFalso (notBigger (succ n) (transitivity (applyEquality succ (transitivity (applyEquality succ (Semiring.+Associative ℕSemiring n a _)) (Semiring.commutative ℕSemiring (succ (n +N a)) _))) (_<N_.proof remIsSmall)))
  modAnd+n {succ n} 0<sn a | record { quot = succ quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl q } = modIsUnique (record { quot = quot ; rem = rem ; pr = t ; remIsSmall = inl remIsSmall ; quotSmall = inl q }) (divisionAlg (succ n) a)
    where
      g : succ n +N ((quot *N succ n) +N rem) ≡ succ n +N a
      g = transitivity (Semiring.+Associative ℕSemiring (succ n) _ rem) (transitivity (applyEquality (_+N rem) (multiplicationNIsCommutative (succ quot) _)) pr)
      h : (quot *N succ n) +N rem ≡ a
      h = canSubtractFromEqualityLeft g
      t : (succ n *N quot) +N rem ≡ a
      t = transitivity (applyEquality (_+N rem) (multiplicationNIsCommutative (succ n) quot)) h

  modExtracts : {n : ℕ} → .(pr : 0 <N n) → (a b : ℕ) → mod n pr (a +N b) ≡ mod n pr (mod n pr a +N mod n pr b)
  modExtracts {succ n} 0<sn a b with divisionAlg (succ n) a
  modExtracts {succ n} 0<sn a b | record { quot = sn/a ; rem = sn%a ; pr = prA ; remIsSmall = remIsSmallA ; quotSmall = quotSmallA } with divisionAlg (succ n) b
  modExtracts {succ n} 0<sn a b | record { quot = sn/a ; rem = sn%a ; pr = prA ; remIsSmall = remIsSmallA ; quotSmall = quotSmallA } | record { quot = sn/b ; rem = sn%b ; pr = prB ; remIsSmall = remIsSmallB ; quotSmall = quotSmallB } with divisionAlg (succ n) (a +N b)
  modExtracts {succ n} 0<sn a b | record { quot = sn/a ; rem = sn%a ; pr = prA ; remIsSmall = remIsSmallA ; quotSmall = quotSmallA } | record { quot = sn/b ; rem = sn%b ; pr = prB ; remIsSmall = remIsSmallB ; quotSmall = quotSmallB } | record { quot = sn/a+b ; rem = sn%a+b ; pr = prA+B ; remIsSmall = remIsSmallA+B ; quotSmall = quotSmallA+B } with divisionAlg (succ n) (sn%a +N sn%b)
  modExtracts {succ n} 0<sn a b | record { quot = sn/a ; rem = sn%a ; pr = prA ; remIsSmall = inl sn%a<sn ; quotSmall = inl _ } | record { quot = sn/b ; rem = sn%b ; pr = prB ; remIsSmall = inl sn%b<sn ; quotSmall = inl _ } | record { quot = sn/a+b ; rem = sn%a+b ; pr = prA+B ; remIsSmall = inl sn%a+b<sn ; quotSmall = inl _ } | record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl _ } = equalityCommutative whoa
    where
      t : ((succ n *N sn/a) +N sn%a) +N ((succ n *N sn/b) +N sn%b) ≡ a +N b
      t = +NWellDefined prA prB
      t' : (succ n *N (sn/a +N sn/b)) +N (sn%a +N sn%b) ≡ a +N b
      t' = transitivity (transitivity (Semiring.+Associative ℕSemiring (succ n *N (sn/a +N sn/b)) sn%a sn%b) (transitivity (applyEquality (_+N sn%b) (transitivity (transitivity (applyEquality (_+N sn%a) (transitivity (applyEquality (succ n *N_) (Semiring.commutative ℕSemiring sn/a sn/b)) (Semiring.+DistributesOver* ℕSemiring (succ n) sn/b sn/a))) (equalityCommutative (Semiring.+Associative ℕSemiring (succ n *N sn/b) (succ n *N sn/a) sn%a))) (Semiring.commutative ℕSemiring (succ n *N sn/b) ((succ n *N sn/a) +N sn%a)))) (equalityCommutative (Semiring.+Associative ℕSemiring ((succ n *N sn/a) +N sn%a) (succ n *N sn/b) sn%b)))) t
      thing : ((succ n) *N quot) +N rem ≡ sn%a +N sn%b
      thing = pr
      t'' : (succ n *N ((sn/a +N sn/b) +N quot)) +N rem ≡ a +N b
      t'' rewrite Semiring.+DistributesOver* ℕSemiring (succ n) (sn/a +N sn/b) quot | equalityCommutative (Semiring.+Associative ℕSemiring (succ n *N (sn/a +N sn/b)) (succ n *N quot) rem) | thing = t'
      whoa : rem ≡ sn%a+b
      whoa = modUniqueLemma _ _ remIsSmall sn%a+b<sn (transitivity t'' (equalityCommutative prA+B))

  modAddition : {n : ℕ} → .(pr : 0 <N n) → {a b : ℕ} → (a <N n) → (b <N n) → (a +N b ≡ mod n pr (a +N b)) || (a +N b ≡ n +N mod n pr (a +N b))
  modAddition {succ n} 0<sn {a} {b} a<n b<n with divisionAlg (succ n) (a +N b)
  modAddition {succ n} 0<sn {a} {b} a<n b<n | record { quot = zero ; rem = rem ; pr = pr ; remIsSmall = inl rem<sn ; quotSmall = inl _ } = inl (equalityCommutative (transitivity (applyEquality (_+N rem) (multiplicationNIsCommutative 0 n)) pr))
  modAddition {succ n} 0<sn {a} {b} a<n b<n | record { quot = succ zero ; rem = rem ; pr = pr ; remIsSmall = inl rem<sn ; quotSmall = inl _ } = inr (transitivity (equalityCommutative pr) (applyEquality (λ i → succ i +N rem) (transitivity (multiplicationNIsCommutative n 1) (Semiring.sumZeroRight ℕSemiring n))))
  modAddition {succ n} 0<sn {a} {b} (le x prA) (le y prB) | record { quot = succ (succ quot) ; rem = 0 ; pr = pr ; remIsSmall = inl rem<sn ; quotSmall = inl _ } rewrite Semiring.sumZeroRight ℕSemiring (succ n *N succ (succ quot)) | multiplicationNIsCommutative (succ n) (succ (succ quot)) = exFalso (notBigger' ((x +N succ y) +N (quot *N succ n)) u)
    where
      t : ((succ x +N a) +N succ (y +N b)) +N (quot *N succ n) ≡ a +N b
      t = transitivity (transitivity (applyEquality (_+N quot *N succ n) (+NWellDefined prA prB)) (equalityCommutative (Semiring.+Associative ℕSemiring (succ n) (succ n) (quot *N succ n)))) pr
      u : ((succ x +N succ y) +N (quot *N succ n)) +N (a +N b) ≡ a +N b
      u rewrite Semiring.commutative ℕSemiring ((x +N succ y) +N quot *N succ n) (a +N b) | Semiring.+Associative ℕSemiring (succ a +N b) (x +N succ y) (quot *N succ n) = transitivity (applyEquality (λ i → succ i +N quot *N succ n) (transitivity (Semiring.commutative ℕSemiring (a +N b) _) (transitivity (equalityCommutative (Semiring.+Associative ℕSemiring x (succ y) _)) (transitivity (applyEquality (x +N_) (transitivity (Semiring.+Associative ℕSemiring (succ y) a b) (transitivity (applyEquality (_+N b) (Semiring.commutative ℕSemiring _ a)) (equalityCommutative (Semiring.+Associative ℕSemiring a (succ y) b))))) (Semiring.+Associative ℕSemiring x a _))))) t
  modAddition {succ n} 0<sn {a} {b} a<n b<n | record { quot = succ (succ quot) ; rem = succ rem ; pr = pr ; remIsSmall = inl rem<sn ; quotSmall = inl _ } = exFalso (irreflexive (<Transitive u t))
    where
      t : (succ n *N succ (succ quot) +N succ rem) <N succ n +N succ n
      t = identityOfIndiscernablesLeft _<N_ (addStrongInequalities a<n b<n) (equalityCommutative pr)
      lemm : {a c d : ℕ} → (a +N a) <N (a *N succ (succ c)) +N succ d
      lemm {a} {c} {d} = le (a *N c +N d) f
        where
          f : succ ((a *N c +N d) +N (a +N a)) ≡ a *N succ (succ c) +N succ d
          f rewrite multiplicationNIsCommutative a (succ (succ c)) | Semiring.+Associative ℕSemiring a a (c *N a) | multiplicationNIsCommutative c a | Semiring.commutative ℕSemiring (a *N c +N d) (a +N a) | Semiring.+Associative ℕSemiring (a +N a) (a *N c) d | Semiring.commutative ℕSemiring ((a +N a) +N a *N c) (succ d) = applyEquality succ (Semiring.commutative ℕSemiring _ d)
      u : (succ n +N succ n) <N (succ n *N succ (succ quot) +N succ rem)
      u = lemm {succ n}

  modN : {n : ℕ} → .(0<n : 0 <N n) → mod n 0<n n ≡ 0
  modN {succ n} 0<n = modIsUnique (divisionAlg (succ n) (succ n)) record { quot = 1 ; rem = zero ; pr = ans ; remIsSmall = inl (le n (Semiring.sumZeroRight ℕSemiring (succ n))) ; quotSmall = inl (le n (Semiring.sumZeroRight ℕSemiring (succ n))) }
    where
      ans : succ (n *N 1 +N 0) ≡ succ n
      ans rewrite multiplicationNIsCommutative n 1 | Semiring.sumZeroRight ℕSemiring n | Semiring.sumZeroRight ℕSemiring n = refl


module list-merge-sort-test where

open import list
open import nat

open import list-merge-sort ℕ _<_

test-list = 3 :: 2 :: 5 :: 1 :: 1 :: 6 :: 8 :: 9 :: 4 :: []

sorted = merge-sort test-list


{-# OPTIONS --without-K --safe #-}
open import Level
open import Categories.Category using (Category)

module Categories.NaturalTransformation.Hom {o ℓ e : Level} (C : Category o ℓ e) where

-- open import Function using (_$_; Inverse) -- else there's a conflict with the import below
-- open import Function.Equality using (Π; _⟨$⟩_; cong)
-- open import Relation.Binary using (module Setoid)
-- import Relation.Binary.Reasoning.Setoid as SetoidR
-- open import Data.Product using (_,_; Σ)

-- open import Categories.Category.Product
-- open import Categories.Category.Construction.Presheaves
-- open import Categories.Category.Construction.Functors
open import Categories.Category.Instance.Setoids
-- open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Hom using (module Hom; Hom[_][-,_]; Hom[_][-,-])
-- open import Categories.Functor.Bifunctor
-- open import Categories.Functor.Presheaf
-- open import Categories.Functor.Construction.LiftSetoids
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper) renaming (id to idN)
-- open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

-- import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

open Category C
open HomReasoning
open MR C
open NaturalTransformation
private
  module CE = Category.Equiv C
  module C = Category C

Hom[A,C]⇒Hom[B,C] : {A B : Obj} → (A ⇒ B) → NaturalTransformation Hom[ C ][-, A ] Hom[ C ][-, B ]
Hom[A,C]⇒Hom[B,C] {A} A⇒B = ntHelper record
  { η       = λ X → record { _⟨$⟩_ = λ X⇒A → A⇒B ∘ X⇒A ; cong = ∘-resp-≈ʳ }
  ; commute = λ f {g} {h} g≈h → begin
      A⇒B ∘ id ∘ g ∘ f   ≈˘⟨ assoc ⟩
      (A⇒B ∘ id) ∘ g ∘ f ≈⟨ id-comm ⟩∘⟨ g≈h ⟩∘⟨refl ⟩
      (id ∘ A⇒B) ∘ h ∘ f ≈⟨ assoc ○ ⟺ (∘-resp-≈ʳ assoc) ⟩ -- TODO: MR.Reassociate
      id ∘ (A⇒B ∘ h) ∘ f ∎
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Operations on and properties of decidable relations
------------------------------------------------------------------------

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

module Relation.Nullary.Decidable where

open import Level using (Level)
open import Function.Base
open import Function.Equality    using (_⟨$⟩_; module Π)
open import Function.Equivalence using (_⇔_; equivalence; module Equivalence)
open import Function.Injection   using (Injection; module Injection)
open import Relation.Binary      using (Setoid; module Setoid; Decidable)
open import Relation.Nullary

private
  variable
    p q : Level
    P : Set p
    Q : Set q

------------------------------------------------------------------------
-- Re-exporting the core definitions

open import Relation.Nullary.Decidable.Core public

------------------------------------------------------------------------
-- Maps

map : P ⇔ Q → Dec P → Dec Q
map P⇔Q = map′ (to ⟨$⟩_) (from ⟨$⟩_)
  where open Equivalence P⇔Q

module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂}
         (inj : Injection A B)
  where

  open Injection inj
  open Setoid A using () renaming (_≈_ to _≈A_)
  open Setoid B using () renaming (_≈_ to _≈B_)

  -- If there is an injection from one setoid to another, and the
  -- latter's equivalence relation is decidable, then the former's
  -- equivalence relation is also decidable.

  via-injection : Decidable _≈B_ → Decidable _≈A_
  via-injection dec x y =
    map′ injective (Π.cong to) (dec (to ⟨$⟩ x) (to ⟨$⟩ y))


module Data.BinaryTree where

import      Lvl
open import Type

private variable ℓ ℓᵢ ℓₗ ℓₙ ℓₒ : Lvl.Level
private variable N N₁ N₂ L T A B : Type{ℓ}

data BinaryTree (L : Type{ℓₗ}) (N : Type{ℓₙ}) : Type{ℓₗ Lvl.⊔ ℓₙ} where
  Leaf : L → BinaryTree L N
  Node : N → BinaryTree L N → BinaryTree L N → BinaryTree L N

elim : (P : BinaryTree L N → Type{ℓ}) → ((l : L) → P(Leaf l)) → (∀{tl tr} → (n : N) → (pl : P(tl)) → (pr : P(tr)) → P(Node n tl tr)) → ((t : BinaryTree L N) → P(t))
elim P pl pn (Leaf l)     = pl l
elim P pl pn (Node n l r) = pn n (elim P pl pn l) (elim P pl pn r)

open import Data using (Unit ; <>)
open import Data.Boolean
open import Data.Option
open import Data.Tuple using (_⨯_ ; _,_)
open import Functional as Fn using (_$_)
open import Numeral.Natural
open import Numeral.Natural.Function
open import Numeral.Natural.Oper hiding (_^_)

emptyTree : BinaryTree{ℓₗ} Unit N
emptyTree = Leaf <>

singleton : N → BinaryTree{ℓₗ} Unit N
singleton a = Node a emptyTree emptyTree

isLeaf : BinaryTree L N → Bool
isLeaf (Leaf _)     = 𝑇
isLeaf (Node _ _ _) = 𝐹

isNode : BinaryTree L N → Bool
isNode (Leaf _)     = 𝐹
isNode (Node _ _ _) = 𝑇

root : BinaryTree L N → Option(N)
root (Leaf _)     = None
root (Node a _ _) = Some a

flip : BinaryTree L N → BinaryTree L N
flip (Leaf l)     = Leaf l
flip (Node n l r) = Node n (flip r) (flip l)

foldPreOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  a ▫ₙ_                                         $
  Fn.swap(foldPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  Fn.swap(foldPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  id

foldInOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldInOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldInOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  Fn.swap(foldInOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  a ▫ₙ_                                        $
  Fn.swap(foldInOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  id

foldPostOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  Fn.swap(foldPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  Fn.swap(foldPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  a ▫ₙ_                                          $
  id

foldReversedPreOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldReversedPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldReversedPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  a ▫ₙ_                                                 $
  Fn.swap(foldReversedPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  Fn.swap(foldReversedPreOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  id

foldReversedInOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldReversedInOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldReversedInOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  Fn.swap(foldReversedInOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  a ▫ₙ_                                                $
  Fn.swap(foldReversedInOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  id

foldReversedPostOrderDepthFirst : (L → T → T) → (N → T → T) → T → BinaryTree L N → T
foldReversedPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Leaf a)     = a ▫ₗ id
foldReversedPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_) id (Node a l r) =
  Fn.swap(foldReversedPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) r $
  Fn.swap(foldReversedPostOrderDepthFirst(_▫ₗ_)(_▫ₙ_)) l $
  a ▫ₙ_                                                  $
  id

-- The size is the number of nodes in the tree.
size : BinaryTree L N → ℕ
size (Leaf _)     = 𝟎
size (Node _ l r) = 𝐒(size(l) + size(r))

-- The number of leaves in the tree.
numberOfLeaves : BinaryTree L N → ℕ
numberOfLeaves (Leaf _)     = 1
numberOfLeaves (Node _ l r) = numberOfLeaves(l) + numberOfLeaves(r)

-- The height is the length of the longest path from the root.
height : BinaryTree L N → ℕ
height (Leaf _)     = 𝟎
height (Node _ l r) = 𝐒(max (height l) (height r))

open import Data.Boolean.Operators
open        Data.Boolean.Operators.Programming

isFull : BinaryTree L N → Bool
isFull (Leaf _)                               = 𝑇
isFull (Node _ (Leaf _)        (Leaf _))      = 𝑇
isFull (Node _ (Node _ _ _)    (Leaf _))      = 𝐹
isFull (Node _ (Leaf _)        (Node _ _ _))  = 𝐹
isFull (Node _ l@(Node _ _ _) r@(Node _ _ _)) = isFull l && isFull r

open import Data.List
import      Data.List.Functions as List

treesOfDepth : ℕ → BinaryTree L N → List(BinaryTree L N)
treesOfDepth 𝟎      tree         = tree ⊰ ∅
treesOfDepth (𝐒(_)) (Leaf _)     = ∅
treesOfDepth (𝐒(n)) (Node _ l r) = (treesOfDepth n l) List.++ (treesOfDepth n r)


module Types.Tail1 where

open import Data.Fin
open import Data.Nat
open import Function using (_∘_)

open import Types.Direction
import Types.IND1 as IND

private
  variable
    n : ℕ

-- session types restricted to tail recursion
-- can be recognized by type of TChan constructor

data Type : Set
data SType (n : ℕ) : Set
data GType (n : ℕ) : Set

data Type where
  TUnit TInt : Type
  TPair : (t₁ t₂ : Type) → Type
  TChan : (s : IND.SType 0) → Type

data SType n where
  gdd : (g : GType n) → SType n
  rec : (g : GType (suc n)) → SType n
  var : (x : Fin n) → SType n

data GType n where
  transmit : (d : Dir) (t : Type) (s : SType n) → GType n
  choice : (d : Dir) (m : ℕ) (alt : Fin m → SType n) → GType n
  end : GType n

-- naive definition of duality for tail recursive session types
-- message types are ignored as they are closed

dualS : SType n → SType n
dualG : GType n → GType n

dualS (gdd g) = gdd (dualG g)
dualS (rec g) = rec (dualG g)
dualS (var x) = var x

dualG (transmit d t s) = transmit (dual-dir d) t (dualS s)
dualG (choice d m alt) = choice (dual-dir d) m (dualS ∘ alt)
dualG end = end


{-# OPTIONS --copatterns #-}

open import Common.Equality
open import Common.Product

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

record Functor (F : Set → Set) : Set₁ where
  field
    map : ∀ {A B} → (A → B) → F A → F B
    map-id : ∀ {A}{x : F A} → map id x ≡ x
open Functor

test : {C : Set} → Functor (_×_ C)
map    test f (c , a) = c , f a
map-id test           = refl -- : map test id x ≡ x
  -- needs to match against record constructor
  -- x/(c,a) = proj₁ x / c, proj₂ x / a


module explore where
import Explore.BigDistr
import Explore.BinTree
import Explore.Core
import Explore.Dice
import Explore.Examples
import Explore.Explorable
import Explore.Fin
import Explore.Group
import Explore.GuessingGameFlipping
import Explore.Isomorphism
import Explore.Monad
import Explore.One
import Explore.Product
import Explore.Properties
import Explore.README
import Explore.Subset
import Explore.Sum
import Explore.Summable
import Explore.Two
import Explore.Universe
import Explore.Universe.Base
import Explore.Universe.FromE
import Explore.Universe.Type
import Explore.Zero
-- BROKEN import Explore.Explorable.Fun
-- BROKEN import Explore.Function.Fin


{-# OPTIONS --cumulativity #-}

open import Agda.Primitive

-- Defaulting of level metas does not apply to interaction metas, so
-- the type of test₁ should be `Set ?0`, not `Set`.
test₁ : Set {!!}
test₁ = {!!}

postulate
  F : ∀ a (A : Set a) → A → Set

-- In this example, t first argument of F should not default to lzero
-- because it occurs in the type of another meta.
test₂ : F _ _ _
test₂ = {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- A bunch of properties about natural number operations
------------------------------------------------------------------------

-- See README.Nat for some examples showing how this module can be
-- used.

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

module Data.Nat.Properties where

open import Axiom.UniquenessOfIdentityProofs
open import Algebra
open import Algebra.Morphism
open import Function
open import Function.Injection using (_↣_)
open import Data.Nat.Base
open import Data.Product
open import Data.Sum
open import Data.Empty
open import Data.Bool.Base using (Bool; false; true; T)
open import Data.Bool.Properties using (T?)

open import Level using (0ℓ)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Relation.Nullary
open import Relation.Nullary.Decidable using (True; via-injection; map′)
open import Relation.Nullary.Negation using (contradiction)

open import Algebra.FunctionProperties (_≡_ {A = ℕ})
  hiding (LeftCancellative; RightCancellative; Cancellative)
open import Algebra.FunctionProperties
  using (LeftCancellative; RightCancellative; Cancellative)
open import Algebra.FunctionProperties.Consequences.Propositional
open import Algebra.Structures (_≡_ {A = ℕ})
open ≡-Reasoning

------------------------------------------------------------------------
-- Properties of _≡_

suc-injective : ∀ {m n} → suc m ≡ suc n → m ≡ n
suc-injective refl = refl

≡ᵇ⇒≡ : ∀ m n → T (m ≡ᵇ n) → m ≡ n
≡ᵇ⇒≡ zero    zero    _  = refl
≡ᵇ⇒≡ (suc m) (suc n) eq = cong suc (≡ᵇ⇒≡ m n eq)
≡ᵇ⇒≡ zero    (suc n) ()
≡ᵇ⇒≡ (suc m) zero    ()

≡⇒≡ᵇ : ∀ m n → m ≡ n → T (m ≡ᵇ n)
≡⇒≡ᵇ zero    zero    eq = _
≡⇒≡ᵇ (suc m) (suc n) eq = ≡⇒≡ᵇ m n (suc-injective eq)
≡⇒≡ᵇ zero    (suc n) ()
≡⇒≡ᵇ (suc m) zero    ()

-- NB: we use the builtin function `_≡ᵇ_ : (m n : ℕ) → Bool` here so
-- that the function quickly decides whether to return `yes` or `no`.
-- It sill takes a linear amount of time to generate the proof if it
-- is inspected. We expect the main benefit to be visible in compiled
-- code: the backend erases proofs.

infix 4 _≟_
_≟_ : Decidable {A = ℕ} _≡_
m ≟ n = map′ (≡ᵇ⇒≡ m n) (≡⇒≡ᵇ m n) (T? (m ≡ᵇ n))

≡-irrelevant : Irrelevant {A = ℕ} _≡_
≡-irrelevant = Decidable⇒UIP.≡-irrelevant _≟_

≟-diag : ∀ {m n} (eq : m ≡ n) → (m ≟ n) ≡ yes eq
≟-diag = ≡-≟-identity _≟_

≡-isDecEquivalence : IsDecEquivalence (_≡_ {A = ℕ})
≡-isDecEquivalence = record
  { isEquivalence = isEquivalence
  ; _≟_           = _≟_
  }

≡-decSetoid : DecSetoid 0ℓ 0ℓ
≡-decSetoid = record
  { Carrier          = ℕ
  ; _≈_              = _≡_
  ; isDecEquivalence = ≡-isDecEquivalence
  }

------------------------------------------------------------------------
-- Properties of _≤_

≤-pred : ∀ {m n} → suc m ≤ suc n → m ≤ n
≤-pred (s≤s m≤n) = m≤n

-- Relation-theoretic properties of _≤_
≤-reflexive : _≡_ ⇒ _≤_
≤-reflexive {zero}  refl = z≤n
≤-reflexive {suc m} refl = s≤s (≤-reflexive refl)

≤-refl : Reflexive _≤_
≤-refl = ≤-reflexive refl

≤-antisym : Antisymmetric _≡_ _≤_
≤-antisym z≤n       z≤n       = refl
≤-antisym (s≤s m≤n) (s≤s n≤m) = cong suc (≤-antisym m≤n n≤m)

≤-trans : Transitive _≤_
≤-trans z≤n       _         = z≤n
≤-trans (s≤s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o)

≤-total : Total _≤_
≤-total zero    _       = inj₁ z≤n
≤-total _       zero    = inj₂ z≤n
≤-total (suc m) (suc n) with ≤-total m n
... | inj₁ m≤n = inj₁ (s≤s m≤n)
... | inj₂ n≤m = inj₂ (s≤s n≤m)

infix 4 _≤?_ _≥?_

_≤?_ : Decidable _≤_
zero  ≤? _     = yes z≤n
suc m ≤? zero  = no λ()
suc m ≤? suc n with m ≤? n
... | yes m≤n = yes (s≤s m≤n)
... | no  m≰n = no  (m≰n ∘ ≤-pred)

_≥?_ : Decidable _≥_
_≥?_ = flip _≤?_

≤-isPreorder : IsPreorder _≡_ _≤_
≤-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = ≤-reflexive
  ; trans         = ≤-trans
  }

≤-preorder : Preorder 0ℓ 0ℓ 0ℓ
≤-preorder = record
  { isPreorder = ≤-isPreorder
  }

≤-isPartialOrder : IsPartialOrder _≡_ _≤_
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

≤-poset : Poset 0ℓ 0ℓ 0ℓ
≤-poset = record
  { isPartialOrder = ≤-isPartialOrder
  }

≤-isTotalOrder : IsTotalOrder _≡_ _≤_
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ
≤-totalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  }

≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_
≤-isDecTotalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  ; _≟_          = _≟_
  ; _≤?_         = _≤?_
  }

≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ
≤-decTotalOrder = record
  { isDecTotalOrder = ≤-isDecTotalOrder
  }

-- Other properties of _≤_
s≤s-injective : ∀ {m n} {p q : m ≤ n} → s≤s p ≡ s≤s q → p ≡ q
s≤s-injective refl = refl

≤-irrelevant : Irrelevant _≤_
≤-irrelevant z≤n        z≤n        = refl
≤-irrelevant (s≤s m≤n₁) (s≤s m≤n₂) = cong s≤s (≤-irrelevant m≤n₁ m≤n₂)

≤-step : ∀ {m n} → m ≤ n → m ≤ 1 + n
≤-step z≤n       = z≤n
≤-step (s≤s m≤n) = s≤s (≤-step m≤n)

n≤1+n : ∀ n → n ≤ 1 + n
n≤1+n _ = ≤-step ≤-refl

1+n≰n : ∀ {n} → 1 + n ≰ n
1+n≰n (s≤s le) = 1+n≰n le

n≤0⇒n≡0 : ∀ {n} → n ≤ 0 → n ≡ 0
n≤0⇒n≡0 z≤n = refl

------------------------------------------------------------------------
-- Properties of _<_

-- Relation theoretic properties of _<_

<-irrefl : Irreflexive _≡_ _<_
<-irrefl refl (s≤s n<n) = <-irrefl refl n<n

<-asym : Asymmetric _<_
<-asym (s≤s n<m) (s≤s m<n) = <-asym n<m m<n

<-trans : Transitive _<_
<-trans (s≤s i≤j) (s≤s j<k) = s≤s (≤-trans i≤j (≤-trans (n≤1+n _) j<k))

<-transʳ : Trans _≤_ _<_ _<_
<-transʳ m≤n (s≤s n≤o) = s≤s (≤-trans m≤n n≤o)

<-transˡ : Trans _<_ _≤_ _<_
<-transˡ (s≤s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o)

<-cmp : Trichotomous _≡_ _<_
<-cmp zero    zero    = tri≈ (λ())     refl  (λ())
<-cmp zero    (suc n) = tri< (s≤s z≤n) (λ()) (λ())
<-cmp (suc m) zero    = tri> (λ())     (λ()) (s≤s z≤n)
<-cmp (suc m) (suc n) with <-cmp m n
... | tri< ≤ ≢ ≱ = tri< (s≤s ≤)      (≢ ∘ suc-injective) (≱ ∘ ≤-pred)
... | tri≈ ≰ ≡ ≱ = tri≈ (≰ ∘ ≤-pred) (cong suc ≡)        (≱ ∘ ≤-pred)
... | tri> ≰ ≢ ≥ = tri> (≰ ∘ ≤-pred) (≢ ∘ suc-injective) (s≤s ≥)

infix 4 _<?_ _>?_

_<?_ : Decidable _<_
x <? y = suc x ≤? y

_>?_ : Decidable _>_
_>?_ = flip _<?_

<-resp₂-≡ : _<_ Respects₂ _≡_
<-resp₂-≡ = subst (_ <_) , subst (_< _)

<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_
<-isStrictPartialOrder = record
  { isEquivalence = isEquivalence
  ; irrefl        = <-irrefl
  ; trans         = <-trans
  ; <-resp-≈      = <-resp₂-≡
  }

<-strictPartialOrder : StrictPartialOrder 0ℓ 0ℓ 0ℓ
<-strictPartialOrder = record
  { isStrictPartialOrder = <-isStrictPartialOrder
  }

<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_
<-isStrictTotalOrder = record
  { isEquivalence = isEquivalence
  ; trans         = <-trans
  ; compare       = <-cmp
  }

<-strictTotalOrder : StrictTotalOrder 0ℓ 0ℓ 0ℓ
<-strictTotalOrder = record
  { isStrictTotalOrder = <-isStrictTotalOrder
  }

-- Other properties of _<_
<-irrelevant : Irrelevant _<_
<-irrelevant = ≤-irrelevant

<⇒≤pred : ∀ {m n} → m < n → m ≤ pred n
<⇒≤pred (s≤s le) = le

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ (s≤s m≤n) = ≤-trans m≤n (≤-step ≤-refl)

<⇒≢ : _<_ ⇒ _≢_
<⇒≢ m<n refl = 1+n≰n m<n

≤⇒≯ : _≤_ ⇒ _≯_
≤⇒≯ z≤n       ()
≤⇒≯ (s≤s m≤n) (s≤s n≤m) = ≤⇒≯ m≤n n≤m

<⇒≱ : _<_ ⇒ _≱_
<⇒≱ (s≤s m+1≤n) (s≤s n≤m) = <⇒≱ m+1≤n n≤m

<⇒≯ : _<_ ⇒ _≯_
<⇒≯ (s≤s m<n) (s≤s n<m) = <⇒≯ m<n n<m

≰⇒≮ : _≰_ ⇒ _≮_
≰⇒≮ m≰n 1+m≤n = m≰n (<⇒≤ 1+m≤n)

≰⇒> : _≰_ ⇒ _>_
≰⇒> {zero}          z≰n = contradiction z≤n z≰n
≰⇒> {suc m} {zero}  _   = s≤s z≤n
≰⇒> {suc m} {suc n} m≰n = s≤s (≰⇒> (m≰n ∘ s≤s))

≰⇒≥ : _≰_ ⇒ _≥_
≰⇒≥ = <⇒≤ ∘ ≰⇒>

≮⇒≥ : _≮_ ⇒ _≥_
≮⇒≥ {_}     {zero}  _       = z≤n
≮⇒≥ {zero}  {suc j} 1≮j+1   = contradiction (s≤s z≤n) 1≮j+1
≮⇒≥ {suc i} {suc j} i+1≮j+1 = s≤s (≮⇒≥ (i+1≮j+1 ∘ s≤s))

≤∧≢⇒< : ∀ {m n} → m ≤ n → m ≢ n → m < n
≤∧≢⇒< {_} {zero}  z≤n       m≢n     = contradiction refl m≢n
≤∧≢⇒< {_} {suc n} z≤n       m≢n     = s≤s z≤n
≤∧≢⇒< {_} {suc n} (s≤s m≤n) 1+m≢1+n =
  s≤s (≤∧≢⇒< m≤n (1+m≢1+n ∘ cong suc))

n≮n : ∀ n → n ≮ n
n≮n n = <-irrefl (refl {x = n})

m<n⇒n≢0 : ∀ {m n} → m < n → n ≢ 0
m<n⇒n≢0 (s≤s m≤n) ()

------------------------------------------------------------------------
-- Properties of _≤′_

≤′-trans : Transitive _≤′_
≤′-trans m≤n ≤′-refl = m≤n
≤′-trans m≤n (≤′-step n≤o) = ≤′-step (≤′-trans m≤n n≤o)

z≤′n : ∀ {n} → zero ≤′ n
z≤′n {zero}  = ≤′-refl
z≤′n {suc n} = ≤′-step z≤′n

s≤′s : ∀ {m n} → m ≤′ n → suc m ≤′ suc n
s≤′s ≤′-refl        = ≤′-refl
s≤′s (≤′-step m≤′n) = ≤′-step (s≤′s m≤′n)

≤′⇒≤ : _≤′_ ⇒ _≤_
≤′⇒≤ ≤′-refl        = ≤-refl
≤′⇒≤ (≤′-step m≤′n) = ≤-step (≤′⇒≤ m≤′n)

≤⇒≤′ : _≤_ ⇒ _≤′_
≤⇒≤′ z≤n       = z≤′n
≤⇒≤′ (s≤s m≤n) = s≤′s (≤⇒≤′ m≤n)

≤′-step-injective : ∀ {m n} {p q : m ≤′ n} → ≤′-step p ≡ ≤′-step q → p ≡ q
≤′-step-injective refl = refl

-- Decidablity for _≤'_

infix 4 _≤′?_ _<′?_ _≥′?_ _>′?_

_≤′?_ : Decidable _≤′_
x ≤′? y = map′ ≤⇒≤′ ≤′⇒≤ (x ≤? y)

_<′?_ : Decidable _<′_
x <′? y = suc x ≤′? y

_≥′?_ : Decidable _≥′_
_≥′?_ = flip _≤′?_

_>′?_ : Decidable _>′_
_>′?_ = flip _<′?_

------------------------------------------------------------------------
-- Properties of pred

pred-mono : pred Preserves _≤_ ⟶ _≤_
pred-mono z≤n      = z≤n
pred-mono (s≤s le) = le

≤pred⇒≤ : ∀ {m n} → m ≤ pred n → m ≤ n
≤pred⇒≤ {m} {zero}  le = le
≤pred⇒≤ {m} {suc n} le = ≤-step le

≤⇒pred≤ : ∀ {m n} → m ≤ n → pred m ≤ n
≤⇒pred≤ {zero}  le = le
≤⇒pred≤ {suc m} le = ≤-trans (n≤1+n m) le

m≢0⇒suc[pred[m]]≡m : ∀ {m} → m ≢ 0 → suc (pred m) ≡ m
m≢0⇒suc[pred[m]]≡m {zero}  m≢0 = ⊥-elim (m≢0 refl)
m≢0⇒suc[pred[m]]≡m {suc m} m≢0 = refl

------------------------------------------------------------------------
-- Properties of _+_

-- Algebraic properties of _+_
+-suc : ∀ m n → m + suc n ≡ suc (m + n)
+-suc zero    n = refl
+-suc (suc m) n = cong suc (+-suc m n)

+-assoc : Associative _+_
+-assoc zero    _ _ = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

+-identityˡ : LeftIdentity 0 _+_
+-identityˡ _ = refl

+-identityʳ : RightIdentity 0 _+_
+-identityʳ zero    = refl
+-identityʳ (suc n) = cong suc (+-identityʳ n)

+-identity : Identity 0 _+_
+-identity = +-identityˡ , +-identityʳ

+-comm : Commutative _+_
+-comm zero    n = sym (+-identityʳ n)
+-comm (suc m) n = begin
  suc m + n   ≡⟨⟩
  suc (m + n) ≡⟨ cong suc (+-comm m n) ⟩
  suc (n + m) ≡⟨ sym (+-suc n m) ⟩
  n + suc m   ∎

+-isMagma : IsMagma _+_
+-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _+_
  }

+-magma : Magma 0ℓ 0ℓ
+-magma = record
  { isMagma = +-isMagma
  }

+-isSemigroup : IsSemigroup _+_
+-isSemigroup = record
  { isMagma = +-isMagma
  ; assoc   = +-assoc
  }

+-semigroup : Semigroup 0ℓ 0ℓ
+-semigroup = record
  { isSemigroup = +-isSemigroup
  }

+-0-isMonoid : IsMonoid _+_ 0
+-0-isMonoid = record
  { isSemigroup = +-isSemigroup
  ; identity    = +-identity
  }

+-0-monoid : Monoid 0ℓ 0ℓ
+-0-monoid = record
  { isMonoid = +-0-isMonoid
  }

+-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0
+-0-isCommutativeMonoid = record
  { isSemigroup = +-isSemigroup
  ; identityˡ    = +-identityˡ
  ; comm        = +-comm
  }

+-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
+-0-commutativeMonoid = record
  { isCommutativeMonoid = +-0-isCommutativeMonoid
  }

-- Other properties of _+_ and _≡_

+-cancelˡ-≡ : LeftCancellative _≡_ _+_
+-cancelˡ-≡ zero    eq = eq
+-cancelˡ-≡ (suc m) eq = +-cancelˡ-≡ m (cong pred eq)

+-cancelʳ-≡ : RightCancellative _≡_ _+_
+-cancelʳ-≡ = comm+cancelˡ⇒cancelʳ +-comm +-cancelˡ-≡

+-cancel-≡ : Cancellative _≡_ _+_
+-cancel-≡ = +-cancelˡ-≡ , +-cancelʳ-≡

m≢1+m+n : ∀ m {n} → m ≢ suc (m + n)
m≢1+m+n zero    ()
m≢1+m+n (suc m) eq = m≢1+m+n m (cong pred eq)

m≢1+n+m : ∀ m {n} → m ≢ suc (n + m)
m≢1+n+m m m≡1+n+m = m≢1+m+n m (trans m≡1+n+m (cong suc (+-comm _ m)))

i+1+j≢i : ∀ i {j} → i + suc j ≢ i
i+1+j≢i zero    ()
i+1+j≢i (suc i) = (i+1+j≢i i) ∘ suc-injective

i+j≡0⇒i≡0 : ∀ i {j} → i + j ≡ 0 → i ≡ 0
i+j≡0⇒i≡0 zero    eq = refl
i+j≡0⇒i≡0 (suc i) ()

i+j≡0⇒j≡0 : ∀ i {j} → i + j ≡ 0 → j ≡ 0
i+j≡0⇒j≡0 i {j} i+j≡0 = i+j≡0⇒i≡0 j (trans (+-comm j i) (i+j≡0))

-- Properties of _+_ and orderings

+-cancelˡ-≤ : LeftCancellative _≤_ _+_
+-cancelˡ-≤ zero    le       = le
+-cancelˡ-≤ (suc m) (s≤s le) = +-cancelˡ-≤ m le

+-cancelʳ-≤ : RightCancellative _≤_ _+_
+-cancelʳ-≤ {m} n o le =
  +-cancelˡ-≤ m (subst₂ _≤_ (+-comm n m) (+-comm o m) le)

+-cancel-≤ : Cancellative _≤_ _+_
+-cancel-≤ = +-cancelˡ-≤ , +-cancelʳ-≤

+-cancelˡ-< : LeftCancellative _<_ _+_
+-cancelˡ-< x {y} {z} = +-cancelˡ-≤ x ∘ subst (_≤ x + z) (sym (+-suc x y))

+-cancelʳ-< : RightCancellative _<_ _+_
+-cancelʳ-< y z y+x<z+x = +-cancelʳ-≤ (suc y) z y+x<z+x

+-cancel-< : Cancellative _<_ _+_
+-cancel-< = +-cancelˡ-< , +-cancelʳ-<

≤-stepsˡ : ∀ {m n} o → m ≤ n → m ≤ o + n
≤-stepsˡ zero    m≤n = m≤n
≤-stepsˡ (suc o) m≤n = ≤-step (≤-stepsˡ o m≤n)

≤-stepsʳ : ∀ {m n} o → m ≤ n → m ≤ n + o
≤-stepsʳ {m} o m≤n = subst (m ≤_) (+-comm o _) (≤-stepsˡ o m≤n)

m≤m+n : ∀ m n → m ≤ m + n
m≤m+n zero    n = z≤n
m≤m+n (suc m) n = s≤s (m≤m+n m n)

n≤m+n : ∀ m n → n ≤ m + n
n≤m+n m zero    = z≤n
n≤m+n m (suc n) = subst (suc n ≤_) (sym (+-suc m n)) (s≤s (n≤m+n m n))

m+n≤o⇒m≤o : ∀ m {n o} → m + n ≤ o → m ≤ o
m+n≤o⇒m≤o zero    m+n≤o       = z≤n
m+n≤o⇒m≤o (suc m) (s≤s m+n≤o) = s≤s (m+n≤o⇒m≤o m m+n≤o)

m+n≤o⇒n≤o : ∀ m {n o} → m + n ≤ o → n ≤ o
m+n≤o⇒n≤o zero    n≤o   = n≤o
m+n≤o⇒n≤o (suc m) m+n<o = m+n≤o⇒n≤o m (<⇒≤ m+n<o)

+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+-mono-≤ {_} {m} z≤n       o≤p = ≤-trans o≤p (n≤m+n m _)
+-mono-≤ {_} {_} (s≤s m≤n) o≤p = s≤s (+-mono-≤ m≤n o≤p)

+-monoˡ-≤ : ∀ n → (_+ n) Preserves _≤_ ⟶ _≤_
+-monoˡ-≤ n m≤o = +-mono-≤ m≤o (≤-refl {n})

+-monoʳ-≤ : ∀ n → (n +_) Preserves _≤_ ⟶ _≤_
+-monoʳ-≤ n m≤o = +-mono-≤ (≤-refl {n}) m≤o

+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_
+-mono-<-≤ {_} {suc y} (s≤s z≤n)       u≤v = s≤s (≤-stepsˡ y u≤v)
+-mono-<-≤ {_} {_}     (s≤s (s≤s x<y)) u≤v = s≤s (+-mono-<-≤ (s≤s x<y) u≤v)

+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_
+-mono-≤-< {_} {y} z≤n       u<v = ≤-trans u<v (n≤m+n y _)
+-mono-≤-< {_} {_} (s≤s x≤y) u<v = s≤s (+-mono-≤-< x≤y u<v)

+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
+-mono-< x≤y = +-mono-≤-< (<⇒≤ x≤y)

+-monoˡ-< : ∀ n → (_+ n) Preserves _<_ ⟶ _<_
+-monoˡ-< n = +-monoˡ-≤ n

+-monoʳ-< : ∀ n → (n +_) Preserves _<_ ⟶ _<_
+-monoʳ-< zero    m≤o = m≤o
+-monoʳ-< (suc n) m≤o = s≤s (+-monoʳ-< n m≤o)

i+1+j≰i : ∀ i {j} → i + suc j ≰ i
i+1+j≰i zero    ()
i+1+j≰i (suc i) le = i+1+j≰i i (≤-pred le)

m+n≮n : ∀ m n → m + n ≮ n
m+n≮n zero    n                   = n≮n n
m+n≮n (suc m) (suc n) (s≤s m+n<n) = m+n≮n m (suc n) (≤-step m+n<n)

m+n≮m : ∀ m n → m + n ≮ m
m+n≮m m n = subst (_≮ m) (+-comm n m) (m+n≮n n m)

m≤′m+n : ∀ m n → m ≤′ m + n
m≤′m+n m n = ≤⇒≤′ (m≤m+n m n)

n≤′m+n : ∀ m n → n ≤′ m + n
n≤′m+n zero    n = ≤′-refl
n≤′m+n (suc m) n = ≤′-step (n≤′m+n m n)

------------------------------------------------------------------------
-- Properties of _*_

+-*-suc : ∀ m n → m * suc n ≡ m + m * n
+-*-suc zero    n = refl
+-*-suc (suc m) n = begin
  suc m * suc n         ≡⟨⟩
  suc n + m * suc n     ≡⟨ cong (suc n +_) (+-*-suc m n) ⟩
  suc n + (m + m * n)   ≡⟨⟩
  suc (n + (m + m * n)) ≡⟨ cong suc (sym (+-assoc n m (m * n))) ⟩
  suc (n + m + m * n)   ≡⟨ cong (λ x → suc (x + m * n)) (+-comm n m) ⟩
  suc (m + n + m * n)   ≡⟨ cong suc (+-assoc m n (m * n)) ⟩
  suc (m + (n + m * n)) ≡⟨⟩
  suc m + suc m * n     ∎

*-identityˡ : LeftIdentity 1 _*_
*-identityˡ x = +-identityʳ x

*-identityʳ : RightIdentity 1 _*_
*-identityʳ zero    = refl
*-identityʳ (suc x) = cong suc (*-identityʳ x)

*-identity : Identity 1 _*_
*-identity = *-identityˡ , *-identityʳ

*-zeroˡ : LeftZero 0 _*_
*-zeroˡ _ = refl

*-zeroʳ : RightZero 0 _*_
*-zeroʳ zero    = refl
*-zeroʳ (suc n) = *-zeroʳ n

*-zero : Zero 0 _*_
*-zero = *-zeroˡ , *-zeroʳ

*-comm : Commutative _*_
*-comm zero    n = sym (*-zeroʳ n)
*-comm (suc m) n = begin
  suc m * n  ≡⟨⟩
  n + m * n  ≡⟨ cong (n +_) (*-comm m n) ⟩
  n + n * m  ≡⟨ sym (+-*-suc n m) ⟩
  n * suc m  ∎

*-distribʳ-+ : _*_ DistributesOverʳ _+_
*-distribʳ-+ m zero    o = refl
*-distribʳ-+ m (suc n) o = begin
  (suc n + o) * m     ≡⟨⟩
  m + (n + o) * m     ≡⟨ cong (m +_) (*-distribʳ-+ m n o) ⟩
  m + (n * m + o * m) ≡⟨ sym (+-assoc m (n * m) (o * m)) ⟩
  m + n * m + o * m   ≡⟨⟩
  suc n * m + o * m   ∎

*-distribˡ-+ : _*_ DistributesOverˡ _+_
*-distribˡ-+ = comm+distrʳ⇒distrˡ *-comm *-distribʳ-+

*-distrib-+ : _*_ DistributesOver _+_
*-distrib-+ = *-distribˡ-+ , *-distribʳ-+

*-assoc : Associative _*_
*-assoc zero    n o = refl
*-assoc (suc m) n o = begin
  (suc m * n) * o     ≡⟨⟩
  (n + m * n) * o     ≡⟨ *-distribʳ-+ o n (m * n) ⟩
  n * o + (m * n) * o ≡⟨ cong (n * o +_) (*-assoc m n o) ⟩
  n * o + m * (n * o) ≡⟨⟩
  suc m * (n * o)     ∎

*-isMagma : IsMagma _*_
*-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _*_
  }

*-magma : Magma 0ℓ 0ℓ
*-magma = record
  { isMagma = *-isMagma
  }

*-isSemigroup : IsSemigroup _*_
*-isSemigroup = record
  { isMagma = *-isMagma
  ; assoc   = *-assoc
  }

*-semigroup : Semigroup 0ℓ 0ℓ
*-semigroup = record
  { isSemigroup = *-isSemigroup
  }

*-1-isMonoid : IsMonoid _*_ 1
*-1-isMonoid = record
  { isSemigroup = *-isSemigroup
  ; identity    = *-identity
  }

*-1-monoid : Monoid 0ℓ 0ℓ
*-1-monoid = record
  { isMonoid = *-1-isMonoid
  }

*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1
*-1-isCommutativeMonoid = record
  { isSemigroup = *-isSemigroup
  ; identityˡ    = *-identityˡ
  ; comm        = *-comm
  }

*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
*-1-commutativeMonoid = record
  { isCommutativeMonoid = *-1-isCommutativeMonoid
  }

*-+-isSemiring : IsSemiring _+_ _*_ 0 1
*-+-isSemiring = record
  { isSemiringWithoutAnnihilatingZero = record
    { +-isCommutativeMonoid = +-0-isCommutativeMonoid
    ; *-isMonoid            = *-1-isMonoid
    ; distrib               = *-distrib-+ }
  ; zero = *-zero
  }

*-+-semiring : Semiring 0ℓ 0ℓ
*-+-semiring = record
  { isSemiring = *-+-isSemiring
  }

*-+-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ 0 1
*-+-isCommutativeSemiring = record
  { +-isCommutativeMonoid = +-0-isCommutativeMonoid
  ; *-isCommutativeMonoid = *-1-isCommutativeMonoid
  ; distribʳ              = *-distribʳ-+
  ; zeroˡ                 = *-zeroˡ
  }

*-+-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ
*-+-commutativeSemiring = record
  { isCommutativeSemiring = *-+-isCommutativeSemiring
  }

-- Other properties of _*_

*-cancelʳ-≡ : ∀ i j {k} → i * suc k ≡ j * suc k → i ≡ j
*-cancelʳ-≡ zero    zero        eq = refl
*-cancelʳ-≡ zero    (suc j)     ()
*-cancelʳ-≡ (suc i) zero        ()
*-cancelʳ-≡ (suc i) (suc j) {k} eq =
  cong suc (*-cancelʳ-≡ i j (+-cancelˡ-≡ (suc k) eq))

*-cancelˡ-≡ : ∀ {i j} k → suc k * i ≡ suc k * j → i ≡ j
*-cancelˡ-≡ {i} {j} k eq = *-cancelʳ-≡ i j
  (subst₂ _≡_ (*-comm (suc k) i) (*-comm (suc k) j) eq)

i*j≡0⇒i≡0∨j≡0 : ∀ i {j} → i * j ≡ 0 → i ≡ 0 ⊎ j ≡ 0
i*j≡0⇒i≡0∨j≡0 zero    {j}     eq = inj₁ refl
i*j≡0⇒i≡0∨j≡0 (suc i) {zero}  eq = inj₂ refl
i*j≡0⇒i≡0∨j≡0 (suc i) {suc j} ()

i*j≡1⇒i≡1 : ∀ i j → i * j ≡ 1 → i ≡ 1
i*j≡1⇒i≡1 (suc zero)    j             _  = refl
i*j≡1⇒i≡1 zero          j             ()
i*j≡1⇒i≡1 (suc (suc i)) (suc (suc j)) ()
i*j≡1⇒i≡1 (suc (suc i)) (suc zero)    ()
i*j≡1⇒i≡1 (suc (suc i)) zero          eq =
  contradiction (trans (sym $ *-zeroʳ i) eq) λ()

i*j≡1⇒j≡1 : ∀ i j → i * j ≡ 1 → j ≡ 1
i*j≡1⇒j≡1 i j eq = i*j≡1⇒i≡1 j i (trans (*-comm j i) eq)

*-cancelʳ-≤ : ∀ i j k → i * suc k ≤ j * suc k → i ≤ j
*-cancelʳ-≤ zero    _       _ _  = z≤n
*-cancelʳ-≤ (suc i) zero    _ ()
*-cancelʳ-≤ (suc i) (suc j) k le =
  s≤s (*-cancelʳ-≤ i j k (+-cancelˡ-≤ (suc k) le))

*-mono-≤ : _*_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
*-mono-≤ z≤n       _   = z≤n
*-mono-≤ (s≤s m≤n) u≤v = +-mono-≤ u≤v (*-mono-≤ m≤n u≤v)

*-monoˡ-≤ : ∀ n → (_* n) Preserves _≤_ ⟶ _≤_
*-monoˡ-≤ n m≤o = *-mono-≤ m≤o (≤-refl {n})

*-monoʳ-≤ : ∀ n → (n *_) Preserves _≤_ ⟶ _≤_
*-monoʳ-≤ n m≤o = *-mono-≤ (≤-refl {n}) m≤o

*-mono-< : _*_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
*-mono-< (s≤s z≤n)       (s≤s u≤v) = s≤s z≤n
*-mono-< (s≤s (s≤s m≤n)) (s≤s u≤v) =
  +-mono-< (s≤s u≤v) (*-mono-< (s≤s m≤n) (s≤s u≤v))

*-monoˡ-< : ∀ n → (_* suc n) Preserves _<_ ⟶ _<_
*-monoˡ-< n (s≤s z≤n)       = s≤s z≤n
*-monoˡ-< n (s≤s (s≤s m≤o)) =
  +-mono-≤-< (≤-refl {suc n}) (*-monoˡ-< n (s≤s m≤o))

*-monoʳ-< : ∀ n → (suc n *_) Preserves _<_ ⟶ _<_
*-monoʳ-< zero    (s≤s m≤o) = +-mono-≤ (s≤s m≤o) z≤n
*-monoʳ-< (suc n) (s≤s m≤o) =
  +-mono-≤ (s≤s m≤o) (<⇒≤ (*-monoʳ-< n (s≤s m≤o)))

------------------------------------------------------------------------
-- Properties of _^_

^-identityʳ : RightIdentity 1 _^_
^-identityʳ zero    = refl
^-identityʳ (suc x) = cong suc (^-identityʳ x)

^-zeroˡ : LeftZero 1 _^_
^-zeroˡ zero    = refl
^-zeroˡ (suc e) = begin
  1 ^ suc e   ≡⟨⟩
  1 * (1 ^ e) ≡⟨ *-identityˡ (1 ^ e) ⟩
  1 ^ e       ≡⟨ ^-zeroˡ e ⟩
  1           ∎

^-distribˡ-+-* : ∀ m n p → m ^ (n + p) ≡ m ^ n * m ^ p
^-distribˡ-+-* m zero    p = sym (+-identityʳ (m ^ p))
^-distribˡ-+-* m (suc n) p = begin
  m * (m ^ (n + p))       ≡⟨ cong (m *_) (^-distribˡ-+-* m n p) ⟩
  m * ((m ^ n) * (m ^ p)) ≡⟨ sym (*-assoc m _ _) ⟩
  (m * (m ^ n)) * (m ^ p) ∎

^-semigroup-morphism : ∀ {n} → (n ^_) Is +-semigroup -Semigroup⟶ *-semigroup
^-semigroup-morphism = record
  { ⟦⟧-cong = cong (_ ^_)
  ; ∙-homo  = ^-distribˡ-+-* _
  }

^-monoid-morphism : ∀ {n} → (n ^_) Is +-0-monoid -Monoid⟶ *-1-monoid
^-monoid-morphism = record
  { sm-homo = ^-semigroup-morphism
  ; ε-homo  = refl
  }

^-*-assoc : ∀ m n p → (m ^ n) ^ p ≡ m ^ (n * p)
^-*-assoc m n zero    = begin
  1           ≡⟨⟩
  m ^ 0       ≡⟨ cong (m ^_) (sym $ *-zeroʳ n) ⟩
  m ^ (n * 0) ∎
^-*-assoc m n (suc p) = begin
  (m ^ n) * ((m ^ n) ^ p) ≡⟨ cong ((m ^ n) *_) (^-*-assoc m n p) ⟩
  (m ^ n) * (m ^ (n * p)) ≡⟨ sym (^-distribˡ-+-* m n (n * p)) ⟩
  m ^ (n + n * p)         ≡⟨ cong (m ^_) (sym (+-*-suc n p)) ⟩
  m ^ (n * (suc p)) ∎

i^j≡0⇒i≡0 : ∀ i j → i ^ j ≡ 0 → i ≡ 0
i^j≡0⇒i≡0 i zero    ()
i^j≡0⇒i≡0 i (suc j) eq = [ id , i^j≡0⇒i≡0 i j ]′ (i*j≡0⇒i≡0∨j≡0 i eq)

i^j≡1⇒j≡0∨i≡1 : ∀ i j → i ^ j ≡ 1 → j ≡ 0 ⊎ i ≡ 1
i^j≡1⇒j≡0∨i≡1 i zero    _  = inj₁ refl
i^j≡1⇒j≡0∨i≡1 i (suc j) eq = inj₂ (i*j≡1⇒i≡1 i (i ^ j) eq)

------------------------------------------------------------------------
-- Properties of _≤‴_

≤‴⇒≤″ : ∀{m n} → m ≤‴ n → m ≤″ n
≤‴⇒≤″ {m = m} ≤‴-refl = less-than-or-equal {k = 0} (+-identityʳ m)
≤‴⇒≤″ {m = m} (≤‴-step x) = less-than-or-equal (trans (+-suc m _) (_≤″_.proof ind)) where
  ind = ≤‴⇒≤″ x

m≤‴m+k : ∀{m n k} → m + k ≡ n → m ≤‴ n
m≤‴m+k {m} {k = zero} refl = subst (λ z → m ≤‴ z) (sym (+-identityʳ m)) (≤‴-refl {m})
m≤‴m+k {m} {k = suc k} proof
  = ≤‴-step (m≤‴m+k {k = k} (trans (sym (+-suc m _)) proof))

≤″⇒≤‴ : ∀{m n} → m ≤″ n → m ≤‴ n
≤″⇒≤‴ (less-than-or-equal {k} proof) = m≤‴m+k proof

------------------------------------------------------------------------
-- Properties of _⊔_ and _⊓_

⊔-assoc : Associative _⊔_
⊔-assoc zero    _       _       = refl
⊔-assoc (suc m) zero    o       = refl
⊔-assoc (suc m) (suc n) zero    = refl
⊔-assoc (suc m) (suc n) (suc o) = cong suc $ ⊔-assoc m n o

⊔-identityˡ : LeftIdentity 0 _⊔_
⊔-identityˡ _ = refl

⊔-identityʳ : RightIdentity 0 _⊔_
⊔-identityʳ zero    = refl
⊔-identityʳ (suc n) = refl

⊔-identity : Identity 0 _⊔_
⊔-identity = ⊔-identityˡ , ⊔-identityʳ

⊔-comm : Commutative _⊔_
⊔-comm zero    n       = sym $ ⊔-identityʳ n
⊔-comm (suc m) zero    = refl
⊔-comm (suc m) (suc n) = cong suc (⊔-comm m n)

⊔-sel : Selective _⊔_
⊔-sel zero    _    = inj₂ refl
⊔-sel (suc m) zero = inj₁ refl
⊔-sel (suc m) (suc n) with ⊔-sel m n
... | inj₁ m⊔n≡m = inj₁ (cong suc m⊔n≡m)
... | inj₂ m⊔n≡n = inj₂ (cong suc m⊔n≡n)

⊔-idem : Idempotent _⊔_
⊔-idem = sel⇒idem ⊔-sel

⊓-assoc : Associative _⊓_
⊓-assoc zero    _       _       = refl
⊓-assoc (suc m) zero    o       = refl
⊓-assoc (suc m) (suc n) zero    = refl
⊓-assoc (suc m) (suc n) (suc o) = cong suc $ ⊓-assoc m n o

⊓-zeroˡ : LeftZero 0 _⊓_
⊓-zeroˡ _ = refl

⊓-zeroʳ : RightZero 0 _⊓_
⊓-zeroʳ zero    = refl
⊓-zeroʳ (suc n) = refl

⊓-zero : Zero 0 _⊓_
⊓-zero = ⊓-zeroˡ , ⊓-zeroʳ

⊓-comm : Commutative _⊓_
⊓-comm zero    n       = sym $ ⊓-zeroʳ n
⊓-comm (suc m) zero    = refl
⊓-comm (suc m) (suc n) = cong suc (⊓-comm m n)

⊓-sel : Selective _⊓_
⊓-sel zero    _    = inj₁ refl
⊓-sel (suc m) zero = inj₂ refl
⊓-sel (suc m) (suc n) with ⊓-sel m n
... | inj₁ m⊓n≡m = inj₁ (cong suc m⊓n≡m)
... | inj₂ m⊓n≡n = inj₂ (cong suc m⊓n≡n)

⊓-idem : Idempotent _⊓_
⊓-idem = sel⇒idem ⊓-sel

⊓-distribʳ-⊔ : _⊓_ DistributesOverʳ _⊔_
⊓-distribʳ-⊔ (suc m) (suc n) (suc o) = cong suc $ ⊓-distribʳ-⊔ m n o
⊓-distribʳ-⊔ (suc m) (suc n) zero    = cong suc $ refl
⊓-distribʳ-⊔ (suc m) zero    o       = refl
⊓-distribʳ-⊔ zero    n       o       = begin
  (n ⊔ o) ⊓ 0    ≡⟨ ⊓-comm (n ⊔ o) 0 ⟩
  0 ⊓ (n ⊔ o)    ≡⟨⟩
  0 ⊓ n ⊔ 0 ⊓ o  ≡⟨ ⊓-comm 0 n ⟨ cong₂ _⊔_ ⟩ ⊓-comm 0 o ⟩
  n ⊓ 0 ⊔ o ⊓ 0  ∎

⊓-distribˡ-⊔ : _⊓_ DistributesOverˡ _⊔_
⊓-distribˡ-⊔ = comm+distrʳ⇒distrˡ ⊓-comm ⊓-distribʳ-⊔

⊓-distrib-⊔ : _⊓_ DistributesOver _⊔_
⊓-distrib-⊔ = ⊓-distribˡ-⊔ , ⊓-distribʳ-⊔

⊔-abs-⊓ : _⊔_ Absorbs _⊓_
⊔-abs-⊓ zero    n       = refl
⊔-abs-⊓ (suc m) zero    = refl
⊔-abs-⊓ (suc m) (suc n) = cong suc $ ⊔-abs-⊓ m n

⊓-abs-⊔ : _⊓_ Absorbs _⊔_
⊓-abs-⊔ zero    n       = refl
⊓-abs-⊔ (suc m) (suc n) = cong suc $ ⊓-abs-⊔ m n
⊓-abs-⊔ (suc m) zero    = cong suc $ begin
  m ⊓ m       ≡⟨ cong (m ⊓_) $ sym $ ⊔-identityʳ m ⟩
  m ⊓ (m ⊔ 0) ≡⟨ ⊓-abs-⊔ m zero ⟩
  m           ∎

⊓-⊔-absorptive : Absorptive _⊓_ _⊔_
⊓-⊔-absorptive = ⊓-abs-⊔ , ⊔-abs-⊓

⊔-isMagma : IsMagma _⊔_
⊔-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _⊔_
  }

⊔-magma : Magma 0ℓ 0ℓ
⊔-magma = record
  { isMagma = ⊔-isMagma
  }

⊔-isSemigroup : IsSemigroup _⊔_
⊔-isSemigroup = record
  { isMagma = ⊔-isMagma
  ; assoc   = ⊔-assoc
  }

⊔-semigroup : Semigroup 0ℓ 0ℓ
⊔-semigroup = record
  { isSemigroup = ⊔-isSemigroup
  }

⊔-isBand : IsBand _⊔_
⊔-isBand = record
  { isSemigroup = ⊔-isSemigroup
  ; idem        = ⊔-idem
  }

⊔-band : Band 0ℓ 0ℓ
⊔-band = record
  { isBand = ⊔-isBand
  }

⊔-isSemilattice : IsSemilattice _⊔_
⊔-isSemilattice = record
  { isBand = ⊔-isBand
  ; comm   = ⊔-comm
  }

⊔-semilattice : Semilattice 0ℓ 0ℓ
⊔-semilattice = record
  { isSemilattice = ⊔-isSemilattice
  }

⊔-0-isCommutativeMonoid : IsCommutativeMonoid _⊔_ 0
⊔-0-isCommutativeMonoid = record
  { isSemigroup = ⊔-isSemigroup
  ; identityˡ   = ⊔-identityˡ
  ; comm        = ⊔-comm
  }

⊔-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
⊔-0-commutativeMonoid = record
  { isCommutativeMonoid = ⊔-0-isCommutativeMonoid
  }

⊓-isMagma : IsMagma _⊓_
⊓-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _⊓_
  }

⊓-magma : Magma 0ℓ 0ℓ
⊓-magma = record
  { isMagma = ⊓-isMagma
  }

⊓-isSemigroup : IsSemigroup _⊓_
⊓-isSemigroup = record
  { isMagma = ⊓-isMagma
  ; assoc   = ⊓-assoc
  }

⊓-semigroup : Semigroup 0ℓ 0ℓ
⊓-semigroup = record
  { isSemigroup = ⊔-isSemigroup
  }

⊓-isBand : IsBand _⊓_
⊓-isBand = record
  { isSemigroup = ⊓-isSemigroup
  ; idem        = ⊓-idem
  }

⊓-band : Band 0ℓ 0ℓ
⊓-band = record
  { isBand = ⊓-isBand
  }

⊓-isSemilattice : IsSemilattice _⊓_
⊓-isSemilattice = record
  { isBand = ⊓-isBand
  ; comm   = ⊓-comm
  }

⊓-semilattice : Semilattice 0ℓ 0ℓ
⊓-semilattice = record
  { isSemilattice = ⊓-isSemilattice
  }

⊔-⊓-isSemiringWithoutOne : IsSemiringWithoutOne _⊔_ _⊓_ 0
⊔-⊓-isSemiringWithoutOne = record
  { +-isCommutativeMonoid = ⊔-0-isCommutativeMonoid
  ; *-isSemigroup         = ⊓-isSemigroup
  ; distrib               = ⊓-distrib-⊔
  ; zero                  = ⊓-zero
  }

⊔-⊓-isCommutativeSemiringWithoutOne
  : IsCommutativeSemiringWithoutOne _⊔_ _⊓_ 0
⊔-⊓-isCommutativeSemiringWithoutOne = record
  { isSemiringWithoutOne = ⊔-⊓-isSemiringWithoutOne
  ; *-comm               = ⊓-comm
  }

⊔-⊓-commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne 0ℓ 0ℓ
⊔-⊓-commutativeSemiringWithoutOne = record
  { isCommutativeSemiringWithoutOne =
      ⊔-⊓-isCommutativeSemiringWithoutOne
  }

⊓-⊔-isLattice : IsLattice _⊓_ _⊔_
⊓-⊔-isLattice = record
  { isEquivalence = isEquivalence
  ; ∨-comm        = ⊓-comm
  ; ∨-assoc       = ⊓-assoc
  ; ∨-cong        = cong₂ _⊓_
  ; ∧-comm        = ⊔-comm
  ; ∧-assoc       = ⊔-assoc
  ; ∧-cong        = cong₂ _⊔_
  ; absorptive    = ⊓-⊔-absorptive
  }

⊓-⊔-lattice : Lattice 0ℓ 0ℓ
⊓-⊔-lattice = record
  { isLattice = ⊓-⊔-isLattice
  }

⊓-⊔-isDistributiveLattice : IsDistributiveLattice _⊓_ _⊔_
⊓-⊔-isDistributiveLattice = record
  { isLattice   = ⊓-⊔-isLattice
  ; ∨-∧-distribʳ = ⊓-distribʳ-⊔
  }

⊓-⊔-distributiveLattice : DistributiveLattice 0ℓ 0ℓ
⊓-⊔-distributiveLattice = record
  { isDistributiveLattice = ⊓-⊔-isDistributiveLattice
  }

-- Ordering properties of _⊔_ and _⊓_
m⊓n≤m : ∀ m n → m ⊓ n ≤ m
m⊓n≤m zero    _       = z≤n
m⊓n≤m (suc m) zero    = z≤n
m⊓n≤m (suc m) (suc n) = s≤s $ m⊓n≤m m n

m⊓n≤n : ∀ m n → m ⊓ n ≤ n
m⊓n≤n m n = subst (_≤ n) (⊓-comm n m) (m⊓n≤m n m)

m≤m⊔n : ∀ m n → m ≤ m ⊔ n
m≤m⊔n zero    _       = z≤n
m≤m⊔n (suc m) zero    = ≤-refl
m≤m⊔n (suc m) (suc n) = s≤s $ m≤m⊔n m n

n≤m⊔n : ∀ m n → n ≤ m ⊔ n
n≤m⊔n m n = subst (n ≤_) (⊔-comm n m) (m≤m⊔n n m)

m≤n⇒m⊓n≡m : ∀ {m n} → m ≤ n → m ⊓ n ≡ m
m≤n⇒m⊓n≡m z≤n       = refl
m≤n⇒m⊓n≡m (s≤s m≤n) = cong suc (m≤n⇒m⊓n≡m m≤n)

m≤n⇒n⊓m≡m : ∀ {m n} → m ≤ n → n ⊓ m ≡ m
m≤n⇒n⊓m≡m {m} m≤n = trans (⊓-comm _ m) (m≤n⇒m⊓n≡m m≤n)

m⊓n≡m⇒m≤n : ∀ {m n} → m ⊓ n ≡ m → m ≤ n
m⊓n≡m⇒m≤n m⊓n≡m = subst (_≤ _) m⊓n≡m (m⊓n≤n _ _)

m⊓n≡n⇒n≤m : ∀ {m n} → m ⊓ n ≡ n → n ≤ m
m⊓n≡n⇒n≤m m⊓n≡n = subst (_≤ _) m⊓n≡n (m⊓n≤m _ _)

m≤n⇒n⊔m≡n : ∀ {m n} → m ≤ n → n ⊔ m ≡ n
m≤n⇒n⊔m≡n z≤n       = ⊔-identityʳ _
m≤n⇒n⊔m≡n (s≤s m≤n) = cong suc (m≤n⇒n⊔m≡n m≤n)

m≤n⇒m⊔n≡n : ∀ {m n} → m ≤ n → m ⊔ n ≡ n
m≤n⇒m⊔n≡n {m} m≤n = trans (⊔-comm m _) (m≤n⇒n⊔m≡n m≤n)

n⊔m≡m⇒n≤m : ∀ {m n} → n ⊔ m ≡ m → n ≤ m
n⊔m≡m⇒n≤m n⊔m≡m = subst (_ ≤_) n⊔m≡m (m≤m⊔n _ _)

n⊔m≡n⇒m≤n : ∀ {m n} → n ⊔ m ≡ n → m ≤ n
n⊔m≡n⇒m≤n n⊔m≡n = subst (_ ≤_) n⊔m≡n (n≤m⊔n _ _)

m⊓n≤m⊔n : ∀ m n → m ⊓ n ≤ m ⊔ n
m⊓n≤m⊔n zero    n       = z≤n
m⊓n≤m⊔n (suc m) zero    = z≤n
m⊓n≤m⊔n (suc m) (suc n) = s≤s (m⊓n≤m⊔n m n)

m≤n⇒m⊓o≤n : ∀ {m n} o → m ≤ n → m ⊓ o ≤ n
m≤n⇒m⊓o≤n o m≤n = ≤-trans (m⊓n≤m _ o) m≤n

m≤n⇒o⊓m≤n : ∀ {m n} o → m ≤ n → o ⊓ m ≤ n
m≤n⇒o⊓m≤n n m≤n = ≤-trans (m⊓n≤n n _) m≤n

m≤n⊓o⇒m≤n : ∀ {m} n o → m ≤ n ⊓ o → m ≤ n
m≤n⊓o⇒m≤n n o m≤n⊓o = ≤-trans m≤n⊓o (m⊓n≤m n o)

m≤n⊓o⇒m≤o : ∀ {m} n o → m ≤ n ⊓ o → m ≤ o
m≤n⊓o⇒m≤o n o m≤n⊓o = ≤-trans m≤n⊓o (m⊓n≤n n o)

m≤n⇒m≤n⊔o : ∀ {m n} o → m ≤ n → m ≤ n ⊔ o
m≤n⇒m≤n⊔o o m≤n = ≤-trans m≤n (m≤m⊔n _ o)

m≤n⇒m≤o⊔n : ∀ {m n} o → m ≤ n → m ≤ o ⊔ n
m≤n⇒m≤o⊔n n m≤n = ≤-trans m≤n (n≤m⊔n n _)

m⊔n≤o⇒m≤o : ∀ m n {o} → m ⊔ n ≤ o → m ≤ o
m⊔n≤o⇒m≤o m n m⊔n≤o = ≤-trans (m≤m⊔n m n) m⊔n≤o

m⊔n≤o⇒n≤o : ∀ m n {o} → m ⊔ n ≤ o → n ≤ o
m⊔n≤o⇒n≤o m n m⊔n≤o = ≤-trans (n≤m⊔n m n) m⊔n≤o

m<n⇒m⊓o<n : ∀ {m n} o → m < n → m ⊓ o < n
m<n⇒m⊓o<n o m<n = <-transʳ (m⊓n≤m _ o) m<n

m<n⇒o⊓m<n : ∀ {m n} o → m < n → o ⊓ m < n
m<n⇒o⊓m<n o m<n = <-transʳ (m⊓n≤n o _) m<n

m<n⊓o⇒m<n : ∀ {m} n o → m < n ⊓ o → m < n
m<n⊓o⇒m<n = m≤n⊓o⇒m≤n

m<n⊓o⇒m<o : ∀ {m} n o → m < n ⊓ o → m < o
m<n⊓o⇒m<o = m≤n⊓o⇒m≤o

m<n⇒m<n⊔o : ∀ {m n} o → m < n → m < n ⊔ o
m<n⇒m<n⊔o = m≤n⇒m≤n⊔o

m<n⇒m<o⊔n : ∀ {m n} o → m < n → m < o ⊔ n
m<n⇒m<o⊔n = m≤n⇒m≤o⊔n

m⊔n<o⇒m<o : ∀ m n {o} → m ⊔ n < o → m < o
m⊔n<o⇒m<o m n m⊔n<o = <-transʳ (m≤m⊔n m n) m⊔n<o

m⊔n<o⇒n<o : ∀ m n {o} → m ⊔ n < o → n < o
m⊔n<o⇒n<o m n m⊔n<o = <-transʳ (n≤m⊔n m n) m⊔n<o

⊔-mono-≤ : _⊔_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
⊔-mono-≤ {x} {y} {u} {v} x≤y u≤v with ⊔-sel x u
... | inj₁ x⊔u≡x rewrite x⊔u≡x = ≤-trans x≤y (m≤m⊔n y v)
... | inj₂ x⊔u≡u rewrite x⊔u≡u = ≤-trans u≤v (n≤m⊔n y v)

⊔-monoˡ-≤ : ∀ n → (_⊔ n) Preserves _≤_ ⟶ _≤_
⊔-monoˡ-≤ n m≤o = ⊔-mono-≤ m≤o (≤-refl {n})

⊔-monoʳ-≤ : ∀ n → (n ⊔_) Preserves _≤_ ⟶ _≤_
⊔-monoʳ-≤ n m≤o = ⊔-mono-≤ (≤-refl {n}) m≤o

⊔-mono-< : _⊔_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
⊔-mono-< = ⊔-mono-≤

⊓-mono-≤ : _⊓_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
⊓-mono-≤ {x} {y} {u} {v} x≤y u≤v with ⊓-sel y v
... | inj₁ y⊓v≡y rewrite y⊓v≡y = ≤-trans (m⊓n≤m x u) x≤y
... | inj₂ y⊓v≡v rewrite y⊓v≡v = ≤-trans (m⊓n≤n x u) u≤v

⊓-monoˡ-≤ : ∀ n → (_⊓ n) Preserves _≤_ ⟶ _≤_
⊓-monoˡ-≤ n m≤o = ⊓-mono-≤ m≤o (≤-refl {n})

⊓-monoʳ-≤ : ∀ n → (n ⊓_) Preserves _≤_ ⟶ _≤_
⊓-monoʳ-≤ n m≤o = ⊓-mono-≤ (≤-refl {n}) m≤o

⊓-mono-< : _⊓_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
⊓-mono-< = ⊓-mono-≤

-- Properties of _⊔_ and _⊓_ and _+_
m⊔n≤m+n : ∀ m n → m ⊔ n ≤ m + n
m⊔n≤m+n m n with ⊔-sel m n
... | inj₁ m⊔n≡m rewrite m⊔n≡m = m≤m+n m n
... | inj₂ m⊔n≡n rewrite m⊔n≡n = n≤m+n m n

m⊓n≤m+n : ∀ m n → m ⊓ n ≤ m + n
m⊓n≤m+n m n with ⊓-sel m n
... | inj₁ m⊓n≡m rewrite m⊓n≡m = m≤m+n m n
... | inj₂ m⊓n≡n rewrite m⊓n≡n = n≤m+n m n

+-distribˡ-⊔ : _+_ DistributesOverˡ _⊔_
+-distribˡ-⊔ zero    y z = refl
+-distribˡ-⊔ (suc x) y z = cong suc (+-distribˡ-⊔ x y z)

+-distribʳ-⊔ : _+_ DistributesOverʳ _⊔_
+-distribʳ-⊔ = comm+distrˡ⇒distrʳ +-comm +-distribˡ-⊔

+-distrib-⊔ : _+_ DistributesOver _⊔_
+-distrib-⊔ = +-distribˡ-⊔ , +-distribʳ-⊔

+-distribˡ-⊓ : _+_ DistributesOverˡ _⊓_
+-distribˡ-⊓ zero    y z = refl
+-distribˡ-⊓ (suc x) y z = cong suc (+-distribˡ-⊓ x y z)

+-distribʳ-⊓ : _+_ DistributesOverʳ _⊓_
+-distribʳ-⊓ = comm+distrˡ⇒distrʳ +-comm +-distribˡ-⊓

+-distrib-⊓ : _+_ DistributesOver _⊓_
+-distrib-⊓ = +-distribˡ-⊓ , +-distribʳ-⊓

-- Other properties
⊓-triangulate : ∀ x y z → x ⊓ y ⊓ z ≡ (x ⊓ y) ⊓ (y ⊓ z)
⊓-triangulate x y z = begin
  x ⊓ y ⊓ z           ≡⟨ cong (λ v → x ⊓ v ⊓ z) (sym (⊓-idem y)) ⟩
  x ⊓ (y ⊓ y) ⊓ z     ≡⟨ ⊓-assoc x _ _ ⟩
  x ⊓ ((y ⊓ y) ⊓ z)   ≡⟨ cong (x ⊓_) (⊓-assoc y _ _) ⟩
  x ⊓ (y ⊓ (y ⊓ z))   ≡⟨ sym (⊓-assoc x _ _) ⟩
  (x ⊓ y) ⊓ (y ⊓ z)   ∎

⊔-triangulate : ∀ x y z → x ⊔ y ⊔ z ≡ (x ⊔ y) ⊔ (y ⊔ z)
⊔-triangulate x y z = begin
  x ⊔ y ⊔ z           ≡⟨ cong (λ v → x ⊔ v ⊔ z) (sym (⊔-idem y)) ⟩
  x ⊔ (y ⊔ y) ⊔ z     ≡⟨ ⊔-assoc x _ _ ⟩
  x ⊔ ((y ⊔ y) ⊔ z)   ≡⟨ cong (x ⊔_) (⊔-assoc y _ _) ⟩
  x ⊔ (y ⊔ (y ⊔ z))   ≡⟨ sym (⊔-assoc x _ _) ⟩
  (x ⊔ y) ⊔ (y ⊔ z)   ∎

------------------------------------------------------------------------
-- Properties of _∸_

0∸n≡0 : LeftZero zero _∸_
0∸n≡0 zero    = refl
0∸n≡0 (suc _) = refl

n∸n≡0 : ∀ n → n ∸ n ≡ 0
n∸n≡0 zero    = refl
n∸n≡0 (suc n) = n∸n≡0 n

-- Ordering properties of _∸_
n∸m≤n : ∀ m n → n ∸ m ≤ n
n∸m≤n zero    n       = ≤-refl
n∸m≤n (suc m) zero    = ≤-refl
n∸m≤n (suc m) (suc n) = ≤-trans (n∸m≤n m n) (n≤1+n n)

m≮m∸n : ∀ m n → m ≮ m ∸ n
m≮m∸n zero    (suc n) ()
m≮m∸n m       zero    = n≮n m
m≮m∸n (suc m) (suc n) = m≮m∸n m n ∘ ≤-trans (n≤1+n (suc m))

∸-mono : _∸_ Preserves₂ _≤_ ⟶ _≥_ ⟶ _≤_
∸-mono z≤n         (s≤s n₁≥n₂)    = z≤n
∸-mono (s≤s m₁≤m₂) (s≤s n₁≥n₂)    = ∸-mono m₁≤m₂ n₁≥n₂
∸-mono m₁≤m₂       (z≤n {n = n₁}) = ≤-trans (n∸m≤n n₁ _) m₁≤m₂

∸-monoˡ-≤ : ∀ {m n} o → m ≤ n → m ∸ o ≤ n ∸ o
∸-monoˡ-≤ o m≤n = ∸-mono {u = o} m≤n ≤-refl

∸-monoʳ-≤ : ∀ {m n} o → m ≤ n → o ∸ m ≥ o ∸ n
∸-monoʳ-≤ _ m≤n = ∸-mono ≤-refl m≤n

m∸n≡0⇒m≤n : ∀ {m n} → m ∸ n ≡ 0 → m ≤ n
m∸n≡0⇒m≤n {zero}  {_}    _   = z≤n
m∸n≡0⇒m≤n {suc m} {zero} ()
m∸n≡0⇒m≤n {suc m} {suc n} eq = s≤s (m∸n≡0⇒m≤n eq)

m≤n⇒m∸n≡0 : ∀ {m n} → m ≤ n → m ∸ n ≡ 0
m≤n⇒m∸n≡0 {n = n} z≤n      = 0∸n≡0 n
m≤n⇒m∸n≡0 {_}    (s≤s m≤n) = m≤n⇒m∸n≡0 m≤n

-- Properties of _∸_ and _+_
+-∸-comm : ∀ {m} n {o} → o ≤ m → (m + n) ∸ o ≡ (m ∸ o) + n
+-∸-comm {zero}  _ {suc o} ()
+-∸-comm {zero}  _ {zero}  _         = refl
+-∸-comm {suc m} _ {zero}  _         = refl
+-∸-comm {suc m} n {suc o} (s≤s o≤m) = +-∸-comm n o≤m

∸-+-assoc : ∀ m n o → (m ∸ n) ∸ o ≡ m ∸ (n + o)
∸-+-assoc m       n       zero    = cong (m ∸_) (sym $ +-identityʳ n)
∸-+-assoc zero    zero    (suc o) = refl
∸-+-assoc zero    (suc n) (suc o) = refl
∸-+-assoc (suc m) zero    (suc o) = refl
∸-+-assoc (suc m) (suc n) (suc o) = ∸-+-assoc m n (suc o)

+-∸-assoc : ∀ m {n o} → o ≤ n → (m + n) ∸ o ≡ m + (n ∸ o)
+-∸-assoc m (z≤n {n = n})             = begin m + n ∎
+-∸-assoc m (s≤s {m = o} {n = n} o≤n) = begin
  (m + suc n) ∸ suc o  ≡⟨ cong (_∸ suc o) (+-suc m n) ⟩
  suc (m + n) ∸ suc o  ≡⟨⟩
  (m + n) ∸ o          ≡⟨ +-∸-assoc m o≤n ⟩
  m + (n ∸ o)          ∎

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

m+n∸n≡m : ∀ m n → (m + n) ∸ n ≡ m
m+n∸n≡m m n = begin
  (m + n) ∸ n  ≡⟨ +-∸-assoc m (≤-refl {x = n}) ⟩
  m + (n ∸ n)  ≡⟨ cong (m +_) (n∸n≡0 n) ⟩
  m + 0        ≡⟨ +-identityʳ m ⟩
  m            ∎

m+n∸m≡n : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
m+n∸m≡n {m} {n} m≤n = begin
  m + (n ∸ m)  ≡⟨ sym $ +-∸-assoc m m≤n ⟩
  (m + n) ∸ m  ≡⟨ cong (_∸ m) (+-comm m n) ⟩
  (n + m) ∸ m  ≡⟨ m+n∸n≡m n m ⟩
  n            ∎

m∸n+n≡m : ∀ {m n} → n ≤ m → (m ∸ n) + n ≡ m
m∸n+n≡m {m} {n} n≤m = begin
  (m ∸ n) + n ≡⟨ sym (+-∸-comm n n≤m) ⟩
  (m + n) ∸ n ≡⟨ m+n∸n≡m m n ⟩
  m           ∎

m∸[m∸n]≡n : ∀ {m n} → n ≤ m → m ∸ (m ∸ n) ≡ n
m∸[m∸n]≡n {m}     {_}     z≤n       = n∸n≡0 m
m∸[m∸n]≡n {suc m} {suc n} (s≤s n≤m) = begin
  suc m ∸ (m ∸ n)   ≡⟨ +-∸-assoc 1 (n∸m≤n n m) ⟩
  suc (m ∸ (m ∸ n)) ≡⟨ cong suc (m∸[m∸n]≡n n≤m) ⟩
  suc n             ∎

[i+j]∸[i+k]≡j∸k : ∀ i j k → (i + j) ∸ (i + k) ≡ j ∸ k
[i+j]∸[i+k]≡j∸k zero    j k = refl
[i+j]∸[i+k]≡j∸k (suc i) j k = [i+j]∸[i+k]≡j∸k i j k

-- Properties of _∸_ and _*_
*-distribʳ-∸ : _*_ DistributesOverʳ _∸_
*-distribʳ-∸ i       zero    zero    = refl
*-distribʳ-∸ zero    zero    (suc k) = sym (0∸n≡0 (k * zero))
*-distribʳ-∸ (suc i) zero    (suc k) = refl
*-distribʳ-∸ i       (suc j) zero    = refl
*-distribʳ-∸ i       (suc j) (suc k) = begin
  (j ∸ k) * i             ≡⟨ *-distribʳ-∸ i j k ⟩
  j * i ∸ k * i           ≡⟨ sym $ [i+j]∸[i+k]≡j∸k i _ _ ⟩
  i + j * i ∸ (i + k * i) ∎

*-distribˡ-∸ : _*_ DistributesOverˡ _∸_
*-distribˡ-∸ = comm+distrʳ⇒distrˡ *-comm *-distribʳ-∸

*-distrib-∸ : _*_ DistributesOver _∸_
*-distrib-∸ = *-distribˡ-∸ , *-distribʳ-∸

-- Properties of _∸_ and _⊓_ and _⊔_
m⊓n+n∸m≡n : ∀ m n → (m ⊓ n) + (n ∸ m) ≡ n
m⊓n+n∸m≡n zero    n       = refl
m⊓n+n∸m≡n (suc m) zero    = refl
m⊓n+n∸m≡n (suc m) (suc n) = cong suc $ m⊓n+n∸m≡n m n

[m∸n]⊓[n∸m]≡0 : ∀ m n → (m ∸ n) ⊓ (n ∸ m) ≡ 0
[m∸n]⊓[n∸m]≡0 zero zero       = refl
[m∸n]⊓[n∸m]≡0 zero (suc n)    = refl
[m∸n]⊓[n∸m]≡0 (suc m) zero    = refl
[m∸n]⊓[n∸m]≡0 (suc m) (suc n) = [m∸n]⊓[n∸m]≡0 m n

∸-distribˡ-⊓-⊔ : ∀ x y z → x ∸ (y ⊓ z) ≡ (x ∸ y) ⊔ (x ∸ z)
∸-distribˡ-⊓-⊔ x       zero    zero    = sym (⊔-idem x)
∸-distribˡ-⊓-⊔ zero    zero    (suc z) = refl
∸-distribˡ-⊓-⊔ zero    (suc y) zero    = refl
∸-distribˡ-⊓-⊔ zero    (suc y) (suc z) = refl
∸-distribˡ-⊓-⊔ (suc x) (suc y) zero    = sym (m≤n⇒m⊔n≡n (≤-step (n∸m≤n y x)))
∸-distribˡ-⊓-⊔ (suc x) zero    (suc z) = sym (m≤n⇒n⊔m≡n (≤-step (n∸m≤n z x)))
∸-distribˡ-⊓-⊔ (suc x) (suc y) (suc z) = ∸-distribˡ-⊓-⊔ x y z

∸-distribʳ-⊓ : _∸_ DistributesOverʳ _⊓_
∸-distribʳ-⊓ zero    y       z       = refl
∸-distribʳ-⊓ (suc x) zero    z       = refl
∸-distribʳ-⊓ (suc x) (suc y) zero    = sym (⊓-zeroʳ (y ∸ x))
∸-distribʳ-⊓ (suc x) (suc y) (suc z) = ∸-distribʳ-⊓ x y z

∸-distribˡ-⊔-⊓ : ∀ x y z → x ∸ (y ⊔ z) ≡ (x ∸ y) ⊓ (x ∸ z)
∸-distribˡ-⊔-⊓ x       zero    zero    = sym (⊓-idem x)
∸-distribˡ-⊔-⊓ zero    zero    z       = 0∸n≡0 z
∸-distribˡ-⊔-⊓ zero    (suc y) z       = 0∸n≡0 (suc y ⊔ z)
∸-distribˡ-⊔-⊓ (suc x) (suc y) zero    = sym (m≤n⇒m⊓n≡m (≤-step (n∸m≤n y x)))
∸-distribˡ-⊔-⊓ (suc x) zero    (suc z) = sym (m≤n⇒n⊓m≡m (≤-step (n∸m≤n z x)))
∸-distribˡ-⊔-⊓ (suc x) (suc y) (suc z) = ∸-distribˡ-⊔-⊓ x y z

∸-distribʳ-⊔ : _∸_ DistributesOverʳ _⊔_
∸-distribʳ-⊔ zero    y       z       = refl
∸-distribʳ-⊔ (suc x) zero    z       = refl
∸-distribʳ-⊔ (suc x) (suc y) zero    = sym (⊔-identityʳ (y ∸ x))
∸-distribʳ-⊔ (suc x) (suc y) (suc z) = ∸-distribʳ-⊔ x y z

------------------------------------------------------------------------
-- Properties of ∣_-_∣

n≡m⇒∣n-m∣≡0 : ∀ {n m} → n ≡ m → ∣ n - m ∣ ≡ 0
n≡m⇒∣n-m∣≡0 {zero}  refl = refl
n≡m⇒∣n-m∣≡0 {suc n} refl = n≡m⇒∣n-m∣≡0 {n} refl

m≤n⇒∣n-m∣≡n∸m : ∀ {n m} → m ≤ n → ∣ n - m ∣ ≡ n ∸ m
m≤n⇒∣n-m∣≡n∸m {zero}  z≤n       = refl
m≤n⇒∣n-m∣≡n∸m {suc n} z≤n       = refl
m≤n⇒∣n-m∣≡n∸m         (s≤s m≤n) = m≤n⇒∣n-m∣≡n∸m m≤n

∣n-m∣≡0⇒n≡m : ∀ {n m} → ∣ n - m ∣ ≡ 0 → n ≡ m
∣n-m∣≡0⇒n≡m {zero}  {zero}  eq = refl
∣n-m∣≡0⇒n≡m {zero}  {suc m} ()
∣n-m∣≡0⇒n≡m {suc n} {zero}  ()
∣n-m∣≡0⇒n≡m {suc n} {suc m} eq = cong suc (∣n-m∣≡0⇒n≡m eq)

∣n-m∣≡n∸m⇒m≤n : ∀ {n m} → ∣ n - m ∣ ≡ n ∸ m → m ≤ n
∣n-m∣≡n∸m⇒m≤n {zero}  {zero}  eq = z≤n
∣n-m∣≡n∸m⇒m≤n {zero}  {suc m} ()
∣n-m∣≡n∸m⇒m≤n {suc n} {zero}  eq = z≤n
∣n-m∣≡n∸m⇒m≤n {suc n} {suc m} eq = s≤s (∣n-m∣≡n∸m⇒m≤n eq)

∣n-n∣≡0 : ∀ n → ∣ n - n ∣ ≡ 0
∣n-n∣≡0 n = n≡m⇒∣n-m∣≡0 {n} refl

∣n-n+m∣≡m : ∀ n m → ∣ n - n + m ∣ ≡ m
∣n-n+m∣≡m zero    m = refl
∣n-n+m∣≡m (suc n) m = ∣n-n+m∣≡m n m

∣n+m-n+o∣≡∣m-o| : ∀ n m o → ∣ n + m - n + o ∣ ≡ ∣ m - o ∣
∣n+m-n+o∣≡∣m-o| zero    m o = refl
∣n+m-n+o∣≡∣m-o| (suc n) m o = ∣n+m-n+o∣≡∣m-o| n m o

n∸m≤∣n-m∣ : ∀ n m → n ∸ m ≤ ∣ n - m ∣
n∸m≤∣n-m∣ n m with ≤-total m n
... | inj₁ m≤n = subst (n ∸ m ≤_) (sym (m≤n⇒∣n-m∣≡n∸m m≤n)) ≤-refl
... | inj₂ n≤m = subst (_≤ ∣ n - m ∣) (sym (m≤n⇒m∸n≡0 n≤m)) z≤n

∣n-m∣≤n⊔m : ∀ n m → ∣ n - m ∣ ≤ n ⊔ m
∣n-m∣≤n⊔m zero    m       = ≤-refl
∣n-m∣≤n⊔m (suc n) zero    = ≤-refl
∣n-m∣≤n⊔m (suc n) (suc m) = ≤-step (∣n-m∣≤n⊔m n m)

∣-∣-comm : Commutative ∣_-_∣
∣-∣-comm zero    zero    = refl
∣-∣-comm zero    (suc m) = refl
∣-∣-comm (suc n) zero    = refl
∣-∣-comm (suc n) (suc m) = ∣-∣-comm n m

∣n-m∣≡[n∸m]∨[m∸n] : ∀ m n → (∣ n - m ∣ ≡ n ∸ m) ⊎ (∣ n - m ∣ ≡ m ∸ n)
∣n-m∣≡[n∸m]∨[m∸n] m n with ≤-total m n
... | inj₁ m≤n = inj₁ $ m≤n⇒∣n-m∣≡n∸m m≤n
... | inj₂ n≤m = inj₂ $ begin
  ∣ n - m ∣ ≡⟨ ∣-∣-comm n m ⟩
  ∣ m - n ∣ ≡⟨ m≤n⇒∣n-m∣≡n∸m n≤m ⟩
  m ∸ n     ∎

private

  *-distribˡ-∣-∣-aux : ∀ a m n → m ≤ n → a * ∣ n - m ∣ ≡ ∣ a * n - a * m ∣
  *-distribˡ-∣-∣-aux a m n m≤n = begin
    a * ∣ n - m ∣     ≡⟨ cong (a *_) (m≤n⇒∣n-m∣≡n∸m m≤n) ⟩
    a * (n ∸ m)       ≡⟨ *-distribˡ-∸ a n m ⟩
    a * n ∸ a * m     ≡⟨ sym $′ m≤n⇒∣n-m∣≡n∸m (*-monoʳ-≤ a m≤n) ⟩
    ∣ a * n - a * m ∣ ∎

*-distribˡ-∣-∣ : _*_ DistributesOverˡ ∣_-_∣
*-distribˡ-∣-∣ a m n with ≤-total m n
... | inj₁ m≤n = begin
  a * ∣ m - n ∣     ≡⟨ cong (a *_) (∣-∣-comm m n) ⟩
  a * ∣ n - m ∣     ≡⟨ *-distribˡ-∣-∣-aux a m n m≤n ⟩
  ∣ a * n - a * m ∣ ≡⟨ ∣-∣-comm (a * n) (a * m) ⟩
  ∣ a * m - a * n ∣ ∎
... | inj₂ n≤m = *-distribˡ-∣-∣-aux a n m n≤m

*-distribʳ-∣-∣ : _*_ DistributesOverʳ ∣_-_∣
*-distribʳ-∣-∣ = comm+distrˡ⇒distrʳ *-comm *-distribˡ-∣-∣

*-distrib-∣-∣ : _*_ DistributesOver ∣_-_∣
*-distrib-∣-∣ = *-distribˡ-∣-∣ , *-distribʳ-∣-∣

------------------------------------------------------------------------
-- Properties of ⌊_/2⌋

⌊n/2⌋-mono : ⌊_/2⌋ Preserves _≤_ ⟶ _≤_
⌊n/2⌋-mono z≤n             = z≤n
⌊n/2⌋-mono (s≤s z≤n)       = z≤n
⌊n/2⌋-mono (s≤s (s≤s m≤n)) = s≤s (⌊n/2⌋-mono m≤n)

⌈n/2⌉-mono : ⌈_/2⌉ Preserves _≤_ ⟶ _≤_
⌈n/2⌉-mono m≤n = ⌊n/2⌋-mono (s≤s m≤n)

⌈n/2⌉≤′n : ∀ n → ⌈ n /2⌉ ≤′ n
⌈n/2⌉≤′n zero          = ≤′-refl
⌈n/2⌉≤′n (suc zero)    = ≤′-refl
⌈n/2⌉≤′n (suc (suc n)) = s≤′s (≤′-step (⌈n/2⌉≤′n n))

⌊n/2⌋≤′n : ∀ n → ⌊ n /2⌋ ≤′ n
⌊n/2⌋≤′n zero    = ≤′-refl
⌊n/2⌋≤′n (suc n) = ≤′-step (⌈n/2⌉≤′n n)

------------------------------------------------------------------------
-- Properties of _<″_, and _≤″_

-- equivalence to _<ᵇ_

m<ᵇn⇒1+m+[n-1+m]≡n : ∀ m n → T (m <ᵇ n) → suc m + (n ∸ suc m) ≡ n
m<ᵇn⇒1+m+[n-1+m]≡n m       zero    ()
m<ᵇn⇒1+m+[n-1+m]≡n zero    (suc n) lt = refl
m<ᵇn⇒1+m+[n-1+m]≡n (suc m) (suc n) lt = cong suc (m<ᵇn⇒1+m+[n-1+m]≡n m n lt)

<ᵇ⇒<″ : ∀ {m n} → T (m <ᵇ n) → m <″ n
<ᵇ⇒<″ {m} {n} eq = less-than-or-equal {k = n ∸ suc m} (m<ᵇn⇒1+m+[n-1+m]≡n m n eq)

m<ᵇ1+m+n : ∀ m {n} → T (m <ᵇ suc (m + n))
m<ᵇ1+m+n zero    = _
m<ᵇ1+m+n (suc m) = m<ᵇ1+m+n m

<″⇒<ᵇ : ∀ {m n} → m <″ n → T (m <ᵇ n)
<″⇒<ᵇ {m} (less-than-or-equal refl) = m<ᵇ1+m+n m

-- equivalence to _≤_

≤″⇒≤ : _≤″_ ⇒ _≤_
≤″⇒≤ {zero}  (less-than-or-equal refl) = z≤n
≤″⇒≤ {suc m} (less-than-or-equal refl) =
  s≤s (≤″⇒≤ (less-than-or-equal refl))

≤⇒≤″ : _≤_ ⇒ _≤″_
≤⇒≤″ m≤n = less-than-or-equal (proof m≤n)
  where
  k : ∀ m n → m ≤ n → ℕ
  k zero    n       _   = n
  k (suc m) zero    ()
  k (suc m) (suc n) m≤n = k m n (≤-pred m≤n)

  proof : ∀ {m n} (m≤n : m ≤ n) → m + k m n m≤n ≡ n
  proof z≤n       = refl
  proof (s≤s m≤n) = cong suc (proof m≤n)

-- decidability

-- NB: we use the builtin function `_<ᵇ_ : (m n : ℕ) → Bool` here so
-- that the function quickly decides whether to return `yes` or `no`.
-- It sill takes a linear amount of time to generate the proof if it
-- is inspected. We expect the main benefit to be visible for compiled
-- code: the backend erases proofs.

infix 4 _<″?_ _≤″?_ _≥″?_ _>″?_

_<″?_ : Decidable _<″_
m <″? n = map′ <ᵇ⇒<″ <″⇒<ᵇ (T? (m <ᵇ n))

_≤″?_ : Decidable _≤″_
zero  ≤″? n = yes (less-than-or-equal refl)
suc m ≤″? n = m <″? n

_≥″?_ : Decidable _≥″_
_≥″?_ = flip _≤″?_

_>″?_ : Decidable _>″_
_>″?_ = flip _<″?_

-- irrelevance

≤″-irrelevant : Irrelevant _≤″_
≤″-irrelevant {m} (less-than-or-equal {k₁} eq₁)
                  (less-than-or-equal {k₂} eq₂)
  with +-cancelˡ-≡ m (trans eq₁ (sym eq₂))
... | refl = cong less-than-or-equal (≡-irrelevant eq₁ eq₂)

<″-irrelevant : Irrelevant _<″_
<″-irrelevant = ≤″-irrelevant

>″-irrelevant : Irrelevant _>″_
>″-irrelevant = ≤″-irrelevant

≥″-irrelevant : Irrelevant _≥″_
≥″-irrelevant = ≤″-irrelevant

------------------------------------------------------------------------
-- Other properties

-- If there is an injection from a type to ℕ, then the type has
-- decidable equality.

eq? : ∀ {a} {A : Set a} → A ↣ ℕ → Decidable {A = A} _≡_
eq? inj = via-injection inj _≟_

------------------------------------------------------------------------
-- A module for reasoning about the _≤_ and _<_ relations

module ≤-Reasoning where
  open import Relation.Binary.Reasoning.Base.Triple
    ≤-isPreorder
    <-trans
    (resp₂ _<_)
    <⇒≤
    <-transˡ
    <-transʳ
    public
    hiding (_≈⟨_⟩_)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.14

_*-mono_ = *-mono-≤
{-# WARNING_ON_USAGE _*-mono_
"Warning: _*-mono_ was deprecated in v0.14.
Please use *-mono-≤ instead."
#-}
_+-mono_ = +-mono-≤
{-# WARNING_ON_USAGE _+-mono_
"Warning: _+-mono_ was deprecated in v0.14.
Please use +-mono-≤ instead."
#-}
+-right-identity = +-identityʳ
{-# WARNING_ON_USAGE +-right-identity
"Warning: +-right-identity was deprecated in v0.14.
Please use +-identityʳ instead."
#-}
*-right-zero     = *-zeroʳ
{-# WARNING_ON_USAGE *-right-zero
"Warning: *-right-zero was deprecated in v0.14.
Please use *-zeroʳ instead."
#-}
distribʳ-*-+     = *-distribʳ-+
{-# WARNING_ON_USAGE distribʳ-*-+
"Warning: distribʳ-*-+ was deprecated in v0.14.
Please use *-distribʳ-+ instead."
#-}
*-distrib-∸ʳ     = *-distribʳ-∸
{-# WARNING_ON_USAGE *-distrib-∸ʳ
"Warning: *-distrib-∸ʳ was deprecated in v0.14.
Please use *-distribʳ-∸ instead."
#-}
cancel-+-left    = +-cancelˡ-≡
{-# WARNING_ON_USAGE cancel-+-left
"Warning: cancel-+-left was deprecated in v0.14.
Please use +-cancelˡ-≡ instead."
#-}
cancel-+-left-≤  = +-cancelˡ-≤
{-# WARNING_ON_USAGE cancel-+-left-≤
"Warning: cancel-+-left-≤ was deprecated in v0.14.
Please use +-cancelˡ-≤ instead."
#-}
cancel-*-right   = *-cancelʳ-≡
{-# WARNING_ON_USAGE cancel-*-right
"Warning: cancel-*-right was deprecated in v0.14.
Please use *-cancelʳ-≡ instead."
#-}
cancel-*-right-≤ = *-cancelʳ-≤
{-# WARNING_ON_USAGE cancel-*-right-≤
"Warning: cancel-*-right-≤ was deprecated in v0.14.
Please use *-cancelʳ-≤ instead."
#-}
strictTotalOrder                      = <-strictTotalOrder
{-# WARNING_ON_USAGE strictTotalOrder
"Warning: strictTotalOrder was deprecated in v0.14.
Please use <-strictTotalOrder instead."
#-}
isCommutativeSemiring                 = *-+-isCommutativeSemiring
{-# WARNING_ON_USAGE isCommutativeSemiring
"Warning: isCommutativeSemiring was deprecated in v0.14.
Please use *-+-isCommutativeSemiring instead."
#-}
commutativeSemiring                   = *-+-commutativeSemiring
{-# WARNING_ON_USAGE commutativeSemiring
"Warning: commutativeSemiring was deprecated in v0.14.
Please use *-+-commutativeSemiring instead."
#-}
isDistributiveLattice                 = ⊓-⊔-isDistributiveLattice
{-# WARNING_ON_USAGE isDistributiveLattice
"Warning: isDistributiveLattice was deprecated in v0.14.
Please use ⊓-⊔-isDistributiveLattice instead."
#-}
distributiveLattice                   = ⊓-⊔-distributiveLattice
{-# WARNING_ON_USAGE distributiveLattice
"Warning: distributiveLattice was deprecated in v0.14.
Please use ⊓-⊔-distributiveLattice instead."
#-}
⊔-⊓-0-isSemiringWithoutOne            = ⊔-⊓-isSemiringWithoutOne
{-# WARNING_ON_USAGE ⊔-⊓-0-isSemiringWithoutOne
"Warning: ⊔-⊓-0-isSemiringWithoutOne was deprecated in v0.14.
Please use ⊔-⊓-isSemiringWithoutOne instead."
#-}
⊔-⊓-0-isCommutativeSemiringWithoutOne = ⊔-⊓-isCommutativeSemiringWithoutOne
{-# WARNING_ON_USAGE ⊔-⊓-0-isCommutativeSemiringWithoutOne
"Warning: ⊔-⊓-0-isCommutativeSemiringWithoutOne was deprecated in v0.14.
Please use ⊔-⊓-isCommutativeSemiringWithoutOne instead."
#-}
⊔-⊓-0-commutativeSemiringWithoutOne   = ⊔-⊓-commutativeSemiringWithoutOne
{-# WARNING_ON_USAGE ⊔-⊓-0-commutativeSemiringWithoutOne
"Warning: ⊔-⊓-0-commutativeSemiringWithoutOne was deprecated in v0.14.
Please use ⊔-⊓-commutativeSemiringWithoutOne instead."
#-}

-- Version 0.15

¬i+1+j≤i  = i+1+j≰i
{-# WARNING_ON_USAGE ¬i+1+j≤i
"Warning: ¬i+1+j≤i was deprecated in v0.15.
Please use i+1+j≰i instead."
#-}
≤-steps   = ≤-stepsˡ
{-# WARNING_ON_USAGE ≤-steps
"Warning: ≤-steps was deprecated in v0.15.
Please use ≤-stepsˡ instead."
#-}

-- Version 0.17

i∸k∸j+j∸k≡i+j∸k : ∀ i j k → i ∸ (k ∸ j) + (j ∸ k) ≡ i + j ∸ k
i∸k∸j+j∸k≡i+j∸k zero    j k    = cong (_+ (j ∸ k)) (0∸n≡0 (k ∸ j))
i∸k∸j+j∸k≡i+j∸k (suc i) j zero = cong (λ x → suc i ∸ x + j) (0∸n≡0 j)
i∸k∸j+j∸k≡i+j∸k (suc i) zero (suc k) = begin
  i ∸ k + 0  ≡⟨ +-identityʳ _ ⟩
  i ∸ k      ≡⟨ cong (_∸ k) (sym (+-identityʳ _)) ⟩
  i + 0 ∸ k  ∎
i∸k∸j+j∸k≡i+j∸k (suc i) (suc j) (suc k) = begin
  suc i ∸ (k ∸ j) + (j ∸ k) ≡⟨ i∸k∸j+j∸k≡i+j∸k (suc i) j k ⟩
  suc i + j ∸ k             ≡⟨ cong (_∸ k) (sym (+-suc i j)) ⟩
  i + suc j ∸ k             ∎
{-# WARNING_ON_USAGE i∸k∸j+j∸k≡i+j∸k
"Warning: i∸k∸j+j∸k≡i+j∸k was deprecated in v0.17."
#-}
im≡jm+n⇒[i∸j]m≡n : ∀ i j m n → i * m ≡ j * m + n → (i ∸ j) * m ≡ n
im≡jm+n⇒[i∸j]m≡n i j m n eq = begin
  (i ∸ j) * m            ≡⟨ *-distribʳ-∸ m i j ⟩
  (i * m) ∸ (j * m)      ≡⟨ cong (_∸ j * m) eq ⟩
  (j * m + n) ∸ (j * m)  ≡⟨ cong (_∸ j * m) (+-comm (j * m) n) ⟩
  (n + j * m) ∸ (j * m)  ≡⟨ m+n∸n≡m n (j * m) ⟩
  n                      ∎
{-# WARNING_ON_USAGE im≡jm+n⇒[i∸j]m≡n
"Warning: im≡jm+n⇒[i∸j]m≡n was deprecated in v0.17."
#-}
≤+≢⇒< = ≤∧≢⇒<
{-# WARNING_ON_USAGE ≤+≢⇒<
"Warning: ≤+≢⇒< was deprecated in v0.17.
Please use ≤∧≢⇒< instead."
#-}

-- Version 1.0

≤-irrelevance = ≤-irrelevant
{-# WARNING_ON_USAGE ≤-irrelevance
"Warning: ≤-irrelevance was deprecated in v1.0.
Please use ≤-irrelevant instead."
#-}
<-irrelevance = <-irrelevant
{-# WARNING_ON_USAGE <-irrelevance
"Warning: <-irrelevance was deprecated in v1.0.
Please use <-irrelevant instead."
#-}


module SizedIO.coIOIO where

open import Size

mutual
  data coIO²  (i : Size) (j : Size)
              (Cin : Set ) (Rin : Cin  → Set)
              (Cext : Set) (Rext : Cext → Set)
              (A : Set) : Set where
     return : A → coIO² i j Cin Rin Cext Rext A
     dof    : (i' : Size< i) →
              (c : Cin) → (Rin c → coIO² i' j Cin Rin Cext Rext A)
              → coIO² i j Cin Rin Cext Rext A
     do∞    : (c : Cext)
              → (Rext c → coIO²∞ j Cin Rin Cext Rext A)
              → coIO² i j Cin Rin Cext Rext A

  record coIO²∞ (j : Size) (Cin : Set ) (Rin : Cin  → Set)
                            (Cext : Set) (Rext : Cext → Set)
                            (A : Set) : Set where
    coinductive
    field
      force : (j' : Size< j)
               → coIO² ∞ j' Cin Rin Cext Rext A

open coIO²∞ public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties of equivalence closures.
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Closure.Equivalence.Properties where

open import Data.Sum.Base using (inj₁)
open import Function using (_∘′_)
open import Relation.Binary.Core using (Rel)
open import Relation.Binary.Construct.Closure.Equivalence
open import Relation.Binary.Construct.Closure.ReflexiveTransitive as RTrans

module _ {a ℓ} {A : Set a} {_⟶_ : Rel A ℓ} where

  private
    _—↠_ = Star _⟶_
    _↔_  = EqClosure _⟶_

  a—↠b⇒a↔b : ∀ {a b} → a —↠ b → a ↔ b
  a—↠b⇒a↔b = RTrans.map inj₁

  a—↠b⇒b↔a : ∀ {a b} → a —↠ b → b ↔ a
  a—↠b⇒b↔a = symmetric _ ∘′ a—↠b⇒a↔b

  a—↠b&a—↠c⇒b↔c : ∀ {a b c} → a —↠ b → a —↠ c → b ↔ c
  a—↠b&a—↠c⇒b↔c a—↠b b—↠c = a—↠b⇒b↔a a—↠b ◅◅ a—↠b⇒a↔b b—↠c


module Min where

open import Data.Nat using (ℕ; zero; suc)
open import Algebra.Bundles using (CommutativeRing)
open import Algebra.Module.Bundles using (Module)
open import Data.Product using (Σ-syntax; ∃-syntax; _×_; proj₁; proj₂; _,_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Binary.Core using (Rel)
import Algebra.Module.Construct.Zero as Zero
import Algebra.Module.Construct.DirectProduct as Prod
import Algebra.Module.Construct.TensorUnit as Unit

module _
  {r ℓr} {CR : CommutativeRing r ℓr}
  {ma ℓma} (MA : Module CR ma ℓma)
  {mb ℓmb} (MB : Module CR mb ℓmb)
  where

  open import Linear MA MB

  module _
    {rel} (_<_ : Rel (CommutativeRing.Carrier CR) rel)
    (∥_∥ᴬ : A → R)
    (∥_∥ᴮ : B → R)
    (_÷_ : B → R → B)
    where

    _LimitOf_x→_ Limit-syntax : (L : B) (f : A → B) (c : A)→ Set _
    L LimitOf f x→ c = ∀ ε → ∃[ δ ] ∥ (f (c +ᴬ δ) -ᴮ L) ∥ᴮ < ∥ ε ∥ᴮ
    Limit-syntax = _LimitOf_x→_

    syntax Limit-syntax L (λ h → f) c = L LimitOf f ∶ h ⟶ c

    Diff' : (f : A → B) (x : A) (f' : A → A → B) → Set _
    Diff' f x f' = 0ᴮ LimitOf tmp dx ∶ dx ⟶ 0ᴬ
      where
        tmp : (dx : A) → B
        tmp dx = (f (x +ᴬ dx) -ᴮ f x -ᴮ f' x dx) ÷ ∥ dx ∥ᴬ

    Differentiable : (f : A → B) → A → Set _
    Differentiable f x =
      Σ[ f' ∈ (A → A → B) ]
          Linear (f' x)
        -- × ∀ dy → ∃[ dx ] (∥ ((f (x +ᴬ dx) -ᴮ f x) -ᴮ (f' x dx)) ∥ᴮ) < (∥ dy ∥ᴮ)

    D : {f : A → B} {x : A} (d : Differentiable f x) → A → B
    D {x = x} d = proj₁ d x

n-module : ∀ {a b} {S : CommutativeRing a b} → ℕ → Module S a b
n-module zero = Zero.⟨module⟩
n-module (suc n) = Prod.⟨module⟩ Unit.⟨module⟩ (n-module n)

open import Tactic.RingSolver

module Line {a b} (CR : CommutativeRing a b) where
  open CommutativeRing CR
  open import Relation.Binary.Reasoning.Setoid setoid

  open import Tactic.RingSolver.Core.AlmostCommutativeRing

  line : Carrier → Carrier → Carrier → Carrier
  line m b x = m * x + b

  x+y-x≈y : ∀ x y → (x + y) - x ≈ y
  x+y-x≈y x y =
    begin
      (x + y) - x
    ≈⟨ +-assoc x y (- x) ⟩
      x + (y - x)
    ≈⟨ +-cong refl (+-comm y (- x)) ⟩
      x + (- x + y)
    ≈⟨ sym (+-assoc x (- x) y) ⟩
      (x - x) + y
    ≈⟨ +-cong (proj₂ -‿inverse x) refl ⟩
      0# + y
    ≈⟨ +-identityˡ y ⟩
      y
    ∎

  x+y+z≈x+z+y : ∀ x y z → x + y + z ≈ x + z + y
  x+y+z≈x+z+y x y z =
    begin
      (x + y) + z
    ≈⟨ +-assoc x y z ⟩
      x + (y + z)
    ≈⟨ +-cong refl (+-comm y z) ⟩
      x + (z + y)
    ≈⟨ sym (+-assoc x z y) ⟩
      (x + z) + y
    ∎

  linear-diff : ∀ m b x dy → line m b (x + dy) - line m b x ≈ m * dy
  linear-diff m b x dy =
    begin
      m * (x + dy) + b - (m * x + b)
    ≈⟨ +-cong (+-cong (distribˡ m x dy) refl) refl ⟩
      m * x + m * dy + b - (m * x + b)
    ≈⟨ +-cong (x+y+z≈x+z+y (m * x) (m * dy) b) refl ⟩
      m * x + b + m * dy - (m * x + b)
    ≈⟨ x+y-x≈y (m * x + b) (m * dy) ⟩
      m * dy
    ∎


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

module Data.Binary.PerformanceTests.Subtraction where

open import Prelude
open import Data.Binary.Definition
open import Data.Binary.Addition using (_+_)
open import Data.Binary.Subtraction using (_-_)
open import Data.Binary.Multiplication using (_*_)

sub-r  : 𝔹 → 𝔹 → ℕ → 𝔹
sub-r a x zero = a
sub-r a x (suc n) = sub-r a x n - x

sub-l  : 𝔹 → 𝔹 → ℕ → 𝔹
sub-l a x zero = a
sub-l a x (suc n) = sub-r (a - x) x n

one-thousand : 𝔹
one-thousand = 2ᵇ 1ᵇ 1ᵇ 2ᵇ 1ᵇ 2ᵇ 2ᵇ 2ᵇ 2ᵇ 0ᵇ

f : 𝔹
f = one-thousand * one-thousand * one-thousand

n : ℕ
n = 99999

-- The actual performance test (uncomment and time how long it takes to type-check)
-- _ : sub-l f one-thousand n ≡ sub-r f one-thousand n
-- _ = refl


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

module Hyper where

open import Prelude hiding (⊥)
open import Data.Empty.UniversePolymorphic
open import Data.List using (List; _∷_; [])
open import Data.Vec.Iterated
open import Data.Nat using (_*_; _+_)
open import Data.Nat.Properties using (Even; Odd)

private
  variable n m : ℕ

infixr 4 _#_↬_
_#_↬_ : ℕ → Type a → Type b → Type (a ℓ⊔ b)
zero  # A ↬ B = ⊥
suc n # A ↬ B = n # B ↬ A → B

module _ {a b} {A : Type a} {B : Type b} where
  yfld : Vec B n → 1 + (n * 2) # List (A × B) ↬ (A → List (A × B))
  yfld =
    foldr
      (λ n → 1 + (n * 2) # List (A × B) ↬ (A → List (A × B)))
      (λ y yk xk x → (x , y) ∷ xk yk)
      (λ ())

  xfld : Vec A n → (1 + n) * 2 # (A → List (A × B)) ↬ List (A × B)
  xfld =
    foldr
      (λ n → (1 + n) * 2 # (A → List (A × B)) ↬ List (A × B))
      (λ x xk yk → yk xk x)
      (λ _ → [])

  zip : Vec A n → Vec B n → List (A × B)
  zip xs ys = xfld xs (yfld ys)

cata : Even n → (((C → A) → B) → C) → n # A ↬ B → C
cata {n = suc (suc n)} e ϕ h = ϕ (λ g → h (g ∘ cata e ϕ))

push : (A → B) → n # A ↬ B → 2 + n # A ↬ B
push {n = suc n} f q k = f (k q)

one : Odd n → n # A ↬ A
one {n = suc zero} o ()
one {n = suc (suc n)} o k = k (one o)


module Numeral.Natural.Combinatorics.Proofs where

open import Functional
import      Lvl
open import Logic
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Combinatorics
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Oper.Proofs.Multiplication
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Relator.Equals.Proofs.Equiv
open import Structure.Setoid hiding (_≡_ ; _≢_)
open import Structure.Function.Domain
open import Structure.Function
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Transitivity
open import Type

factorial-non-zero : ∀{n} → ((n !) ≢ 𝟎)
factorial-non-zero {𝟎}   ()
factorial-non-zero {𝐒 n} p with [⋅]-product-is-0 {a = 𝐒 n}{b = n !} p
... | [∨]-introᵣ n!0 = factorial-non-zero {n} n!0

instance
  factorial-positive : ∀{n} → Positive(n !)
  factorial-positive {n} = non-zero-positive(factorial-non-zero {n})

-- Also called: Pascals's identity
𝑐𝐶-step : ∀{n k} → (𝑐𝐶 (𝐒(n)) (𝐒(k)) ≡ 𝑐𝐶 n k + 𝑐𝐶 n (𝐒(k)))
𝑐𝐶-step = [≡]-intro

𝑐𝐶-empty-subsets : ∀{n} → (𝑐𝐶 n 𝟎 ≡ 𝐒(𝟎))
𝑐𝐶-empty-subsets {𝟎}   = [≡]-intro
𝑐𝐶-empty-subsets {𝐒 n} = [≡]-intro

𝑐𝐶-singleton-subsets : ∀{n} → (𝑐𝐶 n (𝐒 𝟎) ≡ n)
𝑐𝐶-singleton-subsets {𝟎}   = [≡]-intro
𝑐𝐶-singleton-subsets {𝐒 n} = congruence₁(𝐒) (𝑐𝐶-singleton-subsets {n})
{-# REWRITE 𝑐𝐶-singleton-subsets #-}

𝑐𝐶-larger-subsets : ∀{n k} → (n < k) → (𝑐𝐶 n k ≡ 𝟎)
𝑐𝐶-larger-subsets {𝟎}         (succ _) = [≡]-intro
𝑐𝐶-larger-subsets {𝐒 n} {𝐒 k} (succ p)
  rewrite 𝑐𝐶-larger-subsets {n} {k} p
  rewrite 𝑐𝐶-larger-subsets {n} {𝐒 k} ([≤]-successor p)
  = [≡]-intro

𝑐𝐶-full-subsets : ∀{n} → (𝑐𝐶 n n ≡ 𝐒(𝟎))
𝑐𝐶-full-subsets {𝟎}   = [≡]-intro
𝑐𝐶-full-subsets {𝐒 n}
  rewrite 𝑐𝐶-full-subsets {n}
  rewrite 𝑐𝐶-larger-subsets {n}{𝐒 n} (reflexivity(_≤_))
  = [≡]-intro

𝑐𝐶-excluding-single-subsets : ∀{n} → (𝑐𝐶 (𝐒 n) n ≡ 𝐒(n))
𝑐𝐶-excluding-single-subsets {𝟎}   = [≡]-intro
𝑐𝐶-excluding-single-subsets {𝐒 n}
  rewrite 𝑐𝐶-excluding-single-subsets {n}
  rewrite 𝑐𝐶-full-subsets {n}
  rewrite 𝑐𝐶-larger-subsets {n}{𝐒 n} (reflexivity(_≤_))
  = [≡]-intro

{-
𝑐𝐶-test2 : ∀{k₁ k₂} → (𝑐𝐶 (𝐒(k₁ + k₂)) k₁ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₁) ≡ 𝑐𝐶 (𝐒(k₁ + k₂)) k₂ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₂))
𝑐𝐶-test2 {𝟎} {𝟎} = [≡]-intro
𝑐𝐶-test2 {𝟎} {𝐒 k₂}
  rewrite 𝑐𝐶-full-subsets {k₂}
  rewrite 𝑐𝐶-larger-subsets {k₂} (reflexivity(_≤_))
  rewrite 𝑐𝐶-larger-subsets {k₂} ([≤]-successor(reflexivity(_≤_)))
  rewrite 𝑐𝐶-excluding-single-subsets {k₂}
  = [≡]-intro
𝑐𝐶-test2 {𝐒 k₁} {𝟎}
  rewrite 𝑐𝐶-full-subsets {k₁}
  rewrite 𝑐𝐶-larger-subsets {k₁} (reflexivity(_≤_))
  rewrite 𝑐𝐶-larger-subsets {k₁} ([≤]-successor(reflexivity(_≤_)))
  rewrite 𝑐𝐶-excluding-single-subsets {k₁}
  = [≡]-intro
𝑐𝐶-test2 {𝐒 k₁} {𝐒 k₂}
  -- rewrite test2 {k₁ + k₂} {k₁} {k₂} [≡]-intro
  -- rewrite test2 {𝐒(k₁ + k₂)} {𝐒 k₁} {k₂} [≡]-intro
  -- rewrite test2 {𝐒(k₁ + k₂)} {k₁} {𝐒 k₂} [≡]-intro
  = {!!}

𝑐𝐶-symmetric : ∀{n k₁ k₂} → (k₁ + k₂ ≡ n) → (𝑐𝐶 n k₁ ≡ 𝑐𝐶 n k₂)
𝑐𝐶-symmetric {𝟎} {𝟎} {𝟎} x = [≡]-intro
𝑐𝐶-symmetric {𝐒 n} {𝟎} {𝐒 .n} [≡]-intro
  rewrite 𝑐𝐶-full-subsets {n}
  rewrite 𝑐𝐶-larger-subsets {n} (reflexivity(_≤_))
  = [≡]-intro
𝑐𝐶-symmetric {𝐒 n} {𝐒 .n} {𝟎} [≡]-intro
  rewrite 𝑐𝐶-full-subsets {n}
  rewrite 𝑐𝐶-larger-subsets {n} (reflexivity(_≤_))
  = [≡]-intro
𝑐𝐶-symmetric {𝐒 .(𝐒(k₁ + k₂))} {𝐒 k₁} {𝐒 k₂} [≡]-intro
  =
    𝑐𝐶 (𝐒(𝐒(k₁ + k₂))) (𝐒 k₁)                                    🝖[ _≡_ ]-[]
    𝑐𝐶 (𝐒(k₁ + k₂)) k₁ + 𝑐𝐶 (𝐒(k₁ + k₂)) (𝐒 k₁)                  🝖[ _≡_ ]-[]
    𝑐𝐶 (𝐒(k₁ + k₂)) k₁ + (𝑐𝐶 (k₁ + k₂) k₁ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₁)) 🝖[ _≡_ ]-[ One.commuteₗ-assocᵣ {_▫_ = _+_}{a = 𝑐𝐶 (𝐒(k₁ + k₂)) k₁}{b = 𝑐𝐶 (k₁ + k₂) k₁}{c = 𝑐𝐶 (k₁ + k₂) (𝐒 k₁)} ]
    𝑐𝐶 (k₁ + k₂) k₁ + (𝑐𝐶 (𝐒(k₁ + k₂)) k₁ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₁)) 🝖[ _≡_ ]-[ congruence₂(_+_) (𝑐𝐶-symmetric {k₁ + k₂} {k₁} {k₂} [≡]-intro) (𝑐𝐶-test2 {k₁}{k₂}) ]
    𝑐𝐶 (k₁ + k₂) k₂ + (𝑐𝐶 (𝐒(k₁ + k₂)) k₂ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₂)) 🝖[ _≡_ ]-[ One.commuteₗ-assocᵣ {_▫_ = _+_}{a = 𝑐𝐶 (𝐒(k₁ + k₂)) k₂}{b = 𝑐𝐶 (k₁ + k₂) k₂}{c = 𝑐𝐶 (k₁ + k₂) (𝐒 k₂)} ]-sym
    𝑐𝐶 (𝐒(k₁ + k₂)) k₂ + (𝑐𝐶 (k₁ + k₂) k₂ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₂)) 🝖[ _≡_ ]-[]
    𝑐𝐶 (𝐒(k₁ + k₂)) k₂ + 𝑐𝐶 (𝐒(k₁ + k₂)) (𝐒 k₂)                  🝖[ _≡_ ]-[]
    𝑐𝐶 (𝐒(𝐒(k₁ + k₂))) (𝐒 k₂)                                    🝖-end
-}

-- ∀{n k} → 𝑐𝐶 n k ≡ 𝑐𝐶 n (n−k)
-- ∀{n k} → 𝑐𝐶 (𝐒 n) (𝐒 k) ≡ 𝑐𝐶 n k ⋅ (𝐒 n) / (𝐒 k)
-- ∀{n} → (∑(𝟎 ‥ n) (𝑐𝐶 n) ≡ 2 ^ n)
-- ∀{n k} → (𝑐𝐶 (𝐒 n) (𝐒 k) ≡ ∑(0 ‥ n) (i ↦ 𝑐𝐶 i k) = ∑(k ‥ n) (i ↦ 𝑐𝐶 i k))

𝑐𝑃-empty : ∀{n} → (𝑐𝑃 n 𝟎 ≡ 𝐒(𝟎))
𝑐𝑃-empty {𝟎}   = [≡]-intro
𝑐𝑃-empty {𝐒 n} = [≡]-intro

𝑐𝑃-singleton : ∀{n} → (𝑐𝑃 n (𝐒 𝟎) ≡ n)
𝑐𝑃-singleton {𝟎}   = [≡]-intro
𝑐𝑃-singleton {𝐒 n} = [≡]-intro
{-# REWRITE 𝑐𝑃-singleton #-}

𝑐𝑃-step-diff : ∀{n k} → (𝑐𝑃 n k ⋅ n ≡ 𝑐𝑃 n k ⋅ k + 𝑐𝑃 n (𝐒 k)) -- TODO: Prove this for 𝑐𝐶 by using 𝑐𝐶-permutations-is-𝑐𝑃
𝑐𝑃-step-diff {𝟎} {𝟎} = [≡]-intro
𝑐𝑃-step-diff {𝟎} {𝐒 k} = [≡]-intro
𝑐𝑃-step-diff {𝐒 n} {𝟎} = [≡]-intro
𝑐𝑃-step-diff {𝐒 n} {𝐒 k} =
  𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ (𝐒 n)                                      🝖[ _≡_ ]-[]
  (𝑐𝑃 n k ⋅ (𝐒 n)) ⋅ (𝐒 n)                                    🝖[ _≡_ ]-[]
  (𝑐𝑃 n k + 𝑐𝑃 n k ⋅ n) ⋅ (𝐒 n)                               🝖[ _≡_ ]-[ distributivityᵣ(_⋅_)(_+_) {x = 𝑐𝑃 n k}{y = 𝑐𝑃 n k ⋅ n}{z = 𝐒 n} ]
  (𝑐𝑃 n k ⋅ (𝐒 n)) + ((𝑐𝑃 n k ⋅ n) ⋅ (𝐒 n))                   🝖[ _≡_ ]-[ congruence₂(_+_) (reflexivity(_≡_) {x = 𝑐𝑃 (𝐒 n) (𝐒 k)}) proof1 ]
  𝑐𝑃 (𝐒 n) (𝐒 k) + ((𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ k) + 𝑐𝑃 (𝐒 n) (𝐒(𝐒 k))) 🝖[ _≡_ ]-[ associativity(_+_) {x = 𝑐𝑃 (𝐒 n) (𝐒 k)}{y = 𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ k}{z = 𝑐𝑃 (𝐒 n) (𝐒(𝐒 k))} ]-sym
  (𝑐𝑃 (𝐒 n) (𝐒 k) + (𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ k)) + 𝑐𝑃 (𝐒 n) (𝐒(𝐒 k)) 🝖[ _≡_ ]-[]
  (𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ 𝐒 k) + 𝑐𝑃 (𝐒 n) (𝐒(𝐒 k))                  🝖-end
  where
    proof2 =
      (𝑐𝑃 n k ⋅ k) ⋅ (𝐒 n) 🝖[ _≡_ ]-[ One.commuteᵣ-assocₗ {_▫_ = _⋅_}{a = 𝑐𝑃 n k}{b = k}{c = 𝐒 n} ]
      (𝑐𝑃 n k ⋅ (𝐒 n)) ⋅ k 🝖[ _≡_ ]-[]
      𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ k   🝖-end

    proof1 =
      (𝑐𝑃 n k ⋅ n) ⋅ (𝐒 n)                          🝖[ _≡_ ]-[ congruence₂ₗ(_⋅_)(𝐒 n) (𝑐𝑃-step-diff {n}{k}) ]
      (𝑐𝑃 n k ⋅ k + 𝑐𝑃 n (𝐒 k)) ⋅ (𝐒 n)             🝖[ _≡_ ]-[ distributivityᵣ(_⋅_)(_+_) {x = 𝑐𝑃 n k ⋅ k}{y = 𝑐𝑃 n (𝐒 k)}{z = 𝐒 n} ]
      ((𝑐𝑃 n k ⋅ k) ⋅ (𝐒 n)) + (𝑐𝑃 n (𝐒 k) ⋅ (𝐒 n)) 🝖[ _≡_ ]-[ congruence₂(_+_) proof2 (reflexivity(_≡_)) ]
      (𝑐𝑃 (𝐒 n) (𝐒 k) ⋅ k) + 𝑐𝑃 (𝐒 n) (𝐒(𝐒 k))      🝖-end

𝑐𝑃-step-alt : ∀{n k} → (𝑐𝑃 (𝐒 n) (𝐒 k) ≡ (𝑐𝑃 n k ⋅ 𝐒 k) + 𝑐𝑃 n (𝐒 k))
𝑐𝑃-step-alt {n}{k} rewrite 𝑐𝑃-step-diff {n}{k} = symmetry(_≡_) (associativity(_+_) {x = 𝑐𝑃 n k}{y = 𝑐𝑃 n k ⋅ k}{z = 𝑐𝑃 n (𝐒 k)})

𝑐𝐶-permutations-is-𝑐𝑃 : ∀{n k} → (𝑐𝐶 n k ⋅ (k !) ≡ 𝑐𝑃 n k)
𝑐𝐶-permutations-is-𝑐𝑃 {𝟎} {𝟎}     = [≡]-intro
𝑐𝐶-permutations-is-𝑐𝑃 {𝟎} {𝐒 k}   = [≡]-intro
𝑐𝐶-permutations-is-𝑐𝑃 {𝐒 n} {𝟎}   = [≡]-intro
𝑐𝐶-permutations-is-𝑐𝑃 {𝐒 n} {𝐒 k} =
  (𝑐𝐶 n k + 𝑐𝐶 n (𝐒 k)) ⋅ (𝐒 k ⋅ (k !))                   🝖-[ distributivityᵣ(_⋅_)(_+_) {x = 𝑐𝐶 n k}{y = 𝑐𝐶 n (𝐒 k)}{z = 𝐒 k ⋅ (k !)} ]
  (𝑐𝐶 n k ⋅ (𝐒 k ⋅ (k !))) + (𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k ⋅ (k !))) 🝖-[ congruence₂(_+_) l r ]
  (𝑐𝑃 n k ⋅ 𝐒 k) + 𝑐𝑃 n (𝐒 k)                             🝖-[ 𝑐𝑃-step-alt {n}{k} ]-sym
  𝑐𝑃 n k ⋅ 𝐒 n                                            🝖-end
  where
    l =
      𝑐𝐶 n k ⋅ (𝐒 k ⋅ (k !)) 🝖-[ congruence₂ᵣ(_⋅_)(𝑐𝐶 n k) (commutativity(_⋅_) {𝐒 k}{k !}) ]
      𝑐𝐶 n k ⋅ ((k !) ⋅ 𝐒 k) 🝖-[ associativity(_⋅_) {x = 𝑐𝐶 n k}{y = k !}{z = 𝐒 k} ]-sym
      (𝑐𝐶 n k ⋅ (k !)) ⋅ 𝐒 k 🝖-[ congruence₂ₗ(_⋅_)(𝐒 k) (𝑐𝐶-permutations-is-𝑐𝑃 {n} {k}) ]
      𝑐𝑃 n k ⋅ 𝐒 k           🝖-end

    r =
      𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k ⋅ (k !)) 🝖[ _≡_ ]-[]
      𝑐𝐶 n (𝐒 k) ⋅ ((𝐒 k)!)      🝖[ _≡_ ]-[ 𝑐𝐶-permutations-is-𝑐𝑃 {n} {𝐒 k} ]
      𝑐𝑃 n (𝐒 k)                 🝖-end

𝑐𝑃-full : ∀{n} → (𝑐𝑃 n n ≡ n !)
𝑐𝑃-full {n} =
  𝑐𝑃 n n         🝖[ _≡_ ]-[ 𝑐𝐶-permutations-is-𝑐𝑃 {n}{n} ]-sym
  𝑐𝐶 n n ⋅ (n !) 🝖[ _≡_ ]-[ congruence₂ₗ(_⋅_)(n !) (𝑐𝐶-full-subsets {n}) ]
  𝐒(𝟎) ⋅ (n !)   🝖[ _≡_ ]-[]
  n !            🝖-end

𝑐𝐶-step-diff : ∀{n k} → (𝑐𝐶 n k ⋅ n ≡ (𝑐𝐶 n k ⋅ k) + (𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k)))
𝑐𝐶-step-diff {n}{k} = [⋅]-cancellationᵣ {x = k !} ⦃ factorial-positive {k} ⦄ $
  (𝑐𝐶 n k ⋅ n) ⋅ (k !)                                  🝖[ _≡_ ]-[ One.commuteᵣ-assocₗ {_▫_ = _⋅_}{a = 𝑐𝐶 n k}{b = n}{c = k !} ]
  (𝑐𝐶 n k ⋅ (k !)) ⋅ n                                  🝖[ _≡_ ]-[ congruence₁(_⋅ n) (𝑐𝐶-permutations-is-𝑐𝑃 {n}{k}) ]
  𝑐𝑃 n k ⋅ n                                            🝖[ _≡_ ]-[ 𝑐𝑃-step-diff {n}{k} ]
  𝑐𝑃 n k ⋅ k + 𝑐𝑃 n (𝐒 k)                               🝖[ _≡_ ]-[ congruence₂(_+_) (congruence₁(_⋅ k) (symmetry(_≡_) (𝑐𝐶-permutations-is-𝑐𝑃 {n}{k}))) (symmetry(_≡_) (𝑐𝐶-permutations-is-𝑐𝑃 {n}{𝐒 k})) ]
  (𝑐𝐶 n k ⋅ (k !)) ⋅ k + (𝑐𝐶 n (𝐒 k) ⋅ ((𝐒 k) !))       🝖[ _≡_ ]-[]
  (𝑐𝐶 n k ⋅ (k !)) ⋅ k + (𝑐𝐶 n (𝐒 k) ⋅ ((𝐒 k) ⋅ (k !))) 🝖[ _≡_ ]-[ congruence₂(_+_) (One.commuteᵣ-assocₗ {_▫_ = _⋅_}{a = 𝑐𝐶 n k}{b = k !}{c = k}) (symmetry(_≡_) (associativity(_⋅_) {x = 𝑐𝐶 n (𝐒 k)}{y = 𝐒 k}{z = k !})) ]
  (𝑐𝐶 n k ⋅ k) ⋅ (k !) + ((𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k)) ⋅ (k !)) 🝖[ _≡_ ]-[ distributivityᵣ(_⋅_)(_+_) {x = 𝑐𝐶 n k ⋅ k}{y = 𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k)}{z = k !} ]-sym
  ((𝑐𝐶 n k ⋅ k) + (𝑐𝐶 n (𝐒 k) ⋅ (𝐒 k))) ⋅ (k !)         🝖-end

{-
-- Note: This is a variant of the usual definition of 𝑐𝐶 (The usual one: 𝑐𝐶 n k = (n !) / ((k !) ⋅ (n − k)!)).
factorial-of-[+] : ∀{k₁ k₂} → ((k₁ + k₂)! ≡ (k₁ !) ⋅ (k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁)
factorial-of-[+] {𝟎} {k₂} = [≡]-intro
factorial-of-[+] {𝐒 k₁} {k₂} =
  ((𝐒(k₁) + k₂) !)                                 🝖[ _≡_ ]-[]
  (𝐒(k₁ + k₂) !)                                   🝖[ _≡_ ]-[]
  𝐒(k₁ + k₂) ⋅ ((k₁ + k₂) !)                       🝖[ _≡_ ]-[ congruence₂ᵣ(_⋅_)(𝐒(k₁ + k₂)) (factorial-of-[+] {k₁} {k₂}) ]
  𝐒(k₁ + k₂) ⋅ ((k₁ !) ⋅ (k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁) 🝖[ _≡_ ]-[]
  (𝐒(k₁) + k₂) ⋅ ((k₁ !) ⋅ (k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁) 🝖[ _≡_ ]-[ {!!} ]
  ((𝐒(k₁) + k₂) ⋅ (k₁ !)) ⋅ ((k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁) 🝖[ _≡_ ]-[ {!!} ]
  ((𝐒(k₁) ⋅ (k₁ !)) + (k₂ ⋅ (k₁ !))) ⋅ ((k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁) 🝖[ _≡_ ]-[ {!!} ]
  ((𝐒(k₁) !) + (k₂ ⋅ (k₁ !))) ⋅ ((k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁) 🝖[ _≡_ ]-[ {!!} ]
  (𝐒(k₁) !) ⋅ (k₂ !) ⋅ 𝑐𝐶(𝐒(k₁) + k₂) (𝐒(k₁))      🝖-end

𝐒 k₁ ⋅ (k₁ !) ⋅ (k₂ !) ⋅ (𝑐𝐶 (k₁ + k₂) k₁ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₁))
-}
{-factorial-of-[+] {𝟎} {𝟎} = [≡]-intro
factorial-of-[+] {𝟎} {𝐒 k₂} = [≡]-intro
factorial-of-[+] {𝐒 k₁} {𝟎}
  rewrite 𝑐𝐶-full-subsets {k₁}
  rewrite 𝑐𝐶-larger-subsets {k₁} {𝐒 k₁} (reflexivity(_≤_))
  = [≡]-intro
factorial-of-[+] {𝐒 k₁} {𝐒 k₂} = {!!}
𝐒(𝐒(k₁ + k₂)) ⋅ (𝐒(k₁ + k₂) ⋅ ((k₁ + k₂)!))
𝐒(𝐒(k₁ + k₂)) ⋅ (𝐒(k₁ + k₂) ⋅ ((k₁ !) ⋅ (k₂ !) ⋅ 𝑐𝐶 (k₁ + k₂) k₁))
𝐒(k₁) ⋅ (k₁ !) ⋅ (𝐒 k₂ ⋅ (k₂ !)) ⋅ (𝑐𝐶 (𝐒(k₁ + k₂)) k₁ + (𝑐𝐶 (k₁ + k₂) k₁ + 𝑐𝐶 (k₁ + k₂) (𝐒 k₁)))
-}

{-
-- Note: This is a variant of the usual definition of 𝑐𝑃 (The usual one: 𝑐𝑃 n k = (n !) / ((n − k)!)).
factorial-of-[+]-𝑐𝑃 : ∀{k₁ k₂} → ((k₁ + k₂)! ≡ 𝑐𝑃 (k₁ + k₂) k₂ ⋅ (k₁ !))
factorial-of-[+]-𝑐𝑃 {𝟎} {𝟎} = [≡]-intro
factorial-of-[+]-𝑐𝑃 {𝟎} {𝐒 k₂}
  rewrite 𝑐𝑃-full {k₂}
  =
    𝐒 k₂ ⋅ (k₂ !)        🝖[ _≡_ ]-[ commutativity(_⋅_) {𝐒 k₂}{k₂ !} ]
    (k₂ !) ⋅ 𝐒 k₂        🝖[ _≡_ ]-[]
    (k₂ !) + (k₂ !) ⋅ k₂ 🝖-end
factorial-of-[+]-𝑐𝑃 {𝐒 k₁} {𝟎} = [≡]-intro
factorial-of-[+]-𝑐𝑃 {𝐒 k₁} {𝐒 k₂} = {!!}
𝐒(𝐒(k₁ + k₂)) ⋅ (𝐒(k₁ + k₂) ⋅ ((k₁ + k₂)!))
𝐒(𝐒(k₁ + k₂)) ⋅ (𝐒(k₁ + k₂) ⋅ (𝑐𝑃 (k₁ + k₂) k₂ ⋅ (k₁ !)))
(𝑐𝑃 (𝐒(k₁ + k₂)) k₂ + (𝑐𝑃 (𝐒(k₁ + k₂)) k₂ + 𝑐𝑃 (𝐒(k₁ + k₂)) k₂ ⋅ (k₁ + k₂))) ⋅ (𝐒 k₁ ⋅ (k₁ !))
-}


{-# OPTIONS --cubical --safe --postfix-projections #-}

open import Prelude
open import Relation.Binary

module Data.RBTree {e} {E : Type e} {r₁ r₂} (totalOrder : TotalOrder E r₁ r₂) where

open import Relation.Binary.Construct.Bounded totalOrder

open TotalOrder totalOrder using (_≤?_)

data Colour : Type where
  red black : Colour

add-black : Colour → ℕ → ℕ
add-black red = λ n → n
add-black black = suc

private
  variable
    n : ℕ

data Tree (lb ub : [∙]) : ℕ → Type (e ℓ⊔ r₂) where
  leaf : lb [≤] ub → Tree lb ub n
  node : (x : E) → (c : Colour) → Tree lb [ x ] n → Tree [ x ] ub n → Tree lb ub (add-black c n)

private
  variable
    lb ub : [∙]

IsBlack : Tree lb ub n → Type
IsBlack (leaf x) = ⊤
IsBlack (node x red tr tr₁) = ⊥
IsBlack (node x black tr tr₁) = ⊤

Valid-rec : Tree lb ub n → Type
Valid-rec (leaf x) = ⊤
Valid-rec (node x red   xs ys) = IsBlack xs × IsBlack ys × Valid-rec xs × Valid-rec ys
Valid-rec (node x black xs ys) = Valid-rec xs × Valid-rec ys

Valid : Tree lb ub n → Type
Valid tr = IsBlack tr × Valid-rec tr

-- insertWithin : (x : E) →
--                (lb [≤] [ x ]) →
--                ([ x ] [≤] ub) →
--                (tr : Tree lb ub n) →
--                Valid-rec tr →
--                ∃ c Σ (Tree lb ub (add-black c n)) Valid-rec
-- insertWithin x lb≤x x≤ub (leaf _) val = red , node x red (leaf lb≤x) (leaf x≤ub) , tt , tt , tt , tt
-- insertWithin x lb≤x x≤ub (node y c ls rs) val with x ≤? y
-- insertWithin x lb≤x x≤ub (node y red   ls rs) val | inl x≤y with insertWithin x lb≤x x≤y ls (fst (snd (snd val)))
-- insertWithin x lb≤x x≤ub (node y red   ls rs) val | inl x≤y | red    , ls′ , val′ = black , node y black ls′ rs , val′ , snd (snd (snd val))
-- insertWithin x lb≤x x≤ub (node y red   ls rs) val | inl x≤y | black  , ls′ , val′ = {!{!!} , node y {!!} ls′ rs , {!!}!}
-- insertWithin x lb≤x x≤ub (node y black ls rs) val | inl x≤y with insertWithin x lb≤x x≤y ls (fst val)
-- insertWithin x lb≤x x≤ub (node y black ls rs) val | inl x≤y | res = {!!}
-- insertWithin x lb≤x x≤ub (node y c ls rs) val | inr y≤x = {!!}

-- -- insertWithin x lb≤x x≤ub (node y ls rs) with x ≤? y
-- -- insertWithin x lb≤x x≤ub (node y ls rs) | inl x≤y = node y (insertWithin x lb≤x x≤y ls) rs
-- -- insertWithin x lb≤x x≤ub (node y ls rs) | inr y≤x = node y ls (insertWithin x y≤x x≤ub rs)