module Structure.Setoid.Uniqueness.Proofs where

import      Lvl
open import Functional
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid.Uniqueness
open import Structure.Setoid
open import Structure.Function.Domain
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

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

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ {f : A → B} where
  Uniqueness-Injectivity : (∀{y : B} → Unique(x ↦ y ≡ f(x))) ↔ Injective(f)
  Uniqueness-Injectivity = [↔]-intro l r where
    l : (∀{y : B} → Unique(x ↦ y ≡ f(x))) ← Injective(f)
    l inj {y} {x₁}{x₂} (y≡fx₁) (y≡fx₂) = injective _ ⦃ inj ⦄ {x₁}{x₂} (symmetry(_≡_) (y≡fx₁) 🝖 (y≡fx₂))

    r : (∀{y : B} → Unique(x ↦ y ≡ f(x))) → Injective(f)
    Injective.proof(r unique) {x₁}{x₂} (fx₁≡fx₂) = unique {f(x₁)}{x₁}{x₂} (reflexivity(_≡_)) (fx₁≡fx₂)


-- Some basic structures and operations for dealing
-- with non-deterministic values.
--
-- @author Sergio Antoy, Michael Hanus, Steven Libby

module nondet where

open import bool
open import nat
open import list

infixr 8 _??_

----------------------------------------------------------------------
-- A tree datatype to represent a non-deterministic value of some type.
-- It is either a value or a choice between non-deterministic values.
----------------------------------------------------------------------

data ND (A : Set) : Set where
  Val  : A → ND A
  _??_ : ND A → ND A → ND A

----------------------------------------------------------------------
-- Some operations to define functions working this the ND datatype:

-- Apply a (deterministic) function to a non-deterministic argument.
-- This corresponds to a functor on the ND structure.
_$*_ : {A B : Set} → (A → B) → ND A → ND B
f $* (Val xs) = Val (f xs)
f $* (t1 ?? t2) = f $* t1 ?? f $* t2

-- Apply a non-deterministic function to a non-deterministic argument.
-- If ND would be an instance of the monad class, this is a monadic bind
-- with swapped arguments.
_*$*_ : {A B : Set} → (A → ND B) → ND A → ND B
f *$* (Val x)    = f x
f *$* (t1 ?? t2) = f *$* t1 ?? f *$* t2

-- Apply a binary non-deterministic function to non-deterministic arguments.
apply-nd2 : {A B C : Set} → (A → B → ND C) → ND A → ND B → ND C
apply-nd2 f a b = (λ x -> (λ y -> f x y) *$* b) *$* a

-- Apply a ternary non-deterministic function to non-deterministic arguments.
apply-nd3 : {A B C D : Set} → (A → B → C → ND D) → ND A → ND B → ND C → ND D
apply-nd3 f a b c = (λ x -> (λ y -> (λ z → f x y z) *$* c) *$* b) *$* a

-- Extend a deterministic function to one with non-deterministic result:
toND : {A B : Set} → (A → B) → A → ND B
toND f x = Val (f x)

----------------------------------------------------------------------
-- Some operations to define properties of non-deterministic values:

-- Count the number of values:
#vals : {A : Set} → ND A → ℕ
#vals (Val _) = 1
#vals (t1 ?? t2) = #vals t1 + #vals t2

-- Extract the list of all values:
vals-of : {A : Set} → ND A → 𝕃 A
vals-of (Val v)    = v :: []
vals-of (t1 ?? t2) = vals-of t1 ++ vals-of t2

-- All values in a Boolean tree are true:
always : ND 𝔹 → 𝔹
always (Val b)    = b
always (t1 ?? t2) = always t1 && always t2

-- There exists some true value in a Boolean tree:
eventually : ND 𝔹 → 𝔹
eventually (Val b)    = b
eventually (t1 ?? t2) = eventually t1 || eventually t2

-- All non-deterministic values satisfy a given predicate:
_satisfy_ : {A : Set} → ND A → (A → 𝔹) → 𝔹
(Val n)    satisfy p = p n
(t1 ?? t2) satisfy p = t1 satisfy p && t2 satisfy p

-- Every value in a tree is equal to the second argument w.r.t. a
-- comparison function provided as the first argument:
every : {A : Set} → (eq : A → A → 𝔹) → A → ND A → 𝔹
every eq x xs = xs satisfy (eq x)

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


module Numeric.Nat.LCM.Properties where

open import Prelude
open import Numeric.Nat.Divide
open import Numeric.Nat.Divide.Properties
open import Numeric.Nat.LCM

is-lcm-unique : ∀ {m m₁ a b} → IsLCM m a b → IsLCM m₁ a b → m ≡ m₁
is-lcm-unique {m} {m₁} (is-lcm a|m b|m lm) (is-lcm a|m₁ b|m₁ lm₁) =
  divides-antisym (lm m₁ a|m₁ b|m₁) (lm₁ m a|m b|m)

lcm-unique : ∀ {m a b} → IsLCM m a b → lcm! a b ≡ m
lcm-unique {a = a} {b} lm with lcm a b
... | lcm-res m₁ lm₁ = is-lcm-unique lm₁ lm

is-lcm-commute : ∀ {m a b} → IsLCM m a b → IsLCM m b a
is-lcm-commute (is-lcm a|m b|m g) = is-lcm b|m a|m (flip ∘ g)

lcm-commute : ∀ {a b} → lcm! a b ≡ lcm! b a
lcm-commute {a} {b} with lcm b a
... | lcm-res m lm = lcm-unique (is-lcm-commute lm)

private
  _|>_ = divides-trans

lcm-assoc : ∀ a b c → lcm! a (lcm! b c) ≡ lcm! (lcm! a b) c
lcm-assoc a b c with lcm a b | lcm b c
... | lcm-res ab (is-lcm a|ab b|ab lab)
    | lcm-res bc (is-lcm b|bc c|bc lbc) with lcm ab c
...    | lcm-res ab-c (is-lcm ab|abc c|abc labc) =
  lcm-unique {ab-c} {a} {bc}
    (is-lcm (a|ab |> ab|abc)
            (lbc ab-c (b|ab |> ab|abc) c|abc)
            λ k a|k bc|k → labc k (lab k a|k (b|bc |> bc|k)) (c|bc |> bc|k))


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

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

open import Setoids.Setoids
open import Setoids.Subset
open import Setoids.Functions.Definition
open import LogicalFormulae
open import Functions
open import Lists.Lists
open import Setoids.Orders
open import Rings.Orders.Partial.Definition
open import Rings.Definition

module LectureNotes.MetAndTop.Chapter2 {a b c : _} {R : Set a} {S : Setoid {a} {b} R} {_<_ : Rel {a} {c} R} {_+_ _*_ : R → R → R} {ring : Ring S _+_ _*_} {ps : SetoidPartialOrder S _<_} (pRing : PartiallyOrderedRing ring ps) where

open Setoid S renaming (_∼_ to _∼R_)
open Ring ring

record Metric {d1 e : _} {A : Set d1} {T : Setoid {d1} {e} A} (d : A → A → R) : Set (a ⊔ b ⊔ c ⊔ d1 ⊔ e) where
  open Setoid T
  field
    dWellDefined : (x y v w : A) → x ∼ y → v ∼ w → (d x v) ∼R (d w y)
    dZero : (x y : A) → (d x y) ∼R 0R → x ∼ y
    dZero' : (x y : A) → x ∼ y → (d x y) ∼R 0R
    dSymmetric : (x y : A) → (d x y) ∼R (d y x)
    dTriangle : (x y z : A) → ((d x z) < ((d x y) + (d y z))) || ((d x z) ∼R ((d x y) + (d y z)))
  dNonnegative : (x y : A) → (0R < d x y) || (0R ∼R (d x y))
  dNonnegative x y = {!!}


module Structure.Operator.Monoid where

import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Operator.Properties hiding (associativity ; identityₗ ; identityᵣ)
open import Structure.Operator
open import Type

-- A type and a binary operator using this type is a monoid when:
-- • The operator is associative.
-- • The operator have an identity in both directions.
record Monoid {ℓ ℓₑ} {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) : Stmt{ℓ Lvl.⊔ ℓₑ} where
  constructor intro
  field
    ⦃ binary-operator ⦄    : BinaryOperator(_▫_)
    ⦃ associativity ⦄      : Associativity(_▫_)
    ⦃ identity-existence ⦄ : ∃(Identity(_▫_))

  id = [∃]-witness identity-existence

  identity : Identity (_▫_) id
  identity = [∃]-proof identity-existence

  identityₗ : Identityₗ (_▫_) id
  identityₗ = Identity.left(identity)

  identityᵣ : Identityᵣ (_▫_) id
  identityᵣ = Identity.right(identity)

  identity-existenceₗ : ∃(Identityₗ(_▫_))
  identity-existenceₗ = [∃]-intro id ⦃ identityₗ ⦄

  identity-existenceᵣ : ∃(Identityᵣ(_▫_))
  identity-existenceᵣ = [∃]-intro id ⦃ identityᵣ ⦄

record MonoidObject {ℓ ℓₑ} : Stmt{Lvl.𝐒(ℓ Lvl.⊔ ℓₑ)} where
  constructor intro
  field
    {T} : Type{ℓ}
    ⦃ equiv ⦄ : Equiv{ℓₑ}(T)
    _▫_ : T → T → T
    ⦃ monoid ⦄ : Monoid(_▫_)
  open Monoid(monoid) public


module x1-Base where

data List (X : Set) : Set where
  []  :              List X
  _∷_ : X → List X → List X
infixr 5 _∷_

foldr : ∀ {A} {B : Set} → (A → B → B) → B → List A → B
foldr f b      []  = b
foldr f b (a ∷ as) = f a (foldr f b as)

data Either (A : Set) (B : Set) : Set where
  left  : A → Either A B
  right : B → Either A B

[_,_] : ∀ {A B} {C : Set} → (A → C) → (B → C) → Either A B → C
[ f , g ] (left  x) = f x
[ f , g ] (right x) = g x

-- Unhabited type
data Empty : Set where

absurd : {X : Set} → Empty → X
absurd ()

-- use Empty to define something close to negation in logic:
-- e.g., terms of type ¬ (3 > 4)
infix 3 ¬_
¬_ : Set → Set
¬ X = X → Empty

-- binary relation on a type X
Rel : Set → Set₁
Rel X = X → X → Set

-- decidable relations
Decidable : ∀ {X} → Rel X → Set
Decidable R = ∀ x y → Either (R x y) (¬ (R x y))

-- To sort a list, need two relations on elements of list:

-- equality
record Equivalence {X} (_≈_ : Rel X) : Set₁ where
  field
    refl  : ∀ {x}     → x ≈ x
    sym   : ∀ {x y}   → x ≈ y → y ≈ x
    trans : ∀ {x y z} → x ≈ y → y ≈ z → x ≈ z

-- and ordering
record TotalOrder {X} (_≈_ : Rel X) (_≤_ : Rel X) : Set₁ where
  field
    antisym     : ∀ {x y}   → x ≤ y → y ≤ x → x ≈ y
    trans       : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z
    total       : ∀  x y    → Either (x ≤ y) (y ≤ x)
    reflexive   : ∀ {x y}   → x ≈ y → x ≤ y
    equivalence : Equivalence _≈_


open import Agda.Builtin.Nat

data Tree : Set where
  `    : Nat → Tree
  _`+_ : Tree → Tree → Tree

⟦_⟧ : Tree → Nat
⟦ ` n    ⟧ = n
⟦ t `+ u ⟧ = ⟦ t ⟧ + ⟦ u ⟧

data Target : Tree → Set where
  0+_ : ∀ e → Target (` 0 `+ e)
  _+0 : ∀ e → Target (e `+ ` 0)
  [_] : ∀ e → Target e

target : ∀ e → Target e
target (` 0 `+ e) = 0+ e
target (e `+ ` 0) = e +0
target e          = [ e ]

optimise   : Tree → Tree
structural : Tree → Tree

optimise t with {structural t} | target (structural t)
... | 0+ e  = e
... | e +0  = e
... | [ e ] = e

structural (` n)    = ` n
structural (e `+ f) = optimise e `+ optimise f

open import Agda.Builtin.Equality

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

+-cong : ∀ {m n p q} → m ≡ n → p ≡ q → m + p ≡ n + q
+-cong refl refl = refl

trans : {m n p : Nat} → m ≡ n → n ≡ p → m ≡ p
trans refl eq = eq

m≡m+0 : ∀ m → m ≡ m + 0
m≡m+0 0       = refl
m≡m+0 (suc m) = suc-cong (m≡m+0 m)

optimise-sound   : ∀ t → ⟦ optimise t ⟧ ≡ ⟦ t ⟧
structural-sound : ∀ t → ⟦ structural t ⟧ ≡ ⟦ t ⟧

optimise-sound t with {structural t} | target (structural t) | structural-sound t
... | 0+ e  | eq = eq
... | e +0  | eq = trans (m≡m+0 ⟦ e ⟧) eq
... | [ e ] | eq = eq

structural-sound (` n)    = refl
structural-sound (e `+ f) = +-cong (optimise-sound e) (optimise-sound f)


module Formalization.PrimitiveRecursion where

import      Lvl
open import Data
open import Data.ListSized
open import Numeral.Finite
open import Numeral.Natural
open import Syntax.Number
open import Type{Lvl.𝟎}

-- Function(n) is a syntactic representation of primitive recursive functions of type (ℕⁿ → ℕ).
-- The syntax
data Function : ℕ → Type where
  -- Base cases
  Base        : Function(0)
  Successor   : Function(1)
  Projection  : ∀{n : ℕ} → (i : 𝕟(n)) → Function(n)

  -- Inductive cases
  Composition : ∀{m n : ℕ} → Function(n) → List(Function(m))(n) → Function(m)
  Recursion   : ∀{n : ℕ} → Function(n) → Function(𝐒(𝐒(n))) → Function(𝐒(n))

Primitive : Type
Primitive = ℕ

module _ where
  open import Data.ListSized.Functions
  open import Functional

  private variable m n   : ℕ
  private variable i     : 𝕟(n)
  private variable x v   : Primitive
  private variable xs vs : List(Primitive)(n)
  private variable f g   : Function(m)
  private variable fs gs : List(Function(m))(n)

  -- The operational semantics.
  data _$_⟹_ : ∀{m n} → List(Function(m))(n) → List(Primitive)(m) → List(Primitive)(n) → Type
  data _$_⟶_ : ∀{n} → Function(n) → List(Primitive)(n) → ℕ → Type where
    zero : (Base $ ∅ ⟶ 𝟎)
    succ : (Successor $ singleton(n) ⟶ 𝐒(n))
    proj : (Projection{n}(i) $ xs ⟶ index(i)(xs))
    comp : (f $ vs ⟶ v) → (gs $ xs ⟹ vs) → (Composition{m}{n} f gs $ xs ⟶ v)
    rec𝟎 : (f $ xs ⟶ v) → (Recursion f g $ (𝟎 ⊰ xs) ⟶ v)
    rec𝐒 : (Recursion f g $ (n ⊰ xs) ⟶ x) → (g $ (n ⊰ x ⊰ xs) ⟶ v) → (Recursion f g $ (𝐒(n) ⊰ xs) ⟶ v)
  data _$_⟹_ where
    base : (∅ $ xs ⟹ ∅)
    step : (f $ xs ⟶ v) → (fs $ xs ⟹ vs) → ((f ⊰ fs) $ xs ⟹ (v ⊰ vs))

  -- Functionally equivalent to `evaluate f (map(g ↦ evaluate g xs)(gs))`, but the termination checker does not accept that form.
  mapEvaluate : ∀{m n} → List(Function(m))(n) → List(Primitive)(m) → List(Primitive)(n)

  -- The denotational semantics.
  -- This is possible to encode into an Agda function because: Primitive recursive functions ⊆ Agda functions.
  -- `Base` is interpreted as the constant 0.
  -- `Successor` is interpreted as the successor function of ℕ.
  -- `Projection{n}(i)` is interpreted as the projection of the i:th element of ℕⁿ.
  -- `Composition(f)(gs)` is interpreted as generalized composition by using map on the arguments of a function.
  --    Specifically (f ∘ (map gs)).
  -- `Recursion(f)(g)` is interpreted as a "recursion constructor".
  --    This is used to construct a function `r` in which the following holds:
  --    • r(0   ,..xs) = f(..xs)
  --    • r(𝐒(n),..xs) = g(n,r(n,..xs),..xs)
  {-# TERMINATING #-} -- TODO: Terminated before but the termination checker in Agda version 2.6.2-9bed10c denies this (or in some random cases it gives an internal error at src/full/Agda/TypeChecking/Reduce/Fast.hs:1358)
  evaluate : ∀{n} → Function(n) → (List(Primitive)(n) → Primitive)
  evaluate {.𝟎}   (Base)                     ∅             = 𝟎
  evaluate {.𝐒(𝟎)}(Successor)                (singleton x) = 𝐒(x)
  evaluate {_}    (Projection(i))            xs            = index(i)(xs)
  evaluate {m}    (Composition{m}{n}(f)(gs)) xs            = evaluate{n} f (mapEvaluate{m}{n} gs xs)
  evaluate {𝐒(_)} (Recursion(f)(g))          (𝟎    ⊰ xs)   = evaluate f xs
  evaluate {𝐒(m)} (Recursion(f)(g))          (𝐒(n) ⊰ xs)   = evaluate{𝐒(𝐒(m))} g (n ⊰ (evaluate{𝐒 m} (Recursion(f)(g)) (n ⊰ xs) ⊰ xs))

  mapEvaluate          ∅        xs = ∅
  mapEvaluate{m}{𝐒(n)} (g ⊰ gs) xs = (evaluate{m} g xs) ⊰ (mapEvaluate{m}{n} gs xs)

  ------------------------------------------------------
  -- This section proves the equivalence between the operational and the denotational semantics. Or it can be interpreted as the correctness of one of the definitions by the other one.
  -- This equivalence should be obvious from the definitions.
  --

  open import Relator.Equals
  open import Relator.Equals.Proofs
  open import Syntax.Transitivity

  [⟹]-to-eval : (fs $ xs ⟹ vs) → (mapEvaluate fs xs ≡ vs)

  [⟶]-to-eval : (f $ xs ⟶ v) → (evaluate f xs ≡ v)
  [⟶]-to-eval zero = [≡]-intro
  [⟶]-to-eval succ = [≡]-intro
  [⟶]-to-eval {xs = _⊰_ {𝟎}   x xs} (proj {i = 𝟎})   = [≡]-intro
  [⟶]-to-eval {xs = _⊰_ {𝐒 n} x xs} (proj {i = 𝟎})   = [≡]-intro
  [⟶]-to-eval {xs = _⊰_ {𝐒 n} x xs} (proj {i = 𝐒 i}) = [≡]-intro
  [⟶]-to-eval (comp p q) with [⟶]-to-eval p | [⟹]-to-eval q
  ... | [≡]-intro | [≡]-intro = [≡]-intro
  [⟶]-to-eval (rec𝟎 p) with [⟶]-to-eval p
  ... | [≡]-intro = [≡]-intro
  [⟶]-to-eval (rec𝐒 p q) with [⟶]-to-eval p | [⟶]-to-eval q
  ... | [≡]-intro | [≡]-intro = [≡]-intro
  [⟹]-to-eval {fs = ∅}      {vs = ∅}      _           = [≡]-intro
  [⟹]-to-eval {fs = f ⊰ fs} {vs = v ⊰ vs} (step p ps) with [⟶]-to-eval p | [⟹]-to-eval {fs = fs} {vs = vs} ps
  ... | [≡]-intro | [≡]-intro = [≡]-intro

  eval-to-[⟹] : (mapEvaluate fs xs ≡ vs) → (fs $ xs ⟹ vs)

  {-# TERMINATING #-} -- TODO: See TODO above in eval
  eval-to-[⟶] : (evaluate f xs ≡ v) → (f $ xs ⟶ v)
  eval-to-[⟶] {f = Base}             {∅}           [≡]-intro = zero
  eval-to-[⟶] {f = Successor}        {singleton x} [≡]-intro = succ
  eval-to-[⟶] {f = Projection _}                   [≡]-intro = proj
  eval-to-[⟶] {f = Composition f gs} {xs}          p         = comp (eval-to-[⟶] p) (eval-to-[⟹] [≡]-intro)
  eval-to-[⟶] {f = Recursion f g}    {𝟎    ⊰ xs}   p         = rec𝟎(eval-to-[⟶] {f = f}{xs = xs} p)
  eval-to-[⟶] {f = Recursion f g}    {𝐒(n) ⊰ xs}   p         = rec𝐒 (eval-to-[⟶] [≡]-intro) (eval-to-[⟶] p)

  eval-to-[⟹] {fs = ∅}      [≡]-intro = base
  eval-to-[⟹] {fs = f ⊰ fs} [≡]-intro = step (eval-to-[⟶] [≡]-intro) (eval-to-[⟹] [≡]-intro)

  -- TODO: Is it possible to prove that _⟶_ terminates and normalizes by using [⟶]-to-eval (total and deterministic)?

  open import Function.Equals
  open import Logic
  open import Logic.Predicate

  -- When a function on lists of primitives are primitive recursive.
  PrimitiveRecursive : (List(Primitive)(n) → Primitive) → Stmt
  PrimitiveRecursive(f) = ∃(e ↦ evaluate e ⊜ f)

Const : Function(0) → ∀{n} → Function(n)
Const(c) = Composition(c) ∅

-- TODO: Would encoding pairs make this easier to implement (e.g. the Cantor Pairing Function?
--  This is used to construct a function `r` in which the following holds for its evaluation:
--  • r(0      ,..xs) = f(..xs)
--  • r(1      ,..xs) = g(..xs)
--  • r(𝐒(𝐒(n)),..xs) = h(n,r(𝐒(n),..xs),r(n,..xs),..xs)
-- Recursion₂ : ∀{n : ℕ} → Function(n) → Function(n) → Function(𝐒(𝐒(𝐒(n)))) → Function(𝐒(n))
-- Recursion₂{n} (f)(g)(h) = Composition(Projection(0)) (Helper ⊰ ∅) where
--   Recursion
--
--   Helper : Function(2)
--   Helper =
--

module Arithmetic where -- TODO: Prove that these are correct by `evaluate`
  Zero = Base

  Number : ℕ → Function(0)
  Number(𝟎)    = Zero
  Number(𝐒(n)) = Composition(Successor) (Number(n) ⊰ ∅)

  Swap₂ : Function(2) → Function(2)
  Swap₂(f) = Composition(f) (Projection(1) ⊰ Projection(0) ⊰ ∅)

  -- Addition (+) in ℕ.
  -- It describes the following function:
  --   evaluate(Addition)[𝟎   ,b] = 𝟎
  --   evaluate(Addition)[𝐒(a),b] = 𝐒(b)
  Addition : Function(2)
  Addition = Recursion(Projection(0)) (Composition Successor (Projection(1) ⊰ ∅))

  -- Multiplication (⋅) in ℕ.
  -- It describes the following function:
  --   evaluate(Multiplication)[𝟎   ,b] = 𝟎
  --   evaluate(Multiplication)[𝐒(a),b] = evaluate(Multiplication)[a,b] + b
  Multiplication : Function(2)
  Multiplication = Recursion (Const(Zero)) (Composition Addition (Projection(1) ⊰ Projection(2) ⊰ ∅))

  -- Exponentiation (^) in ℕ.
  -- It describes the following function:
  --   evaluate(Exponentiation)[a   ,0   ] = 1
  --   evaluate(Exponentiation)[a   ,𝐒(b)] = evaluate(Exponentiation)[a,b] ⋅ a
  Exponentiation : Function(2)
  Exponentiation = Swap₂(Recursion (Composition Successor (Const Zero ⊰ ∅)) (Composition Multiplication (Projection(1) ⊰ Projection(2) ⊰ ∅)))

  -- Factorial (!) in ℕ.
  -- It describes the following function:
  --   evaluate(Factorial)[𝟎   ] = 1
  --   evaluate(Factorial)[𝐒(a)] = 𝐒(a) ⋅ evaluate(Factorial)[a,b]
  Factorial : Function(1)
  Factorial = Recursion(Number(1)) (Composition Multiplication ((Composition Successor (Projection(0) ⊰ ∅)) ⊰ Projection(1) ⊰ ∅))

  -- Predecessor (𝐏) in ℕ.
  -- It describes the following function:
  --   evaluate(Predecessor)[𝟎   ] = 𝟎
  --   evaluate(Predecessor)[𝐒(a)] = a
  Predecessor : Function(1)
  Predecessor = Recursion(Zero) (Projection(0))

  -- Monus/Cut-off minus (−₀) in ℕ.
  -- It describes the following function:
  --   evaluate(Monus)[b,𝟎   ] = b
  --   evaluate(Monus)[b,𝐒(a)] = 𝐏(evaluate(Monus)[b,a])
  Monus : Function(2)
  Monus = Swap₂(Recursion(Projection(0)) (Composition Predecessor (Projection(1) ⊰ ∅)))

  -- Maximum (max) of ℕ² in ℕ.
  -- It describes the following function:
  --   evaluate(Max)[a,b] = a + (b −₀ a)
  Max : Function(2)
  Max = Composition(Addition) (Projection(0) ⊰ Swap₂(Monus) ⊰ ∅)

  -- Minimum (min) of ℕ² in ℕ.
  -- It describes the following function:
  --   evaluate(Min)[a,b] = (a + b) −₀ max(a,b)
  Min : Function(2)
  Min = Composition(Monus) (Addition ⊰ Max ⊰ ∅)

  -- It describes the following function:
  --   evaluate(Distance)[a,b] = max(x −₀ y , y −₀ x)
  Distance : Function(2)
  Distance = Composition(Addition) (Monus ⊰ Swap₂(Monus) ⊰ ∅)

  -- It describes the following function:
  --   evaluate(IsZero)[𝟎]    = 1
  --   evaluate(IsZero)[𝐒(_)] = 0
  IsZero : Function(1)
  IsZero = Recursion(Number(1)) (Const(Zero))

  -- It describes the following function:
  --   evaluate(IsZero)[𝟎]    = 0
  --   evaluate(IsZero)[𝐒(_)] = 1
  IsNonZero : Function(1)
  IsNonZero = Composition(IsZero) (IsZero ⊰ ∅)

  Eq : Function(2)
  Eq = Composition(IsZero) (Distance ⊰ ∅)

  -- It describes the following function:
  --   evaluate(Fibonacci)[𝟎]    = 0
  --   evaluate(Fibonacci)[𝐒(_)] = 1
  -- Fibonacci : Function(1)
  -- Fibonacci = Composition(Projection(0)) (Fib ⊰ ∅) where
  --   Fib : Function(2)
  --   Fib =

-- TODO: http://www.reluctantm.com/gcruttw/teaching/cpsc513.W2010/A3Solutions.pdf
-- TODO: http://ii.fmph.uniba.sk/cl/courses/1-AIN-625-lpp/0910zs/ln/doc/ch_p_gd.pdf

module Proofs where
  open import Functional
  open import Logic.Propositional
  open import Numeral.Natural.Oper
  open import Numeral.Natural.Oper.Comparisons
  open import Numeral.Natural.Oper.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs
  open import Structure.Operator.Properties
  open import Structure.Relator.Properties
  open import Syntax.Transitivity

  addition-correctness : ∀{a b} → (evaluate Arithmetic.Addition (a ⊰ b ⊰ ∅) ≡ a + b)
  addition-correctness {𝟎}   {b} = [≡]-intro
  addition-correctness {𝐒 a} {b} = [≡]-with(𝐒) (addition-correctness {a}{b})

  multiplication-correctness : ∀{a b} → (evaluate Arithmetic.Multiplication (a ⊰ b ⊰ ∅) ≡ a ⋅ b)
  multiplication-correctness {𝟎}   {b} = [≡]-intro
  multiplication-correctness {𝐒 a} {b} =
    addition-correctness {evaluate Arithmetic.Multiplication (a ⊰ b ⊰ ∅)}{b}
    🝖 [≡]-with(_+ b) (multiplication-correctness {a}{b})
    🝖 symmetry(_≡_) ([⋅]-with-[𝐒]ₗ {a}{b})

  exponentiation-correctness : ∀{a b} → (evaluate Arithmetic.Exponentiation (a ⊰ b ⊰ ∅) ≡ a ^ b)
  exponentiation-correctness {a} {𝟎}   = [≡]-intro
  exponentiation-correctness {a} {𝐒 b} =
    multiplication-correctness {evaluate Arithmetic.Exponentiation (a ⊰ b ⊰ ∅)}{a}
    🝖 [≡]-with(_⋅ a) (exponentiation-correctness {a}{b})
    🝖 commutativity(_⋅_) {a ^ b}{a}

  factorial-correctness : ∀{a} → (evaluate Arithmetic.Factorial (a ⊰ ∅) ≡ a !)
  factorial-correctness {𝟎}   = [≡]-intro
  factorial-correctness {𝐒 a} =
    multiplication-correctness {𝐒 a}
    🝖 [≡]-with(𝐒(a) ⋅_) (factorial-correctness {a})

  predecessor-correctness : ∀{a} → (evaluate Arithmetic.Predecessor (a ⊰ ∅) ≡ 𝐏(a))
  predecessor-correctness {𝟎}   = [≡]-intro
  predecessor-correctness {𝐒 a} = [≡]-intro

  monus-correctness : ∀{a b} → (evaluate Arithmetic.Monus (a ⊰ b ⊰ ∅) ≡ a −₀ b)
  monus-correctness {a}   {𝟎}   = [≡]-intro
  monus-correctness {𝟎}   {𝐒 b} = predecessor-correctness{evaluate Arithmetic.Monus (𝟎 ⊰ b ⊰ ∅)} 🝖 [≡]-with(𝐏) (monus-correctness {𝟎}{b})
  monus-correctness {𝐒 a} {𝐒 b} =
    predecessor-correctness{evaluate Arithmetic.Monus (𝐒(a) ⊰ b ⊰ ∅)}
    🝖 [≡]-with(𝐏) (monus-correctness {𝐒 a}{b})
    🝖 symmetry(_≡_) ([−₀]-with-[𝐒]ᵣ {𝐒(a)}{b})

  isnonzero-correctness : ∀{a} → (evaluate Arithmetic.IsNonZero (a ⊰ ∅) ≡ ℕbool(a ≢? 𝟎))
  isnonzero-correctness {𝟎}   = [≡]-intro
  isnonzero-correctness {𝐒 a} = [≡]-intro

  iszero-correctness : ∀{a} → (evaluate Arithmetic.IsZero (a ⊰ ∅) ≡ ℕbool(a ≡? 𝟎))
  iszero-correctness {𝟎}   = [≡]-intro
  iszero-correctness {𝐒 a} = [≡]-intro

  -- TODO: Formalize "Function(1) is countably infinite". Maybe take some inspiration from https://proofwiki.org/wiki/Not_All_URM_Computable_Functions_are_Primitive_Recursive . Then prove that (ℕ → ℕ) is not countably infinite, and therefore not all computable functions are expressible primitive recursively (is this argument constructive?)

  open import Data.Tuple
  open import Function.Inverse
  open import Logic.Predicate
  open import Logic.Propositional
  open import Type.Size.Countable
  open import Structure.Function.Domain.Proofs
  open import Structure.Function using (congruence₁)
  open import Syntax.Function
  open import Syntax.Transitivity

  postulate Function-countablyInfinite : CountablyInfinite(Function(1))
  encodeFunction : Function(1) → ℕ
  encodeFunction = inv _ ⦃ bijective-to-invertible ⦃ bij = [∃]-proof Function-countablyInfinite ⦄ ⦄

  -- TODO: Use a lifted Numeral.Natural.Sequence.pairIndexing as a witness directly (instead of encodePair). Another alternative is (a ↦ b ↦ 2ᵃ⋅3ᵇ) if it is easier to construct f that way.
  postulate Function-value-pair-countablyInfinite : CountablyInfinite(Function(1) ⨯ ℕ)
  encodePair : (Function(1) ⨯ ℕ) → ℕ
  encodePair = inv _ ⦃ bijective-to-invertible ⦃ bij = [∃]-proof Function-value-pair-countablyInfinite ⦄ ⦄

  -- TODO: Is it possible to use Logic.DiagonalMethod for this proof?
  no-self-interpreter : ¬ ∃(interpret ↦ ∀{f}{n} → evaluate interpret (singleton (encodePair(f , n))) ≡ evaluate f (singleton n))
  no-self-interpreter ([∃]-intro interpret ⦃ p ⦄) = 𝐒-not-self(symmetry(_≡_) x) where
    postulate f : Function(1)
    postulate f-correctness : ∀{g} → (evaluate f (singleton(encodeFunction g)) ≡ encodePair(g , encodeFunction g))

    g : Function(1)
    g = Composition Successor (singleton (Composition interpret (singleton f)))

    x : evaluate g (singleton (encodeFunction g)) ≡ 𝐒(evaluate g (singleton (encodeFunction g)))
    x =
      evaluate g (singleton (encodeFunction g))                                   🝖[ _≡_ ]-[]
      𝐒(evaluate interpret (singleton(evaluate f (singleton(encodeFunction g))))) 🝖[ _≡_ ]-[ congruence₁(𝐒) (congruence₁(evaluate interpret) (congruence₁(singleton) f-correctness)) ]
      𝐒(evaluate interpret (singleton(encodePair(g , encodeFunction g))))         🝖[ _≡_ ]-[ congruence₁(𝐒) p ]
      𝐒(evaluate g (singleton(encodeFunction g)))                                 🝖-end


module Numeral.Natural.Coprime where

open import Logic
import      Lvl
open import Numeral.Natural
open import Numeral.Natural.Relation.Divisibility
open import Relator.Equals

private variable n x y : ℕ

-- Two numbers are coprime when their only divisor is 1.
record Coprime (x : ℕ) (y : ℕ) : Stmt{Lvl.𝟎} where
  constructor intro
  field proof : (n ∣ x) → (n ∣ y) → (n ≡ 1)


open import Level using (Level; suc; zero; _⊔_)
open import Algebra.Structures
open import Algebra.FunctionProperties as FunctionProperties using (Op₁; Op₂)
open import Relation.Binary

-- Definition of an ordered monoid, which adds the law that ∙ must
-- preserve the partial order ≤ (or, equivalently, that an ordering x
-- ≤ y must allow for the substitution of y for x in a more complex
-- ordering) to an existing monoid and partial order.
module Algebra.OrderedMonoid where

record IsOrderedMonoid {a ℓ₁ ℓ₂} {A : Set a} (≈ : Rel A ℓ₁) (≤ : Rel A ℓ₂) (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isMonoid       : IsMonoid ≈ ∙ ε
    isPartialOrder : IsPartialOrder ≈ ≤
    compatibility  : ∙ Preserves₂ ≤ ⟶ ≤ ⟶ ≤

  open IsMonoid isMonoid public
       hiding (isEquivalence)
  open IsPartialOrder isPartialOrder public
       renaming (refl to ≤-refl; trans to ≤-trans; reflexive to ≤-reflexive)

record OrderedMonoid c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where
  infixl 7 _∙_
  infix  4 _≈_
  infix  4 _≤_
  field
    Carrier         : Set c
    _≈_             : Rel Carrier ℓ₁
    _≤_             : Rel Carrier ℓ₂
    _∙_             : Op₂ Carrier
    ε               : Carrier
    isOrderedMonoid : IsOrderedMonoid _≈_ _≤_ _∙_ ε

  open IsOrderedMonoid isOrderedMonoid public

  substitutivity : ∀ {x y z w} → x ≤ y → z ∙ x ∙ w ≤ z ∙ y ∙ w
  substitutivity x≤y = compatibility (compatibility ≤-refl x≤y) ≤-refl


module Bool where

import Logic
open Logic

data Bool : Set where
  false : Bool
  true  : Bool

infixr 5 _&&_

_&&_ : Bool -> Bool -> Bool
true  && x = x
false && _ = false

not : Bool -> Bool
not true  = false
not false = true

IsTrue : Bool -> Set
IsTrue true  = True
IsTrue false = False

IsFalse : Bool -> Set
IsFalse x = IsTrue (not x)

module BoolEq where

  _==_ : Bool -> Bool -> Bool
  true  == x = x
  false == x = not x

  subst : {x y : Bool}(P : Bool -> Set) -> IsTrue (x == y) -> P x -> P y
  subst {true}{true}   _ _ px = px
  subst {false}{false} _ _ px = px
  subst {true}{false}  _ () _
  subst {false}{true}  _ () _

  isTrue== : {x : Bool} -> IsTrue x -> IsTrue (x == true)
  isTrue== {true} _ = tt
  isTrue== {false} ()

infix 1 if_then_else_

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y

open BoolEq

if'_then_else_ : {A : Set} -> (x : Bool) -> (IsTrue x -> A) -> (IsFalse x -> A) -> A
if' true  then f else g = f tt
if' false then f else  g = g tt

isTrue&&₁ : {x y : Bool} -> IsTrue (x && y) -> IsTrue x
isTrue&&₁ {true} _ = tt
isTrue&&₁ {false} ()

isTrue&&₂ : {x y : Bool} -> IsTrue (x && y) -> IsTrue y
isTrue&&₂ {true} p = p
isTrue&&₂ {false} ()


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Vec.NAry where

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

open import Cubical.Data.Nat
open import Cubical.Data.Vec.Base

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

nAryLevel : Level → Level → ℕ → Level
nAryLevel ℓ₁ ℓ₂ zero    = ℓ₂
nAryLevel ℓ₁ ℓ₂ (suc n) = ℓ-max ℓ₁ (nAryLevel ℓ₁ ℓ₂ n)

nAryOp : (n : ℕ) → Type ℓ → Type ℓ' → Type (nAryLevel ℓ ℓ' n)
nAryOp zero A B    = B
nAryOp (suc n) A B = A → nAryOp n A B

_$ⁿ_ : ∀ {n} → nAryOp n A B → (Vec A n → B)
f $ⁿ []       = f
f $ⁿ (x ∷ xs) = f x $ⁿ xs

curryⁿ : ∀ {n} → (Vec A n → B) → nAryOp n A B
curryⁿ {n = zero}  f   = f []
curryⁿ {n = suc n} f x = curryⁿ (λ xs → f (x ∷ xs))

$ⁿ-curryⁿ : ∀ {n} (f : Vec A n → B) → _$ⁿ_ (curryⁿ f) ≡ f
$ⁿ-curryⁿ {n = zero} f  = funExt λ { [] → refl }
$ⁿ-curryⁿ {n = suc n} f = funExt λ { (x ∷ xs) i → $ⁿ-curryⁿ {n = n} (λ ys → f (x ∷ ys)) i xs}

curryⁿ-$ⁿ : ∀ {n} (f : nAryOp {ℓ = ℓ} {ℓ' = ℓ'} n A B) → curryⁿ {A = A} {B = B} (_$ⁿ_ f) ≡ f
curryⁿ-$ⁿ {n = zero} f  = refl
curryⁿ-$ⁿ {n = suc n} f = funExt λ x → curryⁿ-$ⁿ {n = n} (f x)

nAryOp≃VecFun : ∀ {n} → nAryOp n A B ≃ (Vec A n → B)
nAryOp≃VecFun {n = n} = isoToEquiv f
  where
  f : Iso (nAryOp n A B) (Vec A n → B)
  Iso.fun f      = _$ⁿ_
  Iso.inv f      = curryⁿ
  Iso.rightInv f = $ⁿ-curryⁿ
  Iso.leftInv f  = curryⁿ-$ⁿ {n = n}

-- In order to apply ua to nAryOp≃VecFun we probably need to change
-- the base-case of nAryLevel to "ℓ-max ℓ₁ ℓ₂". This will make it
-- necessary to add lots of Lifts in zero cases so it's not done yet,
-- but if the Path is ever needed then it might be worth to do.


{-# OPTIONS --without-K --safe #-}
module Categories.Category where

open import Level

-- The main definitions are in:
open import Categories.Category.Core public

private
  variable
    o ℓ e : Level

-- Convenience functions for working over mupliple categories at once:
-- C [ x , y ] (for x y objects of C) - Hom_C(x , y)
-- C [ f ≈ g ] (for f g arrows of C)  - that f and g are equivalent arrows
-- C [ f ∘ g ] (for f g composables arrows of C) - composition in C
infix 10  _[_,_] _[_≈_] _[_∘_]

_[_,_] : (C : Category o ℓ e) → (X : Category.Obj C) → (Y : Category.Obj C) → Set ℓ
_[_,_] = Category._⇒_

_[_≈_] : (C : Category o ℓ e) → ∀ {X Y} (f g : C [ X , Y ]) → Set e
_[_≈_] = Category._≈_

_[_∘_] : (C : Category o ℓ e) → ∀ {X Y Z} (f : C [ Y , Z ]) → (g : C [ X , Y ]) → C [ X , Z ]
_[_∘_] = Category._∘_

module Definitions (𝓒 : Category o ℓ e) where
  open Category 𝓒

  CommutativeSquare : {A B C D : Obj} → (f : A ⇒ B) (g : A ⇒ C) (h : B ⇒ D) (i : C ⇒ D) → Set _
  CommutativeSquare f g h i = h ∘ f ≈ i ∘ g

-- Combinators for commutative diagram
-- The idea is to use the combinators to write commutations in a more readable way.
-- It starts with [_⇒_]⟨_≈_⟩, and within the third and fourth places, use _⇒⟨_⟩_ to
-- connect morphisms with the intermediate object specified.
module Commutation (𝓒 : Category o ℓ e) where
  open Category 𝓒

  infix 1 [_⇒_]⟨_≈_⟩
  [_⇒_]⟨_≈_⟩ : ∀ (A B : Obj) → A ⇒ B → A ⇒ B → Set _
  [ A ⇒ B ]⟨ f ≈ g ⟩ = f ≈ g

  infixl 2 connect
  connect : ∀ {A C : Obj} (B : Obj) → A ⇒ B → B ⇒ C → A ⇒ C
  connect B f g = g ∘ f

  syntax connect B f g = f ⇒⟨ B ⟩ g


-- Quicksort

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

module Algorithms.List.Sort.Quick where

-- agda-stdlib
open import Level
open import Data.List
import      Data.List.Properties as Listₚ
open import Data.Product
import      Data.Nat as ℕ
open import Data.Nat.Induction as Ind
open import Relation.Binary as B
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Unary as U
import      Relation.Unary.Properties as Uₚ
open import Function.Base
open import Induction.WellFounded

private
  variable
    a p r : Level

module _ {A : Set a} {P : U.Pred A p} (P? : U.Decidable P) where
  partition₁-defn : ∀ xs → proj₁ (partition P? xs) ≡ filter P? xs
  partition₁-defn xs = P.cong proj₁ (Listₚ.partition-defn P? xs)

  partition₂-defn : ∀ xs → proj₂ (partition P? xs) ≡ filter (Uₚ.∁? P?) xs
  partition₂-defn xs = P.cong proj₂ (Listₚ.partition-defn P? xs)

  length-partition₁ : ∀ xs → length (proj₁ (partition P? xs)) ℕ.≤ length xs
  length-partition₁ xs =
    P.subst (ℕ._≤ length xs)
            (P.sym $ P.cong length $ partition₁-defn xs)
            (Listₚ.length-filter P? xs)

  length-partition₂ : ∀ xs → length (proj₂ (partition P? xs)) ℕ.≤ length xs
  length-partition₂ xs =
    P.subst (ℕ._≤ length xs)
            (P.sym $ P.cong length $ partition₂-defn xs)
            (Listₚ.length-filter (Uₚ.∁? P?) xs)

module Quicksort {A : Set a} {_≤_ : Rel A r} (_≤?_ : B.Decidable _≤_) where
  split : A → List A → List A × List A
  split x xs = partition (λ y → y ≤? x) xs

  _L<_ : Rel (List A) _
  _L<_ = ℕ._<_ on length

  sort-acc : ∀ xs → Acc _L<_ xs → List A
  sort-acc []       _        = []
  sort-acc (x ∷ xs) (acc rs) =
    sort-acc ys (rs _ (ℕ.s≤s $ length-partition₁ (_≤? x) xs)) ++
    [ x ] ++
    sort-acc zs (rs _ (ℕ.s≤s $ length-partition₂ (_≤? x) xs))
    where
    splitted = split x xs
    ys = proj₁ splitted
    zs = proj₂ splitted

  L<-wf : WellFounded _L<_
  L<-wf = InverseImage.wellFounded length Ind.<-wellFounded

  -- Quicksort
  sort : List A → List A
  sort xs = sort-acc xs (L<-wf xs)


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

open import Categories.Category

module Categories.Category.Cocomplete.Finitely {o ℓ e} (C : Category o ℓ e) where

open import Level

open import Categories.Category.Cocartesian C
open import Categories.Diagram.Coequalizer C
open import Categories.Diagram.Pushout C
open import Categories.Diagram.Pushout.Properties C

open Category C

record FinitelyCocomplete : Set (levelOfTerm C) where
  field
    cocartesian : Cocartesian
    coequalizer : ∀ {A B} (f g : A ⇒ B) → Coequalizer f g

  module cocartesian = Cocartesian cocartesian
  module coequalizer {A B} (f g : A ⇒ B) = Coequalizer (coequalizer f g)
  open cocartesian public

  pushout : ∀ {X Y Z} (f : X ⇒ Y) (g : X ⇒ Z) → Pushout f g
  pushout f g = Coproduct×Coequalizer⇒Pushout coproduct (coequalizer _ _)

  module pushout {X Y Z} (f : X ⇒ Y) (g : X ⇒ Z) = Pushout (pushout f g)


module FunctionsInIndices where

open import Prelude
open import Eq

data Tree (a : Set) : ℕ -> Set where
  leaf : a -> Tree a 1
  node : forall n₁ n₂ -> Tree a n₁ -> Tree a n₂ -> Tree a (n₁ + n₂)

-- This does not work:

-- leftmost : forall {a} n -> Tree a (suc n) -> a
-- leftmost .0         (leaf x)                     = x
-- leftmost .n₂        (node zero     (suc n₂) l r) = leftmost l
-- leftmost .(n₁ + n₂) (node (suc n₁) n₂       l r) = leftmost l

module Workaround1 where

  private

    T : Set -> ℕ -> Set
    T a zero    = ⊤
    T a (suc n) = a

    leftmost' : forall {a n} -> Tree a n -> T a n
    leftmost' (leaf x)                     = x
    leftmost' (node zero     zero     l r) = tt
    leftmost' (node zero     (suc n₂) l r) = leftmost' r
    leftmost' (node (suc n₁) n₂       l r) = leftmost' l

  leftmost : forall {a n} -> Tree a (suc n) -> a
  leftmost = leftmost'

module Workaround2 where

  private

    leftmost' : forall {a n m} -> Tree a m -> m ≡ suc n -> a
    leftmost' (leaf x)                     _  = x
    leftmost' (node zero     (suc n₂) l r) _  = leftmost' r refl
    leftmost' (node (suc n₁) n₂       l r) _  = leftmost' l refl

  leftmost : forall {a n} -> Tree a (suc n) -> a
  leftmost t = leftmost' t refl


module irreflexive where

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

open import Negation using (¬_)

infix 4 _<_
data _<_ : ℕ → ℕ → Set where
  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n

  s<s : ∀ {m n : ℕ}
    → m < n
      -------------
    → suc m < suc n

-- n が非反射律 ∀ n ∈ ℕ, ¬(n < n) を満たすことの証明
<-irreflexive : ∀ (n : ℕ) → ¬ (n < n)
<-irreflexive zero ()
<-irreflexive (suc n) (s<s n<n) = <-irreflexive n n<n


open import Data.Nat using ( zero ; suc ) renaming ( ℕ to ♭ℕ ; _+_ to add )
open import Function using () renaming ( _∘′_ to _∘_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; trans ; cong ; cong₂ )

open import AssocFree.Util using ( ≡-relevant )

module AssocFree.DNat where

open Relation.Binary.PropositionalEquality.≡-Reasoning using ( begin_ ; _≡⟨_⟩_ ; _∎ )

infixr 5 _,_
infixr 5 _+_

_+♭_ = add

add-unit : ∀ n → (add n 0) ≡ n
add-unit zero    = refl
add-unit (suc n) = cong suc (add-unit n)

add-assoc : ∀ m n → (add (add m n) ≡ ((add m) ∘ (add n)))
add-assoc zero    n = refl
add-assoc (suc m) n = cong (_∘_ suc) (add-assoc m n)

-- "Difference nats" are isomorphic to ℕ but have _+_ associative up
-- to beta-reduction, not just up to _≡_.

record ℕ : Set where
  constructor _,_
  field
    fun : ♭ℕ → ♭ℕ
    .fun✓ : fun ≡ add (fun 0)

open ℕ public

-- Convert ℕ to ♭ℕ and back

♯ : ♭ℕ → ℕ
♯ n = (add n , cong add (sym (add-unit n)))

♭ : ℕ → ♭ℕ
♭ (f , f✓) = f 0

-- Constants

♯0 = ♯ 0
♯1 = ♯ 1

-- Addition

_+_ : ℕ → ℕ → ℕ
(f , f✓) + (g , g✓) = ((f ∘ g) , f∘g✓) where
  .f∘g✓ : (f ∘ g) ≡ add (f (g 0))
  f∘g✓ = begin
      f ∘ g
    ≡⟨ cong₂ _∘_ f✓ g✓ ⟩
      add (f 0) ∘ add (g 0)
    ≡⟨ sym (add-assoc (f 0) (g 0)) ⟩
      add (add (f 0) (g 0))
    ≡⟨ cong (λ X → add (X (g 0))) (sym f✓) ⟩
      add (f (g 0))
    ∎

--Isomorphism which respects +

inject : ∀ m n → (fun m ≡ fun n) → (m ≡ n)
inject (f , f✓) (.f , g✓) refl = refl

iso : ∀ n → ♯ (♭ n) ≡ n
iso n = inject (♯ (♭ n)) n (sym (≡-relevant (fun✓ n)))

iso⁻¹ : ∀ n → ♭ (♯ n) ≡ n
iso⁻¹ = add-unit

iso-resp-+ : ∀ m n → ♭ (m + n) ≡ (♭ m +♭ ♭ n)
iso-resp-+ (f , f✓) (g , g✓) = cong (λ X → X (g 0)) (≡-relevant f✓)

-- Addition forms a monoid on the nose

+-assoc : ∀ l m n → (((l + m) + n) ≡ (l + (m + n)))
+-assoc l m n = refl

+-unit₁ : ∀ n → ((♯0 + n) ≡ n)
+-unit₁ n = refl

+-unit₂ : ∀ n → ((n + ♯0) ≡ n)
+-unit₂ n = refl


{-# OPTIONS --safe #-}
module RevRev where

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

rev : ∀ {ℓ} {A : Set ℓ} → List A → List A
rev [] = []
rev (x ∷ xs) = rev xs ++ x ∷ []

lemma : ∀ {ℓ} {A : Set ℓ} (a b : List A) → rev (a ++ b) ≡ rev b ++ rev a
lemma [] b rewrite ++-identityʳ (rev b) = refl
lemma (x ∷ a) b rewrite lemma a b | ++-assoc (rev b) (rev a) (x ∷ []) = refl

revrevid : ∀ {ℓ} {A : Set ℓ} (a : List A) → rev (rev a) ≡ a
revrevid [] = refl
revrevid (x ∷ a) rewrite lemma (rev a) (x ∷ []) | revrevid a = refl


module #2 where

open import Relation.Binary.PropositionalEquality
open import #1

{-
Exercise 2.2. Show that the three equalities of proofs constructed in the previous exercise form a
commutative triangle. In other words, if the three definitions of concatenation are denoted by
(p ∘ q), (p ∘ q), and (p ∘ q), then the concatenated equality

         (p ∘ q) = (p ∘ q) = (p ∘ q)

is equal to the equality (p ∘ q) = (p ∘ q).
-}

composite-commutative-triangle : ∀ {i} {A : Set i}{x y z : A} → (p : x ≡ y) (q : y ≡ z) →
    composite (composite=composite' p q) (composite'=composite'' p q) ≡ composite=composite'' p q
composite-commutative-triangle refl refl = refl


module LearnYouAn where
  data ℕ : Set where
    zero : ℕ
    suc : ℕ → ℕ

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

  -- if_then_else_ : ∀ { a } → Bool → a → a → a

  data _even : ℕ → Set where
    ZERO : zero even
    STEP : ∀ {x} → x even → suc (suc x) even

  proof₁ : suc (suc (suc (suc zero))) even
  proof₁ = STEP (STEP ZERO)

  proof₂′ : (A : Set) → A → A
  proof₂′ _ x = x

  proof₂ : ℕ → ℕ
  proof₂ = proof₂′ ℕ


open import Sec4

data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

-- Now ≥ relation
_≥_ : ∀ (m : ℕ) → ∀ (n : ℕ) → Prop
Z ≥ Z = ⊤
S m ≥ Z = ⊤
Z ≥ S n = ⊥
S m ≥ S n = m ≥ n

-- Example proof
-- eqqr : ((S (S (S Z))) ≥ (S (S Z))) → ((S (S Z)) ≥ (S (S (S Z))))
-- eqqr ()

-- -- Now is ≥ equivalence relation?
-- relfexivity
reflexivity : ∀ (m : ℕ) → (m ≥ m)
reflexivity  Z = ⋆
reflexivity  (S m) = reflexivity m

-- -- -- Now symmetry
-- sym : ∀ (m : ℕ) → ∀ (n : ℕ) → m ≥ n → n ≥ m
-- sym Z Z p = ⋆
-- sym Z (S n) p = ⋆
-- sym (S m) Z ⋆ = {!!}
-- sym (S m) (S n) p = sym m n p

-- -- -- Now transitivity
trans'' : ∀ (m : ℕ) → ∀ (n : ℕ) → ∀ (p : ℕ) → m ≥ n → n ≥ p → m ≥ p
trans'' Z Z p p0 p1 = p1
trans'' Z (S n) p () p1
trans'' (S m) n Z p0 p1 = ⋆
trans'' (S m) Z (S p) p0 ()
trans'' (S m) (S n) (S p) p0 p1 = trans'' m n p p0 p1

-- Given the above three are satisfied, we know that it is an
-- equivalence relation!

-- Now let us try strictly greater than (>)

-- Definition of >
_>_ : ∀ (m : ℕ) → ∀ (n : ℕ) → Prop
Z > Z =  ⊥
Z > S n = ⊥
S m > Z = ⊤
S m > S n = m > n

-- Now let us see of > is an equivalence relation

-- reflixvity of > not possible!
-- refl-> : ∀ (m : ℕ) → m > m
-- refl-> Z = {!!}
-- refl-> (S m) = refl-> m

-- equality
_==_ : ∀ (m : ℕ) → ∀ (n : ℕ) → Prop
Z == Z =  ⊤
Z == S n = ⊥
S m == Z = ⊥
S m == S n = m == n

-- Is equiality an equivalence relation?

-- reflexivity
refl-≡ : ∀ (m : ℕ) → m == m
refl-≡ Z = ⋆
refl-≡ (S m) = refl-≡ m

-- Symmetry
sym-≡ : ∀ (m : ℕ) → ∀ (n : ℕ) → m == n → n == m
sym-≡ Z Z h = ⋆
sym-≡ Z (S n) ()
sym-≡ (S m) Z ()
sym-≡ (S m) (S n) h = sym-≡ m n h

-- Transitivity
trans-≡ : ∀ (m n p : ℕ) → m == n → n == p → m == p
trans-≡ Z n Z h0 h1 = ⋆
trans-≡ Z Z (S p) h0 h1 = h1
trans-≡ Z (S n) (S p) () h1
trans-≡ (S m) Z Z () h1
trans-≡ (S m) (S n) Z h0 ()
trans-≡ (S m) Z (S p) () h1
trans-≡ (S m) (S n) (S p) h0 h1 = trans-≡ m n p h0 h1

-- Homework ≤ on natural numbers

-- Addition of natural numbers
_+_ : ∀ (m n : ℕ) → ℕ
Z + n = n
S m + n = S (m + n)

-- Use equality, 2 + 3 == 3 + 2
eqq : ((S (S Z)) + (S ( S ( S Z)))) == ((S ( S ( S Z))) + (S (S Z)))
eqq = ⋆

infix 4 _≡_
data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x
{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REFL     refl #-}

eqq2 : ((S (S Z)) + (S ( S ( S Z)))) ≡ ((S ( S ( S Z))) + (S (S Z)))
eqq2 = refl

cong : ∀ (n m : ℕ) → n ≡ m → S n ≡ S m
cong n .n refl = refl

-lemma-+ : ∀ (n : ℕ) → n ≡ (n + Z)
-lemma-+ Z = refl
-lemma-+ (S n) with -lemma-+ n
-lemma-+ (S n) | h = cong n (n + Z) h

lem2 : ∀ (m n : ℕ) → (m + S n) ≡ S (m + n)
lem2 Z n = refl
lem2 (S m) n = cong (m + S n) (S (m + n)) (lem2 m n)

-- Now prove commutativity of addition
commute-+ : ∀ (m n : ℕ) → (m + n) ≡ (n + m)
commute-+ Z n = -lemma-+ n
commute-+ (S m) n with (n + S m) | (lem2 n m)
commute-+ (S m) n | .(S (n + m)) | refl = cong (m + n) (n + m) (commute-+ m n)

_<_ : ∀ (m n : ℕ) → Prop
Z < Z = ⊥
Z < S n = ⊥
S m < Z = ⊤
S m < S n = m < n

-- refl-< : ∀ (m : ℕ) → m < m
-- refl-< Z = !!
-- refl-< (S m) = !!

-- Define booleans
data 𝔹 : Set where
 True : 𝔹
 False : 𝔹

-- Define &&
_&&_ : ∀ (A B : 𝔹) → 𝔹
True && True = True
True && False = False
False && B = False

-- Define ||
_||_ : ∀ (A B : 𝔹) → 𝔹
True || B = True
False || True = True
False || False = False

-- Prove equivalence of two hardware functions g and f
g : ∀ (A B C : 𝔹) → 𝔹
g A B C = B && (A || C)

ff : ∀ (A B C : 𝔹) → 𝔹
ff A B C = (A && B) || ((B && C) && (B || C))

-- Equality of booleans
_==̰_ : ∀ (A B : 𝔹) → Prop
True ==̰ True = ⊤
True ==̰ False = ⊥
False ==̰ True = ⊥
False ==̰ False = ⊤

-- Now prove that for any input A B C, g ≡ ff
g≃ff : ∀ (A B C : 𝔹) → (g A B C) ==̰ (ff A B C)
g≃ff True True True = ⋆
g≃ff True True False = ⋆
g≃ff True False C = ⋆
g≃ff False True True = ⋆
g≃ff False True False = ⋆
g≃ff False False C = ⋆

_≤_ : ∀ (m n : ℕ) → Prop
Z ≤ n = ⊤
S m ≤ Z = ⊥
S m ≤ S n = m ≤ n

-- Symmetry on ≤
-- sym-≤ : ∀ (m n : ℕ) → (m ≤ n) → (n ≤ m)
-- sym-≤ Z Z ⋆ = ⋆
-- sym-≤ Z (S n) ⋆ = {!!}
-- sym-≤ (S m) Z ()
-- sym-≤ (S m) (S n) p = sym-≤ m n p

-- ≠
_≠_ : ∀ (m n : ℕ) → Prop
Z ≠ Z = ⊥
Z ≠ S n = ⊤
S m ≠ Z = ⊤
S m ≠ S n = m ≠ n

-- -- Is ≠ an equivalence relation?
-- ≠-refl
-- ≠-relf : ∀ (m : ℕ) → (m ≠ m)
-- ≠-relf Z = {!!}
-- ≠-relf (S m) = ≠-relf m

-- -- Symmetry
≠-sym : ∀ (m n : ℕ) → (m ≠ n) → (n ≠ m)
≠-sym Z Z ()
≠-sym Z (S n) p = ⋆
≠-sym (S m) Z p = ⋆
≠-sym (S m) (S n) p = ≠-sym m n p

-- -- Transitivity
-- ≠-trans : ∀ (m n p : ℕ) → (m ≠ n) → (n ≠ p) → (m ≠ p)
-- ≠-trans Z Z Z h0 ()
-- ≠-trans Z (S n) Z ⋆ ⋆ = {!!}
-- ≠-trans Z n (S p) h0 h1 = ⋆
-- ≠-trans (S m) n Z h0 h1 = ⋆
-- ≠-trans (S m) Z (S p) ⋆ ⋆ = {!!}
-- ≠-trans (S m) (S n) (S p) h0 h1 = ≠-trans m n p h0 h1

de1 : {A B : Prop} → ((¬ A) ∨ (¬ B)) ⇒ ¬ (A ∧ B)
de1 = impl (λ x → neg (impl (λ x₁ →
                               let y = elim1-∧ x₁
                                   z = elim2-∧ x₁
                               in
                               elim-∨ x (λ x₃ → elim-neg y x₃) (λ x₂ → elim-neg z x₂))))

de2 : {A B : Prop} → ((¬ A) ∧ (¬ B)) ⇒ (¬ (A ∨ B))
de2 = impl (λ x → neg (impl (λ x₁ → elim-∨ x₁ (λ x₂ → elim-neg x₂ (elim1-∧ x))
                                             (λ x₂ → elim-neg x₂ (elim2-∧ x)))))

-- Multiplication of naturals
_*_ : ∀ (m n : ℕ) → ℕ
Z * n = Z
S m * n = n + (m * n)

-- Square relation on two naturals
_r²_ : ∀ (m n : ℕ) → Prop
m r² n = (m * m) ≡ (n * n)

-- reflexivity of r²
refl-r² : ∀ (m : ℕ) → (m r² m)
refl-r² Z = refl
refl-r² (S m) = refl

sym-r² : ∀ (m n : ℕ) → (m r² n) → (n r² m)
sym-r² Z Z p = refl
sym-r² Z (S n) ()
sym-r² (S m) Z ()
sym-r² (S m) (S n) p rewrite p = refl

trans-r² : ∀ (m n p : ℕ) → (m r² n) → (n r² p) → (m r² p)
trans-r² Z n Z h0 h1 = refl
trans-r² Z Z (S p) refl ()
trans-r² Z (S n) (S p) () h1
trans-r² (S m) Z Z () h1
trans-r² (S m) (S n) Z h0 ()
trans-r² (S m) Z (S p) () h1
trans-r² (S m) (S n) (S p) h0 h1 rewrite h0
                                        | h1 = refl


module Data.Bin.Props where

  open import Data.Bin
  import Data.Nat
  import Data.Nat.Properties
  open Data.Nat using (ℕ)
  open import Data.List
  open import Relation.Binary.PropositionalEquality
  open import Function using (_⟨_⟩_)
  open import Algebra.Structures using (IsCommutativeMonoid; module IsCommutativeMonoid; module IsCommutativeSemiring)

  import Data.Bin.Addition

  bin-+-is-comm-monoid = Data.Bin.Addition.is-commutativeMonoid

  open import Data.Bin.Bijection using (fromℕ-bijection)

  import Algebra.Lifting
  module Lifting = Algebra.Lifting _ _ fromℕ-bijection

  open import Data.Bin.Multiplication

  bin-*-is-comm-monoid : IsCommutativeMonoid _≡_ _*_ ([] 1#)
  bin-*-is-comm-monoid = lift-isCommutativeMonoid 1 *-isCommutativeMonoid
   where
     open IsCommutativeSemiring Data.Nat.Properties.isCommutativeSemiring using(*-isCommutativeMonoid)
     open Lifting.WithOp₂ Data.Nat._*_ _*_ *-is-multiplication

  open IsCommutativeMonoid bin-*-is-comm-monoid using () renaming (comm to *-comm)

  *2-is-2* : ∀ x → x *2 ≡ (fromℕ 2) * x
  *2-is-2* 0# = refl
  *2-is-2* (bs 1#) = refl

  *-distrib : ∀ {a b c} → (a + b) * c ≡ a * c + b * c
  *-distrib {a} {b} {c} = Data.Bin.Multiplication.*-distribʳ a b c

  *2-distrib : ∀ a b → (a + b) *2 ≡ a *2 + b *2
  *2-distrib a b = *2-is-*2-bin (a + b) ⟨ trans ⟩ *-distrib {a} {b} {fromℕ 2} ⟨ trans ⟩ cong₂ _+_ (sym (*2-is-*2-bin a)) (sym (*2-is-*2-bin b))
   where
    *2-is-*2-bin : ∀ a → a *2 ≡ a * fromℕ 2
    *2-is-*2-bin a = *2-is-2* a ⟨ trans ⟩ *-comm (fromℕ 2) a

  open import Function
  open import Data.Empty
  1+≢0 : ∀ l → toℕ (l 1#) ≢ 0
  1+≢0 l eq = case Data.Bin.Bijection.toℕ-inj {l 1#} {0#} eq of (λ ())

  z<nzℕ : ∀ {n} → n ≢ 0 → Data.Nat._<_ 0 n
  z<nzℕ {Data.Bin.0b} neq = ⊥-elim (neq refl)
  z<nzℕ {Data.Bin.Bijection.1+ n} neq = Data.Nat.s≤s Data.Nat.z≤n

  z<nz : ∀ l → 0# < l 1#
  z<nz l = Data.Bin.less (z<nzℕ (1+≢0 l))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Showing natural numbers
------------------------------------------------------------------------

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

module Data.Nat.Show where

open import Data.Char as Char using (Char)
open import Data.Digit using (showDigit; toDigits; toNatDigits)
open import Function using (_∘_; _$_)
open import Data.List.Base using (List; []; _∷_; map; reverse)
open import Data.Nat
open import Data.Product using (proj₁)
open import Data.String as String using (String)
open import Relation.Nullary.Decidable using (True)

------------------------------------------------------------------------
-- Conversion from unary representation to the representation by the
-- given base.

toDigitChar : (n : ℕ) → Char
toDigitChar n = Char.fromℕ (n + (Char.toℕ '0'))

toDecimalChars : ℕ → List Char
toDecimalChars = map toDigitChar ∘ toNatDigits 10

------------------------------------------------------------------------
-- Show

-- Time complexity is O(log₁₀(n))

show : ℕ → String
show = String.fromList ∘ toDecimalChars

-- Warning: when compiled the time complexity of `showInBase b n` is
-- O(n) instead of the expected O(log(n)).

showInBase : (base : ℕ)
             {base≥2 : True (2 ≤? base)}
             {base≤16 : True (base ≤? 16)} →
             ℕ → String
showInBase base {base≥2} {base≤16} n =
  String.fromList $
  map (showDigit {base≤16 = base≤16}) $
  reverse $
  proj₁ $ toDigits base {base≥2 = base≥2} n


open import eq
open import bool
open import bool-relations using (transitive; total)
open import maybe
open import nat
open import nat-thms       using (≤-trans; ≤-total)
open import product

module z05-01-bst-test where

open import bool-relations _≤_ hiding (transitive; total)

import z05-01-bst as BST
open   BST nat _≤_ (λ {x} {y} {z} → ≤-trans {x} {y} {z})
                   (λ {x} {y}     → ≤-total {x} {y})

empty : bst 0 0
empty = bst-leaf refl

_ : bst-search 0 empty ≡ nothing
_ = refl

_ : bst-insert 5 empty ≡ bst-node 5 (bst-leaf refl) (bst-leaf refl) refl refl
_ = refl

bst-5 : bst 0 5
bst-5 = bst-insert 5 empty

_ : maybe (Σ ℕ (λ z → (5 < z || 5 =ℕ z) && (z < 5 || z =ℕ 5) ≡ tt))
_ = bst-search 5 bst-5

_ : bst-insert 9 bst-5 ≡ bst-node 5 (bst-leaf refl)
                           (bst-node 9 (bst-leaf refl) (bst-leaf refl) refl refl) refl refl
_ = refl

_ : bst 0 9
_ = bst-insert 9 bst-5

_ : bst 0 5
_ = bst-dec-lb {0} {0} {5} (bst-leaf refl) refl


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

module Categories.Morphism.Properties {o ℓ e} (𝒞 : Category o ℓ e) where

open import Data.Product using (_,_; _×_)

open Category 𝒞
open HomReasoning

import Categories.Morphism as M
open M 𝒞
open import Categories.Morphism.Reasoning 𝒞

private
  variable
    A B C D : Obj
    f g h i : A ⇒ B

module _ (iso : Iso f g) where

  open Iso iso

  Iso-resp-≈ : f ≈ h → g ≈ i → Iso h i
  Iso-resp-≈ {h = h} {i = i} eq₁ eq₂ = record
    { isoˡ = begin
      i ∘ h ≈˘⟨ eq₂ ⟩∘⟨ eq₁ ⟩
      g ∘ f ≈⟨ isoˡ ⟩
      id    ∎
    ; isoʳ = begin
      h ∘ i ≈˘⟨ eq₁ ⟩∘⟨ eq₂ ⟩
      f ∘ g ≈⟨ isoʳ ⟩
      id    ∎
    }

  Iso-swap : Iso g f
  Iso-swap = record
    { isoˡ = isoʳ
    ; isoʳ = isoˡ
    }

  Iso⇒Mono : Mono f
  Iso⇒Mono h i eq = begin
    h           ≈⟨ introˡ isoˡ ⟩
    (g ∘ f) ∘ h ≈⟨ pullʳ eq ⟩
    g ∘ f ∘ i   ≈⟨ cancelˡ isoˡ ⟩
    i           ∎

  Iso⇒Epi : Epi f
  Iso⇒Epi h i eq = begin
    h           ≈⟨ introʳ isoʳ ⟩
    h ∘ f ∘ g   ≈⟨ pullˡ eq ⟩
    (i ∘ f) ∘ g ≈⟨ cancelʳ isoʳ ⟩
    i           ∎

Iso-∘ : Iso f g → Iso h i → Iso (h ∘ f) (g ∘ i)
Iso-∘ {f = f} {g = g} {h = h} {i = i} iso iso′ = record
  { isoˡ = begin
    (g ∘ i) ∘ h ∘ f ≈⟨ cancelInner (isoˡ iso′) ⟩
    g ∘ f           ≈⟨ isoˡ iso ⟩
    id              ∎
  ; isoʳ = begin
    (h ∘ f) ∘ g ∘ i ≈⟨ cancelInner (isoʳ iso) ⟩
    h ∘ i           ≈⟨ isoʳ iso′ ⟩
    id              ∎
  }
  where open Iso

Iso-≈ : f ≈ h → Iso f g → Iso h i → g ≈ i
Iso-≈ {f = f} {h = h} {g = g} {i = i} eq iso iso′ = begin
  g           ≈⟨ introˡ (isoˡ iso′) ⟩
  (i ∘ h) ∘ g ≈˘⟨ (refl ⟩∘⟨ eq) ⟩∘⟨refl ⟩
  (i ∘ f) ∘ g ≈⟨ cancelʳ (isoʳ iso) ⟩
  i           ∎
  where open Iso

module _ where
  open _≅_

  isos×≈⇒≈ : ∀ {f g : A ⇒ B} → h ≈ i → (iso₁ : A ≅ C) → (iso₂ : B ≅ D) →
               CommutativeSquare f (from iso₁) (from iso₂) h →
               CommutativeSquare g (from iso₁) (from iso₂) i →
               f ≈ g
  isos×≈⇒≈ {h = h} {i = i} {f = f} {g = g} eq iso₁ iso₂ sq₁ sq₂ = begin
    f ≈⟨ switch-fromtoˡ iso₂ sq₁ ⟩
    to iso₂ ∘ h ∘ from iso₁ ≈⟨ refl⟩∘⟨ (eq ⟩∘⟨refl ) ⟩
    to iso₂ ∘ i ∘ from iso₁ ≈˘⟨ switch-fromtoˡ iso₂ sq₂ ⟩
    g ∎


{-
  Finitely presented algebras.
  An R-algebra A is finitely presented, if there merely is an exact sequence
  of R-modules:

    (f₁,⋯,fₘ) → R[X₁,⋯,Xₙ] → A → 0

  (where f₁,⋯,fₘ ∈ R[X₁,⋯,Xₙ])
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.FPAlgebra where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure

open import Cubical.Data.FinData
open import Cubical.Data.Nat
open import Cubical.Data.Vec
open import Cubical.Data.Sigma
open import Cubical.Data.Empty

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal using (inclOfFGIdeal)
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.CommAlgebra.FreeCommAlgebra
  renaming (inducedHom to freeInducedHom)
open import Cubical.Algebra.CommAlgebra.QuotientAlgebra
  renaming (inducedHom to quotientInducedHom)
open import Cubical.Algebra.CommAlgebra.Ideal
open import Cubical.Algebra.CommAlgebra.FGIdeal
open import Cubical.Algebra.CommAlgebra.Instances.Initial
open import Cubical.Algebra.CommAlgebra.Instances.Unit
  renaming (UnitCommAlgebra to TerminalCAlg)
open import Cubical.Algebra.CommAlgebra.Kernel
open import Cubical.Algebra.Algebra.Properties
open import Cubical.Algebra.Algebra

private
  variable
    ℓ : Level

module _ {R : CommRing ℓ} where
  open Construction using (var)
  Polynomials : (n : ℕ) → CommAlgebra R ℓ
  Polynomials n = R [ Fin n ]

  evPoly : {n : ℕ} (A : CommAlgebra R ℓ) → ⟨ Polynomials n ⟩ → FinVec ⟨ A ⟩ n → ⟨ A ⟩
  evPoly A P values = fst (freeInducedHom A values) P

  evPolyPoly : {n : ℕ} (P : ⟨ Polynomials n ⟩) → evPoly (Polynomials n) P var ≡ P
  evPolyPoly {n = n} P = cong (λ u → fst u P) (inducedHomVar R (Fin n))

  evPolyHomomorphic : {n : ℕ} (A B : CommAlgebra R ℓ) (f : CommAlgebraHom A B)
                     → (P : ⟨ Polynomials n ⟩) → (values : FinVec ⟨ A ⟩ n)
                     → (fst f) (evPoly A P values) ≡ evPoly B P (fst f ∘ values)
  evPolyHomomorphic A B f P values =
    (fst f) (evPoly A P values)                         ≡⟨ refl ⟩
    (fst f) (fst (freeInducedHom A values) P)           ≡⟨ refl ⟩
    fst (f ∘a freeInducedHom A values) P                ≡⟨ cong (λ u → fst u P) (natIndHomR f values) ⟩
    fst (freeInducedHom B (fst f ∘ values)) P           ≡⟨ refl ⟩
    evPoly B P (fst f ∘ values) ∎
    where open AlgebraHoms

  module _ {m : ℕ} (n : ℕ) (relation : FinVec ⟨ Polynomials n ⟩ m) where
    open CommAlgebraStr using (0a)
    open Cubical.Algebra.Algebra.Properties.AlgebraHoms

    relationsIdeal = generatedIdeal (Polynomials n) relation

    abstract
      {-
        The following definitions are abstract because of type checking speed
        problems - complete unfolding of FPAlgebra is triggered otherwise.
        This also means, the where blocks contain more type declarations than usual.
      -}
      FPAlgebra : CommAlgebra R ℓ
      FPAlgebra = Polynomials n / relationsIdeal

      modRelations : CommAlgebraHom (Polynomials n) (Polynomials n / relationsIdeal)
      modRelations = quotientMap (Polynomials n) relationsIdeal

      generator : (i : Fin n) → ⟨ FPAlgebra ⟩
      generator = fst modRelations ∘ var

      relationsHold : (i : Fin m) → evPoly FPAlgebra (relation i) generator ≡ 0a (snd FPAlgebra)
      relationsHold i =
        evPoly FPAlgebra (relation i) generator
        ≡⟨ sym (evPolyHomomorphic (Polynomials n) FPAlgebra modRelations (relation i) var) ⟩
        fst modRelations (evPoly (Polynomials n) (relation i) var)
        ≡⟨ cong (λ u → fst modRelations u) (evPolyPoly (relation i)) ⟩
        fst modRelations (relation i)
        ≡⟨ isZeroFromIdeal {R = R}
                           {A = (Polynomials n)}
                           {I = relationsIdeal}
                           (relation i)
                           (incInIdeal (Polynomials n) relation i ) ⟩
        0a (snd FPAlgebra) ∎

      inducedHom :
        (A : CommAlgebra R ℓ)
        (values : FinVec ⟨ A ⟩ n)
        (relationsHold : (i : Fin m) → evPoly A (relation i) values ≡ 0a (snd A))
        → CommAlgebraHom FPAlgebra A
      inducedHom A values relationsHold =
        quotientInducedHom
          (Polynomials n)
          relationsIdeal
          A
          freeHom
          isInKernel
        where
          freeHom : CommAlgebraHom (Polynomials n) A
          freeHom = freeInducedHom A values
          isInKernel :   fst (generatedIdeal (Polynomials n) relation)
                       ⊆ fst (kernel (Polynomials n) A freeHom)
          isInKernel = inclOfFGIdeal
                         (CommAlgebra→CommRing (Polynomials n))
                         relation
                         (kernel (Polynomials n) A freeHom)
                         relationsHold

      inducedHomOnGenerators :
        (A : CommAlgebra R ℓ)
        (values : FinVec ⟨ A ⟩ n)
        (relationsHold : (i : Fin m) → evPoly A (relation i) values ≡ 0a (snd A))
        (i : Fin n)
        → fst (inducedHom A values relationsHold) (generator i) ≡ values i
      inducedHomOnGenerators _ _ _ _ = refl

      unique :
             {A : CommAlgebra R ℓ}
             (values : FinVec ⟨ A ⟩ n)
             (relationsHold : (i : Fin m) → evPoly A (relation i) values ≡ 0a (snd A))
             (f : CommAlgebraHom FPAlgebra A)
             → ((i : Fin n) → fst f (generator i) ≡ values i)
             → inducedHom A values relationsHold ≡ f
      unique {A = A} values relationsHold f hasCorrectValues =
        injectivePrecomp
          (Polynomials n)
          relationsIdeal
          A
          (inducedHom A values relationsHold)
          f
          (sym (
           f'     ≡⟨ sym (inv f') ⟩
           freeInducedHom A (evaluateAt A f')    ≡⟨ cong (freeInducedHom A) (funExt hasCorrectValues) ⟩
           freeInducedHom A values               ≡⟨ cong (freeInducedHom A) refl ⟩
           freeInducedHom A (evaluateAt A iHom') ≡⟨ inv iHom' ⟩
           iHom' ∎))
        where
          {-
                     Poly n
                      |    \
            modRelations    f'
                      ↓      ↘
                 FPAlgebra ─f→ A
          -}
          f' iHom' : CommAlgebraHom (Polynomials n) A
          f' = compAlgebraHom modRelations f
          iHom' = compAlgebraHom modRelations (inducedHom A values relationsHold)

          inv : retract (Iso.fun (homMapIso {I = Fin n} A)) (Iso.inv (homMapIso A))
          inv = Iso.leftInv (homMapIso {R = R} {I = Fin n} A)

      {- ∀ A : Comm-R-Algebra,
         ∀ J : Finitely-generated-Ideal,
         Hom(R[I]/J,A) is isomorphic to the Set of roots of the generators of J
      -}

      zeroLocus : (A : CommAlgebra R ℓ) → Type ℓ
      zeroLocus A = Σ[ v ∈ FinVec ⟨ A ⟩ n ] ((i : Fin m) → evPoly A (relation i) v ≡ 0a (snd A))

      inducedHomFP : (A : CommAlgebra R ℓ) →
                      zeroLocus A → CommAlgebraHom FPAlgebra A
      inducedHomFP A d = inducedHom A (fst d) (snd d)

      evaluateAtFP : {A : CommAlgebra R ℓ} →
                      CommAlgebraHom FPAlgebra A → zeroLocus A
      evaluateAtFP {A} f = value ,
                      λ i →  evPoly A (relation i) value                            ≡⟨ step1 (relation i) ⟩
                             fst compHom (evPoly (Polynomials n) (relation i) var)  ≡⟨ refl ⟩
                             (fst f) ((fst modRelations)
                                        (evPoly (Polynomials n) (relation i) var))  ≡⟨ cong (fst f)
                                                                                (evPolyHomomorphic
                                                                                (Polynomials n)
                                                                                FPAlgebra
                                                                                modRelations
                                                                                (relation i) var) ⟩
                             (fst f) (evPoly FPAlgebra (relation i) generator)      ≡⟨ cong (fst f) (relationsHold i) ⟩
                             (fst f) (0a (snd FPAlgebra))                           ≡⟨ IsAlgebraHom.pres0 (snd f) ⟩
                             0a (snd A) ∎
        where
          compHom : CommAlgebraHom (Polynomials n) A
          compHom = CommAlgebraHoms.compCommAlgebraHom (Polynomials n) FPAlgebra A modRelations f
          value : FinVec ⟨ A ⟩ n
          value = (Iso.fun (homMapIso A)) compHom
          step1 : (x : ⟨ Polynomials n ⟩) → evPoly A x value ≡ fst compHom (evPoly (Polynomials n) x var)
          step1 x = sym (evPolyHomomorphic (Polynomials n) A compHom x var)

      FPHomIso : {A : CommAlgebra R ℓ} →
                  Iso (CommAlgebraHom FPAlgebra A) (zeroLocus A)
      Iso.fun FPHomIso = evaluateAtFP
      Iso.inv FPHomIso = inducedHomFP _
      Iso.rightInv (FPHomIso {A}) =
        λ b → Σ≡Prop
                (λ x → isPropΠ
                  (λ i → isSetCommAlgebra A
                          (evPoly A (relation i) x)
                          (0a (snd A))))
                refl
      Iso.leftInv (FPHomIso {A}) =
        λ a → Σ≡Prop (λ f → isPropIsCommAlgebraHom {ℓ} {R} {ℓ} {ℓ} {FPAlgebra} {A} f)
                 λ i → fst (unique {A}
                             (fst (evaluateAtFP {A} a))
                             (snd (evaluateAtFP a))
                             a
                             (λ j → refl)
                             i)

      homMapPathFP : (A : CommAlgebra R ℓ)→ CommAlgebraHom FPAlgebra A ≡ zeroLocus A
      homMapPathFP A = isoToPath (FPHomIso {A})

      isSetZeroLocus : (A : CommAlgebra R ℓ) → isSet (zeroLocus A)
      isSetZeroLocus A =  J (λ y _ → isSet y)
                       (isSetAlgebraHom (CommAlgebra→Algebra FPAlgebra) (CommAlgebra→Algebra A))
                       (homMapPathFP A)

  record FinitePresentation (A : CommAlgebra R ℓ) : Type ℓ where
    field
      n : ℕ
      m : ℕ
      relations : FinVec ⟨ Polynomials n ⟩ m
      equiv : CommAlgebraEquiv (FPAlgebra n relations) A

  isFPAlgebra : (A : CommAlgebra R ℓ) → Type _
  isFPAlgebra A = ∥ FinitePresentation A ∥₁

  isFPAlgebraIsProp : {A : CommAlgebra R ℓ} → isProp (isFPAlgebra A)
  isFPAlgebraIsProp = isPropPropTrunc

module Instances {R : CommRing ℓ} where
  open FinitePresentation

  {- Every (multivariate) polynomial algebra is finitely presented -}
  module _ (n : ℕ) where
    private
      A : CommAlgebra R ℓ
      A = Polynomials n

      emptyGen : FinVec (fst A) 0
      emptyGen = λ ()

      B : CommAlgebra R ℓ
      B = FPAlgebra n emptyGen

    polynomialAlgFP : FinitePresentation A
    FinitePresentation.n polynomialAlgFP = n
    m polynomialAlgFP = 0
    relations polynomialAlgFP = emptyGen
    equiv polynomialAlgFP =
      -- Idea: A and B enjoy the same universal property.
      toAAsEquiv , snd toA
      where
        toA : CommAlgebraHom B A
        toA = inducedHom n emptyGen A Construction.var (λ ())
        fromA : CommAlgebraHom A B
        fromA = freeInducedHom B (generator _ _)
        open AlgebraHoms
        inverse1 : fromA ∘a toA ≡ idAlgebraHom _
        inverse1 =
          fromA ∘a toA
            ≡⟨ sym (unique _ _ _ _ _ (λ i → cong (fst fromA) (
                 fst toA (generator n emptyGen i)
                   ≡⟨ inducedHomOnGenerators _ _ _ _ _ _ ⟩
                 Construction.var i
                   ∎))) ⟩
          inducedHom n emptyGen B (generator _ _) (relationsHold _ _)
            ≡⟨ unique _ _ _ _ _ (λ i → refl) ⟩
          idAlgebraHom _
            ∎
        inverse2 : toA ∘a fromA ≡ idAlgebraHom _
        inverse2 = isoFunInjective (homMapIso A) _ _ (
          evaluateAt A (toA ∘a fromA)   ≡⟨ sym (naturalEvR {A = B} {B = A} toA fromA) ⟩
          fst toA ∘ evaluateAt B fromA  ≡⟨ refl ⟩
          fst toA ∘ generator _ _       ≡⟨ funExt (inducedHomOnGenerators _ _ _ _ _)⟩
          Construction.var              ∎)
        toAAsEquiv : ⟨ B ⟩ ≃ ⟨ A ⟩
        toAAsEquiv = isoToEquiv (iso (fst toA)
                                     (fst fromA)
                                     (λ a i → fst (inverse2 i) a)
                                     (λ b i → fst (inverse1 i) b))

  {- The initial R-algebra is finitely presented -}
  private
    R[⊥] : CommAlgebra R ℓ
    R[⊥] = Polynomials 0

    emptyGen : FinVec (fst R[⊥]) 0
    emptyGen = λ ()

    R[⊥]/⟨0⟩ : CommAlgebra R ℓ
    R[⊥]/⟨0⟩ = FPAlgebra 0 emptyGen

  R[⊥]/⟨0⟩IsInitial : (B : CommAlgebra R ℓ)
                     → isContr (CommAlgebraHom R[⊥]/⟨0⟩ B)
  R[⊥]/⟨0⟩IsInitial B = iHom , uniqueness
    where
      iHom : CommAlgebraHom R[⊥]/⟨0⟩ B
      iHom = inducedHom 0 emptyGen B (λ ()) (λ ())
      uniqueness : (f : CommAlgebraHom R[⊥]/⟨0⟩ B) →
                   iHom ≡ f
      uniqueness f = unique 0 emptyGen {A = B} (λ ()) (λ ()) f (λ ())

  initialCAlgFP : FinitePresentation (initialCAlg R)
  n initialCAlgFP = 0
  m initialCAlgFP = 0
  relations initialCAlgFP = emptyGen
  equiv initialCAlgFP =
    equivByInitiality R R[⊥]/⟨0⟩ R[⊥]/⟨0⟩IsInitial

  {- The terminal R-algebra is finitely presented -}
  private
    unitGen : FinVec (fst R[⊥]) 1
    unitGen zero = 1a
      where open CommAlgebraStr (snd R[⊥])

    R[⊥]/⟨1⟩ : CommAlgebra R ℓ
    R[⊥]/⟨1⟩ = FPAlgebra 0 unitGen

  terminalCAlgFP : FinitePresentation (TerminalCAlg R)
  n terminalCAlgFP = 0
  m terminalCAlgFP = 1
  relations terminalCAlgFP = unitGen
  equiv terminalCAlgFP = equivFrom1≡0 R R[⊥]/⟨1⟩ (sym (⋆-lid 1a) ∙ relationsHold 0 unitGen zero)
    where open CommAlgebraStr (snd R[⊥]/⟨1⟩)


import      Lvl
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.Eigen
  {ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ}
  {V : Type{ℓᵥ}} ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  {S : Type{ℓₛ}} ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (_+ᵥ_ : V → V → V)
  (_⋅ₛᵥ_ : S → V → V)
  (_+ₛ_ _⋅ₛ_ : S → S → S)
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

open VectorSpace(vectorSpace)

open import Logic
open import Logic.Predicate
open import Logic.Propositional
open import Syntax.Function

-- v is a eigenvector for the eigenvalue 𝜆 of the linear transformation f.
-- Multiplication by an eigenvalue can replace a linear transformation for certain vectors.
Eigenpair : (V → V) → S → V → Stmt
Eigenpair(f)(𝜆)(v) = ((v ≢ 𝟎ᵥ) ∧ (f(v) ≡ 𝜆 ⋅ₛᵥ v))

Eigenvector : (V → V) → V → Stmt
Eigenvector(f)(v) = ∃(𝜆 ↦ Eigenpair(f)(𝜆)(v))

Eigenvalue : (V → V) → S → Stmt
Eigenvalue(f)(𝜆) = ∃(v ↦ Eigenpair(f)(𝜆)(v))


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

open import Categories.Category.Core

-- Idempotents and Split Idempotents
module Categories.Morphism.Idempotent {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞

open Category 𝒞
open HomReasoning

record Idempotent (A : Obj) : Set (ℓ ⊔ e) where
  field
    idem       : A ⇒ A
    idempotent : idem ∘ idem ≈ idem

record IsSplitIdempotent {A : Obj} (i : A ⇒ A) : Set (o ⊔ ℓ ⊔ e) where
  field
    {obj}    : Obj
    retract  : A ⇒ obj
    section  : obj ⇒ A
    retracts : retract ∘ section ≈ id
    splits   : section ∘ retract ≈ i

  retract-absorb : retract ∘ i ≈ retract
  retract-absorb = begin
    retract ∘ i                 ≈˘⟨ refl⟩∘⟨ splits ⟩
    retract ∘ section ∘ retract ≈⟨ cancelˡ retracts ⟩
    retract                     ∎

  section-absorb : i ∘ section ≈ section
  section-absorb = begin
    i ∘ section                   ≈˘⟨ splits ⟩∘⟨refl ⟩
    (section ∘ retract) ∘ section ≈⟨ cancelʳ retracts ⟩
    section                       ∎

  idempotent : i ∘ i ≈ i
  idempotent = begin
    i ∘ i                                     ≈˘⟨ splits ⟩∘⟨ splits ⟩
    (section ∘ retract) ∘ (section ∘ retract) ≈⟨ cancelInner retracts ⟩
    section ∘ retract                         ≈⟨ splits ⟩
    i                                         ∎

record SplitIdempotent (A : Obj) : Set (o ⊔ ℓ ⊔ e) where
  field
    idem : A ⇒ A
    isSplitIdempotent : IsSplitIdempotent idem

  open IsSplitIdempotent isSplitIdempotent public

-- All split idempotents are idempotent
SplitIdempotent⇒Idempotent : ∀ {A} → SplitIdempotent A → Idempotent A
SplitIdempotent⇒Idempotent Split = record { Split }
  where
    module Split = SplitIdempotent Split

module _ {A} {f : A ⇒ A} (S T : IsSplitIdempotent f) where
  private
    module S = IsSplitIdempotent S
    module T = IsSplitIdempotent T

  split-idempotent-unique : S.obj ≅ T.obj
  split-idempotent-unique = record
    { from = T.retract ∘ S.section
    ; to = S.retract ∘ T.section
    ; iso = record
      { isoˡ = begin
        (S.retract ∘ T.section) ∘ (T.retract ∘ S.section) ≈⟨ center T.splits ⟩
        S.retract ∘ f ∘ S.section                         ≈⟨ pullˡ S.retract-absorb ⟩
        S.retract ∘ S.section                             ≈⟨ S.retracts ⟩
        id                                                ∎
      ; isoʳ = begin
        (T.retract ∘ S.section) ∘ (S.retract ∘ T.section) ≈⟨ center S.splits ⟩
        T.retract ∘ f ∘ T.section                         ≈⟨ pullˡ T.retract-absorb ⟩
        T.retract ∘ T.section                             ≈⟨ T.retracts ⟩
        id                                                ∎
      }
    }


module DifferentArities where

open import Common.Equality
open import Common.Prelude

f : Nat → Nat → Nat
f zero      = λ x → x
f (suc n) m = f n (suc m)

testf1 : f zero ≡ λ x → x
testf1 = refl

testf2 : ∀ {n m} → f (suc n) m ≡ f n (suc m)
testf2 = refl

testf3 : f 4 5 ≡ 9
testf3 = refl


-- Nils' suggestion

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Data.Nat.Properties.Simple using (+-suc)
open import Relation.Nullary using (¬_)
open import Function using (_∘_; id)
open import Data.Product using (_×_; _,_; proj₁; proj₂; map; ∃; ∃-syntax)
open import Data.Sum using (_⊎_; inj₁; inj₂)

data even : ℕ → Set
data odd  : ℕ → Set

data even where
  even-zero : even zero
  even-suc  : ∀ {n : ℕ} → odd n → even (suc n)

data odd where
  odd-suc   : ∀ {n : ℕ} → even n → odd (suc n)

∃-even : ∀ {n : ℕ} → even n → ∃[ m ] (n ≡ m * 2)
∃-odd  : ∀ {n : ℕ} →  odd n → ∃[ m ] (n ≡ 1 + m * 2)

∃-even even-zero    = zero , refl
∃-even (even-suc o) with ∃-odd o
...                    | m , refl = suc m , refl

∃-odd  (odd-suc  e) with ∃-even e
...                    | m , refl = m , refl


module CS410-Vec where

open import CS410-Prelude
open import CS410-Nat

data Vec (X : Set) : Nat -> Set where
  []   : Vec X 0
  _::_ : forall {n} ->
         X -> Vec X n -> Vec X (suc n)
infixr 3 _::_

_+V_ : forall {X m n} -> Vec X m -> Vec X n -> Vec X (m +N n)
[] +V ys = ys
(x :: xs) +V ys = x :: xs +V ys
infixr 3 _+V_

data Choppable {X : Set}(m n : Nat) : Vec X (m +N n) -> Set where
  chopTo : (xs : Vec X m)(ys : Vec X n) -> Choppable m n (xs +V ys)

chop : {X : Set}(m n : Nat)(xs : Vec X (m +N n)) -> Choppable m n xs
chop zero n xs = chopTo [] xs
chop (suc m) n (x :: xs) with chop m n xs
chop (suc m) n (x :: .(xs +V ys)) | chopTo xs ys = chopTo (x :: xs) ys

chopParts : {X : Set}(m n : Nat)(xs : Vec X (m +N n)) -> Vec X m * Vec X n
chopParts m n xs with chop m n xs
chopParts m n .(xs +V ys) | chopTo xs ys = xs , ys

vec : forall {n X} -> X -> Vec X n
vec {zero}   x = []
vec {suc n}  x = x :: vec x

vapp : forall {n X Y} -> Vec (X -> Y) n -> Vec X n -> Vec Y n
vapp [] [] = []
vapp (f :: fs) (x :: xs) = f x :: vapp fs xs


------------------------------------------------------------------------
-- The Agda standard library
--
-- An either-or-both data type, basic type and operations
------------------------------------------------------------------------

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

module Data.These.Base where

open import Level
open import Data.Sum.Base using (_⊎_; [_,_]′)
open import Function.Base

private
  variable
    a b c d e f : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d
    E : Set e
    F : Set f

data These {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  this  : A     → These A B
  that  :     B → These A B
  these : A → B → These A B

------------------------------------------------------------------------
-- Operations

-- injection

fromSum : A ⊎ B → These A B
fromSum = [ this , that ]′

-- map

map : (f : A → B) (g : C → D) → These A C → These B D
map f g (this a)    = this (f a)
map f g (that b)    = that (g b)
map f g (these a b) = these (f a) (g b)

map₁ : (f : A → B) → These A C → These B C
map₁ f = map f id

map₂ : (g : B → C) → These A B → These A C
map₂ = map id

-- fold

fold : (A → C) → (B → C) → (A → B → C) → These A B → C
fold l r lr (this a)    = l a
fold l r lr (that b)    = r b
fold l r lr (these a b) = lr a b

foldWithDefaults : A → B → (A → B → C) → These A B → C
foldWithDefaults a b lr = fold (flip lr b) (lr a) lr

-- swap

swap : These A B → These B A
swap = fold that this (flip these)

-- align

alignWith : (These A C → E) → (These B D → F) → These A B → These C D → These E F
alignWith f g (this a)    (this c)    = this (f (these a c))
alignWith f g (this a)    (that d)    = these (f (this a)) (g (that d))
alignWith f g (this a)    (these c d) = these (f (these a c)) (g (that d))
alignWith f g (that b)    (this c)    = these (f (that c)) (g (this b))
alignWith f g (that b)    (that d)    = that (g (these b d))
alignWith f g (that b)    (these c d) = these (f (that c)) (g (these b d))
alignWith f g (these a b) (this c)    = these (f (these a c)) (g (this b))
alignWith f g (these a b) (that d)    = these (f (this a)) (g (these b d))
alignWith f g (these a b) (these c d) = these (f (these a c)) (g (these b d))

align : These A B → These C D → These (These A C) (These B D)
align = alignWith id id


{-# OPTIONS --cubical-compatible #-}
module Common.Equality where

open import Agda.Builtin.Equality public
open import Common.Level

subst : ∀ {a p}{A : Set a}(P : A → Set p){x y : A} → x ≡ y → P x → P y
subst P refl t = t

cong : ∀ {a b}{A : Set a}{B : Set b}(f : A → B){x y : A} → x ≡ y → f x ≡ f y
cong f refl = refl

sym : ∀ {a}{A : Set a}{x y : A} → x ≡ y → y ≡ x
sym refl = refl

trans : ∀ {a}{A : Set a}{x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Basic definitions for morphisms between algebraic structures
------------------------------------------------------------------------

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

open import Relation.Binary.Core

module Relation.Binary.Morphism.Definitions
  {a} (A : Set a)     -- The domain of the morphism
  {b} (B : Set b)     -- The codomain of the morphism
  where

open import Algebra.Core
open import Function.Base
open import Level using (Level)

private
  variable
    ℓ₁ ℓ₂ : Level

------------------------------------------------------------------------
-- Basic definitions

Homomorphic₂ : Rel A ℓ₁ → Rel B ℓ₂ → (A → B) → Set _
Homomorphic₂ _∼₁_ _∼₂_ ⟦_⟧ = ∀ {x y} → x ∼₁ y → ⟦ x ⟧ ∼₂ ⟦ y ⟧

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

-- Version 1.3

Morphism : Set _
Morphism = A → B

{-# WARNING_ON_USAGE Morphism
"Warning: Morphism was deprecated in v1.3.
Please use the standard function notation (e.g. A → B) instead."
#-}


module Stable where

open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)

open import Negation using (¬_; ¬¬¬-elim)

Stable : Set → Set
Stable A = ¬ ¬ A → A

¬-stable : ∀ {A : Set} → Stable (¬ A)
¬-stable = λ ¬¬¬a → (λ a → ¬¬¬a (λ ¬a → ¬a a))
-- ¬-stable = ¬¬¬-elim

×-stable : ∀ {A B : Set} → Stable A → Stable B → Stable (A × B)
×-stable sa sb = λ ¬¬a×b →
  ⟨ (sa λ{ ¬a → ¬¬a×b λ{ a×b → ¬a (proj₁ a×b) }})
  , (sb λ{ ¬b → ¬¬a×b λ{ a×b → ¬b (proj₂ a×b) }})
  ⟩


-- some examples for structural order in the termination checker

module StructuralOrder where

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

-- c t > t  for any term t
-- e.g., succ (succ y) > succ y
plus : Nat -> Nat -> Nat
plus x (succ (succ y)) = succ (plus x (succ y))
plus x (succ zero) = succ x
plus x zero        = x

-- constructor names do not matter
-- c (c' t) > c'' t
-- e.g. c0 (c1 x) > c0 x
--      c0 (c0 x) > c1 x

-- Actually constructor names does matter until the non-mattering is
-- implemented properly.

{- TEMPORARILY REMOVED by Ulf since there are problems with the constructor-name ignoring
data Bin : Set where
  eps : Bin
  c0  : Bin -> Bin
  c1  : Bin -> Bin

foo : Bin -> Nat
foo eps = zero
foo (c0 eps) = zero
foo (c0 (c1 x)) = succ (foo (c0 x))
foo (c0 (c0 x)) = succ (foo (c1 x))
foo (c1 x)      = succ (foo x)
-}


{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Data.Nat.Properties where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat.Base
open import Cubical.Data.Empty
open import Cubical.Data.Prod.Base

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

open import Cubical.Data.Nat.Algebra public

+-zero : ∀ m → m + 0 ≡ m
+-zero zero = refl
+-zero (suc m) = cong suc (+-zero m)

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

+-comm : ∀ m n → m + n ≡ n + m
+-comm m zero = +-zero m
+-comm m (suc n) = (+-suc m n) ∙ (cong suc (+-comm m n))

-- Addition is associative
+-assoc : ∀ m n o → m + (n + o) ≡ (m + n) + o
+-assoc zero _ _    = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

private
  variable
    l m n : ℕ

znots : ¬ (0 ≡ suc n)
znots eq = subst (caseNat ℕ ⊥) eq 0

snotz : ¬ (suc n ≡ 0)
snotz eq = subst (caseNat ⊥ ℕ) eq 0

injSuc : suc m ≡ suc n → m ≡ n
injSuc p = cong predℕ p

inj-m+ : m + l ≡ m + n → l ≡ n
inj-m+ {zero} p = p
inj-m+ {suc m} p = inj-m+ (injSuc p)

inj-+m : l + m ≡ n + m → l ≡ n
inj-+m {l} {m} {n} p = inj-m+ ((+-comm m l) ∙ (p ∙ (+-comm n m)))

m+n≡n→m≡0 : m + n ≡ n → m ≡ 0
m+n≡n→m≡0 {n = zero} = λ p → (sym (+-zero _)) ∙ p
m+n≡n→m≡0 {n = suc n} p = m+n≡n→m≡0 (injSuc ((sym (+-suc _ n)) ∙ p))

m+n≡0→m≡0×n≡0 : m + n ≡ 0 → (m ≡ 0) × (n ≡ 0)
m+n≡0→m≡0×n≡0 {zero} = refl ,_
m+n≡0→m≡0×n≡0 {suc m} p = ⊥-elim (snotz p)

discreteℕ : Discrete ℕ
discreteℕ zero zero = yes refl
discreteℕ zero (suc n) = no znots
discreteℕ (suc m) zero = no snotz
discreteℕ (suc m) (suc n) with discreteℕ m n
... | yes p = yes (cong suc p)
... | no p = no (λ x → p (injSuc x))

isSetℕ : isSet ℕ
isSetℕ = Discrete→isSet discreteℕ

0≡m*0 : ∀ m → 0 ≡ m * 0
0≡m*0 zero = refl
0≡m*0 (suc m) = 0≡m*0 m

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

*-comm : ∀ m n → m * n ≡ n * m
*-comm zero n = 0≡m*0 n
*-comm (suc m) n = cong (n +_) (*-comm m n) ∙ sym (*-suc n m)

0≡n*sm→0≡n : 0 ≡ n * suc m → 0 ≡ n
0≡n*sm→0≡n {n = zero} p = refl
0≡n*sm→0≡n {n = suc n} p = ⊥-elim (znots p)

inj-*sm : l * suc m ≡ n * suc m → l ≡ n
inj-*sm {zero} {m} {n} p = 0≡n*sm→0≡n p
inj-*sm {l} {m} {zero} p = sym (0≡n*sm→0≡n (sym p))
inj-*sm {suc l} {m} {suc n} p = cong suc (inj-*sm (inj-m+ {m = suc m} p))

inj-sm* : suc m * l ≡ suc m * n → l ≡ n
inj-sm* {m} {l} {n} p = inj-*sm (*-comm l (suc m) ∙ p ∙ *-comm (suc m) n)


open import prelude
open import ch6 using (Term  ; var ; fun ; _$_ ; two ; four)

-- A stack is a list of values
-- Values are either closures or errors

data Value : Set where
  error : Value
  closure : List(Value) → Term → Value

Stack = List(Value)

lookup : (s : Stack) → (x : Nat) → Value
lookup nil x = error
lookup (v :: s) zero = v
lookup (v :: s) (suc x) = lookup s x

-- Big step sematics

data _▷_⇓_ : Stack → Term → Value → Set where

  E─Var : ∀ {s x} →

    --------------------------
    s ▷ (var x) ⇓ (lookup s x)

  E─Fun : ∀ {s t} →

    ---------------------------
    s ▷ (fun t) ⇓ (closure s t)

  E─App : ∀ {s s′ t t′ u u′ v} →

    s ▷ t ⇓ (closure s′ t′) →
    s ▷ u ⇓ u′ →
    (u′ :: s′) ▷ t′ ⇓ v →
    -------------------
    s ▷ (t $ u) ⇓ v

  E─AppErr : ∀ {s t u} →

    s ▷ t ⇓ error →
    -------------------
    s ▷ (t $ u) ⇓ error

-- An interpreter result

data Result : Stack → Term → Set where

  result : ∀ {s t} →

    (v : Value) →
    (s ▷ t ⇓ v) →
    -------------
    Result s t

{-# NON_TERMINATING #-}
interpret : (s : Stack) → (t : Term) → Result s t
interpret s (var x) = result (lookup s x) E─Var
interpret s (fun t) = result (closure s t) E─Fun
interpret s (t₁ $ t₂) = helper₁ (interpret s t₁) where

  helper₃ : ∀ {s′ t′ u′} → (s ▷ t₁ ⇓ (closure s′ t′)) → (s ▷ t₂ ⇓ u′) → Result (u′ :: s′) t′ → Result s (t₁ $ t₂)
  helper₃ p q (result v r) = result v (E─App p q r)

  helper₂ : ∀ {s′ t′} → (s ▷ t₁ ⇓ (closure s′ t′)) → Result s t₂ → Result s (t₁ $ t₂)
  helper₂ {s′} {t′} p (result u′ q) = helper₃ p q (interpret (u′ :: s′) t′)

  helper₁ : Result s t₁ → Result s (t₁ $ t₂)
  helper₁ (result error           p) = result error (E─AppErr p)
  helper₁ (result (closure s′ t′) p) = helper₂ p (interpret s t₂)

-- Shorthand for starting from the empty stack

i = interpret nil


module Prelude.Nat.Core where

open import Prelude.Unit
open import Prelude.Empty
open import Prelude.Number
open import Prelude.Semiring

open import Agda.Builtin.Nat public
  renaming ( _+_        to _+N_
           ; _*_        to _*N_
           ; _-_        to _-N_
           ; _==_       to eqNat
           ; _<_        to lessNat
           ; div-helper to divAux
           ; mod-helper to modAux )

{-# DISPLAY _+N_ = _+_ #-}
{-# DISPLAY _-N_ = _-_ #-}
{-# DISPLAY _*N_ = _*_ #-}

--- Semiring ---

instance
  NumberNat : Number Nat
  Number.Constraint NumberNat _ = ⊤
  Number.fromNat    NumberNat n = n

  SemiringNat : Semiring Nat
  zro {{SemiringNat}} = 0
  one {{SemiringNat}} = 1
  _+_ {{SemiringNat}} = _+N_
  _*_ {{SemiringNat}} = _*N_

  SubtractiveNat : Subtractive Nat
  _-_    {{SubtractiveNat}}   = _-N_
  negate {{SubtractiveNat}} _ = 0

--- Division and modulo ---

NonZero : Nat → Set
NonZero zero    = ⊥
NonZero (suc _) = ⊤

infixl 7 natDiv natMod
syntax natDiv m n = n div m
natDiv : (m : Nat) {{nz : NonZero m}} → Nat → Nat
natDiv zero {{}} n
natDiv (suc m) n = divAux 0 m n m

syntax natMod m n = n mod m
natMod : (m : Nat) {{nz : NonZero m}} → Nat → Nat
natMod zero {{}} n
natMod (suc m) n = modAux 0 m n m

{-# INLINE natMod #-}
{-# INLINE natDiv #-}


------------------------------------------------------------------------------
-- Testing Agsy arithmetic properties used by the McCarthy 91 function
------------------------------------------------------------------------------

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

-- Tested with the development version of the Agda standard library on
-- 02 February 2012.

module Agsy.McCarthy91.Arithmetic where

open import Data.Nat
open import Relation.Binary.PropositionalEquality

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

91≡[100+11∸10]∸10 : (100 + 11 ∸ 10) ∸ 10 ≡ 91
91≡[100+11∸10]∸10 = refl

20>19 : 20 > 19  -- via Agsy
20>19 = s≤s
          (s≤s
           (s≤s
            (s≤s
             (s≤s
              (s≤s
               (s≤s
                (s≤s
                 (s≤s
                  (s≤s
                   (s≤s
                    (s≤s (s≤s (s≤s (s≤s (s≤s (s≤s (s≤s (s≤s (s≤s z≤n)))))))))))))))))))

50>49 : 50 > 49  -- via Agsy {-t 30}
50>49 = s≤s
          (s≤s
           (s≤s
            (s≤s
             (s≤s
              (s≤s
               (s≤s
                (s≤s
                 (s≤s
                  (s≤s
                   (s≤s
                    (s≤s
                     (s≤s
                      (s≤s
                       (s≤s
                        (s≤s
                         (s≤s
                          (s≤s
                           (s≤s
                            (s≤s
                             (s≤s
                              (s≤s
                               (s≤s
                                (s≤s
                                 (s≤s
                                  (s≤s
                                   (s≤s
                                    (s≤s
                                     (s≤s
                                      (s≤s
                                       (s≤s
                                        (s≤s
                                         (s≤s
                                          (s≤s
                                           (s≤s
                                            (s≤s
                                             (s≤s
                                              (s≤s
                                               (s≤s
                                                (s≤s
                                                 (s≤s
                                                  (s≤s
                                                   (s≤s
                                                    (s≤s
                                                     (s≤s
                                                      (s≤s
                                                       (s≤s
                                                        (s≤s
                                                         (s≤s
                                                          (s≤s
                                                           z≤n)))))))))))))))))))))))))))))))))))))))))))))))))

75>74 : 75 > 74  -- via Agsy {-t 180}
75>74 = s≤s
          (s≤s
           (s≤s
            (s≤s
             (s≤s
              (s≤s
               (s≤s
                (s≤s
                 (s≤s
                  (s≤s
                   (s≤s
                    (s≤s
                     (s≤s
                      (s≤s
                       (s≤s
                        (s≤s
                         (s≤s
                          (s≤s
                           (s≤s
                            (s≤s
                             (s≤s
                              (s≤s
                               (s≤s
                                (s≤s
                                 (s≤s
                                  (s≤s
                                   (s≤s
                                    (s≤s
                                     (s≤s
                                      (s≤s
                                       (s≤s
                                        (s≤s
                                         (s≤s
                                          (s≤s
                                           (s≤s
                                            (s≤s
                                             (s≤s
                                              (s≤s
                                               (s≤s
                                                (s≤s
                                                 (s≤s
                                                  (s≤s
                                                   (s≤s
                                                    (s≤s
                                                     (s≤s
                                                      (s≤s
                                                       (s≤s
                                                        (s≤s
                                                         (s≤s
                                                          (s≤s
                                                           (s≤s
                                                            (s≤s
                                                             (s≤s
                                                              (s≤s
                                                               (s≤s
                                                                (s≤s
                                                                 (s≤s
                                                                  (s≤s
                                                                   (s≤s
                                                                    (s≤s
                                                                     (s≤s
                                                                      (s≤s
                                                                       (s≤s
                                                                        (s≤s
                                                                         (s≤s
                                                                          (s≤s
                                                                           (s≤s
                                                                            (s≤s
                                                                             (s≤s
                                                                              (s≤s
                                                                               (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                z≤n))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

101>100 : 101 > 100  -- via Agsy {-t 600}
101>100 = s≤s
          (s≤s
           (s≤s
            (s≤s
             (s≤s
              (s≤s
               (s≤s
                (s≤s
                 (s≤s
                  (s≤s
                   (s≤s
                    (s≤s
                     (s≤s
                      (s≤s
                       (s≤s
                        (s≤s
                         (s≤s
                          (s≤s
                           (s≤s
                            (s≤s
                             (s≤s
                              (s≤s
                               (s≤s
                                (s≤s
                                 (s≤s
                                  (s≤s
                                   (s≤s
                                    (s≤s
                                     (s≤s
                                      (s≤s
                                       (s≤s
                                        (s≤s
                                         (s≤s
                                          (s≤s
                                           (s≤s
                                            (s≤s
                                             (s≤s
                                              (s≤s
                                               (s≤s
                                                (s≤s
                                                 (s≤s
                                                  (s≤s
                                                   (s≤s
                                                    (s≤s
                                                     (s≤s
                                                      (s≤s
                                                       (s≤s
                                                        (s≤s
                                                         (s≤s
                                                          (s≤s
                                                           (s≤s
                                                            (s≤s
                                                             (s≤s
                                                              (s≤s
                                                               (s≤s
                                                                (s≤s
                                                                 (s≤s
                                                                  (s≤s
                                                                   (s≤s
                                                                    (s≤s
                                                                     (s≤s
                                                                      (s≤s
                                                                       (s≤s
                                                                        (s≤s
                                                                         (s≤s
                                                                          (s≤s
                                                                           (s≤s
                                                                            (s≤s
                                                                             (s≤s
                                                                              (s≤s
                                                                               (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                z≤n))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))


module Oscar.Data.Equality where

open import Agda.Builtin.Equality public using (_≡_; refl) public
open import Relation.Binary.PropositionalEquality public using (_≢_) public
open import Relation.Binary.PropositionalEquality public using (cong; cong₂; cong-app; subst; subst₂; sym; trans) public

open import Oscar.Level
open import Oscar.Function
open import Oscar.Relation

infix 4 _≡̇_
_≡̇_ : ∀ {a} {A : Set a} {b} {B : A → Set b} → ((x : A) → B x) → ((x : A) → B x) → Set (a ⊔ b)
f ≡̇ g = ∀ x → f x ≡ g x

≡̇-refl : ∀ {a} {A : Set a} {b} {B : A → Set b} (f : (x : A) → B x) → f ≡̇ f
≡̇-refl _ _ = refl

≡̇-sym : ∀ {a} {A : Set a} {b} {B : A → Set b} {f g : (x : A) → B x} → f ≡̇ g → g ≡̇ f
≡̇-sym f≡̇g = sym ∘ f≡̇g

≡̇-trans : ∀ {a} {A : Set a} {b} {B : A → Set b} {f g : (x : A) → B x} → f ≡̇ g → {h : (x : A) → B x} → g ⟨ _≡̇ h ⟩→ f
≡̇-trans f≡̇g g≡̇h x = trans (f≡̇g x) (g≡̇h x)

open import Oscar.Category

≡-setoid : ∀ {a} (A : Set a) → Setoid A a
Setoid._≋_ (≡-setoid A) = _≡_
Setoid.≋-reflexivity (≡-setoid A) = refl
Setoid.≋-symmetry (≡-setoid A) = sym
Setoid.≋-transitivity (≡-setoid A) x≡y = trans x≡y

≡̇-setoid : ∀ {a} {A : Set a} {b} (B : A → Set b) → Setoid ((x : A) → B x) (a ⊔ b)
Setoid._≋_ (≡̇-setoid B) = _≡̇_
Setoid.≋-reflexivity (≡̇-setoid B) = ≡̇-refl _
Setoid.≋-symmetry (≡̇-setoid B) = ≡̇-sym
Setoid.≋-transitivity (≡̇-setoid B) = ≡̇-trans