module L where

open import Data.Nat using (ℕ; suc) -- ; _*_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym; trans)
open import Data.Product
open import Data.Empty

-- Recursion principle

recℕ : (C : Set) → C → (ℕ → C → C) → ℕ → C
recℕ C c f 0 = c
recℕ C c f (suc n) = f n (recℕ C c f n)

double : ℕ → ℕ
double = recℕ ℕ 0 (λ n r → suc (suc r))

add : ℕ → ℕ → ℕ
add = recℕ (ℕ → ℕ) (λ n → n) (λ m r → λ n → suc (r n))

-- fact : ℕ → ℕ
-- fact = recℕ ℕ 1 (λ n r → suc n * r)

-- Induction principle

indℕ : (C : ℕ → Set) → C 0 → ((n : ℕ) → C n → C (suc n)) → (n : ℕ) → C n
indℕ C c f 0 = c
indℕ C c f (suc n) = f n (indℕ C c f n)

add-assoc : (i j k : ℕ) → add i (add j k) ≡ add (add i j) k
add-assoc = indℕ
              (λ i → (j k : ℕ) → add i (add j k) ≡ add (add i j) k)
              (λ j k → refl)
              (λ i i+[j+k]≡[i+j]+k j k → cong suc (i+[j+k]≡[i+j]+k j k))

add-right-unit : (i : ℕ) → add i 0 ≡ i
add-right-unit = indℕ (λ i → add i 0 ≡ i) refl (λ i i+0≡i → cong suc i+0≡i)

add-suc : (i j : ℕ) → suc (add i j) ≡ add i (suc j)
add-suc = indℕ (λ i → (j : ℕ) → suc (add i j) ≡ add i (suc j))
               (λ j → refl)
               (λ i s[i+j]≡i+s[j] j → cong suc (s[i+j]≡i+s[j] j))

add-comm : (i j : ℕ) → add i j ≡ add j i
add-comm = indℕ
             (λ i → (j : ℕ) → add i j ≡ add j i)
             (λ j → sym (add-right-unit j))
             (λ i i+j≡j+i j → trans (cong suc (i+j≡j+i j)) (add-suc j i))

-- Some type definitions

_≤_ : (i j : ℕ) → Set
i ≤ j = Σ[ k ∈ ℕ ] (add i k ≡ j)

i≤i+j : (i j : ℕ) → i ≤ add i j
i≤i+j = indℕ
          (λ i → (j : ℕ) → i ≤ add i j)
          (λ j → (j , refl))
          (λ i i≤i+j j → (j , refl))

¬ : Set → Set
¬ A = A → ⊥

_<_ : (i j : ℕ) → Set
i < j = (i ≤ j) × ¬ (i ≡ j)

0≠si : (i : ℕ) → ¬ (0 ≡ suc i)
0≠si i = λ ()

0< : (i : ℕ) → (0 < suc i)
0< = indℕ  (λ i → 0 < suc i)
           {!!}
           {!!}


module Nat where

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

{-# BUILTIN NATURAL ℕ #-}

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎


module Logic.Identity where

open import Logic.Equivalence
open import Logic.Base

infix 20 _≡_ _≢_

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

subst : {A : Set}(P : A -> Set){x y : A} -> x ≡ y -> P y -> P x
subst P {x} .{x} refl px = px

sym : {A : Set}{x y : A} -> x ≡ y -> y ≡ x
sym {A} refl = refl

trans : {A : Set}{x y z : A} -> x ≡ y -> y ≡ z -> x ≡ z
trans {A} refl xz = xz

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

cong2 : {A B C : Set}(f : A -> B -> C){x z : A}{y w : B} -> x ≡ z -> y ≡ w -> f x y ≡ f z w
cong2 {A}{B} f refl refl = refl

Equiv : {A : Set} -> Equivalence A
Equiv = record
	{ _==_  = _≡_
	; refl  = \x -> refl
	; sym   = \x y -> sym
	; trans = \x y z -> trans
	}

_≢_ : {A : Set} -> A -> A -> Set
x ≢ y = ¬ (x ≡ y)

sym≢ : {A : Set}{x y : A} -> x ≢ y -> y ≢ x
sym≢ np p = np (sym p)


open import Relation.Binary.Core

module PLRTree.Order {A : Set} where

open import Data.Nat
open import Data.Sum
open import PLRTree {A}
open import Relation.Binary

open DecTotalOrder decTotalOrder hiding (refl)

height : PLRTree → ℕ
height leaf = zero
height (node t x l r)
    with total (height l) (height r)
... | inj₁ hl≤hr = suc (height r)
... | inj₂ hr≤hl = suc (height l)

_≺_ : PLRTree → PLRTree → Set
t ≺ t' = height t <′ height t'


open import Relation.Binary.Core

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

open import Data.List
open import Data.Sum
open import Function
open import InsertSort.Impl1 _≤_ tot≤
open import List.Permutation.Alternative A renaming (_∼_ to _∼′_)
open import List.Permutation.Alternative.Correctness A
open import List.Permutation.Base A

lemma-insert∼′ : (x : A)(xs : List A) → (x ∷ xs) ∼′ insert x xs
lemma-insert∼′ x [] = ∼refl
lemma-insert∼′ x (y ∷ ys)
    with tot≤ x y
... | inj₁ x≤y = ∼refl
... | inj₂ y≤x = ∼trans (∼swap ∼refl) (∼head y (lemma-insert∼′ x ys))

lemma-insertSort∼′ : (xs : List A) → xs ∼′ insertSort xs
lemma-insertSort∼′ [] = ∼refl
lemma-insertSort∼′ (x ∷ xs) = ∼trans (∼head x (lemma-insertSort∼′ xs)) (lemma-insert∼′ x (insertSort xs))

theorem-insertSort∼ : (xs : List A) → xs ∼ insertSort xs
theorem-insertSort∼ = lemma-∼′-∼ ∘ lemma-insertSort∼′


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

module SOList.Total.Properties {A : Set}
               (_≤_ : A → A → Set)
               (trans≤ : Transitive _≤_)  where

open import Bound.Total A
open import Bound.Total.Order _≤_
open import Bound.Total.Order.Properties _≤_ trans≤
open import List.Order.Bounded _≤_
open import List.Order.Bounded.Properties _≤_ trans≤
open import List.Sorted _≤_
open import Size
open import SOList.Total _≤_

lemma-solist≤ : {ι : Size}{b t : Bound} → SOList {ι} b t → LeB b t
lemma-solist≤ (onil b≤t) = b≤t
lemma-solist≤ (ocons x xs ys) = transLeB (lemma-solist≤ xs) (lemma-solist≤ ys)

lemma-solist≤* : {ι : Size}{b : Bound}{x : A} → (xs : SOList {ι} b (val x)) → forget xs ≤* (val x)
lemma-solist≤* (onil _) = lenx
lemma-solist≤* (ocons x xs ys) = lemma-++≤* (lemma-solist≤ ys) (lemma-solist≤* xs) (lemma-solist≤* ys)

lemma-solist*≤ : {ι : Size}{b t : Bound} → (xs : SOList {ι} b t) → b *≤ forget xs
lemma-solist*≤ (onil _) = genx
lemma-solist*≤ (ocons x xs ys) = lemma-++*≤ (lemma-solist≤ xs) (lemma-solist*≤ xs) (lemma-solist*≤ ys)

lemma-solist-sorted : {ι : Size}{b t : Bound}(xs : SOList {ι} b t) → Sorted (forget xs)
lemma-solist-sorted (onil _) = nils
lemma-solist-sorted (ocons x xs ys) = lemma-sorted++ (lemma-solist≤* xs) (lemma-solist*≤ ys) (lemma-solist-sorted xs) (lemma-solist-sorted ys)


module index where

-- natural numbers
--- additions
import Nats.Add.Assoc
  using (nat-add-assoc) -- associative law
import Nats.Add.Comm
  using (nat-add-comm) -- commutative law
import Nats.Add.Invert
  using (nat-add-invert) -- a + a == b + b implies a == b
  using (nat-add-invert-1) -- a + 1 == b + 1 implies a == b

--- multiplications
import Nats.Multiply.Comm
  using (nat-multiply-comm) -- commutative law
import Nats.Multiply.Distrib
  using (nat-multiply-distrib) -- distributive law
import Nats.Multiply.Assoc
  using (nat-multiply-assoc) -- associative law

-- integers
--- some properties
import Ints.Properties
  using (eq-int-to-nat) -- for natrual number a, + a == + a implis a == a
  using (eq-neg-int-to-nat) -- for natrual number a, - a == - a implis a == a
  using (eq-nat-to-int) -- for natrual number a, a == a implis + a == + a
  using (eq-neg-nat-to-int) -- for natrual number a, a == a implis - a == - a

--- additions
import Ints.Add.Comm
  using (int-add-comm) -- commutative law
import Ints.Add.Assoc
  using (int-add-assoc) -- associative law
import Ints.Add.Invert
  using (int-add-invert) -- a + a == b + b implis a == b

-- non-negative rationals
--- some properties
import Rationals.Properties
  -- if b is not zero, n times b div b is the original number
  using (times-div-id)

-- additions
import Rationals.Add.Comm
  using (rational-add-comm) -- commutative law
import Rationals.Add.Assoc
  using (rational-add-assoc) -- associative law

-- multiplications
import Rationals.Multiply.Comm
  using (rational-multiply-comm) -- commutative law

-- logics
--- the "and" relations
import Logics.And
  using (and-comm) -- commutative law
  using (and-assoc) -- associative law

--- the "or" relations
import Logics.Or
  using (or-comm) -- commutative law
  using (or-assoc) -- associative law
  using (or-elim) -- elimination rule

--- negations
import Logics.Not
  -- law that negative twice will make a positive
  using (not-not)
  using (contrapositive) -- contrapositive

-- vectors
--- reverse twice gives the original vector
import Vecs.Reverse
  using (vec-rev-rev-id)

-- lists
--- reverse twice gives the original vector
import Lists.Reverse
  using (list-rev-rev-id)

-- isomorphisms
--- natrual numbers and others
import Isos.NatLike
  using (iso-nat-vec) -- with vector
  using (iso-nat-list) -- with list

--- trees
import Isos.TreeLike
  using (iso-seven-tree-in-one) -- seven trees in one

-- groups
--- s3 group, xxx=e, yy=e, yx=xxy
import Groups.Symm.S3
  using (s3-property-1) -- given s3, prove xyx≡y


open import Relation.Binary.Core

module TreeSort.Impl2.Correctness.Order  {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_)  where

open import BBSTree _≤_
open import BBSTree.Properties _≤_ trans≤
open import Data.List
open import Function using (_∘_)
open import List.Sorted _≤_
open import TreeSort.Impl2 _≤_ tot≤

theorem-treeSort-sorted : (xs : List A) → Sorted (flatten (treeSort xs))
theorem-treeSort-sorted = lemma-bbst-sorted ∘ treeSort


{-# OPTIONS --copatterns #-}
module Copatterns where

open import Common.Equality

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B
open _×_

pair : {A B : Set} → A → B → A × B
fst (pair a b) = a
snd (pair a b) = b

swap : {A B : Set} → A × B → B × A
fst (swap p) = snd p
snd (swap p) = fst p

swap3 : {A B C : Set} → A × (B × C) → C × (B × A)
fst (swap3 t)       = snd (snd t)
fst (snd (swap3 t)) = fst (snd t)
snd (snd (swap3 t)) = fst t

-- should also work if we shuffle the clauses
swap4 : {A B C D : Set} → A × (B × (C × D)) → D × (C × (B × A))
fst (snd (swap4 t))       = fst (snd (snd t))
snd (snd (snd (swap4 t))) = fst t
fst (swap4 t)             = snd (snd (snd t))
fst (snd (snd (swap4 t))) = fst (snd t)

-- State monad example

record State (S A : Set) : Set where
  constructor state
  field
    runState : S → A × S
open State

record Monad (M : Set → Set) : Set1 where
  constructor monad
  field
    return : {A : Set}   → A → M A
    _>>=_  : {A B : Set} → M A → (A → M B) → M B
open Monad {{...}}

stateMonad : {S : Set} → Monad (State S)
runState (return {{stateMonad}} a  ) s  = a , s
runState (_>>=_  {{stateMonad}} m k) s₀ =
  let a , s₁ = runState m s₀
  in  runState (k a) s₁

leftId : {A B S : Set}(a : A)(k : A → State S B) → (return a >>= k) ≡ k a
leftId a k = refl

rightId : {A B S : Set}(m : State S A) → (m >>= return) ≡ m
rightId m = refl

assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →
   ((m >>= k) >>= l) ≡ (m >>= λ a → k a >>= l)
assoc m k l = refl

-- multiple clauses with abstractions

fswap3 : {A B C X : Set} → (X → A) × ((X → B) × C) → (X → C) × (X → (B × A))
fst (fswap3 t) x       = snd (snd t)
fst (snd (fswap3 t) y) = fst (snd t) y
snd (snd (fswap3 t) z) = fst t z


module Spire.Examples.Standard where

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

data ℕ : Set where
  zero : ℕ
  suc : (n : ℕ) → ℕ

data Vec (A : Set) : ℕ → Set where
  nil : Vec A zero
  cons : (n : ℕ) (a : A) (xs : Vec A n) → Vec A (suc n)

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

elimℕ : (P : ℕ → Set)
  (pzero : P zero)
  (psuc : (m : ℕ) → P m → P (suc m))
  (n : ℕ)
  → P n
elimℕ P pzero psuc zero = pzero
elimℕ P pzero psuc (suc n) = psuc n (elimℕ P pzero psuc n)

elimVec : (A : Set) (P : (n : ℕ) → Vec A n → Set)
  (pnil : P zero nil)
  (pcons : (n : ℕ) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons n a xs))
  (n : ℕ)
  (xs : Vec A n)
  → P n xs
elimVec A P pnil pcons .zero nil = pnil
elimVec A P pnil pcons .(suc n) (cons n a xs) = pcons n a xs (elimVec A P pnil pcons n xs)

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

module PatternMatching where

  add : ℕ → ℕ → ℕ
  add zero n = n
  add (suc m) n = suc (add m n)

  mult : ℕ → ℕ → ℕ
  mult zero n = zero
  mult (suc m) n = add n (mult m n)

  append : (A : Set) (m : ℕ) (xs : Vec A m) (n : ℕ) (ys : Vec A n) → Vec A (add m n)
  append A .zero nil n ys = ys
  append A .(suc m) (cons m x xs) n ys = cons (add m n) x (append A m xs n ys)

  concat : (A : Set) (m n : ℕ) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m .zero nil = nil
  concat A m .(suc n) (cons n xs xss) = append A m xs (mult n m) (concat A m n xss)

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

module Eliminator where

  add : ℕ → ℕ → ℕ
  add = elimℕ (λ _ → ℕ → ℕ)
    (λ n → n)
    (λ m ih n → suc (ih n))

  mult : ℕ → ℕ → ℕ
  mult = elimℕ (λ _ → ℕ → ℕ)
    (λ n → zero)
    (λ m ih n → add n (ih n))

  append : (A : Set) (m : ℕ) (xs : Vec A m) (n : ℕ) (ys : Vec A n) → Vec A (add m n)
  append A = elimVec A (λ m xs → (n : ℕ) (ys : Vec A n) → Vec A (add m n))
    (λ n ys → ys)
    (λ m x xs ih n ys → cons (add m n) x (ih n ys))

  concat : (A : Set) (m n : ℕ) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
    nil
    (λ n xs xss ih → append A m xs (mult n m) ih)

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


module Ag01 where

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

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

{-# BUILTIN NATURAL ℕ #-}

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

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

_ : 3 * 4 ≡ 12
_ = refl

_^_ : ℕ → ℕ → ℕ
m ^ 0       = 1
m ^ (suc n) = m * (m ^ n)

_ : 3 ^ 4 ≡ 81
_ = refl

_∸_ : ℕ → ℕ → ℕ
m ∸ zero = m
zero ∸ suc n = zero
suc m ∸ suc n = m ∸ n

infixl 6 _+_ _∸_
infixl 7 _*_

data Bin : Set where
  nil : Bin
  x0_ : Bin → Bin
  x1_ : Bin → Bin

inc : Bin → Bin
inc nil    = nil
inc (x1 b) = x0 (inc b)
inc (x0 b) = x1 b

_ : inc (x0 nil) ≡ (x1 nil)
_ = refl

_ : inc (x1 x1 x0 x1 nil) ≡ x0 x0 x1 x1 nil
_ = refl

to : ℕ → Bin
to zero = x0 nil
to (suc m) = inc (to m)

from : Bin → ℕ
from nil      = zero
from (x1 b)   = suc (2 * (from b))
from (x0 b)   = 2 * (from b)


{- --- 4. Lists --- -}

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

infixr 5 _∷_

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

{- 4.1 Length -}

length : {A : Set} → List A → ℕ
length [] = 0
length (x ∷ l) = 1 + (length l)

{- 4.2 List reversal -}

concat : {A : Set} → List A → List A → List A
concat [] l = l
concat (x ∷ k) l = x ∷ (concat k l)

concat-length : {A : Set} → (k l : List A) → length (concat k l) ≡ (length k) + (length l)
concat-length [] l = refl
concat-length (x ∷ k) l rewrite concat-length k l = refl

concat-assoc : {A : Set} → (j k l : List A) → concat (concat j k) l ≡ concat j (concat k l)
concat-assoc [] k l = refl
concat-assoc (x ∷ j) k l rewrite concat-assoc j k l = refl

{- 4.3 List reversal -}

snoc : {A : Set} → A -> List A → List A
snoc a [] = a ∷ []
snoc a (x ∷ l) = x ∷ (snoc a l)

rev : {A : Set} → List A → List A
rev [] = []
rev (x ∷ l) = snoc x (rev l)

snoc-length : {A : Set} → (a : A) → (l : List A) → length (snoc a l) ≡ suc (length l)
snoc-length a [] = refl
snoc-length a (x ∷ l) rewrite snoc-length a l = refl

rev-length : {A : Set} → (l : List A) → (length (rev l)) ≡ (length l)
rev-length [] = refl
rev-length (x ∷ l) rewrite snoc-length x (rev l) | rev-length l = refl

snoc-rev : {A : Set} → (a : A) → (l : List A) → rev (snoc a l) ≡ a ∷ (rev l)
snoc-rev a [] = refl
snoc-rev a (x ∷ l) rewrite snoc-rev a l = refl

double-rev : {A : Set} → (l : List A) → rev (rev l) ≡ l
double-rev [] = refl
double-rev (x ∷ l) rewrite snoc-rev x (rev l) | double-rev l = refl

{- 4.4 Filtering -}
open import Data.Bool

filter : {A : Set} → (p : A → Bool) → (l : List A) → List A
filter p [] = []
filter p (x ∷ l) with p x
filter p (x ∷ l) | false = filter p l
filter p (x ∷ l) | true = x ∷ (filter p l)

empty-list : {A : Set} → (l : List A) → filter (λ _ → false) l ≡ []
empty-list [] = refl
empty-list (x ∷ l) = empty-list l

identity-list : {A : Set} → (l : List A) → filter (λ _ → true) l ≡ l
identity-list [] = refl
identity-list (x ∷ l) rewrite identity-list l = refl


module z05-00-internal-verification where

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

{-
------------------------------------------------------------------------------
so far: EXTERNAL VERIFICATION
- written programs (e.g., 'length')
- proved properties (e.g., 'length-reverse')

This style of verification in type theory is called external verification
- proofs are external to programs
- proofs are distinct artifacts about some pre-existing programs

INTERNAL VERIFICATION

write functions with semantically expressive types
write datatypes that put restrictions on data
may require embedding proofs in code

------------------------------------------------------------------------------
-- p 99 VECTORS - length of vector included in type : vector is INDEXED by its length

-- vector.agda
-}
data 𝕍 {ℓ} (A : Set ℓ) : ℕ → Set ℓ where
  []   : 𝕍 A 0
  _::_ : {n : ℕ} (x : A) (xs : 𝕍 A n) → 𝕍 A (suc n)

-- compare to list (overloaded constructors OK)
data L {ℓ} (A : Set ℓ) :     Set ℓ where
  []   : L A
  _::_ :         (x : A) (xs : L A)   → L A

infixr 6 _::_ _++𝕍_

-- p 101

[_]𝕍 : ∀ {ℓ} {A : Set ℓ} → A → 𝕍 A 1
[ x ]𝕍 = x :: []

-- type level addition on length
_++𝕍_ : ∀ {ℓ} {A : Set ℓ}{n m : ℕ} → 𝕍 A n → 𝕍 A m → 𝕍 A (n + m)
[]        ++𝕍 ys = ys
(x :: xs) ++𝕍 ys = x :: xs ++𝕍 ys

-- p 102

-- no 'nil' list corner case
head𝕍 : ∀ {ℓ} {A : Set ℓ} {n : ℕ} → 𝕍 A (suc n) → A
head𝕍 (x :: _) = x

-- type level subtraction
tail𝕍 : ∀ {ℓ} {A : Set ℓ} {n : ℕ} → 𝕍 A n → 𝕍 A (pred n)
tail𝕍       []  = []
tail𝕍 (_ :: xs) = xs

-- p 103

-- length preserving (for lists, length preservation is separate proof)
map𝕍 : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {n : ℕ} → (A → B) → 𝕍 A n → 𝕍 B n
map𝕍 f       []  = []
map𝕍 f (x :: xs) = f x :: map𝕍 f xs

-- p 104

-- takes a vector of length m
-- each element is vector of length n
-- concats into single vector of length m * n
concat𝕍 : ∀{ℓ} {A : Set ℓ} {n m : ℕ} → 𝕍 (𝕍 A n) m → 𝕍 A (m * n)
concat𝕍       []  = []
concat𝕍 (x :: xs) = x ++𝕍 (concat𝕍 xs)

--  p 104

-- no need for maybe result as in lists by requiring n < m
nth𝕍 : ∀ {ℓ} {A : Set ℓ} {m : ℕ}
  → (n : ℕ)
  → n < m ≡ tt
  → 𝕍 A m
  → A
nth𝕍      0   _ (x :: _) = x
-- Proof p (that index is less than length of vector) reused in recursive call.
-- index is suc n
-- length of list is suc m, for implicit m
-- Agda implicitly introduces .m with suc .m
-- p proves suc n < suc m ≡ tt
-- def/eq to n < m ≡ tt
-- so p has correct type to make the recursive call
nth𝕍 (suc n)  p (_ :: xs) = nth𝕍 n p xs
-- us absurd pattern for the proof in last two cases
-- length of list is zero, so no index can be smaller than that length
-- must case-split on the index so Agda can the absurdity
-- because the definition of _<_ splits on both inputs
-- - returns ff separately for when the first input is is 0 and the second is 0
-- - and  for the first input being suc n and second is 0
nth𝕍 (suc n) ()       []
nth𝕍      0  ()       []

-- p 105

repeat𝕍 : ∀ {ℓ} {A : Set ℓ} → (a : A) (n : ℕ) → 𝕍 A n
repeat𝕍 a      0  = []
repeat𝕍 a (suc n) = a :: (repeat𝕍 a n)

{-
------------------------------------------------------------------------------
-- p 106 BRAUN TREES : balanced binary heaps

either empty or
node consisting of some data x and a left and a right subtree

data may be stored so that x is smaller than all data in left and right subtrees
if such an ordering property is desired

BRAUN TREE PROPERTY (BTP) : crucial property : sizes of left and right trees:

for each node in the tree
- either size (left) = size ( right ) or
         size (left) = size ( right ) + 1

ensures depth of the trees is ≤ log₂(N), where N is the number of nodes

property maintained (via types) during insert

make the type A and ordering on that type be parameters of the module

braun-tree.adga
-}

module braun-tree {ℓ} (A : Set ℓ) (_<A_ : A → A → 𝔹) where

  -- index n is size (number of elements of type A) of the tree
  data braun-tree : (n : ℕ) → Set ℓ where
    bt-empty : braun-tree 0
    bt-node : ∀ {n m : ℕ}
      → A
      → braun-tree n
      → braun-tree m
      → n ≡ m ∨ n ≡ suc m        -- 'v' defined in sum.agda for disjunction of two types
      → braun-tree (suc (n + m))

{- -- p 107
sum.agda

-- types A and B, possibly at different levels, accounted via ⊔ in return type
-- ⊔ part of Agda’s primitive level system : imported from Agda.Primitive module in level.agda
-- use this in code that intended to be run
data _⊎_ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') : Set (ℓ ⊔ ℓ') where
  inj₁ : (x : A) → A ⊎ B -- built from an A
  inj₂ : (y : B) → A ⊎ B -- built from an B

-- use this to represent a logical proposition
_∨_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
_∨_ = _⊎_

NO SEMANTIC DIFFERENCE - just different notation to help understanding code
-}

  {-
  --------------------------------------------------
  -- p 107-108 INSERTION
  -- this version keeps smaller (_<A_) elements closer to root when inserting
  -}

  -- type says given BT of size n, returns BT of size suc n
  bt-insert : ∀ {n : ℕ} → A → braun-tree n → braun-tree (suc n)

  -- insert into empty
  -- Create node with element and empty subtrees (both with size 0).
  -- 4th arg to BT constructor is BTP proof
  -- - both 0 so 'refl'
  -- - wrap in inj₁ to say 0 ≡ 0 (not n ≡ suc n)
  bt-insert a bt-empty = bt-node a bt-empty bt-empty (inj₁ refl)

  -- insert info non empty: tree has left and right satisfying BTP
  -- left of size n; right of size m
  -- p is BTP proof
  -- inferred type of return is BT (suc (suc (n + m)))
  -- because type before insert is BT (suc (n + m)) - left plus node element plus right
  -- insert adds ONE, so BT (suc (suc (m + n)))
  bt-insert a (bt-node{n}{m} a' l r p)
    -- regardless of what happens, left and right will be swapped, so size sum will have m first

    -- do rewrite before case splitting on which disjunct of BTP holds (n ≡ m or n ≡ suc m)
    -- does not change structure of tree
    -- will change what proof is used for BTP for new node returned.

    -- case split via WITH on P

    -- could split on p directly in pattern for input BT,
    -- but here rewrite is factored to be done once

    -- could do WITH on an if_then_else_ term, to put the min of element being inserted (a)
    -- and element at current root (a') as 1st component pair (a1), max as 2nd (a2)
    -- want min (a1) to be data at root of new BT
    -- want to insert max (a2) recursively into right
    rewrite +comm n m
    with p | if a <A a' then (a , a') else (a' , a)

  -- inj₁ case
  -- case where p is inj₁ for NEW new pattern variable 'p'
  -- underscore in place of original proof/p
  -- because considering case where original is 'inj₁ p'

  -- p : n ≡ m
  -- so new node
  -- with smaller element a1 at root and then swapped left and update right
  -- has type 'inj₂ refl'

  -- BTP for new node is suc m ≡ n v suc m ≡ suc n
  -- because size of new left is suc m, since it is the updated version of old right
  -- case has proof n ≡ m
  -- rewrite with that proof changes that to suc m ≡ suc n
  -- 'inj 2 refl' proves it
  bt-insert a (bt-node{n}{m} a' l r _) | inj₁ p | (a1 , a2)
    rewrite p = (bt-node a1 (bt-insert a2 r) l (inj₂ refl))

  -- inj₂ case : n ≡ suc m
  -- so need proof suc m ≡ n v suc m ≡ suc n
  -- 'sym p' gives 'suc m ≡ n'
  -- wrap in 'inj₁'
  bt-insert a (bt-node{n}{m} a' l r _) | inj₂ p | (a1 , a2) =
                (bt-node a1 (bt-insert a2 r) l (inj₁ (sym p)))

  {-
  --------------------------------------------------
  -- p 110 REMOVE MIN ELEMENT
  -}

  -- input has at least one element; returns pair of element and a BT one smaller
  bt-remove-min : ∀ {p : ℕ} → braun-tree (suc p) → A × braun-tree p

  -- no need for case of empty input
  -- because size would be 0, but input is 'suc p'

  -- removing sole node; return data and bt-empty
  bt-remove-min (bt-node a bt-empty bt-empty u) = a , bt-empty

  -- next two equations for left is empty and right subtree is a node -- IMPOSSIBLE by BTP
  -- still need to handle both proves with absurd
  bt-remove-min (bt-node a bt-empty (bt-node _ _ _ _) (inj₁ ()))
  bt-remove-min (bt-node a bt-empty (bt-node _ _ _ _) (inj₂ ()))

  -- right empty, left node (implies left size is 1, but not needed)
  -- return data left
  -- need to confirm size relationships satisfied, because
  -- size of input  is suc (suc (n’ + m’) + 0)
  -- size of output is      suc (n’ + m’)
  -- use +0 to drop the '+ 0'
  bt-remove-min (bt-node a (bt-node{n’}{m’} a’ l’ r’ u’) bt-empty u)
    rewrite +0 (n’ + m’) = a , bt-node a’ l’ r’ u’

  -- left and right of input both nodes (not empty)
  -- return data input (the min data)
  -- reassemble output BT: remove min from left:
  bt-remove-min (bt-node a (bt-node a1 l1 r1 u1) (bt-node a2 l2 r2 u2) u)
    with bt-remove-min (bt-node a1 l1 r1 u1)
  -- then match on result of recursive call to bt-remove-min.
  -- produces min a1’ of left and updated left l’
  -- then WITH to pick smaller of a1’ (minimum of left) and a2, minimum of right
  -- similar to the bt-insert with an if_then_else_ term.
  bt-remove-min (bt-node a (bt-node a1 l1 r1 u1) (bt-node a2 l2 r2 u2) u) | a1’ , l’
    with if a1’ <A a2 then (a1’ , a2) else (a2 , a1’)

  -- p 113 first words TODO
  bt-remove-min (bt-node a (bt-node{n1}{m1} a1 l1 r1 u1) (bt-node{n2}{m2} _ l2 r2 u2) u)
    | _ , l’ | smaller , other
    rewrite +suc  (n1 + m1) (n2 + m2) |
            +comm (n1 + m1) (n2 + m2) = a , bt-node smaller (bt-node other l2 r2 u2) l’ (lem u)
    where lem : ∀ {x y}
              → suc x ≡ y ∨ suc x ≡ suc y
              →     y ≡ x ∨     y ≡ suc x
          lem (inj₁ p) = inj₂ (sym          p)
          lem (inj₂ p) = inj₁ (sym (suc-inj p))

{-
------------------------------------------------------------------------------
-- p 114 Sigma Types

Above expresses invariant properties of data using internally verified datatypes.

Any data constructed via the constructors are guaranteed to satisfy the property,
due to restrictions enforced by the constructors.

Different case: state that a property holds of an existing data type.

done using Σ-types (“sigma”)

similar to Cartesian product type A × B (elements of A × B are pairs (a, b))
- but generalization where type of 2nd element can depend on type of 1st
- aka "dependent product type" (though the notation comes from sum types, see below)

see nat-nonzero.agda : type for nonzero natural numbers:

-- a nat 'n' AND a proof 'iszero n ≡ ff'
ℕ⁺ : Set
ℕ⁺ = Σ ℕ (λ n → iszero n ≡ ff)

conceptually similar to Cartesian product : N × (iszero n ≡ ff)
- pair of number and equality proof
- in Cartesian product version, 'n' is free
- Σ-types enable referring to 1st of pair

see product.agda : def of Σ

parametrized by
- type A
- function B
  - input : type A
  - returns a type
- types can be at different levels
- Like sum types, Σ type is then at level ℓ ⊔ ℓ' (least upper bound of the two levels)
data Σ {ℓ ℓ'} (A : Set ℓ) (B : A → Set ℓ') : Set (ℓ ⊔ ℓ') where
  _,_ : (a : A) → (b : B a) → Σ A B
                         ^
               B depends on

------------------------------------------------------------------------------
-- p 115 example: addition on nonzero nats
-}

open import nat-nonzero hiding (_+⁺_)

_+⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(zero         , ()) +⁺ n2 -- cannot happen, so uses absurd pattern
(1            , p1) +⁺ y = suc⁺ y
(suc (suc n1) , p1) +⁺ y = suc⁺ ((suc n1 , refl) +⁺ y) -- recursive call

{-
-- p 115 5.3.1 Why Sigma and Pi?

why Σ symbol for type of dependent pairs?
- because Σ-types generalize disjoint unions
- in math, a disjoint union is union of two sets
  - where elements are tagged to indicate from which set they have come
  - cardinality of A ⊎ B, is sum of cardinalities of A and B
    even if they have a nonempty intersection.
- This is where we get the notation for sum types in Figure 5.2.
- The disjoint union can be defined mathematically as
    ({0} × A) ∪ ({1} × B)
  - each element of union looks like (n, x)
    where if the tag n is 0, then x P A, and
          if         n is 1, then x P B.

------------------------------------------------------------------------------
-- p 116 Binary Search Trees

for some type A and an ordering relation on that type
values in left  subtree always ≤ value at node ℕ
values in right subtree always > value at node ℕ

see z05-01-bst-test.agda
    z05-01-bst.agda

-- p 117-120
TODO : read/understand discussion of
       bool-relations.agda
       relations.agda

------------------------------------------------------------------------------
-- p 123 Internal vs. External Verification

internal verification : datatypes defined with invariants; functions take proofs of preconditions
- Datatypes with essential invariants : enforce via internal
- Complex programs
  - doing external of complex will cause reasoning about complexity
    not relevant to property being proved
  - internal weaves proofs thru code and datatype

external verification : theorems about functions proved separately
- Algebraic Properties e.g., proving associativity
- Functions used in an internal verification's specification
  -- e.g., min/max used in bst - need to externally prove properties about min/max

------------------------------------------------------------------------------
-- p 126 Exercises

1. Nested vector type.
   Fill in the hole to define a type for matrices of nats
   where the type lists the dimensions of the matrix:
-}

-- inner vector is a row
_by_matrix : ℕ → ℕ → Set
rows by cols matrix = 𝕍 (𝕍 ℕ cols) rows

matrix-to-vec-vec : ∀ {rows cols : ℕ} → rows by cols matrix → 𝕍 (𝕍 ℕ cols) rows
matrix-to-vec-vec 𝕞 = 𝕞

-- 2a
zero-matrix : (rows cols : ℕ) → rows by cols matrix
zero-matrix rows cols = repeat𝕍 (repeat𝕍 0 cols) rows

_ : zero-matrix 2 3 ≡ (0 :: 0 :: 0 :: []) ::
                      (0 :: 0 :: 0 :: []) :: []
_ = refl

_ : zero-matrix 0 0 ≡ []
_ = refl
_ : zero-matrix 0 1 ≡ []
_ = refl
_ : zero-matrix 1 0 ≡ [] :: []
_ = refl
_ : zero-matrix 1 1 ≡ (0 :: []) :: []
_ = refl

-- 2b
matrix-elt : ∀ {rows cols : ℕ}
  → rows by cols matrix
  → (r : ℕ)
  → (c : ℕ)
  → r < rows ≡ tt
  → c < cols ≡ tt
  → ℕ
matrix-elt 𝕞 r c r<rows c<cols = nth𝕍 c c<cols (nth𝕍 r r<rows (matrix-to-vec-vec 𝕞))

-- 2c
diagonal-matrix : ℕ → (n : ℕ) → n by n matrix
diagonal-matrix d n = mkRows n n n
 where
  -- when constructing rows/cols
  -- - row/col param corresponds to row/col - rows/cols
  -- - e.g., for 2 x 3 matrix
  --   row param 2 corresponds 2 - 2 = 0

  mkElt  : ℕ → ℕ → ℕ
  mkElt i col = if i =ℕ col then d else zero

  mkCols : (ℕ → ℕ) → (cols : ℕ) → 𝕍 ℕ cols
  mkCols _     zero   = []
  mkCols f sc@(suc c) = f sc :: mkCols f c

  mkRows : ℕ → (rows : ℕ) → (cols : ℕ) → 𝕍 (𝕍 ℕ cols) rows
  mkRows _  zero   _ = []
  mkRows i (suc r) c = mkCols (mkElt i) c :: mkRows (i ∸ 1) r c

identity-matrix : (n : ℕ) → n by n matrix
identity-matrix = diagonal-matrix 1

idm5 : 5 by 5 matrix
idm5 = identity-matrix 5

_ : idm5 ≡ (1 :: 0 :: 0 :: 0 :: 0 :: []) ::
           (0 :: 1 :: 0 :: 0 :: 0 :: []) ::
           (0 :: 0 :: 1 :: 0 :: 0 :: []) ::
           (0 :: 0 :: 0 :: 1 :: 0 :: []) ::
           (0 :: 0 :: 0 :: 0 :: 1 :: []) :: []
_ = refl

_ : matrix-elt idm5 0 0 refl refl ≡ 1
_ = refl
_ : matrix-elt idm5 1 1 refl refl ≡ 1
_ = refl
_ : matrix-elt idm5 0 1 refl refl ≡ 0
_ = refl

-- 2d
-- BEGIN https://typeslogicscats.gitlab.io/posts/agda-matrix.lagda.html
prepend-column
  : ∀ {m n : ℕ}
  → 𝕍 ℕ n                    -- a column
  → n by     m matrix
  → n by suc m matrix        -- prepends the given column to the matrix
prepend-column      []           []  = []
prepend-column (x :: xs) (vec :: vecs) = (x :: vec) :: (prepend-column xs vecs)

-- inverse of prepend-column (NOT USED)
unprepend-column
  : ∀ {m n : ℕ}
  →            n by suc m matrix
  → (𝕍 ℕ n) × (n by     m matrix)
unprepend-column                     [] = ([] , [])
unprepend-column ((x :: vec) :: matrix) = let xs-vecs = unprepend-column matrix
                                in x :: fst xs-vecs , vec :: snd xs-vecs

fill-empty : (n : ℕ) → n by 0 matrix
fill-empty       0 = []
fill-empty (suc n) = [] :: fill-empty n

transpose : ∀ {i : ℕ} {j : ℕ} → i by j matrix → j by i matrix
transpose     {0} {j}           []  = fill-empty j
transpose {suc _} {_} (row :: rows) = prepend-column row (transpose rows)
-- END https://typeslogicscats.gitlab.io/posts/agda-matrix.lagda.html

ex2x3 : 2 by 3 matrix
ex2x3 = (1 :: 2 :: 3 :: []) ::
        (0 :: 6 :: 7 :: []) :: []

_ : transpose ex2x3 ≡ (1 :: 0 :: []) ::
                      (2 :: 6 :: []) ::
                      (3 :: 7 :: []) :: []
_ = refl

-- BEGIN https://www.cs.nott.ac.uk/~psztxa/g53cfr/solutions/ex02.agda
vreturn : {A : Set} {n : ℕ} → A → 𝕍 A n
vreturn {n = zero}  a = []
vreturn {n = suc m} a = a :: vreturn {n = m} a

vapp : {A B : Set} {n : ℕ} → 𝕍 (A → B) n → 𝕍 A n → 𝕍 B n
vapp      []       []  = []
vapp (f :: fs) (a :: as) = f a :: vapp fs as

transposeX : {m n : ℕ} → m by n matrix → n by m matrix
transposeX         []  = vreturn []
transposeX (as :: ass) = vapp (vapp (vreturn _::_ ) as) (transposeX ass)

_ : transposeX ex2x3 ≡ (1 :: 0 :: []) ::
                       (2 :: 6 :: []) ::
                       (3 :: 7 :: []) :: []
_ = refl
-- END https://www.cs.nott.ac.uk/~psztxa/g53cfr/solutions/ex02.agda

-- BEGIN HORRIBLE HACKY TRY
postulate
  yyy : (n : ℕ) → (rc : ℕ) → rc < n ≡ tt

xx : ∀ {x y : ℕ}
   → x =ℕ 0 ≡ ff
   → y =ℕ 0 ≡ ff
   → x ∸ y < x ≡ tt
xx {x} {suc y} x≠0 y≠0
  rewrite ∸< {x} {y} x≠0
  = refl

transpose' : ∀ {n m : ℕ} → n by m matrix → m by n matrix
transpose'             {0}       {m} _ = zero-matrix m 0
transpose'             {1}       {m} _ = zero-matrix m 1
transpose' n@{suc (suc _)}    {zero} 𝕞 = zero-matrix zero n
transpose' n@{suc (suc _)} m@{suc _} 𝕞 = mkRows m n
 where
  mkElt : (newRow : ℕ)
        → newRow =ℕ 0 ≡ ff
        → (newCol : ℕ)
        → newCol =ℕ 0 ≡ ff
        → ℕ
  mkElt newRow rp newCol cp =
    matrix-elt 𝕞 (n ∸ newCol)         (m ∸ newRow)
--                 (xx cp refl) (xx rp refl)
--              (yyy (n ∸ newCol) n) (yyy (m ∸ newRow) m)
                    {!!} {!!}

  mkCols : (∀ (new : ℕ) → new =ℕ 0 ≡ ff → ℕ) → (cols : ℕ) → 𝕍 ℕ cols
  mkCols _     zero   = []
  mkCols f sc@(suc c) = f sc refl :: mkCols f c

  mkRows : (rows : ℕ) → (cols : ℕ) → 𝕍 (𝕍 ℕ cols) rows
  mkRows     zero   _ = []
  mkRows sr@(suc r) c = mkCols (mkElt sr refl) c :: mkRows r c

_ : transpose' ex2x3 ≡ (1 :: 0 :: []) ::
                       (2 :: 6 :: []) ::
                       (3 :: 7 :: []) :: []
_ = refl
-- END HORRIBLE HACKY TRY

-- 2e
dotProduct𝕍 : ∀ {n : ℕ} → 𝕍 ℕ n → 𝕍 ℕ n → ℕ
dotProduct𝕍       []        []  = 0
dotProduct𝕍 (a :: as) (b :: bs) = a * b + (dotProduct𝕍 as bs)

_ : dotProduct𝕍 (1 :: 3 :: 5 :: []) (4 :: 2 :: 1 :: []) ≡ 15
_ = refl

foldr : ∀ {A B : Set} {n : ℕ} → (A → B → B) → B → 𝕍 A n → B
foldr f z       []  = z
foldr f z (x :: xs) = f x (foldr f z xs)

zipWith : ∀ {A B C : Set} {n : ℕ} → (A → B → C) → 𝕍 A n → 𝕍 B n → 𝕍 C n
zipWith _       []        []  = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

dotProduct𝕍' : ∀ {n : ℕ} → 𝕍 ℕ n → 𝕍 ℕ n → ℕ
dotProduct𝕍' as bs = foldr _+_ 0 (zipWith _*_ as bs)

_ : dotProduct𝕍' (1 :: 3 :: 5 :: []) (4 :: 2 :: 1 :: []) ≡ 15
_ = refl

-- 2f
matrix-* : ∀ {m n p : ℕ} → m by n matrix → n by p matrix → m by p matrix
matrix-* [] _ = []
matrix-* {m} {n} {p} (a :: as) bs =
  doRow {n} {p} a (transpose bs) :: matrix-* as bs
 where
  doRow : ∀ {n p : ℕ} → 𝕍 ℕ n → p by n matrix → 𝕍 ℕ p
  doRow a [] = []
  doRow {n} {p} a (b :: bs) = dotProduct𝕍 a b :: doRow a bs

ma : 2 by 3 matrix
ma = (2 :: 3 :: 4 :: []) ::
     (1 :: 0 :: 0 :: []) :: []
mb : 3 by 2 matrix
mb = (0 :: 1000 :: []) ::
     (1 ::  100 :: []) ::
     (0 ::   10 :: []) :: []

_ : matrix-* ma mb ≡ (3 :: 2340 :: []) ::
                     (0 :: 1000 :: []) :: []
_ = refl

identity-2 : 2 by 2 matrix
identity-2 = identity-matrix 2

some-mat : 2 by 2 matrix
some-mat =
  (1 :: 2 :: []) ::
  (3 :: 4 :: []) :: []

some-mat-trans : 2 by 2 matrix
some-mat-trans =
  (1 :: 3 :: []) ::
  (2 :: 4 :: []) :: []

_ : matrix-* some-mat identity-2 ≡ some-mat
_ = refl

_ : transpose some-mat ≡ some-mat-trans
_ = refl

left-mat : 2 by 3 matrix
left-mat =
  (1 :: 2 :: 3 :: []) ::
  (4 :: 5 :: 6 :: []) :: []

right-mat : 3 by 2 matrix
right-mat =
  ( 7 ::  8 :: []) ::
  ( 9 :: 10 :: []) ::
  (11 :: 12 :: []) :: []

product : 2 by 2 matrix
product =
  ( 58 ::  64 :: []) ::
  (139 :: 154 :: []) :: []

_ : matrix-* left-mat right-mat ≡ product
_ = refl

-- TODO https://www.cs.nott.ac.uk/~psztxa/g53cfr/solutions/ex02.agda

-- 3
-- from list.agda
data 𝕃 {ℓ} (A : Set ℓ) : Set ℓ where
  [] : 𝕃 A
  _::_ : (x : A) (xs : 𝕃 A) → 𝕃 A

-- from vector.agda
𝕍-to-𝕃 : ∀ {ℓ} {A : Set ℓ} {n : ℕ} → 𝕍 A n → 𝕃 A
𝕍-to-𝕃 [] = []
𝕍-to-𝕃 (x :: xs) = x :: (𝕍-to-𝕃 xs)

𝕃-to-𝕍 : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → Σ ℕ (λ n → 𝕍 A n)
𝕃-to-𝕍 [] = (0 , [])
𝕃-to-𝕍 (x :: xs) with 𝕃-to-𝕍 xs
... | (n , v) = (suc n , x :: v)

e3 : ∀ {ℓ} {A : Set ℓ} {n : ℕ}
   → (v : 𝕍 A n)
   → 𝕃-to-𝕍 (𝕍-to-𝕃 v) ≡ n , v
e3       [] = refl
e3 (x :: v) with e3 v
... | zz rewrite zz = refl

-- 4. fun takes V (A × B) n ; returns pair V A n and V B n
--    similar to Haskell unzip
unzip : ∀ {ℓ} {A B : Set ℓ} {n : ℕ}
      → 𝕍 (A × B) n
      → 𝕍 A n × 𝕍 B n
unzip       [] = [] , []
unzip ((a , b) :: v) =
  let rest = unzip v
   in a :: fst rest , b :: snd rest

_ : unzip ((1 , 10) :: (2 , 20) :: (3 , 30) :: []) ≡   ( 1 ::  2 ::  3 :: [])
                                                     , (10 :: 20 :: 30 :: [])
_ = refl

{- TODO
-- 5. Implement remove-min / remove-max functions for bst. type.
Using remove-min, define a general remove function
- finds first value isomorphic to given one
- returns bst without that value.
If node holding that value has two (non-leaf) nodes as left and right sub-trees,
then necessary to replace the removed element with its successor.
This is the minimum value in the right subtree.

-- 6. In list-merge-sort.agda : merge-sort using Braun trees.
State and prove theorems about merge-sort.
E.g., prove length of input list and length of returned sorted list are the same.
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Greatest Common Divisor for integers
------------------------------------------------------------------------

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

module Data.Integer.GCD where

open import Data.Integer.Base
open import Data.Integer.Divisibility
open import Data.Integer.Properties
open import Data.Nat.Base
import Data.Nat.GCD as ℕ
open import Relation.Binary.PropositionalEquality

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

gcd : ℤ → ℤ → ℤ
gcd i j = + ℕ.gcd ∣ i ∣ ∣ j ∣

------------------------------------------------------------------------
-- Properties
------------------------------------------------------------------------

gcd[i,j]∣i : ∀ i j → gcd i j ∣ i
gcd[i,j]∣i i j = ℕ.gcd[m,n]∣m ∣ i ∣ ∣ j ∣

gcd[i,j]∣j : ∀ i j → gcd i j ∣ j
gcd[i,j]∣j i j = ℕ.gcd[m,n]∣n ∣ i ∣ ∣ j ∣

gcd-greatest : ∀ {i j c} → c ∣ i → c ∣ j → c ∣ gcd i j
gcd-greatest c∣i c∣j = ℕ.gcd-greatest c∣i c∣j

gcd[0,0]≡0 : gcd 0ℤ 0ℤ ≡ 0ℤ
gcd[0,0]≡0 = cong (+_) ℕ.gcd[0,0]≡0

gcd[i,j]≡0⇒i≡0 : ∀ i j → gcd i j ≡ 0ℤ → i ≡ 0ℤ
gcd[i,j]≡0⇒i≡0 i j eq = ∣n∣≡0⇒n≡0 (ℕ.gcd[m,n]≡0⇒m≡0 (+-injective eq))

gcd[i,j]≡0⇒j≡0 : ∀ {i j} → gcd i j ≡ 0ℤ → j ≡ 0ℤ
gcd[i,j]≡0⇒j≡0 {i} eq = ∣n∣≡0⇒n≡0 (ℕ.gcd[m,n]≡0⇒n≡0 ∣ i ∣ (+-injective eq))

gcd-comm : ∀ i j → gcd i j ≡ gcd j i
gcd-comm i j = cong (+_) (ℕ.gcd-comm ∣ i ∣ ∣ j ∣)


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

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

arith-sum : ℕ → ℕ
arith-sum zero = zero
arith-sum (suc n) = suc n + arith-sum n

arith-formula : ℕ → ℕ
arith-formula n = ⌊ n * (n + 1) /2⌋

silly : ∀ (n m : ℕ) →  ⌊ n + n + m * (m + 1) /2⌋ ≡ n +  ⌊ m * (m + 1) /2⌋
silly zero m = refl
silly (suc n) m rewrite +-suc n n = cong suc (silly n m)

lemma : ∀ (n : ℕ) →  ⌊ suc n * (suc n + 1) /2⌋ ≡ suc n +  ⌊ n * (n + 1) /2⌋
lemma n rewrite *-comm n (suc n + 1) | +-assoc n 1 (n + (n + 1) * n) | *-comm (n + 1) n | +-comm n (suc (n + n * (n + 1)))
                                     | +-assoc n (n * (n + 1)) n | +-comm (n * (n + 1)) n | sym (silly n n) | +-assoc n n (n * (n + 1)) = refl

arith-eq : (n : ℕ) -> arith-formula n ≡ arith-sum n
arith-eq zero = refl
arith-eq (suc n) rewrite lemma n =  cong (_+_ (suc n)) (arith-eq n)


-- Length-indexed lists as a recursive family
-- From "Dependent Types at Work", section 3.1

module xx where

open import Level renaming (suc to lsuc)
open import Data.Nat hiding (_^_)
open import Data.Empty.Polymorphic
open import Data.Unit.Polymorphic
open import Data.Maybe hiding (map ; zip)
open import Data.Product hiding (map ; zip)

private
  variable
    m n : ℕ
    ℓ ℓ′ : Level
    A : Set ℓ
    B : Set ℓ′

-- Vec : Set ℓ → ℕ → Set ℓ
-- Vec A zero = ⊤
-- Vec A (suc n) = A × Vec A n

-- Generalize Vec

open import Function

iter : A → (A → A) → ℕ → A
iter z f zero    = z
iter z f (suc n) = f (iter z f n)

-- Is iter defined somewhere standard?

Vec : Set ℓ → ℕ → Set ℓ
Vec A = iter ⊤ (A ×_)

head : Vec A (suc n) → A
head (a , _) = a

tail : Vec A (suc n) → Vec A n
tail (_ , as) = as

map : (A → B) → Vec A n → Vec B n
map {n = zero } _ _ = tt
map {n = suc n} f (a , as) = f a , map {n = n} f as

zip : Vec A n → Vec B n → Vec (A × B) n
zip {n = zero } _ _ = tt
zip {n = suc n} (a , as) (b , bs) = (a , b) , zip {n = n} as bs

Fin : ℕ → Set
Fin zero    = ⊥
Fin (suc n) = Maybe (Fin n)

f5 : Fin 5
f5 = nothing
f4 : Fin 4
f4 = nothing
f3 : Fin 3
f3 = nothing
f2 : Fin 2
f2 = just nothing -- an element of the type
f1 : Fin 1
f1 = nothing
-- f0 : Fin 0
-- f0 = {!!} -- no solution found

_!_ : Vec A n → Fin n → A
_!_ {n = suc m} (a , _ ) nothing = a
_!_ {n = suc m} (_ , as) (just i) = as ! i

_!'_ : Vec A n → Fin n → A
_!'_ {n = suc m} (a , _)   nothing    = a
_!'_ {n = suc m} (_ , as) (just finm) = as !' finm

{-
(0 , 1 , 2 , tt) !                  nothing
(0 , 1 , 2 , tt) !             just nothing
(0 , 1 , 2 , tt) !       just (just nothing)
(0 , 1 , 2 , tt) ! just (just (just nothing))
-}

-- Perfect binary leaf tree
BTree : Set ℓ → ℕ → Set ℓ
BTree A = iter A (λ τ → τ × τ)


module List.Sorted  {A : Set}(_≤_ : A → A → Set) where

open import Data.List

data Sorted :  List A → Set where
  nils : Sorted []
  singls : (x : A)
                   → Sorted [ x ]
  conss : {x y : A}{xs : List A}
                   → x ≤ y
                   → Sorted (y ∷ xs)
                   → Sorted (x ∷ y ∷ xs)


------------------------------------------------------------------------------
-- Common (interactive and automatic) properties using the induction principle
------------------------------------------------------------------------------

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

module PA.Inductive.PropertiesByInduction where

open import PA.Inductive.Base

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

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

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

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = refl

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity n = ℕ-ind A A0 is n
  where
  A : ℕ → Set
  A i = i + zero ≡ i

  A0 : A zero
  A0 = refl

  is : ∀ i → A i → A (succ i)
  is i ih = succCong ih

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc m n o = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≡ i + (n + o)

  A0 : A zero
  A0 = refl

  is : ∀ i → A i → A (succ i)
  is i ih = succCong ih

x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] m n = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + succ n ≡ succ (i + n)

  A0 : A zero
  A0 = refl

  is : ∀ i → A i → A (succ i)
  is i ih = succCong ih


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

{-# BUILTIN NATURAL ℕ #-}

_+_ : ℕ → ℕ → ℕ
zero + b = b
suc a + b = suc (a + b)
infix 100 _+_

data _≡_ : ℕ → ℕ → Set where
  refl : {n : ℕ} → n ≡ n

sym : {n m : ℕ} → n ≡ m → m ≡ n
sym refl = refl

trans : {m n o : ℕ} → m ≡ n → n ≡ o → m ≡ o
trans refl p₂ = p₂

suc-inj : {m n : ℕ} → suc m ≡ suc n → m ≡ n
suc-inj refl = refl

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥

_≢_ : ℕ → ℕ → Set
m ≢ n = ¬(m ≡ n)

zero-img : ∀ {m} → suc m ≢ 0
zero-img ()

induction : (P : ℕ → Set) → P 0 → (∀ {n} → P n → P (suc n)) → (∀ m → P m)
induction pred base hypo zero = base
induction pred base hypo (suc m) = hypo (induction pred base hypo m)

cong : ∀ {m n} → (f : ℕ → ℕ) → m ≡ n → f m ≡ f n
cong f refl = refl

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

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

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

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

-- Where to go from here?
-- Agda:
--   • Aaron Stump - Verified Functional Programming in Agda, https://svn.divms.uiowa.edu/repos/clc/projects/agda/book/book.pdf
--   • Conor McBride - Dependently Typed Metaprogramming (in Agda), http://cs.ioc.ee/ewscs/2014/mcbride/mcbride-deptypedmetaprog.pdf
-- Type theory:
--   • So you want to learn type theory, http://purelytheoretical.com/sywtltt.html


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

open import Level
open import Categories.Category
open import Categories.Monad

module Categories.Monad.Morphism {o ℓ e} {C D : Category o ℓ e} where

open import Categories.NaturalTransformation
open import Categories.Functor

open NaturalTransformation

-- monad morphism in the sense of the nLab
-- https://ncatlab.org/nlab/show/monad#the_bicategory_of_monads
-- between generic monads t : a -> a & s : b -> b
record Monad⇒ (M : Monad C) (N : Monad D) : Set (o ⊔ ℓ ⊔ e) where

  private
    module M = Monad M
    module N = Monad N

  open module D = Category D using (_∘_; _≈_)

  field
    X : Functor C D
    α : NaturalTransformation (N.F ∘F X) (X ∘F M.F)

  module X = Functor X
  module α = NaturalTransformation α

  field
    unit-comp : ∀ {U} → α.η U ∘ (N.η.η (X.₀ U)) ≈ X.₁ (M.η.η U)
    mult-comp : ∀ {U} → α.η U ∘ (N.μ.η (X.₀ U)) ≈ X.₁ (M.μ.η U) ∘ α.η (M.F.₀ U) ∘ N.F.₁ (α.η U)

-- monad morphism in a different sense:
-- monads are on the same category, X is the identity
record Monad⇒-id (M N : Monad C) : Set (o ⊔ ℓ ⊔ e) where

  private
    module M = Monad M
    module N = Monad N

  field
    α : NaturalTransformation N.F M.F

  module α = NaturalTransformation α

  open module C = Category C using (_∘_; _≈_)

  field
    unit-comp : ∀ {U} → α.η U ∘ N.η.η U ≈ M.η.η U
    mult-comp : ∀ {U} → α.η U ∘ (N.μ.η U) ≈ M.μ.η U ∘ α.η (M.F.₀ U) ∘ N.F.₁ (α.η U)

-- monad 2-cell in the sense of https://ncatlab.org/nlab/show/monad#the_bicategory_of_monads
record Monad²⇒ {M : Monad C} {N : Monad D} (Γ Δ : Monad⇒ M N) : Set (o ⊔ ℓ ⊔ e) where

  private
    module M = Monad M
    module N = Monad N
    module Γ = Monad⇒ Γ
    module Δ = Monad⇒ Δ

  field
    m : NaturalTransformation Γ.X Δ.X

  module m = NaturalTransformation m

  open module D = Category D using (_∘_; _≈_)

  field
    comm : ∀ {U} → Δ.α.η U ∘ N.F.₁ (m.η U) ≈ m.η (M.F.₀ U) ∘ Γ.α.η U


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some examples showing where the natural numbers and some related
-- operations and properties are defined, and how they can be used
------------------------------------------------------------------------

module README.Nat where

-- The natural numbers and various arithmetic operations are defined
-- in Data.Nat.

open import Data.Nat

ex₁ : ℕ
ex₁ = 1 + 3

-- Propositional equality and some related properties can be found
-- in Relation.Binary.PropositionalEquality.

open import Relation.Binary.PropositionalEquality

ex₂ : 3 + 5 ≡ 2 * 4
ex₂ = refl

-- Data.Nat.Properties contains a number of properties about natural
-- numbers. Algebra defines what a commutative semiring is, among
-- other things.

open import Algebra
import Data.Nat.Properties as Nat
private
  module CS = CommutativeSemiring Nat.commutativeSemiring

ex₃ : ∀ m n → m * n ≡ n * m
ex₃ m n = CS.*-comm m n

-- The module ≡-Reasoning in Relation.Binary.PropositionalEquality
-- provides some combinators for equational reasoning.

open ≡-Reasoning
open import Data.Product

ex₄ : ∀ m n → m * (n + 0) ≡ n * m
ex₄ m n = begin
  m * (n + 0)  ≡⟨ cong (_*_ m) (proj₂ CS.+-identity n) ⟩
  m * n        ≡⟨ CS.*-comm m n ⟩
  n * m        ∎

-- The module SemiringSolver in Data.Nat.Properties contains a solver
-- for natural number equalities involving variables, constants, _+_
-- and _*_.

open Nat.SemiringSolver

ex₅ : ∀ m n → m * (n + 0) ≡ n * m
ex₅ = solve 2 (λ m n → m :* (n :+ con 0)  :=  n :* m) refl


module x02induction where

-- prove properties of inductive naturals and operations on them via induction

import      Relation.Binary.PropositionalEquality as Eq
open        Eq             using (_≡_; refl; cong; sym)
open        Eq.≡-Reasoning using (begin_; _≡⟨⟩_; step-≡; _∎)
open import Data.Nat       using (ℕ; zero; suc; _+_; _*_; _∸_; _^_)

{-
------------------------------------------------------------------------------
## Properties of operators : identity, associativity, commutativity, distributivity

* _Identity_.   left/right/both; sometimes called _unit_

* _Associativity_.   e.g., `(m + n) + p ≡ m + (n + p)`

* _Commutativity_.   e.g., `m + n ≡ n + m`

* _Distributivity_.  e.g., from the left  `(m + n) * p ≡ (m * p) + (n * p)`
                           from the right `m * (p + q) ≡ (m * p) + (m * q)`

#### Exercise `operators` (practice) {name=operators} TODO : ops with different properties - no proofs

pair of operators
- have an identity
- are associative, commutative, and distribute over one another
(do not prove)

operator
- has identity
- is associative
- not commutative
(do not prove)
-}

{-
HC not associative; right identity
-}
_ =
  begin
    (3 ∸ 1) ∸ 1 ∸ 0 ≡⟨⟩
     2      ∸ 1 ∸ 0 ≡⟨⟩
     1          ∸ 0 ≡⟨⟩
     1          ∸ 0
  ∎
{-
------------------------------------------------------------------------------
## ASSOCIATIVITY of ADDITION : (m + n) + p ≡ m + (n + p)
-}

_ : (3 + 4) + 5 ≡ 3 + (4 + 5)
_ =
  begin
    (3 +  4) + 5  ≡⟨⟩
     7       + 5  ≡⟨⟩
    12            ≡⟨⟩
     3 +  9       ≡⟨⟩
     3 + (4  + 5)
  ∎

{-
useful to read chains like above
- from top down  until reaching simplest term (i.e., `12`)
- from bottom up until reaching the same term

Why should `7 + 5` be the same as `3 + 9`?
Perhaps gather more evidence, testing the proposition by choosing other numbers.
But infinite naturals so testing can never be complete.

## PROOF BY INDUCTION

natural definition has
- base case
- inductive case

inductive proof follows structure of definition: prove two cases
- _base case_ : show property holds for `zero`
- _inductive case_ :
  - assume property holds for an arbitrary natural `m` (the _inductive hypothesis_)
  - then show that the property holds for `suc m`

    ------
    P  zero

    P      m
    ---------
    P (suc m)

- initially, no properties are known.
- base case : `P zero` holds : add it to set of known properties
    -- On the first day, one property is known.
    P zero
- inductive case tells us that if `P m` holds
    -- On the second day, two properties are known.
    P zero
    P (suc zero)
  then `P (suc m)` also holds

    -- On the third day, three properties are known.
    P zero
    P (suc zero)
    P (suc (suc zero))

    -- On the fourth day, four properties are known.
    P zero
    P (suc zero)
    P (suc (suc zero))
    P (suc (suc (suc zero)))

the process continues: property `P n` first appears on day _n+1_

------------------------------------------------------------------------------
## PROVE ASSOCIATIVITY of ADDITION

take `P m` to be the property:

    (m + n) + p ≡ m + (n + p)

`n` and `p` are arbitrary natural numbers

show the equation holds for all `m` it will also hold for all `n` and `p`

    -------------------------------
     (zero + n) + p ≡  zero + (n + p)

        (m + n) + p ≡     m + (n + p)
    ---------------------------------
    (suc m + n) + p ≡ suc m + (n + p)

demonstrate both of above, then associativity of addition follows by induction
-}

-- signature says providing evidence for proposition
+-assoc : ∀ (m n p : ℕ)
        → (m +  n) + p
        ≡  m + (n  + p)

-- Evidence is a function that
-- - takes three natural numbers, binds them to `m`, `n`, and `p`
-- - returns evidence for the corresponding instance of the equation

-- base case : show: (zero +  n) + p
--                  ≡ zero + (n  + p)
+-assoc zero n p =
  begin
  (zero +  n) + p ≡⟨⟩ -- _+_ base case
           n  + p ≡⟨⟩
   zero + (n  + p)
  ∎

-- inductive case : show: (suc m +  n) + p
--                       ≡ suc m + (n  + p)
+-assoc (suc m) n p =
  begin
  (suc   m +  n) + p   ≡⟨⟩ -- _+_ inductive case (left to right)
   suc  (m +  n) + p   ≡⟨⟩
   suc ((m +  n) + p)  ≡⟨ cong suc (+-assoc m n p) ⟩
                           -- simplifying both sides : suc ((m + n) + p) ≡ suc (m + (n + p))
                           -- follows by prefacing `suc` to both sides of the induction hypothesis:
                           --                               (m + n) + p  ≡      m + (n + p)
   suc  (m + (n  + p)) ≡⟨⟩ -- _+_ inductive case (right to left)
   suc   m + (n  + p)
  ∎

-- HC minimal version

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

{-
identifiers can have any characters NOT including spaces or the characters @.(){};_

the "middle" equation, does not follow from applying _+_ (i.e., "simplification") alone
- `_≡⟨_⟩_` : called "chain reasoning"
- justification for equation given in angle brackets:
  - empty means "simplification", or
  - something more, e.g.,:

    ⟨ cong suc (+-assoc m n p) ⟩

recursive invocation `+-assoc m n p`
- has type of the induction hypothesis
- `cong suc` prefaces `suc` to each side of inductive hypothesis

A relation is a CONGRUENCE for a given function
if the relation is preserved by applying the function.

if `e` is evidence that `x ≡ y`, then `cong f e` is evidence `f x ≡ f y`, for any `f`

here the inductive hypothesis is not assumed

instead, proved by recursive invocation of the function being defined, `+-assoc m n p`

WELL FOUNDED : associativity of larger numbers is proved in of associativity of smaller numbers.

e.g., `assoc (suc m) n p` is proved using `assoc m n p`.

------------------------------------------------------------------------------
## Induction as recursion

Concrete example of how induction corresponds to recursion : instantiate `m` to `2`
-}

+-assoc-2 : ∀ (n p : ℕ)
          → (2 +  n) + p
          ≡  2 + (n  + p)
+-assoc-2 n p =
  begin
         (2 +  n) + p   ≡⟨⟩
    suc  (1 +  n) + p   ≡⟨⟩
    suc ((1 +  n) + p)  ≡⟨ cong suc (+-assoc-1 n p) ⟩
    suc  (1 + (n  + p)) ≡⟨⟩
          2 + (n  + p)
  ∎
 where
  +-assoc-1 : ∀ (n p : ℕ) → (1 + n) + p ≡ 1 + (n + p)
  +-assoc-1 n p =
    begin
           (1 +  n) + p   ≡⟨⟩
      suc  (0 +  n) + p   ≡⟨⟩
      suc ((0 +  n) + p)  ≡⟨ cong suc (+-assoc-0 n p) ⟩
      suc  (0 + (n  + p)) ≡⟨⟩
            1 + (n  + p)
    ∎
   where
    +-assoc-0 : ∀ (n p : ℕ) → (0 + n) + p ≡ 0 + (n + p)
    +-assoc-0 n p =
      begin
        (0 + n) + p  ≡⟨⟩
             n  + p  ≡⟨⟩
        0 + (n  + p)
      ∎
{-
------------------------------------------------------------------------------
## Terminology and notation

Evidence for a universal quantifier is a function.  The notations

    +-assoc : ∀ (m n p : ℕ)
            → (m +  n) + p
            ≡  m + (n  + p)

and

    +-assoc : ∀ (m : ℕ)
            → ∀ (n : ℕ)
            → ∀ (p : ℕ)
            → (m +  n) + p
            ≡  m + (n  + p)

are equivalent.

differ from function type such as `ℕ → ℕ → ℕ`
- variables are associated with each argument type
- the result type may mention (or depend upon) these variables
- hence called _DEPENDENT functions_

------------------------------------------------------------------------------
## COMMUTATIVITY of ADDITION : m + n ≡ n + m

two lemmas used in proof

### first lemma

The base case of the definition of addition states that zero is a left-identity:

    zero + n ≡ n

First lemma states that zero is also a right-identity:
-}

-- proof by induction on `m`
+-identityʳ : ∀ (m : ℕ)
            → m + zero
            ≡ m

-- base case : show:
--    zero + zero
--  ≡ zero
+-identityʳ zero =
  begin
    zero + zero ≡⟨⟩ -- _+_ base
    zero
  ∎

-- inductive case : show:
--     (suc m) + zero
--    = suc m
+-identityʳ (suc m) =
  begin
    suc  m + zero  ≡⟨⟩ -- _+_ inductive
    suc (m + zero) ≡⟨ cong suc (+-identityʳ m) ⟩
                       -- recursive invocation `+-identityʳ m`
                       -- has type of induction hypothesis
                       --      m + zero  ≡     m
                       -- `cong suc` prefaces `suc` to each side of that type, yielding
                       -- suc (m + zero) ≡ suc m
    suc  m
  ∎
{-
### second lemma

inductive case of _+_ pushes `suc` on 1st arg to the outside:

    suc m + n ≡ suc (m + n)

second lemma does same for `suc` on 2nd arg:

    m + suc n ≡ suc (m + n)
-}

-- signature states defining `+-suc` which provides evidence for the proposition/type
+-suc : ∀ (m n : ℕ)
      →      m + suc n
      ≡ suc (m +     n)

-- evidence is fun that takes two nats, binds to `m` and `n`
-- returns evidence for the corresponding instance of the equation
-- proof is by induction on `m`

-- base case
+-suc zero n =
  begin
         zero + suc n  ≡⟨⟩ -- _+_ base
                suc n  ≡⟨⟩ -- _+_ base
    suc (zero +     n)
  ∎
-- inductive case : show:      suc m + suc n
--                      ≡ suc (suc m +     n)
+-suc (suc m) n =
  begin
    suc       m + suc n   ≡⟨⟩                       -- _+_ inductive
    suc      (m + suc n)  ≡⟨ cong suc (+-suc m n) ⟩ -- induction
    suc (suc (m +     n)) ≡⟨⟩                       -- _+_ inductive
    suc (suc  m +     n)
  ∎

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

+-comm : ∀ (m n : ℕ)
       → m + n
       ≡ n + m
+-comm m zero =
  begin
           m + zero ≡⟨ +-identityʳ m ⟩
           m        ≡⟨⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
         m + suc n  ≡⟨ +-suc m n ⟩
    suc (m +     n) ≡⟨ cong suc (+-comm m n) ⟩ -- congruence and induction hypothesis
    suc (n +     m) ≡⟨⟩                        -- _+_ inductive
    suc  n +     m
  ∎

{-
definition required BEFORE using them

------------------------------------------------------------------------------
## COROLLARY: REARRANGING : apply associativity to rearrange parentheses (SYM; sections)
-}

+-rearrange : ∀ (m n p q : ℕ)
            → (m +  n) + (p  + q)
            ≡  m + (n  +  p) + q
+-rearrange m n p q =
  begin
    (m +   n) + (p   + q)  ≡⟨                   +-assoc m n   (p + q) ⟩
     m +  (n  + (p   + q)) ≡⟨ cong (m +_) (sym (+-assoc n p        q)) ⟩
     m + ((n  +  p)  + q)  ≡⟨              sym (+-assoc m (n + p)  q) ⟩
    (m +  (n  +  p)) + q   ≡⟨⟩
     m +  (n  +  p)  + q
  ∎

{-
no induction is required

NOTE:

addition is left associative : m + (n + p)  + q
                            = (m + (n + p)) + q

SYM : interchange sides of an equation, e.g.,
- `+-assoc n p q` shifts parens right to left:

    (n + p) + q ≡ n + (p + q)

`sym (+-assoc n p q)`: to shift them left-to-right

    n + (p + q) ≡ (n + p) + q

general
- if `e` provides evidence for `x ≡ y`
- then `sym e` provides evidence for `y ≡ x`

SECTION NOTATION (introduced by Richard Bird) : `(x +_)`    `(_+ x)`

------------------------------------------------------------------------------
## Creation, one last time

base case : `(zero + n) + p ≡ zero + (n + p)`

inductive case :
- if `(m + n) + p ≡     m + (n + p)` then
 `(suc m + n) + p ≡ suc m + (n + p)`

using base case, associativity of zero on left:
    (0 + 0) + 0 ≡ 0 + (0 + 0)   ...   (0 + 4) + 5 ≡ 0 + (4 + 5)   ...
using inductive case
    (1 + 0) + 0 ≡ 1 + (0 + 0)   ...   (1 + 4) + 5 ≡ 1 + (4 + 5)   ...
    (2 + 0) + 0 ≡ 2 + (0 + 0)   ...   (2 + 4) + 5 ≡ 2 + (4 + 5)   ...
    (3 + 0) + 0 ≡ 3 + (0 + 0)   ...   (3 + 4) + 5 ≡ 3 + (4 + 5)   ...
    ...

there is a finite approach to generating the same equations (following exercise)

------------------------------------------------------------------------------
#### Exercise `finite-|-assoc` (stretch) {name=finite-plus-assoc} TODO - first four days of creation - description, not proof

Write out what is known about associativity of addition on each of the
first four days using a finite story of creation, as
[earlier](/Naturals/#finite-creation).

------------------------------------------------------------------------------
## proof of ASSOCIATIVITY using `rewrite` (rather than chains of equations)

avoids chains of equations and the need to invoke `cong`
-}

+-assoc′ : ∀ (m n p : ℕ)
         → (m +  n) + p
         ≡  m + (n  + p)

-- base
-- show: (zero + n) + p ≡ zero + (n + p)
-- _+_ base applied "invisibly", then terms equal/refl
+-assoc′ zero    n p                         = refl

-- inductive
-- show: (suc m + n) + p ≡ suc m + (n + p)
-- _+_ inductive applied "invisibly" giving: suc ((m + n) + p) ≡ suc (m + (n + p))
-- rewrite with the inductive hypothesis
-- then terms are equal/refl
+-assoc′ (suc m) n p  rewrite +-assoc′ m n p = refl

{-
rewriting by a given equation
- indicated by keyword `rewrite`
- followed by a proof of that equation

------------------------------------------------------------------------------
## COMMUTATIVITY with rewrite
-}

+-suc′ : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc′ zero n = refl
+-suc′ (suc m) n rewrite +-suc′ m n = refl

+-comm′ : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm′ m zero rewrite +-identityʳ m = refl
-- rewriting with two equations indicated by separating the two proofs
-- of the relevant equations by a vertical bar
-- left rewrite performed before right
+-comm′ m (suc n)  -- m + suc n ≡ suc  n + m
                   -- m + suc n ≡ suc (n + m) -- def/eq
  rewrite
    +-suc′  m n    -- suc (m + n) ≡ suc (n + m)
  | +-comm′ m n    -- suc (n + m) ≡ suc (n + m)
  = refl

+-comm′′ : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm′′ m   zero rewrite +-identityʳ m = refl
+-comm′′ m (suc n) =
  begin
    m +  suc n  ≡⟨ +-suc′  m n ⟩
    suc (m + n) ≡⟨ cong suc (+-comm′′ m n) ⟩
    suc (n + m) ≡⟨⟩ -- def/eq
    suc  n + m
  ∎

{-
------------------------------------------------------------------------------
HC
-}

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

0* : ∀ (m : ℕ) → 0 * m ≡ 0
0* m = refl

*1 : ∀ (n : ℕ) → n * 1 ≡ n
*1 zero = refl
*1 (suc n) rewrite *1 n = refl

1* : ∀ (n : ℕ) → 1 * n ≡ n
1* zero = refl
1* (suc n) rewrite 1* n = refl

{-
------------------------------------------------------------------------------
## Building proofs interactively

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ m n p = ?

C-c C-l

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ m n p = { }0

new window at the bottom:

    ?0 : ((m + n) + p) ≡ (m + (n + p))

indicates hole 0 needs to be filled with a proof of the stated judgment

to prove the proposition by induction on `m`
move cursor into hole
C-c C-c
prompt: pattern variables to case (empty for split on result):

type `m` to case split on that variable

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ zero n p = { }0
    +-assoc′ (suc m) n p = { }1

There are now two holes, and the window at the bottom tells you what
each is required to prove:

    ?0 : ((zero + n) + p) ≡ (zero + (n + p))
    ?1 : ((suc m + n) + p) ≡ (suc m + (n + p))

goto hole 0
C-c C-,

    Goal: (n + p) ≡ (n + p)
    ————————————————————————————————————————————————————————————
    p : ℕ
    n : ℕ

indicates that after simplification the goal for hole 0 is as stated,
 and that variables `p` and `n` of the stated types are available to use in the proof.

the proof of the given goal is simple
goto goal
C-c C-r
fills in with refl
C-c C-l renumbers remaining hole to 0:

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ zero n p = refl
    +-assoc′ (suc m) n p = { }0

goto hole 0
C-c C-,

    Goal: suc ((m + n) + p) ≡ suc (m + (n + p))
    ————————————————————————————————————————————————————————————
    p : ℕ
    n : ℕ
    m : ℕ

gives simplified goal and available variables

need to rewrite by the induction hypothesis

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ zero n p = refl
    +-assoc′ (suc m) n p rewrite +-assoc′ m n p = { }0

goto hole
C-c C-,

    Goal: suc (m + (n + p)) ≡ suc (m + (n + p))
    ————————————————————————————————————————————————————————————
    p : ℕ
    n : ℕ
    m : ℕ

goto goal
C-c C-r
fills in, completing proof

    +-assoc′ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
    +-assoc′ zero n p = refl
    +-assoc′ (suc m) n p rewrite +-assoc′ m n p = refl

------------------------------------------------------------------------------
#### Exercise `+-swap` (recommended) {name=plus-swap}

Show

    m + (n + p) ≡ n + (m + p)

for all naturals `m`, `n`, and `p`
- no induction
- use associativity and commutativity of addtion
-}

+-swap : ∀ (m n p : ℕ)
       → m + (n + p)
       ≡ n + (m + p)
+-swap m n p =
  begin
     m + (n  + p) ≡⟨ sym (+-assoc m n p) ⟩
    (m +  n) + p  ≡⟨ cong (_+ p) (sym (+-comm n m)) ⟩
    (n +  m) + p  ≡⟨ +-assoc n m p ⟩
     n + (m  + p)
  ∎

{-
------------------------------------------------------------------------------
#### Exercise `*-distrib-+` (recommended) {name=times-distrib-plus} (m + n) * p ≡ m * p + n * p
-}

*-distrib-+r : ∀ (m n p : ℕ)
             → (m     + n) * p
             ≡  m * p + n  * p
*-distrib-+r  zero   y z = refl
*-distrib-+r (suc x) y z            -- (suc x     + y) * z  ≡ suc x * z + y * z
                                    -- z + (x     + y) * z  ≡ z + x * z + y * z
  rewrite
    *-distrib-+r x y z              -- z + (x * z + y  * z) ≡ z + x * z + y * z
  | sym (+-assoc z (x * z) (y * z)) -- z +  x * z + y  * z  ≡ z + x * z + y * z
  = refl

{- TODO: agda loops on this : *-distrib-+r done with chain reasoning
*-distrib-+r' : ∀ (m n p : ℕ)
             → (m     + n) * p
             ≡  m * p + n  * p
*-distrib-+r'  zero   y z = refl
*-distrib-+r' (suc x) y z
  begin
    (suc x     + y) * z  ≡⟨⟩
    z + (x     + y) * z  ≡⟨ *-distrib-+r' x y z ⟩
    z + (x * z + y  * z) ≡⟨ sym (+-assoc z (x * z) (y * z)) ⟩
    z +  x * z + y  * z  ≡⟨⟩
     suc x * z + y  * z
  ∎
-}
{-
------------------------------------------------------------------------------
#### Exercise `*-assoc` (recommended) {name=times-assoc} (m * n) * p ≡ m * (n * p)
-}

*-assoc : ∀ (m n p : ℕ)
        → (m *  n) * p
        ≡  m * (n  * p)
-- base case : show: (zero *  n) * p
--                  ≡ zero * (n  * p)
*-assoc zero n p = refl      -- zero * n * p        ≡ zero * (n * p)
                             -- zero                ≡ zero -- def/eq
-- inductive case : show: (suc m *  n) * p
--                       ≡ suc m * (n  * p)
*-assoc (suc m) n p          --     suc m * n  * p  ≡     suc m * (n * p)
                             --    (n + m * n) * p  ≡ n * p + m * (n * p)
  rewrite
    *-distrib-+r n (m * n) p -- n * p + m *  n * p  ≡ n * p + m * (n * p)
  | *-assoc m n p            -- n * p + m * (n * p) ≡ n * p + m * (n * p)
  = refl

{-
------------------------------------------------------------------------------
#### Exercise `*-comm` (practice) {name=times-comm} MULTIPLICATION is COMMUTATIVE : m * n ≡ n * m
-}

*-suc : ∀ (x y : ℕ) → x * (suc y) ≡ x + (x * y)
*-suc zero y = refl
*-suc (suc x) y               --       suc x * suc y  ≡ suc  x +  suc  x * y
                              -- suc (y  + x * suc y) ≡ suc (x + (y +  x * y))
  rewrite
    +-comm y (x * suc y)      -- suc (x  * suc y + y) ≡ suc (x + (y +  x * y))
  | *-suc x y                 -- suc (x + x  * y + y) ≡ suc (x + (y +  x * y))
  | +-comm y (x * y)          -- suc (x + x  * y + y) ≡ suc (x + (x *  y + y))
  | sym (+-assoc x (x * y) y) -- suc (x + x  * y + y) ≡ suc (x +  x *  y + y)
  = refl

*-comm : ∀ (m n : ℕ) → m * n  ≡ n * m
*-comm m zero rewrite *0 m = refl
*-comm m (suc n) -- m * suc n ≡ suc n * m
                 -- m * suc n ≡ m + n * m
  rewrite
    *-suc m n    -- m + m * n ≡ m + n * m
  | *-comm m n   -- m + n * m ≡ m + n * m
  = refl

{-
------------------------------------------------------------------------------
#### Exercise `0∸n≡0` (practice) {name=zero-monus} : Show zero ∸ n ≡ zero

for all naturals `n`. Did your proof require induction?
-}

0∸n≡0 : ∀ (n : ℕ) → 0 ∸ n ≡ 0
0∸n≡0  zero   = refl
0∸n≡0 (suc n) = refl

{-
------------------------------------------------------------------------------
#### Exercise `∸-|-assoc` (practice) {name=monus-plus-assoc} : m ∸ n ∸ p ≡ m ∸ (n + p)

show that monus associates with addition
-}

∸-|-assoc : ∀ (m n p : ℕ) → m ∸ n ∸ p ≡ m ∸ (n + p)
∸-|-assoc      m       n   zero   --     m ∸     n ∸ zero   ≡     m ∸     (n + zero)
                                  --     m ∸     n          ≡     m ∸     (n + zero)
  rewrite +-identityʳ n = refl    --     m ∸     n          ≡     m ∸      n
∸-|-assoc      m   zero   (suc p) --     m ∸  zero ∸ suc p  ≡     m ∸  (zero + suc p)
  = refl                          --     m ∸         suc p  ≡     m ∸          suc p
∸-|-assoc  zero   (suc n) (suc p) --  zero ∸ suc n ∸ suc p  ≡  zero ∸ (suc n + suc p)
  = refl                          --  zero                  ≡  zero
∸-|-assoc (suc m) (suc n) (suc p) -- suc m ∸ suc n ∸ suc p  ≡ suc m ∸ (suc n + suc p)
                                  --     m ∸     n ∸ suc p  ≡     m ∸     (n + suc p)
  rewrite
    ∸-|-assoc m n (suc p)         --     m ∸    (n + suc p) ≡     m ∸     (n + suc p)
  = refl

{-
------------------------------------------------------------------------------
#### Exercise `+*^` (stretch)

     m ^ (n  + p) ≡ (m ^  n) * (m ^ p)  (^-distribˡ-|-*)
     (m * n) ^ p  ≡ (m ^  p) * (n ^ p)  (^-distribʳ-*)
     (m ^ n) ^ p  ≡  m ^ (n  *  p)      (^-*-assoc)
-}

-------------------------
-- this can be shortened
^-distribˡ-|-* : ∀ (m n p : ℕ)
               →  m ^ (n  +      p)
               ≡ (m ^  n) * (m ^ p)
^-distribˡ-|-* m n zero              -- (m ^ (n + zero))        ≡ (m ^ n) * (m ^ zero)
                                     -- (m ^ (n + zero))        ≡ (m ^ n) * 1
  rewrite
    +-identityʳ n                    -- (m ^  n)                ≡ (m ^ n) * 1
  | *1 (m ^ n)                       -- (m ^  n)                ≡ (m ^ n)
  = refl
^-distribˡ-|-* m n (suc p)           -- (m ^ (n + suc p))       ≡ (m ^ n) *      (m ^ suc p)
                                     -- (m ^ (n + suc p))       ≡ (m ^ n) * (m * (m ^     p))
  rewrite
    *-comm m (m ^ p)                 -- (m ^ (n + suc p))       ≡ (m ^ n) *     ((m ^     p) * m)
  | sym (*-assoc (m ^ n) (m ^ p) m)  -- (m ^ (n + suc p))       ≡ (m ^ n) *      (m ^     p) * m
  | +-comm n (suc p)                 -- (m ^ suc (p + n))       ≡ (m ^ n) *      (m ^     p) * m
                                     -- m * (m ^ (p + n))       ≡ (m ^ n) *      (m ^     p) * m
  | *-comm ((m ^ n) * (m ^     p)) m -- m * (m ^ (p + n))       ≡  m * ((m ^ n) * (m ^ p))
  | sym (*-assoc m (m ^ n) (m ^ p))  -- m * (m ^ (p + n))       ≡  m *  (m ^ n) * (m ^ p)
  | ^-distribˡ-|-* m p n             -- m * ((m ^ p) * (m ^ n)) ≡  m *  (m ^ n) * (m ^ p)
  | sym (*-comm (m ^ n) (m ^ p))     -- m * ((m ^ n) * (m ^ p)) ≡  m *  (m ^ n) * (m ^ p)
  | *-assoc m (m ^ n) (m ^ p)        -- m * ((m ^ n) * (m ^ p)) ≡  m * ((m ^ n) * (m ^ p))
  = refl

-------------------------
^-distribʳ-* : ∀ (m n p : ℕ)
             → (m * n) ^ p
             ≡ (m ^ p) * (n ^ p)
^-distribʳ-* m n zero = refl
^-distribʳ-* m n (suc p)            --      ((m * n) ^ suc p)      ≡(m ^ suc p) * (n ^ suc p)
                                    -- m * n * ((m      *  n) ^ p) ≡ m * (m ^ p) * (n * (n ^ p))
  rewrite
    ^-distribʳ-* m n p              -- m * n * ((m ^ p) * (n ^ p)) ≡ m * (m ^ p) * (n * (n ^ p))
  | *-comm (m * (m ^ p)) (n * (n ^ p))
                                    -- m * n * ((m ^ p) * (n ^ p)) ≡ n * (n ^ p) * (m * (m ^ p))
  | *-assoc m n ((m ^ p) * (n ^ p)) -- m *(n * ((m ^ p) * (n ^ p)))≡ n * (n ^ p) * (m * (m ^ p))
  | *-comm m (n * ((m ^ p) * (n ^ p)))
                                    -- n *((m ^ p) * (n ^ p))* m  ≡ n * (n ^ p) * (m * (m ^ p))
  | *-comm (m ^ p) (n ^ p)          -- n *((n ^ p) * (m ^ p))* m  ≡ n * (n ^ p) * (m * (m ^ p))
  | sym (*-assoc n (n ^ p) (m ^ p)) -- n * (n ^ p) * (m ^ p) * m  ≡ n * (n ^ p) * (m * (m ^ p))
  | *-assoc n (n ^ p) (m * (m ^ p)) -- n * (n ^ p) * (m ^ p) * m  ≡ n *((n ^ p) * (m * (m ^ p)))
  | *-comm m (m ^ p)                -- n * (n ^ p) * (m ^ p) * m  ≡ n *((n ^ p) * ((m ^ p) * m))
  | *-assoc n (n ^ p) (m ^ p)       -- n *((n ^ p) * (m ^ p))* m  ≡ n *((n ^ p) * ((m ^ p) * m))
  | *-assoc n ((n ^ p) * (m ^ p)) m -- n *((n ^ p) * (m ^ p) * m) ≡ n *((n ^ p) * ((m ^ p) * m))
  | *-assoc (n ^ p) (m ^ p) m       -- n *((n ^ p) *((m ^ p) * m))≡ n *((n ^ p) * ((m ^ p) * m))
  = refl

-------------------------
^-*-assoc : ∀ (m n p : ℕ)
          → (m ^  n) ^ p
          ≡  m ^ (n  * p)
^-*-assoc m n  zero                 --        ((m ^ n) ^ zero) ≡ (m ^ (n * zero))
                                    --                      1  ≡ (m ^ (n * zero))
  rewrite *0 n                      --                      1  ≡ (m ^ 0)
                                    --                      1  ≡ 1
  = refl
^-*-assoc m n (suc p)               --       ((m ^ n) ^ suc p) ≡ (m ^ (n * suc p))
                                    -- (m ^ n) * ((m ^ n) ^ p) ≡ (m ^ (n * suc p))
  rewrite
    *-suc n p                       -- (m ^ n) * ((m ^ n) ^ p) ≡ (m ^ (n + n * p))
  | ^-distribˡ-|-* m n (n * p)      -- (m ^ n) * ((m ^ n) ^ p) ≡ (m ^ n) * (m ^ (n * p))
  | sym (^-*-assoc m n p)           -- (m ^ n) * ((m ^ n) ^ p) ≡ (m ^ n) * ((m ^ n) ^ p)
  = refl

{-
------------------------------------------------------------------------------
#### Exercise `Bin-laws` (stretch) {name=Bin-laws}

Recall that
Exercise [Bin](/Naturals/#Bin)
defines a datatype `Bin` of bitstrings representing natural numbers,
and asks you to define functions
-}

-- begin duplicated from x01 (can't import because of "duplicate" pragma)

data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

inc : Bin → Bin
inc  ⟨⟩    = ⟨⟩      I
inc (b  O) =      b  I
inc (b  I) = (inc b) O

_ : inc (⟨⟩ I O I I) ≡ ⟨⟩ I I O O
_ = refl

-- end duplicated

dbl : ℕ → ℕ
dbl   zero  = zero
dbl (suc m) = suc (suc (dbl m))

to : ℕ → Bin
to   zero  = ⟨⟩ O
to (suc m) = inc (to m)

-- THIS IS THE CRITICAL STEP : defining in terms of 'dbl'
-- Got hint from : https://cs.uwaterloo.ca/~plragde/842/
from : Bin → ℕ
from     ⟨⟩ = 0
from (b  O) =      dbl (from b)
from (b  I) = suc (dbl (from b))

_ : to 6 ≡ ⟨⟩ I I O
_ = refl

_ : from (⟨⟩ I I O) ≡ 6
_ = refl

{-
Consider the following laws, where `n` ranges over naturals and `b`
over bitstrings:

    from (inc b) ≡ suc (from b)
    to (from b) ≡ b
    from (to n) ≡ n

For each law: if it holds, prove; if not, give a counterexample.
-}

-------------------------
-- fromInc≡sucFrom

+1 : ∀ (x : ℕ) → x + 1 ≡ suc x
+1 zero = refl
+1 (suc n) rewrite +1 n = refl

fromInc≡sucFrom : ∀ (b : Bin)
                → from (inc b) ≡ suc (from b)
fromInc≡sucFrom ⟨⟩       --       from (inc ⟨⟩)      ≡ suc (from ⟨⟩)
                         --                        1 ≡ 1
  = refl
fromInc≡sucFrom (⟨⟩ I)   --       from (inc (⟨⟩ I))  ≡ suc (from (⟨⟩ I))
                         --                        2 ≡ 2
  = refl
fromInc≡sucFrom (b O)    --       from (inc (b O))   ≡ suc (from (b O))
                         --       dbl (from b) + 1   ≡ suc (dbl (from b))
  rewrite
    +1 (dbl (from b))    --       suc (dbl (from b)) ≡ suc (dbl (from b))
  = refl
fromInc≡sucFrom (b I)    --       from (inc (b I))   ≡ suc (from (b I))
                         --       dbl (from (inc b)) ≡ suc (dbl (from b) + 1)
  rewrite
    +1 (dbl (from b))    --       dbl (from (inc b)) ≡ suc (suc (dbl (from b)))
  | fromInc≡sucFrom b    --       dbl (suc (from b)) ≡ suc (suc (dbl (from b)))
                         -- suc (suc (dbl (from b))) ≡ suc (suc (dbl (from b)))
  = refl

-------------------------
-- to-from≡b -- cannot be proved because there are TWO representations of ZERO

-- NOT USED
xx : ∀ (b : Bin)
   → (dbl (from b)) ≡ from (b O)
xx ⟨⟩        -- dbl (from ⟨⟩) ≡ from (⟨⟩ O)
             -- zero ≡ zero
  = refl
xx (b O)     -- dbl (from (b O)) ≡ from ((b O) O)
             -- dbl (dbl (from b)) ≡ dbl (dbl (from b))
  = refl
xx (b I)     -- dbl (from (b I)) ≡ from ((b I) O)
             -- suc (suc (dbl (dbl (from b)))) ≡ suc (suc (dbl (dbl (from b))))
  = refl

-- CANNOT BE PROVED BECAUSE TWO REPRESENTATIONS OF ZERO : (⟨⟩) and (⟨⟩ O)
yy : ∀ (b : Bin)
   → to (dbl (from b)) ≡ (b O)
yy ⟨⟩        --                  to (dbl (from ⟨⟩)) ≡ (⟨⟩ O)
             --                              (⟨⟩ O) ≡ (⟨⟩ O)
  = refl
yy (b O)     --           to (dbl (from (b O)))     ≡ ((b O) O)
             --           to (dbl (dbl (from b)))   ≡ ((b O) O)
  rewrite
    yy b
  = {!!}
yy (b I)     --           to (dbl (from (b I)))     ≡ ((b I) O)
             -- inc (inc (to (dbl (dbl (from b))))) ≡ ((b I) O)
  = {!!}

to-from : ∀ (b : Bin)
       → to (from b) ≡ b
to-from ⟨⟩       --       to (from ⟨⟩)      ≡ ⟨⟩
                 --               (⟨⟩ O)    ≡ ⟨⟩ -- *****
  = {!!}
to-from (⟨⟩ I)   --       to (from (⟨⟩ I))  ≡ (⟨⟩ I)
                 --       (⟨⟩ I)            ≡ (⟨⟩ I)
  = refl
to-from (b O)    --       to (from (b O))   ≡ (b O)
                 --       to (dbl (from b)) ≡ (b O)
  rewrite
    yy b         --                   (b O) ≡ (b O)
  = refl
to-from (b I)    --         to (from (b I)) ≡ (b I)
                 -- inc (to (dbl (from b))) ≡ (b I)
  rewrite
    yy b         --                   (b I) ≡ (b I)
  = refl

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

-- https://github.com/billyang98/plfa/blob/master/plfa/Induction.agda

from-inc≡suc-from : ∀ x → from (inc x) ≡ suc (from x)
from-inc≡suc-from ⟨⟩    = refl
from-inc≡suc-from (x O) = refl
from-inc≡suc-from (x I)  --         from (inc (x I)) ≡ suc           (from (x I))
                         --    dbl (from (inc  x))   ≡ suc (suc (dbl (from  x)))
  rewrite
    from-inc≡suc-from x  -- suc (suc (dbl (from x))) ≡ suc (suc (dbl (from x)))
  = refl

from-to : ∀ n → from (to n) ≡ n
from-to zero = refl
from-to (suc n)              -- from (to (suc n)) ≡ suc n
                             -- from (inc (to n)) ≡ suc n
  rewrite
    from-inc≡suc-from (to n) -- suc (from (to n)) ≡ suc n
  | cong suc (from-to n)     -- suc           n   ≡ suc n
  = refl

{-
------------------------------------------------------------------------------
## Standard library

Definitions similar to those in this chapter can be found in the standard library:
```
import Data.Nat.Properties using (+-assoc; +-identityʳ; +-suc; +-comm)
```

------------------------------------------------------------------------------
## Unicode

This chapter uses the following unicode:

    ∀  U+2200  FOR ALL (\forall, \all)
    ʳ  U+02B3  MODIFIER LETTER SMALL R (\^r)
    ′  U+2032  PRIME (\')
    ″  U+2033  DOUBLE PRIME (\')
    ‴  U+2034  TRIPLE PRIME (\')
    ⁗  U+2057  QUADRUPLE PRIME (\')

Similar to `\r`, the command `\^r` gives access to a variety of
superscript rightward arrows, and also a superscript letter `r`.
The command `\'` gives access to a range of primes (`′ ″ ‴ ⁗`).
-}

-- ============================================================================

-- this is here to ensure the Bin/in/from/to does not get broken if changed above

_ : inc (⟨⟩ I O I I) ≡ ⟨⟩ I I O O
_ = refl

_ : inc (⟨⟩     O) ≡ ⟨⟩     I
_ = refl
_ : inc (⟨⟩     I) ≡ ⟨⟩   I O
_ = refl
_ : inc (⟨⟩   I O) ≡ ⟨⟩   I I
_ = refl
_ : inc (⟨⟩   I I) ≡ ⟨⟩ I O O
_ = refl
_ : inc (⟨⟩ I O O) ≡ ⟨⟩ I O I
_ = refl

_ : from (⟨⟩     O) ≡ 0
_ = refl
_ : from (⟨⟩     I) ≡ 1
_ = refl
_ : from (⟨⟩   I O) ≡ 2
_ = refl
_ : from (⟨⟩   I I) ≡ 3
_ = refl
_ : from (⟨⟩ I O O) ≡ 4
_ = refl

_ : to 0 ≡ (⟨⟩     O)
_ = refl
_ : to 1 ≡ (⟨⟩     I)
_ = refl
_ : to 2 ≡ (⟨⟩   I O)
_ = refl
_ : to 3 ≡ (⟨⟩   I I)
_ = refl
_ : to 4 ≡ (⟨⟩ I O O)
_ = refl

_ : from (to 12) ≡ 12
_ = refl

_ : to (from (⟨⟩ I I O O)) ≡ ⟨⟩ I I O O
_ = refl


module InequalityReasoningExercise where

open import EqualityAux

infix 4 _≤_

data _≤_ : ℕ → ℕ → Set where

  z≤n : ∀ {n : ℕ}
      --------
    → zero ≤ n

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

≤-refl : ∀ {n : ℕ}
    -----
  → n ≤ n
≤-refl {zero}  = z≤n
≤-refl {suc n} = s≤s ≤-refl

≤-trans : ∀ {m n p : ℕ}
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p
≤-trans z≤n       _         = z≤n
≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)

module ≤-Reasoning where

  infix  1 ≤-begin_
  infixr 2 _≤⟨⟩_ _≤⟨_⟩_ _≤-≡⟨_⟩_
  infix  3 _≤-∎

  ≤-begin_ : ∀ {x y : ℕ}
    → x ≤ y
      -----
    → x ≤ y
  ≤-begin x≤y = x≤y

  _≤⟨⟩_ : ∀ (x : ℕ) {y : ℕ}
    → x ≤ y
      -----
    → x ≤ y
  x ≤⟨⟩ x≤y = x≤y

  _≤⟨_⟩_ : ∀ (x : ℕ) {y z : ℕ}
    → x ≤ y
    → y ≤ z
      -----
    → x ≤ z
  x ≤⟨ x≤y ⟩ y≤z = ≤-trans x≤y y≤z

  _≤-≡⟨_⟩_ : ∀ (x : ℕ) {y z : ℕ}
    → x ≡ y
    → y ≤ z
      -----
    → x ≤ z
  x ≤-≡⟨ refl ⟩ y≤z = ≤-trans ≤-refl y≤z

  _≤-∎ : ∀ (x : ℕ)
      -----
    → x ≤ x
  x ≤-∎ = ≤-refl

open ≤-Reasoning

+-monoʳ-≤ : ∀ (n p q : ℕ)
  → p ≤ q
    -------------
  → n + p ≤ n + q
+-monoʳ-≤ zero p q p≤q =
  ≤-begin
    zero + p
  ≤⟨⟩
    p
  ≤⟨ p≤q ⟩
    q
  ≤⟨⟩
    zero + q
  ≤-∎

+-monoʳ-≤ (suc n) p q p≤q =
  ≤-begin
    (suc n) + p
  ≤⟨⟩
    suc (n + p)
  ≤⟨ s≤s (+-monoʳ-≤ n p q p≤q) ⟩
    suc (n + q)
  ≤⟨⟩
    (suc n) + q
  ≤-∎

+-monoˡ-≤ : ∀ (m n p : ℕ)
  → m ≤ n
    -------------
  → m + p ≤ n + p
+-monoˡ-≤ m n p m≤n =
  ≤-begin
    m + p
  ≤-≡⟨ +-comm m p ⟩
    p + m
  ≤⟨ +-monoʳ-≤ p m n m≤n ⟩
    p + n
  ≤-≡⟨ +-comm p n ⟩
    n + p
  ≤-∎

+-mono-≤ : ∀ (m n p q : ℕ)
  → m ≤ n
  → p ≤ q
    -------------
  → m + p ≤ n + q
+-mono-≤ m n p q m≤n p≤q =
  ≤-begin
    m + p
  ≤⟨ +-monoˡ-≤ m n p m≤n ⟩
    n + p
  ≤⟨ +-monoʳ-≤ n p q p≤q ⟩
    n + q
  ≤-∎


-- A DSL example in the language Agda: "polynomial types"
module TypeDSL where
open import Data.Nat using (ℕ;_+_;_*_)

data E : Set where
  Zero  : E
  One   : E
  Add   : (x : E) -> (y : E) -> E
  Mul   : (x : E) -> (y : E) -> E

two : E
two = Add One One

four : E
four = Mul two two

-- First semantics: compute the natural number "value" of the expression
card : E -> ℕ
card Zero = 0
card One = 1
card (Add x y) = card x + card y
card (Mul x y) = card x * card y

data Empty : Set where
data Unit : Set where unit : Unit
data Either (a : Set) (b : Set) : Set where
  Left  : a -> Either a b
  Right : b -> Either a b
data Both (a : Set) (b : Set) : Set where
  _,_ : a -> b -> Both a b

-- Second semantics: compute the corresponding finite type
typ : E -> Set
typ Zero = Empty
typ One = Unit
typ (Add x y) = Either (typ x) (typ y)   -- disjoint union type    = sum type
typ (Mul x y) = Both   (typ x) (typ y)   -- cartesian product type = pair type

Bool : Set
Bool = typ two

false : Bool
false = Left unit
true : Bool
true = Right unit

BothBoolBool : Set
BothBoolBool = typ four

ex1 : BothBoolBool
ex1 = ( false , true )

open import Data.Vec as V

variable
  a b : Set
  m n : ℕ

enumAdd : Vec a m -> Vec b n -> Vec (Either a b) (m + n)
enumAdd as bs = V.map Left as ++ V.map Right bs

enumMul : Vec a m -> Vec b n -> Vec (Both   a b) (m * n)
enumMul as bs = concat (V.map (\ a -> V.map (\ b -> (a , b)) bs) as)

-- Third semantics: enumerate all the values in a vector
enumerate : (t : E) -> Vec (typ t) (card t)
enumerate Zero = []
enumerate One = [ unit ]
enumerate (Add x y) = enumAdd (enumerate x) (enumerate y)
enumerate (Mul x y) = enumMul (enumerate x) (enumerate y)

test2 : Vec (typ two) (card two) -- Vec Bool 2
test2 = enumerate two
  -- false ∷ true ∷ []

test4 : Vec (typ four) (card four) -- Vec BothBoolBool 4
test4 = enumerate four
{-
(false , false) ∷
(false , true) ∷
(true , false) ∷
(true , true) ∷ []
-}

-- Exercise: add a constructor for function types


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

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

module Rings.Divisible.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

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

divisionTransitive : (x y z : A) → x ∣ y → y ∣ z → x ∣ z
divisionTransitive x y z (a , pr) (b , pr2) = (a * b) , transitive (transitive *Associative (*WellDefined pr reflexive)) pr2

divisionReflexive : (x : A) → x ∣ x
divisionReflexive x = 1R , transitive *Commutative identIsIdent

everythingDividesZero : (r : A) → r ∣ 0R
everythingDividesZero r = 0R , timesZero

nonzeroInherits : {x y : A} (nz : (x ∼ 0R) → False) → y ∣ x → (y ∼ 0R) → False
nonzeroInherits {x} {y} nz (c , pr) y=0 = nz (transitive (symmetric pr) (transitive (*WellDefined y=0 reflexive) (transitive *Commutative timesZero)))

nonunitInherits : {x y : A} (nonunit : Unit x → False) → x ∣ y → Unit y → False
nonunitInherits nu (s , pr) (a , b) = nu ((s * a) , transitive (transitive *Associative (*WellDefined pr reflexive)) b)


data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

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

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

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

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]      ++ ys = ys
x :: xs ++ ys = x :: (xs ++ ys)

data Vec (A : Set) : ℕ -> Set where
  nil  : Vec A O
  cons : (n : ℕ) -> A -> Vec A n -> Vec A (S n)

head : {A : Set} {n : ℕ} -> Vec A (S n) -> A
head (cons n v vs) = v

vmap : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap .O f nil = nil
vmap .(S n) f (cons n x xs) = cons n (f x) (vmap n f xs)

vmap′ : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap′ O f nil = nil
vmap′ (S n) f (cons .n x xs) = cons n (f x) (vmap n f xs)

data Fin : ℕ -> Set where
  fzero : {n : ℕ} -> Fin (S n)
  fsuc  : {n : ℕ} -> Fin n -> Fin (S n)

_!_ : {n : ℕ}{A : Set} -> Vec A n -> Fin n -> A
nil ! ()
cons n x a ! fzero = x
cons n x a ! fsuc b = a ! b

tabulate : {n : ℕ}{A : Set} -> (Fin n -> A) -> Vec A n
tabulate {O} f = nil
tabulate {S n} f = cons n (f fzero) (tabulate (f ∘ fsuc))

data   False : Set where
record True  : Set where

trivial : True
trivial = _

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

_<_ : ℕ -> ℕ -> Bool
_   < O   = false
O   < S n = true
S m < S n = m < n

length : {A : Set} -> List A -> ℕ
length [] = O
length (x :: xs) = S (length xs)

lookup : {A : Set}(xs : List A)(n : ℕ) -> isTrue (n < length xs) -> A
lookup (x :: xs) O b = x
lookup (x :: xs) (S n) b = lookup xs n b
lookup [] a ()

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

data _≤_ : ℕ -> ℕ -> Set where
  ≤O : {m n : ℕ} -> m == n -> m ≤ n
  ≤I : {m n : ℕ} -> m ≤  n -> m ≤ S n

leq-trans : {l m n : ℕ} -> l ≤ m -> m ≤ n -> l ≤ n
leq-trans a (≤O refl) = a
leq-trans a (≤I b)    = ≤I (leq-trans a b)

min : ℕ -> ℕ -> ℕ
min a b with a < b
min a b | true  = a
min a b | false = b

filter : {A : Set} -> (A -> Bool) -> List A -> List A
filter f [] = []
filter f (x :: xs) with f x
... | true  = x :: filter f xs
... | false =      filter f xs

data _≠_ : ℕ -> ℕ -> Set where
  z≠s : {n : ℕ}   -> O   ≠ S n
  s≠z : {n : ℕ}   -> S n ≠ O
  s≠s : {m n : ℕ} -> n   ≠ m → S n ≠ S m

data Equal? (n m : ℕ) : Set where
  eq  : n == m -> Equal? n m
  neq : n ≠  m -> Equal? n m


{-# OPTIONS --cubical #-}
module ExerciseSession1 where

open import Part1 hiding (B)

-- We redefine B to be a family of types in this file
variable
  B : A → Type ℓ

-- Exercise 1: state and prove funExt for dependent functions f g : (x : A) → B x

-- Exercise 2: generalize the type of cong to dependent function f : (x : A) → B x
-- (hint: the result should be a PathP)

-- Exercise 3 (easy) state and prove that inhabited propositions are contractible

-- We could have stated isProp as follows:
isProp' : Type ℓ → Type ℓ
isProp' A = (x y : A) → isContr (x ≡ y)

-- Exercise 4 (easy): prove that isProp' A implies isProp A

-- For the converse we need path composition, see ExerciseSession2

-- Exercise 5: prove isPropΠ
isPropΠ : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x)
isPropΠ h = {!!}

-- Exercise 6: prove the inverse of funExt (sometimes called happly)
funExt⁻ : {f g : (x : A) → B x} → f ≡ g → ((x : A) → f x ≡ g x)
funExt⁻ p = {!!}

-- Exercise 7: use funExt⁻ to prove isSetΠ
isSetΠ : (h : (x : A) → isSet (B x)) → isSet ((x : A) → B x)
isSetΠ h = {!!}

-- We could have defined the type of singletons as follows
singl' : {A : Type ℓ} (a : A) → Type ℓ
singl' {A = A} a = Σ[ x ∈ A ] x ≡ a

-- Exercise 8 (harder): prove the corresponding version of contractibility of singetons for singl'
-- (hint: use a suitable combinations of connections and _~)
isContrSingl' : (x : A) → isContr (singl' x)
isContrSingl' x = {!!}


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Logic.PropositionalLogic
open import Functions.Definition
open import Numbers.Naturals.Naturals
open import Vectors
open import Boolean.Definition

module Logic.PropositionalAxiomsTautology where

axiomKTaut : {a : _} {A : Set a} (P Q : Propositions A) → Tautology (implies P (implies Q P))
axiomKTaut P Q v with inspect (Valuation.v v P)
axiomKTaut P Q v | BoolTrue with≡ pT with inspect (Valuation.v v Q)
axiomKTaut P Q v | BoolTrue with≡ pT | BoolTrue with≡ qT = Valuation.vImplicationT v (Valuation.vImplicationT v pT)
axiomKTaut P Q v | BoolTrue with≡ pT | BoolFalse with≡ qF = Valuation.vImplicationT v (Valuation.vImplicationVacuous v qF)
axiomKTaut P Q v | BoolFalse with≡ pF = Valuation.vImplicationVacuous v pF

axiomSTaut : {a : _} {A : Set a} (P Q R : Propositions A) → Tautology (implies (implies P (implies Q R)) (implies (implies P Q) (implies P R)))
axiomSTaut P Q R v with inspect (Valuation.v v P)
axiomSTaut P Q R v | BoolTrue with≡ pT with inspect (Valuation.v v Q)
axiomSTaut P Q R v | BoolTrue with≡ pT | BoolTrue with≡ qT with inspect (Valuation.v v R)
axiomSTaut P Q R v | BoolTrue with≡ pT | BoolTrue with≡ qT | BoolTrue with≡ rT = Valuation.vImplicationT v (Valuation.vImplicationT v (Valuation.vImplicationT v rT))
axiomSTaut P Q R v | BoolTrue with≡ pT | BoolTrue with≡ qT | BoolFalse with≡ rF = Valuation.vImplicationVacuous v (Valuation.vImplicationF v pT (Valuation.vImplicationF v qT rF))
axiomSTaut P Q R v | BoolTrue with≡ pT | BoolFalse with≡ qF = Valuation.vImplicationT v (Valuation.vImplicationVacuous v (Valuation.vImplicationF v pT qF))
axiomSTaut P Q R v | BoolFalse with≡ pF = Valuation.vImplicationT v (Valuation.vImplicationT v (Valuation.vImplicationVacuous v pF))

excludedMiddleTaut : {a : _} {A : Set a} (P : Propositions A) → Tautology (implies (prNot (prNot P)) P)
excludedMiddleTaut P v with inspect (Valuation.v v P)
excludedMiddleTaut P v | BoolTrue with≡ pT = Valuation.vImplicationT v pT
excludedMiddleTaut P v | BoolFalse with≡ pF = Valuation.vImplicationVacuous v (Valuation.vImplicationF v (Valuation.vImplicationVacuous v pF) (Valuation.vFalse v))

propositionalAxiomsTautology : {a : _} {A : Set a} (x : Sg ThreeElements (indexAxiom A)) → Tautology (IsSubset.ofElt propositionalAxioms x)
propositionalAxiomsTautology (One , (fst ,, snd)) = axiomKTaut fst snd
propositionalAxiomsTautology (Two , record { one = one ; two = two ; three = three }) = axiomSTaut one two three
propositionalAxiomsTautology (Three , b) = excludedMiddleTaut b


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 30, 2007

                Hello Agda!

                Ulf Norell

-}

-- Now we're getting somewhere! Inductive families of datatypes.

module Families where

-- You can import modules defined in other files.
-- More details later...
--open import Naturals

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

infixl 60 _+_
infixl 80 _*_

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

_*_ : Nat -> Nat -> Nat
zero  * m = zero
suc n * m = m + n * m

-- Think of an inductive family...
module Vec where

  data Vec (A : Set) : Nat -> Set where
    []   : Vec A zero
    _::_ : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

  infixr 40 _::_

  -- Some simple functions
  head : {A : Set}{n : Nat} -> Vec A (suc n) -> A
  head (x :: _) = x  -- no need for a [] case

  -- Does the definition look familiar?
  map : {A B : Set}{n : Nat} -> (A -> B) -> Vec A n -> Vec B n
  map f []        = []
  map f (x :: xs) = f x :: map f xs

  t1 : Vec Nat (suc (suc zero))
  t1 = map (_+_ three) (zero :: suc three :: [])
     where three = suc (suc (suc zero))

  infixr 40 _++_

  _++_ : {A : Set}{n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
  []        ++ ys = ys
  (x :: xs) ++ ys = x :: (xs ++ ys)

{-

  Wait a second.. what's really going on here?

  All the indices were conveniently implicit!

-}

-- Ok. Let's make the implicit stuff explicit.
{-
module WhatsGoingOnHere? where

  open Vec using (Vec; []; _::_)
-}

  -- Now what's this funny dot thing?
  map' : {A B : Set}(n : Nat) -> (A -> B) -> Vec A n -> Vec B n
  map' .zero    f []              = []
  map' .(suc _) f (x :: xs) = f x :: map' _ f xs

  -- Basically the dot means: inside is not a pattern at all but a
  -- term whose value is uniquely determined by type checking
  -- the actual pattern.

  -- In the cases above the types of the patterns
  --   [] and (_::_ {n} x xs)
  -- forces the first argument to be zero and suc n respectively.
  -- So, that's what we write.

  -- We could spend hours talking about this, but let's move on...

-- Let's do some other interesting families.

-- The identity type.
data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

infix 30 _==_
infix 20 ¬_

-- In the presence of families we get a lot more empty types.

data Bool : Set where
  true  : Bool
  false : Bool

data False : Set where

¬_ : Set -> Set
¬ A = A -> False

_≠_ : {A : Set} -> A -> A -> Set
x ≠ y = ¬ x == y

true≠false : true == false -> False -- true ≠ false
true≠false ()

-- [The following example might have worked at AIM6, but it does not
-- work now, so I commented it out. /NAD]

-- lem : (n : Nat) -> n == suc n -> False
-- lem n ()

-- Why does this work: true == false is an empty type.

{-

  What's next?

-}

-- Actually, inductive families are sufficiently fun that
-- you'll never get bored, but there's even more fun to be had.

-- Move on to: With.agda


-- notes-01-monday.agda

open import Data.Nat
open import Data.Bool

f : ℕ → ℕ
f x = x + 2

{-
    f 3 =
  = (x + 2)[x:=3] =
  = 3 + 2 =
  = 5
-}

n : ℕ
n = 3

f' : ℕ → ℕ
f' = λ x → x + 2 -- λ function (nameless function)

{-
    f' 3 =
  = (λ x → x + 2) 3 =
  = (x + 2)[x := 3] = -- β-reduction
  = 3 + 2 =
  = 5
-}

g : ℕ → ℕ → ℕ -- currying
g = λ x → (λ y → x + y)

k : (ℕ → ℕ) → ℕ
k h = h 2 + h 3

{-
    k f =
  = f 2 + f 3 =
  = (2 + 2) + (3 + 2) =
  = 4 + 5 =
  = 9
-}

variable
  A B C : Set -- polymorphic: Set actually means "type"

id : A → A
id x = x

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

{-
  A combinator is a high-order function that uses only function application and
  other combinators.
-}
K : A → B → A
K x y = x

S : (A → B → C) → (A → B) → A → C
S f g x = f x (g x)

-- in combinatory logic, every pure λ-term can be translated into S,K
-- λ x → f x = f -- η-equality


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

-- A category where the Homs are not sets, but commutative monoids
-- There are weak kind of Ab-enriched.
-- The reason to do these "by hand" is that the
-- "free commutative monoid monad", i.e. Bag, is very hard to work
-- with in type theory, so it is easier to work axiomatically.

open import Level
open import Algebra.Bundles using (CommutativeMonoid)
open import Function.Base using (flip)
open import Relation.Binary using (Rel; IsEquivalence)

open import Categories.Category.Core using (Category)

record CM-Category (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  infix  4 _≈_ _⇒_
  infixr 9 _∘_
  infixl 7 _+_

  open CommutativeMonoid using (_∙_; ε) renaming (Carrier to ∣_∣)
  field
    Obj : Set o
    Hom : (A B : Obj) → CommutativeMonoid ℓ e

  _⇒_ : (A B : Obj) → Set ℓ
  A ⇒ B = ∣ Hom A B ∣

  _+_ : {A B : Obj} → A ⇒ B → A ⇒ B → A ⇒ B
  _+_ {A} {B} f g = _∙_ (Hom A B) f g

  0M : {A B : Obj} → A ⇒ B
  0M {A} {B} = ε (Hom A B)

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

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

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

    -- preservation of additive structure
    +-resp-∘ : ∀ {A B C D} {f g : B ⇒ C} {h : A ⇒ B} {k : C ⇒ D} →
      k ∘ (f + g) ∘ h ≈ k ∘ f ∘ h + k ∘ g ∘ h

    0-resp-∘ : ∀ {A C D} {h : A ⇒ C} {k : C ⇒ D} → k ∘ 0M ∘ h ≈ 0M

Underlying : {o ℓ e : Level} → CM-Category o ℓ e → Category o ℓ e
Underlying C = record { CM-Category C }