module Logic.Propositional.Theorems where

open import Data
open import Data.Either as Either using (_‖_)
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic
open import Logic.Propositional
import      Lvl
open import Syntax.Type
open import Type

------------------------------------------
-- Reflexivity

module _ {ℓ} {P : Stmt{ℓ}} where
  [↔]-reflexivity : (P ↔ P)
  [↔]-reflexivity = [↔]-intro id id

  [→]-reflexivity : (P → P)
  [→]-reflexivity = id

------------------------------------------
-- Transitivity

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{R : Stmt{ℓ₃}} where
  [→]-transitivity : (P → Q) → (Q → R) → (P → R)
  [→]-transitivity = liftᵣ

  [↔]-transitivity : (P ↔ Q) → (Q ↔ R) → (P ↔ R)
  [↔]-transitivity ([↔]-intro qp pq) ([↔]-intro rq qr) = [↔]-intro (qp ∘ rq) (qr ∘ pq)

  [∧]-transitivity : (P ∧ Q) → (Q ∧ R) → (P ∧ R)
  [∧]-transitivity ([∧]-intro p _) ([∧]-intro _ r) = [∧]-intro p r

------------------------------------------
-- Symmetry

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [∧]-symmetry : (P ∧ Q) → (Q ∧ P)
  [∧]-symmetry = Tuple.swap

  [∨]-symmetry : (P ∨ Q) → (Q ∨ P)
  [∨]-symmetry = Either.swap

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [↔]-symmetry : (P ↔ Q) → (Q ↔ P)
  [↔]-symmetry = [∧]-symmetry

------------------------------------------
-- Operators that implies other ones

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [∧]-to-[↔] : (P ∧ Q) → (P ↔ Q)
  [∧]-to-[↔] ([∧]-intro p q) = [↔]-intro (const p) (const q)

  [∧]-to-[→] : (P ∧ Q) → (P → Q)
  [∧]-to-[→] ([∧]-intro p q) = const q

  [∧]-to-[←] : (P ∧ Q) → (P ← Q)
  [∧]-to-[←] ([∧]-intro p q) = const p

  [∧]-to-[∨] : (P ∧ Q) → (P ∨ Q)
  [∧]-to-[∨] ([∧]-intro p q) = [∨]-introₗ p

  [∨]-to-[←][→] : (P ∨ Q) → (P ← Q)∨(P → Q)
  [∨]-to-[←][→] ([∨]-introₗ p) = [∨]-introₗ (const p)
  [∨]-to-[←][→] ([∨]-introᵣ q) = [∨]-introᵣ (const q)

------------------------------------------
-- Associativity (with respect to ↔)

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{R : Stmt{ℓ₃}} where
  [∧]-associativity : ((P ∧ Q) ∧ R) ↔ (P ∧ (Q ∧ R))
  [∧]-associativity = [↔]-intro l r
    where l : ((P ∧ Q) ∧ R) ← (P ∧ (Q ∧ R))
          l ([∧]-intro p ([∧]-intro q r)) = [∧]-intro ([∧]-intro p q) r

          r : ((P ∧ Q) ∧ R) → (P ∧ (Q ∧ R))
          r ([∧]-intro ([∧]-intro p q) r) = [∧]-intro p ([∧]-intro q r)

  [∨]-associativity : ((P ∨ Q) ∨ R) ↔ (P ∨ (Q ∨ R))
  [∨]-associativity = [↔]-intro l r
    where l : ((P ∨ Q) ∨ R) ← (P ∨ (Q ∨ R))
          l ([∨]-introₗ p) = [∨]-introₗ([∨]-introₗ p)
          l ([∨]-introᵣ([∨]-introₗ q)) = [∨]-introₗ([∨]-introᵣ q)
          l ([∨]-introᵣ([∨]-introᵣ r)) = [∨]-introᵣ r

          r : ((P ∨ Q) ∨ R) → (P ∨ (Q ∨ R))
          r ([∨]-introₗ([∨]-introₗ p)) = [∨]-introₗ p
          r ([∨]-introₗ([∨]-introᵣ q)) = [∨]-introᵣ([∨]-introₗ q)
          r ([∨]-introᵣ r) = [∨]-introᵣ([∨]-introᵣ r)

-- TODO: According to https://math.stackexchange.com/questions/440261/associativity-of-iff , this is unprovable
{-[↔]-associativity : ∀{P Q R : Stmt} → ((P ↔ Q) ↔ R) ↔ (P ↔ (Q ↔ R))
[↔]-associativity {P}{Q}{R} = [↔]-intro [↔]-associativityₗ [↔]-associativityᵣ where
  [↔]-associativityₗ : ((P ↔ Q) ↔ R) ← (P ↔ (Q ↔ R))
  [↔]-associativityₗ ([↔]-intro yz2x x2yz) = [↔]-intro z2xy xy2z where
    z2xy : (P ↔ Q) ← R
    z2xy r = [↔]-intro y2x x2y where
      y2x : Q → P
      y2x q = yz2x([∧]-to-[↔]([∧]-intro q r))

      x2y : P → Q
      x2y p = [↔]-elimₗ (x2yz(p)) (r)

    xy2z : (P ↔ Q) → R -- TODO: How?
    xy2z ([↔]-intro y2x x2y) = ?

  [↔]-associativityᵣ : ((P ↔ Q) ↔ R) → (P ↔ (Q ↔ R))
  [↔]-associativityᵣ ([↔]-intro z2xy xy2z) = [↔]-intro yz2x x2yz where
    yz2x : P ← (Q ↔ R)
    yz2x ([↔]-intro z2y y2z) = ?

    x2yz : P → (Q ↔ R)
    x2yz p = [↔]-intro z2y y2z where
      z2y : R → Q
      z2y r = [↔]-elimᵣ (z2xy(r)) (p)

      y2z : Q → R
      y2z q = xy2z([∧]-to-[↔]([∧]-intro p q))
-}

------------------------------------------
-- Distributivity

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{R : Stmt{ℓ₃}} where
  [∧][∨]-distributivityₗ : (P ∧ (Q ∨ R)) ↔ (P ∧ Q)∨(P ∧ R)
  [∧][∨]-distributivityₗ = [↔]-intro l r where
    l : (P ∧ (Q ∨ R)) ← (P ∧ Q)∨(P ∧ R)
    l([∨]-introₗ ([∧]-intro p q)) = [∧]-intro p ([∨]-introₗ q)
    l([∨]-introᵣ ([∧]-intro p r)) = [∧]-intro p ([∨]-introᵣ r)

    r : (P ∧ (Q ∨ R)) → (P ∧ Q)∨(P ∧ R)
    r([∧]-intro p ([∨]-introₗ q)) = [∨]-introₗ([∧]-intro p q)
    r([∧]-intro p ([∨]-introᵣ r)) = [∨]-introᵣ([∧]-intro p r)

  [∧][∨]-distributivityᵣ : ((P ∨ Q) ∧ R) ↔ (P ∧ R)∨(Q ∧ R)
  [∧][∨]-distributivityᵣ = [↔]-intro l r where
    l : ((P ∨ Q) ∧ R) ← (P ∧ R)∨(Q ∧ R)
    l([∨]-introₗ ([∧]-intro p r)) = [∧]-intro ([∨]-introₗ p) r
    l([∨]-introᵣ ([∧]-intro q r)) = [∧]-intro ([∨]-introᵣ q) r

    r : ((P ∨ Q) ∧ R) → (P ∧ R)∨(Q ∧ R)
    r([∧]-intro ([∨]-introₗ p) r) = [∨]-introₗ([∧]-intro p r)
    r([∧]-intro ([∨]-introᵣ q) r) = [∨]-introᵣ([∧]-intro q r)

  [∨][∧]-distributivityₗ : (P ∨ (Q ∧ R)) ↔ (P ∨ Q)∧(P ∨ R)
  [∨][∧]-distributivityₗ = [↔]-intro l r where
    l : (P ∨ (Q ∧ R)) ← (P ∨ Q)∧(P ∨ R)
    l([∧]-intro ([∨]-introₗ p) ([∨]-introₗ _)) = [∨]-introₗ(p)
    l([∧]-intro ([∨]-introₗ p) ([∨]-introᵣ r)) = [∨]-introₗ(p)
    l([∧]-intro ([∨]-introᵣ q) ([∨]-introₗ p)) = [∨]-introₗ(p)
    l([∧]-intro ([∨]-introᵣ q) ([∨]-introᵣ r)) = [∨]-introᵣ([∧]-intro q r)

    r : (P ∨ (Q ∧ R)) → (P ∨ Q)∧(P ∨ R)
    r([∨]-introₗ p)               = [∧]-intro ([∨]-introₗ p) ([∨]-introₗ p)
    r([∨]-introᵣ ([∧]-intro q r)) = [∧]-intro ([∨]-introᵣ q) ([∨]-introᵣ r)

  [∨][∧]-distributivityᵣ : ((P ∧ Q) ∨ R) ↔ (P ∨ R)∧(Q ∨ R)
  [∨][∧]-distributivityᵣ = [↔]-intro l r where
    l : ((P ∧ Q) ∨ R) ← (P ∨ R)∧(Q ∨ R)
    l([∧]-intro ([∨]-introₗ p) ([∨]-introₗ q)) = [∨]-introₗ([∧]-intro p q)
    l([∧]-intro ([∨]-introₗ p) ([∨]-introᵣ r)) = [∨]-introᵣ(r)
    l([∧]-intro ([∨]-introᵣ r) ([∨]-introₗ q)) = [∨]-introᵣ(r)
    l([∧]-intro ([∨]-introᵣ r) ([∨]-introᵣ _)) = [∨]-introᵣ(r)

    r : ((P ∧ Q) ∨ R) → (P ∨ R)∧(Q ∨ R)
    r([∨]-introₗ ([∧]-intro p q)) = [∧]-intro ([∨]-introₗ p) ([∨]-introₗ q)
    r([∨]-introᵣ r)               = [∧]-intro ([∨]-introᵣ r) ([∨]-introᵣ r)

------------------------------------------
-- Identity (with respect to →)

module _ {ℓ} {P : Stmt{ℓ}} where
  [∧]-identityₗ : (⊤ ∧ P) → P
  [∧]-identityₗ ([∧]-intro _ p) = p

  [∧]-identityᵣ : (P ∧ ⊤) → P
  [∧]-identityᵣ ([∧]-intro p _) = p

  [∨]-identityₗ : (⊥ ∨ P) → P
  [∨]-identityₗ ([∨]-introₗ ())
  [∨]-identityₗ ([∨]-introᵣ p) = p

  [∨]-identityᵣ : (P ∨ ⊥) → P
  [∨]-identityᵣ ([∨]-introₗ p) = p
  [∨]-identityᵣ ([∨]-introᵣ ())

  [→]-identityₗ : (⊤ → P) → P
  [→]-identityₗ f = f([⊤]-intro)

  [∧]-nullifierₗ : (⊥ ∧ P) → ⊥
  [∧]-nullifierₗ ([∧]-intro () _)

  [∧]-nullifierᵣ : (P ∧ ⊥) → ⊥
  [∧]-nullifierᵣ ([∧]-intro _ ())

module _ {ℓ₂}{ℓ₃} {_▫_ : Stmt{Lvl.𝟎} → Stmt{ℓ₂} → Stmt{ℓ₃}} where
  [⊤]-as-nullifierₗ : ∀{P : Stmt} → (⊤ ▫ P) → ⊤
  [⊤]-as-nullifierₗ _ = [⊤]-intro

module _ {ℓ₁}{ℓ₃} {_▫_ : Stmt{ℓ₁} → Stmt{Lvl.𝟎} → Stmt{ℓ₃}} where
  [⊤]-as-nullifierᵣ : ∀{P : Stmt} → (P ▫ ⊤) → ⊤
  [⊤]-as-nullifierᵣ _ = [⊤]-intro

------------------------------------------
-- Other

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [∨]-not-left : (P ∨ Q) → (¬ P) → Q
  [∨]-not-left ([∨]-introₗ p) np = [⊥]-elim(np p)
  [∨]-not-left ([∨]-introᵣ q) = const q

  [∨]-not-right : (P ∨ Q) → (¬ Q) → P
  [∨]-not-right ([∨]-introₗ p) = const p
  [∨]-not-right ([∨]-introᵣ q) nq = [⊥]-elim(nq q)

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{T : Stmt{ℓ₃}} where
  [→]-lift : (P → Q) → ((T → P) → (T → Q))
  [→]-lift = liftₗ

module _ {ℓ₁ ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  contrapositiveᵣ : (P → Q) → ((¬ P) ← (¬ Q))
  contrapositiveᵣ = [→]-transitivity

  contrapositive-variant : (P → (¬ Q)) ↔ ((¬ P) ← Q)
  contrapositive-variant = [↔]-intro swap swap

  modus-tollens : (P → Q) → (¬ Q) → (¬ P)
  modus-tollens = contrapositiveᵣ

module _ {ℓ₁}{ℓ₂}{ℓ₃}{ℓ₄} {A : Stmt{ℓ₁}}{B : Stmt{ℓ₂}}{C : Stmt{ℓ₃}}{D : Stmt{ℓ₄}} where
  constructive-dilemma : (A → B) → (C → D) → (A ∨ C) → (B ∨ D)
  constructive-dilemma = [∨]-elim2

  destructive-dilemma : (A → B) → (C → D) → ((¬ B) ∨ (¬ D)) → ((¬ A) ∨ (¬ C))
  destructive-dilemma l r = [∨]-elim2 (contrapositiveᵣ l) (contrapositiveᵣ r)

module _ {ℓ} {P : Stmt{ℓ}} where
  [¬¬]-intro : P → (¬¬ P)
  [¬¬]-intro = apply
    -- P → (P → ⊥) → ⊥

  [¬¬¬]-elim : (¬ (¬ (¬ P))) → (¬ P)
  [¬¬¬]-elim = contrapositiveᵣ [¬¬]-intro

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{R : Stmt{ℓ₃}} where
  [↔]-move-out-[∧]ᵣ : ((P ∧ R) ↔ (Q ∧ R)) → (R → (P ↔ Q))
  [↔]-move-out-[∧]ᵣ ([↔]-intro qrpr prqr) r =
    ([↔]-intro
      (q ↦ [∧]-elimₗ(qrpr([∧]-intro q r)))
      (p ↦ [∧]-elimₗ(prqr([∧]-intro p r)))
    )

  [∧]-unaryOperatorₗ : (P ↔ Q) → ((P ∧ R) ↔ (Q ∧ R))
  [∧]-unaryOperatorₗ ([↔]-intro qp pq) =
    ([↔]-intro
      (qr ↦ [∧]-intro (qp([∧]-elimₗ qr)) ([∧]-elimᵣ qr))
      (pr ↦ [∧]-intro (pq([∧]-elimₗ pr)) ([∧]-elimᵣ pr))
    )

  currying : (P → (Q → R)) ↔ ((P ∧ Q) → R)
  currying = [↔]-intro Tuple.curry Tuple.uncurry

module _ {ℓ₁}{ℓ₂}{ℓ₃}{ℓ₄} {A : Stmt{ℓ₁}}{B : Stmt{ℓ₂}}{C : Stmt{ℓ₃}}{D : Stmt{ℓ₄}} where
  [∧]-binaryOperator : (A ↔ C) → (B ↔ D) → ((A ∧ B) ↔ (C ∧ D))
  [∧]-binaryOperator ([↔]-intro ca ac) ([↔]-intro db bd) = [↔]-intro (Tuple.map ca db) (Tuple.map ac bd)

  [∨]-binaryOperator : (A ↔ C) → (B ↔ D) → ((A ∨ B) ↔ (C ∨ D))
  [∨]-binaryOperator ([↔]-intro ca ac) ([↔]-intro db bd) = [↔]-intro (Either.map ca db) (Either.map ac bd)

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [↔]-not-left : (P ↔ Q) → (¬ P) → (¬ Q)
  [↔]-not-left pq np q = np([↔]-elimₗ(q)(pq))

  [↔]-not-right : (P ↔ Q) → (¬ Q) → (¬ P)
  [↔]-not-right pq nq p = nq([↔]-elimᵣ(p)(pq))

  [¬]-unaryOperator : (P ↔ Q) → ((¬ P) ↔ (¬ Q))
  [¬]-unaryOperator pq = [↔]-intro ([↔]-not-right (pq)) ([↔]-not-left (pq))

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [↔]-elim-[∨] : (P ↔ Q) → (P ∨ Q) → (P ∧ Q)
  [↔]-elim-[∨] (p↔q) ([∨]-introₗ p) = [∧]-intro p ([↔]-elimᵣ(p) p↔q)
  [↔]-elim-[∨] (p↔q) ([∨]-introᵣ q) = [∧]-intro ([↔]-elimₗ(q) p↔q) q

module _ {ℓ} {P : Stmt{ℓ}} where
  provable-top-equivalence : P → (P ↔ ⊤)
  provable-top-equivalence p = [↔]-intro (const p) (const [⊤]-intro)

  unprovable-bottom-equivalence : (¬ P) → (P ↔ ⊥)
  unprovable-bottom-equivalence np = [↔]-intro [⊥]-elim np

------------------------------------------
-- Negation is almost preserved over the conjunction-dijunction dual (De-morgan's laws).

module _ {ℓ₁ ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [¬]-preserves-[∧][∨]ₗ : (¬ (P ∧ Q)) ← ((¬ P) ∨ (¬ Q))
  [¬]-preserves-[∧][∨]ₗ ([∨]-introₗ np) = np ∘ [∧]-elimₗ
  [¬]-preserves-[∧][∨]ₗ ([∨]-introᵣ nq) = nq ∘ [∧]-elimᵣ

  [¬]-preserves-[∨][∧] : (¬ (P ∨ Q)) ↔ ((¬ P) ∧ (¬ Q))
  [¬]-preserves-[∨][∧] = [↔]-intro l r where
    l : ¬(P ∨ Q) ← ((¬ P) ∧ (¬ Q))
    l ([∧]-intro np nq) = [∨]-elim np nq

    r : (¬ (P ∨ Q)) → ((¬ P) ∧ (¬ Q))
    r f = [∧]-intro (f ∘ [∨]-introₗ) (f ∘ [∨]-introᵣ)

------------------------------------------
-- Conjunction and implication (Tuples and functions)

module _ {ℓ₁}{ℓ₂}{ℓ₃} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}}{R : Stmt{ℓ₃}} where
  [→][∧]-assumption : ((P ∧ Q) → R) ↔ (P → Q → R)
  [→][∧]-assumption = [↔]-intro Tuple.uncurry Tuple.curry

  [→][∧]-distributivityₗ : (P → (Q ∧ R)) ↔ ((P → Q) ∧ (P → R))
  [→][∧]-distributivityₗ = [↔]-intro l r
    where l : ((P → Q) ∧ (P → R)) → (P → (Q ∧ R))
          l ([∧]-intro pq pr) p = [∧]-intro (pq(p)) (pr(p))

          r : ((P → Q) ∧ (P → R)) ← (P → (Q ∧ R))
          r both = [∧]-intro ([∧]-elimₗ ∘ both) ([∧]-elimᵣ ∘ both)

  [→][∨]-distributivityₗₗ : (P → (Q ∨ R)) ← ((P → Q) ∨ (P → R))
  [→][∨]-distributivityₗₗ = l
    where l : ((P → Q) ∨ (P → R)) → (P → (Q ∨ R))
          l ([∨]-introₗ pq) p = [∨]-introₗ (pq(p))
          l ([∨]-introᵣ pr) p = [∨]-introᵣ (pr(p))

  [→ₗ][∨][∧]-preserving : ((P ∨ Q) → R) ↔ ((P → R) ∧ (Q → R))
  [→ₗ][∨][∧]-preserving = [↔]-intro l r where
    l : ((P ∨ Q) → R) ← ((P → R) ∧ (Q → R))
    l ([∧]-intro pr qr) ([∨]-introₗ p) = pr p
    l ([∧]-intro pr qr) ([∨]-introᵣ q) = qr q

    r : ((P ∨ Q) → R) → ((P → R) ∧ (Q → R))
    r pqr = [∧]-intro (pqr ∘ [∨]-introₗ) (pqr ∘ [∨]-introᵣ)

module _ {ℓ} {P : Stmt{ℓ}} where
  non-contradiction : ¬(P ∧ (¬ P))
  non-contradiction(p , np) = np p

------------------------------------------
-- Redundant formulas in operations

module _ {ℓ₁}{ℓ₂} {A : Stmt{ℓ₁}}{B : Stmt{ℓ₂}} where
  [→]-redundancy : (A → A → B) → (A → B)
  [→]-redundancy = _$₂_

module _ {ℓ} {A : Stmt{ℓ}} where
  [∧]-redundancy : (A ∧ A) ↔ A
  [∧]-redundancy = [↔]-intro ([∧]-intro $₂_) [∧]-elimₗ

  [∨]-redundancy : (A ∨ A) ↔ A
  [∨]-redundancy = [↔]-intro [∨]-introₗ ([∨]-elim id id)

------------------------------------------
-- Disjunctive forms

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  -- Also called: Material implication
  [→]-disjunctive-formₗ : (P → Q) ← ((¬ P) ∨ Q)
  [→]-disjunctive-formₗ = [∨]-elim ([→]-lift [⊥]-elim) const

  [↔]-disjunctive-formₗ : (P ↔ Q) ← ((P ∧ Q) ∨ ((¬ P) ∧ (¬ Q)))
  [↔]-disjunctive-formₗ ([∨]-introₗ pq)   = [∧]-to-[↔] pq
  [↔]-disjunctive-formₗ ([∨]-introᵣ npnq) = Tuple.map ([⊥]-elim ∘_) ([⊥]-elim ∘_) (Tuple.swap npnq)

  -- TODO: Probably unprovable
  -- [↔]-disjunctive-formᵣ : ∀{P Q : Stmt} → (P ↔ Q) → ((P ∧ Q) ∨ ((¬ P) ∧ (¬ Q)))
  -- [↔]-disjunctive-formᵣ ([↔]-intro qp pq) =

  [¬→]-disjunctive-formₗ : ((¬ P) → Q) ← (P ∨ Q)
  [¬→]-disjunctive-formₗ = [∨]-not-left

------------------------------------------
-- Conjuctive forms

-- TODO: None of them are provable?
-- [↔]-conjunctive-form : ∀{P Q : Stmt} → (P ↔ Q) ↔ ((P ∨ Q) ∧ ((¬ P) ∨ (¬ Q)))
-- [↔]-conjunctive-form ([↔]-intro qp pq) = [∨]-elim ([→]-lift [⊥]-elim) (const)

module _ {ℓ₁ ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [→][∧]ᵣ : (P → Q) → ¬(P ∧ (¬ Q))
  [→][∧]ᵣ f = Tuple.uncurry([¬¬]-intro ∘ f)

  [¬→][∧]ₗ : ¬(P → Q) ← (P ∧ (¬ Q))
  [¬→][∧]ₗ = swap [→][∧]ᵣ

  [→¬]-¬[∧] : (P → (¬ Q)) ↔ ¬(P ∧ Q)
  [→¬]-¬[∧] = currying

------------------------------------------
-- Equivalences (TODO: I remember these being defined somewhere else, but I am not sure. At least some special cases have been used somewhere else)

module _ where
  private variable ℓ : Lvl.Level
  private variable A A₁ A₂ B B₁ B₂ : Type{ℓ}

  [∧]-map-[↔] : (A₁ ↔ A₂) → (B₁ ↔ B₂) → ((A₁ ∧ B₁) ↔ (A₂ ∧ B₂))
  [∧]-map-[↔] a b = [↔]-intro (Tuple.map ([↔]-to-[←] a) ([↔]-to-[←] b)) (Tuple.map ([↔]-to-[→] a) ([↔]-to-[→] b))

  [∧]-mapₗ-[↔] : (A₁ ↔ A₂) → ((A₁ ∧ B) ↔ (A₂ ∧ B))
  [∧]-mapₗ-[↔] a = [∧]-map-[↔] a [↔]-reflexivity

  [∧]-mapᵣ-[↔] : (B₁ ↔ B₂) → ((A ∧ B₁) ↔ (A ∧ B₂))
  [∧]-mapᵣ-[↔] b = [∧]-map-[↔] [↔]-reflexivity b

  [∨]-map-[↔] : (A₁ ↔ A₂) → (B₁ ↔ B₂) → ((A₁ ∨ B₁) ↔ (A₂ ∨ B₂))
  [∨]-map-[↔] a b = [↔]-intro (Either.map ([↔]-to-[←] a) ([↔]-to-[←] b)) (Either.map ([↔]-to-[→] a) ([↔]-to-[→] b))

  [∨]-mapₗ-[↔] : (A₁ ↔ A₂) → ((A₁ ∨ B) ↔ (A₂ ∨ B))
  [∨]-mapₗ-[↔] a = [∨]-map-[↔] a [↔]-reflexivity

  [∨]-mapᵣ-[↔] : (B₁ ↔ B₂) → ((A ∨ B₁) ↔ (A ∨ B₂))
  [∨]-mapᵣ-[↔] b = [∨]-map-[↔] [↔]-reflexivity b

  [↔]-map-[↔] : (A₁ ↔ A₂) → (B₁ ↔ B₂) → ((A₁ ↔ B₁) ↔ (A₂ ↔ B₂))
  [↔]-map-[↔] a b =
    [↔]-intro
      (Tuple.map
        (b₂a₂ ↦ [↔]-to-[←] a ∘ b₂a₂ ∘ [↔]-to-[→] b)
        (a₂b₂ ↦ [↔]-to-[←] b ∘ a₂b₂ ∘ [↔]-to-[→] a)
      )
      (Tuple.map
        (b₁a₁ ↦ [↔]-to-[→] a ∘ b₁a₁ ∘ [↔]-to-[←] b)
        (a₁b₁ ↦ [↔]-to-[→] b ∘ a₁b₁ ∘ [↔]-to-[←] a)
      )

  [↔]-mapₗ-[↔] : (A₁ ↔ A₂) → ((A₁ ↔ B) ↔ (A₂ ↔ B))
  [↔]-mapₗ-[↔] a = [↔]-map-[↔] a [↔]-reflexivity

  [↔]-mapᵣ-[↔] : (B₁ ↔ B₂) → ((A ↔ B₁) ↔ (A ↔ B₂))
  [↔]-mapᵣ-[↔] b = [↔]-map-[↔] [↔]-reflexivity b

  [→]-map-[↔] : (A₁ ↔ A₂) → (B₁ ↔ B₂) → ((A₁ → B₁) ↔ (A₂ → B₂))
  [→]-map-[↔] a b = [↔]-intro (ab ↦ [↔]-to-[←] b ∘ ab ∘ [↔]-to-[→] a) (ab ↦ [↔]-to-[→] b ∘ ab ∘ [↔]-to-[←] a)

------------------------------------------
-- Stuff related to classical logic

module _ {ℓ} {P : Stmt{ℓ}} where
  [¬¬]-excluded-middle : ¬¬(P ∨ (¬ P))
  [¬¬]-excluded-middle =
    ([¬]-intro(naorna ↦
      ((non-contradiction([∧]-intro
        (([∨]-introᵣ
          (([¬]-intro(a ↦
            ((non-contradiction([∧]-intro
              (([∨]-introₗ a) :of:  (P ∨ (¬ P)))
              (naorna         :of: ¬(P ∨ (¬ P)))
            )) :of: ⊥)
          )) :of: (¬ P))
        ) :of: (P ∨ (¬ P)))
        (naorna :of: ¬(P ∨ (¬ P)))
      )) :of: ⊥)
    )) :of: ¬¬(P ∨ (¬ P))

  -- Note:
  --   ∀{P} → (P ∨ (¬ P)) ← ((¬¬ P) → P)
  --   is not provable because the statement (P ∨ (¬ P)) requires a [¬¬]-elim.
  --   TODO: ...I think? I do not think (∀{P} → ¬¬(P ∨ (¬ P)) → ((¬¬ P) ∨ (¬ P))) is provable.
  [¬¬]-elim-from-excluded-middle : (P ∨ (¬ P)) → ((¬¬ P) → P)
  [¬¬]-elim-from-excluded-middle ([∨]-introₗ p)  (nnp) = p
  [¬¬]-elim-from-excluded-middle ([∨]-introᵣ np) (nnp) = [⊥]-elim(nnp(np))

  [¬¬]-elim-from-callcc : (∀{Q : Stmt{Lvl.𝟎}} → (((P → Q) → P) → P)) → ((¬¬ P) → P)
  [¬¬]-elim-from-callcc (callcc) (nnp) = callcc{⊥} ([⊥]-elim ∘ nnp)

module _ {ℓ} where
  [[¬¬]-elim]-[excluded-middle]-eqₗ : (∀{P : Stmt{ℓ}} → (¬¬ P) → P) ←ᶠ (∀{P : Stmt{ℓ}} → (P ∨ (¬ P)))
  [[¬¬]-elim]-[excluded-middle]-eqₗ or {P} (nnp) with or
  ... | ([∨]-introₗ p ) = p
  ... | ([∨]-introᵣ np) = [⊥]-elim(nnp(np))

  [[¬¬]-elim]-[excluded-middle]-eqᵣ : (∀{P : Stmt{ℓ}} → (¬¬ P) → P) → (∀{P : Stmt{ℓ}} → (P ∨ (¬ P)))
  [[¬¬]-elim]-[excluded-middle]-eqᵣ (nnpp) = nnpp([¬¬]-excluded-middle)

  -- TODO: https://math.stackexchange.com/questions/910240/equivalence-between-middle-excluded-law-and-double-negation-elimination-in-heyti

  [callcc]-[[¬¬]-elim]-eqₗ : (∀{P : Stmt{ℓ}}{Q : Stmt{Lvl.𝟎}} → (((P → Q) → P) → P)) → (∀{P} → (¬¬ P) → P)
  [callcc]-[[¬¬]-elim]-eqₗ (callcc) {P} (nnp) = callcc{P}{⊥} (np ↦ [⊥]-elim(nnp(np)))

  [callcc]-[[¬¬]-elim]-eqᵣ : (∀{P : Stmt{ℓ}} → (¬¬ P) → P) → (∀{P Q : Stmt{ℓ}} → (((P → Q) → P) → P))
  [callcc]-[[¬¬]-elim]-eqᵣ (nnpp) {P}{Q} (pqp) = nnpp([¬]-intro(np ↦ np(pqp(p ↦ [⊥]-elim(np p)))))

  [callcc]-[excluded-middle]-eqₗ : (∀{P : Stmt{ℓ}} → (P ∨ (¬ P))) → (∀{P Q : Stmt{ℓ}} → (((P → Q) → P) → P))
  [callcc]-[excluded-middle]-eqₗ or {P}{Q} (pqp) with or
  ... | ([∨]-introₗ p ) = p
  ... | ([∨]-introᵣ np) = pqp([⊥]-elim ∘ np)

  [callcc]-[excluded-middle]-eqᵣ : (∀{P : Stmt{ℓ}}{Q : Stmt{Lvl.𝟎}} → (((P → Q) → P) → P)) → (∀{P : Stmt{ℓ}} → (P ∨ (¬ P)))
  [callcc]-[excluded-middle]-eqᵣ (callcc) {P} = callcc{P ∨ (¬ P)}{⊥} (nor ↦ [⊥]-elim ([¬¬]-excluded-middle (nor)))

  -- TODO: Does not have to be over all propositions P in assumption. Only wem P and wem Q are used.
  weak-excluded-middle-[¬][∧]ₗ : (∀{P : Stmt{ℓ}} → (¬ P) ∨ (¬¬ P)) ↔ (∀{P : Stmt{ℓ}}{Q : Stmt{ℓ}} → ((¬ P) ∨ (¬ Q)) ← (¬ (P ∧ Q)))
  weak-excluded-middle-[¬][∧]ₗ = [↔]-intro l r where
    l : (∀{P : Stmt{ℓ}} → (¬ P) ∨ (¬¬ P)) ← (∀{P : Stmt{ℓ}}{Q : Stmt{ℓ}} → ((¬ P) ∨ (¬ Q)) ← (¬ (P ∧ Q)))
    l [¬][∧]ₗ = [¬][∧]ₗ non-contradiction

    r : (∀{P : Stmt{ℓ}} → (¬ P) ∨ (¬¬ P)) → (∀{P : Stmt{ℓ}}{Q : Stmt{ℓ}} → ((¬ P) ∨ (¬ Q)) ← (¬ (P ∧ Q)))
    r wem {P = P} {Q = Q} npq with wem {P = P} | wem {P = Q}
    r wem {P = P} {Q = Q} npq | [∨]-introₗ np  | [∨]-introₗ nq  = [∨]-introₗ np
    r wem {P = P} {Q = Q} npq | [∨]-introₗ np  | [∨]-introᵣ nnq = [∨]-introₗ np
    r wem {P = P} {Q = Q} npq | [∨]-introᵣ nnp | [∨]-introₗ nq  = [∨]-introᵣ nq
    r wem {P = P} {Q = Q} npq | [∨]-introᵣ nnp | [∨]-introᵣ nnq = [∨]-introᵣ (q ↦ nnp (p ↦ npq ([∧]-intro p q)))

------------------------------------------
-- XOR

module _ {ℓ₁}{ℓ₂} {P : Stmt{ℓ₁}}{Q : Stmt{ℓ₂}} where
  [⊕][↔]-contradiction : (P ⊕ Q) → (P ↔ Q) → ⊥
  [⊕][↔]-contradiction ([⊕]-introₗ p nq) pq = nq([↔]-elimᵣ p pq)
  [⊕][↔]-contradiction ([⊕]-introᵣ q np) pq = np([↔]-elimₗ q pq)

  [⊕][∧]-contradiction : (P ⊕ Q) → (P ∧ Q) → ⊥
  [⊕][∧]-contradiction xor = [⊕][↔]-contradiction xor ∘ [∧]-to-[↔]

  [⊕]-not-both : (P ⊕ Q) → P → Q → ⊥
  [⊕]-not-both = Tuple.curry ∘ [⊕][∧]-contradiction

  [⊕]-not-left : (P ⊕ Q) → P → (¬ Q)
  [⊕]-not-left = [⊕]-not-both

  [⊕]-not-right : (P ⊕ Q) → Q → (¬ P)
  [⊕]-not-right = swap ∘ [⊕]-not-both

  [⊕]-to-[∨] : (P ⊕ Q) → (P ∨ Q)
  [⊕]-to-[∨] ([⊕]-introₗ p _) = [∨]-introₗ p
  [⊕]-to-[∨] ([⊕]-introᵣ q _) = [∨]-introᵣ q

  [⊕]-to-[¬∨] : (P ⊕ Q) → ((¬ P) ∨ (¬ Q))
  [⊕]-to-[¬∨] ([⊕]-introₗ _ nq) = [∨]-introᵣ nq
  [⊕]-to-[¬∨] ([⊕]-introᵣ _ np) = [∨]-introₗ np

  [⊕]-excluded-middleₗ : (P ⊕ Q) → (P ∨ (¬ P))
  [⊕]-excluded-middleₗ ([⊕]-introₗ p nq) = [∨]-introₗ p
  [⊕]-excluded-middleₗ ([⊕]-introᵣ q np) = [∨]-introᵣ np

  [⊕]-excluded-middleᵣ : (P ⊕ Q) → (Q ∨ (¬ Q))
  [⊕]-excluded-middleᵣ ([⊕]-introₗ p nq) = [∨]-introᵣ nq
  [⊕]-excluded-middleᵣ ([⊕]-introᵣ q np) = [∨]-introₗ q

  [⊕]-or-not-both : (P ∨ Q) → ¬(P ∧ Q) → (P ⊕ Q)
  [⊕]-or-not-both or nand with or
  ... | [∨]-introₗ p = [⊕]-introₗ p (q ↦ nand([↔]-intro p q))
  ... | [∨]-introᵣ q = [⊕]-introᵣ q (p ↦ nand([↔]-intro p q))


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

module Examples.Sorting.Sequential where

open import Examples.Sorting.Sequential.Comparable

open import Calf costMonoid
open import Calf.Types.Nat
open import Calf.Types.List

open import Relation.Binary.PropositionalEquality as Eq using (_≡_)
open import Data.Product using (_,_)

test/forward  = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ 12 ∷ 13 ∷ 14 ∷ 15 ∷ 16 ∷ []
test/backward = 16 ∷ 15 ∷ 14 ∷ 13 ∷ 12 ∷ 11 ∷ 10 ∷ 9 ∷ 8 ∷ 7 ∷ 6 ∷ 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
test/shuffled = 4 ∷ 8 ∷ 12 ∷ 16 ∷ 13 ∷ 3 ∷ 5 ∷ 14 ∷ 9 ∷ 6 ∷ 7 ∷ 10 ∷ 11 ∷ 1 ∷ 2 ∷ 15 ∷ []

module Ex/InsertionSort where
  import Examples.Sorting.Sequential.InsertionSort NatComparable as Sort

  list' = list nat

  ex/insert : cmp (F list')
  ex/insert = Sort.insert 3 (1 ∷ 2 ∷ 4 ∷ [])

  ex/sort : cmp (F list')
  ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ [])

  ex/sort/forward : cmp (F list')
  ex/sort/forward = Sort.sort test/forward  -- cost: 15

  ex/sort/backward : cmp (F list')
  ex/sort/backward = Sort.sort test/backward  -- cost: 120

  ex/sort/shuffled : cmp (F list')
  ex/sort/shuffled = Sort.sort test/shuffled  -- cost: 76

module Ex/MergeSort where
  import Examples.Sorting.Sequential.MergeSort NatComparable as Sort

  list' = list nat

  ex/split : cmp (F Sort.pair)
  ex/split = Sort.split (6 ∷ 2 ∷ 8 ∷ 3 ∷ 1 ∷ 8 ∷ 5 ∷ [])

  ex/merge : cmp (F list')
  ex/merge = Sort.merge (2 ∷ 3 ∷ 6 ∷ 8 ∷ [] , 1 ∷ 5 ∷ 8 ∷ [])

  ex/sort : cmp (F list')
  ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ [])

  ex/sort/forward : cmp (F list')
  ex/sort/forward = Sort.sort test/forward  -- cost: 32

  ex/sort/backward : cmp (F list')
  ex/sort/backward = Sort.sort test/backward  -- cost: 32

  ex/sort/shuffled : cmp (F list')
  ex/sort/shuffled = Sort.sort test/shuffled  -- cost: 47

module SortEquivalence (M : Comparable) where
  open Comparable M
  open import Examples.Sorting.Sequential.Core M

  import Examples.Sorting.Sequential.InsertionSort M as ISort
  import Examples.Sorting.Sequential.MergeSort     M as MSort

  isort≡msort : ◯ (ISort.sort ≡ MSort.sort)
  isort≡msort = IsSort⇒≡ ISort.sort ISort.sort/correct MSort.sort MSort.sort/correct


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

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

module Decidable.Relations where

DecidableRelation : {a b : _} {A : Set a} (f : A → Set b) → Set (a ⊔ b)
DecidableRelation {A = A} f = (x : A) → (f x) || (f x → False)

orDecidable : {a b c : _} {A : Set a} {f : A → Set b} {g : A → Set c} → DecidableRelation f → DecidableRelation g → DecidableRelation (λ x → (f x) || (g x))
orDecidable fDec gDec x with fDec x
orDecidable fDec gDec x | inl fx = inl (inl fx)
orDecidable fDec gDec x | inr !fx with gDec x
orDecidable fDec gDec x | inr !fx | inl gx = inl (inr gx)
orDecidable {f = f} {g} fDec gDec x | inr !fx | inr !gx = inr t
  where
    t : (f x || g x) → False
    t (inl x) = !fx x
    t (inr x) = !gx x

andDecidable : {a b c : _} {A : Set a} {f : A → Set b} {g : A → Set c} → DecidableRelation f → DecidableRelation g → DecidableRelation (λ x → (f x) && (g x))
andDecidable fDec gDec x with fDec x
andDecidable fDec gDec x | inl fx with gDec x
andDecidable fDec gDec x | inl fx | inl gx = inl (fx ,, gx)
andDecidable fDec gDec x | inl fx | inr !gx = inr (λ x → !gx (_&&_.snd x))
andDecidable fDec gDec x | inr !fx = inr (λ x → !fx (_&&_.fst x))

notDecidable : {a b : _} {A : Set a} {f : A → Set b} → DecidableRelation f → DecidableRelation (λ x → (f x) → False)
notDecidable fDec x with fDec x
notDecidable fDec x | inl fx = inr (λ x → x fx)
notDecidable fDec x | inr !fx = inl !fx

doubleNegation : {a b : _} {A : Set a} {f : A → Set b} → DecidableRelation f → (x : A) → (((f x) → False) → False) → f x
doubleNegation fDec x with fDec x
doubleNegation fDec x | inl fx = λ _ → fx
doubleNegation fDec x | inr !fx = λ p → exFalso (p !fx)


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

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

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

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties

open GroupStr

ℤGroup : Group₀
fst ℤGroup = ℤ
1g (snd ℤGroup) = 0
_·_ (snd ℤGroup) = _+ℤ_
inv (snd ℤGroup) = -ℤ_
isGroup (snd ℤGroup) = isGroupℤ
  where
  abstract
    isGroupℤ : IsGroup (pos 0) (_+ℤ_) (-ℤ_)
    isGroupℤ = makeIsGroup isSetℤ
                           +Assoc (λ _ → refl) (+Comm 0)
                           -Cancel -Cancel'

ℤHom : (n : ℤ) → GroupHom ℤGroup ℤGroup
fst (ℤHom n) x = n ·ℤ x
snd (ℤHom n) =
  makeIsGroupHom λ x y → ·DistR+ n x y

negEquivℤ : GroupEquiv ℤGroup ℤGroup
fst negEquivℤ =
  isoToEquiv
    (iso (GroupStr.inv (snd ℤGroup))
         (GroupStr.inv (snd ℤGroup))
         (GroupTheory.invInv ℤGroup)
         (GroupTheory.invInv ℤGroup))
snd negEquivℤ =
  makeIsGroupHom -Dist+


-- Agda program using the Iowa Agda library

open import bool

module PROOF-odddoublecoin
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
  where

open import eq
open import nat
open import list
open import maybe

---------------------------------------------------------------------------
-- Translated Curry operations:

add : ℕ → ℕ → ℕ
add zero x = x
add (suc y) z = suc (add y z)

-- Forward declaration:
odd : ℕ → 𝔹

even : ℕ → 𝔹
even zero = tt
even (suc x) = odd x

coin : Choice → ℕ → ℕ
coin c1 x = if choose c1 then x else suc x

double : ℕ → ℕ
double x = add x x

odd zero = ff
odd (suc x) = even x

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

add-suc : ∀ (x y : ℕ) → add x (suc y) ≡ suc (add x y)
add-suc zero y = refl
add-suc (suc x) y rewrite add-suc x y = refl

-- auxiliary property for x+x instead of double:
odd-add-x-x : ∀ (x : ℕ) → odd (add x x) ≡ ff
odd-add-x-x zero = refl
odd-add-x-x (suc x) rewrite add-suc x x | odd-add-x-x x = refl

odddoublecoin : (c1 : Choice) → (x : ℕ) → (odd (double (coin c1 x))) ≡ ff
odddoublecoin c1 x rewrite odd-add-x-x (coin c1 x) = refl

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


{- Example by Andrew Pitts, 2016-05-23 -}

{-# OPTIONS --rewriting --cubical-compatible #-}

open import Agda.Builtin.Equality public

infix 6 I─_
postulate
  𝕀     : Set
  O     : 𝕀
  I     : 𝕀
  I─_   : 𝕀 → 𝕀

{-# BUILTIN REWRITE _≡_ #-}

postulate
  I─O≡I   :           I─ O     ≡ I

{-# REWRITE I─O≡I   #-}

data Pth (A : Set) : A → A → Set where
  path : (f : 𝕀 → A) → Pth A (f O) (f I)

infix 6 _at_
_at_ : {A : Set}{x y : A} → Pth A x y → 𝕀 → A
path f at i = f i

record Path (A : Set)(x y : A) : Set where
  field
    pth : Pth A x y
    feq : pth at O ≡ x
    seq : pth at I ≡ y

open Path public

{-# REWRITE feq #-}
{-# REWRITE seq #-}

infix 6 _′_
_′_ : {A : Set}{x y : A} → Path A x y → 𝕀 → A
p ′ i = pth p at i

fun2path : {A : Set}(f : 𝕀 → A) → Path A (f O) (f I)
pth (fun2path f) = path f
feq (fun2path f) = refl
seq (fun2path f) = refl

inv : {A : Set}{x y : A} → Path A x y → Path A y x
inv p = fun2path (λ i → p ′ (I─ i))


-- Properties of Fibonacci nunmbers

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

module Math.NumberTheory.Fibonacci.Nat.Properties where

-- agda-stdlib
open import Data.Unit using (tt)
open import Data.Sum
open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Function.Base

-- agda-misc
open import Math.NumberTheory.Fibonacci.Nat
open import Math.NumberTheory.Summation.Nat

open ≤-Reasoning

1≤fib[1+n] : ∀ n → 1 ≤ fib (suc n)
1≤fib[1+n] zero    = ≤-refl
1≤fib[1+n] (suc n) = begin
  1                   ≤⟨ 1≤fib[1+n] n ⟩
  fib (suc n)         ≤⟨ m≤m+n (fib (suc n)) (fib n) ⟩
  fib (suc n) + fib n ≡⟨ fib[1+n]+fib[n]≡fib[2+n] n ⟩
  fib (suc (suc n))   ∎

fib[n]<fib[1+n] : ∀ n {_ : True (2 ≤? n)} → fib n < fib (suc n)
fib[n]<fib[1+n] (suc (suc zero))    {wit} = s≤s (s≤s z≤n)
fib[n]<fib[1+n] (suc (suc (suc n))) {wit} = begin-strict
  fib (3 + n)               <⟨ ≤-refl ⟩
  1 + fib (3 + n)           ≡⟨ +-comm 1 (fib (3 + n)) ⟩
  fib (3 + n) + 1           ≤⟨ +-monoʳ-≤ (fib (3 + n)) (1≤fib[1+n] (suc n)) ⟩
  fib (3 + n) + fib (2 + n) ≡⟨ fib[1+n]+fib[n]≡fib[2+n] (2 + n) ⟩
  fib (4 + n)               ∎

private
  fib-mono-<-lemma : ∀ m n {_ : True (2 ≤? n)} → fib n < fib (suc m + n)
  fib-mono-<-lemma zero    n               {wit} = fib[n]<fib[1+n] n {wit}
  fib-mono-<-lemma (suc m) n@(suc (suc _)) {wit} = begin-strict
    fib n                           <⟨ fib-mono-<-lemma m n {tt} ⟩
    fib (1 + (m + n))               ≤⟨ m≤m+n (fib (1 + (m + n))) (fib (m + n)) ⟩
    fib (1 + (m + n)) + fib (m + n) ≡⟨ fib[1+n]+fib[n]≡fib[2+n] (m + n) ⟩
    fib (2 + (m + n))               ∎

fib-mono-< : ∀ m n {_ : True (2 ≤? m)} → m < n → fib m < fib n
fib-mono-< m n {wit} m<n = begin-strict
  fib m           <⟨ fib-mono-<-lemma o m {wit} ⟩
  fib (1 + o + m) ≡⟨ cong fib (sym $ n≡1+o+m) ⟩
  fib n           ∎
  where
  o = n ∸ suc m
  n≡1+o+m : n ≡ 1 + o + m
  n≡1+o+m = trans (sym $ m+[n∸m]≡n m<n) (cong suc (+-comm m o))

private
  ≤⇒≡∨< : ∀ {m n} → m ≤ n → (m ≡ n) ⊎ (m < n)
  ≤⇒≡∨< {m} {n} m≤n with m ≟ n
  ... | yes m≡n = inj₁ m≡n
  ... | no  m≢n = inj₂ (≤∧≢⇒< m≤n m≢n)

fib-mono-≤ : ∀ m n → m ≤ n → fib m ≤ fib n
fib-mono-≤ zero            n       m≤n = z≤n
fib-mono-≤ (suc zero)      (suc n) m≤n = 1≤fib[1+n] n
fib-mono-≤ m@(suc (suc _)) n       m≤n with ≤⇒≡∨< m≤n
... | inj₁ m≡n = ≤-reflexive (cong fib m≡n)
... | inj₂ m<n = <⇒≤ $ fib-mono-< m n {tt} m<n

sum-of-fib : ∀ n → Σ[ k ≤ n ] fib k ≡ fib (2 + n) ∸ 1
sum-of-fib zero    = refl
sum-of-fib (suc n) = begin-equality
  Σ[ k ≤ n ] fib k + fib (suc n)
    ≡⟨ cong (_+ fib (suc n)) $ sum-of-fib n ⟩
  (fib (2 + n) ∸ 1) + fib (1 + n)
    ≡⟨ +-comm (fib (2 + n) ∸ 1) (fib (1 + n)) ⟩
  fib (1 + n) + (fib (2 + n) ∸ 1)
    ≡⟨ sym $ +-∸-assoc (fib (1 + n)) (1≤fib[1+n] (suc n)) ⟩
  (fib (1 + n) + fib (2 + n)) ∸ 1
    ≡⟨ cong (_∸ 1) $ fib[n]+fib[1+n]≡fib[2+n] (suc n) ⟩
  fib (3 + n) ∸ 1
    ∎


{-# OPTIONS --universe-polymorphism #-}
module Categories.Functor.Properties where

open import Relation.Binary using (_Preserves_⟶_)

open import Categories.Category
open import Categories.Functor
import Categories.Morphisms as Morphisms

module FunctorsAlways {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F : Functor C D) where
  open Functor F
  module C = Category C
  module D = Category D

  resp-Iso : ∀ {A B} {f : C [ A , B ]} {g : C [ B , A ]}
           → Morphisms.Iso C f g → Morphisms.Iso D (F₁ f) (F₁ g)
  resp-Iso {f = f} {g} I = record
    { isoˡ = begin
               D [ F₁ g ∘ F₁ f ]
             ↑⟨ homomorphism ⟩
               F₁ (C [ g ∘ f ])
             ↓⟨ F-resp-≡ I.isoˡ ⟩
               F₁ (C.id)
             ↓⟨ identity ⟩
               D.id
             ∎
    ; isoʳ = begin
               D [ F₁ f ∘ F₁ g ]
             ↑⟨ homomorphism ⟩
               F₁ (C [ f ∘ g ])
             ↓⟨ F-resp-≡ I.isoʳ ⟩
               F₁ (C.id)
             ↓⟨ identity ⟩
               D.id
             ∎
    }
    where
    module I = Morphisms.Iso I
    open D.HomReasoning

  resp-≅ : F₀ Preserves Morphisms._≅_ C ⟶ Morphisms._≅_ D
  resp-≅ I = record
    { f = F₁ I.f
    ; g = F₁ I.g
    ; iso = resp-Iso I.iso
    }
    where
    module I = Morphisms._≅_ I


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

open import Categories.Category.Core using (Category)

module Categories.Diagram.Pushout {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning
open Equiv

open import Categories.Morphism.Reasoning C as Square
  renaming (glue to glue-square) hiding (id-unique)

open import Level

private
  variable
    A B E X Y Z : Obj
    f g h j : A ⇒ B

record Pushout (f : X ⇒ Y) (g : X ⇒ Z) : Set (o ⊔ ℓ ⊔ e) where
  field
    {Q} : Obj
    i₁  : Y ⇒ Q
    i₂  : Z ⇒ Q

  field
    commute   : i₁ ∘ f ≈ i₂ ∘ g
    universal : {h₁ : Y ⇒ B} {h₂ : Z ⇒ B} → h₁ ∘ f ≈ h₂ ∘ g → Q ⇒ B
    unique    : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {j : Q ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                  j ∘ i₁ ≈ h₁ → j ∘ i₂ ≈ h₂ →
                  j ≈ universal eq

    universal∘i₁≈h₁  : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₁ ≈ h₁
    universal∘i₂≈h₂  : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₂ ≈ h₂

  unique-diagram : h ∘ i₁ ≈ j ∘ i₁ →
                   h ∘ i₂ ≈ j ∘ i₂ →
                   h ≈ j
  unique-diagram {h = h} {j = j} eq₁ eq₂ = begin
    h            ≈⟨ unique eq₁ eq₂ ⟩
    universal eq ≈˘⟨ unique refl refl ⟩
    j            ∎
    where eq = extendˡ commute


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

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

module Categories.Definition where

record Category {a b : _} : Set (lsuc (a ⊔ b)) where
  field
    objects : Set a
    arrows : objects → objects → Set b
    id : (x : objects) → arrows x x
    _∘_ : {x y z : objects} → arrows y z → arrows x y → arrows x z
    rightId : {x y : objects} → (f : arrows x y) → (id y) ∘ f ≡ f
    leftId : {x y : objects} → (f : arrows x y) → f ∘ (id x) ≡ f
    compositionAssociative : {x y z w : objects} → (f : arrows z w) → (g : arrows y z) → (h : arrows x y) → (f ∘ (g ∘ h)) ≡ (f ∘ g) ∘ h


open import Oscar.Prelude
open import Oscar.Data.¶

module Oscar.Data.Descender where

-- m ≤ n, counting down from n-1 to m
data Descender⟨_⟩ {a} (A : ¶ → Ø a) (m : ¶) : ¶ → Ø a where
  ∅ : Descender⟨ A ⟩ m m
  _,_ : ∀ {n} → A n → Descender⟨ A ⟩ m n → Descender⟨ A ⟩ m (↑ n)

Vec'⟨_⟩ = λ {a} (A : Ø a) N → Descender⟨ (λ _ → A) ⟩ 0 N
⟨_⟩¶⟨_≤_↓⟩ = Descender⟨_⟩
AList⟨_⟩ = ⟨_⟩¶⟨_≤_↓⟩


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

module Cubical.Categories.Commutativity where

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Category

private
  variable
    ℓ ℓ' : Level

module _ {C : Precategory ℓ ℓ'} where
  open Precategory C

  compSq : ∀ {x y z w u v} {f : C [ x , y ]} {g h} {k : C [ z , w ]} {l} {m} {n : C [ u , v ]}
       -- square 1
       → f ⋆ g ≡ h ⋆ k
       -- square 2 (sharing g)
       → k ⋆ l ≡ m ⋆ n
       → f ⋆ (g ⋆ l) ≡ (h ⋆ m) ⋆ n
  compSq {f = f} {g} {h} {k} {l} {m} {n} p q
    = f ⋆ (g ⋆ l)
    ≡⟨ sym (⋆Assoc _ _ _) ⟩
      (f ⋆ g) ⋆ l
    ≡⟨ cong (_⋆ l) p ⟩
      (h ⋆ k) ⋆ l
    ≡⟨ ⋆Assoc _ _ _ ⟩
      h ⋆ (k ⋆ l)
    ≡⟨ cong (h ⋆_) q ⟩
      h ⋆ (m ⋆ n)
    ≡⟨ sym (⋆Assoc _ _ _) ⟩
      (h ⋆ m) ⋆ n
    ∎


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

open import Level
open import Function.Base using (flip)

open import Relation.Binary using (Rel; IsEquivalence; Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidR

-- Basic definition of a |Category| with a Hom setoid.
-- Also comes with some reasoning combinators (see HomReasoning)
record Category (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  eta-equality
  infix  4 _≈_ _⇒_
  infixr 9 _∘_

  field
    Obj : Set o
    _⇒_ : Rel Obj ℓ
    _≈_ : ∀ {A B} → Rel (A ⇒ B) e

    id  : ∀ {A} → (A ⇒ A)
    _∘_ : ∀ {A B C} → (B ⇒ C) → (A ⇒ B) → (A ⇒ C)

  field
    assoc     : ∀ {A B C D} {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} → (h ∘ g) ∘ f ≈ h ∘ (g ∘ f)
    -- We add a symmetric proof of associativity so that the opposite category of the
    -- opposite category is definitionally equal to the original category. See how
    -- `op` is implemented.
    sym-assoc : ∀ {A B C D} {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} → h ∘ (g ∘ f) ≈ (h ∘ g) ∘ f
    identityˡ : ∀ {A B} {f : A ⇒ B} → id ∘ f ≈ f
    identityʳ : ∀ {A B} {f : A ⇒ B} → f ∘ id ≈ f
    -- We add a proof of "neutral" identity proof, in order to ensure the opposite of
    -- constant functor is definitionally equal to itself.
    identity² : ∀ {A} → id ∘ id {A} ≈ id {A}
    equiv     : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
    ∘-resp-≈  : ∀ {A B C} {f h : B ⇒ C} {g i : A ⇒ B} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i

  module Equiv {A B : Obj} = IsEquivalence (equiv {A} {B})

  open Equiv

  ∘-resp-≈ˡ : ∀ {A B C} {f h : B ⇒ C} {g : A ⇒ B} → f ≈ h → f ∘ g ≈ h ∘ g
  ∘-resp-≈ˡ pf = ∘-resp-≈ pf refl

  ∘-resp-≈ʳ : ∀ {A B C} {f h : A ⇒ B} {g : B ⇒ C} → f ≈ h → g ∘ f ≈ g ∘ h
  ∘-resp-≈ʳ pf = ∘-resp-≈ refl pf

  hom-setoid : ∀ {A B} → Setoid _ _
  hom-setoid {A} {B} = record
    { Carrier       = A ⇒ B
    ; _≈_           = _≈_
    ; isEquivalence = equiv
    }

  -- When a category is quatified, it is convenient to refer to the levels from a module,
  -- so we do not have to explicitly quantify over a category when universe levels do not
  -- play a big part in a proof (which is the case probably all the time).
  o-level : Level
  o-level = o

  ℓ-level : Level
  ℓ-level = ℓ

  e-level : Level
  e-level = e

  -- Reasoning combinators.  _≈⟨_⟩_ and _≈˘⟨_⟩_ from SetoidR.
  -- Also some useful combinators for doing reasoning on _∘_ chains
  module HomReasoning {A B : Obj} where
    open SetoidR (hom-setoid {A} {B}) public
    -- open Equiv {A = A} {B = B} public

    infixr 4 _⟩∘⟨_ refl⟩∘⟨_
    infixl 5 _⟩∘⟨refl
    _⟩∘⟨_ : ∀ {M} {f h : M ⇒ B} {g i : A ⇒ M} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i
    _⟩∘⟨_ = ∘-resp-≈

    refl⟩∘⟨_ : ∀ {M} {f : M ⇒ B} {g i : A ⇒ M} → g ≈ i → f ∘ g ≈ f ∘ i
    refl⟩∘⟨_ = Equiv.refl ⟩∘⟨_

    _⟩∘⟨refl : ∀ {M} {f h : M ⇒ B} {g : A ⇒ M} → f ≈ h → f ∘ g ≈ h ∘ g
    _⟩∘⟨refl = _⟩∘⟨ Equiv.refl

    -- convenient inline versions
    infix 2 ⟺
    infixr 3 _○_
    ⟺ : {f g : A ⇒ B} → f ≈ g → g ≈ f
    ⟺ = Equiv.sym
    _○_ : {f g h : A ⇒ B} → f ≈ g → g ≈ h → f ≈ h
    _○_ = Equiv.trans

  op : Category o ℓ e
  op = record
    { Obj       = Obj
    ; _⇒_       = flip _⇒_
    ; _≈_       = _≈_
    ; _∘_       = flip _∘_
    ; id        = id
    ; assoc     = sym-assoc
    ; sym-assoc = assoc
    ; identityˡ = identityʳ
    ; identityʳ = identityˡ
    ; identity² = identity²
    ; equiv     = equiv
    ; ∘-resp-≈  = flip ∘-resp-≈
    }


module RecordUpdateSyntax where

open import Common.Prelude
open import Common.Equality

data Param : Nat → Set where
  param : ∀ n → Param (suc n)

record R : Set where
  field
    {i} : Nat
    p : Param i
    s : Nat

old : R
old = record { p = param 0; s = 1 }

-- Simple update, it should be able to infer the type and the implicit.
new : _
new = record old { p = param 1 }

new′ : R
new′ = record { i = 2; p = param 1; s = 1 }

-- Here's a needlessly complex update.
upd-p-s : _ → _ → _ → R
upd-p-s zero s r = record r { p = param zero; s = s }
upd-p-s (suc n) s r = record (upd-p-s n 0 r) { p = param n; s = s }

eq₁ : new ≡ new′
eq₁ = refl

eq₂ : upd-p-s zero 1 (record new { s = 0 }) ≡ old
eq₂ = refl

-- Check that instance arguments are handled properly
postulate
  T : Nat → Set
  instance
    t0 : T 0
    t1 : T 1

record Instance : Set where
  field
    n : Nat
    {{t}} : T n

r0 : Instance
r0 = record { n = 0 }

r1 : Instance
r1 = record r0 { n = 1 }

check : Instance.t r1 ≡ t1
check = refl


{-# OPTIONS --cumulativity #-}

open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

module _ where

variable
  ℓ ℓ′ ℓ₁ ℓ₂ : Level
  A B C : Set ℓ
  k l m n : Nat

lone ltwo lthree : Level
lone = lsuc lzero
ltwo = lsuc lone
lthree = lsuc ltwo

set0 : Set₂
set0 = Set₀

set1 : Set₂
set1 = Set₁

lift : Set ℓ → Set (ℓ ⊔ ℓ′)
lift x = x

data List (A : Set ℓ) : Set ℓ where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

List-test₁ : (A : Set) → List {lone} A
List-test₁ A = []

lower-List : ∀ ℓ′ {A : Set ℓ} → List {ℓ ⊔ ℓ′} A → List A
lower-List ℓ [] = []
lower-List ℓ (x ∷ xs) = x ∷ lower-List ℓ xs

lower-List-test₁ : {A : Set} → List {lthree} A → List {lone} A
lower-List-test₁ = lower-List lthree

map : (f : A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs

map00 : {A B : Set} (f : A → B) → List A → List B
map00 = map

map01 : {A : Set} {B : Set₁} (f : A → B) → List A → List B
map01 = map

map10 : {A : Set₁} {B : Set} (f : A → B) → List A → List B
map10 = map

map20 : {A : Set₂} {B : Set} (f : A → B) → List A → List B
map20 = map

data Vec (A : Set ℓ) : Nat → Set ℓ where
  [] : Vec A 0
  _∷_ : A → Vec A n → Vec A (suc n)

module Without-Cumulativity where

  N-ary-level : Level → Level → Nat → Level
  N-ary-level ℓ₁ ℓ₂ zero    = ℓ₂
  N-ary-level ℓ₁ ℓ₂ (suc n) = ℓ₁ ⊔ N-ary-level ℓ₁ ℓ₂ n

  N-ary : ∀ n → Set ℓ₁ → Set ℓ₂ → Set (N-ary-level ℓ₁ ℓ₂ n)
  N-ary zero    A B = B
  N-ary (suc n) A B = A → N-ary n A B

module With-Cumulativity where

  N-ary : Nat → Set ℓ₁ → Set ℓ₂ → Set (ℓ₁ ⊔ ℓ₂)
  N-ary zero    A B = B
  N-ary (suc n) A B = A → N-ary n A B

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

  _$ⁿ_ : N-ary n A B → (Vec A n → B)
  f $ⁿ []       = f
  f $ⁿ (x ∷ xs) = f x $ⁿ xs

  ∀ⁿ : ∀ {A : Set ℓ} n → N-ary n A (Set ℓ′) → Set (ℓ ⊔ ℓ′)
  ∀ⁿ zero    P = P
  ∀ⁿ (suc n) P = ∀ x → ∀ⁿ n (P x)


module hello-world-dep-lookup where

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

variable
  A : Set
  n : ℕ

lookup : Vec A n → Fin n → A
lookup (a ∷ as) zero = a
lookup (a ∷ as) (suc i) = lookup as i


module trichotomy where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc)

open import Relations using (_<_; z<s; s<s)

-- 三分法
data Trichotomy (m n : ℕ) : Set where
  m<n : m < n → Trichotomy m n
  m≡n : m ≡ n → Trichotomy m n
  n<m : n < m → Trichotomy m n

trichotomy : ∀ (m n : ℕ) → Trichotomy m n
trichotomy zero    zero                        = m≡n refl
trichotomy (suc m) zero                        = n<m z<s
trichotomy zero    (suc n)                     = m<n z<s
trichotomy (suc m) (suc n) with trichotomy m n
...                           | m<n m′<n′      = m<n (s<s m′<n′)
...                           | m≡n refl       = m≡n refl
...                           | n<m n′<m′      = n<m (s<s n′<m′)


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

open import LogicalFormulae
open import Setoids.Setoids
open import Functions.Definition
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.IntegralDomains.Definition

module Rings.Associates.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (intDom : IntegralDomain R) where

open import Rings.Units.Definition R
open Setoid S
open Ring R
open Equivalence eq

Associates : Rel A
Associates x y = Sg A (λ z → Unit z && (x ∼ (y * z)))


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

open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Setoids.Subset
open import Setoids.Setoids
open import Setoids.Orders.Partial.Definition
open import Fields.Fields
open import Rings.Orders.Total.Definition
open import Rings.Orders.Total.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Definition

module Fields.Orders.LeastUpperBounds.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {c : _} {_<_ : Rel {_} {c} A} (pOrder : SetoidPartialOrder S _<_) where

UpperBound : {d : _} {pred : A → Set d} (sub : subset S pred) (x : A) → Set _
UpperBound {pred = pred} sub x = (y : A) → pred y → (y < x) || (Setoid._∼_ S y x)

record LeastUpperBound {d : _} {pred : A → Set d} (sub : subset S pred) (x : A) : Set (a ⊔ b ⊔ c ⊔ d) where
  field
    upperBound : UpperBound sub x
    leastUpperBound : (y : A) → UpperBound sub y → (x < y) || (Setoid._∼_ S x y)


{-# OPTIONS --cubical #-}

module Type.Cubical.Path where

open import Type
open import Type.Cubical

postulate PathP : ∀{ℓ}(P : Interval → Type{ℓ}) → P(Interval.𝟎) → P(Interval.𝟏) → Type{ℓ}
{-# BUILTIN PATHP PathP #-}

-- The type of paths.
-- Can be seen as a path between two points in the space P.
-- (A continuous function from the closed unit interval to the space).
Path : ∀{ℓ}{P : Type{ℓ}} → P → P → Type{ℓ}
Path {P = P} = PathP(\i → P)
{-# BUILTIN PATH Path #-}


module Either where

  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


module Cats.Category.Constructions.Terminal where

open import Data.Product using (proj₁ ; proj₂)
open import Level

open import Cats.Category.Base

import Cats.Category.Constructions.Iso as Iso
import Cats.Category.Constructions.Unique as Unique

module Build {lo la l≈} (Cat : Category lo la l≈) where

  open Category Cat
  open Iso.Build Cat
  open Unique.Build Cat

  IsTerminal : Obj → Set (lo ⊔ la ⊔ l≈)
  IsTerminal One = ∀ X → ∃! X One

  terminal→id-unique : ∀ {A} → IsTerminal A → IsUnique (id {A})
  terminal→id-unique {A} term id′ with term A
  ... | ∃!-intro id″ _ id″-uniq = ≈.trans (≈.sym (id″-uniq _)) (id″-uniq _)

  terminal-unique : ∀ {A B} → IsTerminal A → IsTerminal B → A ≅ B
  terminal-unique {A} {B} A-term B-term = record
      { forth = ∃!′.arr (B-term A)
      ; back = ∃!′.arr (A-term B)
      ; back-forth = ≈.sym (terminal→id-unique A-term _)
      ; forth-back = ≈.sym (terminal→id-unique B-term _)
      }

  X⇒Terminal-unique : ∀ {One} → IsTerminal One → ∀ {X} {f g : X ⇒ One} → f ≈ g
  X⇒Terminal-unique term {X} {f} {g} with term X
  ... | ∃!-intro x _ x-uniq = ≈.trans (≈.sym (x-uniq _)) (x-uniq _)

record HasTerminal {lo la l≈} (Cat : Category lo la l≈)
  : Set (lo ⊔ la ⊔ l≈) where
  open Category Cat
  open Build Cat

  field
    One : Obj
    isTerminal : IsTerminal One


module Oscar.Class.Monoid where

open import Oscar.Data.Equality
open import Oscar.Level

record Monoid {a} {A : Set a} {b} (_↠_ : A → A → Set b) : Set (a ⊔ b) where
  field
    ε : ∀ {m} → m ↠ m
    _◇_ : ∀ {l m n} → m ↠ n → l ↠ m → l ↠ n
    ◇-left-identity : ∀ {m n} → (f : m ↠ n) → ε ◇ f ≡ f
    ◇-right-identity : ∀ {m n} → (f : m ↠ n) → f ◇ ε ≡ f
    ◇-associativity : ∀ {k l m n} (f : k ↠ l) (g : l ↠ m) (h : m ↠ n) → h ◇ (g ◇ f) ≡ (h ◇ g) ◇ f

open Monoid ⦃ … ⦄ public


open import Type

module Graph.Properties where

open import Functional
open import Function.Equals
open import Lang.Instance
open import Logic
open import Logic.Propositional
import      Lvl
open import Graph
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Setoid.Uniqueness
open import Structure.Relator.Properties
open import Type.Properties.MereProposition

module _ {ℓ₁ ℓ₂} {V : Type{ℓ₁}} (_⟶_ : Graph{ℓ₁}{ℓ₂}(V)) where
  -- An undirected graph always have for every edge an edge in the other direction which is the same edge.
  record Undirected : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field
      ⦃ reversable ⦄ : Symmetry(_⟶_)
    reverse = symmetry(_⟶_)

    field
      reverse-involution : ∀{a b} → (reverse ∘ reverse ⊜ (id {T = a ⟶ b}))
  undirected-reverse = inst-fn Undirected.reverse

  -- Construction of an undirected graph from any graph.
  undirect : Graph{ℓ₁}{ℓ₂}(V)
  undirect a b = (b ⟶ a) ∨ (a ⟶ b)

  -- A graph is singular when there is at most one edge between every pair of vertices.
  -- In other words, when it is not a multigraph.
  -- Note: Equality on edges must respect uniqueness. In other words, one edge must not have multiple constructions.
  record Singular : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{a b : V} → MereProposition(a ⟶ b)
  singular = inst-fn(\inst {a}{b}{x}{y} → MereProposition.uniqueness(Singular.proof inst {a}{b}) {x}{y})

  -- A complete graph have an edge for each pair of vertices from V. Loops are allowed.
  record Complete : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{x y : V} → (x ⟶ y) ↔ (x ≢ y)
  complete = inst-fn Complete.proof

  record CompleteWithLoops : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{x y : V} → (x ⟶ y)
  completeWithLoops = inst-fn CompleteWithLoops.proof

  -- A linear graph contains vertices with a maximum of one outgoing edge and a maximum of one ingoing edge.
  record Linear : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field
      unique-start-vertex : ∀{y} → Unique(x ↦ (x ⟶ y))
      unique-end-vertex   : ∀{x} → Unique(y ↦ (x ⟶ y))

  module _ (v : V) where
    -- An initial vertex have no ingoing edges pointing towards it.
    record InitialVertex : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : ∀{x} → ¬(x ⟶ v)
    initialVertex = inst-fn InitialVertex.proof

    -- A final vertex have no outgoing edges pointing from it.
    record FinalVertex : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : ∀{x} → ¬(v ⟶ x)
    finalVertex = inst-fn FinalVertex.proof

  -- A graph is a list when it is linear and has an unique initial vertex and an unique final vertex.
  -- The linearity guarantees so that if there are preceding and succeding elements of the list, they are unique.
  -- The initial vertex represents the first element of the list.
  -- The final vertex represents the last element of the list.
  record IsList : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field
      ⦃ linear ⦄ : Linear
      unique-initial-vertex : Unique(InitialVertex)
      unique-final-vertex   : Unique(FinalVertex)

  -- A graph is a cycle when it is linear and do not have initial or final vertices.
  -- The linearity guarantees so that if there are preceding and succeding elements of the list, they are unique.
  -- The non-existence of initial vertices and final vertices means no first and last elements.
  record IsCycle : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field
      ⦃ linear ⦄ : Linear
      no-initial-vertex : ∀{v} → ¬(InitialVertex v)
      no-final-vertex   : ∀{v} → ¬(FinalVertex v)

  module _ where
    open import Graph.Walk
    open import Graph.Walk.Properties

    -- A graph is a tree when it has an unique path between every pair of vertices.
    -- The existence of a path means that it is always possible to traverse the tree from every vertex along the edges to every vertex.
    record IsTree : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : ∀{x y : V} → ∃!{Obj = Walk(_⟶_) x y}(Path)
    isTree = inst-fn IsTree.proof

    record IsForest : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : ∀{x y : V} → Unique{Obj = Walk(_⟶_) x y}(Path)
    isForest = inst-fn IsForest.proof

    record IsOutwardRootedTree : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        ⦃ tree ⦄ : IsTree
        unique-initial-vertex : ∃!(InitialVertex)
        -- TODO: Should not this be defined as ∃!(root ↦ InitialVertex(root) ∧ (∀{x : V} → ∃!{T = Walk(_⟶_) root x}(Path))) ?

    record IsInwardRootedTree : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field
        ⦃ tree ⦄ : IsTree
        unique-initial-vertex : ∃!(FinalVertex)

module _ {ℓ₁ ℓ₂} {V : Type{ℓ₁}} (_⟶_ : Graph{ℓ₁}{ℓ₂}(V)) where
  open import Graph.Walk

  -- A connected graph have walks from every vertex to any vertex.
  -- For undirected graphs, this can be visually interpreted as disconnected islands of vertices.
  -- Note: Equality on edges must respect uniqueness. In other words, one edge must not have multiple constructions.
  Connected = CompleteWithLoops(Walk(_⟶_))
  connected = completeWithLoops(Walk(_⟶_))


import      Lvl

module Structure.Category {ℓₒ ℓₘ ℓₑ : Lvl.Level} where

open import Functional using (swap)
open import Logic
open import Logic.Propositional
import      Structure.Categorical.Names as Names
open import Structure.Categorical.Properties
open import Structure.Semicategory{ℓₒ}{ℓₘ}{ℓₑ}
open import Structure.Operator
import      Structure.Relator.Names as Names
open import Structure.Relator.Properties
open import Structure.Setoid
open import Type

-- Obj is the collection of objects.
-- _⟶_ is the collection of morphisms.
module _
  {Obj : Type{ℓₒ}}
  (_⟶_ : Obj → Obj → Type{ℓₘ})
  ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(x ⟶ y) ⦄
  where

  -- A category is a structure on a relation called a morphism.
  --
  -- It can be seen as a generalization of the structure in functions between a collection of types/sets.
  -- More specifically, the algebraic properties of functions regarding composition and the identity function.
  -- In this case, sets are objects and functions are morphisms.
  -- See `Type.Category`.
  --
  -- It can also be seen as a generalized algebraic structure, or more specifically a generalization of monoids.
  -- The type of a monoid's operator is usually restricted to a single type, but a category allows it to vary (depending on the rules of morphism instead).
  -- (One can loosely call a category to be a monoid without the "closed" property of algebraic structures).
  -- In this case, the binary operation is (_∘_) and the laws are the usual identity and associative laws.
  -- See `Structure.Category.Monoid`.
  --
  -- A category can also be constructed by letting objects be the models of algebraic structures, and morphisms the homomorphisms of the respective algebraic structure.
  --
  -- In the case of categories being the objects in a category, functors are homomorphisms, and therefore also the morphisms.
  -- See `Structure.Category.Category`.
  --
  -- An alternative interpretation of the definition:
  -- A type (Obj) and a binary relation (Morphism) on this type is a category when:
  -- • The relator is transitive.
  -- • The relator is reflexive.
  -- • The reflexivity proof inside the transitivity proof does not result in a new proof.
  -- • Chains of the transitivity proofs can be applied in any order and the resulting proof will be the same.
  -- See `Relator.Equals.Category` for an example of this kind of binary relation.
  --
  -- A more concrete interpretation of the binary relation one is that a category describes a graph.
  -- Vertices are objects and morphisms are paths between the vertices.
  -- The operator joins two paths into one, and the identity is a loop (the empty path).
  -- See `Graph.Category`.
  --
  -- A category is the common pattern seen in all the examples above.
  record Category : Stmt{ℓₒ Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
    field
      -- Existence of morphisms constructed by connecting two morphisms (The composition of two morphisms).
      -- Existence of a binary operator on morphisms connecting the ends of two morphisms.
      -- Also a proof of transitivity for the binary relator (_⟶_).
      -- Note that this is the operator like the operators in other algebraic structures with binary operators
      -- ∀{x y z : Obj} → (y ⟶ z) → (x ⟶ y) → (x ⟶ z)
      _∘_ : Names.SwappedTransitivity(_⟶_)

      -- Existence of a morphism connected to itself (The identity morphism).
      -- Also a proof of reflexivity for the binary relator (_⟶_).
      -- ∀{x : Obj} → (x ⟶ x)
      id  : Names.Reflexivity(_⟶_)
    infixr 20 _∘_

    field
      -- The binary operator respects the equivalence relation.
      ⦃ binaryOperator ⦄ : ∀{x y z} → BinaryOperator(_∘_ {x}{y}{z})

      -- The binary operator on mophisms is associative.
      -- Or, the order of applying two transitivies on three proofs does not matter. It is the same proof.
      -- ∀{x y z w : Obj}{f : y ⟶ x}{g : z ⟶ y}{h : w ⟶ z} → ((f ∘ g) ∘ h ≡ f ∘ (g ∘ h))
      ⦃ associativity ⦄ : Morphism.Associativity(\{x} → _∘_ {x})

      -- The morphism `id` behaves like aa identity element with respect to the binary operator.
      -- Or, applying the proof of reflexivity on transitivity is an identity function for proofs.
      ⦃ identity ⦄ : Morphism.Identity(_∘_)(\{x} → id{x})

    instance
      identityₗ : Morphism.Identityₗ(_∘_)(\{x} → id{x})
      identityₗ = [∧]-elimₗ identity

    instance
      identityᵣ : Morphism.Identityᵣ(_∘_)(\{x} → id{x})
      identityᵣ = [∧]-elimᵣ identity

    -- As stated in `id`, this can be interpreted as proof of reflexivity when `Morphism` is interpreted as a binary relation.
    morphism-reflexivity : Reflexivity(_⟶_)
    morphism-reflexivity = intro id

    semicategory : Semicategory(_⟶_)
    Semicategory._∘_ semicategory = _∘_
    Semicategory.binaryOperator semicategory = binaryOperator
    Semicategory.associativity semicategory = associativity

    open Semicategory(semicategory) hiding (_∘_ ; binaryOperator ; associativity) public

-- A category object can be used when one refers to a category as an object.
-- Examples of usage are in functors (morphism between categories) or in equivalences of categories.
record CategoryObject : Stmt{Lvl.𝐒(ℓₒ Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ)} where
  constructor intro
  field
    {Object}           : Type{ℓₒ}
    {Morphism}         : Object → Object → Type{ℓₘ}
    ⦃ morphism-equiv ⦄ : ∀{x y} → Equiv{ℓₑ}(Morphism x y)
    category           : Category(Morphism)

  instance
    category-instance = category


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

module Data.Nat.WellFounded where

open import Prelude
open import Data.Nat
open import WellFounded

infix 4 _≤_ _<_
data _≤_ (n : ℕ) : ℕ → Type where
  n≤n : n ≤ n
  n≤s : ∀ {m} → n ≤ m → n ≤ suc m

_<_ : ℕ → ℕ → Type
n < m = suc n ≤ m

≤-wellFounded : WellFounded _<_
≤-wellFounded x = acc (go x)
  where
  go : ∀ n m → m < n → Acc _<_ m
  go (suc n) .n n≤n = acc (go n)
  go (suc n) m (n≤s m<n) = go n m m<n

open import Data.Nat.DivMod
open import Agda.Builtin.Nat using (div-helper)
import Data.Nat.Properties as ℕ

-- Bear in mind the following two functions will not compute
-- as currently subst (with --cubical) doesn't work on GADTs.
--
-- We could write the functions without using subst.
div2≤ : ∀ n → n ÷ 2 ≤ n
div2≤ n = subst (n ÷ 2 ≤_) (ℕ.+-idʳ n) (go zero n)
  where
  go : ∀ k n → div-helper k 1 n 1 ≤ n + k
  go k zero = n≤n
  go k (suc zero) = n≤s n≤n
  go k (suc (suc n)) = n≤s (subst (div-helper (suc k) 1 n 1 ≤_) (ℕ.+-suc n k) (go (suc k) n))

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


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

-- A "canonical" presentation of limits in Setoid.
--
-- These limits are obviously isomorphic to those created by
-- the Completeness proof, but are far less unweildy to work with.
-- This isomorphism is witnessed by Categories.Diagram.Pullback.up-to-iso

module Categories.Category.Instance.Properties.Setoids.Limits.Canonical where

open import Level
open import Data.Product using (_,_; _×_; map; zip; proj₁; proj₂; <_,_>)
open import Function.Equality as SΠ renaming (id to ⟶-id)
open import Relation.Binary.Bundles using (Setoid)
import Relation.Binary.Reasoning.Setoid as SR

open import Categories.Category.Instance.Setoids
open import Categories.Diagram.Pullback

open Setoid renaming (_≈_ to [_][_≈_])

--------------------------------------------------------------------------------
-- Pullbacks

record FiberProduct {o ℓ} {X Y Z : Setoid o ℓ} (f : X ⟶ Z) (g : Y ⟶ Z) : Set (o ⊔ ℓ) where
  constructor mk-×
  field
    elem₁ : Carrier X
    elem₂ : Carrier Y
    commute : [ Z ][ f ⟨$⟩ elem₁ ≈ g ⟨$⟩ elem₂ ]

open FiberProduct

FP-≈ : ∀ {o ℓ} {X Y Z : Setoid o ℓ} {f : X ⟶ Z} {g : Y ⟶ Z} → (fb₁ fb₂ : FiberProduct f g) → Set ℓ
FP-≈ {X = X} {Y} p q = [ X ][ elem₁ p ≈ elem₁ q ] × [ Y ][ elem₂ p ≈ elem₂ q ]

pullback : ∀ (o ℓ : Level) {X Y Z : Setoid (o ⊔ ℓ) ℓ} → (f : X ⟶ Z) → (g : Y ⟶ Z) → Pullback (Setoids (o ⊔ ℓ) ℓ) f g
pullback _ _ {X = X} {Y = Y} {Z = Z} f g = record
  { P = record
    { Carrier = FiberProduct f g
    ; _≈_ =  FP-≈
    ; isEquivalence = record
      { refl = X.refl , Y.refl
      ; sym = map X.sym Y.sym
      ; trans = zip X.trans Y.trans
      }
    }
    ; p₁ = record { _⟨$⟩_ = elem₁ ; cong = proj₁ }
    ; p₂ = record { _⟨$⟩_ = elem₂ ; cong = proj₂ }
    ; isPullback = record
      { commute = λ {p} {q} (eq₁ , eq₂) → trans Z (cong f eq₁) (commute q)
      ; universal = λ {A} {h₁} {h₂} eq → record
        { _⟨$⟩_ = λ a → record
          { elem₁ = h₁ ⟨$⟩ a
          ; elem₂ = h₂ ⟨$⟩ a
          ; commute = eq (refl A)
          }
        ; cong = < cong h₁ , cong h₂ >
        }
      ; unique = λ eq₁ eq₂ x≈y → eq₁ x≈y , eq₂ x≈y
      ; p₁∘universal≈h₁ = λ {_} {h₁} {_} eq → cong h₁ eq
      ; p₂∘universal≈h₂ = λ {_} {_} {h₂} eq → cong h₂ eq
      }
    }
    where
      module X = Setoid X
      module Y = Setoid Y


module x where

{-
------------------------------------------------------------------------------
Abstract

Relational program derivation technique :
- stepwise refining a relational spec to a program by algebraic rules.
- program obtained is correct by construction

Dependent type theory rich enough to express correctness properties verified by type checker.

Library, Algebra of Programming in Agda (AoPA)
- http://www.iis.sinica.edu.tw/~scm/2008/aopa/
- encodes relational derivations
- A program is coupled with an algebraic derivation whose correctness is guaranteed by type system

------------------------------------------------------------------------------
1 Introduction

relational program derivation
- specs are input-output relations that are stepwise refined by an algebra of programs.

paper show how program derivation can be encoded in a type and its proof term.

- case study using Curry-Howard isomorphism
- modelled a many concepts that occur in relational program derivation
  including relational folds, relational division, and converse-of-a-function.
  - e.g., Minimum, is defined using division and intersection
  - e.g., greedy theorem proved using the universal property of minimum.
  - the theorem can be used to deal with a number of optimisation problems specified as folds.
• to ensure termination with unfolds and hylomorphisms, enable programmer to
  model an unfold as the relational converse of a fold, but demand a proof of accessibility
  before it is refined to a functional unfold.

------------------------------------------------------------------------------
2 Overview of Relational Program Derivation

Merit of functional programming : programs can be manipulated by equational reasoning.

Program derivation in Bird-Meertens style 1989b) typically start with a specification,
as a function, that is obviously correct but not efficient.

Algebraic identities are then applied, in successive steps,
to show that the specification equals another functional program that is more efficient.

Typical example : Maximum Segment Sum (Gries, 1989; Bird, 1989a), specification :
    max · map sum · segs
where
- segs produces all consecutive segments of the input list of numbers
- map sum computes their summation
- maximum is picked by max
Specification can be shown, after transformation, to be equal a version using foldr (linear).

In 90’s there was a trend in the program derivation community to move from functions to relations.
- spec given in terms of an input/output relation
- relation is refined to smaller, more deterministic relations in each step,
- until obtaining a function

Relational derivation advantages:
- spec often more concise than corresponding functional specification
- optimisation problems can be specified using relations generating all possible solutions
- easier to talk about program inversion

The catch: *must reason in terms of inequalities rather than equalities*

denoted by R : B ← A
- relation R from A to B
- subset of set of pairs B × A
- A function f is seen as a special case where (b, a) ∈ f and (b' , a) ∈ f implies b = b'

converse R˘ : A ← B of R : B ← A
- defined by (a, b) ∈ R ˘ if (b, a) ∈ R

composition of two relations R : C ← B and S : B ← A
- defined by: (c, a) ∈ R ◦ S if ∃b : (c, b) ∈ R ∧ (b, a) ∈ S

power transpose ΛR of R : B ← A
- is a function from A to P B (subsets of B)
- ΛR a = { b | (b, a) ∈ R }.

relation ∈ : A ← P A
- maps a set to one of its arbitrary members
- converse: ∋ : P A ← A

product of two relations, R × S
- defined by ((c, d), (a, b)) ∈ R × S if (c, a) ∈ R and (d, b) ∈ S

--      step fun      base  input    output
foldr : (A → B → B) → B   → List A → B

generalisation to a relation, denote foldR

              input    step relation  base cases
foldR R : B ← List A ← (B ← (A×B))    (set s : PB)

-- relation mapping a list to one of its arbitrary subsequences
subseq = foldR (cons ∪ outr) {[ ]}
where
  cons (x, xs) = x :: xs -- cons keeps the current element
  outr (x, xs) = xs      -- outr drops the current element

Relational fold defined in terms of functional fold:

   foldR R s = ∈ ◦ foldr Λ(R ◦ (id " ∈)) s

of type List A → P B that collects all the results in a set.

step function Λ(R ◦ (id " ∈))  : has type (A × P B) → P B
(id " ∈) : (A × B) ← (A × P B) : pairs current element with one of the results from previous step
                                 before passing the pair to R

foldR R s satisfies the universal property:
foldR R s = S ⇔ R ◦ (id " S) = S ◦ cons ∧ s = ΛS [ ]

-- induction rule
-- states that foldR R s is the unique fixed-point of the monotonic function
λ X → (R ◦ (id " X) ◦ cons ˘) ∪ {(b, [ ]) | b ∈ s}

-- computation rule
-- foldR R s is also the least prefix-point, therefore
foldR R s ⊆ S ⇐ R ◦ (id " S) ⊆ S ◦ cons ∧ s ⊆ ΛS [ ],
R ◦ (id " foldR R s) ⊆ foldR R s ◦ cons ∧ s ⊆ Λ(foldR R s) [ ].

If an optimisation problem can be specified by generating all possible solutions using
foldR or converse of foldR before picking the best one, Bird and de Moor (1997) gave a
number of conditions under which the specification can be refined to a greedy algorithm, a
dynamic programming algorithm, or something in-between.

------------------------------------------------------------------------------
3 A Crash Course in Agda
-}

-- Fig. 2. Some examples of datatype definitions.

data List (A : Set) : Set where
  []   : List A
  _∷_  : A → List A → List A

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

data _≤_ : ℕ → ℕ → Set where
  ≤-refl : {n   : ℕ} → n ≤ n
  ≤-step : {m n : ℕ} → m ≤ n → m ≤ suc n

_<_ : ℕ → ℕ → Set
m < n = suc m ≤ n

-- Fig. 3. An encoding of first-order intuitionistic logic in Agda.

-- Truth : has one unique term — a record with no fields
record ⊤ : Set where

-- Falsity : type with no constructors therefore no inhabitants
data ⊥ : Set where

-- Disjunction : proof deduced either from a proof of P or a proof of Q
data _⨄_ (A B : Set) : Set where
  inj1 : A → A ⨄ B
  inj2 : B → A ⨄ B

-- Dependent Pair : type of 2nd may depend on the first component
data Σ (A : Set)(B : A → Set) : Set where
  _,_ : (x : A) → (y : B x) → Σ A B

proj₁ : ∀ {A B} → Σ A B → A
proj₁ (x , y) = x

proj₂ : ∀ {A B} → (p : Σ A B) → B (proj₁ p)
proj₂ (x , y) = y

-- Conjunction
_×_ : (A B : Set) → Set
A × B = Σ A (λ _ → B)

-- Existential Quantification
-- to prove the proposition ∃ P, where P is a predicate on terms of type A
-- provide, in a pair, a witness w : A and a proof of P w.
∃ : {A : Set} (P : A → Set) → Set
∃ = Σ _

-- Universal Quantification
-- of predicate P on type A is encoded as a dependent function type
-- whose elements, given any x : A, must produce a proof of P x.
-- Agda provides a short hand ∀ x → P x in place of (x : A) → P x when A can be inferred.

-- Implication
-- P → Q is represented as a function taking a proof of P to a proof of Q
-- no new notation for it

-- Predicates
-- on type A are represented by A → Set.
-- e.g., (λ n → zero < n) : N → Set
-- is a predicate stating that a natural number is positive.

{-
3.2 Identity Type

term of type x ≡ y is proof x and y are equal
-}

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

-- REFLEXIVE : by definition

-- SYMMETRIC
≡-sym : {A : Set}{x y : A} → x ≡ y → y ≡ x
≡-sym {A}{x}{.x} ≡-refl = ≡-refl

-- TRANSITIVE
≡-trans : {A : Set}{x y z : A} → x ≡ y → y ≡ z → x ≡ z
≡-trans {A}{x}{.x}{z} ≡-refl x≡z = x≡z -- could replace x≡z with ≡-refl

-- SUBSTITUTIVE — if x ≡ y, they are interchangeable in all contexts
≡-subst : {A : Set}(P : A → Set){x y : A} → x ≡ y → P x → P y
≡-subst P ≡-refl Px = Px

≡-cong : {A B : Set}(f : A → B){x y : A} → x ≡ y → f x ≡ f y
≡-cong f ≡-refl = ≡-refl
{-
≡ NOT EXTENSIONAL
Qquality of terms is checked by expanding them to normal forms.
Problem comparing higher-order values: e.g., sum·map sum     and     sum · concat
while defining the same function summing up a list of lists of numbers, are not “equal” under ≡ .

Can define extensional equality for (non-dependent) functions on first-order values:
-}
_≐_ : {A B : Set} → (A → B) → (A → B) → Set
f ≐ g = ∀ x → f x ≡ g x
{-
≐ NOT SUBSTITUTIVE : congruence of ≐ has to be proved for each context.

Refinement in preorder reasoning usually involves replacing terms in provably monotonic contexts.
This is a significant overhead; but given that this overhead
is incurred anyway, not having extensional equality is no extra trouble.

3.3 Preorder Reasoning

To prove e1 ≡ e2 is to construct a term having that type.

For any binary relation ∼ that is reflexive and transitive
- for which one can construct terms ∼-refl and ∼-trans having the types described in above
can derive a set of combinators, shown in Fig. 4,
which enables one to construct a term of type e₁ ∼ en  in algebraic style.

-- Fig. 4. Combinators for preorder reasoning.
infixr 2 _∼⟨_⟩_
infix  2 _∼∎

_∼⟨_⟩_ : {A : Set}(x : A){y z : A} → x ∼ y → y ∼ z → x ∼ z
x ∼⟨ x∼y ⟩ y∼z = ∼-trans x∼y y∼z

_∼∎ : {A : Set}(x : A) → x ∼ x
x ∼∎ = ∼-refl

implication as a relation:
-}
_⇒_ : Set → Set → Set
P ⇒ Q = P → Q

_⇐_ : Set → Set → Set
P ⇐ Q = Q ⇒ P
{-
Reflexivity and transitivity of ⇐ , for example, can be simply given by ⇐-refl = id and
⇐-trans = · , where · is function composition. Therefore, they induce a pair of operators
_⇐⟨_⟩_ and ⇐∎ for logical reasoning.

Hierarchy of universes
- Set, the type of small types, is in sort Set1

When instantiating ∼ in Fig. 4 to ⇐ : Set → Set → Set
- notice that the type A : Set itself cannot be instantiated to Set, which is in Set1

We resolve this by using different module generators for different universes.
More on this in Sect. 4.1.

3.4 Functional Derivation

Since _≐_ is reflexive and transitive (not shown), it induces its preorder reasoning operators.

Fig. 5 shows a proof of the universal property of foldr.

The steps using ≡-refl are equivalences Agda proves by expanding definitions.
The inductive hypothesis is established by a recursive call to foldr-universal.
-}
infix  3 _≡∎
infixr 2 _≡⟨⟩_ _≡⟨_⟩_
infix  1 begin_

begin_ : {A : Set} {x y : A} → x ≡ y → x ≡ y
begin_ x≡y = x≡y

_≡⟨⟩_ : {A : Set} (x {y} : A) → x ≡ y → x ≡ y
_ ≡⟨⟩ x≡y = x≡y

_≡⟨_⟩_ : {A : Set} (x {y z} : A) → x ≡ y → y ≡ z → x ≡ z
_ ≡⟨ x≡y ⟩ y≡z = ≡-trans x≡y y≡z

_≡∎ : {A : Set} (x : A) → x ≡ x
_≡∎ _ = ≡-refl
{-
Fig. 5. Proving the universal property for foldr
-}
foldr              : {A B : Set}
                   → (A → B → B) → B → List A
                   → B
foldr f e      []  = e
foldr f e (x ∷ xs) = f x (foldr f e xs)

{- https://www.cs.nott.ac.uk/~pszgmh/fold.pdf
For finite lists, the universal property of fold can be stated as the following equivalence
between two definitions for a function g that processes lists:
g      []  = v
                         ⇔ g = fold f v
g (x ∷ xs) = f x (g xs)

right-to-left : substituting g = fold f v into the two equations for g gives recursive fold def
left-to-right : two equations for g are the assumptions required to show that g = fold f v
using a simple proof by induction on finite lists (Bird, 1998)

universal property states that for finite lists the function fold f v is not just a
solution to its defining equations, but the unique solution.

Utility of universal property : makes explicit the two assumptions
required for a certain pattern of inductive proof.

For specific cases, by verifying the two assumptions (typically done without need for induction)
can then appeal to the universal property to complete the inductive proof that g = fold f v.

universal PROPERTY of fold : encapsulates a pattern of inductive proof concerning lists
just as the fold OPERATOR  : encapsulates a pattern of recursion for processing lists
-}
foldr-universal : ∀ {A B} (h : List A → B) f e
                → (h [] ≡ e)
                → (∀ x xs → h (x ∷ xs) ≡ f x (h xs))
                → h ≐ foldr f e
foldr-universal h f e base step      []  = base
foldr-universal h f e base step (x ∷ xs) =
  begin
    h (x ∷ xs)
  ≡⟨ step x xs ⟩
    f x (h xs)
  ≡⟨ ≡-cong (f x) (foldr-universal h f e base step xs) ⟩
    f x (foldr f e xs)
  ≡⟨ ≡-refl ⟩
    foldr f e (x ∷ xs)
  ≡∎
{-
-- Can use the universal property to prove the foldr-fusion theorem:

_·_ : {A : Set} {B : A → Set} {C : (x : A) → B x → Set}
    → (f : {x : A} (y : B x) → C x y)
    → (g : (x : A) → B x)
    → (x : A) → C x (g x)
(f · g) x = f (g x)

-- TODO compile problems
foldr-fusion : ∀ {A B C} (h : B → C) {f : A → B → B} {g : A → C → C}
             → {e : B}
             → (∀ x y → h (f x y) ≡ g x (h y))
             → (h · foldr f e) ≐ (foldr g (h e))
foldr-fusion h {f} {g} e fuse =
  foldr-universal (h · foldr f e) g (h e) ≡-refl (λ x xs → fuse x (foldr f e xs))
-}


module Structure.Category.Categories where

open import Data
open import Data.Proofs
open import Functional
open import Logic
import      Lvl
import      Relator.Equals as Eq
open import Structure.Setoid
open import Structure.Category
open import Structure.Categorical.Proofs
open import Structure.Categorical.Properties
open import Structure.Operator
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ : Lvl.Level
private variable Obj A B : Type{ℓ}
private variable _▫_ : Obj → Obj → Type{ℓ}
private variable f : A → B

-- The empty category is a category containing nothing.
-- The objects are empty.
-- The morphisms are empty.
emptyCategory : Category{ℓ₁}{ℓ₂}{ℓₑ}(empty-morphism) ⦃ \{} ⦄
Category._∘_            emptyCategory = empty-comp
Category.id             emptyCategory = empty-id
Category.binaryOperator emptyCategory {}
Category.associativity  emptyCategory = empty-associativity ⦃ \{} ⦄
Category.identity       emptyCategory = empty-identity ⦃ \{} ⦄

-- The single category is a category containing a single object and a single morphism.
-- The objects consists of a single thing.
-- The morphisms consists of a single connection connecting the single thing to itself.
singleCategory : ∀{ℓₒ ℓᵢ ℓₚₐ₁ ℓₚₐ₂ ℓₚᵢ₁ ℓₚᵢ₂ ℓₚᵢ₃ : Lvl.Level} → Category{ℓ₁}{ℓ₂}(single-morphism)
Category._∘_ (singleCategory{ℓ₁}{ℓ₂}{ℓₒ}{ℓᵢ}{ℓₚₐ₁}{ℓₚₐ₂}{ℓₚᵢ₁}{ℓₚᵢ₂}{ℓₚᵢ₃}) = single-comp{ℓ₂}{ℓₒ}
Category.id  (singleCategory{ℓ₁}{ℓ₂}{ℓₒ}{ℓᵢ}{ℓₚₐ₁}{ℓₚₐ₂}{ℓₚᵢ₁}{ℓₚᵢ₂}{ℓₚᵢ₃}) = single-id{ℓ₂}{ℓᵢ}
BinaryOperator.congruence (Category.binaryOperator singleCategory) Eq.[≡]-intro Eq.[≡]-intro = Eq.[≡]-intro
Category.associativity (singleCategory{ℓ₁}{ℓ₂}{ℓₒ}{ℓᵢ}{ℓₚₐ₁}{ℓₚₐ₂}{ℓₚᵢ₁}{ℓₚᵢ₂}{ℓₚᵢ₃}) = single-associativity{ℓ₂}{ℓ₂}{ℓₚₐ₁}{ℓ₁}{ℓₚₐ₂}
Category.identity      (singleCategory{ℓ₁}{ℓ₂}{ℓₒ}{ℓᵢ}{ℓₚₐ₁}{ℓₚₐ₂}{ℓₚᵢ₁}{ℓₚᵢ₂}{ℓₚᵢ₃}) = single-identity{ℓ₂}{ℓ₂}{ℓₚᵢ₁}{ℓ₁}{ℓₚᵢ₂}{ℓₚᵢ₃}

on₂-category : ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}{ℓ}(x ▫ y) ⦄ → Category{Obj = B}(_▫_) ⦃ morphism-equiv ⦄ → (f : A → B) → Category((_▫_) on₂ f)
Category._∘_ (on₂-category C _) = Category._∘_ C
Category.id  (on₂-category C _) = Category.id  C
BinaryOperator.congruence (Category.binaryOperator (on₂-category C _)) = BinaryOperator.congruence(Category.binaryOperator C)
Category.associativity (on₂-category C f) = on₂-associativity f (Category.associativity C)
Category.identity      (on₂-category C f) = on₂-identity f (Category.identity C)

{-
TODO:
• https://en.wikipedia.org/wiki/Isomorphism_of_categories
• https://en.wikipedia.org/wiki/Equivalence_of_categories
?
-}


{-
This second-order equational theory was created from the following second-order syntax description:

syntax QIO

type
  T : 0-ary
  P : 0-ary

term
  new      : P.T  ->  T
  measure  : P  T  T  ->  T
  applyX   : P  P.T  ->  T
  applyI2  : P  P.T  ->  T
  applyDuv : P  P  (P,P).T  ->  T
  applyDu  : P  P.T  ->  T
  applyDv  : P  P.T  ->  T

theory
  (A) a:P   t u:T         |> applyX (a, b.measure(b, t, u)) = measure(a, u, t)
  (B) a:P   b:P  t u:P.T  |> measure(a, applyDu(b, b.t[b]), applyDv(b, b.u[b])) = applyDuv(a, b, a b.measure(a, t[b], u[b]))
  (D) t u:T               |> new(a.measure(a, t, u)) = t
  (E) b:P  t:(P, P).T     |> new(a.applyDuv(a, b, a b. t[a,b])) = applyDu(b, b.new(a.t[a,b]))
-}

module QIO.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import QIO.Signature
open import QIO.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution QIO:Syn
open import SOAS.Metatheory.SecondOrder.Equality QIO:Syn

private
  variable
    α β γ τ : QIOT
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ QIO) α Γ → (𝔐 ▷ QIO) α Γ → Set where
  A : ⁅ P ⁆ ⁅ T ⁆ ⁅ T ⁆̣               ▹ ∅ ⊢                             applyX 𝔞 (measure x₀ 𝔟 𝔠) ≋ₐ measure 𝔞 𝔠 𝔟
  B : ⁅ P ⁆ ⁅ P ⁆ ⁅ P ⊩ T ⁆ ⁅ P ⊩ T ⁆̣ ▹ ∅ ⊢ measure 𝔞 (applyDu 𝔟 (𝔠⟨ x₀ ⟩)) (applyDv 𝔟 (𝔡⟨ x₀ ⟩)) ≋ₐ applyDuv 𝔞 𝔟 (measure x₀ (𝔠⟨ x₁ ⟩) (𝔡⟨ x₁ ⟩))
  D : ⁅ T ⁆ ⁅ T ⁆̣                     ▹ ∅ ⊢                                  new (measure x₀ 𝔞 𝔟) ≋ₐ 𝔞
  E : ⁅ P ⁆ ⁅ P · P ⊩ T ⁆̣             ▹ ∅ ⊢                    new (applyDuv x₀ 𝔞 (𝔟⟨ x₀ ◂ x₁ ⟩)) ≋ₐ applyDu 𝔞 (new (𝔟⟨ x₀ ◂ x₁ ⟩))

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning


{-# OPTIONS --cubical #-}
module Multidimensional.Data.DirNum.Base where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.Data.Nat

open import Multidimensional.Data.Dir

-- Dependent "directional numerals":
-- for natural n, obtain 2ⁿ "numerals".
-- This is basically a little-endian binary notation.
-- NOTE: Would an implementation of DirNum with dependent vectors be preferable
--       over using products?
DirNum : ℕ → Type₀
DirNum zero = Unit
DirNum (suc n) = Dir × (DirNum n)

DirNum→ℕ : ∀ {n} → DirNum n → ℕ
DirNum→ℕ {zero} tt = zero
DirNum→ℕ {suc n} (↓ , d) = doublesℕ (suc zero) (DirNum→ℕ d)
DirNum→ℕ {suc n} (↑ , d) = suc (doublesℕ (suc zero) (DirNum→ℕ d))

-- give the next numeral, cycling back to 0
-- in case of 2ⁿ - 1
next : ∀ {n} → DirNum n → DirNum n
next {zero} tt = tt
next {suc n} (↓ , ds) = (↑ , ds)
next {suc n} (↑ , ds) = (↓ , next ds)

prev : ∀ {n} → DirNum n → DirNum n
prev {zero} tt = tt
prev {suc n} (↓ , ds) = (↓ , prev ds)
prev {suc n} (↑ , ds) = (↓ , ds)

zero-n : (n : ℕ) → DirNum n
zero-n zero = tt
zero-n (suc n) = (↓ , zero-n n)

one-n : (n : ℕ) → DirNum n
one-n zero = tt
one-n (suc n) = (↑ , zero-n n)

-- numeral for 2ⁿ - 1
max-n : (n : ℕ) → DirNum n
max-n zero = tt
max-n (suc n) = (↑ , max-n n)

-- -- TODO: rename
-- embed-next : (r : ℕ) → DirNum r → DirNum (suc r)
-- embed-next zero tt = (↓ , tt)
-- embed-next (suc r) (d , ds) with zero-n? ds
-- ... | no _ = (d , embed-next r ds)
-- ... | yes _ = (d , zero-n (suc r))

sucDoubleDirNum+ : (r : ℕ) → DirNum r → DirNum (suc r)
sucDoubleDirNum+ r x = (↑ , x)

-- bad name, since this is doubling "to" suc r
doubleDirNum+ : (r : ℕ) → DirNum r → DirNum (suc r)
doubleDirNum+ r x = (↓ , x)

dropLeast : {r : ℕ} → DirNum (suc r) → DirNum r
dropLeast {zero} d = tt
dropLeast {suc r} (x , x₁) = x₁

dropMost : {r : ℕ} → DirNum (suc r) → DirNum r
dropMost {zero} d = tt
dropMost {suc zero} (x , (x₁ , x₂)) = (x₁ , x₂)
dropMost {suc (suc r)} (x , x₁) = (x , dropMost x₁)

-- need to prove property about doubleable
--doubleDirNum : (r : ℕ) (d : DirNum r) → doubleable-n? {r} d ≡ true → DirNum r
-- bad? is not correct when not "doubleable"
-- possibly should view as operations in residue classes?
doubleDirNum : (r : ℕ) (d : DirNum r) → DirNum r
doubleDirNum zero d  = tt
doubleDirNum (suc r) d  = doubleDirNum+ r (dropMost {r} d)
-- doubleDirNum zero d doubleable = ⊥-elim (false≢true doubleable)
-- doubleDirNum (suc r) d doubleable = doubleDirNum+ r (dropMost {r} d)


------------------------------------------------------------------------------
-- FOTC terms properties
------------------------------------------------------------------------------

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

module FOTC.Base.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base

------------------------------------------------------------------------------
-- Congruence properties

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong refl = refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong refl = refl

·-cong : ∀ {a b c d} → a ≡ b → c ≡ d → a · c ≡ b · d
·-cong refl refl = refl

succCong : ∀ {m n} → m ≡ n → succ₁ m ≡ succ₁ n
succCong refl = refl

predCong : ∀ {m n} → m ≡ n → pred₁ m ≡ pred₁ n
predCong refl = refl

ifCong₁ : ∀ {b b' t t'} → b ≡ b' →
          (if b then t else t') ≡ (if b' then t else t')
ifCong₁ refl = refl

ifCong₂ : ∀ {b t₁ t₂ t} → t₁ ≡ t₂ →
          (if b then t₁ else t) ≡ (if b then t₂ else t)
ifCong₂ refl = refl

ifCong₃ : ∀ {b t t₁ t₂} → t₁ ≡ t₂ →
          (if b then t else t₁) ≡ (if b then t else t₂)
ifCong₃ refl = refl

------------------------------------------------------------------------------
-- Injective properties

succInjective : ∀ {m n} → succ₁ m ≡ succ₁ n → m ≡ n
succInjective {m} {n} h =
  m                ≡⟨ sym (pred-S m) ⟩
  pred₁ (succ₁ m)  ≡⟨ predCong h ⟩
  pred₁ (succ₁ n)  ≡⟨ pred-S n ⟩
  n                ∎

------------------------------------------------------------------------------
-- Discrimination rules

S≢0 : ∀ {n} → succ₁ n ≢ zero
S≢0 S≡0 = 0≢S (sym S≡0)


module Structure.Function.Ordering where

import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Type

module _ {ℓₒ₁ ℓₒ₂ ℓₗ₁ ℓₗ₂} {T₁ : Type{ℓₒ₁}} {T₂ : Type{ℓₒ₂}} (_≤₁_ : T₁ → T₁ → Type{ℓₗ₁}) (_≤₂_ : T₂ → T₂ → Type{ℓₗ₂}) where
  record Increasing (f : T₁ → T₂) : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : ∀{a b : T₁} → (a ≤₁ b) → (f(a) ≤₂ f(b))

  record Decreasing (f : T₁ → T₂) : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : ∀{a b : T₁} → (a ≤₁ b) → (f(b) ≤₂ f(a))

  Monotone : (T₁ → T₂) → Stmt
  Monotone(f) = (Increasing(f) ∨ Decreasing(f))

  record UpperBoundPointOf (f : T₁ → T₂) (p : T₁) : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : ∀{x} → (f(x) ≤₂ f(p))

  UpperBounded : (T₁ → T₂) → Stmt
  UpperBounded(f) = ∃(UpperBoundPointOf(f))

  record LowerBoundPointOf (f : T₁ → T₂) (p : T₁) : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : ∀{x} → (f(p) ≤₂ f(x))

  LowerBounded : (T₁ → T₂) → Stmt
  LowerBounded(f) = ∃(LowerBoundPointOf(f))


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

open import HoTT hiding (_::_)

module algebra.Word {i} (A : Type i) where

  data Word : Type i where
    nil : Word
    _::_ : A → Word → Word
    _inv::_ : A → Word → Word
  infixr 60 _::_ _inv::_

  -- The following six functions prove things like if [x ∷ v ≡ y ∷ w],
  -- then [x ≡ y].
  -- This is not as easy as it sounds, you cannot directly induct on the equality
  -- (because [x ∷ v] is not a general element of type word), so you have to
  -- extract the head, but it’s not always possible…

  Word= : (v w : Word) → Type i
  Word= nil         nil         = Lift ⊤
  Word= nil         (y    :: w) = Lift ⊥
  Word= nil         (y inv:: w) = Lift ⊥
  Word= (x    :: v) nil         = Lift ⊥
  Word= (x    :: v) (y    :: w) = (x == y) × (v == w)
  Word= (x    :: v) (y inv:: w) = Lift ⊥
  Word= (x inv:: v) nil         = Lift ⊥
  Word= (x inv:: v) (y    :: w) = Lift ⊥
  Word= (x inv:: v) (y inv:: w) = (x == y) × (v == w)

  Word=-out : {v w : Word} (p : v == w) → Word= v w
  Word=-out {v = nil}       idp = lift unit
  Word=-out {v = x    :: v} idp = (idp , idp)
  Word=-out {v = x inv:: v} idp = (idp , idp)

  Word=-in : {v w : Word} → Word= v w → v == w
  Word=-in {nil}       {nil}       _         = idp
  Word=-in {nil}       {y    :: w} (lift ())
  Word=-in {nil}       {y inv:: w} (lift ())
  Word=-in {x    :: v} {nil}       (lift ())
  Word=-in {x    :: v} {y    :: w} (p , q)   = ap2 _::_ p q
  Word=-in {x    :: v} {y inv:: w} (lift ())
  Word=-in {x inv:: v} {nil}       (lift ())
  Word=-in {x inv:: v} {y    :: w} (lift ())
  Word=-in {x inv:: v} {y inv:: w} (p , q)   = ap2 _inv::_ p q

  Word-fst= : {x y : A} {v w : Word} (p : x :: v == y :: w) → x == y
  Word-fst= p = fst (Word=-out p)

  Word-snd= : {x y : A} {v w : Word} (p : x :: v == y :: w) → v == w
  Word-snd= p = snd (Word=-out p)

  Word-fst=' : {x y : A} {v w : Word} (p : x inv:: v == y inv:: w) → x == y
  Word-fst=' p = fst (Word=-out p)

  Word-snd=' : {x y : A} {v w : Word} (p : x inv:: v == y inv:: w) → v == w
  Word-snd=' p = snd (Word=-out p)


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

-- The 'Trivial' instance, with a single arrow between objects

module Categories.Theory.Lawvere.Instance.Triv where

open import Data.Nat using (_*_)
open import Data.Unit.Polymorphic using (⊤; tt)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; isEquivalence)

open import Categories.Theory.Lawvere using (LawvereTheory)

Triv : ∀ {ℓ} → LawvereTheory ℓ ℓ
Triv = record
  { L = record
          { _⇒_ = λ _ _ → ⊤
          ; _≈_ = _≡_
          ; assoc = refl
          ; sym-assoc = refl
          ; identityˡ = refl
          ; identityʳ = refl
          ; identity² = refl
          ; equiv = isEquivalence
          ; ∘-resp-≈ = λ _ _ → refl
          }
  ; T = record
    { terminal = record { ⊤ = 0 ; ⊤-is-terminal = record { ! = tt ; !-unique = λ _ → refl } }
    ; products = record
      { product = λ {m} {n} → record
        { A×B = m * n
        ; project₁ = refl
        ; project₂ = refl
        ; unique = λ _ _ → refl
        }
      }
    }
  ; I = record
    { F₁ = λ _ → tt
    ; identity = refl
    ; homomorphism = refl
    ; F-resp-≈ = λ _ → refl
    }
  ; CartF = record
    { F-resp-⊤ = record { ! = tt ; !-unique = λ _ → refl }
    ; F-resp-× = record { ⟨_,_⟩ = λ _ _ → tt ; project₁ = refl ; project₂ = refl ; unique = λ _ _ → refl }
    }
  }


{-# OPTIONS --universe-polymorphism #-}
module Categories.Graphs.Underlying where

open import Categories.Support.PropositionalEquality

open import Categories.Category
  hiding (module Heterogeneous)
open import Categories.Categories
open import Categories.Graphs
open import Categories.Functor
  using (Functor; module Functor; ≡⇒≣)
  renaming (id to idF; _≡_ to _≡F_)
open import Data.Product
open import Graphs.Graph
open import Graphs.GraphMorphism

Underlying₀ : ∀ {o ℓ e} → Category o ℓ e → Graph o ℓ e
Underlying₀ C = record
  { Obj   = Obj
  ; _↝_   = _⇒_
  ; _≈_   = _≡_
  ; equiv = equiv
  } where open Category C

Underlying₁ : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
  {X : Category o₁ ℓ₁ e₁}
  {Y : Category o₂ ℓ₂ e₂}
  → Functor X Y
  → GraphMorphism (Underlying₀ X) (Underlying₀ Y)
Underlying₁ G = record
  { F₀        = G₀
  ; F₁        = G₁
  ; F-resp-≈  = G-resp-≡
  }
  where
    open Functor G
      renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)

Underlying : ∀ {o ℓ e} → Functor (Categories o ℓ e) (Graphs o ℓ e)
Underlying {o}{ℓ}{e} = record
  { F₀            = Underlying₀
  ; F₁            = Underlying₁
  ; identity      = (λ x → ≣-refl) , (λ f → Heterogeneous.refl _)
  ; homomorphism  = (λ x → ≣-refl) , (λ f → Heterogeneous.refl _)
  ; F-resp-≡      = λ {A B}{F G : Functor A B} → F-resp-≡ {A}{B}{F}{G}
  }
  where
    module Graphs     = Category (Graphs     o ℓ e)
    module Categories = Category (Categories o ℓ e)

    .F-resp-≡ : ∀ {A B : Categories.Obj} {G H : Functor A B}
      → G ≡F H
      → Underlying₁ G ≈ Underlying₁ H
    F-resp-≡ {A}{B}{G}{H} G≡H
      = (≡⇒≣ G H G≡H) , (λ f → convert-~ (G≡H f))
      where
        open Heterogeneous (Underlying₀ B)
          renaming (_~_ to _~₂_)
        open Categories.Category.Heterogeneous B
          renaming (_∼_ to _~₁_)

        convert-~ : ∀ {a b c d}{x : B [ a , b ]}{y : B [ c , d ]} → x ~₁ y → x ~₂ y
        convert-~ (≡⇒∼ foo) = ≈⇒~ foo


module PLRTree.Equality {A : Set} where

open import PLRTree {A}

data _≃_ : PLRTree → PLRTree → Set where
  ≃lf : leaf ≃ leaf
  ≃nd : {l r l' r' : PLRTree}
                   (x x' : A)
                   → l ≃ r
                   → l' ≃ r'
                   → l ≃ l'
                   → node perfect x l r ≃ node perfect x' l' r'


------------------------------------------------------------------------
-- An implementation of tree sort, formally proved to return a
-- permutation of the input
------------------------------------------------------------------------

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

open import Equality
open import Prelude hiding (id)

module Tree-sort.Partial
  {c⁺}
  (eq : ∀ {a p} → Equality-with-J a p c⁺)
  {A : Type}
  (_≤_ : A → A → Bool) -- A comparison function.
  where

open Derived-definitions-and-properties eq

open import Bag-equivalence eq
open import Bijection eq using (_↔_)
open import Function-universe eq hiding (_∘_)
open import List eq
open import Tree eq

------------------------------------------------------------------------
-- Insertion into trees

-- Inserts an element into the tree.

insert : A → Tree A → Tree A
insert x leaf         = singleton x
insert x (node l y r) =
  if x ≤ y then node (insert x l) y r
           else node l y (insert x r)

-- The insert function inserts.

Any-insert : ∀ (P : A → Type) x t →
             AnyT P (insert x t) ↔ P x ⊎ AnyT P t
Any-insert P x leaf =
  AnyT P (singleton x)  ↔⟨ Any-singleton P ⟩
  P x                   ↔⟨ inverse ⊎-right-identity ⟩
  P x ⊎ ⊥               ↔⟨⟩
  P x ⊎ AnyT P leaf     □
Any-insert P x (node l y r) with x ≤ y
... | true  =
  AnyT P (insert x l) ⊎ P y ⊎ AnyT P r  ↔⟨ Any-insert P x l ⊎-cong id ⟩
  (P x ⊎ AnyT P l)    ⊎ P y ⊎ AnyT P r  ↔⟨ inverse ⊎-assoc ⟩
  P x ⊎ AnyT P l      ⊎ P y ⊎ AnyT P r  □
... | false =
  AnyT P l ⊎ P y ⊎ AnyT P (insert x r)  ↔⟨ id ⊎-cong id ⊎-cong Any-insert P x r ⟩
  AnyT P l ⊎ P y ⊎ P x ⊎ AnyT P r       ↔⟨ lemma (AnyT P l) (P y) (P x) (AnyT P r) ⟩
  P x ⊎ AnyT P l ⊎ P y ⊎ AnyT P r       □
  where
  -- The following lemma is easy to prove automatically (for instance
  -- by using a ring solver).

  lemma : (A B C D : Type) → A ⊎ B ⊎ C ⊎ D ↔ C ⊎ A ⊎ B ⊎ D
  lemma A B C D =
    A ⊎ B ⊎ C ⊎ D      ↔⟨ id ⊎-cong ⊎-assoc ⟩
    A ⊎ (B ⊎ C) ⊎ D    ↔⟨ id ⊎-cong ⊎-comm ⊎-cong id ⟩
    A ⊎ (C ⊎ B) ⊎ D    ↔⟨ ⊎-assoc ⟩
    (A ⊎ C ⊎ B) ⊎ D    ↔⟨ ⊎-assoc ⊎-cong id ⟩
    ((A ⊎ C) ⊎ B) ⊎ D  ↔⟨ (⊎-comm ⊎-cong id) ⊎-cong id ⟩
    ((C ⊎ A) ⊎ B) ⊎ D  ↔⟨ inverse ⊎-assoc ⊎-cong id ⟩
    (C ⊎ A ⊎ B) ⊎ D    ↔⟨ inverse ⊎-assoc ⟩
    C ⊎ (A ⊎ B) ⊎ D    ↔⟨ id ⊎-cong inverse ⊎-assoc ⟩
    C ⊎ A ⊎ B ⊎ D      □

------------------------------------------------------------------------
-- Turning a list into a search tree

-- Converts the list to a search tree.

to-search-tree : List A → Tree A
to-search-tree = foldr insert leaf

-- No elements are added or removed.

to-search-tree-lemma : ∀ xs z → z ∈T to-search-tree xs ↔ z ∈ xs
to-search-tree-lemma [] = λ z →
  z ∈T leaf  ↔⟨⟩
  z ∈  []    □
to-search-tree-lemma (x ∷ xs) = λ z →
  z ∈T insert x (to-search-tree xs)  ↔⟨ Any-insert (λ x → z ≡ x) _ _ ⟩
  z ≡ x ⊎ z ∈T to-search-tree xs     ↔⟨ id ⊎-cong to-search-tree-lemma xs z ⟩
  z ∈ x ∷ xs                         □

------------------------------------------------------------------------
-- Sorting

-- Sorts a list.

tree-sort : List A → List A
tree-sort = flatten ∘ to-search-tree

-- The result is a permutation of the input.

tree-sort-permutes : ∀ xs → tree-sort xs ≈-bag xs
tree-sort-permutes xs = λ z →
  z ∈  flatten (to-search-tree xs)  ↔⟨ flatten-lemma (to-search-tree xs) z ⟩
  z ∈T to-search-tree xs            ↔⟨ to-search-tree-lemma xs z ⟩
  z ∈  xs                           □


module Data.Tuple.Equiv.Id where

import      Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Equiv
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Operator
open import Type

private variable ℓ ℓₒ₁ ℓₒ₂ : Lvl.Level
private variable A B : Type{ℓ}
private variable f g : A → B
private variable p : A ⨯ B

instance
  Tuple-Id-extensionality : Extensionality{A = A}{B = B}([≡]-equiv)
  Tuple-Id-extensionality = intro

Tuple-left-map : (Tuple.left(Tuple.map f g p) ≡ f(Tuple.left(p)))
Tuple-left-map = [≡]-intro

Tuple-right-map : (Tuple.right(Tuple.map f g p) ≡ g(Tuple.right(p)))
Tuple-right-map = [≡]-intro


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

open import HoTT

module homotopy.HSpace where

record HSpaceStructure {i} (A : Type i) : Type i where
  constructor hSpaceStructure
  field
    e : A
    μ : A → A → A
    μe- : (a : A) → μ e a == a
    μ-e : (a : A) → μ a e == a

module ConnectedHSpace {i} (A : Type i) (c : is-connected ⟨0⟩ A)
  (hA : HSpaceStructure A) where

  open HSpaceStructure hA

  {-
  Given that [A] is 0-connected, to prove that each [μ a] is an equivalence we
  only need to prove that one of them is. But for [a] = [e], [μ a] is the
  identity so we’re done.
  -}

  μ-is-equiv : (a : A) → is-equiv (μ a)
  μ-is-equiv = prop-over-connected {a = e} c
    (λ a → (is-equiv (μ a) , is-equiv-is-prop (μ a)))
    (transport! is-equiv (λ= μe-) (idf-is-equiv A))

  μ'-is-equiv : (a : A) → is-equiv (λ a' → μ a' a)
  μ'-is-equiv = prop-over-connected {a = e} c
    (λ a → (is-equiv (λ a' → μ a' a) , is-equiv-is-prop (λ a' → μ a' a)))
    (transport! is-equiv (λ= μ-e) (idf-is-equiv A))

  μ-equiv : A → A ≃ A
  μ-equiv a = (μ a , μ-is-equiv a)

  μ'-equiv : A → A ≃ A
  μ'-equiv a = ((λ a' → μ a' a) , μ'-is-equiv a)


{-# OPTIONS --verbose=10 #-}

module inorder where

  open import Data.Nat
  open import Data.Vec
  open import Agda.Builtin.Sigma
  open import Data.Product
  open import Data.Fin using (fromℕ)

  open import trees
  open import optics
  open import lemmas

  inorderTree : {A : Set} -> Tree A -> Σ[ n ∈ ℕ ] Vec A n × (Vec A n -> Tree A)
  inorderTree empty = (0 , ([] , λ _ -> empty))
  inorderTree {A} (node t x t₁) with inorderTree t | inorderTree t₁
  ...                              | (n₁ , (g₁ , p₁)) | (n₂ , (g₂ , p₂)) =
    (n₁ + (1 + n₂) , (g₁ ++ (x ∷ g₂) ,
      λ v -> node (p₁ (take n₁ v)) (head (drop n₁ v)) (righttree v)))
      where
        righttree :  Vec A (n₁ + (1 + n₂)) -> Tree A
        -- righttree v = p₂ (drop 1 (drop n₁ v))
        righttree v rewrite +-suc n₁ n₂ = p₂ (drop (1 + n₁) v)

  inorder : {A : Set} -> Traversal (Tree A) (Tree A) A A
  inorder = record{ extract = inorderTree }

  module tests where
    tree1 : Tree ℕ
    tree1 = node (node empty 1 empty) 3 empty

    open Traversal

    inorder1 : Vec ℕ 2
    inorder1 = get inorder tree1

    updatedinorder1 : Tree ℕ
    updatedinorder1 = put inorder tree1  (2 ∷ 3 ∷ [])


------------------------------------------------------------------------------
-- The gcd program is correct
------------------------------------------------------------------------------

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

-- This module proves the correctness of the gcd program using
-- the Euclid's algorithm.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.GCD.Partial.CorrectnessProofATP where

open import FOTC.Base
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP using ( 0∤x ; x∣S→x≤S )
open import FOTC.Data.Nat.Type
open import FOTC.Program.GCD.Partial.CommonDivisorATP using ( gcdCD )
open import FOTC.Program.GCD.Partial.Definitions using ( x≢0≢y ; gcdSpec )
open import FOTC.Program.GCD.Partial.DivisibleATP using ( gcdDivisible )
open import FOTC.Program.GCD.Partial.GCD using ( gcd )

import FOTC.Program.GCD.Partial.GreatestAnyCommonDivisor
open module GreatestAnyCommonDivisorATP =
  FOTC.Program.GCD.Partial.GreatestAnyCommonDivisor x∣S→x≤S 0∤x
  using ( gcdGACD )

open import FOTC.Program.GCD.Partial.TotalityATP using ( gcd-N )

------------------------------------------------------------------------------
-- The gcd is correct.
postulate gcdCorrect : ∀ {m n} → N m → N n → x≢0≢y m n → gcdSpec m n (gcd m n)
{-# ATP prove gcdCorrect gcdCD gcdGACD gcd-N gcdDivisible #-}


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

open import LogicalFormulae
open import Monoids.Definition

module Semirings.Definition where

record Semiring {a : _} {A : Set a} (Zero One : A) (_+_ : A → A → A) (_*_ : A → A → A) : Set a where
  field
    monoid : Monoid Zero _+_
    commutative : (a b : A) → a + b ≡ b + a
    multMonoid : Monoid One _*_
    productZeroLeft : (a : A) → Zero * a ≡ Zero
    productZeroRight : (a : A) → a * Zero ≡ Zero
    +DistributesOver* : (a b c : A) → a * (b + c) ≡ (a * b) + (a * c)
    +DistributesOver*' : (a b c : A) → (a + b) * c ≡ (a * c) + (b * c)
  +Associative = Monoid.associative monoid
  *Associative = Monoid.associative multMonoid
  productOneLeft = Monoid.idLeft multMonoid
  productOneRight = Monoid.idRight multMonoid
  sumZeroLeft = Monoid.idLeft monoid
  sumZeroRight = Monoid.idRight monoid
  +WellDefined : {a b c d : A} → (a ≡ c) → (b ≡ d) → (a + b) ≡ (c + d)
  +WellDefined refl refl = refl

-- (b+c)(a+a) == b(a+a) + c(a+a) == ba+ba+ca+ca == (ba+ca) + (ba+ca)
-- (b+c)(a+a) ==? (b+c)a+(b+c)a


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

module Fragment.Setoid.Morphism.Setoid where

open import Fragment.Setoid.Morphism.Base

open import Level using (Level; _⊔_)
open import Relation.Binary using (Setoid; IsEquivalence; Rel)

private
  variable
    a b ℓ₁ ℓ₂ : Level

module _ {S : Setoid a ℓ₁} {T : Setoid b ℓ₂} where

  open Setoid T

  infix 4 _≗_

  _≗_ : Rel (S ↝ T) (a ⊔ ℓ₂)
  f ≗ g = ∀ {x} → ∣ f ∣ x ≈ ∣ g ∣ x

  ≗-refl : ∀ {f} → f ≗ f
  ≗-refl = refl

  ≗-sym : ∀ {f g} → f ≗ g → g ≗ f
  ≗-sym f≗g {x} = sym (f≗g {x})

  ≗-trans : ∀ {f g h} → f ≗ g → g ≗ h → f ≗ h
  ≗-trans f≗g g≗h {x} = trans (f≗g {x}) (g≗h {x})

  ≗-isEquivalence : IsEquivalence _≗_
  ≗-isEquivalence = record { refl  = λ {f} → ≗-refl {f}
                           ; sym   = λ {f g} → ≗-sym {f} {g}
                           ; trans = λ {f g h} → ≗-trans {f} {g} {h}
                           }

_↝_/≗ : Setoid a ℓ₁ → Setoid b ℓ₂ → Setoid _ _
S ↝ T /≗ = record { Carrier       = S ↝ T
                  ; _≈_           = _≗_
                  ; isEquivalence = ≗-isEquivalence
                  }