-- notes-05-friday.agda

open import mylib

-- Π-types = dependent function types
Π : (A : Set)(B : A → Set) → Set
Π A B = (x : A) → B x

syntax Π A (λ x → P)  = Π[ x ∈ A ] P

-- Σ-types = dependent pair type

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

open Σ

syntax Σ A (λ x → P)  = Σ[ x ∈ A ] P

List' : Set → Set
List' A = Σ[ n ∈ ℕ ] Vec A n

List'' : Set → Set -- ex: show that this is isomorphic to lists
List'' A = Σ[ n ∈ ℕ ] Fin n → A

{-
  Container representation of lists.
  Set of shapes S = ℕ.
  Family of positions P : ℕ → Set, P = Fin.
  All strictly positive types can be represented as containers ( ~ polynomial
  functors) !
-}

{-
A → B = Π[ _ ∈ A ] B
A × B = Σ[ _ ∈ A ] B
-}

_⊎'_ : Set → Set → Set
A ⊎' B = Σ[ b ∈ Bool ] F b
         where F : Bool → Set
               F true = A
               F false = B

_×'_ : Set → Set → Set -- exercise: show that this equivalent to ⊎
A ×' B = Π[ b ∈ Bool ] F b
         where F : Bool → Set
               F true = A
               F false = B

{-
  "Propositions as types": for predicate logic
  P : A → prop = dependent type
-}

All : (A : Set)(P : A → prop) → prop
All A P = Π[ x ∈ A ] P x

Ex : (A : Set)(P : A → prop) → prop
Ex A P = Σ[ x ∈ A ] P x

syntax All A (λ x → P)  = ∀[ x ∈ A ] P
infix 0 All
syntax Ex A (λ x → P) = ∃[ x ∈ A ] P
infix 0 Ex

variable PP QQ : A → prop

taut : (∀[ x ∈ A ] PP x ⇒ Q) ⇔ (∃[ x ∈ A ] PP x) ⇒ Q
proj₁ taut f (a , pa) = f a pa
proj₂ taut g a pa = g (a , pa)

data _≡_ : A → A → prop where
  refl : {a : A} → a ≡ a

infix 4 _≡_

-- inductive definition of equality: _≡_ is an equivalence relation

sym : (a b : A) → a ≡ b → b ≡ a
sym a .a refl = refl

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

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

{-
  Proving that + is associative

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

assoc : (i j k : ℕ) → (i + j) + k ≡ i + (j + k)
assoc zero j k = refl
assoc (suc i) j k = cong suc (assoc i j k)

-- proof by induction = pattern matching + recursion

ind : (P : ℕ → Set)
    → P 0
    → ((n : ℕ) → P n → P (suc n))
    → (n : ℕ) → P n
ind P z s zero = z
ind P z s (suc n) = s n (ind P z s n)

-- eliminator for ℕ = induction/dependent recursion

{-
data _≡_ : A → A → prop where
  refl : {a : A} → a ≡ a

  What is ind for equality?
-}

ind≡ : (P : (a b : A) → a ≡ b → prop)
       (r : (a : A) → P a a refl)
       → (a b : A)(p : a ≡ b) → P a b p
ind≡ P r a .a refl = r a

-- Ex. derive sym, trans, cong from ind≡ (= J)

uip : (a b : A)(p q : a ≡ b) → p ≡ q
uip = ind≡ (λ a b p → (q : a ≡ b) → p ≡ q) λ a q →
           {!!}
--uip refl refl = refl

{-
  Is uip derivable from J ? Hofmann & Streicher: groupoid model of type theory.
  Restricted version of HoTT (infinity groupoid model of TT); observed: version
  of univalence in this theory. Voevodsky formulated HoTT, which supports full
  univalence.
-}


module sortedLists where

open import lib

{- we use internal verification to define a datatype of sorted lists
   of natural numbers, where typing ensures that the lists are truly
   sorted in non-decreasing order.

   A list of type (sortedList n) is sorted and guaranteed to have
   all its data greater than or equal to n; so n is a lower bound
   on the data in the list.  Keeping this lower bound explicit in
   the type enables us to require a proof of a constant-time check,
   namely d ≤ n, when insert d into a list with lower-bound n.  For
   cons nodes, we allow the lower-bound to be less than the head of
   the list.  This is needed for merge below.

   There are three constructors:

   -- nil, as usual (empty list)
   -- cons, as usual (build a new list from head and tail)
   -- weaken, decrease the lower bound (this was missing in my first
      attempt, which led to nasty problems in the case of merge below)

 -}

data sortedList : ℕ → Set where
  nil : ∀ (n : ℕ) → sortedList n  -- empty lists can have any lower bound you like
  cons : ∀ (d : ℕ) → -- the head of the list
           {n : ℕ} → -- the lower-bound for the tail
           sortedList n → -- the tail of the list, with lower bound n on its data
           d ≤ n ≡ tt → {- proof that d is less than or equal to that lower bound, and
                           hence less than or equal to all data in the tail -}
           sortedList d -- d is the lower bound for the new list created by the cons
  weaken : ∀ (n : ℕ) {n' : ℕ} → sortedList n' → n ≤ n' ≡ tt → sortedList n

-- fill in the holes below, just to help you get a feel for how the sortedList datatype works
-- [5 points]
simple : sortedList 1
simple = weaken 1 (cons 2 (nil 3) refl)refl

{- glb stands for greatest lower bound.  min d n is the greatest
   lower bound of d and n, in the sense that if any other d' is a lower bound
   of both d and n, then it is also a lower bound of min d n.  (Ideas from
   basic lattice theory.)

   To prove this, you will run into a mess if you case split on d', d, or n.
   Instead, you should consider cases for whether or not d < n.  You can use
   "with" for this, as discussed in Section 4.3.3 (page 86) of the book.
   -}
-- [10 points]
glb : ∀ d' d n → d' ≤ d ≡ tt → d' ≤ n ≡ tt → d' ≤ min d n ≡ tt
glb d' d n x y with keep (d < n)
... | tt , p rewrite p = x
... | ff , p rewrite p = y
{- insert d xs should insert d into xs as the right position to keep the list
   sorted.

   So you will case split on xs (the sortedList), and in the cons case,
   consider whether the data you are inserting is ≤ the data at the head of the
   list.

   I found I needed to use the "with keep" idiom; see Section 4.3.3 (page 90).

   Another hint: I also needed a few theorems from nat-thms.agda in the IAL:

     <≤, min-mono2, <ff

  Note that you can pattern match on implicit arguments, for example for a cons, like this:

  (cons d' {n} xs x)

  The {n} is used to match on that implicit lower-bound for the sortedList xs.

  [15 points]
-}

insert : ∀ (d : ℕ) → {n : ℕ} → sortedList n → sortedList (min d n)
insert d (nil n) with keep ( d < n )
... | tt , p rewrite p = cons d (nil n) (<≤ {d} p)
... | ff , p rewrite p = weaken n (cons d (nil d) (≤-refl d)) (<ff {d} p)

insert d (cons d1 {n} xs x) with keep ( d < d1 )
... | tt , p rewrite p = cons d ( cons d1 {n} xs x ) ( <≤ {d} {d1} p )
... | ff , p rewrite p  = cons d1 (nil d) (<ff {d} {d1} p )

insert d (weaken d1 {n} xs x) with keep ( d < d1 )
... | tt , p rewrite p =  cons d ( weaken d1 xs x ) ( <≤ {d} p )
... | ff , p rewrite p = weaken d1 (insert d xs) (glb d1 d n (<ff {d} p) x)
{- Write code to merge two sorted lists.

   I found I needed these lemmas from the IAL:

   min-<1, min-<2, <ff, <≤

   Additionally, I found I could save myself some cases by considering these cases for two input lists:

     nil and ys

     xs and nil

     weaken and ys

     xs and weaken

     cons and cons

   This is just five cases, instead of the nine that would be required if you considered the three
   cases for the first list simultaneously with the three for the second (3 * 3 gives 9 cases).
   You will see light gray highlighting on the patterns in the cases if you do this, but that
   is ok (it is just Agda warning you that you are not breaking out all the cases explicitly).

   [20 points]
-}
merge : ∀ {n : ℕ} → sortedList n → {m : ℕ} → sortedList m → sortedList (min n m)
merge (nil d) (nil d1) with keep ( d < d1 )
... | tt , p rewrite p = weaken d (nil d1) (<≤ {d} p)
... | ff , p rewrite p = weaken d1 (nil d) (<ff {d} p)
merge (nil d) (cons d1 d1s pd1) with keep ( d < d1 )
... | tt , p rewrite p = weaken d (cons d1 d1s pd1 ) ( <≤ {d} p)
... | ff , p rewrite p = cons d1 d1s pd1
merge ( nil d ) ( weaken d1 d1s pd1 ) with keep ( d < d1 )
... | tt , p rewrite p = weaken d ( weaken d1 d1s pd1 ) ( <≤ {d} p )
... | ff , p rewrite p = weaken d1 d1s pd1
merge ( cons d ds pd ) ( nil d1 ) with keep ( d < d1 )
... | tt , p rewrite p = cons d ds pd
... | ff , p rewrite p = weaken d1 ( cons d ds pd ) ( <ff {d} p )
merge ( cons d {dn} ds pd ) ( cons d1 {d1n} d1s pd1 ) with keep ( d < d1 )
... | tt , p rewrite p = cons d ( merge ds ( cons d1 d1s pd1 ) ) ( glb d dn d1 pd ( <≤ {d} p ) )
... | ff , p rewrite p = cons d1 ( merge d1s ( cons d ds pd) ) ( glb d1 d1n d pd1 ( <ff {d} p ) )
merge ( cons d {dn} ds pd ) ( weaken d1 {d1n} d1s pd1 ) with keep ( d < d1 )
... | tt , p rewrite p = cons d ( merge ds ( weaken d1 d1s pd1 ) ) ( glb d dn d1 pd ( <≤ {d} p ) )
... | ff , p rewrite p = weaken d1 ( merge d1s ( cons d ds pd ) ) ( glb d1 d1n d pd1 ( <ff {d} p ) )
merge ( weaken d ds pd ) ( nil d1 ) with keep ( d < d1 )
... | tt , p rewrite p = weaken d ds pd
... | ff , p rewrite p = weaken d1 ( weaken d ds pd ) ( <ff {d} p )
merge ( weaken d {dn} ds pd ) ( cons d1 {d1n} d1s pd1 ) with keep ( d < d1 )
... | tt , p rewrite p = weaken d ( merge ds ( cons d1 d1s pd1 ) ) ( glb d dn d1 pd ( <≤ {d} p ) )
... | ff , p rewrite p = cons d1 ( merge d1s ( weaken d ds pd ) ) ( glb d1 d1n d pd1 ( <ff {d} p ) )
merge ( weaken d {dn} ds pd ) ( weaken d1 {d1n} d1s pd1 ) with keep ( d < d1 )
... | tt , p rewrite p = weaken d ( merge ds ( weaken d1 d1s pd1 ) ) ( glb d dn d1 pd ( <≤ {d} p ) )
... | ff , p rewrite p = weaken d1 ( merge d1s ( weaken d ds pd ) ) ( glb d1 d1n d pd1 ( <ff {d} p ) )


module plfa.Induction where

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

-- associativity of addition: (m + n) + p ≡ m + (n + p)
+-assoc : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc zero n p =
  begin
    (zero + n) + p ≡⟨⟩
    zero + (n + p)
  ∎
+-assoc (suc m) n p =
  begin
    (suc m + n) + p ≡⟨⟩
    suc (m + n) + p ≡⟨⟩
    suc ((m + n) + p) ≡⟨ cong suc (+-assoc m n p) ⟩
    suc (m + (n + p)) ≡⟨⟩
    suc m + (n + p)
  ∎

+-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

{-
  identity: m + 0 ≡ m, analogous to 0 + m ≡ m,
  which is the base case of addition
-}
+-identityʳ : ∀ (m : ℕ) → m + zero ≡ m
+-identityʳ zero =
  begin
    zero + zero ≡⟨⟩
    zero
  ∎
+-identityʳ (suc m) =
  begin
    suc m + zero ≡⟨⟩
    suc (m + zero) ≡⟨ cong suc (+-identityʳ m) ⟩
    suc m
  ∎

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

{-
  m + suc n ≡ suc (m + n), analogous to suc m + n ≡ suc (m + n),
  which is the inductive case of addition for ∀ (m n :ℕ)
-}
+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n =
  begin
    zero + suc n ≡⟨⟩
    suc (zero + n)
  ∎
+-suc (suc m) n =
  begin
    suc m + suc n ≡⟨⟩
    suc (m + suc n) ≡⟨ cong suc (+-suc m n) ⟩
    suc (suc (m + n)) ≡⟨⟩
    suc (suc m + n)
  ∎

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

-- commutativity: m + n ≡ n + m
+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m zero =
  begin
    m + zero ≡⟨ +-identityʳ m ⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
    m + suc n ≡⟨ +-suc m n ⟩
    suc (m + n) ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m) ≡⟨⟩
    suc n + m
  ∎

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

-- rearrange: (m + n) + (p + q) ≡ m + (n + p) + q
+-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
  ∎

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

+-swap′ : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap′ m n p rewrite +-comm′ m (n + p) | +-assoc′ n p m | +-comm′ p m  = refl

-- distributivity of multiplication over addition: (m + n) * p ≡ m * p + n * p
*-distrib-+ : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-distrib-+ zero n p =
  begin
    (zero + n) * p ≡⟨⟩
    zero * p + n * p
  ∎
*-distrib-+ (suc m) n p =
  begin
    (suc m + n) * p ≡⟨⟩
    suc (m + n) * p ≡⟨⟩
    p + (m + n) * p ≡⟨ cong (p +_) (*-distrib-+ m n p) ⟩
    p + (m * p + n * p) ≡⟨ sym (+-assoc p (m * p) (n * p)) ⟩
    p + m * p + n * p ≡⟨⟩
    suc m * p + n * p
  ∎

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

-- associativity of multiplication: (m * n) * p ≡ m * (n * p)
*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc zero n p =
  begin
    (zero * n) * p ≡⟨⟩
    zero * (n * p)
  ∎
*-assoc (suc m) n p =
  begin
    (suc m * n) * p ≡⟨⟩
    (n + m * n) * p ≡⟨ *-distrib-+ n (m * n) p ⟩
    n * p + (m * n) * p ≡⟨ cong ((n * p) +_) (*-assoc m n p) ⟩
    n * p + m * (n * p) ≡⟨⟩
    suc m * (n * p)
  ∎

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

-- multiplication by zero, analogous to the base case of multiplication.
n*0≡0 : ∀ (n : ℕ) → n * zero ≡ zero
n*0≡0 zero =
  begin
    zero * zero ≡⟨⟩
    zero
  ∎
n*0≡0 (suc n) =
  begin
    suc n * zero ≡⟨ n*0≡0 n ⟩
    zero
  ∎

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

-- multiplication, analogous to the inductive case of multiplication.
*-suc : ∀ (m n : ℕ) → m * suc n ≡ m + m * n
*-suc zero n =
  begin
    zero * suc n ≡⟨⟩
    zero + zero * n
  ∎
*-suc (suc m) n =
  begin
    suc m * suc n ≡⟨⟩
    suc n + m * suc n ≡⟨ cong (suc n +_) (*-suc m n) ⟩
    suc (n + (m + m * n)) ≡⟨ cong suc (sym (+-assoc n m (m * n))) ⟩
    suc (n + m + m * n) ≡⟨ cong suc (cong (_+ (m * n)) (+-comm n m)) ⟩
    suc (m + n + m * n) ≡⟨ cong suc (+-assoc m n (m * n)) ⟩
    suc m + (n + m * n) ≡⟨⟩
    suc m + suc m * n
  ∎

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

-- commutitavity of multiplication: m * n ≡ n * m
*-comm : ∀ (m n : ℕ) → m * n ≡ n * m
*-comm m zero =
  begin
    m * zero ≡⟨ n*0≡0 m ⟩
    zero * m
  ∎
*-comm m (suc n) =
  begin
    m * suc n ≡⟨ *-suc m n ⟩
    m + m * n ≡⟨ cong (m +_) (*-comm m n) ⟩
    m + n * m ≡⟨⟩
    suc n * m
  ∎

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

-- zero monus (n : ℕ)
0∸n≡0 : ∀ (n : ℕ) → zero ∸ n ≡ zero
0∸n≡0 zero =
  begin
    zero ∸ zero ≡⟨⟩
    zero
  ∎
0∸n≡0 (suc n) =
  begin
    zero ∸ suc n ≡⟨⟩
    zero
  ∎

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

-- associativity of monus: m ∸ n ∸ p ≡ m ∸ (n + p)
∸-+-assoc : ∀ (m n p : ℕ) → m ∸ n ∸ p ≡ m ∸ (n + p)
∸-+-assoc zero n p =
  begin
    zero ∸ n ∸ p ≡⟨ cong (_∸ p) (0∸n≡0 n) ⟩
    zero ∸ p ≡⟨ 0∸n≡0 p ⟩
    zero ≡⟨ sym (0∸n≡0 (n + p)) ⟩
    zero ∸ (n + p)
  ∎
∸-+-assoc (suc m) zero p =
  begin
    suc m ∸ zero ∸ p ≡⟨⟩
    suc m ∸ p ≡⟨⟩
    suc m ∸ (zero + p)
  ∎
∸-+-assoc (suc m) (suc n) p =
  begin
    suc m ∸ suc n ∸ p ≡⟨⟩
    m ∸ n ∸ p ≡⟨ ∸-+-assoc m n p ⟩
    m ∸ (n + p) ≡⟨⟩
    suc m ∸ suc (n + p) ≡⟨⟩
    suc m ∸ (suc n + p)
  ∎

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


module Ag02 where

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

+-assoc : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc zero n p =
  begin
    (zero + n) + p
  ≡⟨⟩
    n + p
  ≡⟨⟩
    zero + (n + p)
  ∎

+-assoc (suc m) n p =
  begin
    (suc m + n) + p
  ≡⟨⟩
    suc (m + n) + p
  ≡⟨⟩
    suc ((m + n) + p)
  ≡⟨ cong suc (+-assoc m n p) ⟩
    suc (m + (n + p))
  ≡⟨⟩
    suc m + (n + p)
  ∎

+-identityʳ : ∀ (m : ℕ) → m + 0 ≡ m
+-identityʳ zero =
  begin
    zero + 0
  ≡⟨⟩
    zero
  ∎
+-identityʳ (suc m) =
  begin
    suc m + zero
  ≡⟨⟩
    suc (m + zero)
  ≡⟨ cong suc (+-identityʳ m) ⟩
    suc m
  ∎

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n =
  begin
    zero + suc n
  ≡⟨⟩
    suc n
  ≡⟨⟩
    suc (zero + n)
  ∎
+-suc (suc m) n =
  begin
    suc m + suc n
  ≡⟨⟩
    suc (m + suc n)
  ≡⟨ cong suc (+-suc m n) ⟩
    suc (suc (m + n))
  ≡⟨⟩
    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) ⟩
    suc (n + m)
  ≡⟨⟩
    suc n + m
  ∎

+-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
  ∎

+-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

+-swap : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap m n p rewrite sym (+-assoc m n p) | +-comm m n | +-assoc n m p = refl

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

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

*-identityʳ : ∀ (n : ℕ) → n * 0 ≡ 0
*-identityʳ 0 = refl
*-identityʳ (suc n) rewrite *-identityʳ n = refl

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

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

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

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

^-distrib-+ : ∀ (m n p : ℕ) → m ^ (n + p) ≡ (m ^ n) * (m ^ p)
^-distrib-+ m 0 p rewrite +-identityʳ (m ^ p) = refl
^-distrib-+ m (suc n) p rewrite ^-distrib-+ m n p | *-assoc 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) rewrite ^-distrib-* m n p | sym (*-assoc (m * n) (m ^ p) (n ^ p))
  | *-assoc m n (m ^ p) | *-comm n (m ^ p) | *-assoc m ((m ^ p) * n) (n ^ p) | *-assoc (m ^ p) n (n ^ p)
  | *-assoc m (m ^ p) (n * (n ^ p)) = refl

^-identity : ∀ (p : ℕ) → 1 ^ p ≡ 1
^-identity zero = refl
^-identity (suc p) rewrite ^-identity p = refl

^-*-plus : ∀ (m n p : ℕ) → m ^ (n * p) ≡ (m ^ n) ^ p
^-*-plus m zero p rewrite ^-identity p = refl
^-*-plus m (suc n) p rewrite ^-distrib-+ m p (n * p) | ^-*-plus m n p | sym (^-distrib-* m (m ^ n) p) = refl

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

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

to : ℕ → Bin
to zero = 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)

inc-suc : ∀ (x : Bin) → from (inc x) ≡ suc (from x)
inc-suc nil = refl
inc-suc (x0 x) = refl
inc-suc (x1 x) rewrite inc-suc x | +-suc (from x) (from x + 0) = refl


module v01-02-induction where

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

plus-n-O : ∀ (n : nat) → n ≡ n + 0
plus-n-O    O  = refl
plus-n-O (S n) rewrite sym (plus-n-O n) = refl

minus-n-n : ∀ (n : nat) → minus n n ≡ 0
minus-n-n    O  = refl
minus-n-n (S n) rewrite sym (minus-n-n n) = refl

mult-0-r : ∀ (n : nat) → n * 0 ≡ 0
mult-0-r    O  = refl
mult-0-r (S n) rewrite mult-0-r n = refl

plus-n-Sm : ∀ (n m : nat) → S (n + m) ≡ n + (S m)
plus-n-Sm    O  m = refl
plus-n-Sm (S n) m rewrite sym (plus-n-Sm n m) = refl

plus-comm : ∀ (n m : nat) → n + m ≡ m + n
plus-comm    n     O  rewrite sym (plus-n-O n) = refl
plus-comm    O  (S m) rewrite sym (plus-n-O m) = refl
plus-comm (S n) (S m)
  rewrite
    sym (plus-n-Sm n m)
  | sym (plus-n-Sm m n)
  | plus-comm n m
  = refl

plus-assoc : ∀ (n m p : nat) → n + (m + p) ≡ (n + m) + p
plus-assoc    O  m p = refl
plus-assoc (S n) m p        --         S n + (m + p) ≡ S n + m + p
  rewrite
    plus-comm (S n + m) p        -- S (plus n (plus m p)) ≡ plus p (S (plus n m))
  | sym (plus-n-Sm p (plus n m)) -- S (plus n (plus m p)) ≡ S (plus p (plus n m))
  | plus-comm p (plus n m)       -- S (plus n (plus m p)) ≡ S (plus (plus n m) p)
  | plus-assoc n m p             -- S (plus (plus n m) p) ≡ S (plus (plus n m) p)
  = refl

double : (n : nat) → nat
double    O  = O
double (S n) = S (S (double n))

double-plus : ∀ (n : nat) → double n ≡ n + n
double-plus    O  = refl
double-plus (S n)          --     double (S n) ≡ S n + S n
                           -- S (S (double n)) ≡ S n + S n
  rewrite
    double-plus n          -- S (S (plus n n)) ≡ S (plus n (S n))
  | plus-n-Sm n n          -- S (plus n (S n)) ≡ S (plus n (S n))
  = refl

{-
Inconvenient in evenb def: recursive call on n - 2.
Makes inductibe proofs about evenb harder since may need IH about n - 2.
Following lemma gives alternative characterization of evenb (S n) that works better with induction.
-}

evenb-S : ∀ (n : nat) → evenb (S n) ≡ negb (evenb n)
evenb-S    O  = refl
evenb-S (S n)                 -- evenb (S (S n)) ≡ negb (evenb (S n))
                              --         evenb n ≡ negb (evenb (S n))
  rewrite
    evenb-S n                 --         evenb n ≡ negb (negb (evenb n))
  | negb-involutive (evenb n) --         evenb n ≡ evenb n
  = refl

mult-0-plus' : ∀ (n m : nat) → (0 + n) * m ≡ n * m
mult-0-plus'    O  m = refl
mult-0-plus' (S n) m       --     (0 + S n) * m ≡ S n * m
  rewrite plus-O-n {n}     -- plus m (mult n m) ≡ plus m (mult n m)
  = refl

plus-rearrange : ∀ (n m p q : nat)
  → (n + m) + (p + q) ≡ (m + n) + (p + q)
plus-rearrange n m p q
  rewrite plus-comm n m
  = refl

plus-swap : ∀ (n m p : nat)
  → n + (m + p) ≡ m + (n + p)
plus-swap n m p
  rewrite
    plus-assoc n m p
  | plus-comm  n m
  | plus-assoc m n p
  = refl

mult-comm : ∀ (m n : nat)
  → m * n ≡ n * m
mult-comm    O  n
  rewrite
    mult-O-l {n}
  | *0 n
  = refl
mult-comm (S m) n       --           S m * n ≡ n * S m
  rewrite               -- plus n (mult m n) ≡ plus (mult n m) n
    sym (mult-n-Sm n m)
  | plus-comm n (mult m n)
  | mult-comm m n
  = refl

leb-refl : ∀ (n : nat) → true ≡ (n <=? n)
leb-refl    O  = refl
leb-refl (S n) = leb-refl n

zero-nbeq-S : ∀ (n : nat) → (0 =? (S n)) ≡ false
zero-nbeq-S n = refl

andb-false-r : ∀ (b : bool) → andb b false ≡ false
andb-false-r true  = refl
andb-false-r false = refl

plus-ble-compat-l : ∀ (n m p : nat)
  → (n <=? m) ≡ true
  → ((p + n) <=? (p + m)) ≡ true
plus-ble-compat-l _ _    O  n<=?m = n<=?m
plus-ble-compat-l n m (S p) n<=?m = plus-ble-compat-l n m p n<=?m

S-nbeq-0 : ∀ (n : nat) → ((S n) =? 0) ≡ false
S-nbeq-0 n = refl

mult-1-l : ∀ (n : nat) → 1 * n ≡ n
mult-1-l    O  = refl
mult-1-l (S n) rewrite mult-1-l n = refl

all3-spec : ∀ (b c : bool)
  → orb
      (andb b c)
      (orb (negb b)
               (negb c))
  ≡ true
all3-spec  true  true = refl
all3-spec  true false = refl
all3-spec false  true = refl
all3-spec false false = refl

mult-plus-distr-r : ∀ (n m p : nat)
  → (n + m) * p ≡ (n * p) + (m * p)
mult-plus-distr-r    O  m p = refl
mult-plus-distr-r (S n) m p      --   (S n     + m) * p
                                 -- ≡  S n * p + m  * p
  rewrite
    mult-comm (S n + m) p        --   mult p (S (plus n m))
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  | sym (mult-n-Sm p (plus n m)) --   plus (mult p (plus n m)) p
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  | mult-comm p (plus n m)       --   plus (mult (plus n m) p) p
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  | mult-plus-distr-r n m p      --   plus (plus (mult n p) (mult m p)) p
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  | plus-comm (plus (mult n p) (mult m p)) p
                                 --   plus p (plus (mult n p) (mult m p))
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  | plus-assoc p (mult n p) (mult m p)
                                 --   plus (plus p (mult n p)) (mult m p)
                                 -- ≡ plus (plus p (mult n p)) (mult m p)
  = refl

mult-assoc : ∀ (n m p : nat)
  → n * (m * p) ≡ (n * m) * p
mult-assoc    O  m p = refl
mult-assoc (S n) m p                 -- S n * (m * p) ≡ S n * m * p
  rewrite
    mult-plus-distr-r m (mult n m) p -- plus (mult m p) (mult n (mult m p)) ≡
                                     -- plus (mult m p) (mult (mult n m) p)
  | mult-assoc n m p                 -- plus (mult m p) (mult (mult n m) p) ≡
                                     -- plus (mult m p) (mult (mult n m) p)
  = refl

eqb-refl : ∀ (n : nat) → true ≡ (n =? n)
eqb-refl    O  = refl
eqb-refl (S n) = eqb-refl n

plus-swap' : ∀ (n m p : nat)
  → n + (m + p) ≡ m + (n + p)
plus-swap' n m p           -- n + (m + p) ≡ m + (n + p)
  rewrite
    plus-assoc n m p       -- plus (plus n m) p ≡ plus m (plus n p)
  | plus-comm n m          -- plus (plus m n) p ≡ plus m (plus n p)
  | sym (plus-assoc m n p) -- plus m (plus n p) ≡ plus m (plus n p)
  = refl

{-

Exercise: 3 stars, standard, especially useful (binary_commute)
Prove this diagram commutes:

                            incr
              bin ----------------------> bin
               |                           |
    bin_to_nat |                           |  bin_to_nat
               |                           |
               v                           v
              nat ----------------------> nat
                             S

incrementing a binary number and then converting it to a (unary) natural number
yields the same result as
first converting it to a natural number and then incrementing
-}

bin-to-nat' : bin → nat
bin-to-nat'     Z  = 0
bin-to-nat' (B₀ x) =      double (bin-to-nat' x)
bin-to-nat' (B₁ x) = 1 + (double (bin-to-nat' x))

_ : bin-to-nat'         (B₀ (B₁ Z))  ≡ 2
_ = refl
_ : bin-to-nat'       (incr (B₁ Z))  ≡ 1 + bin-to-nat' (B₁ Z)
_ = refl
_ : bin-to-nat' (incr (incr (B₁ Z))) ≡ 2 + bin-to-nat' (B₁ Z)
_ = refl

--         PREServes
bin-to-nat-pres-incr : (b : bin) (n : nat)
  → bin-to-nat'       b  ≡   n
  → bin-to-nat' (incr b) ≡ S n
bin-to-nat-pres-incr     Z  n b≡n --           bin-to-nat (incr Z) ≡ S n
                                  --                             1 ≡ S n ; b≡n : 0 ≡ n
  rewrite sym b≡n                 --                             1 ≡ 1
  = refl
bin-to-nat-pres-incr (B₀ b) n b≡n --     bin-to-nat' (incr (B₀ b)) ≡ S n
                                  --    1 + double (bin-to-nat' b) ≡ S n
  rewrite b≡n                     --                           S n ≡ S n
  = refl
bin-to-nat-pres-incr (B₁ b) n b≡n --     bin-to-nat' (incr (B₁ b)) ≡ S n
                                  -- double (bin-to-nat' (incr b)) ≡ S n
                                  -- b≡n : 1 + double (bin-to-nat' b) ≡ n
  rewrite
    sym b≡n                       -- double (bin-to-nat' (incr b)) ≡ S (S (double (bin-to-nat' b)))
--  | bin-to-nat-pres-incr b n b≡n
  = {!!}

nat-to-bin : (n : nat) → bin
nat-to-bin n = {!!}

{-

Prove for any nat, convert it to binary; convert it back, get same nat
HINT If def of nat_to_bin uses other functions,
might need to prove lemma showing how functions relate to nat_to_bin.)

Theorem nat_bin_nat : ∀ n, bin_to_nat (nat_to_bin n) = n.
Proof.
  (* FILL IN HERE *) Admitted.

(b) One might naturally expect that we should also prove the opposite direction -- that starting with a binary number, converting to a natural, and then back to binary should yield the same number we started with. However, this is not the case! Explain (in a comment) what the problem is.

(* FILL IN HERE *)

(c) Define a normalization function -- i.e., a function normalize going directly from bin to bin (i.e., not by converting to nat and back) such that, for any binary number b, converting b to a natural and then back to binary yields (normalize b). Prove it. (Warning: This part is a bit tricky -- you may end up defining several auxiliary lemmas. One good way to find out what you need is to start by trying to prove the main statement, see where you get stuck, and see if you can find a lemma -- perhaps requiring its own inductive proof -- that will allow the main proof to make progress.) Don't define this using nat_to_bin and bin_to_nat!

(* FILL IN HERE *)
-}


open import Data.Nat using (ℕ; zero; suc; _+_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Data.Nat.Properties using (+-assoc; +-comm)

module Exercises.One where

_*_ : ℕ → ℕ → ℕ
zero * y = zero
suc x * y = y + (x * y)

-- Prove that multiplication is commutative
*-idʳ : ∀ x → x * 0 ≡ 0
*-idʳ zero = refl
*-idʳ (suc x) = *-idʳ x

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

*-comm : ∀ x y → x * y ≡ y * x
*-comm zero y rewrite *-idʳ y = refl
*-comm (suc x) y rewrite *-comm x y | *-suc y x = refl

-- Prove that if x + x ≡ y + y then x ≡ y (taken from CodeWars)
suc-injective : ∀ x y → suc x ≡ suc y → x ≡ y
suc-injective zero zero p = refl
suc-injective (suc x) (suc .x) refl = refl

xxyy : ∀ x y → x + x ≡ y + y → x ≡ y
xxyy zero zero refl = refl
xxyy (suc x) (suc y) p rewrite +-comm x (suc x) | +-comm y (suc y) =
  cong suc (xxyy x y (suc-injective _ _ (suc-injective _ _ p)))


-- ----------------------------------------------------------------------
-- The Agda σ-library
--
-- Substitutions
-- ----------------------------------------------------------------------

-- A substitution on T is defined as a mapping from
-- indices to T (w/ explicit bounds).
--
-- Since the domain is bounded, we may think
-- of substitutions as vectors.

module Sigma.Subst.Base where

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

open import Function using (_∘_)

open import Data.Product using (_×_) renaming ( _,_ to ⟨_,_⟩ )

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

-- A subsitution σ : 𝕀ⁿ → T is denoted { i ↦ x : i ∈ 𝕀ⁿ, x ∈ T }
Sub : Set → ℕ → Set
Sub T m = Fin m → T

-- The empty subsitution.
-- Note that 𝕀⁰ ≡ ⊥. We note σ : 𝕀⁰ → T by []
-- Intuitively, this mimics an empty vector.
[] : ∀ { T } → Sub T 0
[] = λ ()

infixr 5 _∷_

-- The σ-cons operator ∷ ∶ T → (𝕀ⁿ → T) → (𝕀¹⁺ⁿ → T)
--
-- Intuitively, the σ-cons operator mimics the
-- semantics of cons operator on vectors.
--
-- x ∷ σ = { 0 ↦ x } ∪ { 1 + i ↦ σ i : i ∈ 𝕀ⁿ }
_∷_ : ∀ { n } { T } → T → Sub T n → Sub T (1 + n)
(x ∷ σ) zero = x
(x ∷ σ) (suc n) = σ n

[_] : ∀ { T } → T → Sub T 1
[ x ] = x ∷ []

head : ∀ { n } { T } → Sub T (1 + n) → T
head σ = σ zero

tail : ∀ { n } { T } → Sub T (1 + n) → Sub T n
tail σ = σ ∘ suc

map : ∀ { n } { T U } → (T → U) → Sub T n → Sub U n
map f σ = f ∘ σ

uncons : ∀ { n } { T } → Sub T (1 + n) → T × Sub T n
uncons σ = ⟨ head σ , tail σ ⟩

infixr 5 _++_

-- The σ-append operator ++ : (𝕀ᵐ → T) → (𝕀ⁿ → T) → (𝕀ᵐ⁺ⁿ → T)
--
-- σ₁ ++ σ₂ = { i ↦ σ₁ i : i ∈ 𝕀ᵐ⁺ⁿ, i < m } ∪ { i ↦ σ₂ i : i ∈ 𝕀ᵐ⁺ⁿ, i ≥ m }
_++_ : ∀ { m n } { T } → Sub T m → Sub T n → Sub T (m + n)
_++_ {zero} σ₁ σ₂ = σ₂
_++_ {suc m} σ₁ σ₂ = σ₁ zero ∷ (σ₁ ∘ suc) ++ σ₂


module plfa.Relations where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym)
open import Data.Nat using (ℕ ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm)

data _≤_ : ℕ → ℕ → Set where

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

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

infix 4 _≤_

_ : 2 ≤ 4
_ = s≤s (s≤s z≤n)

_ : 2 ≤ 4
_ = s≤s {1} {3} (s≤s {0} {2} (z≤n {2}))

_ : 2 ≤ 4
_ = s≤s {m = 1} {n = 3} (s≤s {m = 0} {n = 2} (z≤n {n = 2}))

_ : 2 ≤ 4
_ = s≤s {n = 3} (s≤s {n = 2} z≤n)

inv-s≤s : ∀ { m n : ℕ }
  → suc m ≤ suc n
    -------------
  → m ≤ n
inv-s≤s (s≤s m≤n) = m≤n

inv-z≤n : ∀ { m : ℕ }
  → m ≤ zero
    --------
  → m ≡ zero
inv-z≤n z≤n = refl

-- @practice: exercise `orderings` start

-- _⊆_ relations has partial order property but not total order
-- adjacency relation has preorder property but not partial order

-- @practice: exercise `orderings` end

-- 自反: reflexive - refl
-- 传递: transitive - trans
-- 反对称: anti-symmetric - antisym
-- 完全: total - total

≤-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)


open import Relation.Binary.Core

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

open import Data.List
open import Function using (_∘_)
open import List.Sorted _≤_
open import Mergesort.Impl2 _≤_ tot≤
open import OList _≤_
open import OList.Properties _≤_

theorem-mergesort-sorted : (xs : List A) → Sorted (forget (mergesort xs))
theorem-mergesort-sorted = lemma-olist-sorted  ∘ mergesort


{-
  Computer Aided Formal Reasoning (G53CFR, G54CFR)
  Thorsten Altenkirch

  Lecture 2: A first taste of Agda

  In this lecture we start to explore the Agda system, a functional
  programming language based on Type Theory. We start with some
  ordinary examples which we could have developed in Haskell as well.
-}

module l02 where

-- module myNat where

  {- Agda has no automatically loaded prelude. Hence we can start from
     scratch and define the natural numbers. Later we will use the
     standard libray. -}

  data ℕ : Set where -- to type ℕ we type \bn
    zero : ℕ
    suc : (m : ℕ) → ℕ -- \-> or \to

  {- To process an Agda file we use C-c C-c from emacs. Once Agda has
     checked the file the type checker also colours the different
     symbols. -}

  {- We define addition. Note Agda's syntax for mixfix operations. The
     arguments are represented by _s -}

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

  {- Try to evaluate: (suc (suc zero)) + (suc (suc zero))
     by typing in C-c C-n -}

{- Better we import the library definition of ℕ
   This way we can type 2 instead of (suc (suc zero))
-}

-- open import Data.Nat

{- We define Lists :  -}

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

{- In future we'll use
     open import Data.List -}

{- declare the fixity of ∷ (type \::) -}

infixr 5 _∷_

{- Two example lists -}

{-
l1 : List ℕ
l1 = 1 ∷ 2 ∷ 3 ∷ []

l2 : List ℕ
l2 = 4 ∷ 5 ∷ []
-}

{- implementing append (++) -}

_++_ : {A : Set} → List A → List A → List A
[] ++ bs = bs
(a ∷ as) ++ bs = a ∷ (as ++ bs)

{- Note that Agda checks wether a function is terminating.
   If we type
   (a ∷ as) ++ bs = (a ∷ as) ++ bs
   in the 2nd line Agda will complain by coloring the offending
   function calls in red.
-}

{- What does the following variant of ++ do ? -}

_++'_ : {A : Set} → List A → List A → List A
as ++' [] = as
as ++' (b ∷ bs) = (b ∷ as) ++' bs

{- Indeed it can be used to define reverse.  This way to implement
   reverse is often called fast reverse because it is "tail recursive"
   which leads to a more efficient execution than the naive
   implementation. -}

rev : {A : Set} → List A → List A
rev as = [] ++' as

{- We tried to define a function which accesses the nth element of a list:

_!!_ : {A : Set} → List A → ℕ → A
[] !! n = {!!}
(a ∷ as) !! zero = a
(a ∷ as) !! suc n = as !! n

  but there is no way to complete the first line (consider what happens
  if A is the empty type!
-}

{- To fix this we handle errors explicitely, using Maybe -}

-- open import Data.Maybe

data Maybe (A : Set) : Set where
  just    : (x : A) → Maybe A
  nothing : Maybe A

{- This version of the function can either return an element of the list
    (just a) or an error (nothing).
-}
_!!_ : {A : Set} → List A → ℕ → Maybe A
[] !! n = nothing
(a ∷ as) !! zero = just a
(a ∷ as) !! suc n = as !! n


module Arithmetic where

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

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

  -- ℕ + ℕ =  succ (succ ℕ))

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


module *-distrib-+ where

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

open import Induction′ using (+-assoc; +-comm; +-suc)

-- 積が和に対して分配的であることの証明
*-distrib-+ : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-distrib-+ zero n p =
  begin
    (zero + n) * p
  ≡⟨⟩
    n * p
  ≡⟨⟩
    zero * p + n * p
  ∎
*-distrib-+ (suc m) n p =
  begin
    ((suc m) + n) * p
  ≡⟨ cong (_* p) (+-comm (suc m) n) ⟩
    (n + (suc m)) * p
  ≡⟨ cong (_* p) (+-suc n m) ⟩
    (suc (n + m)) * p
  ≡⟨⟩
    p + ((n + m) * p)
  ≡⟨ cong (p +_) (*-distrib-+ n m p) ⟩
    p + (n * p + m * p)
  ≡⟨ cong (p +_) (+-comm (n * p) (m * p)) ⟩
    p + (m * p + n * p)
  ≡⟨ sym (+-assoc p (m * p) (n * p)) ⟩
    (p + (m * p)) + n * p
  ≡⟨⟩
    (suc m) * p + n * p
  ∎


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

open import LogicalFormulae
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Numbers.Naturals.Semiring
open import Numbers.Integers.Integers
open import Groups.Definition

module Groups.Cyclic.Definition {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_·_ : A → A → A} (G : Group S _·_) where

open Setoid S
open Group G
open Equivalence eq
open import Groups.Lemmas G

positiveEltPower : (x : A) (i : ℕ) → A
positiveEltPower x 0 = Group.0G G
positiveEltPower x (succ i) = x · (positiveEltPower x i)

positiveEltPowerWellDefinedG : (x y : A) → (x ∼ y) → (i : ℕ) → (positiveEltPower x i) ∼ (positiveEltPower y i)
positiveEltPowerWellDefinedG x y x=y 0 = reflexive
positiveEltPowerWellDefinedG x y x=y (succ i) = +WellDefined x=y (positiveEltPowerWellDefinedG x y x=y i)

positiveEltPowerCollapse : (x : A) (i j : ℕ) → Setoid._∼_ S ((positiveEltPower x i) · (positiveEltPower x j)) (positiveEltPower x (i +N j))
positiveEltPowerCollapse x zero j = Group.identLeft G
positiveEltPowerCollapse x (succ i) j = transitive (symmetric +Associative) (+WellDefined reflexive (positiveEltPowerCollapse x i j))

elementPower : (x : A) (i : ℤ) → A
elementPower x (nonneg i) = positiveEltPower x i
elementPower x (negSucc i) = Group.inverse G (positiveEltPower x (succ i))

-- TODO: move this to lemmas
elementPowerWellDefinedZ : (i j : ℤ) → (i ≡ j) → {g : A} → elementPower g i ≡ elementPower g j
elementPowerWellDefinedZ i j i=j {g} = applyEquality (elementPower g) i=j

elementPowerWellDefinedZ' : (i j : ℤ) → (i ≡ j) → {g : A} → (elementPower g i) ∼ (elementPower g j)
elementPowerWellDefinedZ' i j i=j {g} = identityOfIndiscernablesRight _∼_ reflexive (elementPowerWellDefinedZ i j i=j)

elementPowerWellDefinedG : (g h : A) → (g ∼ h) → {n : ℤ} → (elementPower g n) ∼ (elementPower h n)
elementPowerWellDefinedG g h g=h {nonneg n} = positiveEltPowerWellDefinedG g h g=h n
elementPowerWellDefinedG g h g=h {negSucc x} = inverseWellDefined (+WellDefined g=h (positiveEltPowerWellDefinedG g h g=h x))

record CyclicGroup : Set (m ⊔ n) where
  field
    generator : A
    cyclic : {a : A} → (Sg ℤ (λ i → Setoid._∼_ S (elementPower generator i) a))


open import Relation.Binary.Core

module InsertSort.Impl2 {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Data.Sum
open import OList _≤_

insert : {b : Bound}{x : A} → LeB b (val x) → OList b → OList b
insert {b} {x} b≤x onil = :< b≤x onil
insert {b} {x} b≤x (:< {x = y} b≤y ys)
  with tot≤ x y
... | inj₁ x≤y = :< b≤x (:< (lexy x≤y) ys)
... | inj₂ y≤x = :< b≤y (insert (lexy y≤x) ys)

insertSort : List A → OList bot
insertSort [] = onil
insertSort (x ∷ xs) = insert {bot} {x} lebx (insertSort xs)


open import Relation.Binary.Core

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

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Data.Sum
open import Function
open import InsertSort.Impl2 _≤_ tot≤
open import List.Permutation.Alternative A renaming (_∼_ to _∼′_)
open import List.Permutation.Alternative.Correctness A
open import List.Permutation.Base A
open import OList _≤_

lemma-insert∼′ : {b : Bound}{x : A}(b≤x : LeB b (val x))(xs : OList b) → (x ∷ forget xs) ∼′ forget (insert b≤x xs)
lemma-insert∼′ b≤x onil = ∼refl
lemma-insert∼′ {x = x} b≤x (:< {x = y} b≤y ys)
    with tot≤ x y
... | inj₁ x≤y = ∼refl
... | inj₂ y≤x = ∼trans (∼swap ∼refl) (∼head y (lemma-insert∼′ (lexy y≤x) ys))

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

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


module 015-logic where

-- Simple propositional logic.

open import 010-false-true

-- Logical and. We represent a proof of A and B as a pair of proofs,
-- namely, a proof of A and a proof of B.

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

_∧_ : (A B : Set) -> Set
A ∧ B = Pair A B

-- Get back proof of any of the components.

a∧b->a : {A B : Set} -> A ∧ B -> A
a∧b->a (a , b) = a

a∧b->b : {A B : Set} -> A ∧ B -> B
a∧b->b (a , b) = b

-- Logical or. We represent a proof of A or B as a proof of A or a
-- proof of B.

data Either (A B : Set) : Set where
  left : A -> Either A B
  right : B -> Either A B

_∨_ : (A B : Set) -> Set
A ∨ B = Either A B

-- Negation.

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

-- Now some properties.

-- Commutativity.

a∧b->b∧a : ∀ {A B} -> A ∧ B -> B ∧ A
a∧b->b∧a ( a , b ) = ( b , a )

a∨b->b∨a : ∀ {A B} -> A ∨ B -> B ∨ A
a∨b->b∨a (left a) = right a
a∨b->b∨a (right b) = left b

-- Distributivity.

a∧[b∨c]->[a∧b]∨[a∧c] : ∀ {A B C} -> A ∧ (B ∨ C) -> (A ∧ B) ∨ (A ∧ C)
a∧[b∨c]->[a∧b]∨[a∧c] (a , left b) = left (a , b)
a∧[b∨c]->[a∧b]∨[a∧c] (a , right c) = right (a , c)

[a∧b]∨[a∧c]->a∧[b∨c] : ∀ {A B C} -> (A ∧ B) ∨ (A ∧ C) -> A ∧ (B ∨ C)
[a∧b]∨[a∧c]->a∧[b∨c] (left (a , b)) = (a , left b)
[a∧b]∨[a∧c]->a∧[b∨c] (right (a , c)) = (a , right c)

a∨[b∧c]->[a∨b]∧[a∨c] : ∀ {A B C} -> A ∨ (B ∧ C) -> (A ∨ B) ∧ (A ∨ C)
a∨[b∧c]->[a∨b]∧[a∨c] (left a) = (left a , left a)
a∨[b∧c]->[a∨b]∧[a∨c] (right (b , c)) = (right b , right c)

[a∨b]∧[a∨c]->a∨[b∧c] : ∀ {A B C} -> (A ∨ B) ∧ (A ∨ C) -> A ∨ (B ∧ C)
[a∨b]∧[a∨c]->a∨[b∧c] ( left a , _ ) = left a
[a∨b]∧[a∨c]->a∨[b∧c] ( _ , left a ) = left a
[a∨b]∧[a∨c]->a∨[b∧c] ( right b , right c ) = right (b , c)

-- Contraposition.

[a->b]->[¬b->¬a] : ∀ {A B} -> (A -> B) -> (¬ B -> ¬ A)
[a->b]->[¬b->¬a] a->b ¬b a = ¬b (a->b a)

-- Contradiction.

¬[a∧¬a] : ∀ {A} -> ¬ (A ∧ (¬ A))
¬[a∧¬a] ( a , ¬a ) = ¬a a

-- De Morgan.

¬[a∨b]->¬a∧¬b : ∀ {A B} -> ¬ (A ∨ B) -> (¬ A) ∧ (¬ B)
¬[a∨b]->¬a∧¬b ¬[a∨b] = (\a -> ¬[a∨b] (left a)) , (\b -> ¬[a∨b] (right b))

¬a∧¬b->¬[a∨b] : ∀ {A B} -> (¬ A) ∧ (¬ B) -> ¬ (A ∨ B)
¬a∧¬b->¬[a∨b] ( ¬a , ¬b ) (left a) =  ¬a a
¬a∧¬b->¬[a∨b] ( ¬a , ¬b ) (right b) =  ¬b b

¬a∨¬b->¬[a∧b] : ∀ {A B} -> (¬ A) ∨ (¬ B) -> ¬ (A ∧ B)
¬a∨¬b->¬[a∧b] (left ¬a) ( a , b ) = ¬a a
¬a∨¬b->¬[a∧b] (right ¬b) ( a , b ) = ¬b b

-- not provable, see https://math.stackexchange.com/questions/120187/does-de-morgans-laws-hold-in-propositional-intuitionistic-logic
-- ¬[a∧b]->¬a∨¬b : ∀ {A B} -> ¬ (A ∧ B) -> (¬ A) ∨ (¬ B)
-- ¬[a∧b]->¬a∨¬b ¬[a∧b] = {!!}


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

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

open import Data.List
open import Data.Product
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import Size
open import SList
open import SList.Properties
open import SelectSort _≤_ tot≤

lemma-select∼ : {ι : Size}(x : A) → (xs : SList A {ι}) → unsize A (x ∙ xs) ∼ unsize A (proj₁ (select x xs) ∙ proj₂ (select x xs))
lemma-select∼ x snil = ∼x /head /head ∼[]
lemma-select∼ x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = ∼x (/tail /head) (/tail /head) (lemma-select∼ x ys)
... | inj₂ y≤x = ∼x /head (/tail /head) (lemma-select∼ y ys)

lemma-selectSort∼ : {ι : Size}(xs : SList A {ι}) → unsize A xs ∼ unsize A (selectSort xs)
lemma-selectSort∼ snil = ∼[]
lemma-selectSort∼ (x ∙ xs) = trans∼ (lemma-select∼ x xs) (∼x /head /head (lemma-selectSort∼ (proj₂ (select x xs))))

theorem-selectSort∼ : (xs : List A) → xs ∼ unsize A (selectSort (size A xs))
theorem-selectSort∼ xs = trans∼ (lemma-unsize-size A xs) (lemma-selectSort∼ (size A xs))


{-# OPTIONS --without-K #-}
module hott.core.equality where

open import hott.core.universe

-- | The equality type. In hott we think of the equality type as paths
-- between two points in the space A. To simplify the types we first
-- fix the common parameters.

module common {a : Level}{A : Type a} where

  data _≡_ (x : A) : (y : A) → Type a where
    refl : x ≡ x

  -- Induction principle for ≡ type.
  induction≡ : {ℓ : Level}
             → (D : {x y : A} (p : x ≡ y) → Type ℓ)
             → (d : {x : A} → D {x} {x} refl)
             → {x y : A} → (p : x ≡ y) → D p
  induction≡ D d refl = d

  -- In hott view point, this function takes the inverse of the path
  -- from x to y. As a relation you are proving that ≡ is symmetric.
  _⁻¹ : ∀{x y}
      → x ≡ y → y ≡ x
  refl ⁻¹ = refl

  -- The path composition. This means transitivity of the ≡ relation.
  _∙_ : ∀ {x y z}
      → x ≡ y → y ≡ z → x ≡ z
  refl ∙ refl = refl

  infixr 1 _≡_

  -- Precedence of multiplication
  infixl 70 _∙_

  -- Precedence of exponentiation.
  infixl 90 _⁻¹
  -- Equational reasoning
  -- To prove x_0 = x_n by a sequence of proofs
  -- x_0 = x_1
  -- x_1 = x_2
  -- ... you can use the following syntax
  --
  -- begin x_0 ≅ x_1 by p1
  --           ≅ x_2 by p2
  --       ....
  --           ≅ x_n by pn
  -- ∎
  --

  -- In equational proofs, it is more readable to use by definition
  -- than by refl
  definition : ∀{x} → x ≡ x
  definition = refl

  begin_ : (x : A)
         → x ≡ x
  begin_ x = refl

  _≡_by_ : ∀ {x y : A}
         → x ≡ y
         → (z : A)
         → y ≡ z
         → x ≡ z
  p ≡ z by q = p ∙ q

  _∎ : ∀{x y : A}
     → (x ≡ y)
     → (x ≡ y)
  proof ∎ = proof

  infixl 2 begin_
  infixl 1 _≡_by_
  infixl 0 _∎

  -- We now capture path transportation in the following submodule.
  module Transport {ℓ : Level} where
    -- Path transportation.
    transport : ∀ {x y : A}
              → x ≡ y
              → {P : A → Type ℓ}
              → P x → P y
    transport refl = λ z → z

    -- Another symbol for transport. Use it when you do not want to
    -- specify P.
    _⋆ : {P : A → Type ℓ}
     → {x y : A}
     → x ≡ y
     → P x → P y
    p ⋆ = transport p

  open Transport public

open common public

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

-- The functional congruence, i.e. likes gives likes on application of
-- a function. In the HoTT perspective this says that functions are
-- functors.
ap : ∀ {a b : Level} {A : Type a}{B : Type b} {x y : A}
     → (f : A → B)
     → x ≡ y → (f x) ≡ (f y)
ap f refl = refl

-- The dependent version of ap. This requires transport for its
-- definition.
apd : ∀{a b : Level }{A : Type a}{B : A → Type b}
    → (f : (a : A) → B a)
    → {x y : A}
    → (p : x ≡ y)
    → (p ⋆) (f x) ≡ f y
apd f refl = refl

-- Better syntax fro ap in equational reasoning.
applying_on_ : ∀{ℓ₀ ℓ₁}{A : Type ℓ₀}{B : Type ℓ₁}
             → (f : A → B)
             → {x y : A}
             → (p : x ≡ y)
             → f x ≡ f y
applying_on_ f a = ap f a

-- Better syntax for dependent version of applying on both sides.
transporting_over_ : ∀{ℓ₀ ℓ₁}{A : Type ℓ₀}{B : A → Type ℓ₁}
                   → (f : (a : A) → B(a)){x y : A}
                   → (p : x ≡ y)
                   → (p ⋆) (f x) ≡ f y
transporting f over p = apd f p

infixr 2 applying_on_
infixr 2 transporting_over_


-- {-# OPTIONS  --sized-types --show-implicit #-}

module _ where

open import Common.Size

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

caseEither : ∀{A B C : Set} → Either A B → (A → C) → (B → C) → C
caseEither (left  a) l r = l a
caseEither (right b) l r = r b

data Nat {i : Size} : Set where
  zero : Nat
  suc  : {i' : Size< i} → Nat {i'} → Nat

-- subtraction is non size increasing
sub : {size : Size} → Nat {size} → Nat {∞} → Nat {size}
sub zero    n       = zero
sub (suc m) zero    = suc m
sub (suc m) (suc n) = sub m n

-- div' m n  computes  ceiling(m/(n+1))
div' : {size : Size} → Nat {size} → Nat → Nat {size}
div' zero    n = zero
div' (suc m) n = suc (div' (sub m n) n)

-- one can use sized types as if they were not sized
-- sizes default to ∞

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

nisse : {i : Size} → Nat {i} → Nat {i}
nisse zero          = zero
nisse (suc zero)    = suc zero
nisse (suc (suc n)) = suc zero

-- symmetric difference
-- @diff n m@ returns @left (n - m)@ if @n@ is bigger, otherwise @right (m - n)@
diff : ∀{i j} → Nat {i} → Nat {j} → Either (Nat {i}) (Nat {j})
diff zero    m       = right m
diff (suc n) zero    = left (suc n)
diff (suc n) (suc m) = diff n m

module Case where
  gcd : ∀{i j} → Nat {i} → Nat {j} → Nat
  gcd zero    m       = m
  gcd (suc n) zero    = suc n
  gcd (suc n) (suc m) = caseEither (diff n m)
    (λ n' → gcd n' (suc m))
    (λ m' → gcd (suc n) m')

module With where
  gcd : ∀{i j} → Nat {i} → Nat {j} → Nat
  gcd zero    m       = m
  gcd (suc n) zero    = suc n
  gcd (suc n) (suc m) with diff n m
  ... | left  n' = gcd n' (suc m)
  ... | right m' = gcd (suc n) m'

NatInfty = Nat {∞}

{-# BUILTIN NATURAL  NatInfty  #-}
-- {-# BUILTIN NATPLUS     add       #-} -- not accepted


{-# OPTIONS --no-termination-check #-}

module Data.Nat where

import Prelude
import Data.Bool as Bool

open Prelude
open Bool

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

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN SUC suc #-}
{-# BUILTIN ZERO zero #-}

infix 40 _==_ _<_ _≤_ _>_ _≥_
infixl 60 _+_ _-_
infixl 70 _*_
infixr 80 _^_
infix 100 _!

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

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

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

_^_ : Nat -> Nat -> Nat
n ^ zero  = 1
n ^ suc m = n * n ^ m

_! : Nat -> Nat
zero  ! = 1
suc n ! = suc n * n !

{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATMINUS _-_ #-}
{-# BUILTIN NATTIMES _*_ #-}

_==_ : Nat -> Nat -> Bool
zero  == zero  = true
zero  == suc _ = false
suc _ == zero  = false
suc n == suc m = n == m

_<_ : Nat -> Nat -> Bool
n     < zero  = false
zero  < suc m = true
suc n < suc m = n < m

_≤_ : Nat -> Nat -> Bool
n ≤ m = n < suc m

_>_ = flip _<_
_≥_ = flip _≤_

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

divSucAux : Nat -> Nat -> Nat -> Nat -> Nat
divSucAux k m zero    j       = k
divSucAux k m (suc n) zero    = divSucAux (suc k) m n m
divSucAux k m (suc n) (suc j) = divSucAux k m n j

modSucAux : Nat -> Nat -> Nat -> Nat -> Nat
modSucAux k m zero    j       = k
modSucAux k m (suc n) zero    = modSucAux zero m n m
modSucAux k m (suc n) (suc j) = modSucAux (suc k) m n j

{-# BUILTIN NATDIVSUCAUX divSucAux #-}
{-# BUILTIN NATMODSUCAUX modSucAux #-}

div : Nat -> Nat -> Nat
div n  zero   = zero
div n (suc m) = divSucAux zero m n m

mod : Nat -> Nat -> Nat
mod n  zero   = zero
mod n (suc m) = modSucAux zero m n m

gcd : Nat -> Nat -> Nat
gcd a 0 = a
gcd a b = gcd b (mod a b)

lcm : Nat -> Nat -> Nat
lcm a b = div (a * b) (gcd a b)

even : Nat -> Bool
even n = mod n 2 == 0

odd : Nat -> Bool
odd n = mod n 2 == 1


module Example where

open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Equality

downFrom : Nat → List Nat
downFrom zero    = []
downFrom (suc n) = n ∷ downFrom n

sum-rec : List Nat → Nat
sum-rec []       = 0
sum-rec (x ∷ xs) = x + sum-rec xs

sum-acc : Nat → List Nat → Nat
sum-acc z [] = z
sum-acc z (x ∷ xs) = sum-acc (z + x) xs

sum-acc! : Nat → List Nat → Nat
sum-acc! z [] = z
sum-acc! 0 (x ∷ xs) = sum-acc! x xs
sum-acc! z (x ∷ xs) = sum-acc! (z + x) xs

n = 10000
bench-rec  = sum-rec    (downFrom n)
bench-acc  = sum-acc  0 (downFrom n)
bench-acc! = sum-acc! 0 (downFrom n)


------------------------------------------------------------------------------
-- Example of a nested recursive function using the Bove-Capretta
-- method
------------------------------------------------------------------------------

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

-- From: Bove, A. and Capretta, V. (2001). Nested General Recursion
-- and Partiality in Type Theory. In: Theorem Proving in Higher Order
-- Logics (TPHOLs 2001). Ed. by Boulton, R. J. and Jackson,
-- P. B. Vol. 2152. LNCS. Springer, pp. 121–135.

module FOT.FOTC.Program.Nest.NestBC-SL where

open import Data.Nat renaming ( suc to succ )
open import Data.Nat.Properties

open import Induction
open import Induction.Nat

open import Relation.Binary

------------------------------------------------------------------------------
-- The original non-terminating function.

{-# TERMINATING #-}
nestI : ℕ → ℕ
nestI 0        = 0
nestI (succ n) = nestI (nestI n)

-- ≤′-trans : Transitive _≤′_
-- ≤′-trans i≤′j j≤′k = ≤⇒≤′ (NDTO.trans (≤′⇒≤ i≤′j) (≤′⇒≤ j≤′k))

mutual
  -- The domain predicate of the nest function.
  data NestDom : ℕ → Set where
    nestDom0 : NestDom 0
    nestDomS : ∀ {n} → (h₁ : NestDom n) →
               (h₂ : NestDom (nestD n h₁)) →
               NestDom (succ n)

  -- The nest function by structural recursion on the domain predicate.
  nestD : ∀ n → NestDom n → ℕ
  nestD .0        nestDom0             = 0
  nestD .(succ n) (nestDomS {n} h₁ h₂) = nestD (nestD n h₁) h₂

nestD-≤′ : ∀ n → (h : NestDom n) → nestD n h ≤′ n
nestD-≤′ .0        nestDom0             = ≤′-refl
nestD-≤′ .(succ n) (nestDomS {n} h₁ h₂) =
  ≤′-trans (≤′-trans (nestD-≤′ (nestD n h₁) h₂) (nestD-≤′ n h₁))
           (≤′-step ≤′-refl)

-- The nest function is total.
allNestDom : ∀ n → NestDom n
allNestDom = build <′-recBuilder P ih
  where
  P : ℕ → Set
  P = NestDom

  ih : ∀ y → <′-Rec P y → P y
  ih zero     rec = nestDom0
  ih (succ y) rec = nestDomS nd-y (rec (nestD y nd-y) (s≤′s (nestD-≤′ y nd-y)))
    where
    helper : ∀ x → x <′ y → P x
    helper x Sx≤′y = rec x (≤′-step Sx≤′y)

    nd-y : NestDom y
    nd-y = ih y helper

-- The nest function.
nest : ℕ → ℕ
nest n = nestD n (allNestDom n)


module Logic.Base where

infix 60 ¬_
infix 30 _/\_
infix 20 _\/_

data True : Set where
  tt : True

data False : Set where

elim-False : {A : Set} -> False -> A
elim-False ()

data _/\_ (P Q : Set) : Set where
  /\-I : P -> Q -> P /\ Q

data _\/_ (P Q : Set) : Set where
  \/-IL : P -> P \/ Q
  \/-IR : Q -> P \/ Q

elimD-\/ : {P Q : Set}(C : P \/ Q -> Set) ->
	   ((p : P) -> C (\/-IL p)) ->
	   ((q : Q) -> C (\/-IR q)) ->
	   (pq : P \/ Q) -> C pq
elimD-\/ C left right (\/-IL p) = left p
elimD-\/ C left right (\/-IR q) = right q

elim-\/ : {P Q R : Set} -> (P -> R) -> (Q -> R) -> P \/ Q -> R
elim-\/ = elimD-\/ (\_ -> _)

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

data ∃ {A : Set}(P : A -> Set) : Set where
  ∃-I : (w : A) -> P w -> ∃ P

∏ : {A : Set}(P : A -> Set) -> Set
∏ {A} P = (x : A) -> P x


module HC-Lec2 where

open import HC-Lec1

-- ==============================================================================
-- Lecture 4 : Sigma, Difference, Vector Take
-- https://www.youtube.com/watch?v=OZeDRtRmgkw

-- 43:14

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

vTake : (m n : Nat) -> m >= n -> {X : Set} -> Vec X m -> Vec X n
vTake      m   zero   m>=n       xs  = []
vTake (suc m) (suc n) m>=n (x :: xs) = x :: vTake m n m>=n xs

vTake32 : Set
vTake32 = vTake 3 2 <> (1 :: 2 :: 3 :: []) == (1 :: 2 :: [])

-- 47:35 : taking ALL elements is an identity
vTakeIdFact : (n : Nat) {X : Set} (xs : Vec X n)
           -> vTake n n (refl->= n) xs == xs
vTakeIdFact .0             [] = refl []
vTakeIdFact (suc n) (x :: xs) rewrite vTakeIdFact n xs = refl (x :: xs)

-- 48:17 : taking p elements from Vm is same as taking n elements from Vm, forming Vn
--         then taking p elments from Vn
vTakeCpFact : (m n p : Nat) (m>=n : m >= n) (n>=p : n >= p) {X : Set} (xs : Vec X m)
           -> vTake m p (trans->= m n p m>=n n>=p)                 xs
           == vTake n p                      n>=p  (vTake m n m>=n xs)
vTakeCpFact      m       n   zero   m>=n n>=p _ = refl []
vTakeCpFact (suc m) (suc n) (suc p) m>=n n>=p (x :: xs)
  rewrite vTakeCpFact  m n p m>=n n>=p xs
  = refl (x :: (vTake n p n>=p (vTake m n m>=n xs)))

-- 48:54
-- vTakeIdFact : reflexivity  turns into identity
-- vTakeCpFact : transitivity turns into composition

-- ==============================================================================
-- Lecture 5 : How Rewrite Works
-- https://www.youtube.com/watch?v=b5salYMZoyM

-- 3:34
vTake53 : Vec Nat 3
vTake53 = vTake 5 3 <> (1 :: 2 :: 3 :: 4 :: 5 :: [])

-- 5:30
vTake' : ∀ {m : Nat} {X : Set}
      -> (n : Nat) -> m >= n -> Vec X m
      -> Vec X n
vTake'     {m}  zero   m>=n       xs  = []
vTake' {suc m} (suc n) m>=n (x :: xs) = x :: vTake' {m} n m>=n xs

{-
-- 7:45
rigid symbols : constructors (value and type)
- if you are trying to tell if two usages of constructors match each other,
  you can compare them component-wise
- no defined computational meaning - they are what they are
- e.g., Vec Nat 3
non-rigid
- e.g., >=
- can compute

-- 15:48
vTake : think of as turning a '>=' proof into a vector operation.
- In comes a proof on numbers, out comes an operation on vectors.
vTakeIdFact : identity proof on numbers turns into identity operation on vectors
vTakeCpFact : proof of transitivity on numbers turns into composition operation on vectors

-- 24:08 : best practice : use record (instead of data) when possible : agda is more aggressive

-- 24:28 : HOW REWRITE WORKS
Rewrite is shorthand for
- abstract the LHS   of the equation using 'with'
- abstract the proof of the equation using 'with'
- then pattern matching on the proof
-}

------------------------------------------------------------------------------
-- Splittings (which bear some relationship to <= from ex1)
-- 39:00

data _<[_]>_ : Nat -> Nat -> Nat -> Set where
  zzz : zero <[ zero ]> zero

  lll : {l m r : Nat} ->     l <[     m ]>     r
                      -> suc l <[ suc m ]>     r

  rrr : {l m r : Nat} ->     l <[     m ]>     r
                      ->     l <[ suc m ]> suc r

-- xzzz : Set
-- xzzz = zero <[ zero ]> zero

-- x1z1 : Set
-- x1z1 = 1 <[ zero ]> 1

-- x159 : Set
-- x159 = 1 <[ 5 ]> 9

-- x951 : Set
-- x951 = 9 <[ 5 ]> 1

-- 41:08
-- combine two vectors into one according to given instructions

-- this is kind of a "double-sided" '<='
{-        collection
              * <--- *
       * ---> *
       * ---> *
              * <--- *
       * ---> *
 3 from left     2 from right
-}
_>[_]<_ : {X : Set} {l m r : Nat}
       ->     Vec X l
       ->           l <[ m ]>       r -- instructions
             ->               Vec X r
       ->          Vec X m
-- why is rrr the first line?
-- 29:49 https://www.youtube.com/watch?v=RW4aC_6n0yQ
-- do NOT pattern match on vector first (LHS of first clause)
-- pattern match on instructions first
-- i.e., no pattern match on xl, so goes to try to match instruction : >[ rrr mmm ]<
xl        >[ rrr mmm ]< (x :: xr) = x :: (xl >[ mmm ]< xr)
(x :: xl) >[ lll mmm ]<       xr  = x :: (xl >[ mmm ]< xr)
[]        >[ zzz     ]<       []  = []

v6rl : Vec Nat 6
v6rl = (0 :: 2 :: 3 :: []) >[ rrr (rrr (rrr (lll (lll (lll zzz))))) ]< (7 :: 8 :: 9 :: [])

_ : v6rl == (7 :: 8 :: 9 :: 0 :: 2 :: 3 :: [])
_ = refl    (7 :: 8 :: 9 :: 0 :: 2 :: 3 :: [])

v6   : Vec Nat 6
v6   = (0 :: 2 :: 3 :: []) >[ lll (rrr (lll (rrr (lll (rrr zzz))))) ]< (7 :: 8 :: 9 :: [])

_ : v6 == (0 :: 7 :: 2 :: 8 :: 3 :: 9 :: [])
_ = refl  (0 :: 7 :: 2 :: 8 :: 3 :: 9 :: [])

-- 44:27

-- split a vector into two vectors according to given instructions
-- reverses '<[ m ]>' - instructions for taking things apart
data FindSplit {X : Set} {l m r : Nat}
     (nnn : l <[ m ]> r) : (xs : Vec X m) -> Set where
  splitBits : (xl : Vec X l) (xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr)

-- proves FindSplit
findSplit : {X : Set} {l m r : Nat} (nnn : l <[ m ]> r) (xs : Vec X m) -> FindSplit nnn xs

findSplit  zzz      [] = splitBits [] []

findSplit (lll nnn) (x :: xs) with findSplit nnn xs
                                           -- FindSplit (lll nnn) (x :: (xl >[ nnn ]< xr))
findSplit (lll nnn) (x :: .(xl >[ nnn ]< xr)) | splitBits xl xr = splitBits (x :: xl) xr

findSplit (rrr nnn) (x :: xs) with findSplit nnn xs
                                           -- FindSplit (rrr nnn) (x :: (xl >[ nnn ]< xr))
findSplit (rrr nnn) (x :: .(xl >[ nnn ]< xr)) | splitBits xl xr = splitBits xl (x :: xr)

-- ==============================================================================
-- https://www.youtube.com/watch?v=RW4aC_6n0yQ

-- 5:08
{-
The o' <= constructor : you can keep increasing the RHS

  oz -- stop
  os -- take this one and keep going
  o' -- skip this one and keep going

Tabulating the ways of choosing N things from M things
A path is a way to get a specific embedding.
The numbers in parenthesis shows the number of paths to a specific embedding (Pascal's triangle).

                                     oz
                                    0<=0
                                    (1)
                                   /    \
                                 /        \
                               /            \
                             o'              os
                          0<=1                1<=1
                          (1)                 (1)
                         /    \              /    \
                       /        \          /        \
                     /            \      /            \
                   o'              os   o'             os
                  0<=2              1<=2              2<=2
                  (1)               (2)               (2)
                 /    \            /    \            /    \
               /        \        /        \        /        \
             /            \     /           \    /            \
           o'              os  o'           os  o'             os
          0<=3              1<=3             2<=3             3<=3
          (1)               (3)              (3)              (1)

witnesses to M choose N
read a value in a set of this type as instructions for choosing
-}

-- 14:58
-- 'findSplit' (above)
-- 23:20
-- last clause of 'findSplit'
-- 29:49 : the same ERROR I had before changing order of clauses in _>[_]<_
-- 34:22 : rule of thumb
-- if there is one column of args, where on every line is a constructor then no change
-- otherwise, choose ordering carefully
-- 35:52 : final order of clauses of of  _>[_]<_ -- tidy to have nil case at top or bottom
-- 40:15 shows how agda/haskell does case splitting on _>[_]<_


module Fin where

import Nat
import Bool

open Nat hiding (_==_; _<_)
open Bool

data FZero : Set where

data FSuc (A : Set) : Set where
  fz : FSuc A
  fs : A -> FSuc A

mutual

  Fin' : Nat -> Set
  Fin' zero    = FZero
  Fin' (suc n) = FSuc (Fin n)

  data Fin (n : Nat) : Set where
    fin : Fin' n -> Fin n

fzero : {n : Nat} -> Fin (suc n)
fzero = fin fz

fsuc : {n : Nat} -> Fin n -> Fin (suc n)
fsuc n = fin (fs n)

_==_ : {n : Nat} -> Fin n -> Fin n -> Bool
_==_ {zero}  (fin ())     (fin ())
_==_ {suc n} (fin fz)     (fin fz)     = true
_==_ {suc n} (fin (fs i)) (fin (fs j)) = i == j
_==_ {suc n} (fin fz)     (fin (fs j)) = false
_==_ {suc n} (fin (fs i)) (fin fz)     = false

subst : {n : Nat}{i j : Fin n} -> (P : Fin n -> Set) -> IsTrue (i == j) -> P i -> P j
subst {zero}  {fin ()}     {fin ()}     P _  _
subst {suc n} {fin fz}     {fin fz}     P eq pi = pi
subst {suc n} {fin (fs i)} {fin (fs j)} P eq pi = subst (\z -> P (fsuc z)) eq pi
subst {suc n} {fin fz}     {fin (fs j)} P () _
subst {suc n} {fin (fs i)} {fin fz}     P () _

_<_ : {n : Nat} -> Fin n -> Fin n -> Bool
_<_ {zero}  (fin ())     (fin ())
_<_ {suc n} _            (fin fz)     = false
_<_ {suc n} (fin fz)     (fin (fs j)) = true
_<_ {suc n} (fin (fs i)) (fin (fs j)) = i < j

fromNat : (n : Nat) -> Fin (suc n)
fromNat  zero   = fzero
fromNat (suc n) = fsuc (fromNat n)

liftSuc : {n : Nat} -> Fin n -> Fin (suc n)
liftSuc {zero}  (fin ())
liftSuc {suc n} (fin fz)     = fin fz
liftSuc {suc n} (fin (fs i)) = fsuc (liftSuc i)

lift+ : {n : Nat}(m : Nat) -> Fin n -> Fin (m + n)
lift+  zero   i = i
lift+ (suc m) i = liftSuc (lift+ m i)


open import Relation.Binary.Core

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

open import Data.List
open import Function using (_∘_)
open import Heapsort.Impl1 _≤_ tot≤ trans≤
open import List.Sorted _≤_
open import OList _≤_
open import OList.Properties _≤_

theorem-heapsort-sorted : (xs : List A) → Sorted (forget (heapsort xs))
theorem-heapsort-sorted = lemma-olist-sorted ∘ heapsort


------------------------------------------------------------------------
-- The Agda standard library
--
-- An explanation about the `Axiom` modules.
------------------------------------------------------------------------

module README.Axiom where

open import Level using (Level)

private variable ℓ : Level

------------------------------------------------------------------------
-- Introduction

-- Several rules that are used without thought in written mathematics
-- cannot be proved in Agda. The modules in the `Axiom` folder
-- provide types expressing some of these rules that users may want to
-- use even when they're not provable in Agda.

------------------------------------------------------------------------
-- Example: law of excluded middle

-- In classical logic the law of excluded middle states that for any
-- proposition `P` either `P` or `¬P` must hold. This is impossible
-- to prove in Agda because Agda is a constructive system and so any
-- proof of the excluded middle would have to build a term of either
-- type `P` or `¬P`. This is clearly impossible without any knowledge
-- of what proposition `P` is.

-- The types for which `P` or `¬P` holds is called `Dec P` in the
-- standard library (short for `Decidable`).

open import Relation.Nullary using (Dec)

-- The type of the proof of saying that excluded middle holds for
-- all types at universe level ℓ is therefore:
--
--   ExcludedMiddle ℓ = ∀ {P : Set ℓ} → Dec P
--
-- and this type is exactly the one found in `Axiom.ExcludedMiddle`:

open import Axiom.ExcludedMiddle

-- There are two different ways that the axiom can be introduced into
-- your Agda development. The first option is to postulate it:

postulate excludedMiddle : ExcludedMiddle ℓ

-- This has the advantage that it only needs to be postulated once
-- and it can then be imported into many different modules as with any
-- other proof. The downside is that the resulting Agda code will no
-- longer type check under the --safe flag.

-- The second approach is to pass it as a module parameter:

module Proof (excludedMiddle : ExcludedMiddle ℓ) where

-- The advantage of this approach is that the resulting Agda
-- development can still be type checked under the --safe flag.
-- Intuitively the reason for this is that when postulating it
-- you are telling Agda that excluded middle does hold (which is clearly
-- untrue as discussed above). In contrast when passing it as a module
-- parameter you are telling Agda that **if** excluded middle was true
-- then the following proofs would hold, which is logically valid.

-- The disadvantage of this approach is that it is now necessary to
-- include the excluded middle assumption as a parameter in every module
-- that you want to use it in. Additionally the modules can never
-- be fully instantiated (without postulating excluded middle).

------------------------------------------------------------------------
-- Other axioms

-- Double negation elimination
--   (∀ P → ¬ ¬ P → P)

import Axiom.DoubleNegationElimination

-- Function extensionality
--   (∀ f g → (∀ x → f x ≡ g x) → f ≡ g)

import Axiom.Extensionality.Propositional
import Axiom.Extensionality.Heterogeneous

-- Uniqueness of identity proofs (UIP)
--  (∀ x y (p q : x ≡ y) → p ≡ q)

import Axiom.UniquenessOfIdentityProofs


open import Relation.Binary.Core

module TreeSort.Impl1  {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import BTree {A}
open import Data.List
open import Data.Sum

insert : A → BTree → BTree
insert x leaf = node x leaf leaf
insert x (node y l r)
    with tot≤ x y
... | inj₁ x≤y = node y (insert x l) r
... | inj₂ y≤x = node y l (insert x r)

treeSort : List A → BTree
treeSort [] = leaf
treeSort (x ∷ xs) = insert x (treeSort xs)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Least Common Multiple for integers
------------------------------------------------------------------------

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

module Data.Integer.LCM where

open import Data.Integer.Base
open import Data.Integer.Divisibility
open import Data.Integer.GCD
open import Data.Nat.Base using (ℕ)
import Data.Nat.LCM as ℕ
open import Relation.Binary.PropositionalEquality

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

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

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

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

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

lcm-least : ∀ {i j c} → i ∣ c → j ∣ c → lcm i j ∣ c
lcm-least c∣i c∣j = ℕ.lcm-least c∣i c∣j

lcm[0,i]≡0 : ∀ i → lcm 0ℤ i ≡ 0ℤ
lcm[0,i]≡0 i = cong (+_) (ℕ.lcm[0,n]≡0 ∣ i ∣)

lcm[i,0]≡0 : ∀ i → lcm i 0ℤ ≡ 0ℤ
lcm[i,0]≡0 i = cong (+_) (ℕ.lcm[n,0]≡0 ∣ i ∣)

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


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

module Mergesort.Impl1 {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Bound.Lower A
open import Bound.Lower.Order  _≤_
open import Data.Product
open import Data.Sum
open import Size
open import SList
open import SOList.Lower _≤_

deal : {ι : Size} → SList A {ι} → SList A {ι} × SList A {ι}
deal snil = (snil , snil)
deal (x ∙ snil) = (x ∙ snil , snil)
deal (x ∙ (y ∙ xs))
    with deal xs
... | (ys , zs) = (x ∙ ys , y ∙ zs)

merge : {ι ι' : Size}{b : Bound} → SOList {ι} b  → SOList {ι'} b → SOList b
merge onil ys = ys
merge xs onil = xs
merge (:< {x = x} b≤x xs)  (:< {x = y} b≤y ys)
    with tot≤ x y
... | inj₁ x≤y = :< b≤x (merge xs (:< (lexy x≤y) ys))
... | inj₂ y≤x = :< b≤y (merge (:< (lexy y≤x) xs) ys)

mergesort : {ι : Size} → SList A {↑ ι} → SOList bot
mergesort snil = onil
mergesort (x ∙ snil) = :< {x = x} lebx onil
mergesort (x ∙ (y ∙ xs))
    with deal xs
... | (ys , zs) = merge (mergesort (x ∙ ys)) (mergesort (y ∙ zs))


module Parity where

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

infixl 60 _+_
infixl 70 _*_

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

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

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}
{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}

data Parity : ℕ -> Set where
  itsEven : (k : ℕ) -> Parity (2 * k)
  itsOdd  : (k : ℕ) -> Parity (2 * k + 1)

parity : (n : ℕ) -> Parity n
parity  zero              = itsEven zero
parity (suc n)         with parity n
parity (suc .(2 * k))     | itsEven k = itsOdd k
parity (suc .(2 * k + 1)) | itsOdd  k = itsEven (k + 1)

half : ℕ -> ℕ
half n         with parity n
half .(2 * k)     | itsEven k = k
half .(2 * k + 1) | itsOdd  k = k


{-# OPTIONS --sized-types #-}
module SNat.Sum where

open import Relation.Binary.PropositionalEquality
open import Size
open import SNat

+-assoc-succ : (m n : SNat) → m + succ n ≡ succ (m + n)
+-assoc-succ zero n = refl
+-assoc-succ (succ m) n rewrite +-assoc-succ m n = refl

+-assoc-right : (a b c : SNat) → (a + b) + c ≡ a + (b + c)
+-assoc-right zero b c = refl
+-assoc-right (succ n) b c rewrite +-assoc-right n b c = refl

+-assoc-left : (a b c : SNat) → a + (b + c) ≡ (a + b) + c
+-assoc-left zero b c = refl
+-assoc-left (succ n) b c rewrite +-assoc-left  n b c = refl

+-id : (n : SNat) → n + zero ≡ n
+-id zero = refl
+-id (succ n) rewrite +-id n = refl

+-comm : (m n : SNat) → m + n ≡ n + m
+-comm zero n rewrite +-id n = refl
+-comm (succ m) n rewrite +-assoc-succ n m | +-comm m n = refl


module Nat.Class where

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

record Nat (ℕ : Set) : Set₁ where
  field
    zero : ℕ
    succ : ℕ → ℕ

    ind : (P : ℕ → Set) → P zero → (∀ {k} → P k → P (succ k)) → ∀ n → P n

    _+_ : ℕ → ℕ → ℕ
    +-zero : ∀ {n} → zero + n ≡ n
    +-succ : ∀ {m n} → succ m + n ≡ m + succ n

module _ {ℕ : Set} {{nn : Nat ℕ}} where
  open Nat nn

  +-succˡ : {m n : ℕ} → succ m + n ≡ succ (m + n)
  +-succˡ {m} {n} = ind Succˡ Succˡ-zero Succˡ-succ m n
    where
      Succˡ : ℕ → Set
      Succˡ m′ = ∀ n′ → succ m′ + n′ ≡ succ (m′ + n′)

      Succˡ-zero : Succˡ zero
      Succˡ-zero n′ =
        begin
          succ zero + n′
        ≡⟨ +-succ ⟩
          zero + succ n′
        ≡⟨ +-zero ⟩
          succ n′
        ≡⟨ cong succ (sym +-zero) ⟩
          succ (zero + n′)
        ∎

      Succˡ-succ : ∀ {m′} → Succˡ m′ → Succˡ (succ m′)
      Succˡ-succ {m′} ih n′ =
        begin
          succ (succ m′) + n′
        ≡⟨ +-succ ⟩
          succ m′ + succ n′
        ≡⟨ ih (succ n′) ⟩
          succ (m′ + succ n′)
        ≡⟨ cong succ (sym +-succ) ⟩
          succ (succ m′ + n′)
        ∎

  +-succʳ : {m n : ℕ} → m + succ n ≡ succ (m + n)
  +-succʳ = trans (sym +-succ) +-succˡ

  +-assoc : {m n p : ℕ} → (m + n) + p ≡ m + (n + p)
  +-assoc {m} {n} {p} = ind Assoc Assoc-zero Assoc-succ m
    where
      Assoc : ℕ → Set
      Assoc k = (k + n) + p ≡ k + (n + p)

      Assoc-zero : Assoc zero
      Assoc-zero =
        begin
          (zero + n) + p
        ≡⟨ cong (_+ p) +-zero ⟩
          n + p
        ≡⟨ sym +-zero ⟩
          zero + (n + p)
        ∎

      Assoc-succ : ∀ {k} → Assoc k → Assoc (succ k)
      Assoc-succ {k} ih =
        begin
          (succ k + n) + p
        ≡⟨ cong (_+ p) +-succˡ ⟩
          succ (k + n) + p
        ≡⟨ +-succˡ ⟩
          succ ((k + n) + p)
        ≡⟨ cong succ ih ⟩
          succ (k + (n + p))
        ≡⟨ sym +-succˡ ⟩
          succ k + (n + p)
        ∎