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

module 06-universes where

import 05-identity-types
open 05-identity-types public

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

-- Section 6.3 Observational equality on the natural numbers

-- Definition 6.3.1

Eq-ℕ : ℕ → ℕ → UU lzero
Eq-ℕ zero-ℕ zero-ℕ = 𝟙
Eq-ℕ zero-ℕ (succ-ℕ n) = 𝟘
Eq-ℕ (succ-ℕ m) zero-ℕ = 𝟘
Eq-ℕ (succ-ℕ m) (succ-ℕ n) = Eq-ℕ m n

-- Lemma 6.3.2

refl-Eq-ℕ : (n : ℕ) → Eq-ℕ n n
refl-Eq-ℕ zero-ℕ = star
refl-Eq-ℕ (succ-ℕ n) = refl-Eq-ℕ n

-- Proposition 6.3.3

Eq-ℕ-eq : {x y : ℕ} → Id x y → Eq-ℕ x y
Eq-ℕ-eq {x} {.x} refl = refl-Eq-ℕ x

eq-Eq-ℕ : (x y : ℕ) → Eq-ℕ x y → Id x y
eq-Eq-ℕ zero-ℕ zero-ℕ e = refl
eq-Eq-ℕ (succ-ℕ x) (succ-ℕ y) e = ap succ-ℕ (eq-Eq-ℕ x y e)

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

-- Section 6.4 Peano's seventh and eighth axioms

-- Theorem 6.4.1

is-injective-succ-ℕ : (x y : ℕ) → Id (succ-ℕ x) (succ-ℕ y) → Id x y
is-injective-succ-ℕ x y e = eq-Eq-ℕ x y (Eq-ℕ-eq e)

Peano-7 :
  (x y : ℕ) →
  ((Id x y) → (Id (succ-ℕ x) (succ-ℕ y))) ×
  ((Id (succ-ℕ x) (succ-ℕ y)) → (Id x y))
Peano-7 x y = pair (ap succ-ℕ) (is-injective-succ-ℕ x y)

-- Theorem 6.4.2

Peano-8 :
  (x : ℕ) → ¬ (Id zero-ℕ (succ-ℕ x))
Peano-8 x p = Eq-ℕ-eq p

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

-- Exercises

-- Exercise 6.1

-- Exercise 6.1 (a)

is-injective-add-ℕ :
  (k m n : ℕ) → Id (add-ℕ m k) (add-ℕ n k) → Id m n
is-injective-add-ℕ zero-ℕ m n = id
is-injective-add-ℕ (succ-ℕ k) m n p =
  is-injective-add-ℕ k m n (is-injective-succ-ℕ (add-ℕ m k) (add-ℕ n k) p)

-- Exercise 6.1 (b)

is-injective-mul-ℕ :
  (k m n : ℕ) → Id (mul-ℕ m (succ-ℕ k)) (mul-ℕ n (succ-ℕ k)) → Id m n
is-injective-mul-ℕ k zero-ℕ zero-ℕ p = refl
is-injective-mul-ℕ k (succ-ℕ m) (succ-ℕ n) p =
  ap succ-ℕ
    ( is-injective-mul-ℕ k m n
      ( is-injective-add-ℕ
        ( succ-ℕ k)
        ( mul-ℕ m (succ-ℕ k))
        ( mul-ℕ n (succ-ℕ k))
        ( ( inv (left-successor-law-mul-ℕ m (succ-ℕ k))) ∙
          ( ( p) ∙
            ( left-successor-law-mul-ℕ n (succ-ℕ k))))))

-- Exercise 6.1 (c)

neq-add-ℕ :
  (m n : ℕ) → ¬ (Id m (add-ℕ m (succ-ℕ n)))
neq-add-ℕ (succ-ℕ m) n p =
  neq-add-ℕ m n
    ( ( is-injective-succ-ℕ m (add-ℕ (succ-ℕ m) n) p) ∙
      ( left-successor-law-add-ℕ m n))

-- Exercise 6.1 (d)

neq-mul-ℕ :
  (m n : ℕ) → ¬ (Id (succ-ℕ m) (mul-ℕ (succ-ℕ m) (succ-ℕ (succ-ℕ n))))
neq-mul-ℕ m n p =
  neq-add-ℕ
    ( succ-ℕ m)
    ( add-ℕ (mul-ℕ m (succ-ℕ n)) n)
    ( ( p) ∙
      ( ( right-successor-law-mul-ℕ (succ-ℕ m) (succ-ℕ n)) ∙
        ( ap (add-ℕ (succ-ℕ m)) (left-successor-law-mul-ℕ m (succ-ℕ n)))))

-- Exercise 6.2

-- Exercise 6.2 (a)

Eq-𝟚 : bool → bool → UU lzero
Eq-𝟚 true true = unit
Eq-𝟚 true false = empty
Eq-𝟚 false true = empty
Eq-𝟚 false false = unit

-- Exercise 6.2 (b)

reflexive-Eq-𝟚 : (x : bool) → Eq-𝟚 x x
reflexive-Eq-𝟚 true = star
reflexive-Eq-𝟚 false = star

Eq-eq-𝟚 :
  {x y : bool} → Id x y → Eq-𝟚 x y
Eq-eq-𝟚 {x = x} refl = reflexive-Eq-𝟚 x

eq-Eq-𝟚 :
  {x y : bool} → Eq-𝟚 x y → Id x y
eq-Eq-𝟚 {true} {true} star = refl
eq-Eq-𝟚 {false} {false} star = refl

-- Exercise 6.2 (c)

neq-neg-𝟚 : (b : bool) → ¬ (Id b (neg-𝟚 b))
neq-neg-𝟚 true = Eq-eq-𝟚
neq-neg-𝟚 false = Eq-eq-𝟚

neq-false-true-𝟚 :
  ¬ (Id false true)
neq-false-true-𝟚 = Eq-eq-𝟚

-- Exercise 6.3

-- Exercise 6.3 (a)

leq-ℕ : ℕ → ℕ → UU lzero
leq-ℕ zero-ℕ m = unit
leq-ℕ (succ-ℕ n) zero-ℕ = empty
leq-ℕ (succ-ℕ n) (succ-ℕ m) = leq-ℕ n m

_≤_ = leq-ℕ

-- Some trivialities that will be useful later

leq-zero-ℕ :
  (n : ℕ) → leq-ℕ zero-ℕ n
leq-zero-ℕ n = star

eq-leq-zero-ℕ :
  (x : ℕ) → leq-ℕ x zero-ℕ → Id zero-ℕ x
eq-leq-zero-ℕ zero-ℕ star = refl

succ-leq-ℕ : (n : ℕ) → leq-ℕ n (succ-ℕ n)
succ-leq-ℕ zero-ℕ = star
succ-leq-ℕ (succ-ℕ n) = succ-leq-ℕ n

concatenate-eq-leq-eq-ℕ :
  {x1 x2 x3 x4 : ℕ} → Id x1 x2 → leq-ℕ x2 x3 → Id x3 x4 → leq-ℕ x1 x4
concatenate-eq-leq-eq-ℕ refl H refl = H

concatenate-leq-eq-ℕ :
  (m : ℕ) {n n' : ℕ} → leq-ℕ m n → Id n n' → leq-ℕ m n'
concatenate-leq-eq-ℕ m H refl = H

concatenate-eq-leq-ℕ :
  {m m' : ℕ} (n : ℕ) → Id m' m → leq-ℕ m n → leq-ℕ m' n
concatenate-eq-leq-ℕ n refl H = H

-- Exercise 6.3 (b)

reflexive-leq-ℕ : (n : ℕ) → leq-ℕ n n
reflexive-leq-ℕ zero-ℕ = star
reflexive-leq-ℕ (succ-ℕ n) = reflexive-leq-ℕ n

leq-eq-ℕ : (m n : ℕ) → Id m n → leq-ℕ m n
leq-eq-ℕ m .m refl = reflexive-leq-ℕ m

transitive-leq-ℕ :
  (n m l : ℕ) → (n ≤ m) → (m ≤ l) → (n ≤ l)
transitive-leq-ℕ zero-ℕ m l p q = star
transitive-leq-ℕ (succ-ℕ n) (succ-ℕ m) (succ-ℕ l) p q =
  transitive-leq-ℕ n m l p q

preserves-leq-succ-ℕ :
  (m n : ℕ) → leq-ℕ m n → leq-ℕ m (succ-ℕ n)
preserves-leq-succ-ℕ m n p = transitive-leq-ℕ m n (succ-ℕ n) p (succ-leq-ℕ n)

anti-symmetric-leq-ℕ : (m n : ℕ) → leq-ℕ m n → leq-ℕ n m → Id m n
anti-symmetric-leq-ℕ zero-ℕ zero-ℕ p q = refl
anti-symmetric-leq-ℕ (succ-ℕ m) (succ-ℕ n) p q =
  ap succ-ℕ (anti-symmetric-leq-ℕ m n p q)

-- Exercise 6.3 (c)

decide-leq-ℕ :
  (m n : ℕ) → coprod (leq-ℕ m n) (leq-ℕ n m)
decide-leq-ℕ zero-ℕ zero-ℕ = inl star
decide-leq-ℕ zero-ℕ (succ-ℕ n) = inl star
decide-leq-ℕ (succ-ℕ m) zero-ℕ = inr star
decide-leq-ℕ (succ-ℕ m) (succ-ℕ n) = decide-leq-ℕ m n

-- Exercise 6.3 (d)

preserves-order-add-ℕ :
  (k m n : ℕ) → leq-ℕ m n → leq-ℕ (add-ℕ m k) (add-ℕ n k)
preserves-order-add-ℕ zero-ℕ m n = id
preserves-order-add-ℕ (succ-ℕ k) m n = preserves-order-add-ℕ k m n

reflects-order-add-ℕ :
  (k m n : ℕ) → leq-ℕ (add-ℕ m k) (add-ℕ n k) → leq-ℕ m n
reflects-order-add-ℕ zero-ℕ m n = id
reflects-order-add-ℕ (succ-ℕ k) m n = reflects-order-add-ℕ k m n

-- Exercise 6.3 (e)

preserves-order-mul-ℕ :
  (k m n : ℕ) → leq-ℕ m n → leq-ℕ (mul-ℕ m k) (mul-ℕ n k)
preserves-order-mul-ℕ k zero-ℕ n p = star
preserves-order-mul-ℕ k (succ-ℕ m) (succ-ℕ n) p =
  preserves-order-add-ℕ k
    ( mul-ℕ m k)
    ( mul-ℕ n k)
    ( preserves-order-mul-ℕ k m n p)

reflects-order-mul-ℕ :
  (k m n : ℕ) → leq-ℕ (mul-ℕ m (succ-ℕ k)) (mul-ℕ n (succ-ℕ k)) → leq-ℕ m n
reflects-order-mul-ℕ k zero-ℕ n p = star
reflects-order-mul-ℕ k (succ-ℕ m) (succ-ℕ n) p =
  reflects-order-mul-ℕ k m n
    ( reflects-order-add-ℕ
      ( succ-ℕ k)
      ( mul-ℕ m (succ-ℕ k))
      ( mul-ℕ n (succ-ℕ k))
      ( p))

-- Exercise 6.3 (f)

leq-min-ℕ :
  (k m n : ℕ) → leq-ℕ k m → leq-ℕ k n → leq-ℕ k (min-ℕ m n)
leq-min-ℕ zero-ℕ zero-ℕ zero-ℕ H K = star
leq-min-ℕ zero-ℕ zero-ℕ (succ-ℕ n) H K = star
leq-min-ℕ zero-ℕ (succ-ℕ m) zero-ℕ H K = star
leq-min-ℕ zero-ℕ (succ-ℕ m) (succ-ℕ n) H K = star
leq-min-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H K = leq-min-ℕ k m n H K

leq-left-leq-min-ℕ :
  (k m n : ℕ) → leq-ℕ k (min-ℕ m n) → leq-ℕ k m
leq-left-leq-min-ℕ zero-ℕ zero-ℕ zero-ℕ H = star
leq-left-leq-min-ℕ zero-ℕ zero-ℕ (succ-ℕ n) H = star
leq-left-leq-min-ℕ zero-ℕ (succ-ℕ m) zero-ℕ H = star
leq-left-leq-min-ℕ zero-ℕ (succ-ℕ m) (succ-ℕ n) H = star
leq-left-leq-min-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H =
  leq-left-leq-min-ℕ k m n H

leq-right-leq-min-ℕ :
  (k m n : ℕ) → leq-ℕ k (min-ℕ m n) → leq-ℕ k n
leq-right-leq-min-ℕ zero-ℕ zero-ℕ zero-ℕ H = star
leq-right-leq-min-ℕ zero-ℕ zero-ℕ (succ-ℕ n) H = star
leq-right-leq-min-ℕ zero-ℕ (succ-ℕ m) zero-ℕ H = star
leq-right-leq-min-ℕ zero-ℕ (succ-ℕ m) (succ-ℕ n) H = star
leq-right-leq-min-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H =
  leq-right-leq-min-ℕ k m n H

leq-max-ℕ :
  (k m n : ℕ) → leq-ℕ m k → leq-ℕ n k → leq-ℕ (max-ℕ m n) k
leq-max-ℕ zero-ℕ zero-ℕ zero-ℕ H K = star
leq-max-ℕ (succ-ℕ k) zero-ℕ zero-ℕ H K = star
leq-max-ℕ (succ-ℕ k) zero-ℕ (succ-ℕ n) H K = K
leq-max-ℕ (succ-ℕ k) (succ-ℕ m) zero-ℕ H K = H
leq-max-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H K = leq-max-ℕ k m n H K

leq-left-leq-max-ℕ :
  (k m n : ℕ) → leq-ℕ (max-ℕ m n) k → leq-ℕ m k
leq-left-leq-max-ℕ k zero-ℕ zero-ℕ H = star
leq-left-leq-max-ℕ k zero-ℕ (succ-ℕ n) H = star
leq-left-leq-max-ℕ k (succ-ℕ m) zero-ℕ H = H
leq-left-leq-max-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H =
  leq-left-leq-max-ℕ k m n H

leq-right-leq-max-ℕ :
  (k m n : ℕ) → leq-ℕ (max-ℕ m n) k → leq-ℕ n k
leq-right-leq-max-ℕ k zero-ℕ zero-ℕ H = star
leq-right-leq-max-ℕ k zero-ℕ (succ-ℕ n) H = H
leq-right-leq-max-ℕ k (succ-ℕ m) zero-ℕ H = star
leq-right-leq-max-ℕ (succ-ℕ k) (succ-ℕ m) (succ-ℕ n) H =
  leq-right-leq-max-ℕ k m n H

-- Exercise 6.4

-- Exercise 6.4 (a)

-- We define a distance function on ℕ --

dist-ℕ : ℕ → ℕ → ℕ
dist-ℕ zero-ℕ n = n
dist-ℕ (succ-ℕ m) zero-ℕ = succ-ℕ m
dist-ℕ (succ-ℕ m) (succ-ℕ n) = dist-ℕ m n

dist-ℕ' : ℕ → ℕ → ℕ
dist-ℕ' m n = dist-ℕ n m

ap-dist-ℕ :
  {m n m' n' : ℕ} → Id m m' → Id n n' → Id (dist-ℕ m n) (dist-ℕ m' n')
ap-dist-ℕ refl refl = refl

{- We show that two natural numbers are equal if and only if their distance is
   zero. -}

eq-dist-ℕ :
  (m n : ℕ) → Id zero-ℕ (dist-ℕ m n) → Id m n
eq-dist-ℕ zero-ℕ zero-ℕ p = refl
eq-dist-ℕ (succ-ℕ m) (succ-ℕ n) p = ap succ-ℕ (eq-dist-ℕ m n p)

dist-eq-ℕ' :
  (n : ℕ) → Id zero-ℕ (dist-ℕ n n)
dist-eq-ℕ' zero-ℕ = refl
dist-eq-ℕ' (succ-ℕ n) = dist-eq-ℕ' n

dist-eq-ℕ :
  (m n : ℕ) → Id m n → Id zero-ℕ (dist-ℕ m n)
dist-eq-ℕ m .m refl = dist-eq-ℕ' m

-- The distance function is symmetric --

symmetric-dist-ℕ :
  (m n : ℕ) → Id (dist-ℕ m n) (dist-ℕ n m)
symmetric-dist-ℕ zero-ℕ zero-ℕ = refl
symmetric-dist-ℕ zero-ℕ (succ-ℕ n) = refl
symmetric-dist-ℕ (succ-ℕ m) zero-ℕ = refl
symmetric-dist-ℕ (succ-ℕ m) (succ-ℕ n) = symmetric-dist-ℕ m n

-- We compute the distance from zero --

left-zero-law-dist-ℕ :
  (n : ℕ) → Id (dist-ℕ zero-ℕ n) n
left-zero-law-dist-ℕ zero-ℕ = refl
left-zero-law-dist-ℕ (succ-ℕ n) = refl

right-zero-law-dist-ℕ :
  (n : ℕ) → Id (dist-ℕ n zero-ℕ) n
right-zero-law-dist-ℕ zero-ℕ = refl
right-zero-law-dist-ℕ (succ-ℕ n) = refl

-- We prove the triangle inequality --

ap-add-ℕ :
  {m n m' n' : ℕ} → Id m m' → Id n n' → Id (add-ℕ m n) (add-ℕ m' n')
ap-add-ℕ refl refl = refl

triangle-inequality-dist-ℕ :
  (m n k : ℕ) → leq-ℕ (dist-ℕ m n) (add-ℕ (dist-ℕ m k) (dist-ℕ k n))
triangle-inequality-dist-ℕ zero-ℕ zero-ℕ zero-ℕ = star
triangle-inequality-dist-ℕ zero-ℕ zero-ℕ (succ-ℕ k) = star
triangle-inequality-dist-ℕ zero-ℕ (succ-ℕ n) zero-ℕ =
  tr ( leq-ℕ (succ-ℕ n))
     ( inv (left-unit-law-add-ℕ (succ-ℕ n)))
     ( reflexive-leq-ℕ (succ-ℕ n))
triangle-inequality-dist-ℕ zero-ℕ (succ-ℕ n) (succ-ℕ k) =
  concatenate-eq-leq-eq-ℕ
    ( inv (ap succ-ℕ (left-zero-law-dist-ℕ n)))
    ( triangle-inequality-dist-ℕ zero-ℕ n k)
    ( ( ap (succ-ℕ ∘ (add-ℕ' (dist-ℕ k n))) (left-zero-law-dist-ℕ k)) ∙
      ( inv (left-successor-law-add-ℕ k (dist-ℕ k n))))
triangle-inequality-dist-ℕ (succ-ℕ m) zero-ℕ zero-ℕ = reflexive-leq-ℕ (succ-ℕ m)
triangle-inequality-dist-ℕ (succ-ℕ m) zero-ℕ (succ-ℕ k) =
  concatenate-eq-leq-eq-ℕ
    ( inv (ap succ-ℕ (right-zero-law-dist-ℕ m)))
    ( triangle-inequality-dist-ℕ m zero-ℕ k)
    ( ap (succ-ℕ ∘ (add-ℕ (dist-ℕ m k))) (right-zero-law-dist-ℕ k))
triangle-inequality-dist-ℕ (succ-ℕ m) (succ-ℕ n) zero-ℕ =
  concatenate-leq-eq-ℕ
    ( dist-ℕ m n)
    ( transitive-leq-ℕ
      ( dist-ℕ m n)
      ( succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))
      ( succ-ℕ (succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))))
      ( transitive-leq-ℕ
        ( dist-ℕ m n)
        ( add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))
        ( succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))
        ( triangle-inequality-dist-ℕ m n zero-ℕ)
        ( succ-leq-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))))
      ( succ-leq-ℕ (succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))))
    ( ( ap (succ-ℕ ∘ succ-ℕ)
           ( ap-add-ℕ (right-zero-law-dist-ℕ m) (left-zero-law-dist-ℕ n))) ∙
      ( inv (left-successor-law-add-ℕ m (succ-ℕ n))))
triangle-inequality-dist-ℕ (succ-ℕ m) (succ-ℕ n) (succ-ℕ k) =
  triangle-inequality-dist-ℕ m n k

-- We show that dist-ℕ x y is a solution to a simple equation.

leq-dist-ℕ :
  (x y : ℕ) → leq-ℕ x y → Id (add-ℕ x (dist-ℕ x y)) y
leq-dist-ℕ zero-ℕ zero-ℕ H = refl
leq-dist-ℕ zero-ℕ (succ-ℕ y) star = left-unit-law-add-ℕ (succ-ℕ y)
leq-dist-ℕ (succ-ℕ x) (succ-ℕ y) H =
  ( left-successor-law-add-ℕ x (dist-ℕ x y)) ∙
  ( ap succ-ℕ (leq-dist-ℕ x y H))

rewrite-left-add-dist-ℕ :
  (x y z : ℕ) → Id (add-ℕ x y) z → Id x (dist-ℕ y z)
rewrite-left-add-dist-ℕ zero-ℕ zero-ℕ .zero-ℕ refl = refl
rewrite-left-add-dist-ℕ zero-ℕ (succ-ℕ y) .(succ-ℕ (add-ℕ zero-ℕ y)) refl =
  ( dist-eq-ℕ' y) ∙
  ( inv (ap (dist-ℕ (succ-ℕ y)) (left-unit-law-add-ℕ (succ-ℕ y))))
rewrite-left-add-dist-ℕ (succ-ℕ x) zero-ℕ .(succ-ℕ x) refl = refl
rewrite-left-add-dist-ℕ
  (succ-ℕ x) (succ-ℕ y) .(succ-ℕ (add-ℕ (succ-ℕ x) y)) refl =
  rewrite-left-add-dist-ℕ (succ-ℕ x) y (add-ℕ (succ-ℕ x) y) refl

rewrite-left-dist-add-ℕ :
  (x y z : ℕ) → leq-ℕ y z → Id x (dist-ℕ y z) → Id (add-ℕ x y) z
rewrite-left-dist-add-ℕ .(dist-ℕ y z) y z H refl =
  ( commutative-add-ℕ (dist-ℕ y z) y) ∙
  ( leq-dist-ℕ y z H)

rewrite-right-add-dist-ℕ :
  (x y z : ℕ) → Id (add-ℕ x y) z → Id y (dist-ℕ x z)
rewrite-right-add-dist-ℕ x y z p =
  rewrite-left-add-dist-ℕ y x z (commutative-add-ℕ y x ∙ p)

rewrite-right-dist-add-ℕ :
  (x y z : ℕ) → leq-ℕ x z → Id y (dist-ℕ x z) → Id (add-ℕ x y) z
rewrite-right-dist-add-ℕ x .(dist-ℕ x z) z H refl =
  leq-dist-ℕ x z H

-- We show that dist-ℕ is translation invariant

translation-invariant-dist-ℕ :
  (k m n : ℕ) → Id (dist-ℕ (add-ℕ k m) (add-ℕ k n)) (dist-ℕ m n)
translation-invariant-dist-ℕ zero-ℕ m n =
  ap-dist-ℕ (left-unit-law-add-ℕ m) (left-unit-law-add-ℕ n)
translation-invariant-dist-ℕ (succ-ℕ k)  m n =
  ( ap-dist-ℕ (left-successor-law-add-ℕ k m) (left-successor-law-add-ℕ k n)) ∙
  ( translation-invariant-dist-ℕ k m n)

-- We show that dist-ℕ is linear with respect to scalar multiplication

linear-dist-ℕ :
  (m n k : ℕ) → Id (dist-ℕ (mul-ℕ k m) (mul-ℕ k n)) (mul-ℕ k (dist-ℕ m n))
linear-dist-ℕ zero-ℕ zero-ℕ zero-ℕ = refl
linear-dist-ℕ zero-ℕ zero-ℕ (succ-ℕ k) = linear-dist-ℕ zero-ℕ zero-ℕ k
linear-dist-ℕ zero-ℕ (succ-ℕ n) zero-ℕ = refl
linear-dist-ℕ zero-ℕ (succ-ℕ n) (succ-ℕ k) =
  ap (dist-ℕ' (mul-ℕ (succ-ℕ k) (succ-ℕ n))) (right-zero-law-mul-ℕ (succ-ℕ k))
linear-dist-ℕ (succ-ℕ m) zero-ℕ zero-ℕ = refl
linear-dist-ℕ (succ-ℕ m) zero-ℕ (succ-ℕ k) =
  ap (dist-ℕ (mul-ℕ (succ-ℕ k) (succ-ℕ m))) (right-zero-law-mul-ℕ (succ-ℕ k))
linear-dist-ℕ (succ-ℕ m) (succ-ℕ n) zero-ℕ = refl
linear-dist-ℕ (succ-ℕ m) (succ-ℕ n) (succ-ℕ k) =
  ( ap-dist-ℕ
    ( right-successor-law-mul-ℕ (succ-ℕ k) m)
    ( right-successor-law-mul-ℕ (succ-ℕ k) n)) ∙
  ( ( translation-invariant-dist-ℕ
      ( succ-ℕ k)
      ( mul-ℕ (succ-ℕ k) m)
      ( mul-ℕ (succ-ℕ k) n)) ∙
    ( linear-dist-ℕ m n (succ-ℕ k)))

-- Exercise 6.6

{- In this exercise we were asked to define the relations ≤ and < on the
   integers. As a criterion of correctness, we were then also asked to show
   that the type of all integers l satisfying k ≤ l satisfy the induction
   principle of the natural numbers. -}

diff-ℤ : ℤ → ℤ → ℤ
diff-ℤ k l = add-ℤ (neg-ℤ k) l

is-non-negative-ℤ : ℤ → UU lzero
is-non-negative-ℤ (inl x) = empty
is-non-negative-ℤ (inr k) = unit

leq-ℤ : ℤ → ℤ → UU lzero
leq-ℤ k l = is-non-negative-ℤ (diff-ℤ k l)

reflexive-leq-ℤ : (k : ℤ) → leq-ℤ k k
reflexive-leq-ℤ k =
  tr is-non-negative-ℤ (inv (left-inverse-law-add-ℤ k)) star

is-non-negative-succ-ℤ :
  (k : ℤ) → is-non-negative-ℤ k → is-non-negative-ℤ (succ-ℤ k)
is-non-negative-succ-ℤ (inr (inl star)) p = star
is-non-negative-succ-ℤ (inr (inr x)) p = star

is-non-negative-add-ℤ :
  (k l : ℤ) →
  is-non-negative-ℤ k → is-non-negative-ℤ l → is-non-negative-ℤ (add-ℤ k l)
is-non-negative-add-ℤ (inr (inl star)) (inr (inl star)) p q = star
is-non-negative-add-ℤ (inr (inl star)) (inr (inr n)) p q = star
is-non-negative-add-ℤ (inr (inr zero-ℕ)) (inr (inl star)) p q = star
is-non-negative-add-ℤ (inr (inr (succ-ℕ n))) (inr (inl star)) star star =
  is-non-negative-succ-ℤ
    ( add-ℤ (inr (inr n)) (inr (inl star)))
    ( is-non-negative-add-ℤ (inr (inr n)) (inr (inl star)) star star)
is-non-negative-add-ℤ (inr (inr zero-ℕ)) (inr (inr m)) star star = star
is-non-negative-add-ℤ (inr (inr (succ-ℕ n))) (inr (inr m)) star star =
  is-non-negative-succ-ℤ
    ( add-ℤ (inr (inr n)) (inr (inr m)))
    ( is-non-negative-add-ℤ (inr (inr n)) (inr (inr m)) star star)

triangle-diff-ℤ :
  (k l m : ℤ) → Id (add-ℤ (diff-ℤ k l) (diff-ℤ l m)) (diff-ℤ k m)
triangle-diff-ℤ k l m =
  ( associative-add-ℤ (neg-ℤ k) l (diff-ℤ l m)) ∙
  ( ap
    ( add-ℤ (neg-ℤ k))
    ( ( inv (associative-add-ℤ l (neg-ℤ l) m)) ∙
      ( ( ap (λ x → add-ℤ x m) (right-inverse-law-add-ℤ l)) ∙
        ( left-unit-law-add-ℤ m))))

transitive-leq-ℤ : (k l m : ℤ) → leq-ℤ k l → leq-ℤ l m → leq-ℤ k m
transitive-leq-ℤ k l m p q =
  tr is-non-negative-ℤ
    ( triangle-diff-ℤ k l m)
    ( is-non-negative-add-ℤ
      ( add-ℤ (neg-ℤ k) l)
      ( add-ℤ (neg-ℤ l) m)
      ( p)
      ( q))

succ-leq-ℤ : (k : ℤ) → leq-ℤ k (succ-ℤ k)
succ-leq-ℤ k =
  tr is-non-negative-ℤ
    ( inv
      ( ( right-successor-law-add-ℤ (neg-ℤ k) k) ∙
        ( ap succ-ℤ (left-inverse-law-add-ℤ k))))
    ( star)

leq-ℤ-succ-leq-ℤ : (k l : ℤ) → leq-ℤ k l → leq-ℤ k (succ-ℤ l)
leq-ℤ-succ-leq-ℤ k l p = transitive-leq-ℤ k l (succ-ℤ l) p (succ-leq-ℤ l)

is-positive-ℤ : ℤ → UU lzero
is-positive-ℤ k = is-non-negative-ℤ (pred-ℤ k)

le-ℤ : ℤ → ℤ → UU lzero
le-ℤ (inl zero-ℕ) (inl x) = empty
le-ℤ (inl zero-ℕ) (inr y) = unit
le-ℤ (inl (succ-ℕ x)) (inl zero-ℕ) = unit
le-ℤ (inl (succ-ℕ x)) (inl (succ-ℕ y)) = le-ℤ (inl x) (inl y)
le-ℤ (inl (succ-ℕ x)) (inr y) = unit
le-ℤ (inr x) (inl y) = empty
le-ℤ (inr (inl star)) (inr (inl star)) = empty
le-ℤ (inr (inl star)) (inr (inr x)) = unit
le-ℤ (inr (inr x)) (inr (inl star)) = empty
le-ℤ (inr (inr zero-ℕ)) (inr (inr zero-ℕ)) = empty
le-ℤ (inr (inr zero-ℕ)) (inr (inr (succ-ℕ y))) = unit
le-ℤ (inr (inr (succ-ℕ x))) (inr (inr zero-ℕ)) = empty
le-ℤ (inr (inr (succ-ℕ x))) (inr (inr (succ-ℕ y))) =
  le-ℤ (inr (inr x)) (inr (inr y))

-- Extra material

-- We show that ℕ is an ordered semi-ring

left-law-leq-add-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (add-ℕ m k) (add-ℕ n k)
left-law-leq-add-ℕ zero-ℕ m n = id
left-law-leq-add-ℕ (succ-ℕ k) m n H = left-law-leq-add-ℕ k m n H

right-law-leq-add-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (add-ℕ k m) (add-ℕ k n)
right-law-leq-add-ℕ k m n H =
  concatenate-eq-leq-eq-ℕ
    ( commutative-add-ℕ k m)
    ( left-law-leq-add-ℕ k m n H)
    ( commutative-add-ℕ n k)

preserves-leq-add-ℕ :
  {m m' n n' : ℕ} → leq-ℕ m m' → leq-ℕ n n' → leq-ℕ (add-ℕ m n) (add-ℕ m' n')
preserves-leq-add-ℕ {m} {m'} {n} {n'} H K =
  transitive-leq-ℕ
    ( add-ℕ m n)
    ( add-ℕ m' n)
    ( add-ℕ m' n')
    ( left-law-leq-add-ℕ n m m' H)
    ( right-law-leq-add-ℕ m' n n' K)

{-
right-law-leq-mul-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (mul-ℕ k m) (mul-ℕ k n)
right-law-leq-mul-ℕ zero-ℕ m n H = star
right-law-leq-mul-ℕ (succ-ℕ k) m n H = {!!}
-}

{-
  preserves-leq-add-ℕ
    { m = mul-ℕ k m}
    { m' = mul-ℕ k n}
    ( right-law-leq-mul-ℕ k m n H) H

left-law-leq-mul-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (mul-ℕ m k) (mul-ℕ n k)
left-law-leq-mul-ℕ k m n H =
  concatenate-eq-leq-eq-ℕ
    ( commutative-mul-ℕ k m)
    ( commutative-mul-ℕ k n)
    ( right-law-leq-mul-ℕ k m n H)
-}

-- We show that ℤ is an ordered ring

{-
leq-add-ℤ : (m k l : ℤ) → leq-ℤ k l → leq-ℤ (add-ℤ m k) (add-ℤ m l)
leq-add-ℤ (inl zero-ℕ) k l H = {!!}
leq-add-ℤ (inl (succ-ℕ x)) k l H = {!!}
leq-add-ℤ (inr m) k l H = {!!}
-}

-- Section 5.5 Identity systems

succ-fam-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i) →
  (m n : ℕ) → Eq-ℕ m n → UU i
succ-fam-Eq-ℕ R m n e = R (succ-ℕ m) (succ-ℕ n) e

succ-refl-fam-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  (ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  (n : ℕ) → (succ-fam-Eq-ℕ R n n (refl-Eq-ℕ n))
succ-refl-fam-Eq-ℕ R ρ n = ρ (succ-ℕ n)

path-ind-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  ( ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  ( m n : ℕ) (e : Eq-ℕ m n) → R m n e
path-ind-Eq-ℕ R ρ zero-ℕ zero-ℕ star = ρ zero-ℕ
path-ind-Eq-ℕ R ρ zero-ℕ (succ-ℕ n) ()
path-ind-Eq-ℕ R ρ (succ-ℕ m) zero-ℕ ()
path-ind-Eq-ℕ R ρ (succ-ℕ m) (succ-ℕ n) e =
  path-ind-Eq-ℕ
    ( λ m n e → R (succ-ℕ m) (succ-ℕ n) e)
    ( λ n → ρ (succ-ℕ n)) m n e

comp-path-ind-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  ( ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  ( n : ℕ) → Id (path-ind-Eq-ℕ R ρ n n (refl-Eq-ℕ n)) (ρ n)
comp-path-ind-Eq-ℕ R ρ zero-ℕ = refl
comp-path-ind-Eq-ℕ R ρ (succ-ℕ n) =
  comp-path-ind-Eq-ℕ
    ( λ m n e → R (succ-ℕ m) (succ-ℕ n) e)
    ( λ n → ρ (succ-ℕ n)) n

{-
-- Graphs
Gph : (i : Level) → UU (lsuc i)
Gph i = Σ (UU i) (λ X → (X → X → (UU i)))

-- Reflexive graphs
rGph : (i : Level) →  UU (lsuc i)
rGph i = Σ (UU i) (λ X → Σ (X → X → (UU i)) (λ R → (x : X) → R x x))
-}

-- Exercise 3.7

{- With the construction of the divisibility relation we open the door to basic
   number theory. -}

divides : (d n : ℕ) → UU lzero
divides d n = Σ ℕ (λ m → Eq-ℕ (mul-ℕ d m) n)

-- We prove some lemmas about inequalities --

leq-add-ℕ :
  (m n : ℕ) → leq-ℕ m (add-ℕ m n)
leq-add-ℕ m zero-ℕ = reflexive-leq-ℕ m
leq-add-ℕ m (succ-ℕ n) =
  transitive-leq-ℕ m (add-ℕ m n) (succ-ℕ (add-ℕ m n))
    ( leq-add-ℕ m n)
    ( succ-leq-ℕ (add-ℕ m n))

leq-add-ℕ' :
  (m n : ℕ) → leq-ℕ m (add-ℕ n m)
leq-add-ℕ' m n =
  concatenate-leq-eq-ℕ m (leq-add-ℕ m n) (commutative-add-ℕ m n)

leq-leq-add-ℕ :
  (m n x : ℕ) → leq-ℕ (add-ℕ m x) (add-ℕ n x) → leq-ℕ m n
leq-leq-add-ℕ m n zero-ℕ H = H
leq-leq-add-ℕ m n (succ-ℕ x) H = leq-leq-add-ℕ m n x H

leq-leq-add-ℕ' :
  (m n x : ℕ) → leq-ℕ (add-ℕ x m) (add-ℕ x n) → leq-ℕ m n
leq-leq-add-ℕ' m n x H =
  leq-leq-add-ℕ m n x
    ( concatenate-eq-leq-eq-ℕ
      ( commutative-add-ℕ m x)
      ( H)
      ( commutative-add-ℕ x n))

leq-leq-mul-ℕ :
  (m n x : ℕ) → leq-ℕ (mul-ℕ (succ-ℕ x) m) (mul-ℕ (succ-ℕ x) n) → leq-ℕ m n
leq-leq-mul-ℕ zero-ℕ zero-ℕ x H = star
leq-leq-mul-ℕ zero-ℕ (succ-ℕ n) x H = star
leq-leq-mul-ℕ (succ-ℕ m) zero-ℕ x H =
  ex-falso
    ( concatenate-leq-eq-ℕ
      ( mul-ℕ (succ-ℕ x) (succ-ℕ m))
      ( H)
      ( right-zero-law-mul-ℕ (succ-ℕ x)))
leq-leq-mul-ℕ (succ-ℕ m) (succ-ℕ n) x H =
  leq-leq-mul-ℕ m n x
    ( leq-leq-add-ℕ' (mul-ℕ (succ-ℕ x) m) (mul-ℕ (succ-ℕ x) n) (succ-ℕ x)
      ( concatenate-eq-leq-eq-ℕ
        ( inv (right-successor-law-mul-ℕ (succ-ℕ x) m))
        ( H)
        ( right-successor-law-mul-ℕ (succ-ℕ x) n)))

leq-leq-mul-ℕ' :
  (m n x : ℕ) → leq-ℕ (mul-ℕ m (succ-ℕ x)) (mul-ℕ n (succ-ℕ x)) → leq-ℕ m n
leq-leq-mul-ℕ' m n x H =
  leq-leq-mul-ℕ m n x
    ( concatenate-eq-leq-eq-ℕ
      ( commutative-mul-ℕ (succ-ℕ x) m)
      ( H)
      ( commutative-mul-ℕ n (succ-ℕ x)))

{-
succ-relation-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) → ℕ → ℕ → UU i
succ-relation-ℕ R m n = R (succ-ℕ m) (succ-ℕ n)

succ-reflexivity-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) (ρ : (n : ℕ) → R n n) →
  (n : ℕ) → succ-relation-ℕ R n n
succ-reflexivity-ℕ R ρ n = ρ (succ-ℕ n)

{- In the book we suggest that first the order of the variables should be
   swapped, in order to make the inductive hypothesis stronger. Agda's pattern
   matching mechanism allows us to bypass this step and give a more direct
   construction. -}

least-reflexive-Eq-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) (ρ : (n : ℕ) → R n n) →
  (m n : ℕ) → Eq-ℕ m n → R m n
least-reflexive-Eq-ℕ R ρ zero-ℕ zero-ℕ star = ρ zero-ℕ
least-reflexive-Eq-ℕ R ρ zero-ℕ (succ-ℕ n) ()
least-reflexive-Eq-ℕ R ρ (succ-ℕ m) zero-ℕ ()
least-reflexive-Eq-ℕ R ρ (succ-ℕ m) (succ-ℕ n) e =
  least-reflexive-Eq-ℕ (succ-relation-ℕ R) (succ-reflexivity-ℕ R ρ) m n e
-}

-- The definition of <

le-ℕ : ℕ → ℕ → UU lzero
le-ℕ m zero-ℕ = empty
le-ℕ zero-ℕ (succ-ℕ m) = unit
le-ℕ (succ-ℕ n) (succ-ℕ m) = le-ℕ n m

_<_ = le-ℕ

anti-reflexive-le-ℕ : (n : ℕ) → ¬ (n < n)
anti-reflexive-le-ℕ zero-ℕ = ind-empty
anti-reflexive-le-ℕ (succ-ℕ n) = anti-reflexive-le-ℕ n

transitive-le-ℕ : (n m l : ℕ) → (le-ℕ n m) → (le-ℕ m l) → (le-ℕ n l)
transitive-le-ℕ zero-ℕ (succ-ℕ m) (succ-ℕ l) p q = star
transitive-le-ℕ (succ-ℕ n) (succ-ℕ m) (succ-ℕ l) p q =
  transitive-le-ℕ n m l p q

succ-le-ℕ : (n : ℕ) → le-ℕ n (succ-ℕ n)
succ-le-ℕ zero-ℕ = star
succ-le-ℕ (succ-ℕ n) = succ-le-ℕ n

anti-symmetric-le-ℕ : (m n : ℕ) → le-ℕ m n → le-ℕ n m → Id m n
anti-symmetric-le-ℕ (succ-ℕ m) (succ-ℕ n) p q =
  ap succ-ℕ (anti-symmetric-le-ℕ m n p q)

{-
--------------------------------------------------------------------------------

data Fin-Tree : UU lzero where
  constr : (n : ℕ) → (Fin n → Fin-Tree) → Fin-Tree

root-Fin-Tree : Fin-Tree
root-Fin-Tree = constr zero-ℕ ex-falso

succ-Fin-Tree : Fin-Tree → Fin-Tree
succ-Fin-Tree t = constr one-ℕ (λ i → t)

map-assoc-coprod :
  {l1 l2 l3 : Level} {A : UU l1} {B : UU l2} {C : UU l3} →
  coprod (coprod A B) C → coprod A (coprod B C)
map-assoc-coprod (inl (inl x)) = inl x
map-assoc-coprod (inl (inr x)) = inr (inl x)
map-assoc-coprod (inr x) = inr (inr x)

map-coprod-Fin :
  (m n : ℕ) → Fin (add-ℕ m n) → coprod (Fin m) (Fin n)
map-coprod-Fin m zero-ℕ = inl
map-coprod-Fin m (succ-ℕ n) =
  map-assoc-coprod ∘ (functor-coprod (map-coprod-Fin m n) (id {A = unit}))

add-Fin-Tree : Fin-Tree → Fin-Tree → Fin-Tree
add-Fin-Tree (constr n x) (constr m y) =
  constr (add-ℕ n m) ((ind-coprod (λ i → Fin-Tree) x y) ∘ (map-coprod-Fin n m))

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

data labeled-Bin-Tree {l1 : Level} (A : UU l1) : UU l1 where
  leaf : A → labeled-Bin-Tree A
  constr : (bool → labeled-Bin-Tree A) → labeled-Bin-Tree A

mul-leaves-labeled-Bin-Tree :
  {l1 : Level} {A : UU l1} (μ : A → (A → A)) →
  labeled-Bin-Tree A → A
mul-leaves-labeled-Bin-Tree μ (leaf x) = x
mul-leaves-labeled-Bin-Tree μ (constr f) =
  μ ( mul-leaves-labeled-Bin-Tree μ (f false))
    ( mul-leaves-labeled-Bin-Tree μ (f true))

pick-list : {l1 : Level} {A : UU l1} → ℕ → list A → coprod A unit
pick-list zero-ℕ nil = inr star
pick-list zero-ℕ (cons a x) = inl a
pick-list (succ-ℕ n) nil = inr star
pick-list (succ-ℕ n) (cons a x) = pick-list n x
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise table equality
------------------------------------------------------------------------

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

module Data.Table.Relation.Binary.Equality where

open import Relation.Binary using (Setoid)
open import Data.Table.Base
open import Data.Nat using (ℕ)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
  as P using (_≡_; _→-setoid_)

setoid : ∀ {c p} → Setoid c p → ℕ → Setoid _ _
setoid S n = record
  { Carrier = Table Carrier n
  ; _≈_ = λ t t′ → ∀ i → lookup t i ≈ lookup t′ i
  ; isEquivalence = record
    { refl  = λ i → refl
    ; sym   = λ p → sym ∘ p
    ; trans = λ p q i → trans (p i) (q i)
    }
  }
  where open Setoid S

≡-setoid : ∀ {a} → Set a → ℕ → Setoid _ _
≡-setoid A = setoid (P.setoid A)

module _ {a} {A : Set a} {n} where
  open Setoid (≡-setoid A n) public
    using () renaming (_≈_ to _≗_)


{-

Computable stuff constructed from the Combinatorics of Finite Sets

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

module Cubical.Experiments.Combinatorics where

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

open import Cubical.Data.Nat
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.Data.Fin
open import Cubical.Data.FinSet
open import Cubical.Data.FinSet.Constructors

open import Cubical.Functions.Embedding
open import Cubical.Functions.Surjection

-- some computable functions

-- this should be addtion
card+ : ℕ → ℕ → ℕ
card+ m n = card (Fin m ⊎ Fin n , isFinSet⊎ (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- this should be multiplication
card× : ℕ → ℕ → ℕ
card× m n = card (Fin m × Fin n , isFinSet× (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- this should be exponential
card→ : ℕ → ℕ → ℕ
card→ m n = card ((Fin m → Fin n) , isFinSet→ (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- this should be factorial or zero
card≃ : ℕ → ℕ → ℕ
card≃ m n = card ((Fin m ≃ Fin n) , isFinSet≃ (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- this should be binomial coeffient
card↪ : ℕ → ℕ → ℕ
card↪ m n = card ((Fin m ↪ Fin n) , isFinSet↪ (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- this should be something that I don't know the name
card↠ : ℕ → ℕ → ℕ
card↠ m n = card ((Fin m ↠ Fin n) , isFinSet↠ (Fin m , isFinSetFin) (Fin n , isFinSetFin))

-- explicit numbers

s2 : card≃ 2 2 ≡ 2
s2 = refl

s3 : card≃ 3 3 ≡ 6
s3 = refl

c3,2 : card↪ 2 3 ≡ 6
c3,2 = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Finite sets defined in terms of Data.Star
------------------------------------------------------------------------

module Data.Star.Fin where

open import Data.Star
open import Data.Star.Nat as ℕ using (ℕ)
open import Data.Star.Pointer
open import Data.Unit

-- Finite sets are undecorated pointers into natural numbers.

Fin : ℕ → Set
Fin = Any (λ _ → ⊤) (λ _ → ⊤)

-- "Constructors".

zero : ∀ {n} → Fin (ℕ.suc n)
zero = this tt

suc : ∀ {n} → Fin n → Fin (ℕ.suc n)
suc = that tt


module Data.FixedTree.Properties where

import      Lvl
open import Data using (Unit ; <>)
open import Data.Boolean
open import Data.FixedTree
open import Data.Tuple.Raise
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Functional as Fn
open import Logic.Propositional
open import Numeral.Finite
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Natural
open import Type

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

-- A tree is full when every node has no or all children.
data Full {L : Type{ℓₗ}}{N : Type{ℓₙ}}{n} : FixedTree(n) L N → Type{ℓₗ Lvl.⊔ ℓₙ} where
  leaf   : ∀{l} → Full(Leaf l)
  single : ∀{a}{l} → Full(Node a (Raise.repeat(n) (Leaf l))) -- TODO: All the leaves should not be forced to all have the same data
  step   : ∀{a : N}{ca : N ^ n}{cc : ((FixedTree(n) L N) ^ n) ^ n} → (∀{i : 𝕟(n)} → Full(Node (Raise.index i ca) (Raise.index i cc))) → Full(Node a (Raise.map₂{n} Node ca cc))
  -- step  : ∀{a : T}{ca : T ^ n}{cc : (FixedTree(n)(T) ^ n) ^ n} → Raise.reduceOrᵣ{n}(_⨯_) Unit (Raise.map₂(Full ∘₂ Node) ca cc) → Full(Node a (Raise.map₂{n} Node ca cc))

-- A tree is perfect at depth `n` when all leaves are at height `n`.
-- In other words, a tree is perfect when all leaves are at the same height.
data Perfect {L : Type{ℓₗ}}{N : Type{ℓₙ}}{n} : FixedTree(n) L N → ℕ → Type{ℓₗ Lvl.⊔ ℓₙ} where
  leaf : ∀{l} → Perfect(Leaf l)(𝟎)
  step : ∀{a}{c}{h} → (∀{i : 𝕟(n)} → Perfect(Raise.index i c)(h)) → Perfect(Node a c)(𝐒(h))

data Complete {L : Type{ℓₗ}}{N : Type{ℓₙ}}{n} : FixedTree(n) L N → ℕ → Bool → Type{ℓₗ Lvl.⊔ ℓₙ} where
  perfect-leaf : ∀{l} → Complete(Leaf l)(𝟎)(𝑇)
  imperfect-leaf : ∀{l} → Complete(Leaf l)(𝐒(𝟎))(𝐹)
  step : ∀{a}{c}{h}{t : 𝕟(n)} → (∀{i : 𝕟(n)} → Complete(Raise.index i c)(h)(i ≤? t)) → Complete(Node a c)(𝐒(h))(t ≤? maximum{n})

data DepthOrdered {L : Type{ℓₗ}}{N : Type{ℓₙ}} (_≤_ : N → N → Type{ℓₒ}) {n} : FixedTree(n) L N → Type{ℓₗ Lvl.⊔ ℓₙ Lvl.⊔ ℓₒ} where
  leaf : ∀{l} → DepthOrdered(_≤_)(Leaf l)
  step : ∀{p}{c : (FixedTree(n) L N) ^ n} → (∀{i : 𝕟(n)} → (\{(Leaf _) → Unit ; (Node a c) → (p ≤ a) ∧ DepthOrdered(_≤_)(Node a c)}) $ (Raise.index i c)) → DepthOrdered(_≤_)(Node p c)

Heap : ∀{L : Type{ℓₗ}}{N : Type{ℓₙ}} → (N → N → Type{ℓₒ}) → ∀{n} → FixedTree(n) L N → ℕ → Bool → Type
Heap(_≤_) tree height perfect = DepthOrdered(_≤_)(tree) ∧ Complete(tree)(height)(perfect)


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

open import Functions.Definition
open import Groups.Definition
open import Rings.Homomorphisms.Definition
open import Setoids.Setoids
open import Rings.Definition
open import Sets.EquivalenceRelations
open import Groups.Lemmas
open import Rings.Ideals.Definition

module Rings.Cosets {a b c : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) {pred : A → Set c} (ideal : Ideal R pred) where

open Ring R
open import Rings.Lemmas R
open import Groups.Subgroups.Normal.Lemmas

open import Groups.Cosets additiveGroup (Ideal.isSubgroup ideal)

open Setoid S
open Equivalence eq
open Ideal ideal
open Group additiveGroup

cosetRing : Ring cosetSetoid _+_ _*_
Ring.additiveGroup cosetRing = cosetGroup (abelianGroupSubgroupIsNormal (Ideal.isSubgroup ideal) abelianUnderlyingGroup)
Ring.*WellDefined cosetRing {r} {s} {t} {u} r=t s=u = need
  where
    r=t' : pred ((inverse t + r) * u)
    r=t' = accumulatesTimes r=t
    s=u' : pred ((inverse u + s) * r)
    s=u' = accumulatesTimes s=u
    need : pred (inverse (t * u) + (r * s))
    need = isSubset (transitive (+WellDefined (*DistributesOver+') *DistributesOver+') (transitive +Associative (+WellDefined (transitive (symmetric +Associative) (transitive (+WellDefined ringMinusExtracts' (transitive (+WellDefined reflexive (transitive ringMinusExtracts' (inverseWellDefined additiveGroup *Commutative))) invRight)) identRight)) *Commutative))) (closedUnderPlus r=t' s=u')
Ring.1R cosetRing = 1R
Ring.groupIsAbelian cosetRing = isSubset (transitive (symmetric invLeft) (+WellDefined (inverseWellDefined additiveGroup groupIsAbelian) reflexive)) containsIdentity
Ring.*Associative cosetRing = isSubset (transitive (symmetric invLeft) (+WellDefined (inverseWellDefined additiveGroup *Associative) reflexive)) containsIdentity
Ring.*Commutative cosetRing {a} {b} = isSubset (transitive (symmetric invLeft) (+WellDefined (inverseWellDefined additiveGroup *Commutative) reflexive)) containsIdentity
Ring.*DistributesOver+ cosetRing = isSubset (symmetric (transitive (+WellDefined (inverseWellDefined additiveGroup (symmetric *DistributesOver+)) reflexive) invLeft)) containsIdentity
Ring.identIsIdent cosetRing = isSubset (symmetric (transitive (Group.+WellDefined additiveGroup reflexive identIsIdent) invLeft)) containsIdentity

cosetRingHom : RingHom R cosetRing id
RingHom.preserves1 cosetRingHom = isSubset (symmetric invLeft) (Ideal.containsIdentity ideal)
RingHom.ringHom cosetRingHom = isSubset (symmetric invLeft) (Ideal.containsIdentity ideal)
RingHom.groupHom cosetRingHom = cosetGroupHom (abelianGroupSubgroupIsNormal (Ideal.isSubgroup ideal) abelianUnderlyingGroup)


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

open import LogicalFormulae
open import Semirings.Definition

module Semirings.Lemmas {a : _} {A : Set a} {Zero One : A} {_+_ _*_ : A → A → A} (S : Semiring Zero One _+_ _*_) where

open Semiring S

doubleIsAddTwo : (a : A) → (a + a) ≡ (One + One) * a
doubleIsAddTwo a = transitivity (equalityCommutative (+WellDefined (productOneLeft a) (productOneLeft a))) (equalityCommutative (+DistributesOver*' One One a))


open import Everything

module Test.Transassociativity where

test-transassociativity-≡ : ∀
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
  ⦃ _ : Transitivity.class _∼_ ⦄
  ⦃ _ : Transassociativity!.class _∼_ Proposequality ⦄
  → ∀ {w x y z} (f : w ∼ x) (g : x ∼ y) (h : y ∼ z) → (h ∙ g) ∙ f ≡ h ∙ g ∙ f
test-transassociativity-≡ f g h rewrite transassociativity![ Proposequality ] f g h = ∅ -- transassociativity


------------------------------------------------------------------------
-- The Agda standard library
--
-- Propositional equality
--
-- This file contains some core definitions which are re-exported by
-- Relation.Binary.PropositionalEquality.
------------------------------------------------------------------------

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

module Relation.Binary.PropositionalEquality.Core where

open import Data.Product using (_,_)
open import Level
open import Relation.Binary.Core
open import Relation.Nullary using (¬_)

------------------------------------------------------------------------
-- Propositional equality

open import Agda.Builtin.Equality public

infix 4 _≢_
_≢_ : ∀ {a} {A : Set a} → Rel A a
x ≢ y = ¬ x ≡ y

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

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

  sym : Symmetric {A = A} _≡_
  sym refl = refl

  trans : Transitive {A = A} _≡_
  trans refl eq = eq

  subst : ∀ {p} → Substitutive {A = A} _≡_ p
  subst P refl p = p

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

  respˡ : ∀ {ℓ} (∼ : Rel A ℓ) → ∼ Respectsˡ _≡_
  respˡ _∼_ refl x∼y = x∼y

  respʳ : ∀ {ℓ} (∼ : Rel A ℓ) → ∼ Respectsʳ _≡_
  respʳ _∼_ refl x∼y = x∼y

  resp₂ : ∀ {ℓ} (∼ : Rel A ℓ) → ∼ Respects₂ _≡_
  resp₂ _∼_ = respʳ _∼_ , respˡ _∼_

  isEquivalence : IsEquivalence {A = A} _≡_
  isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }

------------------------------------------------------------------------
-- Various equality rearrangement lemmas

module _ {a} {A : Set a} {x y : A} where

  trans-reflʳ : (p : x ≡ y) → trans p refl ≡ p
  trans-reflʳ refl = refl

  trans-assoc : ∀ {z u} (p : x ≡ y) {q : y ≡ z} {r : z ≡ u} →
    trans (trans p q) r ≡ trans p (trans q r)
  trans-assoc refl = refl

  trans-symˡ : (p : x ≡ y) → trans (sym p) p ≡ refl
  trans-symˡ refl = refl

  trans-symʳ : (p : x ≡ y) → trans p (sym p) ≡ refl
  trans-symʳ refl = refl

------------------------------------------------------------------------
-- Convenient syntax for equational reasoning

-- This is a special instance of `Relation.Binary.Reasoning.Setoid`.
-- Rather than instantiating the latter with (setoid A), we reimplement
-- equation chains from scratch since then goals are printed much more
-- readably.

module ≡-Reasoning {a} {A : Set a} where

  infix  3 _∎
  infixr 2 _≡⟨⟩_ _≡⟨_⟩_ _≡˘⟨_⟩_
  infix  1 begin_

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

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

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

  _≡˘⟨_⟩_ : ∀ (x {y z} : A) → y ≡ x → y ≡ z → x ≡ z
  _ ≡˘⟨ y≡x ⟩ y≡z = trans (sym y≡x) y≡z

  _∎ : ∀ (x : A) → x ≡ x
  _∎ _ = refl


module Human.Equality where

data _==_ {A : Set} (x : A) : A -> Set where
  refl : x == x

{-# BUILTIN EQUALITY _==_ #-}

sym : {A : Set} (x : A) (y : A) -> x == y -> y == x
sym x .x refl = refl

cong : {A : Set} {B : Set} (x : A) (y : A) (f : A -> B) -> x == y -> f x == f y
cong x y f refl = refl


--------------------------------------------------------------------
-- This file contains the definition of and facts about functors. --
--------------------------------------------------------------------
module Category.Funct where

open import Level

open import Relation.Relation

open import Relation.Binary.PropositionalEquality public renaming (_≡_ to _P≡_; sym to prop-sym ; trans to prop-trans; refl to prop-refl)

open import Setoid.Total
open import Category.Category

record Functor {l₁ l₂ : Level} (ℂ₁ : Cat {l₁}) (ℂ₂ : Cat {l₂}) : Set (l₁ ⊔ l₂) where
  constructor Funct_,_,_,_
  field
    -- The object map.
    omap : Obj ℂ₁ → Obj ℂ₂

    -- The morphism map.
    fmap : {A B : Obj ℂ₁}
      → SetoidFun (Hom ℂ₁ A B) (Hom ℂ₂ (omap A) (omap B))

    -- The morphism map must send identities to identities.
    idPF : ∀{A}
     → ⟨  Hom ℂ₂ (omap A) (omap A) ⟩[ appT fmap (id ℂ₁) ≡ id ℂ₂ ]
    -- The morphism map must respect composition.
    compPF : ∀{A B C}{f : el (Hom ℂ₁ A B)}{g : el (Hom ℂ₁ B C)}
      → ⟨ Hom ℂ₂ (omap A) (omap C) ⟩[ appT fmap (f ○[ comp ℂ₁ ] g) ≡ (appT fmap f) ○[ comp ℂ₂ ] (appT fmap g) ]

open Functor public


module Membership where

open import OscarPrelude
open import Successor

record Membership {ℓ} (m : Set ℓ) (M : Set ℓ) : Set (⊹ ℓ)
 where
  field
    _∈_ : m → M → Set ℓ
    _∉_ : m → M → Set ℓ
    xor-membership : ∀ {x : m} {X : M} → x ∈ X ←⊗→ x ∉ X

open Membership ⦃ … ⦄ public

data _∈List_ {ℓ} {A : Set ℓ} (a : A) : List A → Set ℓ
 where
  zero : {as : List A} → a ∈List (a ∷ as)
  suc : {x : A} {as : List A} → a ∈List as → a ∈List (x ∷ as)

instance MembershipList : ∀ {ℓ} {A : Set ℓ} → Membership A $ List A
Membership._∈_ MembershipList = _∈List_
Membership._∉_ MembershipList x X = ¬ x ∈ X
Membership.xor-membership MembershipList = (λ x x₁ → x₁ x) , (λ x x₁ → x x₁)

instance SuccessorMembershipList : ∀ {ℓ} {A : Set ℓ} {a : A} {x : A} {as : List A} → Successor (a ∈ as) $ a ∈ (x List.∷ as)
Successor.⊹ SuccessorMembershipList = suc

_⊆_ : ∀ {ℓ} {m M : Set ℓ} ⦃ _ : Membership m M ⦄ → M → M → Set ℓ
_⊆_ {m = m} M₁ M₂ = ∀ {x : m} → x ∈ M₁ → x ∈ M₂


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

syntax Monad | M

type
  T : 1-ary

term
  ret  : α  ->  T α
  bind : T α  α.(T β)  ->  T β | _>>=_ r10

theory
  (LU) a : α   b : α.(T β) |> bind (ret(a), x. b[x]) =  b[a]
  (RU) t : T α |> bind (t, x. ret(x)) = t
  (AS) t : T α  b : α.(T β)  c : β.(T γ) |> bind (bind (t, x.b[x]), y.c[y]) = bind (t, x. bind (b[x], y.c[y]))
-}

module Monad.Signature where

open import SOAS.Context

-- Type declaration
data MT : Set where
  T : MT → MT

open import SOAS.Syntax.Signature MT public
open import SOAS.Syntax.Build MT public

-- Operator symbols
data Mₒ : Set where
  retₒ : {α : MT} → Mₒ
  bindₒ : {α β : MT} → Mₒ

-- Term signature
M:Sig : Signature Mₒ
M:Sig = sig λ
  { (retₒ  {α})    → (⊢₀ α) ⟼₁ T α
  ; (bindₒ {α}{β}) → (⊢₀ T α) , (α ⊢₁ T β) ⟼₂ T β
  }

open Signature M:Sig public


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

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

open VectorSpace(vectorSpace)

open import Logic
open import Logic.Predicate
open import Logic.Predicate.Equiv
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
open import Structure.Container.SetLike using (SetElement)
private open module SetLikeFunctionProperties{ℓ} = Structure.Container.SetLike.FunctionProperties{C = PredSet{ℓ}(V)}(_∈_)
open import Structure.Operator.Vector
open import Structure.Operator.Vector.LinearCombination ⦃ vectorSpace = vectorSpace ⦄
open import Syntax.Transitivity

private variable ℓ : Lvl.Level

-- A subspace is a subset of V such that it is a vector space under the same operators.
record Subspace (Vₛ : PredSet{ℓ}(V)) : Stmt{ℓᵥ Lvl.⊔ ℓₛ Lvl.⊔ ℓ} where
  constructor intro
  field
    ⦃ add-closure ⦄ : Vₛ closed-under₂ (_+ᵥ_)
    ⦃ mul-closure ⦄ : ∀{s} → (Vₛ closed-under₁ (s ⋅ₛᵥ_))

  _+_ : SetElement(_∈_)(Vₛ) → SetElement(_∈_)(Vₛ) → SetElement(_∈_)(Vₛ)
  _+_ = [∃]-map₂(_+ᵥ_) (Vₛ closureUnder₂ (_+ᵥ_))

  _⋅_ : S → SetElement(_∈_)(Vₛ) → SetElement(_∈_)(Vₛ)
  _⋅_ s = [∃]-map(s ⋅ₛᵥ_) (Vₛ closureUnder₁ (s ⋅ₛᵥ_))

  -- TODO: A proof of this would be easier if a similar "substructure" relation was defined on groups and fields, but I am not sure if using PredSet is the correct choice (maybe this is unprovable when using this?). Another alternative is to use a general set structure by Structure.Container.SetLike
  postulate is-vectorSpace : VectorSpace{V = SetElement(_∈_)(Vₛ)}{S = S}(_+_)(_⋅_)(_+ₛ_)(_⋅ₛ_)
  -- is-vectorSpace = {!!}

SubspaceObject : ∀{ℓ} → Stmt
SubspaceObject{ℓ} = ∃(Subspace{ℓ})


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

open import Level
open import Data.Product using (_×_; Σ)
open import Function.Surjection using (Surjective)
open import Function.Equality using (_⟶_)
open import Relation.Nullary

open import Categories.Category
open import Categories.Functor.Core public
import Categories.Morphism as Morphism

private
  variable
    o ℓ e o′ ℓ′ e′ : Level
    C D : Category o ℓ e

Contravariant : ∀ (C : Category o ℓ e) (D : Category o′ ℓ′ e′) → Set _
Contravariant C D = Functor (Category.op C) D

Faithful : Functor C D → Set _
Faithful {C = C} {D = D} F = ∀ {X Y} → (f g : C [ X , Y ]) → D [ F₁ f ≈ F₁ g ] → C [ f ≈ g ]
  where open Functor F

Full : Functor C D → Set _
Full {C = C} {D = D} F = ∀ {X Y} → Surjective {To = D.hom-setoid {F₀ X} {F₀ Y}} G
  where
    module C = Category C
    module D = Category D
    open Functor F
    G : ∀ {X Y} → (C.hom-setoid {X} {Y}) ⟶ D.hom-setoid {F₀ X} {F₀ Y}
    G = record { _⟨$⟩_ = F₁ ; cong = F-resp-≈ }

FullyFaithful : Functor C D → Set _
FullyFaithful F = Full F × Faithful F

-- Note that this is a constructive version of Essentially Surjective, which is
-- quite a strong assumption.
EssentiallySurjective : Functor C D → Set _
EssentiallySurjective {C = C} {D = D} F = (d : Obj) → Σ C.Obj (λ c → Functor.F₀ F c ≅ d)
  where
  open Morphism D
  open Category D
  module C = Category C


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

-- Definition of the "Twisted Arrow" Category of a Category 𝒞
module Categories.Category.Construction.TwistedArrow {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Data.Product using (_,_; _×_; map; zip)
open import Function.Base using (_$_; flip)
open import Relation.Binary.Core using (Rel)

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

open Category 𝒞
open Definitions 𝒞
open HomReasoning

private
  variable
    A B C : Obj

record Morphism : Set (o ⊔ ℓ) where
  field
    {dom} : Obj
    {cod} : Obj
    arr   : dom ⇒ cod

record Morphism⇒ (f g : Morphism) : Set (ℓ ⊔ e) where
  constructor mor⇒
  private
    module f = Morphism f
    module g = Morphism g

  field
    {dom⇐} : g.dom ⇒ f.dom
    {cod⇒} : f.cod ⇒ g.cod
    square : cod⇒ ∘ f.arr ∘ dom⇐ ≈ g.arr

TwistedArrow : Category (o ⊔ ℓ) (ℓ ⊔ e) e
TwistedArrow = record
  { Obj       = Morphism
  ; _⇒_       = Morphism⇒
  ; _≈_       = λ f g → dom⇐ f ≈ dom⇐ g × cod⇒ f ≈ cod⇒ g
  ; id        = mor⇒ (identityˡ ○ identityʳ)
  ; _∘_       = λ {A} {B} {C} m₁ m₂ → mor⇒ {A} {C} (∘′ m₁ m₂  ○ square m₁)
  ; assoc     = sym-assoc , assoc
  ; sym-assoc = assoc , sym-assoc
  ; identityˡ = identityʳ , identityˡ
  ; identityʳ = identityˡ , identityʳ
  ; identity² = identity² , identity²
  ; equiv     = record
    { refl  = refl , refl
    ; sym   = map sym sym
    ; trans = zip trans trans
    }
  ; ∘-resp-≈  = zip (flip ∘-resp-≈) ∘-resp-≈
  }
  where
  open Morphism⇒
  open Equiv
  open HomReasoning
  ∘′ : ∀ {A B C} (m₁ : Morphism⇒ B C) (m₂ : Morphism⇒ A B) →
    (cod⇒ m₁ ∘ cod⇒ m₂) ∘ Morphism.arr A ∘ (dom⇐ m₂ ∘ dom⇐ m₁) ≈ cod⇒ m₁ ∘ Morphism.arr B ∘ dom⇐ m₁
  ∘′ {A} {B} {C} m₁ m₂ = begin
    (cod⇒ m₁ ∘ cod⇒ m₂) ∘ Morphism.arr A ∘ (dom⇐ m₂ ∘ dom⇐ m₁) ≈⟨ pullʳ sym-assoc ⟩
    cod⇒ m₁ ∘ (cod⇒ m₂ ∘ Morphism.arr A) ∘ (dom⇐ m₂ ∘ dom⇐ m₁) ≈⟨ refl⟩∘⟨ (pullˡ assoc) ⟩
    cod⇒ m₁ ∘ (cod⇒ m₂ ∘ Morphism.arr A ∘ dom⇐ m₂) ∘ dom⇐ m₁   ≈⟨ (refl⟩∘⟨ square m₂ ⟩∘⟨refl) ⟩
    cod⇒ m₁ ∘ Morphism.arr B ∘ dom⇐ m₁ ∎


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

module InnerProduct where

open import Algebra.Bundles using (CommutativeRing)
open import NormedModule using (NormedModule)
open import Level using (_⊔_; suc)
open import Relation.Nullary using (¬_)

module _
  {r ℓr} (CR : CommutativeRing r ℓr)
  m ℓm rel
  where

module _
  {r ℓr} {CR : CommutativeRing r ℓr}
  (open CommutativeRing CR renaming (Carrier to S))
  {rel} {_<_ : S → S → Set rel} (STO : IsStrictTotalOrder _≈_ _<_)
  (_† : S → S)
  {m ℓm} (M : Module CR m ℓm)
  (open Module M renaming (Carrierᴹ to A))
  (⟨_,_⟩ : A → A → S)
  where

  record IsInnerProduct : Set (r ⊔ ℓr ⊔ suc (m ⊔ ℓm ⊔ rel)) where
    field
      ⟨,⟩-linear-+ : ∀ x y z → ⟨ x +ᴹ y , z ⟩ ≈ ⟨ x , z ⟩ + ⟨ y , z ⟩
      ⟨,⟩-linear-* : ∀ s x y → ⟨ s *ₗ x , y ⟩ ≈ s * ⟨ x , y ⟩
      ⟨,⟩-cong : ∀ {x y} → x ≈ᴹ y → ⟨ x , x ⟩ ≈ ⟨ y , y ⟩
      †-linear-+ : ∀ x y → (x + y) † ≈ x † + y †
      †-cong : ∀ {s t} → s ≈ t → s † ≈ t †
      †-inv : ∀ s → (s †) † ≈ s
      ⟨,⟩-herm : ∀ x y → ⟨ x , y ⟩ ≈ ⟨ y , x ⟩ †

    real : S → Set _
    real s = s ≈ s †

    field
      ⟨x,x⟩-real : ∀ x → real ⟨ x , x ⟩
      positive-definite : ∀ {x} → ¬ (x ≈ᴹ 0ᴹ) → 0# < ⟨ x , x ⟩

    open IsStrictTotalOrder STO public
    open import Relation.Binary.Construct.StrictToNonStrict _≈_ _<_ public using (_≤_)

    _-ᴹ_ : A → A → A
    x -ᴹ y = x +ᴹ (-ᴹ y)

    ∥_∥² : A → S
    ∥ x ∥² = ⟨ x , x ⟩

    -- TODO
    -- is this universally true?
    -- or just common?
    ∥-x∥²≈∥x∥² : ∀ x → ∥ -ᴹ x ∥² ≈ ∥ x ∥²
    ∥-x∥²≈∥x∥² = {!   !}

    -- ∥a-b∥≤∥a∥-∥b∥ : ∀ a b → ∥ a -ᴹ b ∥² ≤ ∥ a ∥² - ∥ b ∥²
    -- ∥a-b∥≤∥a∥-∥b∥ = {!   !}

    [s+s†]†≈s+s† : ∀ s → (s + s †) † ≈ s + s †
    [s+s†]†≈s+s† s =
      begin
        (s + s †) †
      ≈⟨ †-linear-+ s (s †) ⟩
        (s † + (s †) †)
      ≈⟨ +-cong refl (†-inv _) ⟩
        (s † + s)
      ≈⟨ +-comm _ _ ⟩
        (s + s †)
      ∎
      where open import Relation.Binary.Reasoning.Setoid setoid


module Logic.Predicate.Equiv where

import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable Obj : Type{ℓ}
private variable Pred : Obj → Stmt{ℓ}

module _ ⦃ _ : Equiv{ℓₑ}(Obj) ⦄ where
  _≡∃_ : ∃{Obj = Obj}(Pred) → ∃{Obj = Obj}(Pred) → Stmt
  [∃]-intro x ≡∃ [∃]-intro y = x ≡ y

  instance
    [≡∃]-reflexivity : Reflexivity(_≡∃_ {Pred = Pred})
    Reflexivity.proof [≡∃]-reflexivity = reflexivity(_≡_)

  instance
    [≡∃]-symmetry : Symmetry(_≡∃_ {Pred = Pred})
    Symmetry.proof [≡∃]-symmetry = symmetry(_≡_)

  instance
    [≡∃]-transitivity : Transitivity(_≡∃_ {Pred = Pred})
    Transitivity.proof [≡∃]-transitivity = transitivity(_≡_)

  instance
    [≡∃]-equivalence : Equivalence(_≡∃_ {Pred = Pred})
    [≡∃]-equivalence = intro

  instance
    [≡∃]-equiv : Equiv{ℓₑ}(∃{Obj = Obj} Pred)
    [≡∃]-equiv = intro(_≡∃_) ⦃ [≡∃]-equivalence ⦄


module Sets.BoolSet.Proofs{ℓ₁} where

open import Data.Boolean
open import Data.Boolean.Proofs
open import Functional
open import Logic.Propositional
open import Sets.BoolSet{ℓ₁}
open import Type

module _ {ℓ₂}{T : Type{ℓ₂}} where
  [∈]-in-[∪] : ∀{a : T}{S₁ S₂ : BoolSet(T)} → (a ∈ S₁) → (a ∈ (S₁ ∪ S₂))
  [∈]-in-[∪] proof-a = [∨]-introₗ-[𝑇] proof-a

  [∈]-in-[∩] : ∀{a : T}{S₁ S₂ : BoolSet(T)} → (a ∈ S₁) → (a ∈ S₂) → (a ∈ (S₁ ∩ S₂))
  [∈]-in-[∩] proof-a₁ proof-a₂ = [∧]-intro-[𝑇] proof-a₁ proof-a₂

  [∈]-in-[∖] : ∀{a : T}{S₁ S₂ : BoolSet(T)} → (a ∈ S₁) → (a ∉ S₂) → (a ∈ (S₁ ∖ S₂))
  [∈]-in-[∖] proof-a₁ proof-a₂ = [∧]-intro-[𝑇] proof-a₁ proof-a₂

  [∈]-in-[∁] : ∀{a : T}{S : BoolSet(T)} → (a ∉ S) → (a ∈ (∁ S))
  [∈]-in-[∁] = id


open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; trans ; cong )

open import AssocFree.DList using ( List )
open import AssocFree.DNat using ( ℕ )

module AssocFree.STLambdaC.Typ (TConst : Set) where

infixr 2 _⇝_

data Typ : Set where
  const : TConst → Typ
  _⇝_ : Typ → Typ → Typ

Var : Set
Var = ℕ

Ctxt : Set
Ctxt = List Typ

open AssocFree.DList public using
  ( [] ; [_] ; _++_ ; _∷_ ; _∈_ ; _≪_ ; _≫_ ; _⋙_ ; uniq ; singleton
  ; Case ; case ; inj₁ ; inj₂ ; inj₃ ; case-≪ ; case-≫ ; case-⋙
  ; Case₃ ; case₃ ; caseˡ ; caseʳ ; caseˡ₃ ; caseʳ₃ ; case⁻¹ ; case-iso )


import      Lvl
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.Subspaces.Image
  {ℓₛ ℓₛₑ}
  {S : Type{ℓₛ}}
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  where

open import Logic.Predicate
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
open import Structure.Container.SetLike as SetLike using (SetElement)
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Operator.Properties
open import Structure.Operator.Vector
open import Structure.Operator.Vector.LinearMap
open import Structure.Operator.Vector.Proofs
open import Structure.Operator.Vector.Subspace
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Implication
open import Syntax.Transitivity

open VectorSpace ⦃ … ⦄
open VectorSpaceVObject ⦃ … ⦄ using (_+ᵥ_; _⋅ₛᵥ_)
open VectorSpaceVObject       using (Vector)

private variable ℓ ℓᵥ ℓᵥₑ : Lvl.Level
private variable V W : VectorSpaceVObject {ℓᵥ = ℓᵥ} {ℓᵥₑ = ℓᵥₑ} ⦃ equiv-S = equiv-S ⦄ (_+ₛ_)(_⋅ₛ_)
private variable F : V →ˡⁱⁿᵉᵃʳᵐᵃᵖ W

image : (V →ˡⁱⁿᵉᵃʳᵐᵃᵖ W) → PredSet(Vector(W))
image {V = V}{W = W} ([∃]-intro f) = PredSet.⊶ f

image-subspace : Subspace(image(F))
SetLike.FunctionProperties._closed-under₂_.proof (Subspace.add-closure (image-subspace {_} {_} {V} {_} {_} {W} {F = F@([∃]-intro f)})) {x} {y} xim yim =
  • (
    xim             ⇒
    x ∈ image(F)    ⇒-[]
    ∃(a ↦ f(a) ≡ x) ⇒-end
  )
  • (
    yim             ⇒
    y ∈ image(F)    ⇒-[]
    ∃(a ↦ f(a) ≡ y) ⇒-end
  )                      ⇒₂-[ [∃]-map₂ (_+ᵥ_) (p ↦ q ↦ (preserving₂(f)(_+ᵥ_)(_+ᵥ_) 🝖 congruence₂(_+ᵥ_) p q)) ]
  ∃(a ↦ f(a) ≡ x +ᵥ y)   ⇒-[]
  (x +ᵥ y) ∈ image(F)    ⇒-end
  where
    instance _ = V
    instance _ = W
SetLike.FunctionProperties._closed-under₁_.proof (Subspace.mul-closure (image-subspace {_} {_} {V} {_} {_} {W} {F = F@([∃]-intro f)}) {s}) {v} vim =
  vim ⇒
  v ∈ image(F)                ⇒-[]
  ∃(x ↦ f(x) ≡ v)             ⇒-[ [∃]-map-proof (congruence₂ᵣ(_⋅ₛᵥ_)(s)) ]
  ∃(x ↦ s ⋅ₛᵥ f(x) ≡ s ⋅ₛᵥ v) ⇒-[ [∃]-map (s ⋅ₛᵥ_) (preserving₁(f)(s ⋅ₛᵥ_)(s ⋅ₛᵥ_) 🝖_) ]
  ∃(x ↦ f(x) ≡ s ⋅ₛᵥ v)       ⇒-[]
  (s ⋅ₛᵥ v) ∈ image(F)        ⇒-end
  where
    instance _ = V
    instance _ = W


{- Name: Bowornmet (Ben) Hudson

--Preorders 2: Electric Boogaloo--

-}

open import Preliminaries

module Preorder-withmax where

  {- Doing the same thing as we did in Preorder.agda but this
     time we want to keep our end goal in mind and extend the
     notion of preorders to include information about maximums
     as well. This will make it easier to 'ensure' that functions
     on nats are monotone (because they sometimes aren't - e.g.
     sine, cosine, etc.) so we can give them a reasonable upper bound.
     If we don't monotonize functions on nats then that makes bounding
     more complicated. This also means we have to extend the idea of
     maximums to all our other types...
  -}
  record Preorder-max-str (A : Set) : Set1 where
    constructor preorder-max
    field
      ≤ : A → A → Set
      refl : ∀ x → ≤ x x
      trans : ∀ x y z → ≤ x y → ≤ y z → ≤ x z
      max : A → A → A
      max-l : ∀ l r → ≤ l (max l r)
      max-r : ∀ l r → ≤ r (max l r)
      max-lub : ∀ k l r → ≤ l k → ≤ r k → ≤ (max l r) k

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

  -- order on nats
  ≤nat : Nat → Nat → Set
  ≤nat Z Z = Unit
  ≤nat Z (S y) = Unit
  ≤nat (S x) Z = Void
  ≤nat (S x) (S y) = ≤nat x y

  -- proof that Nat is reflexive under ≤
  nat-refl : ∀ (x : Nat) → ≤nat x x
  nat-refl Z = <>
  nat-refl (S x) = nat-refl x

  -- proof that Nat is transitive under ≤
  nat-trans : ∀ (x y z : Nat) → ≤nat x y → ≤nat y z → ≤nat x z
  nat-trans Z Z Z p q = <>
  nat-trans Z Z (S z) p q = <>
  nat-trans Z (S y) Z p q = <>
  nat-trans Z (S y) (S z) p q = <>
  nat-trans (S x) Z Z p q = p
  nat-trans (S x) Z (S z) () q
  nat-trans (S x) (S y) Z p ()
  nat-trans (S x) (S y) (S z) p q = nat-trans x y z p q

  -- nat max
  nat-max : Nat → Nat → Nat
  nat-max Z n = n
  nat-max (S m) Z = S m
  nat-max (S m) (S n) = S (nat-max m n)

  -- left max
  nat-max-l : ∀ (l r : Nat) → ≤nat l (nat-max l r)
  nat-max-l Z Z = <>
  nat-max-l Z (S n) = <>
  nat-max-l (S m) Z = nat-refl m
  nat-max-l (S m) (S n) = nat-max-l m n

  -- right max
  nat-max-r : ∀ (l r : Nat) → ≤nat r (nat-max l r)
  nat-max-r Z Z = <>
  nat-max-r Z (S n) = nat-refl n
  nat-max-r (S m) Z = <>
  nat-max-r (S m) (S n) = nat-max-r m n

  -- rub a dub dub, Nats have a lub
  nat-max-lub : ∀ (k l r : Nat) → ≤nat l k → ≤nat r k → ≤nat (nat-max l r) k
  nat-max-lub Z Z Z p q = <>
  nat-max-lub Z Z (S r) p ()
  nat-max-lub Z (S l) Z () q
  nat-max-lub Z (S l) (S r) () q
  nat-max-lub (S k) Z Z p q = <>
  nat-max-lub (S k) Z (S r) p q = q
  nat-max-lub (S k) (S l) Z p q = p
  nat-max-lub (S k) (S l) (S r) p q = nat-max-lub k l r p q

  -- Nat is preorder with max
  nat-p : Preorder-max-str Nat
  nat-p = preorder-max ≤nat nat-refl nat-trans nat-max nat-max-l nat-max-r nat-max-lub

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

--same thing for products

  -- relation for products
  ≤axb : ∀ {A B : Set} → Preorder-max-str A → Preorder-max-str B → (A × B) → (A × B) → Set
  ≤axb PA PB (a1 , b1) (a2 , b2) = Preorder-max-str.≤ PA a1 a2 × Preorder-max-str.≤ PB b1 b2

  axb-refl : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (x : (A × B)) →  ≤axb PA PB x x
  axb-refl PA PB (a , b) = Preorder-max-str.refl PA a , Preorder-max-str.refl PB b

  axb-trans : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (x y z : (A × B)) → ≤axb PA PB x y → ≤axb PA PB y z → ≤axb PA PB x z
  axb-trans PA PB (a1 , b1) (a2 , b2) (a3 , b3) (a1<a2 , b1<b2) (a2<a3 , b2<b3) =
                          Preorder-max-str.trans PA a1 a2 a3 a1<a2 a2<a3 , Preorder-max-str.trans PB b1 b2 b3 b1<b2 b2<b3

  axb-max : ∀ {A B : Set} → Preorder-max-str A → Preorder-max-str B → (A × B) → (A × B) → (A × B)
  axb-max PA PB (a1 , b1) (a2 , b2) = Preorder-max-str.max PA a1 a2 , Preorder-max-str.max PB b1 b2

  axb-max-l : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (l r : (A × B)) → ≤axb PA PB l (axb-max PA PB l r)
  axb-max-l PA PB (a1 , b1) (a2 , b2) = Preorder-max-str.max-l PA a1 a2 , Preorder-max-str.max-l PB b1 b2

  axb-max-r : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (l r : (A × B)) → ≤axb PA PB r (axb-max PA PB l r)
  axb-max-r PA PB (a1 , b1) (a2 , b2) = Preorder-max-str.max-r PA a1 a2 , Preorder-max-str.max-r PB b1 b2

  axb-max-lub : ∀ {A B : Set}
                → (PA : Preorder-max-str A)
                → (PB : Preorder-max-str B)
                → (k l r : (A × B))
                → ≤axb PA PB l k → ≤axb PA PB r k → ≤axb PA PB (axb-max PA PB l r) k
  axb-max-lub PA PB (k1 , k2) (l1 , l2) (r1 , r2) (l1<k1 , l2<k2) (r1<k1 , r2<k2) =
                 Preorder-max-str.max-lub PA k1 l1 r1 l1<k1 r1<k1 , Preorder-max-str.max-lub PB k2 l2 r2 l2<k2 r2<k2

  axb-p : ∀ (A B : Set) → Preorder-max-str A → Preorder-max-str B → Preorder-max-str (A × B)
  axb-p A B PA PB = preorder-max (≤axb PA PB) (axb-refl PA PB) (axb-trans PA PB) (axb-max PA PB) (axb-max-l PA PB) (axb-max-r PA PB) (axb-max-lub PA PB)

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

  -- the type of monotone functions from A to B
  record Monotone (A : Set) (B : Set) (PA : Preorder-max-str A) (PB : Preorder-max-str B) : Set where
    constructor monotone
    field
      f : A → B
      is-monotone : ∀ (x y : A) → Preorder-max-str.≤ PA x y → Preorder-max-str.≤ PB (f x) (f y)

  ≤mono : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (Monotone A B PA PB) → (Monotone A B PA PB) → Set
  ≤mono {A} PA PB f g = (x : A) → Preorder-max-str.≤ PB (Monotone.f f x) (Monotone.f g x)

  mono-refl : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (x : (Monotone A B PA PB)) → ≤mono PA PB x x
  mono-refl PA PB f = λ x → Preorder-max-str.refl PB (Monotone.f f x)

  mono-trans : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (x y z : (Monotone A B PA PB)) → ≤mono PA PB x y → ≤mono PA PB y z → ≤mono PA PB x z
  mono-trans PA PB f g h p q = λ x → Preorder-max-str.trans PB (Monotone.f f x) (Monotone.f g x) (Monotone.f h x) (p x) (q x)

  mono-max : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (Monotone A B PA PB) → (Monotone A B PA PB) → (Monotone A B PA PB)
  mono-max PA PB (monotone f f-ismono) (monotone g g-ismono) =
             monotone (λ x → Preorder-max-str.max PB (f x) (g x)) (λ x y x₁ → Preorder-max-str.max-lub PB (Preorder-max-str.max PB (f y) (g y)) (f x) (g x)
               (Preorder-max-str.trans PB (f x) (f y) (Preorder-max-str.max PB (f y) (g y)) (f-ismono x y x₁) (Preorder-max-str.max-l PB (f y) (g y)))
                 (Preorder-max-str.trans PB (g x) (g y) (Preorder-max-str.max PB (f y) (g y)) (g-ismono x y x₁) (Preorder-max-str.max-r PB (f y) (g y))))

  mono-max-l : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (l r : Monotone A B PA PB) → ≤mono PA PB l (mono-max PA PB l r)
  mono-max-l PA PB f g = λ x → Preorder-max-str.max-l PB (Monotone.f f x) (Monotone.f g x)

  mono-max-r : ∀ {A B : Set} → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → (l r : Monotone A B PA PB) → ≤mono PA PB r (mono-max PA PB l r)
  mono-max-r PA PB f g = λ x → Preorder-max-str.max-r PB (Monotone.f f x) (Monotone.f g x)

  mono-max-lub : ∀ {A B : Set}
                → (PA : Preorder-max-str A)
                → (PB : Preorder-max-str B)
                → (k l r : Monotone A B PA PB)
                → ≤mono PA PB l k → ≤mono PA PB r k → ≤mono PA PB (mono-max PA PB l r) k
  mono-max-lub PA PB f g h p q = λ x → Preorder-max-str.max-lub PB (Monotone.f f x) (Monotone.f g x) (Monotone.f h x) (p x) (q x)

  mono-p : ∀ (A B : Set) → (PA : Preorder-max-str A) → (PB : Preorder-max-str B) → Preorder-max-str (Monotone A B PA PB)
  mono-p A B PA PB = preorder-max (≤mono PA PB) (mono-refl PA PB) (mono-trans PA PB) (mono-max PA PB) (mono-max-l PA PB) (mono-max-r PA PB) (mono-max-lub PA PB)

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

--"Hey, let's make things monotone!"

  -- another way to define the ≤ relation on Nat
  data _≤'_ : Nat → Nat → Set where
    x≤'x : {x : Nat} → x ≤' x
    x≤'y : {x y : Nat} → x ≤' y → x ≤' (S y)

  -- silly lemmas about silly nats
  nat-lemma : (x : Nat) → Z ≤' x
  nat-lemma Z = x≤'x
  nat-lemma (S x) = x≤'y (nat-lemma x)

  nat-lemma2 : (x y : Nat) → x ≤' y → (S x) ≤' (S y)
  nat-lemma2 .y y x≤'x = x≤'x
  nat-lemma2 x .(S y) (x≤'y {.x} {y} p) = x≤'y (nat-lemma2 x y p)

  nat-lemma3 : (x : Nat) → ≤nat x (S x)
  nat-lemma3 Z = <>
  nat-lemma3 (S x) = nat-lemma3 x

  -- maps to and from the old and new definitions of the ≤ relation
  ≤-map : (x y : Nat) → ≤nat x y → x ≤' y
  ≤-map Z Z f = x≤'x
  ≤-map Z (S y) f = nat-lemma (S y)
  ≤-map (S x) Z ()
  ≤-map (S x) (S y) f = nat-lemma2 x y (≤-map x y f)

  ≤-map2 : (x y : Nat) → x ≤' y → ≤nat x y
  ≤-map2 .y y x≤'x = nat-refl y
  ≤-map2 x .(S y) (x≤'y {.x} {y} f) = nat-trans x y (S y) (≤-map2 x y f) (nat-lemma3 y)

  -- a function to find the maximum of a whole set and not just a pair of values
  max' : ∀ {A : Set} → (PA : Preorder-max-str A) → Nat → (Nat → A) → A
  max' PA Z f = f Z
  max' PA (S n) f = Preorder-max-str.max PA (f (S n)) (max' PA n f)

  -- primitive recursion function corresponding to rec
  natrec : ∀{C : Set} → C → (Nat → C → C) → Nat → C
  natrec base step Z = base
  natrec base step (S n) = step n (natrec base step n)

  -- another lemma
  mono-f-lemma : ∀ {A : Set} → (x y : Nat) → x ≤' y → (PA : Preorder-max-str A) → (f : Nat → A) → Preorder-max-str.≤ PA (max' PA x f) (max' PA y f)
  mono-f-lemma .y y x≤'x PA f = Preorder-max-str.refl PA (max' PA y f)
  mono-f-lemma x .(S y) (x≤'y {.x} {y} p) PA f = Preorder-max-str.trans PA (max' PA x f) (max' PA y f) (max' PA (S y) f)
                                                                        (mono-f-lemma x y p PA f) (Preorder-max-str.max-r PA (f (S y)) (max' PA y f))

  -- make a function monotone by taking the max at every point
  mono-f : ∀ {A : Set} → (PA : Preorder-max-str A) → (f : Nat → A) → Monotone Nat A nat-p PA
  mono-f PA f = monotone (λ x → max' PA x f) (λ x y x₁ → mono-f-lemma x y (≤-map x y x₁) PA f)

  -- f ≤ (monotonization of f)
  mono-f-is-monotone : ∀ {A : Set} → (PA : Preorder-max-str A) → (x : Nat) → (f : Nat → A) → Preorder-max-str.≤ PA (f x) (Monotone.f (mono-f PA f) x)
  mono-f-is-monotone PA Z f = Preorder-max-str.refl PA (f Z)
  mono-f-is-monotone PA (S x) f = Preorder-max-str.max-l PA (f (S x)) (max' PA x f)

  -- if f is already monotone, then its monotonization is less than or equal to itself
  mono-f-≤-itself : ∀ {A : Set}
                    → (PA : Preorder-max-str A)
                    → (x : Nat)
                    → (f : Monotone Nat A nat-p PA)
                    →  Preorder-max-str.≤ PA (Monotone.f (mono-f PA (Monotone.f f)) x) (Monotone.f f x)
  mono-f-≤-itself PA Z f = Preorder-max-str.refl PA (Monotone.f (mono-f PA (Monotone.f f)) Z)
  mono-f-≤-itself PA (S x) f = Preorder-max-str.max-lub PA (Monotone.f f (S x)) (Monotone.f f (S x)) (max' PA x (Monotone.f f))
                                                        (Preorder-max-str.refl PA (Monotone.f f (S x)))
                                                          (Preorder-max-str.trans PA (max' PA x (Monotone.f f))
                                                            (Monotone.f f x) (Monotone.f f (S x)) (mono-f-≤-itself PA x f)
                                                              (Monotone.is-monotone f x (S x) (≤-map2 x (S x) (x≤'y x≤'x))))

  -- monotonize at the end
  mnatrec : ∀ {A : Set} → (PA : Preorder-max-str A) → A → (Nat → A → A) → Nat → A
  mnatrec PA zc sc e = max' PA e (natrec zc sc)

  -- still incorrect
  mono-natrec : ∀ {A : Set} → (PA : Preorder-max-str A) → A → (Nat → A → A) → Nat → A
  mono-natrec PA zc sc Z = zc
  mono-natrec PA zc sc (S y') = Preorder-max-str.max PA zc (sc y' (mono-natrec PA zc sc y'))

  data N' : Set where
    Z1 : N'
    Sa : N' → N'
    Sb : N' → N'

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

-- same thing as Preorder.agda but for this module

  PREORDER = Σ (λ (A : Set) → Preorder-max-str A)

  MONOTONE : (PΓ PA : PREORDER) → Set
  MONOTONE (Γ , PΓ) (A , PA) = Monotone Γ A PΓ PA

  -- some operations
  _×p_ : PREORDER → PREORDER → PREORDER
  (A , PA) ×p (B , PB) = A × B , axb-p A B PA PB

  _->p_ : PREORDER → PREORDER → PREORDER
  (A , PA) ->p (B , PB) = Monotone A B PA PB , mono-p A B PA PB

  -- Unit is a preorder
  unit-p : PREORDER
  unit-p = Unit , preorder-max (λ x x₁ → Unit) (λ x → <>) (λ x y z _ _ → <>) (λ _ _ → <>) (λ l r → <>) (λ l r → <>) (λ k l r _ _ → <>)

  -- identity preserves monotonicity
  id : ∀ {Γ} → MONOTONE Γ Γ
  id = λ {Γ} → monotone (λ x → x) (λ x y x₁ → x₁)

  -- composition preserves monotonicity
  comp : ∀ {PA PB PC} → MONOTONE PA PB → MONOTONE PB PC → MONOTONE PA PC
  comp (monotone f f-ismono) (monotone g g-ismono) = monotone (λ x → g (f x)) (λ x y x₁ → g-ismono (f x) (f y) (f-ismono x y x₁))

  -- proofs that types like pairs etc. with preorders are monotone
  pair' : ∀ {PΓ PA PB} → MONOTONE PΓ PA → MONOTONE PΓ PB → MONOTONE PΓ (PA ×p PB)
  pair' (monotone f f-ismono) (monotone g g-ismono) = monotone (λ x → (f x) , (g x)) (λ x y x₁ → f-ismono x y x₁ , g-ismono x y x₁)

  fst' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ×p PB) → MONOTONE PΓ PA
  fst' (monotone f f-ismono) =
          monotone (λ x → fst (f x)) (λ x y z → fst (f-ismono x y z))

  snd' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ×p PB) → MONOTONE PΓ PB
  snd' (monotone f f-ismono) =
          monotone (λ x → snd (f x)) (λ x y z → snd (f-ismono x y z))

  lam' : ∀ {PΓ PA PB} → MONOTONE (PΓ ×p PA) PB → MONOTONE PΓ (PA ->p PB)
  lam' {Γ , preorder-max _ reflΓ _ _ _ _ _} {A , preorder-max _ refla _ _ _ _ _} (monotone f f-ismono) =
          monotone (λ x → monotone (λ p → f (x , p)) (λ a b c → f-ismono (x , a) (x , b) ((reflΓ x) , c))) (λ x y z w → f-ismono (x , w) (y , w) (z , (refla w)))

  app' : ∀ {PΓ PA PB} → MONOTONE PΓ (PA ->p PB) → MONOTONE PΓ PA → MONOTONE PΓ PB
  app' {_} {_} {b , preorder-max _ _ transb _ _ _ _} (monotone f f-ismono) (monotone g g-ismono) =
          monotone (λ x → Monotone.f (f x) (g x)) (λ x y z → transb (Monotone.f (f x) (g x)) (Monotone.f (f y) (g x)) (Monotone.f (f y) (g y))
          (f-ismono x y z (g x)) (Monotone.is-monotone (f y) (g x) (g y) (g-ismono x y z)))


{-
      Agda file from the exercise session(s).
-}

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

open import Agda.Primitive

{-
  Two inductive implementations of the
    Martin-Löf identity type
  aka
    equality type
  aka
    identification type
  aka
    path type.
-}

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

infixr 10 _≡_

-- explcit
data _≡'_ {A : Set} : A → A → Set where
  refl : (a : A) → a ≡' a

-- variables can be used later and are understood as Pi-quantified.
variable
  A B C : Set

-- sym' for ≡'
sym' : {a b : A} → a ≡' b → b ≡' a
sym' {a = x} {.x} (refl .x) = refl x

-- sym for ≡
sym : {a b : A} → a ≡ b → b ≡ a
sym refl = refl

_⁻¹ = sym

symsym : {a b : A} → (p : a ≡ b) → sym (sym p) ≡ p
symsym refl = refl

ap : (f : A → B) → {a b : A} → a ≡ b → f a ≡ f b
ap f {a} {.a} refl = refl

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

infixl 26 _∘_

ap-g∘f : (f : A → B) (g : B → C) {a b : A} (p : a ≡ b)
         → ap (g ∘ f) p ≡ (ap g ∘ ap f) p
ap-g∘f f g refl = refl

trans : {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans refl q = q

_∙_ = trans
infixr 30 _∙_

sym-refl : {a b : A} → (p : a ≡ b) → (p ⁻¹) ∙ p ≡ refl
sym-refl refl = refl

trans2 : {a b c : A} -> a ≡ b -> b ≡ c -> a ≡ c
trans2 p refl = p

trans-trans2 : {a b c : A} -> (p : a ≡ b) -> (q : b ≡ c)
               -> trans p q ≡ trans2 p q
trans-trans2 {a = x} {b = .x} {c = .x} refl refl = refl

trans3 : {a b c : A} -> a ≡ b -> b ≡ c -> a ≡ c
trans3 refl refl = refl

trans-trans3 : {a b c : A} -> (p : a ≡ b) -> (q : b ≡ c)
               -> trans p q ≡ trans3 p q
trans-trans3 {a = x} {b = .x} {c = .x} refl refl = refl

test : {a c : A} → (q : a ≡ c) → trans refl q ≡ q
test q = refl

test2 : {a c : A} → (q : a ≡ c) → trans2 q refl ≡ q
test2 q = refl

test3 : {a c : A} → (q : a ≡ c) → trans3 refl q ≡ q
test3 refl = refl

{-
  In test3 above, we have to pattern match (path induct) on q!
  What if we cannot, as in
    test4 : {a : A} → (q : a ≡ a) → trans3 refl q ≡ q
  ?
-}

-- solution:
test4 : {a : A} → (q : a ≡ a) → trans3 refl q ≡ q
test4 q = test3 q

-- We can only pattern match on q if we remove the --without-K option:
uip : {a b : A} → (p q : a ≡ b) → p ≡ q
uip {a = x} {b = .x} refl q = {!q!}

-- implementation of the J eliminator (aka path induction)
module _ (C : (a b : A) → a ≡ b → Set) where

   J-elim : (d : (a : A) → C a a refl) → (a b : A) → (p : a ≡ b) → C a b p
   J-elim d a .a refl = d a

-- implementation of the Paulin-Mohring version of J (based bath induction)
module _ (a₀ : A) (C : (b : A) → a₀ ≡ b → Set) where

   J-elim-PM : (d : C a₀ refl) → (b : A) → (p : a₀ ≡ b) → C b p
   J-elim-PM d b refl = d

-- this is "Axiom K" (which is disabled in the options)
module _ (a₀ : A) (C : a₀ ≡ a₀ → Set) where

  K : (d : C refl) → (p : a₀ ≡ a₀) → C p
  K d p = {!p!}

-- Caveat:
-- judgmental equality in Agda: = but on paper: ≡
-- path type in Agda: ≡ but on paper: =

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst

open Σ public
infixr 4 _,_

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

{-
  Exercise 5
  For a given function f : A -> B, a *pointwise left inverse* is a
  function g : B -> A such that (a : A) -> g (f a) = a.

  Show: If f has a pointwise left inverse then, for all a,b : A, the
  function ap_f {a} {b} has a pointwise left inverse. (Does the other
  direction hold as well?)

  Solution of the easy part:
-}

has-ptw-left-inv : {A B : Set} → (f : A → B) → Set
has-ptw-left-inv {A} {B} f = Σ (B → A) λ g → (a : A) → g (f a) ≡ a

ptw-left-inv-ap : {A B : Set} → (f : A → B) →
                  has-ptw-left-inv f →
                  {a₁ a₂ : A} → has-ptw-left-inv (ap f {a₁} {a₂})
ptw-left-inv-ap f (g , g∘f) {a₁} {a₂} =
                (λ q → (g∘f a₁ ⁻¹) ∙ ap g {f a₁} {f a₂} q ∙ g∘f a₂) ,
                λ {refl →  sym-refl (g∘f a₁) }

{-
  Exercise 6: a1 a2 : A, b1 b2 : B
  (a1 , b1) ≡ (a2 , b2) is equivalent to (a1 = a2) × (b1 = b2).

  Exercise 7:
  eqv2iso :   isEqv(f) -> isIso(f)   [easy]
  iso2eqv :  isIso(f) -> isEqv(f)   [hard]
-}

module _ (A B : Set) (g : B → A) (a b : B) where

  lemma : (pair1 pair2 : Σ A λ x → x ≡ g a) → pair1 ≡ pair2
  lemma (.(g a) , refl) (.(g a) , refl) = refl

  wrong : (pair1 pair2 : Σ A λ x → g a ≡ g b) → pair1 ≡ pair2
  wrong (x1 , p1) (x2 , p2) = {!p1!}

split-equality : {x y : A × B} → x ≡ y → (fst x ≡ fst y) × (snd x ≡ snd y)
split-equality = {!!}

combine-equalities : {x y : A × B} → (fst x ≡ fst y) × (snd x ≡ snd y) → x ≡ y
combine-equalities = {!!}


open import Data.Empty using ( ⊥ )
open import Data.Nat using ( ℕ ; zero ; suc ; _+_ ; _≤_ ; z≤n ; s≤s )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong )
open import Relation.Binary.PropositionalEquality.TrustMe using ( trustMe )
open import Relation.Nullary using ( ¬_ )

module FRP.LTL.Util where

infixr 5 _trans_ _∋_

-- Irrelevant projections

postulate
  .irrelevant : ∀ {A : Set} → .A → A

-- Irrelevant ≡ can be promoted to relevant ≡

≡-relevant : ∀ {A : Set} {a b : A} → .(a ≡ b) → (a ≡ b)
≡-relevant a≡b = trustMe

-- A version of ⊥-elim which takes an irrelevant argument

⊥-elim : {A : Set} → .⊥ → A
⊥-elim ()

-- An infix variant of trans

_trans_ : ∀ {X : Set} {x y z : X} → (x ≡ y) → (y ≡ z) → (x ≡ z)
refl trans refl = refl

-- Help the type inference engine out by being explicit about X.

_∋_ : (X : Set) → X → X
X ∋ x = x

-- Lemmas about addition on ℕ
-- These are from Data.Nat.Properties,
-- included here to avoid having to load all of Data.Nat.Properties' dependencies.

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

+-comm : ∀ m n → (m + n ≡ n + m)
+-comm zero    zero    = refl
+-comm zero    (suc n) = cong suc (+-comm zero n)
+-comm (suc m) n       = (cong suc (+-comm m n)) trans (sym (m+1+n≡1+m+n n m))

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

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

1+n≰n : ∀ n → ¬(suc n ≤ n)
1+n≰n zero    ()
1+n≰n (suc n) (s≤s m≤n) = 1+n≰n n m≤n

≤0-impl-≡0 : ∀ {n} → (n ≤ 0) → (n ≡ 0)
≤0-impl-≡0 z≤n = refl


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

open import Categories.Category using (Category; module Commutation)

-- The "four middle interchange" for monoidal categories.
--
-- Aka the "interchange law" or "exchange law" (though those terms are
-- more comonly used in the more general context of composition in
-- 2-categories).

-- Section 5.3 of the PhD thesis of Geoff Cruttwell states most (all?)
-- the properties in the module, starting on p. 57 (starting with Prop. 5.3.4).
-- It also has nice string-diagrammatic proofs.
--    See also further comments in https://github.com/agda/agda-categories/pull/294#issuecomment-897697009

module Categories.Category.Monoidal.Interchange
  {o ℓ e} {C : Category o ℓ e} where

open import Level using (_⊔_)

import Categories.Category.Monoidal.Construction.Product as MonoidalProduct
open import Categories.Category.Monoidal.Core using (Monoidal)
import Categories.Category.Monoidal.Utilities as MonoidalUtilities
open import Categories.Category.Product using (_⁂_)
open import Categories.Functor using (_∘F_)
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_; niHelper)
open import Categories.Morphism C using (_≅_; module ≅)

open Category C using (Obj; id; _⇒_; _∘_; _≈_)
open Commutation C

private
  variable
    W W₁ W₂ X X₁ X₂ Y Y₁ Y₂ Z Z₁ Z₂ : Obj
    f g h i : X ⇒ Y

-- An abstract definition of an interchange map with the minimal set
-- of coherence laws required to make the tensor product ⊗ of C a
-- monoidal functor.  (See also Categories.Functor.Monoidal.Tensor.)

record HasInterchange (M : Monoidal C) : Set (o ⊔ ℓ ⊔ e) where
  open Monoidal M using (_⊗₀_; _⊗₁_; unit; ⊗)
  open MonoidalUtilities.Shorthands M using (α⇒; λ⇐; λ⇒; ρ⇒)

  -- The "four middle interchange" for tensor products.

  field swapInner : ∀ {W X Y Z} → (W ⊗₀ X) ⊗₀ (Y ⊗₀ Z) ≅ (W ⊗₀ Y) ⊗₀ (X ⊗₀ Z)

  module swapInner {W X Y Z} = _≅_ (swapInner {W} {X} {Y} {Z})
  private
    i⇒ = swapInner.from
    i⇐ = swapInner.to

  -- Naturality and coherence laws of the interchange.

  field
    natural : i⇒ ∘ (f ⊗₁ g) ⊗₁ (h ⊗₁ i) ≈ (f ⊗₁ h) ⊗₁ (g ⊗₁ i) ∘ i⇒

    assoc : [ ((X₁ ⊗₀ X₂) ⊗₀ (Y₁ ⊗₀ Y₂)) ⊗₀ (Z₁ ⊗₀ Z₂) ⇒
              (X₁ ⊗₀ (Y₁ ⊗₀ Z₁)) ⊗₀ (X₂ ⊗₀ (Y₂ ⊗₀ Z₂)) ]⟨
              i⇒ ⊗₁ id   ⇒⟨ ((X₁ ⊗₀ Y₁) ⊗₀ (X₂ ⊗₀ Y₂)) ⊗₀ (Z₁ ⊗₀ Z₂) ⟩
              i⇒         ⇒⟨ ((X₁ ⊗₀ Y₁) ⊗₀ Z₁) ⊗₀ ((X₂ ⊗₀ Y₂) ⊗₀ Z₂) ⟩
              α⇒ ⊗₁ α⇒
            ≈ α⇒         ⇒⟨ (X₁ ⊗₀ X₂) ⊗₀ ((Y₁ ⊗₀ Y₂) ⊗₀ (Z₁ ⊗₀ Z₂)) ⟩
              id ⊗₁ i⇒   ⇒⟨ (X₁ ⊗₀ X₂) ⊗₀ ((Y₁ ⊗₀ Z₁) ⊗₀ (Y₂ ⊗₀ Z₂)) ⟩
              i⇒
            ⟩

    unitˡ : [ unit ⊗₀ (X ⊗₀ Y) ⇒ (X ⊗₀ Y) ]⟨
              λ⇐ ⊗₁ id   ⇒⟨ (unit ⊗₀ unit) ⊗₀ (X ⊗₀ Y) ⟩
              i⇒         ⇒⟨ (unit ⊗₀ X) ⊗₀ (unit ⊗₀ Y) ⟩
              λ⇒ ⊗₁ λ⇒
            ≈ λ⇒
            ⟩

    unitʳ : [ (X ⊗₀ Y) ⊗₀ unit ⇒ (X ⊗₀ Y) ]⟨
              id ⊗₁ λ⇐   ⇒⟨ (X ⊗₀ Y) ⊗₀ (unit ⊗₀ unit) ⟩
              i⇒         ⇒⟨ (X ⊗₀ unit) ⊗₀ (Y ⊗₀ unit) ⟩
              ρ⇒ ⊗₁ ρ⇒
            ≈ ρ⇒
            ⟩

  -- The interchange is a natural isomorphism.

  naturalIso : ⊗ ∘F (⊗ ⁂ ⊗) ≃ ⊗ ∘F MonoidalProduct.⊗ M M
  naturalIso = niHelper (record
    { η       = λ _ → i⇒
    ; η⁻¹     = λ _ → i⇐
    ; commute = λ _ → natural
    ; iso     = λ _ → swapInner.iso
    })


-- Σ type (also used as existential) and
-- cartesian product (also used as conjunction).

{-# OPTIONS --safe #-}

import Tools.PropositionalEquality as PE

module Tools.Product where

infixr 4 _,_
infixr 2 _×_

-- Dependent pair type (aka dependent sum, Σ type).

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

-- Existential quantification.

∃ : {A : Set} → (A → Set) → Set
∃ = Σ _

∃₂ : {A : Set} {B : A → Set}
     (C : (x : A) → B x → Set) → Set
∃₂ C = ∃ λ a → ∃ λ b → C a b

-- Cartesian product.

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

×-eq : ∀ {A B : Set} {x x' : A} {y y' : B} → x PE.≡ x' × y PE.≡ y' → (x , y) PE.≡ ( x' , y' )
×-eq ( PE.refl , PE.refl ) = PE.refl


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

  open import Sec4
  postulate A : Set -- XXX: E.g., Nat or Bool some base type

  -- XXX: Postulates for ≤
  postulate _≤_ : A → A → Prop
  postulate antisym-≤ : (a b : A) → (a ≤ b) → (b ≤ a) → (a ≡ b)
  postulate tot-≤ : (a b : A) → (a ≤ b) ∨ (b ≤ a)
  postulate refl-≤ : (a : A) → (a ≤ a)
  postulate trans-≤ : (a b c : A) → (a ≤ b) → (b ≤ a) → (a ≤ c)

  -- XXX: Postulates for ≥
  postulate _≥_ : A → A → Prop
  postulate antisym-≥ : (a b : A) → (a ≥ b) → (b ≥ a) → (a ≡ b)
  postulate tot-≥ : (a b : A) → (a ≥ b) ∨ (b ≥ a)
  postulate refl-≥ : (a : A) → (a ≥ a)
  postulate trans-≥ : (a b c : A) → (a ≥ b) → (b ≥ a) → (a ≥ c)

-- XXX: Definition of a binary tree.
  data SortedBinaryTree (A : Set) : Set where
    Leaf : SortedBinaryTree A
    Node : (a : A) → (l : SortedBinaryTree A) → (r : SortedBinaryTree A) → SortedBinaryTree A

  all-leq : (a : A) → (t : SortedBinaryTree A) → Prop
  all-leq a₁ Leaf = ⊤
  all-leq a₁ (Node a₂ l r) = (a₂ ≤ a₁) ∧ ((all-leq a₁ l) ∧ (all-leq a₁ r))

  all-geq : (a : A) → (t : SortedBinaryTree A) → Prop
  all-geq a₁ Leaf = ⊤
  all-geq a₁ (Node a₂ l r) = (a₂ ≥ a₁) ∧ ((all-geq a₁ l) ∧ (all-geq a₁ r))

-- XXX: What is a sorted tree. A BTree is sorted, if all elements in the
-- left substree are ≥ root and all elements in the right subtree are ≤
-- root.
  ordered : SortedBinaryTree A → Prop
  ordered Leaf = ⊤
  ordered (Node a l r) = ((all-leq a l) ∧ (all-geq a r)) ∧ ((ordered l) ∧ (ordered r))

-- XXX: Insert function for SortedBinaryTree
  insert : (a : A) → SortedBinaryTree A → SortedBinaryTree A
  insert x Leaf = Node x Leaf Leaf
  insert x (Node a t t₁) with (tot-≤ x a)
  insert x (Node a t t₁) | ora x₁ = insert x t
  insert x (Node a t t₁) | orb x₁ = insert x t₁

-- XXX: Prove that the tree obtained after insertion is sorted
  insert-sorted : (a : A)
                  → (t : SortedBinaryTree A)
                  → (p : ordered t)
                  → ordered (insert a t)
  insert-sorted a Leaf _ = and (and ⋆ ⋆) (and ⋆ ⋆)
  insert-sorted a (Node a₁ t t₁) (and (and x x1) (and x2 x3)) with (tot-≤ a a₁)
  insert-sorted a (Node a₁ t t₁) (and (and p1 p2) (and p3 p4)) | ora w = insert-sorted a t p3
  insert-sorted a (Node a₁ t t₁) (and (and p1 p2) (and p3 p4)) | orb w = insert-sorted a t₁ p4

-- XXX: Proof carrying code
  insert' : (a : A)
            → (t : SortedBinaryTree A)
            → (p : ordered t)
            → Exists (SortedBinaryTree A) (λ t' → ordered t')
  insert' a t p = [ insert a t , insert-sorted a t p ]

-- XXX: Write Proof that delete works.

-- XXX: Write a version with record and setoid carrying the ≤, etc


module nat-division-wf where

open import bool
open import bool-thms
open import eq
open import neq
open import nat
open import nat-thms
open import product
open import product-thms
open import sum
open import termination

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infixl 10 _÷_!_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

{- a div-result for dividend x and divisor d consists of the quotient q, remainder r,
   a proof that q * d + r = x, and a proof that the remainder is less than the divisor. -}
div-result : ℕ → ℕ → Set
div-result x d = Σ ℕ (λ q → Σ ℕ (λ r → q * d + r ≡ x ∧ r < d ≡ tt))

-- this uses well-founded recursion.  The approach in nat-division.agda is arguably simpler.
div-helper : ∀ (x : ℕ) → ↓𝔹 _>_ x → (d : ℕ) → d =ℕ 0 ≡ ff → div-result x d
div-helper x ↓x 0 ()
div-helper 0 (pf↓ fx) (suc d) _ = 0 , 0 , refl , refl
div-helper (suc x) (pf↓ fx) (suc d) _ with keep (x < d)
div-helper (suc x) (pf↓ fx) (suc d) _ | tt , p = 0 , suc x , refl , p
div-helper (suc x) (pf↓ fx) (suc d) _ | ff , p
  with div-helper (x ∸ d) (fx (∸<1 {x} {d})) (suc d) refl
div-helper (suc x) (pf↓ fx) (suc d) _ | ff , p | q , r , u , v =
  suc q , r , lem{q * suc d} (∸eq-swap{x}{d}{q * suc d + r} (<ff{x} p) u) , v
  where lem : ∀ {a b c : ℕ} → a + b + c ≡ x → suc (c + a + b) ≡ suc x
        lem{a}{b}{c} p' rewrite +comm c a | sym (+assoc a c b)
                              | +comm c b | +assoc a b c | p' = refl

_÷_!_ : (x : ℕ) → (d : ℕ) → d =ℕ 0 ≡ ff → div-result x d
x ÷ d ! p = div-helper x (↓-> x) d p

_÷_!!_ : ℕ → (d : ℕ) → d =ℕ 0 ≡ ff → ℕ × ℕ
x ÷ d !! p with x ÷ d ! p
... | q , r , p' = q , r

-- return quotient only
_÷_div_ : ℕ → (d : ℕ) → d =ℕ 0 ≡ ff → ℕ
x ÷ d div p with x ÷ d ! p
... | q , r , p' = q


------------------------------------------------------------------------------
-- Inductive PA properties using the induction principle
------------------------------------------------------------------------------

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

module PA.Inductive.PropertiesByInductionATP where

open import PA.Inductive.Base
open import PA.Inductive.PropertiesByInduction

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

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + n ≡ n + i
  {-# ATP definition A #-}

  A0 : A zero
  A0 = sym (+-rightIdentity n)

  postulate is : ∀ i → A i → A (succ i)
  -- TODO (21 November 2014). See Apia issue 16
  -- {-# ATP prove is x+Sy≡S[x+y] #-}


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

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

module Fields.FieldOfFractions.Multiplication {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (I : IntegralDomain R) where

open import Fields.FieldOfFractions.Setoid I

fieldOfFractionsTimes : fieldOfFractionsSet → fieldOfFractionsSet → fieldOfFractionsSet
fieldOfFractionsTimes (record { num = a ; denom = b ; denomNonzero = b!=0 }) (record { num = c ; denom = d ; denomNonzero = d!=0 }) = record { num = a * c ; denom = b * d ; denomNonzero = ans }
  where
    open Setoid S
    open Ring R
    ans : ((b * d) ∼ Ring.0R R) → False
    ans pr with IntegralDomain.intDom I pr
    ans pr | f = exFalso (d!=0 (f b!=0))

fieldOfFractionsTimesWellDefined : {a b c d : fieldOfFractionsSet} → (Setoid._∼_ fieldOfFractionsSetoid a c) → (Setoid._∼_ fieldOfFractionsSetoid b d) → (Setoid._∼_ fieldOfFractionsSetoid (fieldOfFractionsTimes a b) (fieldOfFractionsTimes c d))
fieldOfFractionsTimesWellDefined {record { num = a ; denom = b }} {record { num = c ; denom = d }} {record { num = e ; denom = f }} {record { num = g ; denom = h }} af=be ch=dg = need
  where
    open Setoid S
    open Equivalence eq
    need : ((a * c) * (f * h)) ∼ ((b * d) * (e * g))
    need = transitive (Ring.*WellDefined R reflexive (Ring.*Commutative R)) (transitive (Ring.*Associative R) (transitive (Ring.*WellDefined R (symmetric (Ring.*Associative R)) reflexive) (transitive (Ring.*WellDefined R (Ring.*WellDefined R reflexive ch=dg) reflexive) (transitive (Ring.*Commutative R) (transitive (Ring.*Associative R) (transitive (Ring.*WellDefined R (Ring.*Commutative R) reflexive) (transitive (Ring.*WellDefined R af=be reflexive) (transitive (Ring.*Associative R) (transitive (Ring.*WellDefined R (transitive (symmetric (Ring.*Associative R)) (transitive (Ring.*WellDefined R reflexive (Ring.*Commutative R)) (Ring.*Associative R))) reflexive) (symmetric (Ring.*Associative R)))))))))))


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Cubical.Path
open import Agda.Primitive
open import Agda.Primitive.Cubical

variable
  a p         : Level
  A           : Set a
  P           : A → Set p
  eq₁ u v x y : A

refl : x ≡ x
refl {x = x} = λ _ → x

subst : (P : A → Set p) → x ≡ y → P x → P y
subst P x≡y p = primTransp (λ i → P (x≡y i)) i0 p

hcong :
  (f : (x : A) → P x) (x≡y : x ≡ y) →
  PathP (λ i → P (x≡y i)) (f x) (f y)
hcong f x≡y = λ i → f (x≡y i)

dcong :
  (f : (x : A) → P x) (x≡y : x ≡ y) →
  subst P x≡y (f x) ≡ f y
dcong {P = P} f x≡y = λ i →
  primTransp (λ j → P (x≡y (primIMax i j))) i (f (x≡y i))

-- This lemma is due to Anders Mörtberg.

lemma₁ :
  {P : I → Set p} {p : P i0} {q : P i1} →
  PathP P p q ≡ (primTransp P i0 p ≡ q)
lemma₁ {P = P} {p = p} {q = q} = λ i →
  PathP
    (λ j → P (primIMax i j))
    (primTransp (λ j → P (primIMin i j)) (primINeg i) p)
    q

data 𝕊¹ : Set where
  base : 𝕊¹
  loop : base ≡ base

postulate

  Q : 𝕊¹ → Set
  b : Q base
  ℓ : subst Q loop b ≡ b

lemma₂ :
  {eq : x ≡ y} →
  subst Q eq u ≡ v →
  PathP (λ i → Q (eq i)) u v
lemma₂ = subst (λ A → A → PathP _ _ _) lemma₁ (λ x → x)

lemma₃ : (x : 𝕊¹) → Q x
lemma₃ base     = b
lemma₃ (loop i) = lemma₂ ℓ i

postulate

  lemma₄ :
    (eq₂ : subst Q eq₁ (lemma₃ x) ≡ lemma₃ y) →
    hcong lemma₃ eq₁ ≡ lemma₂ eq₂ →
    dcong lemma₃ eq₁ ≡ eq₂

works : dcong lemma₃ loop ≡ ℓ
works = lemma₄ ℓ refl

-- "injectivity" of lemma₃ was the problem
should-work-too : dcong lemma₃ loop ≡ ℓ
should-work-too = lemma₄ _ refl


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.NatPlusOne.Base where

open import Cubical.Core.Primitives
open import Cubical.Data.Nat
open import Cubical.Data.Empty

record ℕ₊₁ : Type₀ where
  constructor 1+_
  field
    n : ℕ

pattern one = 1+ zero
pattern 2+_ n = 1+ (suc n)

-1+_ : ℕ₊₁ → ℕ
-1+ (1+ n) = n

ℕ₊₁→ℕ : ℕ₊₁ → ℕ
ℕ₊₁→ℕ (1+ n) = suc n

suc₊₁ : ℕ₊₁ → ℕ₊₁
suc₊₁ (1+ n) = 1+ (suc n)

-- Natural number literals for ℕ₊₁

open import Cubical.Data.Nat.Literals public

instance
  fromNatℕ₊₁ : HasFromNat ℕ₊₁
  fromNatℕ₊₁ = record { Constraint = λ { zero → ⊥ ; _ → Unit }
                      ; fromNat = λ { (suc n) → 1+ n } }


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

module Categories.Category.Construction.GroupAsCategory o {c ℓ} (G : Group c ℓ) where

open import Level

open import Categories.Category.Groupoid

open Group G

-- A group is a groupoid with a single object
open import Categories.Category.Construction.MonoidAsCategory o monoid
  renaming (MonoidAsCategory to GroupAsCategory) public

GroupIsGroupoid : IsGroupoid GroupAsCategory
GroupIsGroupoid = record
  { iso = record
    { isoˡ = inverseˡ _
    ; isoʳ = inverseʳ _
    }
  }

GroupAsGroupoid : Groupoid o c ℓ
GroupAsGroupoid = record { isGroupoid = GroupIsGroupoid }


------------------------------------------------------------------------
-- Equivalence relations
------------------------------------------------------------------------

module Eq where

infix 4 _≡_

------------------------------------------------------------------------
-- Definition

record Equiv {a : Set} (_≈_ : a -> a -> Set) : Set where
  field
    refl      : forall x       -> x ≈ x
    sym       : forall {x y}   -> x ≈ y -> y ≈ x
    _`trans`_ : forall {x y z} -> x ≈ y -> y ≈ z -> x ≈ z

------------------------------------------------------------------------
-- Propositional equality

data _≡_ {a : Set} (x : a) : a -> Set where
  refl : x ≡ x

subst : forall {a x y} ->
  (P : a -> Set) -> x ≡ y -> P x -> P y
subst _ refl p = p

cong : forall {a b x y} ->
  (f : a -> b) -> x ≡ y -> f x ≡ f y
cong _ refl = refl

Equiv-≡ : forall {a} -> Equiv {a} _≡_
Equiv-≡ {a} =
  record { refl      = \_ -> refl
         ; sym       = sym
         ; _`trans`_ = _`trans`_
         }
  where
  sym : {x y : a} -> x ≡ y -> y ≡ x
  sym refl = refl

  _`trans`_ : {x y z : a} -> x ≡ y -> y ≡ z -> x ≡ z
  refl `trans` refl = refl


------------------------------------------------------------------------------
-- Definition of mutual inductive predicates
------------------------------------------------------------------------------

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

module FOTC.MutualInductivePredicates where

open import FOTC.Base

------------------------------------------------------------------------------
-- Using mutual inductive predicates

data Even : D → Set
data Odd  : D → Set

data Even where
  ezero : Even zero
  esucc : ∀ {n} → Odd n → Even (succ₁ n)

data Odd where
  osucc : ∀ {n} → Even n → Odd (succ₁ n)

-- Non-mutual induction principles

Even-ind : (A : D → Set) →
           A zero →
           (∀ {n} → Odd n → A (succ₁ n)) →
           ∀ {n} → Even n → A n
Even-ind A A0 h ezero      = A0
Even-ind A A0 h (esucc On) = h On

Odd-ind : (A : D → Set) →
          (∀ {n} → Even n → A (succ₁ n)) →
          ∀ {n} → Odd n → A n
Odd-ind A h (osucc En) = h En

-- Mutual induction principles (from Coq)
Even-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Even n → A n

Odd-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Odd n → B n

Even-mutual-ind A B A0 h₁ h₂ ezero      = A0
Even-mutual-ind A B A0 h₁ h₂ (esucc On) = h₁ On (Odd-mutual-ind A B A0 h₁ h₂ On)

Odd-mutual-ind A B A0 h₁ h₂ (osucc En) = h₂ En (Even-mutual-ind A B A0 h₁ h₂ En)

module DisjointSum where
  -- Using a single inductive predicate on D × D (see
  -- Blanchette (2013)).

  _+_ : Set → Set → Set
  _+_ = _∨_

  data EvenOdd : D + D → Set where
    eozero :                            EvenOdd (inj₁ zero)
    eoodd  : {n : D} → EvenOdd (inj₁ n) → EvenOdd (inj₂ (succ₁ n))
    eoeven : {n : D} → EvenOdd (inj₂ n) → EvenOdd (inj₁ (succ₁ n))

  -- Induction principle
  EvenOdd-ind : (A : D + D → Set) →
                A (inj₁ zero) →
                ({n : D} → A (inj₁ n) → A (inj₂ (succ₁ n))) →
                ({n : D} → A (inj₂ n) → A (inj₁ (succ₁ n))) →
                {n : D + D} → EvenOdd n → A n
  EvenOdd-ind A A0 h₁ h₂ eozero       = A0
  EvenOdd-ind A A0 h₁ h₂ (eoodd EOn)  = h₁ (EvenOdd-ind A A0 h₁ h₂ EOn)
  EvenOdd-ind A A0 h₁ h₂ (eoeven EOn) = h₂ (EvenOdd-ind A A0 h₁ h₂ EOn)

  -------------------------------------------------------------------------
  -- From the single inductive predicate to the mutual inductive predicates

  -- Even and Odd from EvenOdd.
  Even' : D → Set
  Even' n = EvenOdd (inj₁ n)

  Odd' : D → Set
  Odd' n = EvenOdd (inj₂ n)

  -- From Even/Odd to Even'/Odd'
  Even→Even' : ∀ {n} → Even n → Even' n
  Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  Even→Even' ezero = eozero
  Even→Even' (esucc On) = eoeven (Odd→Odd' On)

  Odd→Odd' (osucc En) = eoodd (Even→Even' En)

  -- From Even'/Odd' to Even/Odd
  Even'→Even : ∀ {n} → Even' n → Even n
  Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Requires K.
  Even'→Even eozero     = ezero
  Even'→Even (eoeven h) = esucc (Odd'→Odd h)

  Odd'→Odd (eoodd h) = osucc (Even'→Even h)

  -- TODO (03 December 2012). From EvenOdd-ind to Even-mutual-ind and
  -- Odd-mutual-ind.

module FunctionSpace where
-- Using a single inductive predicate on D → D

  data EvenOdd : D → D → Set where
    eozero :                         EvenOdd zero (succ₁ zero)
    eoodd  : ∀ {m n} → EvenOdd m n → EvenOdd m (succ₁ m)
    eoeven : ∀ {m n} → EvenOdd m n → EvenOdd (succ₁ n) n

  -- Even and Odd from EvenOdd.
  -- Even' : D → Set
  -- Even' n = EvenOdd zero (succ₁ zero) ∨ EvenOdd (succ₁ n) n

  -- Odd' : D → Set
  -- Odd' n = EvenOdd n (succ₁ n)

  -- -- From Even/Odd to Even'/Odd'
  -- Even→Even' : ∀ {n} → Even n → Even' n
  -- Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  -- Even→Even' ezero      = inj₁ eozero
  -- Even→Even' (esucc On) = inj₂ (eoeven (Odd→Odd' On))

  -- Odd→Odd' (osucc En) = eoodd {!!}

  -- -- From Even'/Odd' to Even/Odd
  -- Even'→Even : ∀ {n} → Even' n → Even n
  -- Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Even'→Even (inj₁ x) = {!!}
  -- Even'→Even (inj₂ x) = {!!}

  -- Odd'→Odd h = {!!}

------------------------------------------------------------------------------
-- References
--
-- Blanchette, Jasmin Christian (2013). Relational analysis of
-- (co)inductive predicates, (co)algebraic datatypes, and
-- (co)recursive functions. Software Quality Journal 21.1,
-- pp. 101–126.


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

open import Relation.Binary.PropositionalEquality

open import Categories.Category.Dagger
open import Categories.Category.Discrete

Discrete-HasDagger : ∀ {a} (A : Set a) → HasDagger (Discrete A)
Discrete-HasDagger A = record
  { _† = sym
  ; †-identity = refl
  ; †-homomorphism = λ { {f = refl} {g = refl} → refl }
  ; †-resp-≈ = cong sym
  ; †-involutive = λ { refl → refl}
  }

Discrete-DaggerCategory : ∀ {a} (A : Set a) → DaggerCategory a a a
Discrete-DaggerCategory A = record { hasDagger = Discrete-HasDagger A }


module Common.Equality where

open import Common.Level

infix 4 _≡_

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

{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REFL     refl #-}

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

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

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

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


{-# OPTIONS --without-K #-}
module Model.Nat where

open import Model.Size as MS using
  ( Size ; Sizes ; _≤_ ; _<_ ; ≤-IsProp ; nat )
open import Model.Type.Core
open import Util.HoTT.HLevel
open import Util.Prelude
open import Util.Relation.Binary.PropositionalEquality using (Σ-≡⁺)

import Data.Nat.Properties as ℕ

open Size

ℕ≤ : Size → Set
ℕ≤ n = ∃[ m ] (nat m ≤ n)

ℕ≤-IsSet : ∀ {n} → IsSet (ℕ≤ n)
ℕ≤-IsSet = Σ-IsSet ℕ.≡-irrelevant λ m → IsOfHLevel-suc 1 ≤-IsProp

abstract
  ℕ≤-≡⁺ : ∀ {n} {m m′} (m≤n : nat m ≤ n) (m′≤n : nat m′ ≤ n)
    → m ≡ m′
    → (m , m≤n) ≡ (m′ , m′≤n)
  ℕ≤-≡⁺ _ _ m≡m′ = Σ-≡⁺ (m≡m′ , ≤-IsProp _ _)

Nat : ⟦Type⟧ Sizes
Nat = record
  { ObjHSet = λ n → HLevel⁺ (ℕ≤ n) ℕ≤-IsSet
  ; eqHProp = λ { _ (n , _) (m , _) → HLevel⁺ (n ≡ m) ℕ.≡-irrelevant }
  ; eq-refl = λ _ → refl
  }

castℕ≤ : ∀ {n m} → n ≤ m → ℕ≤ n → ℕ≤ m
castℕ≤ n≤m (k , k≤n) = k , go
  where abstract go = MS.≤-trans k≤n n≤m

zero≤ : ∀ n → ℕ≤ n
zero≤ n = 0 , MS.0≤n

suc≤ : ∀ n m → m < n → ℕ≤ m → ℕ≤ n
suc≤ n m m<n (x , x≤m) = suc x , MS.n<m→Sn≤m (MS.≤→<→< x≤m m<n)

caseℕ≤ : ∀ {α} {A : Set α} {n}
  → ℕ≤ n
  → A
  → (∀ m → m < n → ℕ≤ m → A)
  → A
caseℕ≤ (zero , _) z s = z
caseℕ≤ (suc x , Sx≤n) z s = s (nat x) (MS.Sn≤m→n<m Sx≤n) (x , MS.≤-refl)

caseℕ≤-pres : ∀ {α β γ} {A : Set α} {A′ : Set β} {n n′}
  → (R : A → A′ → Set γ)
  → (i : ℕ≤ n) (i′ : ℕ≤ n′)
  → (z : A) (z′ : A′)
  → (s : ∀ m → m < n → ℕ≤ m → A) (s′ : ∀ m → m < n′ → ℕ≤ m → A′)
  → proj₁ i ≡ proj₁ i′
  → R z z′
  → (∀ m m<n m′ m′<n′ j j′
      → proj₁ j ≡ proj₁ j′
      → R (s m m<n j) (s′ m′ m′<n′ j′))
  → R (caseℕ≤ i z s) (caseℕ≤ i′ z′ s′)
caseℕ≤-pres R (zero , _) (_ , _) z z′ s s′ refl zRz′ sRs′ = zRz′
caseℕ≤-pres R (suc i , _) (_ , _) z z′ s s′ refl zRz′ sRs′
  = sRs′ _ _ _ _ _ _ refl


module Oscar.Class.Congruity where

open import Oscar.Class.Extensionality
open import Oscar.Level

record Congruity {a} {A : Set a} {ℓ₁} (_≋₁_ : A → A → Set ℓ₁)
                 {b} {B : Set b} {ℓ₂} (_≋₂_ : B → B → Set ℓ₂)
       : Set (a ⊔ ℓ₁ ⊔ b ⊔ ℓ₂) where
  field
    congruity : ∀ (μ : A → B) {x y} → x ≋₁ y → μ x ≋₂ μ y

  instance ′extensionality : ∀ (μ : A → B) → Extensionality _≋₁_ (λ ⋆ → _≋₂_ ⋆) μ μ
  Extensionality.extensionality (′extensionality μ) = congruity μ

open Congruity ⦃ … ⦄ public -- hiding (′extensionality)