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

module 05-identity-types where

import 04-inductive-types
open 04-inductive-types public

-- Section 5.1

-- Definition 5.1.1

{- We introduce the identity type. -}

data Id {i : Level} {A : UU i} (x : A) : A → UU i where
  refl : Id x x

{- In the following definition we give a construction of path induction.
   However, in the development of this library we will mostly use Agda's
   built-in methods to give constructions by path induction. -}

ind-Id :
  {i j : Level} {A : UU i} (x : A) (B : (y : A) (p : Id x y) → UU j) →
  (B x refl) → (y : A) (p : Id x y) → B y p
ind-Id x B b y refl = b

-- Section 5.2 The groupoid structure of types

-- Definition 5.2.1

_∙_ :
  {i : Level} {A : UU i} {x y z : A} → Id x y → Id y z → Id x z
refl ∙ q = q

concat :
  {i : Level} {A : UU i} {x y : A} → Id x y → (z : A) → Id y z → Id x z
concat p z q = p ∙ q

-- Definition 5.2.2

inv :
  {i : Level} {A : UU i} {x y : A} → Id x y → Id y x
inv refl = refl

-- Definition 5.2.3

assoc :
  {i : Level} {A : UU i} {x y z w : A} (p : Id x y) (q : Id y z)
  (r : Id z w) → Id ((p ∙ q) ∙ r) (p ∙ (q ∙ r))
assoc refl q r = refl

-- Definition 5.2.4

left-unit :
  {i : Level} {A : UU i} {x y : A} {p : Id x y} → Id (refl ∙ p) p
left-unit = refl

right-unit :
  {i : Level} {A : UU i} {x y : A} {p : Id x y} → Id (p ∙ refl) p
right-unit {p = refl} = refl

-- Definition 5.2.5

left-inv :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) →
  Id ((inv p) ∙ p) refl
left-inv refl = refl

right-inv :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) →
  Id (p ∙ (inv p)) refl
right-inv refl = refl

-- Section 5.3 The action on paths of functions

-- Definition 5.3.1

ap :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) {x y : A} (p : Id x y) →
  Id (f x) (f y)
ap f refl = refl

ap-id :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) → Id (ap id p) p
ap-id refl = refl

ap-comp :
  {i j k : Level} {A : UU i} {B : UU j} {C : UU k} (g : B → C)
  (f : A → B) {x y : A} (p : Id x y) → Id (ap (g ∘ f) p) (ap g (ap f p))
ap-comp g f refl = refl

-- Definition 5.3.2

ap-refl :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (x : A) →
  Id (ap f (refl {_} {_} {x})) refl
ap-refl f x = refl

ap-concat :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) {x y z : A}
  (p : Id x y) (q : Id y z) → Id (ap f (p ∙ q)) ((ap f p) ∙ (ap f q))
ap-concat f refl q = refl

ap-inv :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) {x y : A}
  (p : Id x y) → Id (ap f (inv p)) (inv (ap f p))
ap-inv f refl = refl

-- Section 5.4 Transport

-- Definition 5.4.1

tr :
  {i j : Level} {A : UU i} (B : A → UU j) {x y : A} (p : Id x y) → B x → B y
tr B refl b = b

-- Definition 5.4.2

apd :
  {i j : Level} {A : UU i} {B : A → UU j} (f : (x : A) → B x) {x y : A}
  (p : Id x y) → Id (tr B p (f x)) (f y)
apd f refl = refl

path-over :
  {i j : Level} {A :  UU i} (B : A → UU j) {x x' : A} (p : Id x x') →
  B x → B x' → UU j
path-over B p y y' = Id (tr B p y) y'

refl-path-over :
  {i j : Level} {A : UU i} (B : A → UU j) (x : A) (y : B x) →
  path-over B refl y y
refl-path-over B x y = refl

-- Exercises

-- Exercise 5.1

-- Exercise 5.2

distributive-inv-concat :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) {z : A}
  (q : Id y z) → Id (inv (p ∙ q)) ((inv q) ∙ (inv p))
distributive-inv-concat refl refl = refl

-- Exercise 5.3

inv-con :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) {z : A} (q : Id y z)
  (r : Id x z) → (Id (p ∙ q) r) → Id q ((inv p) ∙ r)
inv-con refl q r = id

con-inv :
  {i : Level} {A : UU i} {x y : A} (p : Id x y) {z : A} (q : Id y z)
  (r : Id x z) → (Id (p ∙ q) r) → Id p (r ∙ (inv q))
con-inv p refl r =
  ( λ α → α ∙ (inv right-unit)) ∘ (concat (inv right-unit) r)

-- Exercise 5.4

lift :
  {i j : Level} {A : UU i} {B : A → UU j} {x y : A} (p : Id x y)
  (b : B x) → Id (pair x b) (pair y (tr B p b))
lift refl b = refl

-- Exercise 5.5

-- Exercise 5.5(a)

abstract
  right-unit-law-add-ℕ :
    (x : ℕ) → Id (add-ℕ x zero-ℕ) x
  right-unit-law-add-ℕ x = refl

  left-unit-law-add-ℕ :
    (x : ℕ) → Id (add-ℕ zero-ℕ x) x
  left-unit-law-add-ℕ zero-ℕ = refl
  left-unit-law-add-ℕ (succ-ℕ x) = ap succ-ℕ (left-unit-law-add-ℕ x)

  left-successor-law-add-ℕ :
    (x y : ℕ) → Id (add-ℕ (succ-ℕ x) y) (succ-ℕ (add-ℕ x y))
  left-successor-law-add-ℕ x zero-ℕ = refl
  left-successor-law-add-ℕ x (succ-ℕ y) =
    ap succ-ℕ (left-successor-law-add-ℕ x y)

  right-successor-law-add-ℕ :
    (x y : ℕ) → Id (add-ℕ x (succ-ℕ y)) (succ-ℕ (add-ℕ x y))
  right-successor-law-add-ℕ x y = refl

-- Exercise 5.5(b)

abstract
  associative-add-ℕ :
    (x y z : ℕ) → Id (add-ℕ (add-ℕ x y) z) (add-ℕ x (add-ℕ y z))
  associative-add-ℕ x y zero-ℕ = refl
  associative-add-ℕ x y (succ-ℕ z) = ap succ-ℕ (associative-add-ℕ x y z)

abstract
  commutative-add-ℕ : (x y : ℕ) → Id (add-ℕ x y) (add-ℕ y x)
  commutative-add-ℕ zero-ℕ y = left-unit-law-add-ℕ y
  commutative-add-ℕ (succ-ℕ x) y =
    (left-successor-law-add-ℕ x y) ∙ (ap succ-ℕ (commutative-add-ℕ x y))

-- Exercise 5.5(c)

abstract
  left-zero-law-mul-ℕ :
    (x : ℕ) → Id (mul-ℕ zero-ℕ x) zero-ℕ
  left-zero-law-mul-ℕ x = refl

  right-zero-law-mul-ℕ :
    (x : ℕ) → Id (mul-ℕ x zero-ℕ) zero-ℕ
  right-zero-law-mul-ℕ zero-ℕ = refl
  right-zero-law-mul-ℕ (succ-ℕ x) =
    ( right-unit-law-add-ℕ (mul-ℕ x zero-ℕ)) ∙ (right-zero-law-mul-ℕ x)

abstract
  right-unit-law-mul-ℕ :
    (x : ℕ) → Id (mul-ℕ x one-ℕ) x
  right-unit-law-mul-ℕ zero-ℕ = refl
  right-unit-law-mul-ℕ (succ-ℕ x) = ap succ-ℕ (right-unit-law-mul-ℕ x)

  left-unit-law-mul-ℕ :
    (x : ℕ) → Id (mul-ℕ one-ℕ x) x
  left-unit-law-mul-ℕ zero-ℕ = refl
  left-unit-law-mul-ℕ (succ-ℕ x) = ap succ-ℕ (left-unit-law-mul-ℕ x)

abstract
  left-successor-law-mul-ℕ :
    (x y : ℕ) → Id (mul-ℕ (succ-ℕ x) y) (add-ℕ (mul-ℕ x y) y)
  left-successor-law-mul-ℕ x y = refl

  right-successor-law-mul-ℕ :
    (x y : ℕ) → Id (mul-ℕ x (succ-ℕ y)) (add-ℕ x (mul-ℕ x y))
  right-successor-law-mul-ℕ zero-ℕ y = refl
  right-successor-law-mul-ℕ (succ-ℕ x) y =
    ( ( ap (λ t → succ-ℕ (add-ℕ t y)) (right-successor-law-mul-ℕ x y)) ∙
      ( ap succ-ℕ (associative-add-ℕ x (mul-ℕ x y) y))) ∙
    ( inv (left-successor-law-add-ℕ x (add-ℕ (mul-ℕ x y) y)))

-- Exercise 5.5(d)

abstract
  commutative-mul-ℕ :
    (x y : ℕ) → Id (mul-ℕ x y) (mul-ℕ y x)
  commutative-mul-ℕ zero-ℕ y = inv (right-zero-law-mul-ℕ y)
  commutative-mul-ℕ (succ-ℕ x) y =
    ( commutative-add-ℕ (mul-ℕ x y) y) ∙
    ( ( ap (add-ℕ y) (commutative-mul-ℕ x y)) ∙
      ( inv (right-successor-law-mul-ℕ y x)))

-- Exercise 5.5(e)

abstract
  left-distributive-mul-add-ℕ :
    (x y z : ℕ) → Id (mul-ℕ x (add-ℕ y z)) (add-ℕ (mul-ℕ x y) (mul-ℕ x z))
  left-distributive-mul-add-ℕ zero-ℕ y z = refl
  left-distributive-mul-add-ℕ (succ-ℕ x) y z =
    ( left-successor-law-mul-ℕ x (add-ℕ y z)) ∙
    ( ( ap (λ t → add-ℕ t (add-ℕ y z)) (left-distributive-mul-add-ℕ x y z)) ∙
      ( ( associative-add-ℕ (mul-ℕ x y) (mul-ℕ x z) (add-ℕ y z)) ∙
        ( ( ap ( add-ℕ (mul-ℕ x y))
               ( ( inv (associative-add-ℕ (mul-ℕ x z) y z)) ∙
                 ( ( ap (λ t → add-ℕ t z) (commutative-add-ℕ (mul-ℕ x z) y)) ∙
                   ( associative-add-ℕ y (mul-ℕ x z) z)))) ∙
          ( inv (associative-add-ℕ (mul-ℕ x y) y (add-ℕ (mul-ℕ x z) z))))))

abstract
  right-distributive-mul-add-ℕ :
    (x y z : ℕ) → Id (mul-ℕ (add-ℕ x y) z) (add-ℕ (mul-ℕ x z) (mul-ℕ y z))
  right-distributive-mul-add-ℕ x y z =
    ( commutative-mul-ℕ (add-ℕ x y) z) ∙
    ( ( left-distributive-mul-add-ℕ z x y) ∙
      ( ( ap (λ t → add-ℕ t (mul-ℕ z y)) (commutative-mul-ℕ z x)) ∙
        ( ap (λ t → add-ℕ (mul-ℕ x z) t) (commutative-mul-ℕ z y))))

-- Exercise 5.5(f)

abstract
  associative-mul-ℕ :
    (x y z : ℕ) → Id (mul-ℕ (mul-ℕ x y) z) (mul-ℕ x (mul-ℕ y z))
  associative-mul-ℕ zero-ℕ y z = refl
  associative-mul-ℕ (succ-ℕ x) y z =
    ( right-distributive-mul-add-ℕ (mul-ℕ x y) y z) ∙
    ( ap (λ t → add-ℕ t (mul-ℕ y z)) (associative-mul-ℕ x y z))

-- Exercise 5.6

Mac-Lane-pentagon :
  {i : Level} {A : UU i} {a b c d e : A}
  (p : Id a b) (q : Id b c) (r : Id c d) (s : Id d e) →
  let α₁ = (ap (λ t → t ∙ s) (assoc p q r))
      α₂ = (assoc p (q ∙ r) s)
      α₃ = (ap (λ t → p ∙ t) (assoc q r s))
      α₄ = (assoc (p ∙ q) r s)
      α₅ = (assoc p q (r ∙ s))
  in
  Id ((α₁ ∙ α₂) ∙ α₃) (α₄ ∙ α₅)
Mac-Lane-pentagon refl refl refl refl = refl

{- The following code is an experiment that shows that constructions in an
   abstract environment do remember the specific definitions of previous
   definitions in abstract environments. -}

abstract
  abstract-concat :
    {l : Level} {A : UU l} {x y z : A} → Id x y → Id y z → Id x z
  abstract-concat refl q = q

  abstract-left-unit-law :
    {l : Level} {A : UU l} {x y : A} (q : Id x y) → Id (abstract-concat refl q) q
  abstract-left-unit-law q = refl

{- We just make some random definition to make sure that we are not in the
   same abstract envirnoment anymore. -}
one : ℕ
one = succ-ℕ zero-ℕ

abstract
  abstract-right-unit-law :
    {l : Level} {A : UU l} {x y : A} (p : Id x y) →
      Id (abstract-concat p refl) p
  abstract-right-unit-law refl = refl

  {- The term refl should not be accepted if the definition of abstract-concat
     were forgotten. A definition that would work under all circumstances is
     abstract-left-unit refl. -}

-- The ring axioms for ℤ

abstract
  left-inverse-pred-ℤ :
    (k : ℤ) → Id (pred-ℤ (succ-ℤ k)) k
  left-inverse-pred-ℤ (inl zero-ℕ) = refl
  left-inverse-pred-ℤ (inl (succ-ℕ x)) = refl
  left-inverse-pred-ℤ (inr (inl star)) = refl
  left-inverse-pred-ℤ (inr (inr zero-ℕ)) = refl
  left-inverse-pred-ℤ (inr (inr (succ-ℕ x))) = refl

  right-inverse-pred-ℤ :
    (k : ℤ) → Id (succ-ℤ (pred-ℤ k)) k
  right-inverse-pred-ℤ (inl zero-ℕ) = refl
  right-inverse-pred-ℤ (inl (succ-ℕ x)) = refl
  right-inverse-pred-ℤ (inr (inl star)) = refl
  right-inverse-pred-ℤ (inr (inr zero-ℕ)) = refl
  right-inverse-pred-ℤ (inr (inr (succ-ℕ x))) = refl

{- Exercise 6.12 (a) simply asks to prove the unit laws. The left unit law
   holds by judgmental equality. -}

abstract
  left-unit-law-add-ℤ :
    (k : ℤ) → Id (add-ℤ zero-ℤ k) k
  left-unit-law-add-ℤ k = refl

  right-unit-law-add-ℤ :
    (k : ℤ) → Id (add-ℤ k zero-ℤ) k
  right-unit-law-add-ℤ (inl zero-ℕ) = refl
  right-unit-law-add-ℤ (inl (succ-ℕ x)) =
    ap pred-ℤ (right-unit-law-add-ℤ (inl x))
  right-unit-law-add-ℤ (inr (inl star)) = refl
  right-unit-law-add-ℤ (inr (inr zero-ℕ)) = refl
  right-unit-law-add-ℤ (inr (inr (succ-ℕ x))) =
    ap succ-ℤ (right-unit-law-add-ℤ (inr (inr x)))

{- Exercise 6.12 (b) asks to show the left and right predecessor and successor
   laws. These are helpful to give proofs of associativity and commutativity.
   -}

abstract
  left-predecessor-law-add-ℤ :
    (x y : ℤ) → Id (add-ℤ (pred-ℤ x) y) (pred-ℤ (add-ℤ x y))
  left-predecessor-law-add-ℤ (inl n) y = refl
  left-predecessor-law-add-ℤ (inr (inl star)) y = refl
  left-predecessor-law-add-ℤ (inr (inr zero-ℕ)) y =
    ( ap (λ t → add-ℤ t y) (left-inverse-pred-ℤ zero-ℤ)) ∙
    ( inv (left-inverse-pred-ℤ y))
  left-predecessor-law-add-ℤ (inr (inr (succ-ℕ x))) y =
    ( ap (λ t → (add-ℤ t y)) (left-inverse-pred-ℤ (inr (inr x)))) ∙
    ( inv (left-inverse-pred-ℤ (add-ℤ (inr (inr x)) y)))

  right-predecessor-law-add-ℤ :
    (x y : ℤ) → Id (add-ℤ x (pred-ℤ y)) (pred-ℤ (add-ℤ x y))
  right-predecessor-law-add-ℤ (inl zero-ℕ) n = refl
  right-predecessor-law-add-ℤ (inl (succ-ℕ m)) n =
    ap pred-ℤ (right-predecessor-law-add-ℤ (inl m) n)
  right-predecessor-law-add-ℤ (inr (inl star)) n = refl
  right-predecessor-law-add-ℤ (inr (inr zero-ℕ)) n =
    (right-inverse-pred-ℤ n) ∙ (inv (left-inverse-pred-ℤ n))
  right-predecessor-law-add-ℤ (inr (inr (succ-ℕ x))) n =
    ( ap succ-ℤ (right-predecessor-law-add-ℤ (inr (inr x)) n)) ∙
    ( ( right-inverse-pred-ℤ (add-ℤ (inr (inr x)) n)) ∙
      ( inv (left-inverse-pred-ℤ (add-ℤ (inr (inr x)) n))))

abstract
  left-successor-law-add-ℤ :
    (x y : ℤ) → Id (add-ℤ (succ-ℤ x) y) (succ-ℤ (add-ℤ x y))
  left-successor-law-add-ℤ (inl zero-ℕ) y =
    ( ap (λ t → add-ℤ t y) (right-inverse-pred-ℤ zero-ℤ)) ∙
    ( inv (right-inverse-pred-ℤ y))
  left-successor-law-add-ℤ (inl (succ-ℕ x)) y =
    ( inv (right-inverse-pred-ℤ (add-ℤ (inl x) y))) ∙
    ( ap succ-ℤ (inv (left-predecessor-law-add-ℤ (inl x) y)))
  left-successor-law-add-ℤ (inr (inl star)) y = refl
  left-successor-law-add-ℤ (inr (inr x)) y = refl

  right-successor-law-add-ℤ :
    (x y : ℤ) → Id (add-ℤ x (succ-ℤ y)) (succ-ℤ (add-ℤ x y))
  right-successor-law-add-ℤ (inl zero-ℕ) y =
    (left-inverse-pred-ℤ y) ∙ (inv (right-inverse-pred-ℤ y))
  right-successor-law-add-ℤ (inl (succ-ℕ x)) y =
    ( ap pred-ℤ (right-successor-law-add-ℤ (inl x) y)) ∙
    ( ( left-inverse-pred-ℤ (add-ℤ (inl x) y)) ∙
      ( inv (right-inverse-pred-ℤ (add-ℤ (inl x) y))))
  right-successor-law-add-ℤ (inr (inl star)) y = refl
  right-successor-law-add-ℤ (inr (inr zero-ℕ)) y = refl
  right-successor-law-add-ℤ (inr (inr (succ-ℕ x))) y =
    ap succ-ℤ (right-successor-law-add-ℤ (inr (inr x)) y)

{- Exercise 6.12 (c) asks to prove associativity and commutativity. Note that
   we avoid an unwieldy amount of cases by only using induction on the first
   argument. The resulting proof term is fairly short, and we don't have to
   present ℤ as a certain quotient of ℕ × ℕ. -}

abstract
  associative-add-ℤ :
    (x y z : ℤ) → Id (add-ℤ (add-ℤ x y) z) (add-ℤ x (add-ℤ y z))
  associative-add-ℤ (inl zero-ℕ) y z =
    ( ap (λ t → add-ℤ t z) (left-predecessor-law-add-ℤ zero-ℤ y)) ∙
    ( ( left-predecessor-law-add-ℤ y z) ∙
      ( inv (left-predecessor-law-add-ℤ zero-ℤ (add-ℤ y z))))
  associative-add-ℤ (inl (succ-ℕ x)) y z =
    ( ap (λ t → add-ℤ t z) (left-predecessor-law-add-ℤ (inl x) y)) ∙
    ( ( left-predecessor-law-add-ℤ (add-ℤ (inl x) y) z) ∙
      ( ( ap pred-ℤ (associative-add-ℤ (inl x) y z)) ∙
        ( inv (left-predecessor-law-add-ℤ (inl x) (add-ℤ y z)))))
  associative-add-ℤ (inr (inl star)) y z = refl
  associative-add-ℤ (inr (inr zero-ℕ)) y z =
    ( ap (λ t → add-ℤ t z) (left-successor-law-add-ℤ zero-ℤ y)) ∙
    ( ( left-successor-law-add-ℤ y z) ∙
      ( inv (left-successor-law-add-ℤ zero-ℤ (add-ℤ y z))))
  associative-add-ℤ (inr (inr (succ-ℕ x))) y z =
    ( ap (λ t → add-ℤ t z) (left-successor-law-add-ℤ (inr (inr x)) y)) ∙
    ( ( left-successor-law-add-ℤ (add-ℤ (inr (inr x)) y) z) ∙
      ( ( ap succ-ℤ (associative-add-ℤ (inr (inr x)) y z)) ∙
        ( inv (left-successor-law-add-ℤ (inr (inr x)) (add-ℤ y z)))))

abstract
  commutative-add-ℤ :
    (x y : ℤ) → Id (add-ℤ x y) (add-ℤ y x)
  commutative-add-ℤ (inl zero-ℕ) y =
    ( left-predecessor-law-add-ℤ zero-ℤ y) ∙
    ( inv
      ( ( right-predecessor-law-add-ℤ y zero-ℤ) ∙
        ( ap pred-ℤ (right-unit-law-add-ℤ y))))
  commutative-add-ℤ (inl (succ-ℕ x)) y =
    ( ap pred-ℤ (commutative-add-ℤ (inl x) y)) ∙
    ( inv (right-predecessor-law-add-ℤ y (inl x)))
  commutative-add-ℤ (inr (inl star)) y = inv (right-unit-law-add-ℤ y)
  commutative-add-ℤ (inr (inr zero-ℕ)) y =
    inv
      ( ( right-successor-law-add-ℤ y zero-ℤ) ∙
        ( ap succ-ℤ (right-unit-law-add-ℤ y)))
  commutative-add-ℤ (inr (inr (succ-ℕ x))) y =
    ( ap succ-ℤ (commutative-add-ℤ (inr (inr x)) y)) ∙
    ( inv (right-successor-law-add-ℤ y (inr (inr x))))

{- Exercise 6.12 (d) finally asks to show the inverse laws, completing the
   verification of the group laws. Combined with associativity and
   commutativity we conclude that (add-ℤ x) and (λ x → add-ℤ x y) are
   equivalences, for every x : ℤ and y : ℤ, respectively. -}

abstract
  left-inverse-law-add-ℤ :
    (x : ℤ) → Id (add-ℤ (neg-ℤ x) x) zero-ℤ
  left-inverse-law-add-ℤ (inl zero-ℕ) = refl
  left-inverse-law-add-ℤ (inl (succ-ℕ x)) =
    ( ap succ-ℤ (right-predecessor-law-add-ℤ (inr (inr x)) (inl x))) ∙
    ( ( right-inverse-pred-ℤ (add-ℤ (inr (inr x)) (inl x))) ∙
      ( left-inverse-law-add-ℤ (inl x)))
  left-inverse-law-add-ℤ (inr (inl star)) = refl
  left-inverse-law-add-ℤ (inr (inr x)) =
    ( commutative-add-ℤ (inl x) (inr (inr x))) ∙
    ( left-inverse-law-add-ℤ (inl x))

  right-inverse-law-add-ℤ :
    (x : ℤ) → Id (add-ℤ x (neg-ℤ x)) zero-ℤ
  right-inverse-law-add-ℤ x =
    ( commutative-add-ℤ x (neg-ℤ x)) ∙ (left-inverse-law-add-ℤ x)

-- Similar for multiplication on ℤ

neg-neg-ℤ : (k : ℤ) → Id (neg-ℤ (neg-ℤ k)) k
neg-neg-ℤ (inl n) = refl
neg-neg-ℤ (inr (inl star)) = refl
neg-neg-ℤ (inr (inr n)) = refl

neg-pred-ℤ :
  (k : ℤ) → Id (neg-ℤ (pred-ℤ k)) (succ-ℤ (neg-ℤ k))
neg-pred-ℤ (inl x) = refl
neg-pred-ℤ (inr (inl star)) = refl
neg-pred-ℤ (inr (inr zero-ℕ)) = refl
neg-pred-ℤ (inr (inr (succ-ℕ x))) = refl

pred-neg-ℤ :
  (k : ℤ) → Id (pred-ℤ (neg-ℤ k)) (neg-ℤ (succ-ℤ k))
pred-neg-ℤ (inl zero-ℕ) = refl
pred-neg-ℤ (inl (succ-ℕ x)) = refl
pred-neg-ℤ (inr (inl star)) = refl
pred-neg-ℤ (inr (inr x)) = refl

right-negative-law-add-ℤ :
  (k l : ℤ) → Id (add-ℤ k (neg-ℤ l)) (neg-ℤ (add-ℤ (neg-ℤ k) l))
right-negative-law-add-ℤ (inl zero-ℕ) l =
  ( left-predecessor-law-add-ℤ zero-ℤ (neg-ℤ l)) ∙
  ( pred-neg-ℤ l)
right-negative-law-add-ℤ (inl (succ-ℕ x)) l =
  ( left-predecessor-law-add-ℤ (inl x) (neg-ℤ l)) ∙
  ( ( ap pred-ℤ (right-negative-law-add-ℤ (inl x) l)) ∙
    ( pred-neg-ℤ (add-ℤ (inr (inr x)) l)))
right-negative-law-add-ℤ (inr (inl star)) l = refl
right-negative-law-add-ℤ (inr (inr zero-ℕ)) l = inv (neg-pred-ℤ l)
right-negative-law-add-ℤ (inr (inr (succ-ℕ n))) l =
  ( left-successor-law-add-ℤ (in-pos n) (neg-ℤ l)) ∙
  ( ( ap succ-ℤ (right-negative-law-add-ℤ (inr (inr n)) l)) ∙
    ( inv (neg-pred-ℤ (add-ℤ (inl n) l))))

distributive-neg-add-ℤ :
  (k l : ℤ) → Id (neg-ℤ (add-ℤ k l)) (add-ℤ (neg-ℤ k) (neg-ℤ l))
distributive-neg-add-ℤ (inl zero-ℕ) l =
  ( ap neg-ℤ (left-predecessor-law-add-ℤ zero-ℤ l)) ∙
  ( neg-pred-ℤ l)
distributive-neg-add-ℤ (inl (succ-ℕ n)) l =
  ( neg-pred-ℤ (add-ℤ (inl n) l)) ∙
  ( ( ap succ-ℤ (distributive-neg-add-ℤ (inl n) l)) ∙
    ( ap (λ t → add-ℤ t (neg-ℤ l)) (inv (neg-pred-ℤ (inl n)))))
distributive-neg-add-ℤ (inr (inl star)) l = refl
distributive-neg-add-ℤ (inr (inr zero-ℕ)) l = inv (pred-neg-ℤ l)
distributive-neg-add-ℤ (inr (inr (succ-ℕ n))) l =
  ( inv (pred-neg-ℤ (add-ℤ (in-pos n) l))) ∙
  ( ap pred-ℤ (distributive-neg-add-ℤ (inr (inr n)) l))

left-zero-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ zero-ℤ k) zero-ℤ
left-zero-law-mul-ℤ k = refl

right-zero-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ k zero-ℤ) zero-ℤ
right-zero-law-mul-ℤ (inl zero-ℕ) = refl
right-zero-law-mul-ℤ (inl (succ-ℕ n)) =
  right-zero-law-mul-ℤ (inl n)
right-zero-law-mul-ℤ (inr (inl star)) = refl
right-zero-law-mul-ℤ (inr (inr zero-ℕ)) = refl
right-zero-law-mul-ℤ (inr (inr (succ-ℕ n))) =
  right-zero-law-mul-ℤ (inr (inr n))

left-unit-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ one-ℤ k) k
left-unit-law-mul-ℤ k = refl

right-unit-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ k one-ℤ) k
right-unit-law-mul-ℤ (inl zero-ℕ) = refl
right-unit-law-mul-ℤ (inl (succ-ℕ n)) =
  ap (add-ℤ (neg-one-ℤ)) (right-unit-law-mul-ℤ (inl n))
right-unit-law-mul-ℤ (inr (inl star)) = refl
right-unit-law-mul-ℤ (inr (inr zero-ℕ)) = refl
right-unit-law-mul-ℤ (inr (inr (succ-ℕ n))) =
  ap (add-ℤ one-ℤ) (right-unit-law-mul-ℤ (inr (inr n)))

left-neg-unit-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ neg-one-ℤ k) (neg-ℤ k)
left-neg-unit-law-mul-ℤ k = refl

right-neg-unit-law-mul-ℤ : (k : ℤ) → Id (mul-ℤ k neg-one-ℤ) (neg-ℤ k)
right-neg-unit-law-mul-ℤ (inl zero-ℕ) = refl
right-neg-unit-law-mul-ℤ (inl (succ-ℕ n)) =
  ap (add-ℤ one-ℤ) (right-neg-unit-law-mul-ℤ (inl n))
right-neg-unit-law-mul-ℤ (inr (inl star)) = refl
right-neg-unit-law-mul-ℤ (inr (inr zero-ℕ)) = refl
right-neg-unit-law-mul-ℤ (inr (inr (succ-ℕ n))) =
  ap (add-ℤ neg-one-ℤ) (right-neg-unit-law-mul-ℤ (inr (inr n)))

left-successor-law-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ (succ-ℤ k) l) (add-ℤ l (mul-ℤ k l))
left-successor-law-mul-ℤ (inl zero-ℕ) l =
  inv (right-inverse-law-add-ℤ l)
left-successor-law-mul-ℤ (inl (succ-ℕ n)) l =
  ( ( inv (left-unit-law-add-ℤ (mul-ℤ (inl n) l))) ∙
    ( ap
      ( λ x → add-ℤ x (mul-ℤ (inl n) l))
      ( inv (right-inverse-law-add-ℤ l)))) ∙
  ( associative-add-ℤ l (neg-ℤ l) (mul-ℤ (inl n) l))
left-successor-law-mul-ℤ (inr (inl star)) l =
  inv (right-unit-law-add-ℤ l)
left-successor-law-mul-ℤ (inr (inr n)) l = refl

left-predecessor-law-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ (pred-ℤ k) l) (add-ℤ (neg-ℤ l) (mul-ℤ k l))
left-predecessor-law-mul-ℤ (inl n) l = refl
left-predecessor-law-mul-ℤ (inr (inl star)) l =
  ( left-neg-unit-law-mul-ℤ l) ∙
  ( inv (right-unit-law-add-ℤ (neg-ℤ l)))
left-predecessor-law-mul-ℤ (inr (inr zero-ℕ)) l =
  inv (left-inverse-law-add-ℤ l)
left-predecessor-law-mul-ℤ (inr (inr (succ-ℕ x))) l =
   ( ap
     ( λ t → add-ℤ t (mul-ℤ (in-pos x) l))
     ( inv (left-inverse-law-add-ℤ l))) ∙
   ( associative-add-ℤ (neg-ℤ l) l (mul-ℤ (in-pos x) l))

right-successor-law-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ k (succ-ℤ l)) (add-ℤ k (mul-ℤ k l))
right-successor-law-mul-ℤ (inl zero-ℕ) l = inv (pred-neg-ℤ l)
right-successor-law-mul-ℤ (inl (succ-ℕ n)) l =
  ( left-predecessor-law-mul-ℤ (inl n) (succ-ℤ l)) ∙
  ( ( ap (add-ℤ (neg-ℤ (succ-ℤ l))) (right-successor-law-mul-ℤ (inl n) l)) ∙
    ( ( inv (associative-add-ℤ (neg-ℤ (succ-ℤ l)) (inl n) (mul-ℤ (inl n) l))) ∙
      ( ( ap
          ( λ t → add-ℤ t (mul-ℤ (inl n) l))
          { x = add-ℤ (neg-ℤ (succ-ℤ l)) (inl n)}
          { y = add-ℤ (inl (succ-ℕ n)) (neg-ℤ l)}
          ( ( right-successor-law-add-ℤ (neg-ℤ (succ-ℤ l)) (inl (succ-ℕ n))) ∙
            ( ( ap succ-ℤ
                ( commutative-add-ℤ (neg-ℤ (succ-ℤ l)) (inl (succ-ℕ n)))) ∙
              ( ( inv
                  ( right-successor-law-add-ℤ
                    ( inl (succ-ℕ n))
                    ( neg-ℤ (succ-ℤ l)))) ∙
                ( ap
                  ( add-ℤ (inl (succ-ℕ n)))
                  ( ( ap succ-ℤ (inv (pred-neg-ℤ l))) ∙
                    ( right-inverse-pred-ℤ (neg-ℤ l)))))))) ∙
        ( associative-add-ℤ (inl (succ-ℕ n)) (neg-ℤ l) (mul-ℤ (inl n) l)))))
right-successor-law-mul-ℤ (inr (inl star)) l = refl
right-successor-law-mul-ℤ (inr (inr zero-ℕ)) l = refl
right-successor-law-mul-ℤ (inr (inr (succ-ℕ n))) l =
  ( left-successor-law-mul-ℤ (in-pos n) (succ-ℤ l)) ∙
  ( ( ap (add-ℤ (succ-ℤ l)) (right-successor-law-mul-ℤ (inr (inr n)) l)) ∙
    ( ( inv (associative-add-ℤ (succ-ℤ l) (in-pos n) (mul-ℤ (in-pos n) l))) ∙
      ( ( ap
          ( λ t → add-ℤ t (mul-ℤ (in-pos n) l))
          { x = add-ℤ (succ-ℤ l) (in-pos n)}
          { y = add-ℤ (in-pos (succ-ℕ n)) l}
          ( ( left-successor-law-add-ℤ l (in-pos n)) ∙
            ( ( ap succ-ℤ (commutative-add-ℤ l (in-pos n))) ∙
              ( inv (left-successor-law-add-ℤ (in-pos n) l))))) ∙
        ( associative-add-ℤ (inr (inr (succ-ℕ n))) l (mul-ℤ (inr (inr n)) l)))))

right-predecessor-law-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ k (pred-ℤ l)) (add-ℤ (neg-ℤ k) (mul-ℤ k l))
right-predecessor-law-mul-ℤ (inl zero-ℕ) l =
  ( left-neg-unit-law-mul-ℤ (pred-ℤ l)) ∙
  ( neg-pred-ℤ l)
right-predecessor-law-mul-ℤ (inl (succ-ℕ n)) l =
  ( left-predecessor-law-mul-ℤ (inl n) (pred-ℤ l)) ∙
  ( ( ap (add-ℤ (neg-ℤ (pred-ℤ l))) (right-predecessor-law-mul-ℤ (inl n) l)) ∙
    ( ( inv
        ( associative-add-ℤ (neg-ℤ (pred-ℤ l)) (in-pos n) (mul-ℤ (inl n) l))) ∙
      ( ( ap
          ( λ t → add-ℤ t (mul-ℤ (inl n) l))
          { x = add-ℤ (neg-ℤ (pred-ℤ l)) (inr (inr n))}
          { y = add-ℤ (neg-ℤ (inl (succ-ℕ n))) (neg-ℤ l)}
          ( ( ap (λ t → add-ℤ t (in-pos n)) (neg-pred-ℤ l)) ∙
            ( ( left-successor-law-add-ℤ (neg-ℤ l) (in-pos n)) ∙
              ( ( ap succ-ℤ (commutative-add-ℤ (neg-ℤ l) (in-pos n))) ∙
                ( inv (left-successor-law-add-ℤ (in-pos n) (neg-ℤ l))))))) ∙
        ( associative-add-ℤ (in-pos (succ-ℕ n)) (neg-ℤ l) (mul-ℤ (inl n) l)))))
right-predecessor-law-mul-ℤ (inr (inl star)) l = refl
right-predecessor-law-mul-ℤ (inr (inr zero-ℕ)) l = refl
right-predecessor-law-mul-ℤ (inr (inr (succ-ℕ n))) l =
  ( left-successor-law-mul-ℤ (in-pos n) (pred-ℤ l)) ∙
  ( ( ap (add-ℤ (pred-ℤ l)) (right-predecessor-law-mul-ℤ (inr (inr n)) l)) ∙
    ( ( inv (associative-add-ℤ (pred-ℤ l) (inl n) (mul-ℤ (inr (inr n)) l))) ∙
      ( ( ap
          ( λ t → add-ℤ t (mul-ℤ (in-pos n) l))
          { x = add-ℤ (pred-ℤ l) (inl n)}
          { y = add-ℤ (neg-ℤ (in-pos (succ-ℕ n))) l}
          ( ( left-predecessor-law-add-ℤ l (inl n)) ∙
            ( ( ap pred-ℤ (commutative-add-ℤ l (inl n))) ∙
              ( inv (left-predecessor-law-add-ℤ (inl n) l))))) ∙
        ( associative-add-ℤ (inl (succ-ℕ n)) l (mul-ℤ (inr (inr n)) l)))))

right-distributive-mul-add-ℤ :
  (k l m : ℤ) → Id (mul-ℤ (add-ℤ k l) m) (add-ℤ (mul-ℤ k m) (mul-ℤ l m))
right-distributive-mul-add-ℤ (inl zero-ℕ) l m =
  ( left-predecessor-law-mul-ℤ l m) ∙
  ( ap
    ( λ t → add-ℤ t (mul-ℤ l m))
    ( inv
      ( ( left-predecessor-law-mul-ℤ zero-ℤ m) ∙
        ( right-unit-law-add-ℤ (neg-ℤ m)))))
right-distributive-mul-add-ℤ (inl (succ-ℕ x)) l m =
  ( left-predecessor-law-mul-ℤ (add-ℤ (inl x) l) m) ∙
  ( ( ap (add-ℤ (neg-ℤ m)) (right-distributive-mul-add-ℤ (inl x) l m)) ∙
    ( inv (associative-add-ℤ (neg-ℤ m) (mul-ℤ (inl x) m) (mul-ℤ l m))))
right-distributive-mul-add-ℤ (inr (inl star)) l m = refl
right-distributive-mul-add-ℤ (inr (inr zero-ℕ)) l m =
  left-successor-law-mul-ℤ l m
right-distributive-mul-add-ℤ (inr (inr (succ-ℕ n))) l m =
  ( left-successor-law-mul-ℤ (add-ℤ (in-pos n) l) m) ∙
  ( ( ap (add-ℤ m) (right-distributive-mul-add-ℤ (inr (inr n)) l m)) ∙
    ( inv (associative-add-ℤ m (mul-ℤ (in-pos n) m) (mul-ℤ l m))))

left-negative-law-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ (neg-ℤ k) l) (neg-ℤ (mul-ℤ k l))
left-negative-law-mul-ℤ (inl zero-ℕ) l =
  ( left-unit-law-mul-ℤ l) ∙
  ( inv (neg-neg-ℤ l))
left-negative-law-mul-ℤ (inl (succ-ℕ n)) l =
  ( ap (λ t → mul-ℤ t l) (neg-pred-ℤ (inl n))) ∙
  ( ( left-successor-law-mul-ℤ (neg-ℤ (inl n)) l) ∙
    ( ( ap (add-ℤ l) (left-negative-law-mul-ℤ (inl n) l)) ∙
      ( right-negative-law-add-ℤ l (mul-ℤ (inl n) l))))
left-negative-law-mul-ℤ (inr (inl star)) l = refl
left-negative-law-mul-ℤ (inr (inr zero-ℕ)) l = refl
left-negative-law-mul-ℤ (inr (inr (succ-ℕ n))) l =
  ( left-predecessor-law-mul-ℤ (inl n) l) ∙
  ( ( ap (add-ℤ (neg-ℤ l)) (left-negative-law-mul-ℤ (inr (inr n)) l)) ∙
    ( inv (distributive-neg-add-ℤ l (mul-ℤ (in-pos n) l))))

associative-mul-ℤ :
  (k l m : ℤ) → Id (mul-ℤ (mul-ℤ k l) m) (mul-ℤ k (mul-ℤ l m))
associative-mul-ℤ (inl zero-ℕ) l m =
  left-negative-law-mul-ℤ l m
associative-mul-ℤ (inl (succ-ℕ n)) l m =
  ( right-distributive-mul-add-ℤ (neg-ℤ l) (mul-ℤ (inl n) l) m) ∙
  ( ( ap (add-ℤ (mul-ℤ (neg-ℤ l) m)) (associative-mul-ℤ (inl n) l m)) ∙
    ( ap
      ( λ t → add-ℤ t (mul-ℤ (inl n) (mul-ℤ l m)))
      ( left-negative-law-mul-ℤ l m)))
associative-mul-ℤ (inr (inl star)) l m = refl
associative-mul-ℤ (inr (inr zero-ℕ)) l m = refl
associative-mul-ℤ (inr (inr (succ-ℕ n))) l m =
  ( right-distributive-mul-add-ℤ l (mul-ℤ (in-pos n) l) m) ∙
  ( ap (add-ℤ (mul-ℤ l m)) (associative-mul-ℤ (inr (inr n)) l m))

commutative-mul-ℤ :
  (k l : ℤ) → Id (mul-ℤ k l) (mul-ℤ l k)
commutative-mul-ℤ (inl zero-ℕ) l = inv (right-neg-unit-law-mul-ℤ l)
commutative-mul-ℤ (inl (succ-ℕ n)) l =
  ( ap (add-ℤ (neg-ℤ l)) (commutative-mul-ℤ (inl n) l)) ∙
  ( inv (right-predecessor-law-mul-ℤ l (inl n)))
commutative-mul-ℤ (inr (inl star)) l = inv (right-zero-law-mul-ℤ l)
commutative-mul-ℤ (inr (inr zero-ℕ)) l = inv (right-unit-law-mul-ℤ l)
commutative-mul-ℤ (inr (inr (succ-ℕ n))) l =
  ( ap (add-ℤ l) (commutative-mul-ℤ (inr (inr n)) l)) ∙
  ( inv (right-successor-law-mul-ℤ l (in-pos n)))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Explaining how to use the inspect idiom and elaborating on the way
-- it is implemented in the standard library.
------------------------------------------------------------------------

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

module README.Inspect where

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

------------------------------------------------------------------------
-- Using inspect

-- We start with the definition of a (silly) predicate: `Plus m n p` states
-- that `m + n` is equal to `p` in a rather convoluted way. Crucially, it
-- distinguishes two cases: whether `p` is 0 or not.

Plus-eq : (m n p : ℕ) → Set
Plus-eq m n zero      = m ≡ 0 × n ≡ 0
Plus-eq m n p@(suc _) = m + n ≡ p

-- A sensible lemma to prove of this predicate is that whenever `p` is literally
-- `m + n` then `Plus m n p` holds. That is to say `∀ m n → Plus m n (m + n)`.
-- To be able to prove `Plus-eq m n (m + n)`, we need `m + n` to have either
-- the shape `zero` or `suc _` so that `Plus-eq` may reduce.

-- We could follow the way `_+_` computes by mimicking the same splitting
-- strategy, thus forcing `m + n` to reduce:

plus-eq-+ : ∀ m n → Plus-eq m n (m + n)
plus-eq-+ zero   zero    = refl , refl
plus-eq-+ zero   (suc n) = refl
plus-eq-+ (suc m) n      = refl

-- Or we could attempt to compute `m + n` first and check whether the result
-- is `zero` or `suc p`. By using `with m + n` and naming the result `p`,
-- the goal will become `Plus-eq m n p`. We can further refine this definition
-- by distinguishing two cases like so:

-- plus-eq-with : ∀ m n → Plus-eq m n (m + n)
-- plus-eq-with m n with m + n
-- ... | zero  = {!!}
-- ... | suc p = {!!}

-- The problem however is that we have abolutely lost the connection between the
-- computation `m + n` and its result `p`. Which makes the two goals unprovable:

-- 1. `m ≡ 0 × n ≡ 0`, with no assumption whatsoever
-- 2. `m + n ≡ suc p`, with no assumption either

-- By using the `with` construct, we have generated an auxiliary function that
-- looks like this:
-- `plus-eq-with-aux : ∀ m n p → Plus-eq m n p`
-- when we would have wanted a more precise type of the form:
-- `plus-eq-aux : ∀ m n p → m + n ≡ p → Plus-eq m n p`.

-- This is where we can use `inspect`. By using `with f x | inspect f x`,
-- we get both a `y` which is the result of `f x` and a proof that `f x ≡ y`.
-- Splitting on the result of `m + n`, we get two cases:

-- 1. `m ≡ 0 × n ≡ 0` under the assumption that `m + n ≡ zero`
-- 2. `m + n ≡ suc p` under the assumption that `m + n ≡ suc p`

-- The first one can be discharged using lemmas from Data.Nat.Properties and
-- the second one is trivial.

plus-eq-with : ∀ m n → Plus-eq m n (m + n)
plus-eq-with m n with m + n | inspect (m +_) n
... | zero  | [ m+n≡0   ] = m+n≡0⇒m≡0 m m+n≡0 , m+n≡0⇒n≡0 m m+n≡0
... | suc p | [ m+n≡1+p ] = m+n≡1+p

------------------------------------------------------------------------
-- Understanding the implementation of inspect

-- So why is it that we have to go through the record type `Reveal_·_is_`
-- and the ̀inspect` function? The fact is: we don't have to if we write
-- our own auxiliary lemma:

plus-eq-aux : ∀ m n → Plus-eq m n (m + n)
plus-eq-aux m n = aux m n (m + n) refl where

  aux : ∀ m n p → m + n ≡ p → Plus-eq m n p
  aux m n zero    m+n≡0   = m+n≡0⇒m≡0 m m+n≡0 , m+n≡0⇒n≡0 m m+n≡0
  aux m n (suc p) m+n≡1+p = m+n≡1+p

-- The problem is that when we write ̀with f x | pr`, `with` decides to call `y`
-- the result `f x` and to replace *all* of the occurences of `f x` in the type
-- of `pr` with `y`. That is to say that if we were to write:

-- plus-eq-naïve : ∀ m n → Plus-eq m n (m + n)
-- plus-eq-naïve m n with m + n | refl {x = m + n}
-- ... | p | eq = {!!}

-- then `with` would abstract `m + n` as `p` on *both* sides of the equality
-- proven by `refl` thus giving us the following goal with an extra, useless,
-- assumption:

-- 1. `Plus-eq m n p` under the assumption that `p ≡ p`

-- So how does `inspect` work? The standard library uses a more general version
-- of the following type and function:

record MyReveal_·_is_ (f : ℕ → ℕ) (x y : ℕ) : Set where
  constructor [_]
  field eq : f x ≡ y

my-inspect : ∀ f n → MyReveal f · n is (f n)
my-inspect f n = [ refl ]

-- Given that `inspect` has the type `∀ f n → Reveal f · n is (f n)`, when we
-- write `with f n | inspect f n`, the only `f n` that can be abstracted in the
-- type of `inspect f n` is the third argument to `Reveal_·_is_`.

-- That is to say that the auxiliary definition generated looks like this:

plus-eq-reveal : ∀ m n → Plus-eq m n (m + n)
plus-eq-reveal m n = aux m n (m + n) (my-inspect (m +_) n) where

  aux : ∀ m n p → MyReveal (m +_) · n is p → Plus-eq m n p
  aux m n zero    [ m+n≡0   ] = m+n≡0⇒m≡0 m m+n≡0 , m+n≡0⇒n≡0 m m+n≡0
  aux m n (suc p) [ m+n≡1+p ] = m+n≡1+p

-- At the cost of having to unwrap the constructor `[_]` around the equality
-- we care about, we can keep relying on `with` and avoid having to roll out
-- handwritten auxiliary definitions.


module Prelude.Nat where

open import Prelude.Bool

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

{-# BUILTIN NATURAL Nat #-}

infixl 30 _+_

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

{-# BUILTIN NATPLUS _+_ #-}

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

{-# BUILTIN NATTIMES _*_ #-}

_-_ : Nat -> Nat -> Nat
n     - Z     = n
(S n) - (S m) = n - m
Z     - _     = Z

{-# BUILTIN NATMINUS _-_ #-}

_<_ : Nat -> Nat -> Bool
_   < Z   = false
Z   < S _ = true
S n < S m = n < m

-- {-# BUILTIN NATLESS _<_ #-}

Nid : Nat -> Bool -> Bool
Nid Z     true  = true
Nid Z     false = false
Nid (S n) m     =  (Nid n ( m))

-- {-# BUILTIN NATEQUALS __ #-}


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

syntax GroupAction | GA

type
  * : 0-ary
  X : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20
  neg  : *  ->  * | ⊖_ r40
  act  : *  X  ->  X | _⊙_ r30

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊖N⊕ᴸ) a |> add (neg (a), a) = unit
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = unit
  (εU⊙)      x : X |> act (unit,      x) = x
  (⊕A⊙) g h  x : X |> act (add(g, h), x) = act (g, act(h, x))
-}

module GroupAction.Equality where

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

open import GroupAction.Signature
open import GroupAction.Syntax

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

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

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ GA) α Γ → (𝔐 ▷ GA) α Γ → Set where
  εU⊕ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ε ⊕ 𝔞 ≋ₐ 𝔞
  εU⊕ᴿ : ⁅ * ⁆̣             ▹ ∅ ⊢       𝔞 ⊕ ε ≋ₐ 𝔞
  ⊕A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ⊕ 𝔟) ⊕ 𝔠 ≋ₐ 𝔞 ⊕ (𝔟 ⊕ 𝔠)
  ⊖N⊕ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢   (⊖ 𝔞) ⊕ 𝔞 ≋ₐ ε
  ⊖N⊕ᴿ : ⁅ * ⁆̣             ▹ ∅ ⊢   𝔞 ⊕ (⊖ 𝔞) ≋ₐ ε
  εU⊙  : ⁅ X ⁆̣             ▹ ∅ ⊢       ε ⊙ 𝔞 ≋ₐ 𝔞
  ⊕A⊙  : ⁅ * ⁆ ⁅ * ⁆ ⁅ X ⁆̣ ▹ ∅ ⊢ (𝔞 ⊕ 𝔟) ⊙ 𝔠 ≋ₐ 𝔞 ⊙ (𝔟 ⊙ 𝔠)

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


module Lookup where

data Bool : Set where
  false : Bool
  true  : Bool

data IsTrue : Bool -> Set where
  isTrue : IsTrue true

data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

data _×_ (A B : Set) : Set where
  _,_ : A -> B -> A × B

module Map
  (Key  : Set)
  (_==_ : Key -> Key -> Bool)
  (Code : Set)
  (Val  : Code -> Set) where

  infixr 40 _⟼_,_
  infix  20 _∈_

  data Map : List Code -> Set where
    ε     : Map []
    _⟼_,_ : forall {c cs} ->
            Key -> Val c -> Map cs -> Map (c :: cs)

  _∈_ : forall {cs} -> Key -> Map cs -> Bool
  k ∈ ε            = false
  k ∈ (k' ⟼ _ , m) with k == k'
  ...              | true  = true
  ...              | false = k ∈ m

  Lookup : forall {cs} -> (k : Key)(m : Map cs) -> IsTrue (k ∈ m) -> Set
  Lookup k ε ()
  Lookup k (_⟼_,_ {c} k' _ m) p with k == k'
  ... | true  = Val c
  ... | false = Lookup k m p

  lookup : {cs : List Code}(k : Key)(m : Map cs)(p : IsTrue (k ∈ m)) ->
           Lookup k m p
  lookup k ε ()
  lookup k (k' ⟼ v , m) p with k == k'
  ... | true  = v
  ... | false = lookup k m p


module Dave.Structures.Monoid where
    open import Dave.Structures.Semigroup public

    record Identity {A : Set} (_·_ : op₂ A) (e : A) : Set where
        field
            left : left-identity _·_ e
            right : right-identity _·_ e

    record IsMonoid {A : Set} (_·_ : op₂ A) (e : A) : Set where
        field
            semigroup : IsSemigroup _·_
            identity : Identity _·_ e

    record Monoid : Set₁ where
        field
            Carrier : Set
            _·_ : op₂ Carrier
            e : Carrier
            isMonoid : IsMonoid _·_ e

    record IsCommutativeMonoid {A : Set} (_·_ : op₂ A) (e : A) : Set where
        field
            isSemigroup : IsSemigroup _·_
            leftIdentity : left-identity _·_ e
            comm : commutative _·_

        rightIdentity : right-identity _·_ e
        rightIdentity m = begin
            m · e ≡⟨ comm m e ⟩
            e · m ≡⟨ leftIdentity m ⟩
            m ∎

        identity : Identity _·_ e
        Identity.left identity = leftIdentity
        Identity.right identity = rightIdentity

        isMonoid : IsMonoid _·_ e
        IsMonoid.semigroup isMonoid = isSemigroup
        IsMonoid.identity isMonoid = identity

        swap021 : ∀ (m n p : A) → (m · n) · p ≡ (m · p) · n
        swap021 m n p = begin
            (m · n) · p ≡⟨ IsSemigroup.assoc isSemigroup m n p ⟩
            m · (n · p) ≡⟨ cong (λ a → m · a) (comm n p) ⟩
            m · (p · n) ≡⟨ sym (IsSemigroup.assoc isSemigroup m p n) ⟩
            (m · p) · n ∎

        swap102 : ∀ (m n p : A) → (m · n) · p ≡ (n · m) · p
        swap102 m n p = begin
            (m · n) · p ≡⟨ cong (λ a → a · p) (comm m n) ⟩
            (n · m) · p ∎

        swap120 : ∀ (m n p : A) → (m · n) · p ≡ (n · m) · p
        swap120 m n p = begin
            (m · n) · p ≡⟨ cong (λ a → a · p) (comm m n) ⟩
            (n · m) · p ∎

        swap210 : ∀ (m n p : A) → (m · n) · p ≡ (p · n) · m
        swap210 m n p = begin
            (m · n) · p ≡⟨ comm (m · n) p ⟩
            p · (m · n) ≡⟨ cong (λ a → p · a) (comm m n) ⟩
            p · (n · m) ≡⟨ sym (IsSemigroup.assoc isSemigroup p n m) ⟩
            (p · n) · m ∎

        swap201 : ∀ (m n p : A) → (m · n) · p ≡ (p · m) · n
        swap201 m n p = begin
            (m · n) · p ≡⟨ comm (m · n) p ⟩
            p · (m · n) ≡⟨ sym (IsSemigroup.assoc isSemigroup p m n) ⟩
            (p · m) · n ∎

    record CommutativeMonoid : Set₁ where
        field
            Carrier : Set
            _·_ : op₂ Carrier
            e : Carrier
            isCommutativeMonoid : IsCommutativeMonoid _·_ e


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of functions, such as associativity and commutativity
------------------------------------------------------------------------

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

open import Level
open import Relation.Binary
open import Data.Sum

-- The properties are parameterised by the following "equality" relation

module Algebra.FunctionProperties
  {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) where

open import Data.Product

------------------------------------------------------------------------
-- Unary and binary operations

open import Algebra.FunctionProperties.Core public

------------------------------------------------------------------------
-- Properties of operations

Associative : Op₂ A → Set _
Associative _∙_ = ∀ x y z → ((x ∙ y) ∙ z) ≈ (x ∙ (y ∙ z))

Commutative : Op₂ A → Set _
Commutative _∙_ = ∀ x y → (x ∙ y) ≈ (y ∙ x)

LeftIdentity : A → Op₂ A → Set _
LeftIdentity e _∙_ = ∀ x → (e ∙ x) ≈ x

RightIdentity : A → Op₂ A → Set _
RightIdentity e _∙_ = ∀ x → (x ∙ e) ≈ x

Identity : A → Op₂ A → Set _
Identity e ∙ = (LeftIdentity e ∙) × (RightIdentity e ∙)

LeftZero : A → Op₂ A → Set _
LeftZero z _∙_ = ∀ x → (z ∙ x) ≈ z

RightZero : A → Op₂ A → Set _
RightZero z _∙_ = ∀ x → (x ∙ z) ≈ z

Zero : A → Op₂ A → Set _
Zero z ∙ = (LeftZero z ∙) × (RightZero z ∙)

LeftInverse : A → Op₁ A → Op₂ A → Set _
LeftInverse e _⁻¹ _∙_ = ∀ x → ((x ⁻¹) ∙ x) ≈ e

RightInverse : A → Op₁ A → Op₂ A → Set _
RightInverse e _⁻¹ _∙_ = ∀ x → (x ∙ (x ⁻¹)) ≈ e

Inverse : A → Op₁ A → Op₂ A → Set _
Inverse e ⁻¹ ∙ = (LeftInverse e ⁻¹) ∙ × (RightInverse e ⁻¹ ∙)

LeftConical : A → Op₂ A → Set _
LeftConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → x ≈ e

RightConical : A → Op₂ A → Set _
RightConical e _∙_ = ∀ x y → (x ∙ y) ≈ e → y ≈ e

Conical : A → Op₂ A → Set _
Conical e ∙ = (LeftConical e ∙) × (RightConical e ∙)

_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverˡ _+_ =
  ∀ x y z → (x * (y + z)) ≈ ((x * y) + (x * z))

_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverʳ _+_ =
  ∀ x y z → ((y + z) * x) ≈ ((y * x) + (z * x))

_DistributesOver_ : Op₂ A → Op₂ A → Set _
* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +)

_IdempotentOn_ : Op₂ A → A → Set _
_∙_ IdempotentOn x = (x ∙ x) ≈ x

Idempotent : Op₂ A → Set _
Idempotent ∙ = ∀ x → ∙ IdempotentOn x

IdempotentFun : Op₁ A → Set _
IdempotentFun f = ∀ x → f (f x) ≈ f x

Selective : Op₂ A → Set _
Selective _∙_ = ∀ x y → (x ∙ y) ≈ x ⊎ (x ∙ y) ≈ y

_Absorbs_ : Op₂ A → Op₂ A → Set _
_∙_ Absorbs _∘_ = ∀ x y → (x ∙ (x ∘ y)) ≈ x

Absorptive : Op₂ A → Op₂ A → Set _
Absorptive ∙ ∘ = (∙ Absorbs ∘) × (∘ Absorbs ∙)

Involutive : Op₁ A → Set _
Involutive f = ∀ x → f (f x) ≈ x

LeftCancellative : Op₂ A → Set _
LeftCancellative _•_ = ∀ x {y z} → (x • y) ≈ (x • z) → y ≈ z

RightCancellative : Op₂ A → Set _
RightCancellative _•_ = ∀ {x} y z → (y • x) ≈ (z • x) → y ≈ z

Cancellative : Op₂ A → Set _
Cancellative _•_ = (LeftCancellative _•_) × (RightCancellative _•_)

Congruent₁ : Op₁ A → Set _
Congruent₁ f = f Preserves _≈_ ⟶ _≈_

Congruent₂ : Op₂ A → Set _
Congruent₂ ∙ = ∙ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_

LeftCongruent : Op₂ A → Set _
LeftCongruent _∙_ = ∀ {x} → (x ∙_) Preserves _≈_ ⟶ _≈_

RightCongruent : Op₂ A → Set _
RightCongruent _∙_ = ∀ {x} → (_∙ x) Preserves _≈_ ⟶ _≈_


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

-- A Presheaf (into Setoids) is representation if it is naturally isomorphic to a Hom functor
--  over a particular object A of the base category.
open import Level

open import Categories.Category using (Category)
open import Categories.Category.Instance.Setoids
open import Categories.Functor using (Functor)
open import Categories.Functor.Hom
open import Categories.Functor.Presheaf
open import Categories.NaturalTransformation.NaturalIsomorphism

record Representable {o ℓ e} {C : Category o ℓ e} (F : Presheaf C (Setoids ℓ e)) : Set (o ⊔ suc ℓ ⊔ suc e ) where
  open Category C
  open Hom C
  field
    A : Obj
    Iso : NaturalIsomorphism F Hom[-, A ]


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module Quicksort.Correctness.Permutation {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_) where

open import Bound.Total A
open import Bound.Total.Order _≤_
open import Data.List
open import Data.Product
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import List.Permutation.Pair A
open import List.Permutation.Pair.Properties A
open import Quicksort _≤_ tot≤
open import SBList _≤_
open import SBList.Properties _≤_
open import Size
open import SOList.Total _≤_

lemma-deal : {ι : Size}{b t : Bound}{x : A} → (b≤x : LeB b (val x)) → (x≤t : LeB (val x) t) → (xs : SBList {ι} b t) → unbound xs ≈ unbound× (deal b≤x x≤t xs)
lemma-deal _ _ (nil _) = ≈[]r []
lemma-deal {x = x} b≤x x≤t (cons y b≤y y≤t ys)
    with tot≤ x y
... | inj₁ x≤y = ≈xr (lemma-deal b≤x x≤t ys)
... | inj₂ y≤x = ≈xl (lemma-deal b≤x x≤t ys)

lemma-quickSort : {ι : Size}{b t : Bound}(xs : SBList {ι} b t) → unbound xs ∼ forget (quickSort xs)
lemma-quickSort (nil _) = ∼[]
lemma-quickSort (cons x b≤x x≤t xs) =  trans∼ (lemma≈∼ (≈xr (lemma-deal b≤x x≤t xs))) (lemma++∼ (lemma-quickSort ys) (∼x /head /head (lemma-quickSort zs)))
                where yszs = deal b≤x x≤t xs
                      ys = proj₁ yszs
                      zs = proj₂ yszs

theorem-quickSort∼ : (xs : List A) → xs ∼ forget (quickSort (bound xs))
theorem-quickSort∼ xs = trans∼ (lemma-unbound-bound xs) (lemma-quickSort (bound xs))


-- imports
open import Data.Nat as ℕ     using (ℕ; suc; zero; _+_; _∸_)
open import Data.Vec as Vec   using (Vec; _∷_; []; tabulate; foldr)
open import Data.Fin as Fin   using (Fin; suc; zero)
open import Function          using (_∘_; const; id)
open import Data.List as List using (List; _∷_; [])
open import Data.Maybe        using (Maybe; just; nothing)

-- Without square cutoff optimization
module Simple where
  primes : ∀ n → List (Fin n)
  primes zero = []
  primes (suc zero) = []
  primes (suc (suc zero)) = []
  primes (suc (suc (suc m))) = sieve (tabulate (just ∘ suc))
    where
    sieve : ∀ {n} → Vec (Maybe (Fin (2 + m))) n → List (Fin (3 + m))
    sieve [] = []
    sieve (nothing ∷ xs) =         sieve xs
    sieve (just x  ∷ xs) = suc x ∷ sieve (foldr B remove (const []) xs x)
      where
      B = λ n → ∀ {i} → Fin i → Vec (Maybe (Fin (2 + m))) n

      remove : ∀ {n} → Maybe (Fin (2 + m)) → B n → B (suc n)
      remove _ ys zero    = nothing ∷ ys x
      remove y ys (suc z) = y       ∷ ys z

-- With square cutoff optimization
module SquareOpt where
  primes : ∀ n → List (Fin n)
  primes zero = []
  primes (suc zero) = []
  primes (suc (suc zero)) = []
  primes (suc (suc (suc m))) = sieve 1 m (Vec.tabulate (just ∘ Fin.suc ∘ Fin.suc))
    where
    sieve : ∀ {n} → ℕ → ℕ → Vec (Maybe (Fin (3 + m))) n → List (Fin (3 + m))
    sieve _ zero = List.mapMaybe id ∘ Vec.toList
    sieve _ (suc _) [] = []
    sieve i (suc l) (nothing ∷ xs) =     sieve (suc i) (l ∸ i ∸ i) xs
    sieve i (suc l) (just x  ∷ xs) = x ∷ sieve (suc i) (l ∸ i ∸ i) (Vec.foldr B remove (const []) xs i)
      where
      B = λ n → ℕ → Vec (Maybe (Fin (3 + m))) n

      remove : ∀ {i} → Maybe (Fin (3 + m)) → B i → B (suc i)
      remove _ ys zero    = nothing ∷ ys i
      remove y ys (suc j) = y       ∷ ys j


module Issue552 where

data Id3 {A : Set} : A -> A -> A -> Set where
  refl3 : {x : A} -> Id3 x x x

-- These work:

ok1 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
ok1 ._ ._ ._ (refl3 {_}) = refl3

ok2 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
ok2 _ ._ ._ (refl3) = refl3

ok3 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
ok3 _ ._ ._ (refl3 {._}) = refl3

-- These work after the fix:

bad4 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
bad4 ._ ._ _ (refl3 {._}) = refl3

bad3 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
bad3 ._ _ ._ (refl3 {._}) = refl3

-- This still doesn't work:

-- bad1 : {A : Set}(a b c : A) -> Id3 a b c -> Id3 a b c
-- bad1 ._ ._ ._ (refl3) = refl3


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

-- We can use a propositional equality parametrized on Set instead of
-- using two "different" equalities on D and M.

module LogicalFramework.SetEquality where

-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Relation/Binary/Core.agda).
infix 7 _≡D_ _≡M_

------------------------------------------------------------------------------
-- Domain universe D
postulate
  D : Set

-- Propositional equality on D.
data _≡D_ (x : D) : D → Set where
  refl : x ≡D x

≡D-thm : ∀ {d e} → d ≡D e → e ≡D d
≡D-thm refl = refl

------------------------------------------------------------------------------
-- Domain universe M

data M : Set where
  zero :     M
  succ : M → M

-- Propositional equality on M.
data _≡M_ (n : M) : M → Set where
  refl : n ≡M n

≡M-thm : ∀ {m n} → m ≡M n → n ≡M m
≡M-thm refl = refl

------------------------------------------------------------------------------
-- Propositional equality on Set.

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

≡-thm₁ : ∀ {d e : D} → d ≡ e → e ≡ d
≡-thm₁ refl = refl

≡-thm₂ : ∀ {m n : M} → m ≡ n → n ≡ m
≡-thm₂ refl = refl


module Numeral.Natural.TotalOper where

import Lvl
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural hiding (𝐏)
open import Numeral.Natural.Relation.Divisibility
open import Numeral.Natural.Relation.Divisibility.Proofs
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs

-- Total predecessor function (Truncated predecessor)
𝐏 : (n : ℕ) → ⦃ _ : Positive(n) ⦄ → ℕ
𝐏(𝐒(n)) = n

-- Total subtraction (Truncated subtraction)
_−_ : (a : ℕ) → (b : ℕ) → ⦃ _ : a ≥ b ⦄ → ℕ
_−_ a 𝟎 = a
_−_ 𝟎 (𝐒(b)) ⦃ 0≥𝐒b ⦄ with ([<]-to-[≱] ([<]-minimum{b})) (0≥𝐒b)
... | ()
_−_ (𝐒(a)) (𝐒(b)) ⦃ 𝐒b≤𝐒a ⦄ = _−_ a b ⦃ [≤]-without-[𝐒] {b} (𝐒b≤𝐒a) ⦄

-- Total division (Whole number division)
_/₀_ : (a : ℕ) → (b : ℕ) → ⦃ _ : (b ∣ a) ⦄ → ℕ
_/₀_ _ _ ⦃ div ⦄ = divides-quotient div


module Numeral.Sign.Oper where

open import Data.Boolean
open import Numeral.Sign

-- Negation
−_ : (+|−) → (+|−)
− (➕) = (➖)
− (➖) = (➕)

-- Addition
_+_ : (+|−) → (+|−) → (+|0|−)
(➕) + (➕) = (➕)
(➖) + (➖) = (➖)
(➕) + (➖) = (𝟎)
(➖) + (➕) = (𝟎)

-- Multiplication
_⨯_ : (+|−) → (+|−) → (+|−)
(➕) ⨯ (➕) = (➕)
(➖) ⨯ (➖) = (➕)
(➕) ⨯ (➖) = (➖)
(➖) ⨯ (➕) = (➖)

_⋚_ : (+|−) → (+|−) → (+|0|−)
➕ ⋚ ➕ = 𝟎
➕ ⋚ ➖ = ➕
➖ ⋚ ➕ = ➖
➖ ⋚ ➖ = 𝟎


module Dave.Isomorphism where
    open import Dave.Equality
    open import Dave.Functions

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

    {- Another way to define Isomporphism throug data -}
    data _≃′_ (A B : Set) : Set where
        mk-≃′ : ∀ (to : A → B) →
                ∀ (from : B → A) →
                ∀ (from∘to : (∀ (x : A) → from (to x) ≡ x)) →
                ∀ (to∘from : (∀ (y : B) → to (from y) ≡ y)) →
                A ≃′ B

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

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

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

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

    ≃-refl : ∀ {A : Set} → A ≃ A
    ≃-refl = record
        {
            to = λ x → x;
            from = λ y → y;
            from∘to = λ x → refl;
            to∘from = λ y → refl
        }

    ≃-sym : ∀ {A B : Set} → A ≃ B → B ≃ A
    ≃-sym A≃B = record
        {
            to = from A≃B ;
            from = to A≃B ;
            from∘to = to∘from A≃B ;
            to∘from = from∘to A≃B
        }

    ≃-trans : ∀ {A B C : Set} → A ≃ B → B ≃ C → A ≃ C
    ≃-trans A≃B B≃C = record
        {
            to = (to B≃C) ∘ (to A≃B);
            from = (from A≃B) ∘ (from B≃C);
            from∘to = λ x → begin
                (from A≃B ∘ from B≃C) ((to B≃C ∘ to A≃B) x) ≡⟨⟩
                from A≃B (from B≃C (to B≃C (to A≃B x))) ≡⟨ cong (from A≃B) (from∘to B≃C (to A≃B x)) ⟩
                from A≃B (to A≃B x) ≡⟨ from∘to A≃B x ⟩
                x ∎;
            to∘from = λ x → begin
                (to B≃C ∘ to A≃B) ((from A≃B ∘ from B≃C) x) ≡⟨⟩
                to B≃C (to A≃B (from A≃B (from B≃C x))) ≡⟨ cong (to B≃C) (to∘from A≃B (from B≃C x)) ⟩
                to B≃C (from B≃C x) ≡⟨ to∘from B≃C x ⟩
                x ∎
        }

    module ≃-Reasoning where

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

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

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

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

    open ≃-Reasoning public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the `Reflects` construct
------------------------------------------------------------------------

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

module Relation.Nullary.Reflects where

open import Agda.Builtin.Equality
open import Data.Bool.Base
open import Data.Empty
open import Level
open import Relation.Nullary

private
  variable
    p : Level
    P : Set p

------------------------------------------------------------------------
-- `Reflects P b` is equivalent to `if b then P else ¬ P`.

-- These lemmas are intended to be used mostly when `b` is a value, so
-- that the `if` expressions have already been evaluated away.
-- In this case, `of` works like the relevant constructor (`ofⁿ` or
-- `ofʸ`), and `invert` strips off the constructor to just give either
-- the proof of `P` or the proof of `¬ P`.

of : ∀ {b} → if b then P else ¬ P → Reflects P b
of {b = false} ¬p = ofⁿ ¬p
of {b = true }  p = ofʸ p

invert : ∀ {b} → Reflects P b → if b then P else ¬ P
invert (ofʸ  p) = p
invert (ofⁿ ¬p) = ¬p

------------------------------------------------------------------------
-- Other lemmas

-- `Reflects` is deterministic.
det : ∀ {b b′} → Reflects P b → Reflects P b′ → b ≡ b′
det (ofʸ  p) (ofʸ  p′) = refl
det (ofʸ  p) (ofⁿ ¬p′) = ⊥-elim (¬p′ p)
det (ofⁿ ¬p) (ofʸ  p′) = ⊥-elim (¬p p′)
det (ofⁿ ¬p) (ofⁿ ¬p′) = refl


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

module Test where

open import Level

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

J : {a b : Level} (A : Set a) (C : (x y : A) → x ≡ y → Set b)
    → ((x : A) → C x x refl)
    → (x y : A) (P : x ≡ y)
    → C x y P
J A C b x .x refl = b x

-- K : (A : Set) (x : A) (C : x ≡ x → Set)
--   → C refl
--   → (loop : x ≡ x)
--   → C loop
-- K A x C b p = {! p  !}

-- Lemma 2.1.1 (inversion of paths)
infix 6 ¬_
¬_ : {a : Level} {A : Set a} {x y : A} → x ≡ y → y ≡ x
¬_ {a} {A} {x} {y} p = J A D d x y p

  where
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = y ≡ x

    d : (x : A) → D x x refl
    d x = refl

-- Lemma 2.1.2 (concatenation of paths)
infixl 5 _∙_
_∙_ : {a : Level} {A : Set a} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
_∙_ {a} {A} {x} {y} {z} p q = J {a} {a} A D d x y p z q

  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = (z : A) (q : y ≡ z) → x ≡ z

    -- base case
    d : (x : A) → D x x refl
    d x z q = J A E e x z q
      where
        -- the predicate
        E : (x z : A) (q : x ≡ z) → Set a
        E x z q = x ≡ z

        -- base case
        e : (x : A) → E x x refl
        e x = refl

-- Lemma 2.1.4.i (identity of path concatenation)
∙-identityʳ : {a : Level} {A : Set a} {x y : A} (p : x ≡ y) → p ≡ p ∙ refl
∙-identityʳ {a} {A} {x} {y} p = J A D d x y p

  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = p ≡ p ∙ refl

    -- base case
    d : (x : A) → D x x refl
    d x = refl

∙-identityˡ : {a : Level} {A : Set a} {x y : A} (p : x ≡ y) → p ≡ refl ∙ p
∙-identityˡ {a} {A} {x} {y} p = J A D d x y p
  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = p ≡ refl ∙ p

    -- base case
    d : (x : A) → D x x refl
    d x = refl

-- Lemma 2.1.4.ii (identity of path inversion)
¬-identityʳ : {a : Level} {A : Set a} {x y : A} (p : x ≡ y) → ¬ p ∙ p ≡ refl
¬-identityʳ {a} {A} {x} {y} p = J A D d x y p
  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = ¬ p ∙ p ≡ refl

    -- base case
    d : (x : A) → D x x refl
    d x = refl

¬-identityˡ : {a : Level} {A : Set a} {x y : A} (p : x ≡ y) → p ∙ ¬ p ≡ refl
¬-identityˡ {a} {A} {x} {y} p = J A D d x y p
  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set a
    D x y p = p ∙ ¬ p ≡ refl

    -- base case
    d : (x : A) → D x x refl
    d x = refl

-- Lemma 2.1.4.iii (involution of path inversion)
involution : {A : Set} {x y : A} (p : x ≡ y) → ¬ ¬ p ≡ p
involution {A} {x} {y} p = J A D d x y p
  where
    -- the predicate
    D : (x y : A) (p : x ≡ y) → Set
    D x y p = ¬ ¬ p ≡ p

    -- base case
    d : (x : A) → D x x refl
    d x = refl

-- Lemma 2.1.4.iv (associativity of path concatenation)
∙-assoc : {a : Level} {A : Set a} {w x y z : A}
  → (p : w ≡ x) (q : x ≡ y) (r : y ≡ z)
  → p ∙ (q ∙ r) ≡ (p ∙ q) ∙ r
∙-assoc {a} {A} {w} {x} {y} {z} p q r = J A D d w x p y q z r
  where
    -- the predicate
    D : (w x : A) (p : w ≡ x) → Set a
    D w x p = (y : A) (q : x ≡ y)
            → (z : A) (r : y ≡ z)
            → p ∙ (q ∙ r) ≡ (p ∙ q) ∙ r

    -- base case
    d : (x : A) → D x x refl
    d x y q z r = J A E e x y q z r
      where
        -- the predicate
        E : (x y : A) (q : x ≡ y) → Set a
        E x y q = (z : A) (r : y ≡ z)
                → refl ∙ (q ∙ r) ≡ refl ∙ q ∙ r

        -- base case
        e : (x : A) → E x x refl
        e x z r = J A F f x z r
          where
            -- the predicate
            F : (y z : A) (r : y ≡ z) → Set a
            F y z r = refl ∙ (refl ∙ r) ≡ refl ∙ refl ∙ r

            -- base case
            f : (x : A) → F x x refl
            f x = {!   !}


------------------------------------------------------------------------
-- The Agda standard library
--
-- A definition for the permutation relation using setoid equality
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Permutation.Homogeneous where

open import Data.List.Base using (List; _∷_)
open import Data.List.Relation.Binary.Pointwise as Pointwise
  using (Pointwise)
open import Level using (Level; _⊔_)
open import Relation.Binary

private
  variable
    a r s : Level
    A : Set a

data Permutation {A : Set a} (R : Rel A r) : Rel (List A) (a ⊔ r) where
  refl  : ∀ {xs ys} → Pointwise R xs ys → Permutation R xs ys
  prep  : ∀ {xs ys x y} (eq : R x y) → Permutation R xs ys → Permutation R (x ∷ xs) (y ∷ ys)
  swap  : ∀ {xs ys x y x' y'} (eq₁ : R x x') (eq₂ : R y y') → Permutation R xs ys → Permutation R (x ∷ y ∷ xs) (y' ∷ x' ∷ ys)
  trans : ∀ {xs ys zs} → Permutation R xs ys → Permutation R ys zs → Permutation R xs zs

------------------------------------------------------------------------
-- The Permutation relation is an equivalence

module _ {R : Rel A r}  where

  sym : Symmetric R → Symmetric (Permutation R)
  sym R-sym (refl xs∼ys)           = refl (Pointwise.symmetric R-sym xs∼ys)
  sym R-sym (prep x∼x' xs↭ys)      = prep (R-sym x∼x') (sym R-sym xs↭ys)
  sym R-sym (swap x∼x' y∼y' xs↭ys) = swap (R-sym y∼y') (R-sym x∼x') (sym R-sym xs↭ys)
  sym R-sym (trans xs↭ys ys↭zs)    = trans (sym R-sym ys↭zs) (sym R-sym xs↭ys)

  isEquivalence : Reflexive R → Symmetric R → IsEquivalence (Permutation R)
  isEquivalence R-refl R-sym = record
    { refl  = refl (Pointwise.refl R-refl)
    ; sym   = sym R-sym
    ; trans = trans
    }

  setoid : Reflexive R → Symmetric R → Setoid _ _
  setoid R-refl R-sym = record
    { isEquivalence = isEquivalence R-refl R-sym
    }

map : ∀ {R : Rel A r} {S : Rel A s} →
      (R ⇒ S) → (Permutation R ⇒ Permutation S)
map R⇒S (refl xs∼ys)         = refl (Pointwise.map R⇒S xs∼ys)
map R⇒S (prep e xs∼ys)       = prep (R⇒S e) (map R⇒S xs∼ys)
map R⇒S (swap e₁ e₂ xs∼ys)   = swap (R⇒S e₁) (R⇒S e₂) (map R⇒S xs∼ys)
map R⇒S (trans xs∼ys ys∼zs)  = trans (map R⇒S xs∼ys) (map R⇒S ys∼zs)


module FMSB where

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Lam (X : Nat -> Set)(n : Nat) : Set where
  var : X n -> Lam X n
  app : Lam X n -> Lam X n -> Lam X n
  lam : Lam X (su n) -> Lam X n

_->>_ : {I : Set}(X Y : I -> Set) -> Set
X ->> Y = {i : _} -> X i -> Y i

fmsub : {X Y : Nat -> Set} -> (X ->> Lam Y) -> Lam X ->> Lam Y
fmsub sb (var x)   = sb x
fmsub sb (app f s) = app (fmsub sb f) (fmsub sb s)
fmsub sb (lam b)   = lam (fmsub sb b)

data Fin : Nat -> Set where
  ze : {n : Nat} -> Fin (su n)
  su : {n : Nat} -> Fin n -> Fin (su n)

D : (Nat -> Set) -> Nat -> Set
D F n = F (su n)

weak : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
       {m n : Nat}-> (Fin m -> F n) -> D Fin m -> D F n
weak v w f ze      = v ze
weak v w f (su x)  = w (f x)

_+_ : Nat -> Nat -> Nat
ze    + y = y
su x  + y = su (x + y)

_!+_ : (Nat -> Set) -> Nat -> (Nat -> Set)
F !+ n = \ m -> F (m + n)

weaks : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
        {m n : Nat}-> (Fin m -> F n) -> (Fin !+ m) ->> (F !+ n)
weaks v w f {ze}    = f
weaks v w f {su i}  = weak v w (weaks v w f {i})

jing : {m n : Nat} -> Lam Fin (m + n) -> Lam (Fin !+ n) m
jing (var x) = var x
jing (app f s) = app (jing f) (jing s)
jing (lam t) = lam (jing t)

gnij : {m n : Nat} -> Lam (Fin !+ n) m -> Lam Fin (m + n)
gnij (var x) = var x
gnij (app f s) = app (gnij f) (gnij s)
gnij (lam t) = lam (gnij t)

ren : {m n : Nat} -> (Fin m -> Fin n) -> Lam Fin m -> Lam Fin n
ren f t = gnij (fmsub (\ {i} x -> var (weaks (\ z -> z) su f {i} x)) {ze} (jing t))

sub : {m n : Nat} -> (Fin m -> Lam Fin n) -> Lam Fin m -> Lam Fin n
sub {m}{n} f t = gnij {ze} (fmsub (\ {i} x -> jing {i} (weaks {Lam Fin} var (ren su) f {i} x)) (jing {ze} t))


{-

ℤ is a Commutative Ring (using QuoInt)

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

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.CommRing
open import Cubical.Data.Nat  using (ℕ ; zero ; suc)
open import Cubical.Data.Bool using (not)
open import Cubical.Data.Int.MoreInts.QuoInt
  renaming (ℤ to ℤType ; _+_ to _+ℤ_; _·_ to _·ℤ_; -_ to -ℤ_)

open CommRingStr

-- The missing additive inversion

+InvL' : ∀ n s → signed (not s) n +ℤ signed s n ≡ signed s zero
+InvL' zero _ = refl
+InvL' (suc n) spos = predℤ-+ʳ (neg n) (pos (suc n)) ∙ (λ i → neg n +ℤ predSucℤ (pos n) i) ∙ +InvL' n spos
+InvL' (suc n) sneg = sucℤ-+ʳ  (pos n) (neg (suc n)) ∙ (λ i → pos n +ℤ sucPredℤ (neg n) i) ∙ +InvL' n sneg

+InvL : (n : ℤType) → (-ℤ n) +ℤ n ≡ 0
+InvL (signed spos n) = +InvL' n spos
+InvL (signed sneg n) = +InvL' n sneg ∙ sym posneg
+InvL (posneg i) j =
  hcomp (λ k → λ
    { (i = i0) → 0
    ; (i = i1) → compPath-filler refl (sym posneg) k j
    ; (j = i0) → posneg i
    ; (j = i1) → posneg (i ∧ ~ k) })
  (posneg i)

+InvR : (n : ℤType) → n +ℤ (-ℤ n) ≡ 0
+InvR n = +-comm n (-ℤ n) ∙ +InvL n

ℤCommRing : CommRing ℓ-zero
ℤCommRing .fst = ℤType
ℤCommRing .snd .0r = 0
ℤCommRing .snd .1r = 1
ℤCommRing .snd ._+_ = _+ℤ_
ℤCommRing .snd ._·_ = _·ℤ_
ℤCommRing .snd .-_ = -ℤ_
ℤCommRing .snd .isCommRing = isCommRingℤ
  where
  abstract
    isCommRingℤ : IsCommRing 0 1 _+ℤ_ _·ℤ_ -ℤ_
    isCommRingℤ = makeIsCommRing
      isSetℤ +-assoc (+-zeroʳ _)
      +InvR +-comm ·-assoc
      ·-identityʳ (λ x y z → sym (·-distribˡ x y z)) ·-comm


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

open import Categories.Category

-- Biproducts, a-la Karvonen.
--
-- This definition has advantages over more traditional ones,
-- namely that that we don't require either enrichment in CMon/Ab, or Zero Objects.
--
-- See https://arxiv.org/abs/1801.06488
module Categories.Object.Biproduct {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Object.Coproduct 𝒞
open import Categories.Object.Product 𝒞

open import Categories.Morphism 𝒞

open Category 𝒞
open HomReasoning

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

record IsBiproduct {A B A⊕B : Obj} (π₁ : A⊕B ⇒ A) (π₂ : A⊕B ⇒ B) (i₁ : A ⇒ A⊕B) (i₂ : B ⇒ A⊕B) : Set (o ⊔ ℓ ⊔ e) where
  field
    isCoproduct : IsCoproduct i₁ i₂
    isProduct : IsProduct π₁ π₂

    π₁∘i₁≈id : π₁ ∘ i₁ ≈ id
    π₂∘i₂≈id : π₂ ∘ i₂ ≈ id
    permute  : i₁ ∘ π₁ ∘ i₂ ∘ π₂ ≈ i₂ ∘ π₂ ∘ i₁ ∘ π₁

  open IsCoproduct isCoproduct public renaming (unique to []-unique)
  open IsProduct isProduct public renaming (unique to ⟨⟩-unique)

record Biproduct (A B : Obj) : Set (o ⊔ ℓ ⊔ e) where
  field
    A⊕B : Obj

    π₁    : A⊕B ⇒ A
    π₂    : A⊕B ⇒ B

    i₁    : A ⇒ A⊕B
    i₂    : B ⇒ A⊕B

    isBiproduct : IsBiproduct π₁ π₂ i₁ i₂

  open IsBiproduct isBiproduct public

IsBiproduct⇒Biproduct : {π₁ : C ⇒ A} {π₂ : C ⇒ B} {i₁ : A ⇒ C} {i₂ : B ⇒ C}  → IsBiproduct π₁ π₂ i₁ i₂ → Biproduct A B
IsBiproduct⇒Biproduct isBiproduct = record
  { isBiproduct = isBiproduct
  }

Biproduct⇒IsBiproduct : (b : Biproduct A B) → IsBiproduct (Biproduct.π₁ b) (Biproduct.π₂ b) (Biproduct.i₁ b) (Biproduct.i₂ b)
Biproduct⇒IsBiproduct biproduct = Biproduct.isBiproduct biproduct

Biproduct⇒Product : Biproduct A B → Product A B
Biproduct⇒Product b = record
  { ⟨_,_⟩ = ⟨_,_⟩
  ; project₁ = project₁
  ; project₂ = project₂
  ; unique = ⟨⟩-unique
  }
  where
    open Biproduct b

Biproduct⇒Coproduct : Biproduct A B → Coproduct A B
Biproduct⇒Coproduct b = record
  { [_,_] = [_,_]
  ; inject₁ = inject₁
  ; inject₂ = inject₂
  ; unique = []-unique
  }
  where
    open Biproduct b


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

module Lecture8 where

import Lecture7
open Lecture7 public

-- Section 8.1 Propositions

is-prop : {i : Level} (A : UU i) → UU i
is-prop A = (x y : A) → is-contr (Id x y)

is-prop-empty : is-prop empty
is-prop-empty ()

is-prop-unit : is-prop unit
is-prop-unit = is-prop-is-contr is-contr-unit

is-prop' : {i : Level} (A : UU i) → UU i
is-prop' A = (x y : A) → Id x y

is-prop-is-prop' : {i : Level} {A : UU i} → is-prop' A → is-prop A
is-prop-is-prop' {i} {A} H x y =
  dpair
    (concat _ (inv (H x x)) (H x y))
    (ind-Id
      (λ z p → Id (concat _ (inv (H x x)) (H x z)) p)
      (left-inv (H x x)) y)

is-prop'-is-prop : {i : Level} {A : UU i} → is-prop A → is-prop' A
is-prop'-is-prop H x y = pr1 (H x y)

is-contr-is-prop-inh : {i : Level} {A : UU i} → is-prop A → A → is-contr A
is-contr-is-prop-inh H a = dpair a (is-prop'-is-prop H a)

is-subtype : {i j : Level} {A : UU i} (B : A → UU j) → UU (i ⊔ j)
is-subtype B = (x : _) → is-prop (B x)

-- Section 8.2 Sets

is-set : {i : Level} → UU i → UU i
is-set A = (x y : A) → is-prop (Id x y)

axiom-K : {i : Level} → UU i → UU i
axiom-K A = (x : A) (p : Id x x) → Id refl p

is-set-axiom-K : {i : Level} (A : UU i) → axiom-K A → is-set A
is-set-axiom-K A H x y =
  is-prop-is-prop' (ind-Id (λ z p → (q : Id x z) → Id p q) (H x) y)

axiom-K-is-set : {i : Level} (A : UU i) → is-set A → axiom-K A
axiom-K-is-set A H x p =
  concat
    (center (is-contr-is-prop-inh (H x x) refl))
      (inv (contraction (is-contr-is-prop-inh (H x x) refl) refl))
      (contraction (is-contr-is-prop-inh (H x x) refl) p)

is-equiv-prop-in-id : {i j : Level} {A : UU i}
  (R : A → A → UU j)
  (p : (x y : A) → is-prop (R x y))
  (ρ : (x : A) → R x x)
  (i : (x y : A) → R x y → Id x y)
  → (x y : A) → is-equiv (i x y)
is-equiv-prop-in-id R p ρ i x =
  id-fundamental-retr x (i x)
    (λ y → dpair
      (ind-Id (λ z p → R x z) (ρ x) y)
      ((λ r → is-prop'-is-prop (p x y) _ r)))

is-prop-is-equiv : {i j : Level} {A : UU i} (B : UU j)
  (f : A → B) (E : is-equiv f) → is-prop B → is-prop A
is-prop-is-equiv B f E H x y =
  is-contr-is-equiv (ap f {x} {y}) (is-emb-is-equiv f E x y) (H (f x) (f y))

is-prop-is-equiv' : {i j : Level} (A : UU i) {B : UU j}
  (f : A → B) (E : is-equiv f) → is-prop A → is-prop B
is-prop-is-equiv' A f E H =
  is-prop-is-equiv _ (inv-is-equiv E) (is-equiv-inv-is-equiv E) H

is-set-prop-in-id : {i j : Level} {A : UU i}
  (R : A → A → UU j)
  (p : (x y : A) → is-prop (R x y))
  (ρ : (x : A) → R x x)
  (i : (x y : A) → R x y → Id x y)
  → is-set A
is-set-prop-in-id R p ρ i x y = is-prop-is-equiv' (R x y) (i x y) (is-equiv-prop-in-id R p ρ i x y) (p x y)

is-prop-EqN : (n m : ℕ) → is-prop (EqN n m)
is-prop-EqN Nzero Nzero = is-prop-unit
is-prop-EqN Nzero (Nsucc m) = is-prop-empty
is-prop-EqN (Nsucc n) Nzero = is-prop-empty
is-prop-EqN (Nsucc n) (Nsucc m) = is-prop-EqN n m

is-set-nat : is-set ℕ
is-set-nat =
  is-set-prop-in-id
    EqN
    is-prop-EqN
    reflexive-EqN
    (least-reflexive-EqN (λ n → refl))


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

module Math.NumberTheory.Fibonacci.Nat where

-- agda-stdlib
open import Data.Nat
open import Data.Nat.Properties

-- agda-misc
open import Math.NumberTheory.Fibonacci.Generic +-0-commutativeMonoid 0 1
  renaming
  ( fibRec≈fib to fibRec≡fib
  ; fib[2+n]≈fib[1+n]∙fib[n] to fib[2+n]≡fib[1+n]+fib[n]
  ; fib[1+n]∙fib[n]≈fib[2+n] to fib[1+n]+fib[n]≡fib[2+n]
  ; fib[n]∙fib[1+n]≈fib[2+n] to fib[n]+fib[1+n]≡fib[2+n]
  ) public


module Nats.Add.Assoc where

open import Equality
open import Nats
open import Function

------------------------------------------------------------------------
-- internal stuffs

private

  a+/b+c/=/a+b/+c : ∀ a b c → a + b + c ≡ a + (b + c)
  a+/b+c/=/a+b/+c  zero   b c = refl
  a+/b+c/=/a+b/+c (suc a) b c = cong suc $ a+/b+c/=/a+b/+c a b c

------------------------------------------------------------------------
-- public aliases

nat-add-assoc : ∀ a b c → a + b + c ≡ a + (b + c)
nat-add-assoc = a+/b+c/=/a+b/+c


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

data Zero : Nat → Set where
  instance
    isZero : Zero zero

data NonZero : Nat → Set where
  instance
    isSuc : ∀ {n : Nat} → NonZero (suc n)

pred : ∀ t {{_ : NonZero t}} → Nat
pred ._ {{isSuc {n}}} = n

test : Nat
test = pred (suc zero)

data Test (x : Nat) : Set where
  here  : {{_ : Zero x}} → Test x
  there : {{nz : NonZero x}} → Test (pred x) → Test x

broken : Test (suc zero)
broken = there here


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

open import Algebra.Structures.Bundles.Field

module Algebra.Linear.Structures.FiniteDimensional
  {k ℓᵏ} (K : Field k ℓᵏ)
  where

open import Algebra.Linear.Core
open import Algebra.FunctionProperties
open import Relation.Binary using (Rel)

open import Algebra.Linear.Morphism.Bundles K

open import Algebra.Linear.Structures.VectorSpace K

open import Function.Equality

open import Level using (_⊔_; suc)
open import Data.Nat using (ℕ)
import Algebra.Linear.Construct.Vector K as Vec

private
  K' : Set k
  K' = Field.Carrier K

record IsFiniteDimensional
       {v ℓ} {V : Set v}
       (_≈_ : Rel V ℓ)
       (_+_ : Op₂ V) (_∙_ : K' → V → V) (-_ : Op₁ V) (0# : V)
       (n : ℕ) : Set (suc (v ⊔ k ⊔ ℓ ⊔ ℓᵏ))
    where
  field
    isVectorSpace : IsVectorSpace _≈_ _+_ _∙_ -_ 0#
    embed         : LinearIsomorphism (record { isVectorSpace = isVectorSpace })
                                      (record { isVectorSpace = Vec.isVectorSpace {n} })

  open IsVectorSpace isVectorSpace public

module Vector {n} where
  open Vec

  isFiniteDimensional : IsFiniteDimensional (Vec._≈_) (Vec._+_) (Vec._∙_) (Vec.-_) (Vec.0#) n
  isFiniteDimensional = record
    { isVectorSpace = Vec.isVectorSpace
    ; embed         = Vec.embed
    }


module Cat where

open import Agda.Builtin.Equality

{- A category is very much like a graph. It has vertices
   named objects and vertices named arrows. Each arrow goes
   from an object to an object (possibly the same!). -}
record Cat (obj : Set) (arr : obj -> obj -> Set) : Set where
  constructor MkCat
  field
    {- For each object, there is an arrow called `id` which
       goes from the object to itself. -}
    id : {o : obj} -> arr o o

    {- Given an arrow `f` from object `a` to `b` and an arrow
       `g` from `b` to `c`. We can compose these arrow. The
       result is an arrow from `a` to `c`. -}
    compose : {a b c : obj} -> arr a b -> arr b c -> arr a c

    -- Here comes some properties of `id` and `compose`

    {- For any arrow `f`, compose id f = f -}
    neutralLeft  : {a b : obj} -> (f : arr a b) -> compose id f ≡ f

    {- For any arrow `f`, compose f id = f  -}
    neutralRight : {a b : obj} -> (f : arr a b) -> compose f id ≡ f

    {- For any arrows `f`, `g` and `h`,
        composing f with g, and then the result with h
       gives exatctly the same result as
        composing f with the result of the composition of g and h

       Which means, like string concatenation than we can commpose
       the way we preserve the order of each element in the sequence.
    -}
    associativity : {a b c d : obj} ->
                    (f : arr a b) -> (g : arr b c) -> (h : arr c d) ->
                    compose f (compose g h) ≡ compose (compose f g) h

open import Agda.Builtin.Nat

{- `LE n m` encode the property that `n ≤ m`
    i.e. `n` is less or equal to `m` -}
data LE : Nat -> Nat -> Set where
  LERefl : {n : Nat} -> LE n n
  LENext : {n m : Nat} -> LE n m -> LE n (suc m)

{- Taking naturals as objects and `LE` as arrows,
   this actually forms a category! -}
natPoset : Cat Nat LE
natPoset = ???


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

open import Categories.Category
open import Categories.Category.Cocomplete.Finitely

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

open import Categories.Category.Duality C
private
  module C = Category C
  open C

open import Categories.Category.Finite.Fin
open import Categories.Category.Complete.Finitely C.op
open import Categories.Category.Complete.Finitely.Properties (FinitelyCocomplete⇒coFinitelyComplete finite)

open import Categories.Diagram.Colimit
open import Categories.Diagram.Limit
open import Categories.Diagram.Duality C
open import Categories.Functor

finiteColimit : (shape : FinCatShape) (F : Functor (FinCategory shape) C) → Colimit F
finiteColimit shape F = coLimit⇒Colimit (finiteLimit shape.op F.op)
  where module shape = FinCatShape shape
        module F = Functor F


------------------------------------------------------------------------
-- Indices
------------------------------------------------------------------------

module Parallel.Index where

open import Data.Product.Record
import Data.Product as Prod; open Prod using () renaming (_,_ to pair)

open import Data.Bool using (Bool; true; false; _∨_; _∧_; if_then_else_)
open import Data.Bool.Properties as Bool

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

open import Algebra
import Algebra.Props.BooleanAlgebra as BAlg
import Algebra.Props.DistributiveLattice as DL
private
  module NR = CommutativeSemiringWithoutOne
                ⊔-⊓-0-commutativeSemiringWithoutOne
  module NL = DL distributiveLattice
  module BR = CommutativeSemiring Bool.commutativeSemiring-∨-∧
  module BA = BAlg Bool.booleanAlgebra

import Relation.Binary.PropositionalEquality as PropEq
open PropEq hiding (setoid)
open ≡-Reasoning
open import Data.Function
open import Relation.Nullary

------------------------------------------------------------------------
-- The index type

-- Does the parser accept the empty string?

Empty : Set
Empty = Bool

-- The maximum "distance" to the next parser which is guaranteed to
-- either consume a token or fail.

Distance : Set
Distance = ℕ

-- Parser indices. Note that it is important that the record type used
-- here has η-equality, since otherwise it would be harder to infer
-- the types.

Index : Set
Index = Empty × Distance

import Algebra.FunctionProperties as P; open P (PropEq.setoid Index)

------------------------------------------------------------------------
-- The basic operations on indices

infixl 50 _·I_
infixl 40 _∣I_

0I : Index
0I = (false , zero)

1I : Index
1I = (true , zero)

_·I_ : Index -> Index -> Index
i₁ ·I i₂ = ( proj₁ i₁ ∧ proj₁ i₂
           , (if proj₁ i₁ then proj₂ i₁ ⊔ proj₂ i₂
                          else proj₂ i₁)
           )

_∣I_ : Index -> Index -> Index
i₁ ∣I i₂ = (proj₁ i₁ ∨ proj₁ i₂ , proj₂ i₁ ⊔ proj₂ i₂)

------------------------------------------------------------------------
-- These operations satisfy some algebraic properties

private

  -- TODO: General code for taking the product of two commutative
  -- monoids. However, I don't want to define this operation for both
  -- Data.Product and Data.Product.Record. Hence I'll probably wait
  -- (at least) until pattern matching on records is possible, since I
  -- plan to merge Data.Product and Data.Product.Record then.

  ∣-assoc : Associative _∣I_
  ∣-assoc i₁ i₂ i₃ =
    cong₂ _,_ (BR.+-assoc (proj₁ i₁) (proj₁ i₂) (proj₁ i₃))
              (NR.+-assoc (proj₂ i₁) (proj₂ i₂) (proj₂ i₃))

  ∣-comm : Commutative _∣I_
  ∣-comm i₁ i₂ =
    cong₂ _,_ (BR.+-comm (proj₁ i₁) (proj₁ i₂))
              (NR.+-comm (proj₂ i₁) (proj₂ i₂))

  ∣-identity : Identity 0I _∣I_
  ∣-identity = pair
    (\i -> cong₂ _,_ (Prod.proj₁ BR.+-identity (proj₁ i))
                     (Prod.proj₁ NR.+-identity (proj₂ i)))
    (\i -> cong₂ _,_ (Prod.proj₂ BR.+-identity (proj₁ i))
                     (Prod.proj₂ NR.+-identity (proj₂ i)))

  ·-assoc : Associative _·I_
  ·-assoc i₁ i₂ i₃ with proj₁ i₁ | proj₁ i₂
  ·-assoc i₁ i₂ i₃ | false | e₂    = refl
  ·-assoc i₁ i₂ i₃ | true  | false = refl
  ·-assoc i₁ i₂ i₃ | true  | true  =
    cong (_,_ (proj₁ i₃)) (NR.+-assoc (proj₂ i₁) (proj₂ i₂) (proj₂ i₃))

  ·-identity : Identity 1I _·I_
  ·-identity = pair (\_ -> refl) (\x -> helper (proj₁ x) (proj₂ x))
    where
    helper : forall e d ->
             _≡_ {a = Index} (e ∧ true , (if e then d ⊔ zero else d))
                             (e        , d)
    helper false d = refl
    helper true  d = cong (_,_ true) (Prod.proj₂ NR.+-identity d)

  ·-∣-distrib : _·I_ DistributesOver _∣I_
  ·-∣-distrib = pair
    (\i₁ i₂ i₃ ->
        cong₂ _,_
              (Prod.proj₁ BR.distrib (proj₁ i₁) (proj₁ i₂) (proj₁ i₃))
              (distribˡ₂ (proj₂ i₁) (proj₂ i₂) (proj₂ i₃) (proj₁ i₁)))
    (\i₁ i₂ i₃ ->
        cong₂ _,_
              (Prod.proj₂ BR.distrib (proj₁ i₁) (proj₁ i₂) (proj₁ i₃))
              (distribʳ₂ (proj₂ i₁) (proj₂ i₂) (proj₂ i₃)
                                    (proj₁ i₂) (proj₁ i₃)))
    where
    lemma : forall d₁ d₂ d₃ -> d₁ ⊔ (d₂ ⊔ d₃) ≡ d₁ ⊔ d₂ ⊔ (d₁ ⊔ d₃)
    lemma d₁ d₂ d₃ = begin
      d₁       ⊔ (d₂ ⊔ d₃)   ≡⟨ sym (NL.∧-idempotent d₁)
                                  ⟨ NR.+-pres-≈ ⟩
                                byDef {x = d₂ ⊔ d₃} ⟩
      d₁ ⊔  d₁ ⊔ (d₂ ⊔ d₃)   ≡⟨ NR.+-assoc d₁ d₁ (d₂ ⊔ d₃) ⟩
      d₁ ⊔ (d₁ ⊔ (d₂ ⊔ d₃))  ≡⟨ byDef {x = d₁} ⟨ NR.+-pres-≈ ⟩
                                sym (NR.+-assoc d₁ d₂ d₃) ⟩
      d₁ ⊔ (d₁ ⊔  d₂ ⊔ d₃)   ≡⟨ byDef {x = d₁} ⟨ NR.+-pres-≈ ⟩
                                  (NR.+-comm d₁ d₂ ⟨ NR.+-pres-≈ ⟩
                                   byDef {x = d₃}) ⟩
      d₁ ⊔ (d₂ ⊔  d₁ ⊔ d₃)   ≡⟨ byDef {x = d₁} ⟨ NR.+-pres-≈ ⟩
                                NR.+-assoc d₂ d₁ d₃ ⟩
      d₁ ⊔ (d₂ ⊔ (d₁ ⊔ d₃))  ≡⟨ sym $ NR.+-assoc d₁ d₂ (d₁ ⊔ d₃) ⟩
      d₁ ⊔ d₂  ⊔ (d₁ ⊔ d₃)   ∎

    distribˡ₂ : forall d₁ d₂ d₃ e₁ ->
                (if e₁ then d₁ ⊔ (d₂ ⊔ d₃) else d₁) ≡
                (if e₁ then d₁ ⊔ d₂        else d₁) ⊔
                (if e₁ then d₁ ⊔ d₃        else d₁)
    distribˡ₂ d₁ d₂ d₃ true  = lemma d₁ d₂ d₃
    distribˡ₂ d₁ d₂ d₃ false = sym (NL.∧-idempotent d₁)

    distribʳ₂ : forall d₁ d₂ d₃ e₂ e₃ ->
                (if e₂ ∨ e₃ then d₂ ⊔ d₃ ⊔ d₁ else d₂ ⊔ d₃)
                ≡
                (if e₂ then d₂ ⊔ d₁ else d₂) ⊔
                (if e₃ then d₃ ⊔ d₁ else d₃)
    distribʳ₂ d₁ d₂ d₃ true true = begin
      d₂ ⊔ d₃ ⊔ d₁         ≡⟨ NR.+-comm (d₂ ⊔ d₃) d₁ ⟩
      d₁ ⊔ (d₂ ⊔ d₃)       ≡⟨ lemma d₁ d₂ d₃ ⟩
      d₁ ⊔ d₂ ⊔ (d₁ ⊔ d₃)  ≡⟨ NR.+-comm d₁ d₂ ⟨ NR.+-pres-≈ ⟩
                              NR.+-comm d₁ d₃ ⟩
      d₂ ⊔ d₁ ⊔ (d₃ ⊔ d₁)  ∎
    distribʳ₂ d₁ d₂ d₃ true false = begin
      d₂ ⊔  d₃ ⊔ d₁   ≡⟨ NR.+-assoc d₂ d₃ d₁ ⟩
      d₂ ⊔ (d₃ ⊔ d₁)  ≡⟨ byDef {x = d₂} ⟨ NR.+-pres-≈ ⟩
                         NR.+-comm d₃ d₁ ⟩
      d₂ ⊔ (d₁ ⊔ d₃)  ≡⟨ sym $ NR.+-assoc d₂ d₁ d₃ ⟩
      d₂ ⊔  d₁ ⊔ d₃   ∎
    distribʳ₂ d₁ d₂ d₃ false true  = NR.+-assoc d₂ d₃ d₁
    distribʳ₂ d₁ d₂ d₃ false false = refl

·-idempotent : Idempotent _·I_
·-idempotent i = cong₂ _,_ (BA.∧-idempotent (proj₁ i))
                           (lemma (proj₁ i) (proj₂ i))
  where
  lemma : forall b x -> (if b then x ⊔ x else x) ≡ x
  lemma true  x = NL.∧-idempotent x
  lemma false x = refl

∣-idempotent : Idempotent _∣I_
∣-idempotent i = cong₂ _,_ (BA.∨-idempotent (proj₁ i))
                           (NL.∧-idempotent (proj₂ i))

-- Not quite a semiring, but the proper name is too long...

indexSemiring : SemiringWithoutAnnihilatingZero
indexSemiring = record
  { setoid = PropEq.setoid Index
  ; _+_    = _∣I_
  ; _*_    = _·I_
  ; 0#     = 0I
  ; 1#     = 1I
  ; isSemiringWithoutAnnihilatingZero = record
    { +-isCommutativeMonoid = record
      { isMonoid = record
        { isSemigroup = record
          { assoc    = ∣-assoc
          ; ∙-pres-≈ = cong₂ _∣I_
          }
        ; identity = ∣-identity
        }
      ; comm = ∣-comm
      }
    ; *-isMonoid = record
      { isSemigroup = record
        { assoc    = ·-assoc
        ; ∙-pres-≈ = cong₂ _·I_
        }
      ; identity = ·-identity
      }
    ; distrib = ·-∣-distrib
    }
  }

module IndexSemiring =
  SemiringWithoutAnnihilatingZero indexSemiring

nearSemiring : NearSemiring
nearSemiring = record
  { setoid = setoid
  ; _+_    = _+_
  ; _*_    = _*_
  ; 0#     = 0#
  ; isNearSemiring = record
    { +-isMonoid    = +-isMonoid
    ; *-isSemigroup = *-isSemigroup
    ; distribʳ      = Prod.proj₂ distrib
    ; zeroˡ         = \_ -> PropEq.refl
    }
  }
  where open IndexSemiring

private

  lemma : suc zero ≢ zero
  lemma ()

  -- The indices very nearly form a semiring (∣I, ·I, 0I, 1I). The
  -- only missing piece is that 0I is not a right zero for ·I:

  notRightZero : ¬ RightZero 0I _·I_
  notRightZero zeroʳ = lemma $ cong proj₂ $
    zeroʳ (false , suc zero)

  -- It might also be worth noting that ·I is not commutative:

  notCommutative : ¬ Commutative _·I_
  notCommutative comm = lemma $ cong proj₂ $
    comm (true , suc zero) (false , zero)

  -- Note that we don't want these properties to be true. The second
  -- one implies the first, and the first implies that
  --   p = p ⊛> symbol
  -- is an OK definition, even though it is left recursive.


open import Relation.Binary.Core

module SelectSort.Everything {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import SelectSort.Correctness.Order _≤_ tot≤ trans≤
open import SelectSort.Correctness.Permutation _≤_ tot≤


{-# OPTIONS --safe #-}
module Cubical.Algebra.AbGroup.Properties where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.AbGroup.Base

private variable
  ℓ : Level

module AbGroupTheory (A'@(A , Ar) : AbGroup ℓ) where

  open AbGroupStr Ar

  comm-4 : (a b c d : A) → ((a + b) + (c + d) ≡ (a + c) + (b + d))
  comm-4 a b c d = ((a + b) + (c + d)  ≡⟨ +Assoc (a + b) c d ⟩
                   (((a + b) + c) + d) ≡⟨ cong (λ X → X + d) (sym (+Assoc a b c)) ⟩
                   ((a + (b + c)) + d) ≡⟨ cong (λ X → (a + X) + d) (+Comm b c) ⟩
                   ((a + (c + b)) + d) ≡⟨ cong (λ X → X + d) (+Assoc a c b) ⟩
                   (((a + c) + b) + d) ≡⟨ sym (+Assoc (a + c) b d) ⟩
                   ((a + c) + (b + d)) ∎)


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

module Data.Binary.Isomorphism where

open import Data.Binary.Definition
open import Data.Binary.Conversion
open import Data.Binary.Increment
open import Prelude
import Data.Nat as ℕ

inc-suc : ∀ x → ⟦ inc x ⇓⟧ ≡ suc ⟦ x ⇓⟧
inc-suc 0ᵇ     i = 1
inc-suc (1ᵇ x) i = 2 ℕ.+ ⟦ x ⇓⟧ ℕ.* 2
inc-suc (2ᵇ x) i = suc (inc-suc x i ℕ.* 2)

inc-2*-1ᵇ : ∀ n → inc ⟦ n ℕ.* 2 ⇑⟧ ≡ 1ᵇ ⟦ n ⇑⟧
inc-2*-1ᵇ zero    i = 1ᵇ 0ᵇ
inc-2*-1ᵇ (suc n) i = inc (inc (inc-2*-1ᵇ n i))

𝔹-rightInv : ∀ x → ⟦ ⟦ x ⇑⟧ ⇓⟧ ≡ x
𝔹-rightInv zero    = refl
𝔹-rightInv (suc x) = inc-suc ⟦ x ⇑⟧ ; cong suc (𝔹-rightInv x)

𝔹-leftInv : ∀ x → ⟦ ⟦ x ⇓⟧ ⇑⟧ ≡ x
𝔹-leftInv 0ᵇ = refl
𝔹-leftInv (1ᵇ x) =           inc-2*-1ᵇ ⟦ x ⇓⟧  ; cong 1ᵇ_ (𝔹-leftInv x)
𝔹-leftInv (2ᵇ x) = cong inc (inc-2*-1ᵇ ⟦ x ⇓⟧) ; cong 2ᵇ_ (𝔹-leftInv x)

𝔹⇔ℕ : 𝔹 ⇔ ℕ
𝔹⇔ℕ .fun = ⟦_⇓⟧
𝔹⇔ℕ .inv = ⟦_⇑⟧
𝔹⇔ℕ .rightInv = 𝔹-rightInv
𝔹⇔ℕ .leftInv  = 𝔹-leftInv


module Cats.Category.Mon where

open import Data.Unit using (⊤)
open import Relation.Binary using (Setoid ; _Preserves₂_⟶_⟶_ ; IsEquivalence)
open import Level

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)
open import Cats.Util.Conv

import Cats.Util.Function as Fun

record Monoid l l≈ : Set (suc (l ⊔ l≈)) where
  infixr 9 _⊕_

  field
    Universe : Setoid l l≈

  open Setoid Universe public

  field
    _⊕_ : Carrier → Carrier → Carrier
    unit : Carrier

    ⊕-resp : _⊕_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
    assoc : ∀ {a b c} → (a ⊕ b) ⊕ c ≈ a ⊕ (b ⊕ c)
    id-l : ∀ {a} → unit ⊕ a ≈ a
    id-r : ∀ {a} → a ⊕ unit ≈ a

  module ≈ = IsEquivalence isEquivalence

module _ (l l≈ : Level) where

  infixr 9 _∘_
  infixr 4 _≈_

  module Setoids = Category (Setoids l l≈)

  Obj : Set (suc (l ⊔ l≈))
  Obj = Monoid l l≈

  record _⇒_ (M N : Obj) : Set (l ⊔ l≈) where
    private
      module M = Monoid M
      module N = Monoid N

    field
      arr : M.Universe Setoids.⇒ N.Universe
      unit : (arr ⃗) M.unit N.≈ N.unit
      commute : ∀ {n m} → (arr ⃗) (n M.⊕ m) N.≈ (arr ⃗) n N.⊕ (arr ⃗) m

    open Cats.Category.Setoids._⇒_ arr public using (resp)

  open _⇒_ using (unit ; commute ; resp)

  instance
    HasArrow-⇒ : ∀ M N → HasArrow (M ⇒ N) _ _ _
    HasArrow-⇒ M N = record { Cat = Setoids l l≈ ; _⃗ = _⇒_.arr }

  id : ∀ {M} → M ⇒ M
  id {M} = record
      { arr = Setoids.id
      ; unit = refl
      ; commute = refl
      }
    where
      open Monoid M using (refl)

  _≈_ : ∀ {M N} (f g : M ⇒ N) → Set (l≈ ⊔ l)
  _≈_ = Setoids._≈_ Fun.on _⃗

  _∘_ : ∀ {M N O} → (N ⇒ O) → (M ⇒ N) → (M ⇒ O)
  _∘_ {M} {N} {O} f g = record
      { arr = f ⃗ Setoids.∘ g ⃗
      ; unit = trans (resp f (unit g)) (unit f)
      ; commute = trans (resp f (commute g)) (commute f)
      }
    where
      open Monoid O using (trans)

  Mon : Category (suc (l≈ ⊔ l)) (l≈ ⊔ l) (l≈ ⊔ l)
  Mon = record
      { Obj = Obj
      ; _⇒_ = _⇒_
      ; _≈_ = _≈_
      ; id = id
      ; _∘_ = _∘_
      ; equiv = Fun.on-isEquivalence _⃗ Setoids.equiv
      ; ∘-resp = Setoids.∘-resp
      ; id-r = Setoids.id-r
      ; id-l = Setoids.id-l
      ; assoc = λ { {f = f} {g} {h} → Setoids.assoc {f = f ⃗} {g ⃗} {h ⃗} }
      }

monoidAsCategory : ∀ {l l≈} → Monoid l l≈ → Category zero l l≈
monoidAsCategory M = record
    { Obj = ⊤
    ; _⇒_ = λ _ _ → M.Carrier
    ; _≈_ = M._≈_
    ; id = M.unit
    ; _∘_ = M._⊕_
    ; equiv = M.isEquivalence
    ; ∘-resp = M.⊕-resp
    ; id-r = M.id-r
    ; id-l = M.id-l
    ; assoc = M.assoc
    }
  where
    module M = Monoid M


------------------------------------------------------------------------------
-- Group theory congruence proofs using pattern matching
------------------------------------------------------------------------------

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

module LogicalFramework.GroupCongruence where

open import GroupTheory.Base

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

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

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

⁻¹-cong : ∀ {a b} → a ≡ b → a ⁻¹ ≡ b ⁻¹
⁻¹-cong refl = refl


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

-- Define Strong Monad; use the Wikipedia definition
-- https://en.wikipedia.org/wiki/Strong_monad
-- At the nLab, https://ncatlab.org/nlab/show/strong+monad
-- there are two further definitions; the 2-categorical version is too complicated
-- and the Moggi definition is a special case of the one here

module Categories.Monad.Strong  where

open import Level
open import Data.Product using (_,_)

open import Categories.Category
open import Categories.Functor renaming (id to idF)
open import Categories.Category.Monoidal
open import Categories.Category.Product
open import Categories.NaturalTransformation hiding (id)
-- open import Categories.NaturalTransformation.NaturalIsomorphism
open import Categories.Monad

private
  variable
    o ℓ e : Level

record Strength {C : Category o ℓ e} (V : Monoidal C) (m : Monad C) : Set (o ⊔ ℓ ⊔ e) where
  open Category C
  open Monoidal V
  open Monad m using (F)
  module M = Monad m
  open NaturalTransformation M.η using (η)
  open NaturalTransformation M.μ renaming (η to μ)
  open Functor F
  field
    strengthen : NaturalTransformation (⊗ ∘F (idF ⁂ F)) (F ∘F ⊗)

  private
    module t = NaturalTransformation strengthen

  field
    -- strengthening with 1 is irrelevant
    identityˡ : {A : Obj} → F₁ (unitorˡ.from) ∘ t.η (unit , A) ≈ unitorˡ.from
    -- commutes with unit (of monad)
    η-comm : {A B : Obj} → t.η (A , B) ∘ (id ⊗₁ η B) ≈  η (A ⊗₀ B)
    -- strength commutes with multiplication
    μ-η-comm : {A B : Obj} → μ (A ⊗₀ B) ∘ F₁ (t.η (A , B)) ∘ t.η (A , F₀ B)
      ≈ t.η (A , B) ∘ id ⊗₁ μ B
    -- consecutive applications of strength commute (i.e. strength is associative)
    strength-assoc :  {A B C : Obj} → F₁ associator.from ∘ t.η (A ⊗₀ B , C)
      ≈ t.η (A , B ⊗₀ C) ∘ id ⊗₁ t.η (B , C) ∘ associator.from

record StrongMonad {C : Category o ℓ e} (V : Monoidal C) : Set (o ⊔ ℓ ⊔ e) where
  field
    m : Monad C
    strength : Strength V m


------------------------------------------------------------------------------
-- Mendelson's substitution
------------------------------------------------------------------------------

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

module FOT.FOL.MendelsonSubstI where

-- First-order logic with equality.
open import Common.FOL.FOL-Eq public

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

-- Mendelson's [2015] substitution (p. 93).

--   (A7) x = y ⇒ (A(x,x) ⇒ B(x,y)) (substitutivity of equality)

-- Using pattern matching.
mendelsonSubst : (A : D → D → Set) → ∀ {x y} → x ≡ y → A x x → A x y
mendelsonSubst A refl Axx = Axx

-- From `subst` to Mendelson substitution.
subst→mendelsonSubst : (A : D → D → Set) → ∀ {x y} → x ≡ y → A x x → A x y
subst→mendelsonSubst A {x} = subst (λ z → A x z)

-- From Mendelson substitution to `subst`.
mendelsonSubst→subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
mendelsonSubst→subst A = mendelsonSubst (λ _ → A)

------------------------------------------------------------------------------
-- References

-- Mendelson, Elliott (2015). Introduction to Mathematical Logic. CRC
-- Press, 6th edition.


{-# OPTIONS --cubical --safe #-}
module Label where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude using (isProp; transport)

open import Cubical.Data.Nat using (ℕ; zero; suc; isSetℕ)
open import Cubical.Data.Nat.Order using (_<_; _≤_; ≤-refl; <-weaken; ≤<-trans; m≤n-isProp; <-asym)
open import Cubical.Data.Maybe using (Maybe; nothing; just)
open import Cubical.Data.Empty using () renaming (rec to ⊥-elim)

Label : Set
Label = ℕ

data Record (A : Set) : Label -> Set where
  nil : forall {l} -> Record A l
  cons : forall {l} -> Record A l -> (l' : Label) -> A -> .(l < l') -> Record A l'

data _∈_ {A : Set} (l₁ : Label) {l : Label} : Record A l -> Set where
  here : forall {l'} {r : Record A l'} {x lt} -> l₁ ≡ l -> l₁ ∈ cons r l x lt
  there : forall {l'} {r : Record A l'} {x lt} -> l₁ ∈ r -> l₁ ∈ cons r l x lt

find : forall {A} {l} -> (l₁ : Label) -> (r : Record A l) -> l₁ ∈ r -> A
find l₁ (cons _ _ x _) (here e) = x
find l₁ (cons r _ _ _) (there l₁∈r) = find l₁ r l₁∈r

∈-implies-≤ : forall {A} {l l'} {r : Record A l'} -> l ∈ r -> l ≤ l'
∈-implies-≤ {l = l} (here e) = transport (λ i -> l ≤ e i) ≤-refl
∈-implies-≤ (there {lt = lt} l∈r) = <-weaken (≤<-trans (∈-implies-≤ l∈r) lt)

l∈r-isProp : forall {A} l {l'} (r : Record A l') -> isProp (l ∈ r)
l∈r-isProp l {l'} (cons _ _ _ _) (here {lt = a} e1) (here {lt = b} e2) = λ i -> here {lt = m≤n-isProp a b i} (isSetℕ l l' e1 e2 i)
l∈r-isProp l (cons {l = l₁} r _ _ _) (here {lt = k} e) (there y) = ⊥-elim (<-asym k (transport (λ i -> e i ≤ l₁) (∈-implies-≤ y)))
l∈r-isProp l (cons {l = l₁} r _ _ _) (there {lt = k} x) (here e) = ⊥-elim (<-asym k (transport (λ i -> e i ≤ l₁) (∈-implies-≤ x)))
l∈r-isProp l (cons r _ _ _) (there {lt = k1} x) (there {lt = k2} y) = let a = l∈r-isProp l r x y in λ i → there {lt = m≤n-isProp k1 k2 i} (a i)


----------------------------------------------------------------
-- This file contains the definition natural transformations. --
----------------------------------------------------------------
module Category.NatTrans where

open import Level

open import Category.Category public
open import Category.Funct public
open import Category.CatEq public

record NatTrans {l₁ l₂ : Level}
                {ℂ₁ : Cat {l₁}}
                {ℂ₂ : Cat {l₂}}
                (F G : Functor ℂ₁ ℂ₂) : Set (l₁ ⊔ l₂) where
  field
    -- The family of components.
    η : (A : Obj ℂ₁) → el (Hom ℂ₂ (omap F A) (omap G A))

    -- The natural transformation law.
    η-ax : ∀{A B}{f : el (Hom ℂ₁ A B)} → comm-square {ℂ = ℂ₂} (appT (fmap F) f) (η B) (η A) (appT (fmap G) f)

open NatTrans public


-- Agda program using the Iowa Agda library

open import bool

module TO-PROVE-evendoublecoin
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
  where

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

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

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

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

double : ℕ → ℕ
double x = add x x

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

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

evendoublecoin : (c1 : Choice) → (x : ℕ) → (even (double (coin c1 x))) ≡ tt
evendoublecoin c1 x = ?

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


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

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

record Stream (A : Set) : Set where
  constructor stream
  field
    start : A
    next : A → A

open Stream

ℕ-stream : Stream ℕ
start ℕ-stream = zero
next ℕ-stream n = succ n

0th : {A : Set} → Stream A → A
0th s = start s

3rd : {A : Set} → Stream A → A
3rd s = next s (next s (next s (start s)))

_ : 0th ℕ-stream ≡ zero
_ = refl

_ : 3rd ℕ-stream ≡ succ (succ (succ zero))
_ = refl


open import Agda.Builtin.Bool
open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma
open import Agda.Primitive

infixr 2 _×_

_×_ : ∀ {a b} → Set a → Set b → Set (a ⊔ b)
A × B = Σ A λ _ → B

∃-notation exists-notation :
  ∀ {a b} {A : Set a} → (A → Set b) → Set (a ⊔ b)
∃-notation      = Σ _
exists-notation = Σ _

Σ-notation : ∀ {a b} (A : Set a) → (A → Set b) → Set (a ⊔ b)
Σ-notation = Σ

infixr 2 ∃-notation exists-notation Σ-notation

syntax ∃-notation (λ x → B)      = ∃ x × B
syntax exists-notation (λ x → B) = exists x × B
syntax Σ-notation A (λ x → B)    = [ x ∶ A ] × B

_ : ∃ b × b ≡ true × Bool
_ = true , refl , false

_ : exists b × b ≡ true
_ = true , refl

_ : [ b ∶ Bool ] × b ≡ true
_ = true , refl

_ : [ b₁ ∶ Bool ] × [ b₂ ∶ Bool ] × b₁ ≡ b₂
_ = true , true , refl

_ : [ b₁ ∶ Bool ] × ∃ b₂ × b₁ ≡ b₂
_ = true , true , refl

_ : [ f ∶ (Bool → Bool) ] × f ≡ λ x → x
_ = (λ x → x) , refl

data List (A : Set) : Set where
  []   : List A
  cons : A → List A → List A

infixr 5 cons

syntax []        = [ ]
syntax cons x xs = x consed to xs

_ : List Bool
_ = true consed to false consed to [ ]

f : List Bool → Bool
f [ ]                               = true
f (true consed to [ ])              = false
f (false consed to x consed to [ ]) = x
f _                                 = true


module Acme.Data.Nat where

open import Acme.Type

ℕ   : Type
isZ : Type
isS : Type

ℕ cs = isZ cs || isS cs

isZ [] = false
isZ (c ∷ cs) = c == 'Z' && isNil cs

isS [] = false
isS (c ∷ cs) = c == 'S' && ℕ cs

zero = ℕ ∋ "Z"

suc : Elt ℕ → Elt ℕ
suc [ n ] = [ 'S' ∷ n ]

one    = ℕ ∋ "SZ"
two    = suc (suc zero)
three  = ℕ ∋ "SSSZ"
four   = suc three

module _ (P : Elt ℕ → Set)
         (P0 : P zero)
         (PS : ∀ n → P n → P (suc n))
         where

  induction : ∀ n → P n
  induction [ ccs@(c ∷ cs) ] = checkZ (c ≟ 'Z') cs refl where

    checkS : ∀ {b} → Reflects c 'S' b → ∀ cs →
             {{@0 _ : IsTrue (b && ℕ cs)}} →
             ∀ {ccs} → c ∷ cs ≡ ccs .value → P ccs
    checkS true cs refl = PS [ cs ] (induction [ cs ])

    checkZ : ∀ {b} → Reflects c 'Z' b → ∀ cs →
             {{@0 _ : IsTrue (b && isNil cs || isS (c ∷ cs))}} →
             ∀ {ccs} → c ∷ cs ≡ ccs .value → P ccs
    checkZ true  [] refl = P0
    checkZ false cs eq   = checkS (c ≟ 'S') cs eq

_ : ∀ {P P0 PS} → induction P P0 PS zero ≡ P0
_ = refl

_ : ∀ {P P0 PS n} →
    induction P P0 PS (suc n) ≡ PS n (induction P P0 PS n)
_ = refl

_+_ : Elt ℕ → Elt ℕ → Elt ℕ
m + n = induction (λ _ → Elt ℕ) n (λ _ → suc) m

_ : three + one ≡ four
_ = refl

_*_ : Elt ℕ → Elt ℕ → Elt ℕ
m * n = induction (λ _ → Elt ℕ) zero (λ _ → n +_) m

_ : two * three ≡ four + two
_ = refl

zero-+ : ∀ m → zero + m ≡ m
zero-+ m = refl

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

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

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

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n =
  induction
    (λ m → m + n ≡ n + m)
    (sym (+-zero n))
    (λ m ih → trans (cong suc ih) (sym (+-suc n m)))
    m

+-assoc : ∀ m n p → (m + n) + p ≡ m + (n + p)
+-assoc m n p =
  induction
    (λ m → ((m + n) + p) ≡ (m + (n + p)))
    refl
    (λ m → cong suc)
    m


module Oscar.Property.Associativity where

open import Oscar.Level

record Associativity
  {𝔬} {⋆ : Set 𝔬}
  {𝔪} {_⇒_ : ⋆ → ⋆ → Set 𝔪}
  (_∙_ : ∀ {y z} → y ⇒ z → ∀ {x} → x ⇒ y → x ⇒ z)
  {𝔮} (_≤_ : ∀ {x y} → x ⇒ y → x ⇒ y → Set 𝔮)
  : Set (𝔬 ⊔ 𝔪 ⊔ 𝔮) where
  field
    associativity : ∀ {w x} (f : w ⇒ x) {y} (g : x ⇒ y) {z} (h : y ⇒ z) → ((h ∙ g) ∙ f) ≤ (h ∙ (g ∙ f))

open Associativity ⦃ … ⦄ public

association : ∀
  {𝔬} {⋆ : Set 𝔬}
  {𝔪} {_⇒_ : ⋆ → ⋆ → Set 𝔪}
  (_∙_ : ∀ {y z} → y ⇒ z → ∀ {x} → x ⇒ y → x ⇒ z)
  {𝔮} (_≤_ : ∀ {x y} → x ⇒ y → x ⇒ y → Set 𝔮)
  ⦃ _ : Associativity _∙_ _≤_ ⦄
  → ∀ {w x} (f : w ⇒ x) {y} (g : x ⇒ y) {z} (h : y ⇒ z) → ((h ∙ g) ∙ f) ≤ (h ∙ (g ∙ f))
association _∙_ _≤_ = associativity {_∙_ = _∙_} {_≤_ = _≤_}