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

module x05-842Isomorphism-hc where

import      Relation.Binary.PropositionalEquality as Eq
open        Eq                                    using (_≡_; refl; cong; cong-app; sym; subst) -- added last
open        Eq.≡-Reasoning
open import Data.Nat                              using (ℕ; zero; suc; _+_; _*_; _^_)
open import Data.Nat.Properties                   using (+-comm; +-suc; +-identityʳ) -- added last
------------------------------------------------------------------------------
open import x02-842Induction-hc-2                 hiding (+-suc; +-identityʳ)

------------------------------------------------------------------------------
-- Function composition.

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

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

------------------------------------------------------------------------------
-- EXTENSIONALITY

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

-- def of + that matches on right
_+′_ : ℕ → ℕ → ℕ
m +′ zero  = m
m +′ suc n = suc (m +′ n)

same-app : ∀ (m n : ℕ) → m +′ n ≡ m + n
same-app m  zero         -- (m +′ zero) ≡ m + zero
                         --  m          ≡ m + zero
  rewrite +-identityʳ m  --  m          ≡ m
  = refl
same-app m (suc n) -- (m +′ suc n) ≡ m + suc n
                   -- suc (m +′ n) ≡ m + suc n
  rewrite
    +-suc m n      -- suc (m +′ n) ≡ suc (m + n)
  | same-app m n   -- suc (m +  n) ≡ suc (m + n)
  = refl

-- requires extensionality
+′-same-as-+ : _+′_ ≡ _+_
+′-same-as-+ = extensionality λ m → extensionality λ n → same-app m n

------------------------------------------------------------------------------
-- ISOMORPHISM

infix 0 _≃_
record _≃_ (A B : Set) : Set where
  constructor mk-≃  -- added, not in PLFA
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

-- RECORD def equivalent to DATA def and functions:

data _≃′_ (A B : Set): Set where
  mk-≃′ : ∀ (to : A → B) →
          ∀ (from : B → A) →
          ∀ (from∘to : (∀ (x : A) → from (to x) ≡ x)) →
          ∀ (to∘from : (∀ (y : B) → to (from y) ≡ y)) →
          A ≃′ B

to′ : ∀ {A B : Set} → (A ≃′ B) → (A → B)
to′ (mk-≃′ f g g∘f f∘g) = f

from′ : ∀ {A B : Set} → (A ≃′ B) → (B → A)
from′ (mk-≃′ f g g∘f f∘g) = g

from∘to′ : ∀ {A B : Set} → (A≃B : A ≃′ B)
                         → (∀ (x : A)
                         → from′ A≃B (to′ A≃B x) ≡ x)
from∘to′ (mk-≃′ f g g∘f f∘g) = g∘f

to∘from′ : ∀ {A B : Set} → (A≃B : A ≃′ B)
                         → (∀ (y : B)
                         → to′ A≃B (from′ A≃B y) ≡ y)
to∘from′ (mk-≃′ f g g∘f f∘g) = f∘g

-- End of equivalent formulation (records are faster!)

------------------------------------------------------------------------------
-- PROPERTIES OF ISOMORPHISM : AN EQUIVALENCE RELATION (i.e., reflexive, symmetric and transitive)

-- reflexive
≃-refl : ∀ {A : Set}
    -----
  → A ≃ A

-- in empty hole, split on result, get COPATTERNS (not in PLFA)

to      ≃-refl x = x
from    ≃-refl x = x
from∘to ≃-refl x = refl
to∘from ≃-refl x = refl

-- symmetric
≃-sym : ∀ {A B : Set}
  → A ≃ B
    -----
  → B ≃ A

to      (≃-sym A≃B) = from    A≃B
from    (≃-sym A≃B) = to      A≃B
from∘to (≃-sym A≃B) = to∘from A≃B
to∘from (≃-sym A≃B) = from∘to A≃B

-- transitive
≃-trans : ∀ {A B C : Set}
  → A ≃ B
  →     B ≃ C
    -----
  → A ≃     C

to      (≃-trans A≃B B≃C) = to   B≃C ∘ to   A≃B
from    (≃-trans A≃B B≃C) = from A≃B ∘ from B≃C
from∘to (≃-trans A≃B B≃C) x rewrite from∘to B≃C (to   A≃B x) = from∘to A≃B x
to∘from (≃-trans A≃B B≃C) x rewrite to∘from A≃B (from B≃C x) = to∘from B≃C x

-- syntax for isomorphic equational reasoning
module ≃-Reasoning where

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

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

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

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

open ≃-Reasoning

------------------------------------------------------------------------------
-- EMBEDDING (weaker than isomorphism)

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

≲-refl : ∀ {A : Set} → A ≲ A
to      ≲-refl x = x
from    ≲-refl x = x
from∘to ≲-refl x = refl

≲-trans : ∀ {A B C : Set} → A ≲ B → B ≲ C → A ≲ C
to      (≲-trans A≲B B≲C) = to   B≲C ∘ to   A≲B
from    (≲-trans A≲B B≲C) = from A≲B ∘ from B≲C
from∘to (≲-trans A≲B B≲C) x rewrite from∘to B≲C (to A≲B x) = from∘to A≲B x

≲-antisym : ∀ {A B : Set}
  → (A≲B : A ≲ B)
  → (B≲A : B ≲ A)
  → (to   A≲B ≡ from B≲A)
  → (from A≲B ≡ to   B≲A)
    -------------------
  → A ≃ B

to      (≲-antisym A≲B B≲A to≡from from≡to)   = to      A≲B
from    (≲-antisym A≲B B≲A to≡from from≡to)   = from    A≲B
from∘to (≲-antisym A≲B B≲A to≡from from≡to) x = from∘to A≲B x
to∘from (≲-antisym A≲B B≲A to≡from from≡to) y
  rewrite from≡to | to≡from                   = from∘to B≲A y

-- equational reasoning for embedding
module ≲-Reasoning where

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

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

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

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

open ≲-Reasoning

------------------------------------------------------------------------------
-- isomorphism implies embedding

≃-implies-≲ : ∀ {A B : Set}
  → A ≃ B
    -----
  → A ≲ B

to      (≃-implies-≲ a≃b) = to      a≃b
from    (≃-implies-≲ a≃b) = from    a≃b
from∘to (≃-implies-≲ a≃b) = from∘to a≃b

------------------------------------------------------------------------------
-- PROPOSITIONAL EQUIVALENCE (weaker than embedding) - aka IFF
-- an equivalence relation

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_ -- added

⇔-refl : ∀ {A : Set}
    -----
  → A ⇔ A

_⇔_.to   ⇔-refl x = x
_⇔_.from ⇔-refl x = x

⇔-sym : ∀ {A B : Set}
  → A ⇔ B
    -----
  → B ⇔ A

_⇔_.to   (⇔-sym A⇔B) = from A⇔B
_⇔_.from (⇔-sym A⇔B) = to   A⇔B

⇔-trans : ∀ {A B C : Set}
  → A ⇔ B
  →     B ⇔ C
    -----
  → A ⇔     C

to   (⇔-trans A⇔B B⇔C) = to   B⇔C ∘ to   A⇔B
from (⇔-trans A⇔B B⇔C) = from A⇔B ∘ from B⇔C

{-
------------------------------------------------------------------------------
-- 842 extended exercise: Canonical bitstrings.
-- Modified and extended from Bin-predicates exercise in PLFA Relations.

cannot prove
              ∀ {n : Bin-ℕ} → tob (fromb n) ≡ n
because of possibility of leading zeroes in Bin-ℕ value (e.g., 'bits x0 x0 x1')

It s true for Bin-ℕ without leading zeroes
-}
-- Predicate that states:
-- value of type One n is evidence that n has a leading one.
data One : Bin-ℕ → Set where
  [bitsx1] :                         One (bits x1)
  _[x0]    : ∀ {b : Bin-ℕ} → One b → One (b x0)
  _[x1]    : ∀ {b : Bin-ℕ} → One b → One (b x1)

-- proof that 'bits x1 x0 x0' has leading one
_ : One (bits x1 x0 x0)
_ = [bitsx1] [x0] [x0]

-- There is no value of type One (bits x0 x0 x1).
-- Can't state and prove yet, because negation not covered until Connectives chapter.

-- Canonical binary representation is either zero or has a leading one.
data Can : Bin-ℕ → Set where
  [zero] :                         Can bits
  [pos]  : ∀ {b : Bin-ℕ} → One b → Can b

_ : Can bits
_ = [zero]

_ : Can (bits x1 x0)
_ = [pos] ([bitsx1] [x0])

-- PLFA Relations Bin-predicates exercise gives three properties of canonicity.
-- First : increment of a canonical number is canonical.
-- Most of the work is done in the following lemma.

-- IncCanOne : increment of a canonical number has a leading one.
one-inc : ∀ {b : Bin-ℕ} → Can b → One (inc b)
one-inc [zero]           =          [bitsx1] -- note: 'n' is bound to 'bits'
one-inc ([pos] [bitsx1]) =          [bitsx1] [x0]
one-inc ([pos] (b [x0])) =                b  [x1]
one-inc ([pos] (b [x1])) = one-inc ([pos] b) [x0]

-- OneInc : 1st canonicity property is now a corollary.
can-inc : ∀ {b : Bin-ℕ} → Can b → Can (inc b)
can-inc cb = [pos] (one-inc cb)

-- CanToB : 2nd canonicity property : converting unary to binary produces a canonical number.
to-can : ∀ (n : ℕ) → Can (tob n)
to-can   zero  = [zero]
to-can (suc n) = can-inc (to-can n)

-- OneDblbX0 : relates binary double to the x0 constructor, for numbers with a leading one.
dblb-x0 : ∀ {b : Bin-ℕ} → One b → dblb b ≡ b x0
dblb-x0 [bitsx1]                     = refl
dblb-x0 (on [x0]) rewrite dblb-x0 on = refl
dblb-x0 (on [x1]) rewrite dblb-x0 on = refl

dblb-x1 : ∀ {b : Bin-ℕ} → One b → inc (dblb b) ≡ b x1
dblb-x1 [bitsx1]  = refl
dblb-x1 (on [x0])           --  inc (dblb (b  x0))    ≡ ((b x0) x1)
                            --      (dblb  b  x1)     ≡ ((b x0) x1)
  rewrite sym (dblb-x0 on)  --      (dblb  b  x1)     ≡ (dblb b x1)
  = refl
dblb-x1 (on [x1])           --  inc (dblb (b  x1))    ≡ ((b x1) x1)
                            -- (inc (dblb  b) x1)     ≡ ((b x1) x1)
  rewrite dblb-x1 on        --           ((b  x1) x1) ≡ ((b x1) x1)
  = refl

-- To prove 3rd property, use lemmas from 842Induction
-- 'one-to∘from' below and some new ones you define.

one-bits-to-nat : ∀ {b : Bin-ℕ} → One b → ℕ
one-bits-to-nat {b} _ = fromb b

one-to∘from : ∀ {b : Bin-ℕ} → One b → tob (fromb b) ≡ b
one-to∘from [bitsx1]  = refl
one-to∘from {b} (on [x0])       --      tob      (fromb (b  x0))  ≡ (b  x0)
                                --      tob  (dbl (fromb b ))     ≡ (b  x0)
  rewrite
    sym (dblb-x0 on)            --      tob  (dbl (fromb b ))     ≡ dblb b
  | to∘dbl (one-bits-to-nat on) --      dblb (tob (fromb b₁))     ≡ dblb b₁
  | one-to∘from on              --      dblb              lhs     ≡ dblb lhs
  = refl
one-to∘from {b} (on [x1])       --      tob      (fromb (b₁ x1))  ≡ (b₁ x1)
                                -- inc (tob (dbl (fromb  b₁)))    ≡ (b₁ x1)
  rewrite
    to∘dbl (one-bits-to-nat on) -- inc (dblb (tob (fromb b₁)))    ≡ (b₁ x1)
  | one-to∘from on              -- inc (dblb lhs)                 ≡ (lhs x1)
  | dblb-x1 on                  --          (lhs x1)              ≡ (lhs x1)
  = refl

-- 3rd canonicity property :
-- converting a canonical number from binary and back to unary produces the same number.
-- CanToFrom
can-to∘from : ∀ {b : Bin-ℕ} → Can b → tob (fromb b) ≡ b
can-to∘from [zero]    = refl
can-to∘from ([pos] b) = one-to∘from b

-- Proofs of positivity are unique.
one-unique : ∀ {b : Bin-ℕ} → (ox oy : One b) → ox ≡ oy
one-unique [bitsx1]  [bitsx1]  = refl
one-unique (ox [x0]) (oy [x0])
  with one-unique ox oy
... | refl = refl
one-unique (ox [x1]) (oy [x1])
  with one-unique ox oy
... | refl = refl

-- Proofs of canonicity are unique.
can-unique : ∀ {b : Bin-ℕ} → (cx cy : Can b) → cx ≡ cy
can-unique [zero]     [zero]     = refl
can-unique ([pos] ox) ([pos] oy)
  with one-unique ox oy
... | refl = refl

------------------------------------------------------------------------------
-- There is NOT an isomorphism between ℕ (unary) and canonical binary representations.
-- Because Can is not a set, but a family of sets, it does not fit into framework for isomorphism.

-- It is possible to roll all the values into one set which is isomorphic to ℕ.
-- A CanR VALUE wraps a Bin-ℕ and proof it has a canonical representation.
data CanR : Set where
  wrap : ∀ (b : Bin-ℕ) → Can b → CanR

-- IsoNCanR : Prove an isomorphism between ℕ and CanR.
iso-ℕ-CanR : ℕ ≃ CanR
to      iso-ℕ-CanR          n  = wrap (tob n) (to-can n) -- -- Goal: CanR; n : ℕ
from    iso-ℕ-CanR (wrap b cb) = fromb b -- Goal: ℕ; cb : Can b, b  : Bin-ℕ
                                         -- Constraints
                                         -- fromb (tob n) = ?0 (b = (tob n)) (cb = (to-can n)) : ℕ
from∘to iso-ℕ-CanR          n  = from∘tob n -- Goal: fromb (tob n) ≡ n; n : ℕ
to∘from iso-ℕ-CanR (wrap b cb)  -- Goal: to iso-ℕ-CanR (from iso-ℕ-CanR (wrap b cb)) ≡ wrap b cb
                                -- Goal: wrap (tob (fromb b)) (to-can (fromb b))     ≡ wrap b cb
                                -- cb : Can b, b  : Bin-ℕ
  with to-can (fromb b) | can-to∘from cb
... |  tcfb             | ctfcb -- Goal: wrap (tob (fromb b)) tcfb ≡ wrap b cb
                                -- ctfcb : tob (fromb b) ≡ b, tcfb  : Can (tob (fromb b))
  rewrite
    ctfcb                       -- Goal: wrap b tcfb ≡ wrap b cb
  | can-unique cb tcfb          -- Goal: wrap b tcfb ≡ wrap b tcfb
  = refl

------------------------------------------------------------------------------
-- BIJECTIVE BINARY NUMBERING -- TODO
-- Isomorphism between ℕ and some binary encoding (without awkward non-canonical values).
-- Via using digits 1 and 2 (instead of 0 and 1) where the multiplier/base is still 2.
-- e.g., <empty>, 1, 2, 11, 12, 21, 22, 111, ...

data Bij-ℕ : Set where
  bits :         Bij-ℕ
  _x1  : Bij-ℕ → Bij-ℕ
  _x2  : Bij-ℕ → Bij-ℕ

--------------------------------------------------
incBij-ℕ : Bij-ℕ → Bij-ℕ
incBij-ℕ   bits  = bits x1
incBij-ℕ (bj x1) = bj x2
incBij-ℕ (bj x2) = (incBij-ℕ bj) x1

_ : incBij-ℕ  bits        ≡ bits       x1
_ = refl
_ : incBij-ℕ (bits    x1) ≡ bits       x2
_ = refl
_ : incBij-ℕ (bits    x2) ≡ bits    x1 x1
_ = refl
_ : incBij-ℕ (bits x1 x1) ≡ bits    x1 x2
_ = refl
_ : incBij-ℕ (bits x1 x2) ≡ bits    x2 x1
_ = refl
_ : incBij-ℕ (bits x2 x1) ≡ bits    x2 x2
_ = refl
_ : incBij-ℕ (bits x2 x2) ≡ bits x1 x1 x1
_ = refl

--------------------------------------------------
toBij-ℕ : ℕ → Bij-ℕ
toBij-ℕ  zero   = bits
toBij-ℕ (suc n) = incBij-ℕ (toBij-ℕ n)

_ : toBij-ℕ  0 ≡ bits
_ = refl
_ : toBij-ℕ  1 ≡ bits          x1
_ = refl
_ : toBij-ℕ  2 ≡ bits          x2
_ = refl
_ : toBij-ℕ  3 ≡ bits       x1 x1
_ = refl
_ : toBij-ℕ  4 ≡ bits       x1 x2
_ = refl
_ : toBij-ℕ  5 ≡ bits       x2 x1
_ = refl
_ : toBij-ℕ  6 ≡ bits       x2 x2
_ = refl
_ : toBij-ℕ  7 ≡ bits    x1 x1 x1
_ = refl
_ : toBij-ℕ  8 ≡ bits    x1 x1 x2
_ = refl
_ : toBij-ℕ  9 ≡ bits    x1 x2 x1
_ = refl
_ : toBij-ℕ 10 ≡ bits    x1 x2 x2
_ = refl
_ : toBij-ℕ 11 ≡ bits    x2 x1 x1
_ = refl
_ : toBij-ℕ 12 ≡ bits    x2 x1 x2
_ = refl
_ : toBij-ℕ 14 ≡ bits    x2 x2 x2
_ = refl
_ : toBij-ℕ 16 ≡ bits x1 x1 x1 x2
_ = refl
_ : toBij-ℕ 18 ≡ bits x1 x1 x2 x2
_ = refl
_ : toBij-ℕ 20 ≡ bits x1 x2 x1 x2
_ = refl
-------------------------
_ : toBij-ℕ  0 ≡ bits
_ = refl
_ : toBij-ℕ  0 ≡ bits
_ = refl
-------------------------
_ : toBij-ℕ  1 ≡ bits          x1
_ = refl
_ : toBij-ℕ  2 ≡ bits          x2
_ = refl
-------------------------
_ : toBij-ℕ  2 ≡ bits          x2
_ = refl
_ : toBij-ℕ  4 ≡ bits       x1 x2
_ = refl
-------------------------
_ : toBij-ℕ  3 ≡ bits       x1 x1
_ = refl
_ : toBij-ℕ  6 ≡ bits       x2 x2
_ = refl
-------------------------
_ : toBij-ℕ  4 ≡ bits       x1 x2
_ = refl
_ : toBij-ℕ  8 ≡ bits    x1 x1 x2
_ = refl
-------------------------
_ : toBij-ℕ  5 ≡ bits       x2 x1
_ = refl
_ : toBij-ℕ 10 ≡ bits    x1 x2 x2
_ = refl
-------------------------
_ : toBij-ℕ  6 ≡ bits       x2 x2
_ = refl
_ : toBij-ℕ 12 ≡ bits    x2 x1 x2
_ = refl
-------------------------
_ : toBij-ℕ  7 ≡ bits    x1 x1 x1
_ = refl
_ : toBij-ℕ 14 ≡ bits    x2 x2 x2
_ = refl
-------------------------
_ : toBij-ℕ  8 ≡ bits    x1 x1 x2
_ = refl
_ : toBij-ℕ 16 ≡ bits x1 x1 x1 x2
_ = refl
-------------------------
_ : toBij-ℕ  9 ≡ bits    x1 x2 x1
_ = refl
_ : toBij-ℕ 18 ≡ bits x1 x1 x2 x2
_ = refl
-------------------------
_ : toBij-ℕ 10 ≡ bits    x1 x2 x2
_ = refl
_ : toBij-ℕ 20 ≡ bits x1 x2 x1 x2
_ = refl
-------------------------

--------------------------------------------------
fromBij-ℕ : Bij-ℕ → ℕ
fromBij-ℕ  bj = fbj bj 0
 where
  fbj : Bij-ℕ → ℕ → ℕ
  fbj bits    _ = zero
  fbj (bj x1) n = (1 * (2 ^ n)) + fbj bj (n + 1)
  fbj (bj x2) n = (2 * (2 ^ n)) + fbj bj (n + 1)

_ : fromBij-ℕ (bits) ≡ 0
_ = refl
_ : fromBij-ℕ (bits          x1)  ≡  1
_ = refl
_ : fromBij-ℕ (bits          x2)  ≡  2
_ = refl
_ : fromBij-ℕ (bits       x1 x1)  ≡  3
_ = refl
_ : fromBij-ℕ (bits       x1 x2)  ≡  4
_ = refl
_ : fromBij-ℕ (bits       x2 x1)  ≡  5
_ = refl
_ : fromBij-ℕ (bits       x2 x2)  ≡  6
_ = refl
_ : fromBij-ℕ (bits    x1 x1 x1)  ≡  7
_ = refl
_ : fromBij-ℕ (bits    x1 x1 x2)  ≡  8
_ = refl
_ : fromBij-ℕ (bits    x1 x2 x1)  ≡  9
_ = refl
_ : fromBij-ℕ (bits    x1 x2 x2)  ≡ 10
_ = refl
_ : fromBij-ℕ (bits x1 x2 x1 x2)  ≡ 20
_ = refl

--------------------------------------------------
doubleBij-ℕ : Bij-ℕ → Bij-ℕ
doubleBij-ℕ  bits   = bits
doubleBij-ℕ (bj x1) = {!!}
doubleBij-ℕ (bj x2) = {!!}

--------------------------------------------------
xxx : ∀ {n : ℕ} → fromBij-ℕ (toBij-ℕ n) ≡ n
xxx {zero}  = refl
xxx {suc n} = {! !}

--------------------------------------------------
-- Prove the isomorphism between ℕ and Bij-ℕ.
-- Largely follows outline of above.

iso-ℕ-Bij-ℕ : ℕ ≃ Bij-ℕ
to      iso-ℕ-Bij-ℕ n   = toBij-ℕ n
from    iso-ℕ-Bij-ℕ bjn = fromBij-ℕ bjn
from∘to iso-ℕ-Bij-ℕ n   = {!!}
to∘from iso-ℕ-Bij-ℕ bjn = {!!}


module Numeral.Natural.Relation.Order.Proofs where

import Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Induction
open import Numeral.Natural.Relation.Order
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Relator
import      Structure.Relator.Names as Names
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Operator.Properties
open import Structure.Relator.Ordering
open import Structure.Relator.Properties
open import Structure.Relator.Properties.Proofs
open import Syntax.Transitivity
open import Type.Properties.MereProposition
open import Type

-- TODO: A method for pattern matching: https://stackoverflow.com/questions/20682013/agda-why-am-i-unable-to-pattern-match-on-refl

instance
  [≤]-succ-injectivity : ∀{x y} → Injective(succ{x}{y})
  Injective.proof [≤]-succ-injectivity [≡]-intro = [≡]-intro

instance
  [≤]-mereProposition : ∀{x y} → MereProposition(x ≤ y)
  MereProposition.uniqueness [≤]-mereProposition {min}    {min}    = [≡]-intro
  MereProposition.uniqueness [≤]-mereProposition {succ x} {succ y} = congruence₁(succ) (MereProposition.uniqueness [≤]-mereProposition {x}{y})

instance
  [≤]-minimum = \{y} → _≤_.min {y}
  [≤]-with-[𝐒] = \{x}{y} ⦃ xy ⦄ → _≤_.succ {x}{y} xy
[<]-minimum = \{y} → succ([≤]-minimum {y})

[≡]-to-[≤] : ∀{x y : ℕ} → (x ≡ y) → (x ≤ y)
[≡]-to-[≤] {𝟎}   {_}    _         = [≤]-minimum
[≡]-to-[≤] {𝐒(x)}{𝐒(y)} [≡]-intro = succ([≡]-to-[≤] {x}{y} [≡]-intro)

[≡]-to-[≥] : ∀{x y : ℕ} → (x ≡ y) → (x ≥ y)
[≡]-to-[≥] = [≡]-to-[≤] ∘ symmetry(_≡_)

[≰]-to-[≢] : ∀{x y : ℕ} → (x ≰ y) → (x ≢ y)
[≰]-to-[≢] = contrapositiveᵣ [≡]-to-[≤]

[≱]-to-[≢] : ∀{x y : ℕ} → (x ≱ y) → (x ≢ y)
[≱]-to-[≢] = contrapositiveᵣ [≡]-to-[≥]

[≤][0]ᵣ : ∀{x : ℕ} → (x ≤ 0) → (x ≡ 0)
[≤][0]ᵣ {𝟎}    (_) = [≡]-intro
[≤][0]ᵣ {𝐒(_)} ()

[≤][0]ᵣ-negation : ∀{x : ℕ} → (𝐒(x) ≰ 0)
[≤][0]ᵣ-negation ()

[≤]-successor : ∀{x y : ℕ} → (x ≤ y) → (x ≤ 𝐒(y))
[≤]-successor {𝟎}   {_}    (_) = [≤]-minimum
[≤]-successor {𝐒(x)}{𝟎}    ()
[≤]-successor {𝐒(x)}{𝐒(y)} (succ proof) = succ([≤]-successor {x}{y} (proof))

[≤]-predecessor : ∀{x y : ℕ} → (𝐒(x) ≤ y) → (x ≤ y)
[≤]-predecessor {x}   {𝟎}    ()
[≤]-predecessor {𝟎}   {𝐒(y)} (_) = [≤]-minimum
[≤]-predecessor {𝐒(x)}{𝐒(y)} (succ proof) = succ([≤]-predecessor {x}{y} (proof))

[≤]-without-[𝐒] : ∀{x y : ℕ} → (𝐒(x) ≤ 𝐒(y)) → (x ≤ y)
[≤]-without-[𝐒] (succ proof) = proof

[≤][𝐒]ₗ : ∀{x : ℕ} → ¬(𝐒(x) ≤ x)
[≤][𝐒]ₗ {𝟎}    (1≤0)    = [≤][0]ᵣ-negation{0}(1≤0)
[≤][𝐒]ₗ {𝐒(n)} (SSn≤Sn) = [≤][𝐒]ₗ {n} ([≤]-without-[𝐒] {𝐒(n)}{n} (SSn≤Sn))

instance
  [≤]-reflexivity : Reflexivity (_≤_)
  Reflexivity.proof([≤]-reflexivity) = [≡]-to-[≤] [≡]-intro

instance
  [≤]-transitivity : Transitivity (_≤_)
  Transitivity.proof([≤]-transitivity) = proof where
    proof : Names.Transitivity (_≤_)
    proof {𝟎}   {_}   {_} (_)(_) = [≤]-minimum
    proof {𝐒(a)}{𝐒(b)}{𝐒(c)} (succ proofₗ) (succ proofᵣ ) =
      succ(proof {a}{b}{c} (proofₗ) (proofᵣ))

instance
  [≤]-antisymmetry : Antisymmetry (_≤_) (_≡_)
  Antisymmetry.proof([≤]-antisymmetry) = proof where
    proof : Names.Antisymmetry (_≤_) (_≡_)
    proof {𝟎}    {𝟎}    (_) (_) = [≡]-intro
    proof {𝐒(_)} {𝟎}    ()
    proof {𝟎}    {𝐒(_)} (_) ()
    proof {𝐒(a)} {𝐒(b)} (succ proofₗ) (succ proofᵣ) =
      [≡]-with(𝐒) (proof {a}{b} proofₗ proofᵣ)

instance
  [≤]-totality : ConverseTotal(_≤_)
  ConverseTotal.proof([≤]-totality) = proof where
    proof : Names.ConverseTotal(_≤_)
    proof {𝟎}   {𝟎}    = [∨]-introₗ ([≡]-to-[≤] [≡]-intro)
    proof {𝐒(a)}{𝟎}    = [∨]-introᵣ ([≤]-minimum)
    proof {𝟎}   {𝐒(b)} = [∨]-introₗ ([≤]-minimum)
    proof {𝐒(a)}{𝐒(b)} = [∨]-elim ([∨]-introₗ ∘ (proof ↦ [≤]-with-[𝐒] {a}{b} ⦃ proof ⦄)) ([∨]-introᵣ ∘ (proof ↦ [≤]-with-[𝐒] {b}{a} ⦃ proof ⦄)) (proof {a}{b})

instance
  [≤]-weakPartialOrder : Weak.PartialOrder (_≤_) (_≡_)
  [≤]-weakPartialOrder = record{}

instance
  [≤]-weakTotalOrder : Weak.TotalOrder (_≤_) (_≡_)
  [≤]-weakTotalOrder = record{}

instance
  [≥]-reflexivity : Reflexivity (_≥_)
  Reflexivity.proof([≥]-reflexivity) = Reflexivity.proof([≤]-reflexivity)

instance
  [≥]-transitivity : Transitivity (_≥_)
  Transitivity.proof([≥]-transitivity) = swap(Transitivity.proof([≤]-transitivity))

instance
  [≥]-antisymmetry : Antisymmetry (_≥_) (_≡_)
  Antisymmetry.proof([≥]-antisymmetry) = swap(Antisymmetry.proof([≤]-antisymmetry))

instance
  [≥]-totality : ConverseTotal(_≥_)
  ConverseTotal.proof([≥]-totality) = ConverseTotal.proof([≤]-totality)

instance
  [≥]-weakPartialOrder : Weak.PartialOrder (_≥_) (_≡_)
  [≥]-weakPartialOrder = record{}

instance
  [≥]-weakTotalOrder : Weak.TotalOrder (_≥_) (_≡_)
  [≥]-weakTotalOrder = record{}

[≥]-to-[≮] : ∀{a b : ℕ} → (a ≮ b) ← (a ≥ b)
[≥]-to-[≮] {a}{b} (b≤a) (𝐒a≤b) = [≤][𝐒]ₗ (transitivity(_≤_) {𝐒(a)}{b}{a} (𝐒a≤b) (b≤a))

[≤]-to-[≯] : ∀{a b : ℕ} → (a ≯ b) ← (a ≤ b)
[≤]-to-[≯] {a}{b} (a≤b) (𝐒b≤a) = [≥]-to-[≮] {b}{a} (a≤b) (𝐒b≤a)

[>]-to-[≰] : ∀{a b : ℕ} → (a ≰ b) ← (a > b)
[>]-to-[≰] {a}{b} (𝐒b≤a) (a≤b) = [≤]-to-[≯] (a≤b) (𝐒b≤a)

[<]-to-[≱] : ∀{a b : ℕ} → (a ≱ b) ← (a < b)
[<]-to-[≱] {a}{b} (𝐒a≤b) (b≤a) = [≥]-to-[≮] (b≤a) (𝐒a≤b)

[<]-to-[≢] : ∀{a b : ℕ} → (a < b) → (a ≢ b)
[<]-to-[≢] = [≱]-to-[≢] ∘ [<]-to-[≱]

[>]-to-[≢] : ∀{a b : ℕ} → (a > b) → (a ≢ b)
[>]-to-[≢] = [≰]-to-[≢] ∘ [>]-to-[≰]

[<][0]ᵣ : ∀{x : ℕ} → (x ≮ 0)
[<][0]ᵣ = [≤][0]ᵣ-negation

instance
  [<]-irreflexivity : Irreflexivity (_<_)
  Irreflexivity.proof([<]-irreflexivity) = [≤][𝐒]ₗ

instance
  [<]-transitivity : Transitivity (_<_)
  Transitivity.proof([<]-transitivity) {x}{y}{z} (l) (r) = Transitivity.proof([≤]-transitivity) {𝐒(x)} {𝐒(y)} {z} ([≤]-successor (l)) (r)

instance
  [<]-asymmetry : Asymmetry (_<_)
  Asymmetry.proof([<]-asymmetry) (l) (r) = Irreflexivity.proof([<]-irreflexivity) (Transitivity.proof([<]-transitivity) (l) (r))

instance
  [<]-converseTrichotomy : ConverseTrichotomy(_<_)(_≡_)
  ConverseTrichotomy.proof [<]-converseTrichotomy = p where
    p : Names.ConverseTrichotomy(_<_)(_≡_)
    p {𝟎}   {𝟎}   = [∨]-introₗ ([∨]-introᵣ [≡]-intro)
    p {𝟎}   {𝐒 y} = [∨]-introₗ ([∨]-introₗ [≤]-with-[𝐒])
    p {𝐒 x} {𝟎}   = [∨]-introᵣ [≤]-with-[𝐒]
    p {𝐒 x} {𝐒 y} with p {x} {y}
    ... | [∨]-introₗ ([∨]-introₗ (succ xy)) = [∨]-introₗ ([∨]-introₗ (succ (succ xy)))
    ... | [∨]-introₗ ([∨]-introᵣ [≡]-intro) = [∨]-introₗ ([∨]-introᵣ [≡]-intro)
    ... | [∨]-introᵣ (succ xy)              = [∨]-introᵣ (succ (succ xy))

instance
  [<]-strictPartialOrder : Strict.PartialOrder (_<_)
  [<]-strictPartialOrder = record{}

instance
  [<]-strictTotalOrder : Strict.TotalOrder (_<_)(_≡_)
  [<]-strictTotalOrder = record{}

instance
  [>]-irreflexivity : Irreflexivity (_>_)
  Irreflexivity.proof([>]-irreflexivity) = Irreflexivity.proof([<]-irreflexivity)

instance
  [>]-transitivity : Transitivity (_>_)
  Transitivity.proof([>]-transitivity) = swap(Transitivity.proof([<]-transitivity))

instance
  [>]-asymmetry : Asymmetry (_>_)
  Asymmetry.proof([>]-asymmetry) = swap(Asymmetry.proof([<]-asymmetry))

instance
  [>]-strictOrder : Strict.PartialOrder (_>_)
  [>]-strictOrder = record{}

[<]-of-[𝐒] : ∀{x : ℕ} → (x < 𝐒(x))
[<]-of-[𝐒] = reflexivity(_≤_)

[<]-of-[𝟎][𝐒] : ∀{x : ℕ} → (𝟎 < 𝐒(x))
[<]-of-[𝟎][𝐒] {𝟎} = [<]-of-[𝐒]
[<]-of-[𝟎][𝐒] {𝐒 x} = succ([≤]-minimum)

instance
  [≤]-of-[𝐒] : ∀{x : ℕ} → (x ≤ 𝐒(x))
  [≤]-of-[𝐒] = [≤]-successor(reflexivity(_≤_))

[<][≢]-equivalence : ∀{x} → (x > 0) ↔ (x ≢ 0)
[<][≢]-equivalence {x} = [↔]-intro (l{x}) (r{x}) where
  l : ∀{x} → (x > 0) ← (x ≢ 0)
  l{𝟎}    (x≢𝟎)  = [⊥]-elim((x≢𝟎)([≡]-intro))
  l{𝐒(x)} (𝐒x≢𝟎) = succ([≤]-minimum)

  r : ∀{x} → (x > 0) → (x ≢ 0)
  r{𝟎}    ()
  r{𝐒(x)} (𝟏≤𝐒x) (𝐒x≡𝟎) with [≡]-substitutionᵣ (𝐒x≡𝟎) {expr ↦ 1 ≤ expr} (𝟏≤𝐒x)
  ... | ()

[≤]-to-[<][≡] : ∀{a b : ℕ} → (a ≤ b) → (a < b)∨(a ≡ b)
[≤]-to-[<][≡] {𝟎}   {𝟎}    ([≤]-minimum)    = [∨]-introᵣ([≡]-intro)
[≤]-to-[<][≡] {𝟎}   {𝐒(b)} ([≤]-minimum)    = [∨]-introₗ([<]-minimum)
[≤]-to-[<][≡] {𝐒(a)}{𝐒(b)} (succ(a≤b)) with [≤]-to-[<][≡] {a}{b} (a≤b)
... | [∨]-introₗ(a<b) = [∨]-introₗ(succ(a<b))
... | [∨]-introᵣ(a≡b) = [∨]-introᵣ([≡]-with(𝐒) (a≡b))

[≮][≢]-to-[≰] : ∀{a b : ℕ} → (a ≮ b) → (a ≢ b) → (a ≰ b)
[≮][≢]-to-[≰] (a≮b) (a≢b) (a≤b) with [≤]-to-[<][≡] (a≤b)
... | [∨]-introₗ (a<b) = a≮b a<b
... | [∨]-introᵣ (a≡b) = a≢b a≡b

[<][≡]-to-[≤] : ∀{a b : ℕ} → (a < b)∨(a ≡ b) → (a ≤ b)
[<][≡]-to-[≤] {a}   {.a}   ([∨]-introᵣ([≡]-intro)) = [≡]-to-[≤] ([≡]-intro)
[<][≡]-to-[≤] {a}   {b}    ([∨]-introₗ(a<b))       = [≤]-predecessor (a<b)

instance
  [<][≤]-sub : (_<_) ⊆₂ (_≤_)
  [<][≤]-sub = intro [≤]-predecessor

instance
  [>][≥]-sub : (_>_) ⊆₂ (_≥_)
  [>][≥]-sub = intro(sub₂(_<_)(_≤_))

[≰]-to-[≮] : ∀{x y : ℕ} → (x ≰ y) → (x ≮ y)
[≰]-to-[≮] = contrapositiveᵣ (sub₂(_<_)(_≤_))

[≥]-to-[>][≡] : ∀{a b : ℕ} → (a ≥ b) → (a > b)∨(a ≡ b)
[≥]-to-[>][≡] {a}{b} (proof) with [≤]-to-[<][≡] {b}{a} (proof)
... | [∨]-introₗ(a<b) = [∨]-introₗ(a<b)
... | [∨]-introᵣ(b≡a) = [∨]-introᵣ(symmetry(_≡_) (b≡a))

[<]-trichotomy : ∀{x y} → (x < y) ∨ (x ≡ y) ∨ (x > y)
[<]-trichotomy {x}{y} with converseTotal(_≤_) ⦃ [≤]-totality ⦄
[<]-trichotomy {x}{y} | [∨]-introₗ x≤y with [≤]-to-[<][≡] {x}{y} x≤y
[<]-trichotomy {x}{y} | [∨]-introₗ x≤y | [∨]-introₗ x<y = [∨]-introₗ ([∨]-introₗ x<y)
[<]-trichotomy {x}{y} | [∨]-introₗ x≤y | [∨]-introᵣ x≡y = [∨]-introₗ ([∨]-introᵣ x≡y)
[<]-trichotomy {x}{y} | [∨]-introᵣ y≤x with [≥]-to-[>][≡] {x}{y} y≤x
[<]-trichotomy {x}{y} | [∨]-introᵣ y≤x | [∨]-introₗ y<x = [∨]-introᵣ y<x
[<]-trichotomy {x}{y} | [∨]-introᵣ y≤x | [∨]-introᵣ y≡x = [∨]-introₗ ([∨]-introᵣ y≡x)

[≤][>]-dichotomy : ∀{x y} → (x ≤ y) ∨ (x > y)
[≤][>]-dichotomy {x}{y} with [<]-trichotomy {x}{y}
[≤][>]-dichotomy {x} {y} | [∨]-introₗ ([∨]-introₗ x<y) = [∨]-introₗ(sub₂(_<_)(_≤_) x<y)
[≤][>]-dichotomy {x} {y} | [∨]-introₗ ([∨]-introᵣ x≡y) = [∨]-introₗ(sub₂(_≡_)(_≤_) x≡y)
[≤][>]-dichotomy {x} {y} | [∨]-introᵣ x>y              = [∨]-introᵣ(x>y)

[<][≥]-dichotomy : ∀{x y} → (x < y) ∨ (x ≥ y)
[<][≥]-dichotomy {x}{y} = [∨]-symmetry([≤][>]-dichotomy {y}{x})

[≯][≢]-to-[≱] : ∀{a b : ℕ} → (a ≯ b) → (a ≢ b) → (a ≱ b)
[≯][≢]-to-[≱] (a≯b) (a≢b) (a≥b) with [≥]-to-[>][≡] (a≥b)
... | [∨]-introₗ (a>b) = a≯b a>b
... | [∨]-introᵣ (a≡b) = a≢b a≡b

[>][≡]-to-[≥] : ∀{a b : ℕ} → (a > b)∨(a ≡ b) → (a ≥ b)
[>][≡]-to-[≥] {a}{b} ([∨]-introₗ(a<b)) = [<][≡]-to-[≤] {b}{a} ([∨]-introₗ(a<b))
[>][≡]-to-[≥] {a}{b} ([∨]-introᵣ(b≡a)) = [<][≡]-to-[≤] {b}{a} ([∨]-introᵣ(symmetry(_≡_)(b≡a)))

[>]-to-[≥] : ∀{a b : ℕ} → (a > b) → (a ≥ b)
[>]-to-[≥] {a}{b} (a<b) = [<][≡]-to-[≤] {b}{a} ([∨]-introₗ(a<b))

[≱]-to-[≯] : ∀{x y : ℕ} → (x ≱ y) → (x ≯ y)
[≱]-to-[≯] = contrapositiveᵣ [>]-to-[≥]

[≮][≯]-to-[≡] : ∀{a b : ℕ} → (a ≮ b) → (a ≯ b) → (a ≡ b)
[≮][≯]-to-[≡] {a}{b} (a≮b) (a≯b) with [<]-trichotomy {a}{b}
... | [∨]-introₗ ([∨]-introₗ a<b) = [⊥]-elim(a≮b a<b)
... | [∨]-introₗ ([∨]-introᵣ a≡b) = a≡b
... | [∨]-introᵣ b<a              = [⊥]-elim(a≯b b<a)

[≮][≢][≯]-not : ∀{a b : ℕ} → (a ≮ b) → (a ≢ b) → (a ≯ b) → ⊥
[≮][≢][≯]-not {a}{b} (a≮b) (a≢b) (a≯b) with [<]-trichotomy {a}{b}
... | [∨]-introₗ ([∨]-introₗ a<b) = a≮b a<b
... | [∨]-introₗ ([∨]-introᵣ a≡b) = a≢b a≡b
... | [∨]-introᵣ b<a              = a≯b b<a

[≰][≯]-not : ∀{a b : ℕ} → (a ≰ b) → (a ≯ b) → ⊥
[≰][≯]-not {a}{b} (a≰b) (a≯b) = [≮][≢][≯]-not ([≰]-to-[≮] a≰b) ([≰]-to-[≢] a≰b) (a≯b)

[≮][≱]-not : ∀{a b : ℕ} → (a ≮ b) → (a ≱ b) → ⊥
[≮][≱]-not {a}{b} (a≮b) (a≱b) = [≮][≢][≯]-not (a≮b) ([≱]-to-[≢] a≱b) ([≱]-to-[≯] a≱b)

[<]-non-zero-existence : ∀{a b : ℕ} → (a < b) → (𝟎 < b)
[<]-non-zero-existence (succ _) = [<]-of-[𝟎][𝐒]

[≢]-to-[<]-of-0ᵣ : ∀{n} → (n ≢ 0) → (0 < n)
[≢]-to-[<]-of-0ᵣ {𝟎}   p with () ← p [≡]-intro
[≢]-to-[<]-of-0ᵣ {𝐒 n} p = succ min

[≤][≢]-to-[<] : ∀{a b : ℕ} → (a ≤ b) → (a ≢ b) → (a < b)
[≤][≢]-to-[<] {.𝟎}     {b}      min       ne = [≢]-to-[<]-of-0ᵣ (ne ∘ symmetry(_≡_))
[≤][≢]-to-[<] {.(𝐒 _)} {.(𝐒 _)} (succ lt) ne = succ([≤][≢]-to-[<] lt (ne ∘ congruence₁(𝐒)))

instance
  [≤][≡]-subtransitivityₗ : Subtransitivityₗ(_≤_)(_≡_)
  [≤][≡]-subtransitivityₗ = subrelation-transitivity-to-subtransitivityₗ

instance
  [≤][≡]-subtransitivityᵣ : Subtransitivityᵣ(_≤_)(_≡_)
  [≤][≡]-subtransitivityᵣ = subrelation-transitivity-to-subtransitivityᵣ

instance
  [≥][≡]-subtransitivityₗ : Subtransitivityₗ(_≥_)(_≡_)
  [≥][≡]-subtransitivityₗ = subrelation-transitivity-to-subtransitivityₗ

instance
  [≥][≡]-subtransitivityᵣ : Subtransitivityᵣ(_≥_)(_≡_)
  [≥][≡]-subtransitivityᵣ = subrelation-transitivity-to-subtransitivityᵣ

instance
  [<][≤]-subtransitivityₗ : Subtransitivityₗ(_≤_)(_<_)
  [<][≤]-subtransitivityₗ = subrelation-transitivity-to-subtransitivityₗ

instance
  [<][≤]-subtransitivityᵣ : Subtransitivityᵣ(_≤_)(_<_)
  [<][≤]-subtransitivityᵣ = subrelation-transitivity-to-subtransitivityᵣ

instance
  [>][≥]-subtransitivityₗ : Subtransitivityₗ(_≥_)(_>_)
  [>][≥]-subtransitivityₗ = subrelation-transitivity-to-subtransitivityₗ

instance
  [>][≥]-subtransitivityᵣ : Subtransitivityᵣ(_≥_)(_>_)
  [>][≥]-subtransitivityᵣ = subrelation-transitivity-to-subtransitivityᵣ

instance
  [>][≡]-subtransitivityₗ : Subtransitivityₗ(_>_)(_≡_)
  Subtransitivityₗ.proof [>][≡]-subtransitivityₗ = substitute₂ₗ(_>_) ∘ symmetry(_≡_)

instance
  [>][≡]-subtransitivityᵣ : Subtransitivityᵣ(_>_)(_≡_)
  Subtransitivityᵣ.proof [>][≡]-subtransitivityᵣ = swap(substitute₂ᵣ(_>_))

instance
  [<][≡]-subtransitivityₗ : Subtransitivityₗ(_<_)(_≡_)
  Subtransitivityₗ.proof [<][≡]-subtransitivityₗ = substitute₂ₗ(_<_) ∘ symmetry(_≡_)

instance
  [<][≡]-subtransitivityᵣ : Subtransitivityᵣ(_<_)(_≡_)
  Subtransitivityᵣ.proof [<][≡]-subtransitivityᵣ = swap(substitute₂ᵣ(_<_))


module Monoids where

open import Library

record Monoid {a} : Set (lsuc a) where
  field S   : Set a
        ε   : S
        _•_ : S → S → S
        lid : ∀{m} → ε • m ≅ m
        rid : ∀{m} → m • ε ≅ m
        ass : ∀{m n o} → (m • n) • o ≅ m • (n • o)

  infix 10 _•_

Nat+Mon : Monoid
Nat+Mon = record {
  S   = ℕ;
  ε   = zero;
  _•_ = _+_;
  lid = refl;
  rid = ≡-to-≅ $ +-right-identity _;
  ass = λ{m} → ≡-to-≅ $ +-assoc m _ _}


module Numeral.Natural.Oper where

open import Numeral.Natural

infixl 10010 _+_
infix  10010 _−₀_ _𝄩_
infixl 10020 _⋅_
-- infix  10020 _/₀_
infixl 10030 _^_

-- TODO: It would require a great amount of work, but consider changing the induction to being on the left side instead of the right on _+_ and _⋅_. It will then mirror how lists (a similar structure) uses induction in its definition. The advantage of having it on the right side as it is now is that induction using the full operator name is easier: ℕ-induction(_+_ a) vs ℕ-induction(a ↦ _+_ a b)

-- Addition
_+_ : ℕ → ℕ → ℕ
x + 𝟎 = x
x + 𝐒(y) = 𝐒(x + y)
{-# BUILTIN NATPLUS _+_ #-}

-- Multiplication
_⋅_ : ℕ → ℕ → ℕ
_ ⋅ 𝟎 = 𝟎
x ⋅ 𝐒(y) = x + (x ⋅ y)
{-# BUILTIN NATTIMES _⋅_ #-}

-- Exponentiation
_^_ : ℕ → ℕ → ℕ
x ^ 𝟎 = 𝐒(𝟎)
x ^ 𝐒(y) = x ⋅ (x ^ y)

-- Factorial
_! : ℕ → ℕ
𝟎 ! = 𝐒(𝟎)
𝐒(x) ! = 𝐒(x) ⋅ (x !)

-- Distance (Absolute subtraction) (Interval length)
_𝄩_ : ℕ → ℕ → ℕ
𝟎    𝄩 𝟎    = 𝟎
𝐒(x) 𝄩 𝟎    = 𝐒(x)
𝟎    𝄩 𝐒(x) = 𝐒(x)
𝐒(x) 𝄩 𝐒(y) = x 𝄩 y

-- Closed total subtraction (monus)
_−₀_ : ℕ → ℕ → ℕ
x    −₀ 𝟎    = x
𝟎    −₀ 𝐒(_) = 𝟎
𝐒(x) −₀ 𝐒(y) = x −₀ y
{-# BUILTIN NATMINUS _−₀_ #-}

-- Closed total ceiled division (rounding up)
{-# TERMINATING #-}
_⌈/₀⌉_ : ℕ → ℕ → ℕ
𝟎 ⌈/₀⌉ y = 𝟎
{-# CATCHALL #-}
x ⌈/₀⌉ 𝟎 = 𝟎
{-# CATCHALL #-}
x ⌈/₀⌉ y = 𝐒((x −₀ y) ⌈/₀⌉ y)

-- Hyperoperation: (a ↑[n]↑ b) where (n=0)⇒(_ ↦ 𝐒) , (n=1)⇒(+) , (n=2)⇒(⋅) , (n=3)⇒(^)
_↑[_]↑_ : ℕ → ℕ → ℕ → ℕ
_ ↑[ 0          ]↑ b = 𝐒(b)
a ↑[ 1          ]↑ 0 = a
_ ↑[ 2          ]↑ 0 = 0
_ ↑[ 𝐒(𝐒(𝐒(n))) ]↑ 0 = 1
{-# CATCHALL #-}
a ↑[ 𝐒(n)       ]↑ (𝐒(b)) = a ↑[ n ]↑ (a ↑[ n ]↑ b)


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.Instances.Int where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.CommRing
open import Cubical.Data.Int as Int
  renaming ( ℤ to ℤ ; _+_ to _+ℤ_; _·_ to _·ℤ_; -_ to -ℤ_)

open CommRingStr using (0r ; 1r ; _+_ ; _·_ ; -_ ; isCommRing)

ℤCommRing : CommRing ℓ-zero
fst ℤCommRing = ℤ
0r (snd ℤCommRing) = 0
1r (snd ℤCommRing) = 1
_+_ (snd ℤCommRing) = _+ℤ_
_·_ (snd ℤCommRing) = _·ℤ_
- snd ℤCommRing = -ℤ_
isCommRing (snd ℤCommRing) = isCommRingℤ
  where
  abstract
    isCommRingℤ : IsCommRing 0 1 _+ℤ_ _·ℤ_ -ℤ_
    isCommRingℤ = makeIsCommRing isSetℤ Int.+Assoc (λ _ → refl)
                                 -Cancel Int.+Comm Int.·Assoc
                                 Int.·Rid ·DistR+ Int.·Comm


module UniDB.Morph.Star where

open import UniDB.Spec

infixl 4 _▻_
data Star (Ξ : MOR) : MOR where
  ε   : {γ : Dom} → Star Ξ γ γ
  _▻_ : {γ₁ γ₂ γ₃ : Dom} (ξs : Star Ξ γ₁ γ₂) (ξ : Ξ γ₂ γ₃) → Star Ξ γ₁ γ₃

module _ {Ξ : MOR} where
  instance
    iIdmStar : Idm (Star Ξ)
    idm {{iIdmStar}} _ = ε

    iCompStar : Comp (Star Ξ)
    _⊙_ {{iCompStar}} ξs ε = ξs
    _⊙_ {{iCompStar}} ξs (ζs ▻ ζ) = (ξs ⊙ ζs) ▻ ζ

module _ {Ξ : MOR} {{upΞ : Up Ξ}} where

  instance
    iUpStar : Up (Star Ξ)
    _↑₁ {{iUpStar}} ε        = ε
    _↑₁ {{iUpStar}} (ξs ▻ ξ) = (ξs ↑₁) ▻ (ξ ↑₁)
    _↑_ {{iUpStar}} ξ 0 = ξ
    _↑_ {{iUpStar}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
    ↑-zero {{iUpStar}} ξ = refl
    ↑-suc {{iUpStar}} ξ δ⁺ = refl

    iUpIdmStar : UpIdm (Star Ξ)
    idm-↑₁ {{iUpIdmStar}} = refl

    iUpCompStar : UpComp (Star Ξ)
    ⊙-↑₁ {{iUpCompStar}} ξs ε        = refl
    ⊙-↑₁ {{iUpCompStar}} ξs (ζs ▻ ζ) =
      cong₂ _▻_ (⊙-↑₁ {Star Ξ} ξs ζs ) (refl {x = ζ ↑₁})


module Logic.Predicate.Multi where

open import Data.Tuple.RaiseTypeᵣ
open import Function.Multi
open import Function.Multi.Functions
open import Numeral.Natural
open import Logic.Predicate
open import Logic

-- Universal quantification of multiple variables.
-- Example:
--   ∀₊(3) P = ∀{x}{y}{z} → P(x)(y)(z)
∀₊ : (n : ℕ) → ∀{ℓ}{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ Stmt{ℓ}) → Stmt
∀₊(n) = quantifier₊(n) ∀ₗ

-- Existential quantification of multiple variables.
-- Example:
--   ∃₊(3) P = ∃(x ↦ ∃(y ↦ ∃(z ↦ P(x)(y)(z))))
∃₊ : (n : ℕ) → ∀{ℓ}{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ Stmt{ℓ}) → Stmt
∃₊(n) = quantifier₊(n) ∃


module Type.Isomorphism where

open import Functional
import      Lvl
open import Structure.Setoid
open import Structure.Function.Domain hiding (inverseₗ ; inverseᵣ)
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level

module _
  (A : Type{ℓ₁})
  (B : Type{ℓ₂})
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  where

  record _≅_ : Type{ℓ₁ Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓₑ₂} where
    field
      left  : A ← B
      right : A → B
      ⦃ inverseₗ ⦄ : Inverseₗ(right)(left)
      ⦃ inverseᵣ ⦄ : Inverseᵣ(right)(left)


------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------

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

open import Equality

module List
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Prelude

open import Bijection eq as Bijection using (_↔_)
open Derived-definitions-and-properties eq
open import Equality.Decision-procedures eq
import Equivalence eq as Eq
open import Function-universe eq hiding (_∘_)
open import H-level eq as H-level
open import H-level.Closure eq
open import Monad eq hiding (map)
open import Nat eq
open import Nat.Solver eq

private
  variable
    a ℓ      : Level
    A B C    : Type a
    x y      : A
    f        : A → B
    n        : ℕ
    xs ys zs : List A
    ns       : List ℕ

------------------------------------------------------------------------
-- Some functions

-- The tail of a list. Returns [] if the list is empty.

tail : List A → List A
tail []       = []
tail (_ ∷ xs) = xs

-- The function take n returns the first n elements of a list (or the
-- entire list, if the list does not contain n elements).

take : ℕ → List A → List A
take zero    xs       = []
take (suc n) (x ∷ xs) = x ∷ take n xs
take (suc n) xs@[]    = xs

-- The function drop n removes the first n elements from a list (or
-- all elements, if the list does not contain n elements).

drop : ℕ → List A → List A
drop zero    xs       = xs
drop (suc n) (x ∷ xs) = drop n xs
drop (suc n) xs@[]    = xs

-- Right fold.

foldr : (A → B → B) → B → List A → B
foldr _⊕_ ε []       = ε
foldr _⊕_ ε (x ∷ xs) = x ⊕ foldr _⊕_ ε xs

-- Left fold.

foldl : (B → A → B) → B → List A → B
foldl _⊕_ ε []       = ε
foldl _⊕_ ε (x ∷ xs) = foldl _⊕_ (ε ⊕ x) xs

-- The length of a list.

length : List A → ℕ
length = foldr (const suc) 0

-- The sum of all the elements in a list of natural numbers.

sum : List ℕ → ℕ
sum = foldr _+_ 0

-- Appends two lists.

infixr 5 _++_

_++_ : List A → List A → List A
xs ++ ys = foldr _∷_ ys xs

-- Maps a function over a list.

map : (A → B) → List A → List B
map f = foldr (λ x ys → f x ∷ ys) []

-- Concatenates a list of lists.

concat : List (List A) → List A
concat = foldr _++_ []

-- "Zips" two lists, using the given function to combine elementsw.

zip-with : (A → B → C) → List A → List B → List C
zip-with f []       _        = []
zip-with f _        []       = []
zip-with f (x ∷ xs) (y ∷ ys) = f x y ∷ zip-with f xs ys

-- "Zips" two lists.

zip : List A → List B → List (A × B)
zip = zip-with _,_

-- Reverses a list.

reverse : List A → List A
reverse = foldl (λ xs x → x ∷ xs) []

-- Replicates the given value the given number of times.

replicate : ℕ → A → List A
replicate zero    x = []
replicate (suc n) x = x ∷ replicate n x

-- A filter function.

filter : (A → Bool) → List A → List A
filter p = foldr (λ x xs → if p x then x ∷ xs else xs) []

-- Finds the element at the given position.

index : (xs : List A) → Fin (length xs) → A
index []       ()
index (x ∷ xs) fzero    = x
index (x ∷ xs) (fsuc i) = index xs i

-- A lookup function.

lookup : (A → A → Bool) → A → List (A × B) → Maybe B
lookup _≟_ x []             = nothing
lookup _≟_ x ((y , z) ∷ ps) =
  if x ≟ y then just z else lookup _≟_ x ps

-- The list nats-< consists of the first n natural numbers in
-- strictly descending order.

nats-< : ℕ → List ℕ
nats-< zero    = []
nats-< (suc n) = n ∷ nats-< n

-- A list that includes every tail of the given list (including the
-- list itself) exactly once. Longer tails precede shorter ones.

tails : List A → List (List A)
tails []           = [] ∷ []
tails xxs@(_ ∷ xs) = xxs ∷ tails xs

------------------------------------------------------------------------
-- Some properties

-- If you take the first n elements from xs and append what you get if
-- you drop the first n elements from xs, then you get xs (even if n
-- is larger than the length of xs).

take++drop : ∀ n → take n xs ++ drop n xs ≡ xs
take++drop               zero    = refl _
take++drop {xs = []}     (suc n) = refl _
take++drop {xs = x ∷ xs} (suc n) = cong (x ∷_) (take++drop n)

-- The map function commutes with take n.

map-take : map f (take n xs) ≡ take n (map f xs)
map-take {n = zero}                = refl _
map-take {n = suc n} {xs = []}     = refl _
map-take {n = suc n} {xs = x ∷ xs} = cong (_ ∷_) map-take

-- The map function commutes with drop n.

map-drop : ∀ n → map f (drop n xs) ≡ drop n (map f xs)
map-drop               zero    = refl _
map-drop {xs = []}     (suc n) = refl _
map-drop {xs = x ∷ xs} (suc n) = map-drop n

-- The function foldr _∷_ [] is pointwise equal to the identity
-- function.

foldr-∷-[] : (xs : List A) → foldr _∷_ [] xs ≡ xs
foldr-∷-[] []       = refl _
foldr-∷-[] (x ∷ xs) = cong (x ∷_) (foldr-∷-[] xs)

-- The empty list is a right identity for the append function.

++-right-identity : (xs : List A) → xs ++ [] ≡ xs
++-right-identity []       = refl _
++-right-identity (x ∷ xs) = cong (x ∷_) (++-right-identity xs)

-- The append function is associative.

++-associative : (xs ys zs : List A) →
                 xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs
++-associative []       ys zs = refl _
++-associative (x ∷ xs) ys zs = cong (x ∷_) (++-associative xs ys zs)

-- The map function commutes with _++_.

map-++ : (f : A → B) (xs ys : List A) →
         map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++ f []       ys = refl _
map-++ f (x ∷ xs) ys = cong (f x ∷_) (map-++ f xs ys)

-- The concat function commutes with _++_.

concat-++ : (xss yss : List (List A)) →
            concat (xss ++ yss) ≡ concat xss ++ concat yss
concat-++ []         yss = refl _
concat-++ (xs ∷ xss) yss =
  concat ((xs ∷ xss) ++ yss)        ≡⟨⟩
  xs ++ concat (xss ++ yss)         ≡⟨ cong (xs ++_) (concat-++ xss yss) ⟩
  xs ++ (concat xss ++ concat yss)  ≡⟨ ++-associative xs _ _ ⟩
  (xs ++ concat xss) ++ concat yss  ≡⟨ refl _ ⟩∎
  concat (xs ∷ xss) ++ concat yss   ∎

-- A lemma relating foldr and _++_.

foldr-++ :
  {c : A → B → B} {n : B} →
  ∀ xs → foldr c n (xs ++ ys) ≡ foldr c (foldr c n ys) xs
foldr-++                           []       = refl _
foldr-++ {ys = ys} {c = c} {n = n} (x ∷ xs) =
  foldr c n (x ∷ xs ++ ys)         ≡⟨⟩
  c x (foldr c n (xs ++ ys))       ≡⟨ cong (c x) (foldr-++ xs) ⟩
  c x (foldr c (foldr c n ys) xs)  ≡⟨⟩
  foldr c (foldr c n ys) (x ∷ xs)  ∎

-- A fusion lemma for foldr and map.

foldr∘map :
  (_⊕_ : B → C → C) (ε : C) (f : A → B) (xs : List A) →
  (foldr _⊕_ ε ∘ map f) xs ≡ foldr (_⊕_ ∘ f) ε xs
foldr∘map _⊕_ ε f []       = ε ∎
foldr∘map _⊕_ ε f (x ∷ xs) = cong (f x ⊕_) (foldr∘map _⊕_ ε f xs)

-- A fusion lemma for length and map.

length∘map :
  (f : A → B) (xs : List A) →
  (length ∘ map f) xs ≡ length xs
length∘map = foldr∘map _ _

-- A lemma relating index, map and length∘map.

index∘map :
  ∀ xs {i} →
  index (map f xs) i ≡
  f (index xs (subst Fin (length∘map f xs) i))
index∘map {f = f} (x ∷ xs) {i} =
  index (f x ∷ map f xs) i                                  ≡⟨ lemma i ⟩
  f (index (x ∷ xs) (subst (λ n → ⊤ ⊎ Fin n) p i))          ≡⟨⟩
  f (index (x ∷ xs) (subst (Fin ∘ suc) p i))                ≡⟨ cong (f ∘ index (_ ∷ xs)) (subst-∘ Fin suc _) ⟩
  f (index (x ∷ xs) (subst Fin (cong suc p) i))             ≡⟨⟩
  f (index (x ∷ xs) (subst Fin (length∘map f (x ∷ xs)) i))  ∎
  where
  p = length∘map f xs

  lemma :
    ∀ i →
    index (f x ∷ map f xs) i ≡
    f (index (x ∷ xs) (subst (λ n → ⊤ ⊎ Fin n) p i))
  lemma fzero =
    index (f x ∷ map f xs) fzero                          ≡⟨⟩
    f x                                                   ≡⟨⟩
    f (index (x ∷ xs) fzero)                              ≡⟨⟩
    f (index (x ∷ xs) (inj₁ (subst (λ _ → ⊤) p tt)))      ≡⟨ cong (f ∘ index (_ ∷ xs)) $ sym $ push-subst-inj₁ _ Fin ⟩∎
    f (index (x ∷ xs) (subst (λ n → ⊤ ⊎ Fin n) p fzero))  ∎
  lemma (fsuc i) =
    index (f x ∷ map f xs) (fsuc i)                          ≡⟨⟩
    index (map f xs) i                                       ≡⟨ index∘map xs ⟩
    f (index xs (subst Fin p i))                             ≡⟨⟩
    f (index (x ∷ xs) (fsuc (subst Fin p i)))                ≡⟨ cong (f ∘ index (_ ∷ xs)) $ sym $ push-subst-inj₂ _ Fin ⟩∎
    f (index (x ∷ xs) (subst (λ n → ⊤ ⊎ Fin n) p (fsuc i)))  ∎

-- The length function is homomorphic with respect to _++_/_+_.

length-++ : ∀ xs → length (xs ++ ys) ≡ length xs + length ys
length-++ []       = refl _
length-++ (_ ∷ xs) = cong suc (length-++ xs)

-- The sum function is homomorphic with respect to _++_/_+_.

sum-++ : ∀ ms → sum (ms ++ ns) ≡ sum ms + sum ns
sum-++           []       = refl _
sum-++ {ns = ns} (m ∷ ms) =
  sum (m ∷ ms ++ ns)     ≡⟨⟩
  m + sum (ms ++ ns)     ≡⟨ cong (m +_) $ sum-++ ms ⟩
  m + (sum ms + sum ns)  ≡⟨ +-assoc m ⟩
  (m + sum ms) + sum ns  ≡⟨⟩
  sum (m ∷ ms) + sum ns  ∎

-- Some lemmas related to reverse.

++-reverse : ∀ xs → reverse xs ++ ys ≡ foldl (flip _∷_) ys xs
++-reverse xs = lemma xs
  where
  lemma :
    ∀ xs →
    foldl (flip _∷_) ys xs ++ zs ≡
    foldl (flip _∷_) (ys ++ zs) xs
  lemma                     []       = refl _
  lemma {ys = ys} {zs = zs} (x ∷ xs) =
    foldl (flip _∷_) ys (x ∷ xs) ++ zs    ≡⟨⟩
    foldl (flip _∷_) (x ∷ ys) xs ++ zs    ≡⟨ lemma xs ⟩
    foldl (flip _∷_) (x ∷ ys ++ zs) xs    ≡⟨⟩
    foldl (flip _∷_) (ys ++ zs) (x ∷ xs)  ∎

reverse-∷ : ∀ xs → reverse (x ∷ xs) ≡ reverse xs ++ x ∷ []
reverse-∷ {x = x} xs =
  reverse (x ∷ xs)              ≡⟨⟩
  foldl (flip _∷_) (x ∷ []) xs  ≡⟨ sym $ ++-reverse xs ⟩∎
  reverse xs ++ x ∷ []          ∎

reverse-++ : ∀ xs → reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++ {ys = ys} [] =
  reverse ys        ≡⟨ sym $ ++-right-identity _ ⟩∎
  reverse ys ++ []  ∎
reverse-++ {ys = ys} (x ∷ xs) =
  reverse (x ∷ xs ++ ys)                ≡⟨ reverse-∷ (xs ++ _) ⟩
  reverse (xs ++ ys) ++ x ∷ []          ≡⟨ cong (_++ _) $ reverse-++ xs ⟩
  (reverse ys ++ reverse xs) ++ x ∷ []  ≡⟨ sym $ ++-associative (reverse ys) _ _ ⟩
  reverse ys ++ (reverse xs ++ x ∷ [])  ≡⟨ cong (reverse ys ++_) $ sym $ reverse-∷ xs ⟩∎
  reverse ys ++ reverse (x ∷ xs)        ∎

reverse-reverse : (xs : List A) → reverse (reverse xs) ≡ xs
reverse-reverse []       = refl _
reverse-reverse (x ∷ xs) =
  reverse (reverse (x ∷ xs))                ≡⟨ cong reverse (reverse-∷ xs) ⟩
  reverse (reverse xs ++ x ∷ [])            ≡⟨ reverse-++ (reverse xs) ⟩
  reverse (x ∷ []) ++ reverse (reverse xs)  ≡⟨⟩
  x ∷ reverse (reverse xs)                  ≡⟨ cong (x ∷_) (reverse-reverse xs) ⟩∎
  x ∷ xs                                    ∎

map-reverse : ∀ xs → map f (reverse xs) ≡ reverse (map f xs)
map-reverse         []       = refl _
map-reverse {f = f} (x ∷ xs) =
  map f (reverse (x ∷ xs))        ≡⟨ cong (map f) $ reverse-∷ xs ⟩
  map f (reverse xs ++ x ∷ [])    ≡⟨ map-++ _ (reverse xs) _ ⟩
  map f (reverse xs) ++ f x ∷ []  ≡⟨ cong (_++ _) $ map-reverse xs ⟩
  reverse (map f xs) ++ f x ∷ []  ≡⟨ sym $ reverse-∷ (map f xs) ⟩
  reverse (f x ∷ map f xs)        ≡⟨⟩
  reverse (map f (x ∷ xs))        ∎

foldr-reverse :
  {c : A → B → B} {n : B} →
  ∀ xs → foldr c n (reverse xs) ≡ foldl (flip c) n xs
foldr-reverse                 []       = refl _
foldr-reverse {c = c} {n = n} (x ∷ xs) =
  foldr c n (reverse (x ∷ xs))      ≡⟨ cong (foldr c n) (reverse-++ {ys = xs} (x ∷ [])) ⟩
  foldr c n (reverse xs ++ x ∷ [])  ≡⟨ foldr-++ (reverse xs) ⟩
  foldr c (c x n) (reverse xs)      ≡⟨ foldr-reverse xs ⟩
  foldl (flip c) (c x n) xs         ≡⟨⟩
  foldl (flip c) n (x ∷ xs)         ∎

foldl-reverse :
  {c : B → A → B} {n : B} →
  ∀ xs → foldl c n (reverse xs) ≡ foldr (flip c) n xs
foldl-reverse {c = c} {n = n} xs =
  foldl c n (reverse xs)                   ≡⟨ sym (foldr-reverse (reverse xs)) ⟩
  foldr (flip c) n (reverse (reverse xs))  ≡⟨ cong (foldr (flip c) n) (reverse-reverse xs) ⟩∎
  foldr (flip c) n xs                      ∎

length-reverse : (xs : List A) → length (reverse xs) ≡ length xs
length-reverse []       = refl _
length-reverse (x ∷ xs) =
  length (reverse (x ∷ xs))      ≡⟨ cong length (reverse-∷ xs) ⟩
  length (reverse xs ++ x ∷ [])  ≡⟨ length-++ (reverse xs) ⟩
  length (reverse xs) + 1        ≡⟨ cong (_+ 1) (length-reverse xs) ⟩
  length xs + 1                  ≡⟨ +-comm (length xs) ⟩∎
  length (x ∷ xs)                ∎

sum-reverse : ∀ ns → sum (reverse ns) ≡ sum ns
sum-reverse []       = refl _
sum-reverse (n ∷ ns) =
  sum (reverse (n ∷ ns))           ≡⟨ cong sum (reverse-∷ ns) ⟩
  sum (reverse ns ++ n ∷ [])       ≡⟨ sum-++ (reverse ns) ⟩
  sum (reverse ns) + sum (n ∷ [])  ≡⟨ cong₂ _+_ (sum-reverse ns) +-right-identity ⟩
  sum ns + n                       ≡⟨ +-comm (sum ns) ⟩∎
  sum (n ∷ ns)                     ∎

-- The functions filter and map commute (kind of).

filter∘map :
  (p : B → Bool) (f : A → B) (xs : List A) →
  (filter p ∘ map f) xs ≡ (map f ∘ filter (p ∘ f)) xs
filter∘map p f []       = refl _
filter∘map p f (x ∷ xs) with p (f x)
... | true  = cong (_ ∷_) (filter∘map p f xs)
... | false = filter∘map p f xs

-- The length of replicate n x is n.

length-replicate : ∀ n → length (replicate n x) ≡ n
length-replicate         zero    = refl _
length-replicate {x = x} (suc n) =
  length (replicate (suc n) x)  ≡⟨⟩
  suc (length (replicate n x))  ≡⟨ cong suc $ length-replicate n ⟩∎
  suc n                         ∎

-- The sum of replicate m n is m * n.

sum-replicate : ∀ m → sum (replicate m n) ≡ m * n
sum-replicate         zero    = refl _
sum-replicate {n = n} (suc m) =
  sum (replicate (suc m) n)  ≡⟨⟩
  n + sum (replicate m n)    ≡⟨ cong (n +_) $ sum-replicate m ⟩
  n + m * n                  ≡⟨⟩
  suc m * n                  ∎

-- The length of nats-< n is n.

length∘nats-< : ∀ n → length (nats-< n) ≡ n
length∘nats-< zero    = 0 ∎
length∘nats-< (suc n) = cong suc (length∘nats-< n)

-- The sum of nats-< n can be expressed without referring to lists.

sum-nats-< : ∀ n → sum (nats-< n) ≡ ⌊ n * pred n /2⌋
sum-nats-< zero          = refl _
sum-nats-< (suc zero)    = refl _
sum-nats-< (suc (suc n)) =
  sum (suc n ∷ nats-< (suc n))       ≡⟨⟩
  suc n + sum (nats-< (suc n))       ≡⟨ cong (suc n +_) (sum-nats-< (suc n)) ⟩
  suc n + ⌊ suc n * n /2⌋            ≡⟨ sym $ ⌊2*+/2⌋≡ (suc n) ⟩
  ⌊ 2 * suc n + suc n * n /2⌋        ≡⟨ cong ⌊_/2⌋ (solve 1 (λ n → con 2 :* (con 1 :+ n) :+ (con 1 :+ n) :* n :=
                                                                   con 1 :+ n :+ (con 1 :+ n :+ n :* (con 1 :+ n)))
                                                          (refl _) n) ⟩
  ⌊ suc n + (suc n + n * suc n) /2⌋  ≡⟨⟩
  ⌊ suc (suc n) * suc n /2⌋          ∎

-- If xs ++ ys is equal to [], then both lists are.

++≡[]→≡[]×≡[] : ∀ xs → xs ++ ys ≡ [] → xs ≡ [] × ys ≡ []
++≡[]→≡[]×≡[] {ys = []}    []      _    = refl _ , refl _
++≡[]→≡[]×≡[] {ys = _ ∷ _} []      ∷≡[] = ⊥-elim (List.[]≢∷ (sym ∷≡[]))
++≡[]→≡[]×≡[]              (_ ∷ _) ∷≡[] = ⊥-elim (List.[]≢∷ (sym ∷≡[]))

-- Empty lists are not equal to non-empty lists.

[]≢++∷ : ∀ xs → [] ≢ xs ++ y ∷ ys
[]≢++∷ {y = y} {ys = ys} xs =
  [] ≡ xs ++ y ∷ ys  ↝⟨ sym ∘ proj₂ ∘ ++≡[]→≡[]×≡[] xs ∘ sym ⟩
  [] ≡ y ∷ ys        ↝⟨ List.[]≢∷ ⟩□
  ⊥                  □

------------------------------------------------------------------------
-- The list monad

instance

  -- The list monad.

  raw-monad : Raw-monad (List {a = ℓ})
  Raw-monad.return raw-monad x    = x ∷ []
  Raw-monad._>>=_  raw-monad xs f = concat (map f xs)

  monad : Monad (List {a = ℓ})
  Monad.raw-monad      monad     = raw-monad
  Monad.left-identity  monad x f = foldr-∷-[] (f x)
  Monad.right-identity monad xs  = lemma xs
    where
    lemma : ∀ xs → concat (map (_∷ []) xs) ≡ xs
    lemma []       = refl _
    lemma (x ∷ xs) =
      concat (map (_∷ []) (x ∷ xs))  ≡⟨⟩
      x ∷ concat (map (_∷ []) xs)    ≡⟨ cong (x ∷_) (lemma xs) ⟩∎
      x ∷ xs                         ∎
  Monad.associativity monad xs f g = lemma xs
    where
    lemma : ∀ xs → concat (map (concat ∘ map g ∘ f) xs) ≡
                   concat (map g (concat (map f xs)))
    lemma []       = refl _
    lemma (x ∷ xs) =
      concat (map (concat ∘ map g ∘ f) (x ∷ xs))                    ≡⟨⟩
      concat (map g (f x)) ++ concat (map (concat ∘ map g ∘ f) xs)  ≡⟨ cong (concat (map g (f x)) ++_) (lemma xs) ⟩
      concat (map g (f x)) ++ concat (map g (concat (map f xs)))    ≡⟨ sym $ concat-++ (map g (f x)) _ ⟩
      concat (map g (f x) ++ map g (concat (map f xs)))             ≡⟨ cong concat (sym $ map-++ g (f x) _) ⟩
      concat (map g (f x ++ concat (map f xs)))                     ≡⟨ refl _ ⟩∎
      concat (map g (concat (map f (x ∷ xs))))                      ∎

------------------------------------------------------------------------
-- Some isomorphisms

-- An unfolding lemma for List.

List↔Maybe[×List] : List A ↔ Maybe (A × List A)
List↔Maybe[×List] = record
  { surjection = record
    { logical-equivalence = record
      { to   = λ { [] → inj₁ tt; (x ∷ xs) → inj₂ (x , xs) }
      ; from = [ (λ _ → []) , uncurry _∷_ ]
      }
    ; right-inverse-of = [ (λ _ → refl _) , (λ _ → refl _) ]
    }
  ; left-inverse-of = λ { [] → refl _; (_ ∷ _) → refl _ }
  }

-- Some isomorphisms related to list equality.

[]≡[]↔⊤ : [] ≡ ([] ⦂ List A) ↔ ⊤
[]≡[]↔⊤ =
  [] ≡ []            ↔⟨ inverse $ Eq.≃-≡ (Eq.↔⇒≃ List↔Maybe[×List]) ⟩
  nothing ≡ nothing  ↝⟨ inverse Bijection.≡↔inj₁≡inj₁ ⟩
  tt ≡ tt            ↝⟨ tt≡tt↔⊤ ⟩□
  ⊤                  □

[]≡∷↔⊥ : [] ≡ x ∷ xs ↔ ⊥ {ℓ = ℓ}
[]≡∷↔⊥ {x = x} {xs = xs} =
  [] ≡ x ∷ xs              ↔⟨ inverse $ Eq.≃-≡ (Eq.↔⇒≃ List↔Maybe[×List]) ⟩
  nothing ≡ just (x , xs)  ↝⟨ Bijection.≡↔⊎ ⟩
  ⊥                        ↝⟨ ⊥↔⊥ ⟩□
  ⊥                        □

∷≡[]↔⊥ : x ∷ xs ≡ [] ↔ ⊥ {ℓ = ℓ}
∷≡[]↔⊥ {x = x} {xs = xs} =
  x ∷ xs ≡ []  ↝⟨ ≡-comm ⟩
  [] ≡ x ∷ xs  ↝⟨ []≡∷↔⊥ ⟩□
  ⊥            □

∷≡∷↔≡×≡ : x ∷ xs ≡ y ∷ ys ↔ x ≡ y × xs ≡ ys
∷≡∷↔≡×≡ {x = x} {xs = xs} {y = y} {ys = ys} =
  x ∷ xs ≡ y ∷ ys                ↔⟨ inverse $ Eq.≃-≡ (Eq.↔⇒≃ List↔Maybe[×List]) ⟩
  just (x , xs) ≡ just (y , ys)  ↝⟨ inverse Bijection.≡↔inj₂≡inj₂ ⟩
  (x , xs) ≡ (y , ys)            ↝⟨ inverse ≡×≡↔≡ ⟩□
  x ≡ y × xs ≡ ys                □

------------------------------------------------------------------------
-- H-levels

-- If A is inhabited, then List A is not a proposition.

¬-List-propositional : A → ¬ Is-proposition (List A)
¬-List-propositional x h = List.[]≢∷ $ h [] (x ∷ [])

-- H-levels greater than or equal to two are closed under List.

H-level-List : ∀ n → H-level (2 + n) A → H-level (2 + n) (List A)
H-level-List n _ {[]} {[]} =
                             $⟨ ⊤-contractible ⟩
  Contractible ⊤             ↝⟨ H-level-cong _ 0 (inverse []≡[]↔⊤) ⟩
  Contractible ([] ≡ [])     ↝⟨ H-level.mono (zero≤ (1 + n)) ⟩□
  H-level (1 + n) ([] ≡ [])  □

H-level-List n h {[]} {y ∷ ys} =
                                 $⟨ ⊥-propositional ⟩
  Is-proposition ⊥₀              ↝⟨ H-level-cong _ 1 (inverse []≡∷↔⊥) ⟩
  Is-proposition ([] ≡ y ∷ ys)   ↝⟨ H-level.mono (suc≤suc (zero≤ n)) ⟩□
  H-level (1 + n) ([] ≡ y ∷ ys)  □

H-level-List n h {x ∷ xs} {[]} =
                                 $⟨ ⊥-propositional ⟩
  Is-proposition ⊥₀              ↝⟨ H-level-cong _ 1 (inverse ∷≡[]↔⊥) ⟩
  Is-proposition (x ∷ xs ≡ [])   ↝⟨ H-level.mono (suc≤suc (zero≤ n)) ⟩□
  H-level (1 + n) (x ∷ xs ≡ [])  □

H-level-List n h {x ∷ xs} {y ∷ ys} =
  H-level-cong _ (1 + n) (inverse ∷≡∷↔≡×≡)
    (×-closure (1 + n) h (H-level-List n h))


module reductionSystems1 where

data ℕ : Set where
  Z : ℕ
  S : ℕ -> ℕ

_+_ : ℕ -> ℕ -> ℕ
n + Z   = n
n + S m = S (n + m)

_*_ : ℕ -> ℕ -> ℕ
n * Z = Z
n * S m = (n * m) + n

{-
{-# BUILTIN NATURAL  ℕ  #-}
{-# BUILTIN ZERO     Z #-}
{-# BUILTIN SUC      S  #-}
{-# BUILTIN NATPLUS  _+_  #-}
{-# BUILTIN NATTIMES _*_  #-}
-}


-- intrinsically-typed λ-calculus

module IntrinsicallyTypedLC where

open import Data.List
open import Data.List.Relation.Unary.All
open import Data.Unit
open import Data.Nat

-- definitions

data Ty : Set where
  Tunit : Ty
  Tfun : Ty → Ty → Ty

TEnv = List Ty

data _∈_ : Ty → TEnv → Set where
  here : ∀ {t Φ} → t ∈ (t ∷ Φ)
  there : ∀ {t t' Φ} → t ∈ Φ → t ∈ (t' ∷ Φ)

data Exp : TEnv → Ty → Set where
  Var : ∀ {Φ t} → (x : t ∈ Φ) → Exp Φ t
  Abs : ∀ {Φ t t'} → Exp (t ∷ Φ) t' → Exp Φ (Tfun t t')
  App : ∀ {Φ t t'} → Exp Φ (Tfun t t') → Exp Φ t → Exp Φ t'

-- big-step semantics

Val : Ty → Set
Val Tunit = ⊤
Val (Tfun t t₁) = Val t → Val t₁

access : ∀ {t Φ} → t ∈ Φ → All Val Φ → Val t
access here (px ∷ ρ) = px
access (there x) (px ∷ ρ) = access x ρ

eval : ∀ {Φ t} → Exp Φ t → All Val Φ → Val t
eval (Var x) ρ = access x ρ
eval (Abs e) ρ = λ x → eval e (x ∷ ρ)
eval (App e e₁) ρ = (eval e ρ) (eval e₁ ρ)


module Data.HVec where

open import Data.Fin using (Fin; zero; suc)
open import Data.Nat using (ℕ; zero; suc; _+_)

open import Function using (const)

open import Data.Vec as V using (Vec; []; _∷_; _[_]≔_)

open import Level as L using (Level; suc)

-- ------------------------------------------------------------------------
-- Hetrogenous Vectors

infixr 5 _∷_

data HVec { ℓ } : ( n : ℕ ) → Vec (Set ℓ) n → Set ℓ where
  [] : HVec 0 []
  _∷_ : ∀ { n } { A : Set ℓ } { As }
    → A
    → HVec n As
    -- ----------------------
    → HVec (1 + n) (A ∷ As)

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

private
  variable
    ℓ : Level
    A : Set ℓ
    n : ℕ
    As : Vec (Set ℓ) n

length : HVec n As → ℕ
length { n = n } _ = n

head : HVec (1 + n) As → (V.head As)
head (x ∷ xs) = x

tail : HVec (1 + n) As → HVec n (V.tail As)
tail (x ∷ xs) = xs

lookup : HVec n As → (i : Fin n) → (V.lookup As i)
lookup (x ∷ xs) zero = x
lookup (x ∷ xs) (suc i) = lookup xs i

insert : HVec n As → (i : Fin (1 + n)) → A → HVec (1 + n) (V.insert As i A)
insert xs zero v = v ∷ xs
insert (x ∷ xs) (suc i) v = x ∷ insert xs i v

remove : HVec (1 + n) As → (i : Fin (1 + n)) → HVec n (V.remove As i)
remove (x ∷ xs) zero = xs
remove (x₁ ∷ x₂ ∷ xs) (suc i) = x₁ ∷ remove (x₂ ∷ xs) i

updateAt : ∀ { ℓ n } { A : Set ℓ } { As : Vec (Set ℓ) n } (i : Fin n) → (V.lookup As i → A) → HVec n As → HVec n (As [ i ]≔ A)
updateAt zero f (x ∷ xs) = f x ∷ xs
updateAt (suc i) f (x ∷ xs) = x ∷ updateAt i f xs

infixl 6 _[_]$=_

_[_]$=_ : HVec n As → (i : Fin n) → (V.lookup As i → A) → HVec n (As [ i ]≔ A)
xs [ i ]$= f = updateAt i f xs

infixl 6 _[_]&=_

_[_]&=_ : HVec n As → (i : Fin n) → A → HVec n (As [ i ]≔ A)
xs [ i ]&= y = xs [ i ]$= const y

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


module Everything where

import Basic
import Category
import Functor
import Nat
import Yoneda
import Adjoint
import Monad
import TAlgebra


data Nat : Set where
  zero : Nat
  suc : Nat → Nat

test : ∀{N M : Nat} → Nat → Nat → Nat
test L K = {!N L M!}
-- Andreas, 2016-07-10, issue 2088
-- Changed behavior:
-- The hidden variables N and M are made visible
-- only the visible L is split.


module Issue450 where

open import Common.Level
open import Common.Coinduction

data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

data Wrap (A : Set) : Set where
  con : A -> Wrap A

out : forall {A} -> Wrap A -> A
out (con x) = x

out' : forall {A} -> ∞ (Wrap A) -> A
out' y = out (♭ y)

inn : forall {A}  -> A -> ∞ (Wrap A)
inn y = ♯ (con y)

prf : (A : Set)(x : A) → out' (inn x) ≡ x
prf A x = refl

test : forall {A : Set}{x : A} -> out (con x) ≡ x
test = refl

-- these work
test1 : forall {A}{x : A} -> out' (inn x) ≡ x
test1 {A} {x} = test

test2 : forall {A}{x : A} -> out' (inn x) ≡ x
test2 {A} {x} = test {A}

-- but the following ones won't typecheck

test3 : forall {A}{x : A} -> out' (inn x) ≡ x
test3 {A} {x} = test {A} {x}

test4 : forall {A}{x : A} -> out' (inn x) ≡ x
test4 {A} {x} = refl


------------------------------------------------------------------------------
-- A proof that was rejected using the --without-K option
------------------------------------------------------------------------------

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

module ListsSL where

open import Data.List
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Relation.Binary
module NDTO = DecTotalOrder ≤-decTotalOrder

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

LTC : {A : Set} → List A → List A → Set
LTC xs ys = ∃ (λ x → ys ≡ x ∷ xs)

LTL : {A : Set} → List A → List A → Set
LTL xs ys = (length xs) < (length ys)

helper : {A : Set}(y : A)(xs : List A) → (length xs) < (length (y ∷ xs))
helper y []       = s≤s z≤n
helper y (x ∷ xs) = s≤s NDTO.refl

-- 25 April 2014. The proof is accepted using Cockx's --without-K
-- implementation.
foo : {A : Set}(xs ys : List A) → LTC xs ys → LTL xs ys
foo xs .(x ∷ xs) (x , refl) = helper x xs

foo' : {A : Set}(xs ys : List A) → LTC xs ys → LTL xs ys
foo' xs ys (x , h) =
  subst (λ ys' → length xs < length ys') (sym h) (helper x xs)


------------------------------------------------------------------------
-- Streams
------------------------------------------------------------------------

module Data.Stream where

open import Coinduction
open import Data.Colist using (Colist; []; _∷_)
open import Data.Vec    using (Vec;    []; _∷_)
open import Data.Nat using (ℕ; zero; suc)
open import Relation.Binary

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

infixr 5 _∷_

data Stream (A : Set) : Set where
  _∷_ : (x : A) (xs : ∞ (Stream A)) → Stream A

------------------------------------------------------------------------
-- Some operations

head : forall {A} -> Stream A -> A
head (x ∷ xs) = x

tail : forall {A} -> Stream A -> Stream A
tail (x ∷ xs) = ♭ xs

map : ∀ {A B} → (A → B) → Stream A → Stream B
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

zipWith : forall {A B C} ->
          (A -> B -> C) -> Stream A -> Stream B -> Stream C
zipWith _∙_ (x ∷ xs) (y ∷ ys) = (x ∙ y) ∷ ♯ zipWith _∙_ (♭ xs) (♭ ys)

take : ∀ {A} (n : ℕ) → Stream A → Vec A n
take zero    xs       = []
take (suc n) (x ∷ xs) = x ∷ take n (♭ xs)

drop : ∀ {A} -> ℕ -> Stream A -> Stream A
drop zero    xs       = xs
drop (suc n) (x ∷ xs) = drop n (♭ xs)

repeat : forall {A} -> A -> Stream A
repeat x = x ∷ ♯ repeat x

iterate : ∀ {A} → (A → A) → A → Stream A
iterate f x = x ∷ ♯ iterate f (f x)

-- Interleaves the two streams.

infixr 5 _⋎_

_⋎_ : ∀ {A} → Stream A → Stream A → Stream A
(x ∷ xs) ⋎ ys = x ∷ ♯ (ys ⋎ ♭ xs)

toColist : ∀ {A} → Stream A → Colist A
toColist (x ∷ xs) = x ∷ ♯ toColist (♭ xs)

lookup : ∀ {A} → ℕ → Stream A → A
lookup zero    (x ∷ xs) = x
lookup (suc n) (x ∷ xs) = lookup n (♭ xs)

infixr 5 _++_

_++_ : ∀ {A} → Colist A → Stream A → Stream A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ ♯ (♭ xs ++ ys)

------------------------------------------------------------------------
-- Equality and other relations

-- xs ≈ ys means that xs and ys are equal.

infix 4 _≈_

data _≈_ {A} : (xs ys : Stream A) → Set where
  _∷_ : ∀ x {xs ys} (xs≈ : ∞ (♭ xs ≈ ♭ ys)) → x ∷ xs ≈ x ∷ ys

-- x ∈ xs means that x is a member of xs.

infix 4 _∈_

data _∈_ {A : Set} : A → Stream A → Set where
  here  : ∀ {x   xs}                   → x ∈ x ∷ xs
  there : ∀ {x y xs} (x∈xs : x ∈ ♭ xs) → x ∈ y ∷ xs

-- xs ⊑ ys means that xs is a prefix of ys.

infix 4 _⊑_

data _⊑_ {A : Set} : Colist A → Stream A → Set where
  []  : ∀ {ys}                            → []     ⊑ ys
  _∷_ : ∀ x {xs ys} (p : ∞ (♭ xs ⊑ ♭ ys)) → x ∷ xs ⊑ x ∷ ys

------------------------------------------------------------------------
-- Some proofs

setoid : Set → Setoid
setoid A = record
  { carrier       = Stream A
  ; _≈_           = _≈_ {A}
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : Reflexive _≈_
  refl {x ∷ xs} = x ∷ ♯ refl

  sym : Symmetric _≈_
  sym (x ∷ xs≈) = x ∷ ♯ sym (♭ xs≈)

  trans : Transitive _≈_
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

map-cong : ∀ {A B} (f : A → B) {xs ys : Stream A} →
           xs ≈ ys → map f xs ≈ map f ys
map-cong f (x ∷ xs≈) = f x ∷ ♯ map-cong f (♭ xs≈)


{-# OPTIONS --safe --without-K #-}
open import Algebra.Bundles using (Monoid)

module Categories.Category.Construction.MonoidAsCategory o {c ℓ} (M : Monoid c ℓ) where

open import Data.Unit.Polymorphic
open import Level

open import Categories.Category.Core

open Monoid M

-- A monoid is a category with one object
MonoidAsCategory : Category o c ℓ
MonoidAsCategory = record
  { Obj = ⊤
  ; assoc = assoc _ _ _
  ; sym-assoc = sym (assoc _ _ _)
  ; identityˡ = identityˡ _
  ; identityʳ = identityʳ _
  ; identity² = identityˡ _
  ; equiv = isEquivalence
  ; ∘-resp-≈ = ∙-cong
  }


module PLRTree.Equality.Correctness {A : Set} where

open import BTree.Equality {A}
open import PLRTree {A}
open import PLRTree.Equality {A} renaming (_≃_ to _≃'_)

lemma-≃'-≃ : {l r : PLRTree} → l ≃' r → forget l ≃ forget r
lemma-≃'-≃ ≃lf = ≃lf
lemma-≃'-≃ (≃nd x x' l≃'r l'≃'r' l≃'l') = ≃nd x x' (lemma-≃'-≃ l≃'r) (lemma-≃'-≃ l≃'l') (lemma-≃'-≃ l'≃'r')


{-

Counting how many structured finite sets with a given cardinal

https://github.com/EgbertRijke/OEIS-A000001

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

module Cubical.Experiments.CountingFiniteStructure where

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

open import Cubical.Data.Nat
open import Cubical.Data.Bool
open import Cubical.Data.Sigma

open import Cubical.Data.FinSet
open import Cubical.Data.FinSet.Induction
open import Cubical.Data.FinSet.Constructors
open import Cubical.Data.FinType
open import Cubical.Data.FinType.FiniteStructure

private
  variable
    ℓ : Level

-- convenient abbreviation

isFinStrCard : (S : FinSet ℓ-zero → FinSet ℓ) (n : ℕ) → isFinType 0 (FinSetWithStrOfCard S n)
isFinStrCard S n = isFinTypeFinSetWithStrOfCard S n

-- structure that there is no structure

TrivialStr : FinSet ℓ → FinSet ℓ
TrivialStr _ = 𝟙

-- structure that "picking an element in that set"

IdentityStr : FinSet ℓ → FinSet ℓ
IdentityStr X = X

-- finite semi-groups

FinSemiGroupStr : FinSet ℓ → FinSet ℓ
FinSemiGroupStr X .fst =
  Σ[ p ∈ (X .fst → X .fst → X .fst) ] ((x y z : X .fst) → p (p x y) z ≡ p x (p y z))
FinSemiGroupStr X .snd =
  isFinSetΣ (_ , isFinSetΠ2 X (λ _ → X) (λ _ _ → X))
    (λ p → _ , isFinSetΠ3 X (λ _ → X) (λ _ _ → X) (λ _ _ _ → _ , isFinSet≡ X _ _))

-- finite groups

FinGroupStr : FinSet ℓ → FinSet ℓ
FinGroupStr X .fst =
  Σ[ e ∈ X .fst ]
    Σ[ inv ∈ (X .fst → X .fst) ]
      Σ[ p ∈ (X .fst → X .fst → X .fst) ]
          ((x y z : X .fst) → p (p x y) z ≡ p x (p y z))
        × ((x : X .fst)
            → (p x e ≡ x) × (p e x ≡ x) × (p (inv x) x ≡ e) × (p x (inv x) ≡ e))
FinGroupStr X .snd =
  isFinSetΣ X (λ _ → _ ,
    isFinSetΣ (_ , isFinSetΠ X (λ _ → X)) (λ _ → _ ,
      isFinSetΣ (_ , isFinSetΠ2 X (λ _ → X) (λ _ _ → X)) (λ _ → _ ,
        isFinSet× (_ , isFinSetΠ3 X (λ _ → X) (λ _ _ → X) (λ _ _ _ → _ , isFinSet≡ X _ _)) (_ ,
          isFinSetΠ X (λ _ → _ ,
            isFinSet× (_ , isFinSet≡ X _ _) (_ ,
              isFinSet× (_ , isFinSet≡ X _ _) (_ ,
                isFinSet× (_ , isFinSet≡ X _ _) (_ , isFinSet≡ X _ _))))))))

-- two rather trivial numbers
-- but the computation is essentially not that trivial
-- Time: 5 ms
a2 : ℕ
a2 = card (_ , isFinStrCard TrivialStr 2)

-- this is already hard to compute
-- Time: 443 ms
b2 : ℕ
b2 = card (_ , isFinStrCard IdentityStr 2)

-- the number of finite semi-groups
numberOfFinSemiGroups : ℕ → ℕ
numberOfFinSemiGroups n = card (_ , isFinStrCard FinSemiGroupStr n)

-- two trivial cases of semi-groups
-- Time: 29 ms
n0 : ℕ
n0 = numberOfFinSemiGroups 0

-- Time: 2,787ms
n1 : ℕ
n1 = numberOfFinSemiGroups 1

-- the number of finite semi-groups with cardinal 2
-- it should be 5
-- would you like to try?
n2 : ℕ
n2 = numberOfFinSemiGroups 2

-- OEIS-A000001
-- I think you'd better not evaluate this function with n > 1
numberOfFinGroups : ℕ → ℕ
numberOfFinGroups n = card (_ , isFinStrCard FinGroupStr n)

-- group with one element
-- Time: 26,925ms
g1 : ℕ
g1 = numberOfFinGroups 1

-- Rijke's challenge
-- seemed to big to do an exhaustive search
g4 : ℕ
g4 = numberOfFinGroups 4