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

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

{-# BUILTIN NATURAL ℕ #-}

{- Addition -}

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

_ : 3 + 4 ≡ 7
_ =
  begin
    3 + 4
  ≡⟨⟩
    suc (2 + 4)
  ≡⟨⟩
    suc (suc (1 + 4))
  ≡⟨⟩
    suc (suc (suc (0 + 4)))
  ≡⟨⟩
    suc (suc (suc 4))
  ≡⟨⟩
    7
  ∎

_ : 1 + 1 ≡ 2
_ = refl

{- Multiplication -}

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

_ : 2 * 2 ≡ 4
_ =
  begin
    2 * 2
  ≡⟨⟩
    2 + (1 * 2)
  ≡⟨⟩
    2 + (2 + (0 * 2))
  ≡⟨⟩
    2 + 2
  ≡⟨⟩
    4
  ∎

_ : 1 * 1 ≡ 1
_ = refl

{- Exponentiation -}

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

_ : 2 ^ 3 ≡ 8
_ =
  begin
    2 ^ 3
  ≡⟨⟩
    2 * (2 ^ 2)
  ≡⟨⟩
    2 * (2 * (2 ^ 1))
  ≡⟨⟩
    2 * (2 * (2 * (2 ^ 0)))
  ≡⟨⟩
    2 * (2 * (2 * 1))
  ≡⟨⟩
    8
  ∎

_ : 42 ^ 0 ≡ 1
_ = refl

{- Monus -}

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

_ : 2 ∸ 1 ≡ 1
_ =
  begin
    2 ∸ 1
  ≡⟨⟩
    1 ∸ 0
  ≡⟨⟩
    1
  ∎

_ : 7 ∸ 4 ≡ 3
_ = refl

_ : 4 ∸ 7 ≡ 0
_ = refl


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

-- Some basic theorms about natural numbers.
module hott.types.nat.theorems where

open import hott.core
open import hott.functions
open import hott.types.nat

-- 0 is the right identity of addition.
x+0≡x : ∀(x : ℕ) → x + 0 ≡ x
x+0≡x  0                = begin 0 + 0 ≡ 0 by definition ∎
x+0≡x (succ n)
  = begin succ n + 0 ≡ succ (n + 0) by definition
                     ≡ succ n       by ap succ (x+0≡x (n))
  ∎

-- Alternate from of 0 being right identity.
x≡x+0 : ∀(x : ℕ) → x ≡ x + 0
x≡x+0 n = x+0≡x n ⁻¹

-- This is really refl but it is better to use these when proving
-- properties about ℕ. One does not have to remember which is
-- definitional equality and which is not.
0+x≡x : ∀ (x : ℕ) → 0 + x ≡ x
0+x≡x n = begin 0 + n ≡ n by definition ∎

-- This is really refl but it is better to use these when proving
-- properties about ℕ. One does not have to remember which is
-- definitional equality and which is not.
x≡0+x : ∀ (x : ℕ) → x ≡ 0 + x
x≡0+x n = begin n ≡ 0 + n by definition ∎

-- Commutativity of addition.
x+y≡y+x : ∀ (x y : ℕ) → x + y ≡ y + x
x+y≡y+x 0 n
        = begin 0 + n ≡ n     by  definition
                      ≡ n + 0 by  x≡x+0 (n)
          ∎
x+y≡y+x n 0
        = begin n + 0 ≡ n      by x+0≡x (n)
                      ≡ 0 + n  by definition
          ∎
x+y≡y+x (succ m) (succ n)
  = begin succ m + succ n
          ≡ succ (m + succ n)   by definition
          ≡ succ (succ n + m)   by applying succ on x+y≡y+x m (succ n)
          ≡ succ (succ (n + m)) by definition
          ≡ succ (succ (m + n)) by applying succ ∘ succ on (x+y≡y+x n m)
          ≡ succ (succ m + n)   by applying succ on definition
          ≡ succ (n + succ m)   by applying succ on x+y≡y+x (succ m) n
          ≡ succ n + succ m     by definition
  ∎
-- Associativity of +
x+[y+z]≡[x+y]+z : ∀ (x y z : ℕ) → x + (y + z) ≡ (x + y) + z
x+[y+z]≡[x+y]+z zero      y z
                = begin 0 + (y + z)
                        ≡ y + z        by definition
                        ≡ (0 + y) + z  by definition
                ∎
x+[y+z]≡[x+y]+z (succ x)  y z
  = begin succ x + (y + z)
          ≡ succ (x + (y  + z)) by definition
          ≡ succ ((x + y) + z) by applying succ on x+[y+z]≡[x+y]+z x y z
          ≡ succ (x + y)  + z  by definition
          ≡ (succ x + y)  + z  by definition
  ∎


module Nat where

import Bool
open Bool

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

infixr 25 _+_

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

infix 10 _==_ _<_

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

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

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}
-- {-# BUILTIN NATPLUS _+_ #-}
-- {-# BUILTIN NATEQUALS _==_ #-}
-- {-# BUILTIN NATLESS _<_ #-}


module plfa-code.Naturals where

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

{-# BUILTIN NATURAL ℕ #-}

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

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

_ : 2 + 3 ≡ 5
_ = refl

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

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

_ : 3 ^ 4 ≡ 81
_ =
  begin
    3 ^ 4
  ≡⟨⟩
    3 * (3 ^ 3)
  ≡⟨⟩
    3 * (3 * (3 ^ 2))
  ≡⟨⟩
    3 * (3 * (3 * (3 ^ 1)))
  ≡⟨⟩
    3 * (3 * (3 * (3 * (3 ^ 0))))
  ≡⟨⟩
    3 * (3 * (3 * (3 * 1)))
  ≡⟨⟩
    81
  ∎

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

_ =
  begin
     3 ∸ 2
  ≡⟨⟩
     2 ∸ 1
  ≡⟨⟩
     1 ∸ 0
  ≡⟨⟩
     1
  ∎

_ =
  begin
     2 ∸ 3
  ≡⟨⟩
     1 ∸ 2
  ≡⟨⟩
     0 ∸ 1
  ≡⟨⟩
     0
  ∎

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

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

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

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

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

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

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

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

to   : ℕ → Bin
to 0   = x0 nil
to (suc n) = inc (to n)

from : Bin → ℕ
from nil      = 0
from (x0 t)   = (from t) * 2
from (x1 t)   = (from t) * 2 + 1

_ : to 0 ≡ x0 nil
_ = refl

_ : to 1 ≡ x1 nil
_ = refl

_ : to 2 ≡ x0 x1 nil
_ = refl

_ : to 3 ≡ x1 x1 nil
_ = refl

_ : to 4 ≡ x0 x0 x1 nil
_ = refl

_ : 0 ≡ from (x0 nil)
_ = refl

_ : 1 ≡ from (x1 nil)
_ = refl

_ : 2 ≡ from (x0 x1 nil)
_ = refl

_ : 3 ≡ from (x1 x1 nil)
_ = refl

_ : 4 ≡ from (x0 x0 x1 nil)
_ = refl


open import Relation.Binary.Core

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

open import Data.List
open import Data.Sum
open import InsertSort.Impl1 _≤_ tot≤
open import List.Sorted _≤_

lemma-insert-sorted : {xs : List A}(x : A) → Sorted xs → Sorted (insert x xs)
lemma-insert-sorted {xs = .[]} x nils = singls x
lemma-insert-sorted {xs = .([ y ])} x  (singls y)
    with tot≤ x y
... | inj₁ x≤y  = conss x≤y (singls y)
... | inj₂ y≤x  = conss y≤x (singls x)
lemma-insert-sorted x (conss {y} {z} {ys} y≤z szys)
    with tot≤ x y
... | inj₁ x≤y = conss x≤y (conss y≤z szys)
... | inj₂ y≤x
    with tot≤ x z | lemma-insert-sorted x szys
... | inj₁ x≤z | _ = conss y≤x (conss x≤z szys)
... | inj₂ z≤x | h = conss y≤z h

theorem-insertSort-sorted : (xs : List A) → Sorted (insertSort xs)
theorem-insertSort-sorted [] = nils
theorem-insertSort-sorted (x ∷ xs) = lemma-insert-sorted x (theorem-insertSort-sorted xs)


{-

https://serokell.io/blog/playing-with-negation

Constructive and Non-Constructive Proofs in Agda (Part 3): Playing with Negation

Danya Rogozin Friday, November 30th, 2018

Present an empty type to work with constructive negation.
Discuss Markov’s principle and apply this principle for one use case.
Declare the double negation elimination as a postulate.
Some examples of non-constructive proofs in Agda.

------------------------------------------------------------------------------
Empty type

-}
-- Type with no constructors (so-called bottom).
-- Type that corresponds to an absurd statement or contradiction.
data ⊥ : Set where

-- ¬ defines negation. ¬A denotes that any proof of A yields a proof of a contradiction:

¬_ : Set → Set
¬ A = A → ⊥

-- elimination of ⊥ : derives an arbitrary statement from bottom
exFalso : {A : Set} → ⊥ → A
exFalso ()

-- examples of propositions with negation that are provable constructively.

-- Derives an arbitrary formula from a contradiction.
-- The first argument f has a type ¬ A (or A → ⊥).
-- The second argument x has a type A.
-- Thus f x is an object of type ⊥.
-- Hence exContr (f x) has a type B.
exContr : {A B : Set} → ¬ A → A → B
exContr f x = exFalso (f x)

exContr2 : {A B : Set} → (A → ⊥) → A → B
exContr2 f x = exFalso (f x)

-- g proves B → ⊥
-- f proves A → B
-- g ∘ f proves A → ⊥, i.e. ¬ A.
contraposition : {A B : Set} → (A → B) → (¬ B → ¬ A)
contraposition f g = g ∘ f

-- negation on formula A.
-- If possible to derive contradictionary consequences B and ¬ B from the statement A,
-- then any proof of A yields ⊥.
¬-intro : {A B : Set} → (A → B) → (A → ¬ B) → ¬ A
¬-intro f g x = g x (f x)

{-
disjImpl establishes a connection between disjunction and implication.
If prove ¬ A ∨ B and have a proof of A.
If have a proof of ¬ A, then we have proved B by ex-falso.
If have a proof of B, then we have already proved B trivially.
So, we have obtained a proof of B by case analysis (i.e., pattern-matching).
-}
disjImpl : {A B : Set} → ¬ A ⊎ B → A → B
disjImpl (inj₁ x) a = exContr x a
disjImpl (inj₂ y) a = y


module simpleAgda where

-- main : IO ()
-- main = putStrLn "Testing simple Idris"

--
-- Some simple equivalent Idris and Agda code.
--

-- data N = Z | Suc N
data N : Set where
  Z : N
  suc : N -> N

-- one : N
-- one = Suc Z
one : N
one = suc Z

-- addOne : N -> N
-- addOne Z = Suc Z
-- addOne (Suc n) = Suc (Suc n)

addOne : N -> N
addOne Z = suc Z
addOne (suc a) = suc (suc a)

-- add : N -> N -> N
-- add Z s = s
-- add (Suc a) b = add a (Suc b)
add : N -> N -> N
add Z s = s
add (suc a) b = add a (suc b)

-- data Vec : Type -> N -> Type where
--   Nil : Vec a Z
--   (::) : a -> Vec a n -> Vec a (Suc n)
data Vec (A : Set) : N -> Set where
  Nil : Vec A Z
  cons : {n : N} -> A -> Vec A n -> Vec A (suc n)

-- empt : Vec N Z
-- empt = Nil
empt : Vec N Z
empt = Nil

open import Agda.Builtin.Nat
-- test : Vec Nat (Suc Main.one)
-- test = 1 :: 2 :: Nil
test : Vec Nat (suc (suc Z))
test = cons 1 (cons 2 Nil)

-- test2 : Vec Nat (Suc (Suc Main.one))
-- test2 = 3 :: 4 :: 5 :: Nil
test2 : Vec Nat (suc (suc (suc Z)))
test2 = cons 3 (cons 4 (cons 5 Nil))

-- concat : Vec g a -> Vec g b -> Vec g (add a b)
-- concat Nil rest = rest
-- concat (a :: rest) b = concat rest (a :: b)
concat : {a b : N} {g : Set} -> (Vec g a) -> (Vec g b) -> (Vec g (add a b))
concat Nil rest = rest
concat (cons a rest) b = concat rest (cons a b)

-- t3 : Vec (addOne $ addOne $ addOne $ addOne Main.one) Nat
-- t3 = concat test test2
t3 : Vec Nat (addOne (addOne (addOne (addOne one))))
t3 = concat test test2


module Relation.Unary.Membership {a} (A : Set a) where

open import Level
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Relation.Unary
open import Relation.Binary

infixl 4 _≋_
_≋_ : Rel (Pred A a) _
P ≋ Q = P ⊆′ Q × Q ⊆′ P

⊆-refl : Reflexive (_⊆′_ {a} {A} {a})
⊆-refl {pred} x P = P

≋-refl : Reflexive _≋_
≋-refl {pred} = (⊆-refl {pred}) , (⊆-refl {pred})

≋-sym : Symmetric _≋_
≋-sym x = (proj₂ x) , (proj₁ x)

≋-trans : Transitive _≋_
≋-trans f≋g g≋h =
    (λ x z → proj₁ g≋h x (proj₁ f≋g x z)) , (λ x z → proj₂ f≋g x (proj₂ g≋h x z))

≋-isEquivalence : IsEquivalence _≋_
≋-isEquivalence = record
    { refl = ≋-refl
    ; sym = ≋-sym
    ; trans = ≋-trans
    }

⊆-trans : Transitive (_⊆′_ {a} {A} {a})
⊆-trans A⊆B B⊆C x x∈A = B⊆C x (A⊆B x x∈A)

⊆-preorder : IsPreorder _≋_ _⊆′_
⊆-preorder = record
    { isEquivalence = ≋-isEquivalence
    ; reflexive = proj₁
    ; trans = ⊆-trans
    }

⊆-partialOrder : IsPartialOrder _≋_ _⊆′_
⊆-partialOrder = record
    { isPreorder = ⊆-preorder
    ; antisym = λ A⊆B B⊆A → A⊆B , B⊆A
    }

⊆-poset : Poset (suc a) a a
⊆-poset = record
    { Carrier = Pred A a
    ; _≈_ = _≋_
    ; _≤_ = _⊆′_
    ; isPartialOrder = ⊆-partialOrder
    }

module ⊆-Reasoning where
    import Relation.Binary.PartialOrderReasoning as PosetR
    open PosetR ⊆-poset public
        renaming (_≤⟨_⟩_ to _⊆⟨_⟩_)

    infix 1 _∈⟨_⟩_
    infixr 2 _→⟨_⟩_

    _∈⟨_⟩_ : ∀ x {xs ys} → x ∈ xs → xs IsRelatedTo ys → x ∈ ys
    x ∈⟨ x∈xs ⟩ xs⊆ys = begin_ xs⊆ys x x∈xs

    _→⟨_⟩_ : ∀ A {B C} → (A ⊆ B) → B IsRelatedTo C → A IsRelatedTo C
    A →⟨ f ⟩ B∼C = A ⊆⟨ (λ x x∈A → f x∈A) ⟩ B∼C
    -- A ⊆[ f ] relTo B∼C = A ⊆⟨ f ⟩ relTo B∼C
    --

        --(begin xs⊆ys) x∈xs


---------------------------------------------------------------------------------
-- Equality

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

------------------------------------------------------------------------------
-- Equality is an equivalence relation : reflexive, symmetric, and transitive.
-- Reflexivity is built-in to the definition of equality.

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

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

-- Equality satisfies congruence.
-- If two terms are equal, they are eual after the same function is applied to both:
cong : ∀ {A B : Set} (f : A → B) {x y : A}
  → x ≡ y
    ---------
  → f x ≡ f y
cong f refl  =  refl

-- Congruence of 2 arg functions
cong₂ : ∀ {A B C : Set} (f : A → B → C) {u x : A} {v y : B}
  → u ≡ x
  → v ≡ y
    -------------
  → f u v ≡ f x y
cong₂ f refl refl  =  refl

-- Equality is a congruence in the function position of an application.
-- If two functions are equal, then applying them to the same term yields equal terms:
cong-app : ∀ {A B : Set} {f g : A → B}
  → f ≡ g
    ---------------------
  → ∀ (x : A) → f x ≡ g x
cong-app refl x = refl

-- Equality satisfies substitution.
-- If two values are equal and a predicate holds of the first then it also holds of the second:
subst : ∀ {A : Set} {x y : A} (P : A → Set)
  → x ≡ y
    ---------
  → P x → P y
subst P refl px = px

-- Chains of equations : support equational reasoning
module ≡-Reasoning {A : Set} where

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

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

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

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

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

open ≡-Reasoning

-- equational proof of transitivity
trans′ : ∀ {A : Set} {x y z : A}
  → x ≡ y
  → y ≡ z
    -----
  → x ≡ z
trans′ {A} {x} {y} {z} x≡y y≡z =
  begin
    x
  ≡⟨ x≡y ⟩
    y
  ≡⟨ y≡z ⟩
    z
  ∎

{-
Exercise trans and ≡-Reasoning (practice): TODO
Cannot use the definition of trans’ using ≡-Reasoning as the definition for trans.
WHY?
Hint: look at the definition of _≡⟨_⟩_
-}

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

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

postulate
  +-identity : ∀ (m : ℕ) → m + zero ≡ m
  +-suc : ∀ (m n : ℕ) → m + suc n ≡ 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
  ∎

{-
Exercise ≤-Reasoning (stretch) TODO
The proof of monotonicity from Chapter Relations can be written in a more readable form
by using an analogue of our notation for ≡-Reasoning.
Define ≤-Reasoning analogously, and use it to write out an alternative proof
that addition is monotonic with regard to inequality.
Rewrite all of +-monoˡ-≤, +-monoʳ-≤, and +-mono-≤.
-}

------------------------------------------------------------------------------
-- Rewriting
-- keyword rewrite : followed by evidence of an EQUALITY
-- that equality is used to rewrite
-- - the type of the goal
-- - and of any variable in scope

data even : ℕ → Set
data odd  : ℕ → Set

data even where

  even-zero : even zero

  even-suc : ∀ {n : ℕ}
    → odd n
      ------------
    → even (suc n)

data odd where
  odd-suc : ∀ {n : ℕ}
    → even n
      -----------
    → odd (suc n)

even-comm : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm m n ev         -- even (n + m)
  rewrite +-comm n m     -- even (m + n) ; ev : even (m + n)
  = ev

--------------------------------------------------
-- Multiple rewrites each separated by a vertical bar.
+-comm′ : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm′ zero    n  rewrite +-identity n             =  refl
+-comm′ (suc m) n  rewrite +-suc n m | +-comm′ m n  =  refl

--------------------------------------------------
-- rewrite is shorthand for an use of WITH

even-comm′ : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm′ m n ev with   m + n  | +-comm m n
...                  | .(n + m) | refl       = ev

{-
--------------------------------------------------
DOT pattern, .(n + m).
dot followed by an expression.
Used when other info forces value matched to be equal to value of expr in dot pattern.
-}

------------------------------------------------------------------------------
-- subst (instead of rewrite)

even-comm″ : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm″ m n  =  subst even (+-comm m n)

{-
------------------------------------------------------------------------------
Leibniz equality

≡ def is due to Martin Löf (1975).

Older form is due to Leibniz (1686).

IDENTITY OF INDISCERNIBLES:
-  two objects are equal IFF they satisfy the same properties

Below: define Leibniz equality, and show that two terms satisfy Leibniz equality IFF
they satisfy Martin Löf equality.

x ≐ y holds if every property P that holds of x also holds of y

this def is sufficient to ensure the converse
- that every property P that holds of y also holds of x

Let x and y be objects of type A.
x ≐ y holds if for every predicate P over type A we have that P x implies P y:
_]
-}

_≐_ : ∀ {A : Set} (x y : A) → Set₁
_≐_ {A} x y = ∀ (P : A → Set) → P x → P y

{-
NOTE: write _≐_ {A} x y (instead of x ≐ y) to provide access to implicit parameter.

--------------------------------------------------
FIRST USE OF LEVELS.

Cannot assign Set the type Set (Russell’s Paradox and Girard’s Paradox).

Set is an abbreviation for Set₀

Since _≐_ def  mentions Set on right-hand side, the corresponding signature must use Set₁.

Leibniz equality is reflexive (follows by a variant of the identity function)
and transitive (by a variant of function composition)
-}
refl-≐ : ∀ {A : Set} {x : A}
  → x ≐ x
refl-≐ P Px  =  Px

trans-≐ : ∀ {A : Set} {x y z : A}
  → x ≐ y
  → y ≐ z
    -----
  → x ≐ z
trans-≐ x≐y y≐z P Px  =  y≐z P (x≐y P Px)

-- Symmetry : show that if P x implies P y for all predicates P,
-- then the implication holds the other way round as well:
sym-≐ : ∀ {A : Set} {x y : A}
  → x ≐ y
    -----
  → y ≐ x
sym-≐ {A} {x} {y} x≐y P  =  Qy
  where
    Q : A → Set
    Q z = P z → P x
    Qx : Q x
    Qx = refl-≐ P
    Qy : Q y
    Qy = x≐y Q Qx
{-
Given x ≐ y, a specific P, construct a proof that P y implies P x.
Instantiate the equality with a predicate Q such that Q z holds if P z implies P x.
The property Q x is trivial by reflexivity, and hence Q y follows from x ≐ y.
But Q y is exactly a proof of what we require, that P y implies P x.

show Martin Löf equality implies Leibniz equality, and vice versa.

if x ≡ y then need for any P to take evidence of P x to evidence of P y
which can be done since equality of x and y implies that any proof of P x is also a proof of P y:
-}

≡-implies-≐ : ∀ {A : Set} {x y : A}
  → x ≡ y
    -----
  → x ≐ y
≡-implies-≐ x≡y P  =  subst P x≡y

-- given that for any P we can take a proof of P x to a proof of P y then show x ≡ y:

≐-implies-≡ : ∀ {A : Set} {x y : A}
  → x ≐ y
    -----
  → x ≡ y
≐-implies-≡ {A} {x} {y} x≐y  =  Qy
  where
    Q : A → Set
    Q z = x ≡ z
    Qx : Q x
    Qx = refl
    Qy : Q y
    Qy = x≐y Q Qx
{-
proof similar to that for symmetry of Leibniz equality.
We take Q to be the predicate that holds of z if x ≡ z.
Then Q x is trivial by reflexivity of Martin Löf equality, and hence Q y follows from x ≐ y.
But Q y is exactly a proof of what we require, that x ≡ y.

(Parts adapted from
≐≃≡: Leibniz Equality is Isomorphic to Martin-Löf Identity, Parametrically,
by Andreas Abel, Jesper Cockx, Dominique Devries, Andreas Nuyts, and Philip Wadler, draft, 2017.)

------------------------------------------------------------------------------
Universe polymorphism

Not every type belongs to Set.
Set₀ : Set₁, Set₁ : Set₂, ...

≡ def at beginning is ok for comparing values of a type that belongs to Set.

How to compare two values of a type that belongs to Set ℓ for some arbitrary level ℓ?

Via universe polymorphism : definition made with respect to arbitrary level ℓ.
To use levels:
-}
open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)
{-

Levels : isomorphic to natural numbers

lzero : Level
lsuc  : Level → Level

Set₀, Set₁, Set₂, and so on, are abbreviations for

Set lzero
Set (lsuc lzero)
Set (lsuc (lsuc lzero))

_⊔_ : Level → Level → Level -- given two levels returns the largest

equality, symetry, generalised to an arbitrary level:
-}

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

sym′ : ∀ {ℓ : Level} {A : Set ℓ} {x y : A}
  → x ≡′ y
    ------
  → y ≡′ x
sym′ refl′ = refl′

{-
most defs in standard library are generalised to arbitrary levels

generalised Leibniz equality:
-}

_≐′_ : ∀ {ℓ : Level} {A : Set ℓ} (x y : A) → Set (lsuc ℓ)
_≐′_ {ℓ} {A} x y = ∀ (P : A → Set ℓ) → P x → P y

-- generalized composition
_∘_ : ∀ {ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set ℓ₁} {B : Set ℓ₂} {C : Set ℓ₃}
  → (B → C) → (A → B) → A → C
(g ∘ f) x  =  g (f x)

{-
Standard library

defines _≡⟨_⟩_ as step-≡, which reverses the order of the arguments.

defines a syntax macro ((automatically imported with step-≡) i, which recovers original arg order:
-}


module Numeral.Natural.Combinatorics where

open import Numeral.Natural
open import Numeral.Natural.Oper

-- Counting combinations.
-- `𝑐𝐶 n k` is the number of ways one can pick `k` number of distinct objects from a set of `n` number of distinct objects.
-- Equivalently, it is the number of `k`-sized subsets of an `n`-sized set.
-- Also called: Binomial coefficients
-- Formulated using sets:
--   𝐶: Set → ℕ → Set
--   𝐶 S k = {(K∊℘(S)). #K = k}
--   𝑐𝐶(n) = #𝐶(𝕟(n))
𝑐𝐶 : ℕ → ℕ → ℕ
𝑐𝐶 _     𝟎     = 𝐒 𝟎
𝑐𝐶 𝟎     (𝐒 k) = 𝟎
𝑐𝐶 (𝐒 n) (𝐒 k) = 𝑐𝐶 n k + 𝑐𝐶 n (𝐒 k)

-- Counting partial permutations.
-- `𝑐𝑃 n k` is the number of arrangements for a list of `n` number of distinct objects into `k` number of objects.
-- Equivalently, it is the number of injective functions (function equality by the standard function extensionality) of type `𝕟(k) → 𝕟(n)`.
-- Also called: Falling factorial
-- Formulated using sets:
--   𝑃: Set → ℕ → Set
--   𝑃 S k = {(π: 𝕟(k) → S). Injective(π)}
--   𝑐𝑃(n) = #𝑃(𝕟(n))
𝑐𝑃 : ℕ → ℕ → ℕ
𝑐𝑃 _     𝟎     = 𝐒 𝟎
𝑐𝑃 𝟎     (𝐒 k) = 𝟎
𝑐𝑃 (𝐒 n) (𝐒 k) = 𝑐𝑃 n k ⋅ (𝐒 n)

-- Counting derangements.
-- `𝑐𝐷(n)` is the number of permutations of a list of `n` number of distinct objects such that in every permutation, no object is permuted with itself.
-- Formulated using sets:
--   𝐷: Set → Set
--   𝐷(S) = {(π∊𝑃(S)). ∀(s∊S). π(s) ≠ s}
--   𝑐𝐷(n) = #𝐷(𝕟(n))
𝑐𝐷 : ℕ → ℕ
𝑐𝐷(𝟎)      = 𝐒 𝟎
𝑐𝐷(𝐒 𝟎)    = 𝟎
𝑐𝐷(𝐒(𝐒 n)) = 𝐒(n) ⋅ (𝑐𝐷 (𝐒 n) + 𝑐𝐷 n)

-- Stirling numbers of the first kind.
stir₁ : ℕ → ℕ → ℕ
stir₁ 𝟎      𝟎      = 𝐒(𝟎)
stir₁ (𝐒(n)) 𝟎      = 𝟎
stir₁ 𝟎      (𝐒(k)) = 𝟎
stir₁ (𝐒(n)) (𝐒(k)) = (n ⋅ stir₁ n (𝐒(k))) + stir₁ n k

-- Stirling numbers of the second kind.
stir₂ : ℕ → ℕ → ℕ
stir₂ 𝟎      𝟎      = 𝐒(𝟎)
stir₂ (𝐒(n)) 𝟎      = 𝟎
stir₂ 𝟎      (𝐒(k)) = 𝟎
stir₂ (𝐒(n)) (𝐒(k)) = (𝐒(k) ⋅ stir₂ n (𝐒(k))) + stir₂ n k

-- Counting injective functions.
𝑐𝐼𝑛𝑗 : ℕ → ℕ → ℕ
𝑐𝐼𝑛𝑗 = 𝑐𝑃

-- Counting surjective functions.
𝑐𝑆𝑢𝑟𝑗 : ℕ → ℕ → ℕ
𝑐𝑆𝑢𝑟𝑗 a b = stir₂ a b ⋅ (b !)


module logic where

open import Level
open import Relation.Nullary
open import Relation.Binary hiding (_⇔_ )
open import Data.Empty

data One {n : Level } : Set n where
  OneObj : One

data Two : Set where
   i0 : Two
   i1 : Two

data Bool : Set where
   true : Bool
   false : Bool

record  _∧_  {n m : Level} (A  : Set n) ( B : Set m ) : Set (n ⊔ m) where
   constructor ⟪_,_⟫
   field
      proj1 : A
      proj2 : B

data  _∨_  {n m : Level} (A  : Set n) ( B : Set m ) : Set (n ⊔ m) where
   case1 : A → A ∨ B
   case2 : B → A ∨ B

_⇔_ : {n m : Level } → ( A : Set n ) ( B : Set m )  → Set (n ⊔ m)
_⇔_ A B =  ( A → B ) ∧ ( B → A )

contra-position : {n m : Level } {A : Set n} {B : Set m} → (A → B) → ¬ B → ¬ A
contra-position {n} {m} {A} {B}  f ¬b a = ¬b ( f a )

double-neg : {n  : Level } {A : Set n} → A → ¬ ¬ A
double-neg A notnot = notnot A

double-neg2 : {n  : Level } {A : Set n} → ¬ ¬ ¬ A → ¬ A
double-neg2 notnot A = notnot ( double-neg A )

de-morgan : {n  : Level } {A B : Set n} →  A ∧ B  → ¬ ( (¬ A ) ∨ (¬ B ) )
de-morgan {n} {A} {B} and (case1 ¬A) = ⊥-elim ( ¬A ( _∧_.proj1 and ))
de-morgan {n} {A} {B} and (case2 ¬B) = ⊥-elim ( ¬B ( _∧_.proj2 and ))

dont-or :　{n m : Level} {A  : Set n} { B : Set m } →  A ∨ B → ¬ A → B
dont-or {A} {B} (case1 a) ¬A = ⊥-elim ( ¬A a )
dont-or {A} {B} (case2 b) ¬A = b

dont-orb :　{n m : Level} {A  : Set n} { B : Set m } →  A ∨ B → ¬ B → A
dont-orb {A} {B} (case2 b) ¬B = ⊥-elim ( ¬B b )
dont-orb {A} {B} (case1 a) ¬B = a

infixr  130 _∧_
infixr  140 _∨_
infixr  150 _⇔_


module x02-842Induction where

-- Library

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

-- PLFA coverage of identity, associativity, commutativity, distributivity.

-- An example of the associative law for addition.

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

-- A theorem easy to prove.

+-identityᴸ : ∀ (m : ℕ) → zero + m ≡ m
+-identityᴸ m = {!!}

-- A first nontrivial theorem.
-- An equational proof is shown in PLFA.
-- It uses helpers cong and sym imported from the standard library,
-- and a form of equational reasoning that allows more elaborate justification.
-- Instead we will use 'rewrite'.

+-identityʳ : ∀ (m : ℕ) → m + zero ≡ m
+-identityʳ m = {!!}

-- Associativity of addition.
-- (Done first in PLFA.)

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

-- A useful lemma about addition.
-- Equational proof shown in PLFA.

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc m n = {!!}

-- Commutativity of addition.
-- Equational proof shown in PLFA.

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m n = {!!}

-- 842 exercise: AddSwap (1 point)
-- Please do this without using induction/recursion.

+-swap : ∀ (m n p : ℕ) → (m + n) + p ≡ n + (m + p)
+-swap m n p = {!!}

-- 842 exercise: AddDistMult (2 points)
-- Show that addition distributes over multiplication.

*-+-rdistrib : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-+-rdistrib m n p = {!!}

-- 842 exercise: MultAssoc (2 points)
-- Show that multiplication is associative.

*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc m n p = {!!}

-- 842 exercise: MultComm (3 points)
-- Show that multiplication is commutative.
-- As with the addition proof above, helper lemmas will be needed.

*-comm : ∀ (m n : ℕ) → m * n ≡ n * m
*-comm m n = {!!}

-- 842 exercise: LeftMonusZero (1 point)
-- PLFA asks "Did your proof require induction?"
-- (which should give you an indication of the expected answer).

0∸n≡0 : ∀ (m : ℕ) → zero ∸ m ≡ zero
0∸n≡0 m = {!!}

-- 842 exercise: MonusAssocish (2 points)
-- Show a form of associativity for monus.

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

-- 842 extended exercise: properties of binary representation.
-- This is based on the PLFA Bin-laws exercise.

-- Copied from 842Naturals.

data Bin-ℕ : Set where
  bits : Bin-ℕ
  _x0 : Bin-ℕ → Bin-ℕ
  _x1 : Bin-ℕ → Bin-ℕ

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

-- Copy your versions of 'inc', 'to', 'from', 'bin-+' over from 842Naturals.
-- You may choose to change them here to make proofs easier.
-- But make sure to test them if you do!

inc : Bin-ℕ → Bin-ℕ
inc m = {!!}

tob : ℕ → Bin-ℕ
tob m = {!!}

fromb : Bin-ℕ → ℕ
fromb m = {!!}

_bin-+_ : Bin-ℕ → Bin-ℕ → Bin-ℕ
m bin-+ n = {!!}

-- 842 exercise: DoubleB (1 point)
-- Write the Bin-ℕ version of dbl, here called dblb.
-- As with the other Bin-ℕ operations, don't use tob/fromb.

dblb : Bin-ℕ → Bin-ℕ
dblb m = {!!}

-- Here are some properties of tob/fromb/inc suggested by PLFA Induction.
-- Please complete the proofs.

-- 842 exercise: FromInc (1 point)

from∘inc : ∀ (m : Bin-ℕ) → fromb (inc m) ≡ suc (fromb m)
from∘inc m = {!!}

-- 842 exercise: FromToB (1 point)

from∘tob : ∀ (m : ℕ) → fromb (tob m) ≡ m
from∘tob m = {!!}

-- 842 exercise: ToFromB (2 points)
-- The property ∀ (m : Bin-ℕ) → tob (fromb m) ≡ m cannot be proved.
-- Can you see why?
-- However, this restriction of it can be proved.

to/from-corr : ∀ (m : Bin-ℕ) (n : ℕ) → m ≡ tob n → fromb m ≡ n
to/from-corr m n m≡tn = {!!}

-- Here are a few more properties for you to prove.

-- 842 exercise: DblBInc (1 point)

dblb∘inc : ∀ (m : Bin-ℕ) → dblb (inc m) ≡ inc (inc (dblb m))
dblb∘inc m = {!!}

-- 842 exercise: ToDbl (1 point)

to∘dbl : ∀ (m : ℕ) → tob (dbl m) ≡ dblb (tob m)
to∘dbl m = {!!}

-- 842 exercise: FromDblB (1 point)

from∘dblb : ∀ (m : Bin-ℕ) → fromb (dblb m) ≡ dbl (fromb m)
from∘dblb m = {!!}

-- 842 exercise: BinPlusLInc (2 points)
-- This helper function translates the second case for unary addition
--  suc m + n = suc (m + n)
-- into the binary setting. It's useful in the next proof.
-- Hint: induction on both m and n is needed.

bin-+-linc : ∀ (m n : Bin-ℕ) → (inc m) bin-+ n ≡ inc (m bin-+ n)
bin-+-linc m n = {!!}

-- 842 exercise: PlusUnaryBinary (2 points)
-- This theorem relates unary and binary addition.

to∘+ : ∀ (m n : ℕ) → tob (m + n) ≡ tob m bin-+ tob n
to∘+ m n = {!!}

-- This ends the extended exercise.

-- The following theorems proved in PLFA can be found in the standard library.

-- import Data.Nat.Properties using (+-assoc; +-identityʳ; +-suc; +-comm)

-- Unicode used in this chapter:

{-

    ∀  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 (\')

-}


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

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

{-# BUILTIN EQUALITY _≡_ #-}

data Sigma {l} (A : Set l) (B : A -> Set l) : Set l where
  _**_ : (a : A) -> B a -> Sigma A B

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

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

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

cong : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) {x y : A} → x ≡ y → f x ≡ f y
cong f refl = refl
fst : ∀ {l} -> {A : Set l}{B : A -> Set l} -> Sigma A B -> A
fst (x ** _) = x

snd : ∀ {l} -> {A : Set l}{B : A -> Set l} -> (sum : Sigma A B) -> B (fst sum)
snd (x ** y) = y

record Group {l} (G : Set l) (_op_ : G -> G -> G) : Set l where
  field
    assoc : {a b c : G} -> ((a op b) op c) ≡ (a op (b op c))
    id : {a : G} -> Sigma G (\e -> e op a ≡ a)
    inv : {a : G} -> Sigma G (\a^-1 -> (a^-1 op a) ≡ (fst (id {a})))
  e : {a : G} -> G
  e {a} = fst (id {a})

  _^-1 : G -> G
  x ^-1 = fst (inv {x})

  a^-1-op-a==e : {a : G} -> ((a ^-1) op a) ≡ e {a}
  a^-1-op-a==e {a} with inv {a}
  ...                   | (_ ** p) = p

  id-lem-right : {a : G} -> (e {a} op a) ≡ a
  id-lem-right {a} = snd (id {a})

  id-lem-left : {a : G} -> (a op e {a}) ≡ a
  id-lem-left {a} rewrite id-lem-right {a} = {!!}

-- In Agda 2.4.2.5 the error was:

-- Function does not accept argument {r = _}
-- when checking that {r = a} is a valid argument to a function of
-- type {a : G} → G


module Propositional where

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

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open ≡-Reasoning

--------------------------------------------------------------------------------
--  Some easy lemmas
--------------------------------------------------------------------------------

+-zero : ∀ a → a + zero ≡ a
+-zero zero = refl
+-zero (suc a) rewrite +-zero a = refl

+-suc : ∀ a b → a + suc b ≡ suc (a + b)
+-suc zero b = refl
+-suc (suc a) b rewrite +-suc a b = refl

+-assoc : ∀ a b c → a + b + c ≡ a + (b + c)
+-assoc zero b c = refl
+-assoc (suc a) b c rewrite +-assoc a b c = refl

--------------------------------------------------------------------------------
--  Proofs by equational reasoning
--------------------------------------------------------------------------------

-- commutativity of addition proved traditionally

+-comm₁ : ∀ a b → a + b ≡ b + a
+-comm₁ zero b = sym (+-zero b)
+-comm₁ (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong suc (+-comm₁ a b) ⟩
  suc (b + a)     ≡⟨ sym (+-suc b a) ⟩
  b + suc a       ∎

-- commutativity of addition proved with holes

+-comm : ∀ a b → a + b ≡ b + a
+-comm zero b = sym (+-zero b)
+-comm (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong! (+-comm a b) ⟩
  suc (b + a)     ≡⟨ cong! (+-suc b a) ⟩
  b + suc a       ∎

-- distributivity of multiplication over addition proved traditionally

*-distrib-+₁ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+₁ zero b c = refl
*-distrib-+₁ (suc a) b c =
    b + c + a * (b + c)          ≡⟨ cong (λ h → b + c + h) (*-distrib-+₁ a b c) ⟩
    (b + c) + (a * b + a * c)    ≡⟨ sym (+-assoc (b + c) (a * b) (a * c)) ⟩
    ((b + c) + a * b) + a * c    ≡⟨ cong (λ h → h + a * c) (+-assoc b c (a * b)) ⟩
    (b + (c + a * b)) + a * c    ≡⟨ cong (λ h → (b + h) + a * c) (+-comm c (a * b)) ⟩
    (b + (a * b + c)) + a * c    ≡⟨ cong (λ h → h + a * c) (sym (+-assoc b (a * b) c)) ⟩
    ((b + a * b) + c) + a * c    ≡⟨ +-assoc (b + a * b) c (a * c) ⟩
    (b + a * b) + (c + a * c)
  ∎

-- distributivity of multiplication over addition proved with holes

*-distrib-+ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+ zero b c = refl
*-distrib-+ (suc a) b c =
  b + c + ⌞ a * (b + c) ⌟         ≡⟨ cong! (*-distrib-+ a b c) ⟩
  ⌞ (b + c) + (a * b + a * c) ⌟   ≡⟨ cong! (+-assoc (b + c) (a * b) (a * c)) ⟩
  ⌞ (b + c) + a * b ⌟ + a * c     ≡⟨ cong! (+-assoc b c (a * b)) ⟩
  (b + ⌞ c + a * b ⌟) + a * c     ≡⟨ cong! (+-comm c (a * b)) ⟩
  ⌞ b + (a * b + c) ⌟ + a * c     ≡⟨ cong! (+-assoc b (a * b) c) ⟩
  ⌞ ((b + a * b) + c) + a * c ⌟   ≡⟨ cong! (+-assoc (b + a * b) c (a * c)) ⟩
  (b + a * b) + (c + a * c)
  ∎


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

-- Some basic theorems on paths and path compositions.
module hott.core.equality.theorems where

open import hott.core

-- The path refl is the left identity under path concatnation.
refl∙p≡p : ∀ {ℓ} {A : Type ℓ}  {x y : A}
                      → ∀ (p : x ≡ y)
                      → refl ∙ p ≡ p
refl∙p≡p refl = refl

-- Alternate form of refl being left identity.
p≡refl∙p : ∀ {ℓ} {A : Type ℓ}  {x y : A}
         → ∀ (p : x ≡ y)
         → p ≡ refl ∙ p
p≡refl∙p p = refl∙p≡p p ⁻¹

-- The path refl is the right identity under path concatnation.
p∙refl≡p : ∀ {ℓ} {A : Type ℓ}  {x y : A}
         → ∀ (p : x ≡ y)
         → p ∙ refl ≡ p

p∙refl≡p refl = refl

-- Alternate form of refl being the right identity.
p≡p∙refl : ∀ {ℓ} {A : Type ℓ}  {x y : A}
         → ∀ (p : x ≡ y)
         → p ≡ p ∙ refl

p≡p∙refl p = p∙refl≡p p ⁻¹

-- The inverse of inverse is identity
p⁻¹⁻¹≡p  : ∀ {ℓ} {A : Type ℓ}  {x y : A}
         → ∀ (p : x ≡ y)
         → (p ⁻¹)⁻¹ ≡ p
p⁻¹⁻¹≡p refl = refl

-- Alternate form of the theorem inverse of inverse is identity.
p≡p⁻¹⁻¹  : ∀ {ℓ} {A : Type ℓ}  {x y : A}
         → ∀ (p : x ≡ y)
         → p ≡ (p ⁻¹)⁻¹
p≡p⁻¹⁻¹ p = p⁻¹⁻¹≡p p ⁻¹

-- Inverse is actually right inverse.
p∙p⁻¹≡refl : ∀ {ℓ} {A : Type ℓ}  {x y : A}
          → ∀ (p : x ≡ y)
          → p ∙ p ⁻¹ ≡ refl
p∙p⁻¹≡refl refl = refl

-- Inverse is actually left inverse.
p⁻¹∙p≡refl : ∀ {ℓ} {A : Type ℓ}  {x y : A}
          → ∀ (p : x ≡ y)
          → p ⁻¹ ∙ p ≡ refl
p⁻¹∙p≡refl refl = refl

-- The associativity of path composition.
assoc :  ∀ {ℓ} {A : Type ℓ}  {u v w x : A}
      → (p : u ≡ v)
      → (q : v ≡ w)
      → (r : w ≡ x)
      → (p ∙ q) ∙ r ≡ p ∙ (q ∙ r)
assoc refl refl refl = refl


{-# OPTIONS --sized-types #-}
module SNat.Order.Properties where

open import Data.Sum renaming (_⊎_ to _∨_)
open import Relation.Binary.PropositionalEquality
open import Size
open import SNat
open import SNat.Order

tot≤ : {ι ι' : Size} → (m : SNat {ι}) → (n : SNat {ι'}) → m ≤ n ∨ n ≤ m
tot≤ zero n = inj₁ (z≤n n)
tot≤ m zero = inj₂ (z≤n m)
tot≤ (succ m) (succ n)
   with tot≤ m n
...| inj₁ m≤n = inj₁ (s≤s m≤n)
...| inj₂ n≤m = inj₂ (s≤s n≤m)

refl≤ : {n : SNat} → n ≤ n
refl≤ {n}
    with tot≤ n n
... | inj₁ n≤n = n≤n
... | inj₂ n≤n = n≤n

trans≤ :  {ι ι' ι'' : Size}{n : SNat {ι}}{n' : SNat {ι'}}{n'' : SNat {ι''}} → n ≤ n' → n' ≤ n'' → n ≤ n''
trans≤ {n'' = n''} (z≤n n') _ = z≤n n''
trans≤ (s≤s n≤n') (s≤s n'≤n'') = s≤s (trans≤ n≤n' n'≤n'')

refl≅ : {n : SNat} → n ≅ n
refl≅ {zero} = z≅z
refl≅ {succ _} = s≅s refl≅

trans≅ :  {ι ι' ι'' : Size}{n : SNat {ι}}{n' : SNat {ι'}}{n'' : SNat {ι''}} → n ≅ n' → n' ≅ n'' → n ≅ n''
trans≅ z≅z z≅z = z≅z
trans≅ (s≅s n≅n') (s≅s n'≅n'') = s≅s (trans≅ n≅n' n'≅n'')

lemma-z≤′n : {ι ι' : Size}(n : SNat {ι}) → zero {ι'} ≤′ n
lemma-z≤′n zero = ≤′-eq z≅z
lemma-z≤′n (succ n) = ≤′-step (lemma-z≤′n n)

lemma-s≤′s : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≤′ n → succ m ≤′ succ n
lemma-s≤′s (≤′-eq m≅n) = ≤′-eq (s≅s m≅n)
lemma-s≤′s (≤′-step m≤′n) = ≤′-step (lemma-s≤′s m≤′n)

lemma-≤-≤′ : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≤ n → m ≤′ n
lemma-≤-≤′ (z≤n n) = lemma-z≤′n n
lemma-≤-≤′ (s≤s m≤n) = lemma-s≤′s (lemma-≤-≤′ m≤n)

lemma-≅-≤ : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≅ n → m ≤ n
lemma-≅-≤ z≅z = z≤n zero
lemma-≅-≤ (s≅s m≅n) = s≤s (lemma-≅-≤ m≅n)

lemma-≡-≤′ : {a b c : SNat} → b ≡ a → a ≤′ c → b ≤′ c
lemma-≡-≤′ b≡a a≤′c rewrite b≡a = a≤′c

lemma-n≤sn : {ι : Size}(n : SNat {ι}) → n ≤ succ n
lemma-n≤sn zero = z≤n (succ zero)
lemma-n≤sn (succ n) = s≤s (lemma-n≤sn n)

lemma-≤′-≤ : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}} → m ≤′ n → m ≤ n
lemma-≤′-≤ (≤′-eq m≅n) = lemma-≅-≤ m≅n
lemma-≤′-≤ (≤′-step {n = n} m≤′n) = trans≤ (lemma-≤′-≤ m≤′n) (lemma-n≤sn n)

refl≤′ : {n : SNat} → n ≤′ n
refl≤′ = lemma-≤-≤′ refl≤

trans≤′ :  {ι ι' ι'' : Size}{n : SNat {ι}}{n' : SNat {ι'}}{n'' : SNat {ι''}} → n ≤′ n' → n' ≤′ n'' → n ≤′ n''
trans≤′ n≤′n' n'≤′n'' = lemma-≤-≤′ (trans≤ (lemma-≤′-≤ n≤′n') (lemma-≤′-≤ n'≤′n''))


module x01-842Naturals where

-- This is a comment.

{-
  This is a multi-line comment
-}

-- Definition of datatype representing natural numbers. ♭

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

-- A couple of definitions using this datatype.

one : ℕ
one = suc zero

two : ℕ
two = suc (suc zero)

-- I could have also said two = suc one.

-- PLFA exercise: write out seven.

-- Pragma to use decimal notation as shorthand.

{-# BUILTIN NATURAL ℕ #-}

-- Some useful imports from the standard library:

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

-- Addition on naturals.

_+_ : ℕ → ℕ → ℕ
zero + n = n
suc m + n = suc {!m + n!}

-- Agda normalization; proof of equality.

_ : 2 + 3 ≡ 5
_ = refl

-- Equational reasoning.

_ : 2 + 3 ≡ 5
_ =
  begin
    2 + 3
  ≡⟨⟩    -- is shorthand for
    (suc (suc zero)) + (suc (suc (suc zero)))
  ≡⟨⟩    -- many steps condensed
    5
  ∎

-- PLFA shows longhand and shorthand are interchangeable.

-- PLFA exercise: write out the reduction for 3+4 equationally.

-- Multiplication.

_*_ : ℕ → ℕ → ℕ
m * n = {!!}

_ =
  begin
    2 * 3
  ≡⟨⟩    -- many steps condensed
    6
  ∎

-- PLFA exercise: write out 3*4.

-- 842 exercise: Exponentiation (1 point)
-- Define exponentiation (m raised to the power n).

_^_ : ℕ → ℕ → ℕ
m ^ n = {!!}

-- One test for exponentiation (you should write others).

_ : 2 ^ 3 ≡ 8
_ = refl

-- Monus (subtraction for naturals, bottoms out at zero).

_∸_ : ℕ → ℕ → ℕ
m ∸ n = {!!}

_ =
  begin
     3 ∸ 2
  ≡⟨⟩ -- many steps condensed
     1
  ∎

_ =
  begin
     2 ∸ 3
  ≡⟨⟩ -- many steps condensed
     0
  ∎

-- PLFA exercise: write out 5 ∸ 3 and 3 ∸ 5.

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

-- These pragmas will register our operations, if we want,
-- so that they work with decimal notation.

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

-- Binary representation.
-- Modified from PLFA exercise (thanks to David Darais).

data Bin-ℕ : Set where
  bits : Bin-ℕ
  _x0 : Bin-ℕ → Bin-ℕ
  _x1 : Bin-ℕ → Bin-ℕ

-- Our representation of zero is different from PLFA.
-- We use the empty sequence of bits (more consistent).

bin-zero : Bin-ℕ
bin-zero = bits

bin-one : Bin-ℕ
bin-one = bits x1     -- 1 in binary

bin-two : Bin-ℕ
bin-two = bits x1 x0  -- 10 in binary

-- 842 exercise: Increment (1 point)
-- Define increment (add one).

inc : Bin-ℕ → Bin-ℕ
inc m = {!!}

-- An example/test of increment (you should create others).

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

-- 842 exercise: To/From (2 points)
-- Define 'tob' and 'fromb' operations
-- to convert between unary (ℕ) and binary (Bin-ℕ) notation.
-- Hint: avoid addition and multiplication,
-- and instead use the provided dbl (double) function.
-- This will make later proofs easier.
-- I've put 'b' on the end of the operations to
-- avoid a name clash in a later file.
-- It also makes the direction clear when using them.

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

tob : ℕ → Bin-ℕ
tob m = {!!}

fromb : Bin-ℕ → ℕ
fromb n = {!!}

-- A couple of examples/tests (you should create others).

_ : tob 6 ≡ bits x1 x1 x0
_ = refl

_ : fromb (bits x1 x1 x0) ≡ 6
_ = refl

-- 842 exercise: BinAdd (2 points)
-- Write the addition function for binary notation.
-- Do NOT use 'to' and 'from'. Work with Bin-ℕ as if ℕ did not exist.
-- Hint: use recursion on both m and n.

_bin-+_ : Bin-ℕ → Bin-ℕ → Bin-ℕ
m bin-+ n = {!!}

-- Tests can use to/from, or write out binary constants as below.
-- Again: write more tests!

_ : (bits x1 x0) bin-+ (bits x1 x1) ≡ (bits x1 x0 x1)
_ = refl

-- That's it for now, but we will return to binary notation later.

-- Many definitions from above are also in the standard library.

-- open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _^_; _∸_)

-- Unicode used in this chapter:

{-
    ℕ  U+2115  DOUBLE-STRUCK CAPITAL N (\bN)
    →  U+2192  RIGHTWARDS ARROW (\to, \r, \->)
    ∸  U+2238  DOT MINUS (\.-)
    ≡  U+2261  IDENTICAL TO (\==)
    ⟨  U+27E8  MATHEMATICAL LEFT ANGLE BRACKET (\<)
    ⟩  U+27E9  MATHEMATICAL RIGHT ANGLE BRACKET (\>)
    ∎  U+220E  END OF PROOF (\qed)
-}


-- For the first task, we are asked to prove that max is idempotent and
-- associative. The proves presented in this file are as succint as they
-- possibly can. The proves come with added comments to aid understanding as
-- the proves are meant to be short and simple but not very legible. The
-- solution to task 1 starts in lines 44 and 51.

module sv20.assign2.First where

open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat using (_≤_; z≤n; s≤s; _<_)
open import Relation.Nullary using (¬_)
open import Data.Empty using (⊥-elim)
open import Function using (_∘_)

-- First, we define the max function. Notice, how the function differs from the
-- definition offered for the assignment
max : ℕ → ℕ → ℕ
max zero    n       = n
max (suc m) zero    = suc m
max (suc m) (suc n) = suc (max m n)

-- Nonetheless, we can prove that the definition of max presented in the
-- assignment follows from ours.
-- In athena, the first part of the definition corresponds to the sentence
-- "y < x ==> x max y = x", which translated into Agda corresponds to:
less : ∀ {x y} → y < x → max x y ≡ x
-- and it is easily proven by:
less {zero} ()                       -- Nonesense case
less {suc m} {zero} (s≤s z≤n) = refl -- Simplest case, y ≡ 0
less {suc m} {suc n} (s≤s n<m) = cong suc (less n<m)  -- if "n < m → max m n ≡ m" then "suc n < suc m → max (suc m) (suc n) ≡ (suc m)"

-- The second part of the definition asserts (in Athena) that
-- "~ y < x ==> x max y = y"
not-less : ∀ {x y} → ¬ (y < x) → max x y ≡ y
-- which is easily proven by induction with:
not-less {zero} {n} ¬y<x = refl -- Base case 1
not-less {suc m} {zero} ¬z<sm = ⊥-elim (¬z<sm (s≤s z≤n)) -- Base case 2
not-less {suc m} {suc n} ¬sn<sm = cong suc (not-less (¬sn<sm ∘ s≤s)) -- Inductive case
--not-less {suc m} {suc n} ¬sn<sm = cong suc (not-less {m} {n} (λ n<m → ¬sn<sm (s≤s n<m)))
-- The pattern ¬sn<sm ∘ s≤s means that you are creating a function ¬n<m from ¬sn<sm

-- SOLUTIONS
-- max is idempotent
-- By induction:
max-idem : ∀ x → max x x ≡ x
max-idem zero    = refl                  -- Base case: max 0 0 ≡ 0
max-idem (suc n) = cong suc (max-idem n) -- Inductive case: if "max n n ≡ n" then "max (suc n) (suc n) ≡ suc n" because "max (suc n) (suc n) ≡ suc (max n n)"

-- max is associative
-- By induction:
max-assoc : ∀ x y z → max x (max y z) ≡ max (max x y) z
max-assoc zero    _       _       = refl -- Base cases: when one of the numbers is 0, then "max 0 n ≡ n" by definition of max
max-assoc (suc m) zero    _       = refl --
max-assoc (suc m) (suc n) zero    = refl --
max-assoc (suc m) (suc n) (suc o) = cong suc (max-assoc m n o) -- Inductive case: if "max m (max n o) ≡ max (max m n) o" then "max (suc m) (max (suc n) (suc o)) ≡ suc (max m (max n o)) ≡ suc (max (max m n) o) ≡ max (max (suc m) (suc n)) (suc o)"


open import Relation.Binary.Core

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

open import Data.List
open import Data.Sum
open import InsertSort.Impl1 _≤_ tot≤
open import List.Permutation.Base A

lemma-insert∼/ : (x : A)(xs : List A) → (insert x xs) / x ⟶ xs
lemma-insert∼/ x [] = /head
lemma-insert∼/ x (y ∷ ys)
    with tot≤ x y
... | inj₁ _ = /head
... | inj₂ _ = /tail (lemma-insert∼/ x ys)

lemma-insert∼ : {xs ys : List A}(x : A) → xs ∼ ys → (x ∷ xs) ∼ insert x ys
lemma-insert∼ {xs} {ys} x xs∼ys = ∼x  /head (lemma-insert∼/ x ys) xs∼ys

theorem-insertSort∼ : (xs : List A) → xs ∼ insertSort xs
theorem-insertSort∼ [] = ∼[]
theorem-insertSort∼ (x ∷ xs) = lemma-insert∼ x (theorem-insertSort∼ xs)


module List.Order.Simple.Properties  {A : Set}
                     (_≤_ : A → A → Set)
                     (trans≤ : {x y z : A} → x ≤ y → y ≤ z → x ≤ z) where

open import Data.List
open import List.Order.Simple _≤_
open import List.Sorted _≤_

lemma-≤-*≤ : {x y : A}{xs : List A} → xs *≤ y → y ≤ x → xs *≤ x
lemma-≤-*≤ lenx y≤x  = lenx
lemma-≤-*≤ (lecx z≤y zs≤y) y≤x = lecx (trans≤ z≤y y≤x) (lemma-≤-*≤ zs≤y y≤x)

lemma-++-*≤ : {x y : A}{xs ys : List A} → y ≤ x → xs *≤ y → ys *≤ x → (xs ++ (y ∷ ys)) *≤ x
lemma-++-*≤ y≤x lenx ys≤x = lecx y≤x ys≤x
lemma-++-*≤ y≤x (lecx z≤y zs≤y) ys≤x = lecx (trans≤ z≤y y≤x) (lemma-++-*≤ y≤x zs≤y ys≤x)

lemma-≤-≤* : {x y : A}{xs : List A} → x ≤ y → y ≤* xs → x ≤* xs
lemma-≤-≤* x≤y genx = genx
lemma-≤-≤* x≤y (gecx y≤z y≤zs) = gecx (trans≤ x≤y y≤z) (lemma-≤-≤* x≤y y≤zs)

lemma-≤*-++ : {x y : A}{xs ys : List A} → x ≤ y → x ≤* xs → y ≤* ys → x ≤* (xs ++ (y ∷ ys))
lemma-≤*-++ x≤y genx y≤ys = gecx x≤y (lemma-≤-≤* x≤y y≤ys)
lemma-≤*-++ x≤y (gecx x≤z x≤zs) y≤ys = gecx x≤z (lemma-≤*-++ x≤y x≤zs y≤ys)

lemma-sorted++ : {x : A}{xs ys : List A} → xs *≤ x → x ≤* ys → Sorted xs → Sorted ys → Sorted (xs ++ (x ∷ ys))
lemma-sorted++ {x = x} lenx genx _ _ = singls x
lemma-sorted++ lenx (gecx u≤y _) _ sys = conss u≤y sys
lemma-sorted++ (lecx x≤u xs≤*u) u*≤ys (singls x) sys = conss x≤u (lemma-sorted++ xs≤*u u*≤ys nils sys)
lemma-sorted++ (lecx x≤u xs≤*u) u*≤ys (conss x≤z sxs) sys = conss x≤z (lemma-sorted++ xs≤*u u*≤ys sxs sys)


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong-app)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Data.Product using (∃; _,_)

+-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))
  ≡⟨ cong suc (+-assoc m n p) ⟩
    suc ((m + n) + p)
  ≡⟨⟩
    (suc m + n) + p
  ∎

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

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

*-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
  ≡⟨⟩
    p + (m + n) * p
  ≡⟨ cong (_+_ p) (*-distrib-+ m n p) ⟩
    p + (m * p + n * p)
  ≡⟨ +-assoc p (m * p) (n * p) ⟩
    (p + m * p) + n * p
  ≡⟨⟩
    suc m * p + n * p
  ∎

data even : ℕ → Set where
  ev0 : even zero
  ev+2 : ∀ {n : ℕ} → even n → even (suc (suc n))

lemma : ∀ (m : ℕ) → 2 * suc m ≡ suc (suc (2 * m))
lemma m =
  begin
    2 * suc m
  ≡⟨⟩
    suc m + (suc m + zero)
  ≡⟨⟩
    suc (m + (suc (m + zero)))
  ≡⟨ cong suc (+-suc m (m + zero)) ⟩
    suc (suc (m + (m + zero)))
  ≡⟨⟩
    suc (suc (2 * m))
  ∎

ev-ex : ∀ {n : ℕ} → even n → ∃(λ (m : ℕ) → 2 * m ≡ n)
ev-ex ev0 =  (0 , refl)
ev-ex (ev+2 ev) with ev-ex ev
... | (m , refl) = (suc m , lemma m)

ex-ev : ∀ {n : ℕ} → ∃(λ (m : ℕ) → 2 * m ≡ n) → even n
ex-ev (zero , refl) = ev0
ex-ev (suc m , refl) rewrite lemma m = ev+2 (ex-ev (m , refl))

-- I can't see how to avoid using rewrite in the second proof,
-- or how to use rewrite in the first proof!


module x03relations 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; +-identityʳ; *-comm; +-suc)

{-
------------------------------------------------------------------------------
-- DEFINING RELATIONS : INEQUALITY ≤

z≤n --------
    zero ≤ n

        m ≤     n
s≤s -------------
    suc m ≤ suc n
-}

-- INDEXED datatype : the type m ≤ n is indexed by two naturals, m and n
data _≤_ : ℕ → ℕ → Set where

  -- base case holds for all naturals
  z≤n : ∀ {n : ℕ}    -- IMPLICIT args
      --------
    → zero ≤ n

  -- inductive case holds if m ≤ n
  s≤s : ∀ {m n : ℕ}  -- IMPLICIT args
    →     m ≤     n
      -------------
    → suc m ≤ suc n

{-
proof 2 ≤ 4

  z≤n -----
      0 ≤ 2
 s≤s -------
      1 ≤ 3
s≤s ---------
      2 ≤ 4
-}

_ : 2 ≤ 4
_ = s≤s (s≤s z≤n) -- no explicit 'n'     arg  to z≤n because implicit
                  -- no explicit 'm' 'n' args to s≤s because implicit

-- can be explicit

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

_ : 2 ≤ 4 -- with named implicit args
_ = s≤s {m = 1} {n = 3} (s≤s {m = 0} {n = 2} (z≤n {n = 2}))

_ : 2 ≤ 4 -- with some implicit named args
_ = s≤s {n = 3} (s≤s {n = 2} z≤n)

-- infer explicit term via _
-- e.g., +-identityʳ variant with implicit arguments
+-identityʳ′ : ∀ {m : ℕ} → m + zero ≡ m
+-identityʳ′ = +-identityʳ _ -- agda infers _ from context (if it can)

-- precedence

infix 4 _≤_

------------------------------------------------------------------------------
-- DECIDABILITY : can compute ≤ : see Chapter Decidable

{-
------------------------------------------------------------------------------
-- INVERSION

above def goes from smaller to larger things (e.g., m ≤ n to suc m ≤ suc n)

sometimes go from bigger to smaller things.

only one way to prove suc m ≤ suc n, for any m n

use it to invert rule
-}

inv-s≤s : ∀ {m n : ℕ}
  → suc m ≤ suc n
    -------------
  →     m ≤     n
inv-s≤s (s≤s m≤n) = m≤n
{-           ^
          variable name  (m ≤ n (with spaces) is a type)

m≤n is of type m ≤ n

convention : var name from type

not every rule is invertible
e.g., rule for z≤n has no non-implicit hypotheses, so nothing to invert

another example inversion
-}

inv-z≤n : ∀ {m : ℕ}
  → m ≤ zero
    --------
  → m ≡ zero -- only one way a number can be ≤ zero
inv-z≤n z≤n = refl

{-
------------------------------------------------------------------------------
-- PROPERTIES OF ORDERING RELATIONS

- REFLEXIVE       : ∀ n    , n ≤ n
- TRANSITIVE      : ∀ m n p, if m ≤ n && n ≤ p then m ≤ p
- ANTI-SYMMETRIC  : ∀ m n  , if m ≤ n && n ≤ m then m ≡ n
- TOTAL           : ∀ m n  , either m ≤ n or n ≤ m

_≤_ satisfies all 4

names for some combinations:

PREORDER      : reflexive and transitive
PARTIAL ORDER : preorder      that is also anti-symmetric
TOTAL ORDER   : partial order that is also total

Exercise orderings (practice)

preorder that is not a partial order:

-- https://math.stackexchange.com/a/2217969

partial order that is not a total order:

-- https://math.stackexchange.com/a/367590

-- other properties

- SYMMETRIC : ∀ x y, if x R y then y R x

------------------------------------------------------------------------------
REFLEXIVITY
-}

-- proof is via induction on implicit arg n
≤-refl : ∀ {n : ℕ} -- implicit arg to make it easier to invoke
    -----
  → n ≤ n

≤-refl {zero}  = z≤n        -- zero  ≤ zero
-- inductive case applies IH '≤-refl {n}' for a proof of n ≤ n to 's≤s' giving proof suc n ≤ suc n
≤-refl {suc n} = s≤s ≤-refl -- suc n ≤ suc n

{-
------------------------------------------------------------------------------
TRANSITIVITY
-}

-- inductive proof using evidence m ≤ n
≤-trans : ∀ {m n p : ℕ}
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p

-- base
-- 1st first inequality holds by z≤n
--            v
≤-trans      z≤n         _  = z≤n
{-                       ^     ^
                         |     now must show zero ≤ p; follows by z≤n
n ≤ p case is irrelevant (written _)

-}

{-
inductive
-- 1st inequality
--          |     2nd inequality
            v         v -}
≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)
{-
1st proves
   suc m ≤ suc n
2nd proves
           suc n ≤ suc p
must now show
   suc m         ≤ suc p

IH '≤-trans m≤n n≤p' establishes m ≤ p

goal follows by applying s≤s

≤-trans (s≤s m≤n) z≤n case cannot arise since
- 1st inequality implies middle value is suc n
- 2nd inequality implies that it is zero

-}

≤-trans′ : ∀ (m n p : ℕ) -- ALTERNATIVE with explicit args
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p
≤-trans′   zero       _       _       z≤n         _  = z≤n
≤-trans′ (suc m) (suc n) (suc p) (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans′ m n p m≤n n≤p)

{-
technique of induction on evidence that a property holds
- e.g., inducting on evidence that m ≤ n
rather than induction on values of which the property holds
- e.g., inducting on m
is often used

------------------------------------------------------------------------------
ANTI-SYMMETRY
-}

-- 842
-- proof via rewrite
≤-antisym' : ∀ {m n : ℕ}
  → m ≤ n
  → n ≤ m
    -----
  → m ≡ n
≤-antisym'      z≤n       z≤n  = refl
≤-antisym' (s≤s m≤n) (s≤s n≤m) rewrite ≤-antisym' m≤n n≤m = refl

-- proof via induction over the evidence that m ≤ n and n ≤ m hold
≤-antisym : ∀ {m n : ℕ}
  → m ≤ n
  → n ≤ m
    -----
  → m ≡ n
≤-antisym      z≤n       z≤n  = refl
≤-antisym (s≤s m≤n) (s≤s n≤m) = cong suc (≤-antisym m≤n n≤m)

{-
base : both inequalities hold by z≤n
- so given zero ≤ zero and zero ≤ zero
- shows zero ≡ zero (via Reflexivity of equality)

inductive
- after using evidence for 1st and 2nd inequalities
- have suc m ≤ suc n and suc n ≤ suc m
- must show suc m ≡ suc n
- IH '≤-antisym m≤n n≤m' establishes m ≡ n
- goal follows by congruence

Exercise ≤-antisym-cases (practice) TODO : describe why missing case OK

The above proof omits cases where one argument is z≤n and one argument is s≤s.
Why is it ok to omit them?

-- Your code goes here

------------------------------------------------------------------------------
TOTAL
-}

-- datatype with PARAMETERS
data Total (m n : ℕ) : Set where

  forward :
      m ≤ n
      ---------
    → Total m n

  flipped :
      n ≤ m
      ---------
    → Total m n

{-
Evidence that Total m n holds is either of the form
- forward m≤n or
- flipped n≤m
where m≤n and n≤m are evidence of m ≤ n and n ≤ m respectively

(above definition could also be written as a disjunction; see Chapter Connectives.)

above data type uses PARAMETERS m n --- equivalent to following INDEXED datatype:
-}

data Total′ : ℕ → ℕ → Set where

  forward′ : ∀ {m n : ℕ}
    → m ≤ n
      ----------
    → Total′ m n

  flipped′ : ∀ {m n : ℕ}
    → n ≤ m
      ----------
    → Total′ m n

{-
Each parameter of the type translates as an implicit parameter of each constructor.
Unlike an indexed datatype, where the indexes can vary (as in zero ≤ n and suc m ≤ suc n),
in a parameterised datatype the parameters must always be the same (as in Total m n).

Parameterised declarations are shorter, easier to read,
and occasionally aid Agda’s termination checker.
Use them in preference to indexed types when possible.

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

show ≤ is a total order by induction over 1st and 2nd args

uses WITH
-}

≤-total : ∀ (m n : ℕ) → Total m n

-- base : 1st arg zero so forward case holds with z≤n as evidence that zero ≤ n
≤-total   zero       n = forward z≤n

-- base : 2nd arg zero so flipped case holds with z≤n as evidence that zero ≤ suc m
≤-total (suc m)   zero = flipped z≤n

-- inductive : IH establishes one of
≤-total (suc m) (suc n) with ≤-total m n
-- forward case of IH with m≤n as evidence that m ≤ n
-- follows that forward case of prop holds with s≤s m≤n as evidence that suc m ≤ suc n
... | forward m≤n = forward (s≤s m≤n)
-- flipped case of IH with n≤m as evidence that n ≤ m
-- follows that flipped case of prop holds with s≤s n≤m as evidence that suc n ≤ suc m
... | flipped n≤m = flipped (s≤s n≤m)

{-
WITH expression and one or more subsequent lines
each line begins ... | followed by pattern and right-hand side

WITH equivalent to defining a helper function:
-}

≤-total′ : ∀ (m n : ℕ) → Total m n
≤-total′   zero       n  = forward z≤n
≤-total′ (suc m)   zero  = flipped z≤n
≤-total′ (suc m) (suc n) = helper (≤-total′ m n)
 where
  helper : Total m n → Total (suc m) (suc n)
  helper (forward m≤n) = forward (s≤s m≤n)
  helper (flipped n≤m) = flipped (s≤s n≤m)

{-
WHERE

vars bound on the left-hand side of the preceding equation (e.g., m n) in scope in nested def
any identifiers bound in nested definition (e.g., helper)
in scope in right-hand side of preceding equation

If both arguments are equal, then both cases hold and we could return evidence of either.
In the code above we return the forward case, but there is a variant that returns the flipped case:
-}

≤-total″ : ∀ (m n : ℕ) → Total m n
≤-total″      m    zero  = flipped z≤n
≤-total″   zero  (suc n) = forward z≤n
≤-total″ (suc m) (suc n) with ≤-total″ m n
... | forward m≤n = forward (s≤s m≤n)
... | flipped n≤m = flipped (s≤s n≤m)

-- differs from original : pattern matches on 2nd arg before 1st

{-
------------------------------------------------------------------------------
MONOTONICITY ∀ {m n p q : ℕ} → m ≤ n → p ≤ q → m + p ≤ n + q

addition is monotonic on the right
proof by induction on 1st arg
-}

+-monoʳ-≤ : ∀ (n p q : ℕ)
  →     p ≤     q
    -------------
  → n + p ≤ n + q
-- base      : 1st is zero;        zero + p  ≤   zero + q
--                  def/eq                p  ≤          q
-- evidence given by arg p≤q
+-monoʳ-≤ zero    p q p≤q  =  p≤q
-- inductive : 1st is suc n;      suc n + p  ≤  suc n + q
--                  def/eq;      suc (n + p) ≤ suc (n + q)
-- IH +-monoʳ-≤ n p q p≤q establishes n + p ≤ n + q
-- goal follows by applying s≤s
+-monoʳ-≤ (suc n) p q p≤q  =  s≤s (+-monoʳ-≤ n p q p≤q)

{-
addition is monotonic on the left
via previous result and commutativity of addition:
-}
+-monoˡ-≤ : ∀ (m n p : ℕ)
  → m     ≤ n
    -------------
  → m + p ≤ n + p
+-monoˡ-≤ m n p m≤n         -- m + p ≤ n + p
  rewrite
    +-comm m p              -- p + m ≤ n + p
  | +-comm n p              -- p + m ≤ p + n
 = +-monoʳ-≤ p m n m≤n

-- combine above results:

+-mono-≤ : ∀ (m n p q : ℕ)
  → m     ≤ n
  →     p ≤     q
    -------------
  → m + p ≤ n + q
+-mono-≤ m n p q m≤n p≤q
  = ≤-trans               -- combining below via transitivity proves m + p ≤ n + q
    (+-monoˡ-≤ m n p m≤n) -- proves m + p ≤ n + p
    (+-monoʳ-≤ n p q p≤q) -- proves n + p ≤ n + q

{-
------------------------------------------------------------------------------
Exercise *-mono-≤ (stretch) Show that multiplication is monotonic with regard to inequality.
-}
-------------------------
-- multiplication is monotonic on the right
*-monoʳ-≤ : ∀ (n p q : ℕ)
  →     p ≤     q
    -------------
  → n * p ≤ n * q

*-monoʳ-≤ zero p q p≤q          --  zero * p ≤  zero * q
                                --  zero     ≤  zero
  = z≤n

*-monoʳ-≤ n zero q p≤q          --  n * zero ≤ n * q
  rewrite
    *-comm n zero               --         0 ≤ n * q
  = z≤n

*-monoʳ-≤ n p zero p≤q          --     n * p ≤ n * zero
  rewrite
    *-comm n zero               --     n * p ≤ 0
  | inv-z≤n p≤q                 --     n * 0 ≤ 0
  | *-comm n zero               --         0 ≤ 0
  = z≤n

*-monoʳ-≤ n (suc p) (suc q) p≤q -- n * suc p ≤ n * suc q
  rewrite
    *-comm n (suc p)            -- n + p * n ≤ n * suc q
  | *-comm n (suc q)            -- n + p * n ≤ n + q * n
  | *-comm p n                  -- n + n * p ≤ n + q * n
  | *-comm q n                  -- n + n * p ≤ n + n * q
  = +-monoʳ-≤ n (n * p) (n * q) (*-monoʳ-≤ n p q (inv-s≤s p≤q))

-------------------------
-- multiplication is monotonic on the left
*-monoˡ-≤ : ∀ (m n p : ℕ)
  → m     ≤ n
    -------------
  → m * p ≤ n * p

*-monoˡ-≤ zero n p m≤n          --  zero * p ≤ n * p
                                --  zero     ≤ n * p
  = z≤n

*-monoˡ-≤ m zero p m≤n          --     m * p ≤ zero * p
                                --     m * p ≤ zero
  rewrite inv-z≤n m≤n           --     0 * p ≤ 0
                                --      zero ≤ 0
  = z≤n

*-monoˡ-≤ (suc m) (suc n) p m≤n -- suc m * p ≤ suc n * p
                                -- p + m * p ≤ p + n * p
  = +-monoʳ-≤ p (m * p) (n * p) (*-monoˡ-≤ m n p (inv-s≤s m≤n))

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

*-mono-≤ : ∀ (m n p q : ℕ)
  → m     ≤ n
  →     p ≤     q
    -------------
  → m * p ≤ n * q
*-mono-≤ m n p q m≤n p≤q
  = ≤-trans
    (*-monoˡ-≤ m n p m≤n)
    (*-monoʳ-≤ n p q p≤q)

{-
------------------------------------------------------------------------------
STRICT INEQUALITY <
-}

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n -- diff from '≤' : 'zero ≤ n'

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

{-
NOT REFLEXIVE

IRREFLEXIVE : n < n never holds for any n

TRANSITIVE

NOT TOTAL

TRICHOTOMY: ∀ m n, one of m < n, m ≡ n, or m > n holds
- where m > n hold when n < m

MONOTONIC with regards to ADDITION and MULTIPLICATION

negation required to prove (so deferred to Chapter Negation)
- irreflexivity
- trichotomy case are mutually exclusive

------------------------------------------------------------------------------
show suc m ≤ n implies m < n (and conversely)
-}

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

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

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

{-
can then give an alternative derivation of the properties of strict inequality
(e.g., transitivity) by exploiting the corresponding properties of inequality

------------------------------------------------------------------------------
Exercise <-trans (recommended) : strict inequality is transitive.
-}

<-trans : ∀ {m n p : ℕ}
  → m < n
  → n < p
    -----
  → m < p
<-trans  {zero}     {n}     {p}      z<s  (s<s n<p) = z<s
<-trans {suc m} {suc n} {suc p} (s<s m<n) (s<s n<p) = s<s (<-trans {m} {n} {p} m<n n<p)

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

{-
------------------------------------------------------------------------------
Exercise trichotomy (practice)

Show that strict inequality satisfies a weak version of trichotomy,
in the sense that for any m and n that one of the following holds:
- m < n
- m ≡ n
- m > n

Define m > n to be the same as n < m.

Need a data declaration, similar to that used for totality.
(Later will show that the three cases are exclusive after negation is introduced.)
-}

-- from 842
data Trichotomy (m n : ℕ) : Set where
  is-< : m < n → Trichotomy m n
  is-≡ : m ≡ n → Trichotomy m n
  is-> : n < m → Trichotomy m n

-- hc
<-trichotomy : ∀ (m n : ℕ) → Trichotomy m n
<-trichotomy   zero    zero  = is-≡ refl
<-trichotomy   zero  (suc n) = is-< z<s
<-trichotomy (suc m)   zero  = is-> z<s
<-trichotomy (suc m) (suc n) = helper (<-trichotomy m n)
 where
  helper : Trichotomy m n -> Trichotomy (suc m) (suc n)
  helper (is-< x) = is-< (s<s x)
  helper (is-≡ x) = is-≡ (cong suc x)
  helper (is-> x) = is-> (s<s x)

{-
------------------------------------------------------------------------------
Exercise +-mono-< (practice)

Show that addition is monotonic with respect to strict inequality.
As with inequality, some additional definitions may be required.
-}

-- HC
-- these proof are literal cut/paste/change '≤' to '<'
-- no additional defs were required

+-monoʳ-< : ∀ (n p q : ℕ)
  → p < q
    -------------
  → n + p < n + q
+-monoʳ-< zero    p q p<q  =  p<q
+-monoʳ-< (suc n) p q p<q  =  s<s (+-monoʳ-< n p q p<q)

+-monoˡ-< : ∀ (m n p : ℕ)
  → m < n
    -------------
  → m + p < n + p
+-monoˡ-< m n p m<n
  rewrite
    +-comm m p
  | +-comm n p
 = +-monoʳ-< p m n m<n

+-mono-< : ∀ (m n p q : ℕ)
  → m < n
  → p < q
    -------------
  → m + p < n + q
+-mono-< m n p q m<n p<q
  = <-trans
    (+-monoˡ-< m n p m<n)
    (+-monoʳ-< n p q p<q)

{-
------------------------------------------------------------------------------
Exercise ≤-iff-< (recommended) : suc m ≤ n implies m < n, and conversely
-}

-- 842 exercise: LEtoLTS (1 point) ≤-<-to

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

-- 842 exercise: LEStoLT (1 point) ≤-<--to′

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

-- 842 exercise: LTtoSLE (1 point) ≤-<-from

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

-- 842 exercise: LTStoLE (1 point) ≤-<-from′

m<sucn→m≤n : ∀ {m n : ℕ}
  → m < suc n
  → m ≤     n
m<sucn→m≤n  {zero}              z<n  = z≤n
m<sucn→m≤n {suc m} {suc n} (s<s m<n) = s≤s (m<sucn→m≤n {m} {n} m<n)
--                          ^
--                   critical move

{-
------------------------------------------------------------------------------
Exercise <-trans-revisited (practice)

Give an alternative proof that strict inequality is transitive,
using the relation between strict inequality and inequality
and the fact that inequality is transitive.

-- 842: use the above to give a proof of <-trans that uses ≤-trans
-}

n<p→n<sucp : ∀ {n p : ℕ}
  → n <     p
  → n < suc p
n<p→n<sucp                 z<s = z<s
n<p→n<sucp {suc n} {suc p} n<p = s<s (n<p→n<sucp {n} {p} (inv-s<s n<p))

<-trans'' : ∀ {m n p : ℕ}
  → m < n
  → n < p
    -----
  → m < p
<-trans''  {zero} {suc n} {suc p}      z<s         _  = z<s
<-trans'' {suc m} {suc n} {suc p} (s<s m<n) (s<s n<p)
  = sucm≤n→m<n
      (≤-trans (m<n→sucm≤n (s<s             m<n))
               (m<sucn→m≤n (s<s (n<p→n<sucp n<p))))

{-
------------------------------------------------------------------------------
EVEN and ODD : MUTUALLY RECURSIVE DATATYPE DECLARATION and OVERLOADED CONSTRUCTORS

inequality and strict inequality are BINARY RELATIONS

even and odd are UNARY RELATIONS, sometimes called PREDICATES
-}

-- identifier must be defined before it is used, so declare both before giving constructors.
data even : ℕ → Set
data odd  : ℕ → Set

data even where

  zero :           -- overloaded with nat def
      ---------
      even zero

  suc  : ∀ {n : ℕ}
    → odd       n
      ------------
    → even (suc n)

data odd where

  suc  : ∀ {n : ℕ} -- suc is overloaded with one above and nat def
    → even     n
      -----------
    → odd (suc n)
{-
overloading constructors is OK (handled by type inference
overloading defined names NOT OK
best practice : only overload related meanings
-}

-- mutually recursive proof functions : give types first, then impls

-- sum of two even numbers is even
e+e≡e : ∀ {m n : ℕ}
  → even m
  → even n
    ------------
  → even (m + n)

-- sum of even and odd is odd
o+e≡o : ∀ {m n : ℕ}
  → odd m
  → even n
    -----------
  → odd (m + n)

-- given: zero is evidence that 1st is even
-- given: 2nd is even
-- result: even because 2nd is even
e+e≡e zero     en = en
-- given: 1st is even because it is suc of odd
-- given: 2nd is even
-- result: even because it is suc of sum of odd and even number, which is odd
e+e≡e (suc om) en = suc (o+e≡o om en)

-- given: 1st odd because it is suc of even
-- given: 2nd is event
-- result: odd because it is suc of sum of two evens, which is even
o+e≡o (suc em) en = suc (e+e≡e em en)

------------------------------------------------------------------------------
-- Exercise o+o≡e (stretch) : sum of two odd numbers is even
-- 842 Hint: need to define another theorem and prove both by mutual induction

-- sum of odd and even is odd
e+o≡o : ∀ {m n : ℕ}
  → even m
  → odd n
    -----------
  → odd (m + n)

-- sum of odd and odd is even
o+o≡e : ∀ {m n : ℕ}
  → odd m
  → odd n
  --------------
  → even (m + n)

e+o≡o    zero  on = on
e+o≡o (suc em) on = suc (o+o≡e em on)

o+o≡e (suc om) on = suc (e+o≡o om on)

{-
------------------------------------------------------------------------------
Exercise Bin-predicates (stretch)

representations not unique due to leading zeros

eleven:
  ⟨⟩     I O I I --     canonical
  ⟨⟩ O O I O I I -- not canonical
-}

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

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

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

from : Bin → ℕ
from     ⟨⟩ = 0
from (b  O) =      dbl (from b)
from (b  I) = suc (dbl (from b))

-- httpS://www.reddit.com/r/agda/comments/hrvk07/plfa_quantifiers_help_with_binisomorphism/

-- holds if bitstring has a leading one
data One : Bin → Set where
  one    :                 One (⟨⟩ I)
  _withO : ∀ {b} → One b → One  (b O)
  _withI : ∀ {b} → One b → One  (b I)

{-
Hint: to prove below
- first state/prove properties of One
-}

n≤1+n : ∀ (n : ℕ) → n ≤ 1 + n
n≤1+n   zero  = z≤n
n≤1+n (suc n) = s≤s (n≤1+n n)

dbl-mono : ∀ (n : ℕ) → n ≤ dbl n
dbl-mono  zero   = z≤n
dbl-mono (suc n) = s≤s (≤-trans (dbl-mono n) (n≤1+n (dbl n)))

-- not used; I thought it would be useful; first try
n≤fromb→n≤dblfromb' : ∀ {n : ℕ} {b : Bin} → n ≤ from b → n ≤ dbl (from b)
n≤fromb→n≤dblfromb'  {zero} {b}        p  = z≤n
n≤fromb→n≤dblfromb' {suc n} {b O}      p  =
                ≤-trans p (dbl-mono      (from (b O)))
n≤fromb→n≤dblfromb' {suc n} {b I} (s≤s p) =
  s≤s (≤-trans (≤-trans p (dbl-mono (dbl (from b))))
               (n≤1+n (dbl (dbl (from b)))))

-- not used; above cleaned up
n≤fromb→n≤dblfromb : ∀ {n : ℕ} {b : Bin}
  → n ≤      from b
  → n ≤ dbl (from b)
n≤fromb→n≤dblfromb {_} {b} p = ≤-trans p (dbl-mono (from b))

-- HINT: prove if One b then 1 is less or equal to the result of from b
oneb→1≤fromb : ∀ {b : Bin} → One b → 1 ≤ from b
oneb→1≤fromb {b I}        _  = s≤s z≤n
oneb→1≤fromb {b O} (p withO) = ≤-trans (oneb→1≤fromb p) (dbl-mono (from b))

oneb→0<fromb : ∀ {b : Bin} → One b → 0 < from b
oneb→0<fromb p = m≤n→m<n (oneb→1≤fromb p)

-- not used
num-trailing-zeros : (b : Bin) {p : One b} → ℕ
num-trailing-zeros (b I)           = 0
num-trailing-zeros (b O) {p withO} = 1 + num-trailing-zeros b {p}

-- not used
do-dbls : ℕ -> ℕ
do-dbls   zero  = suc zero
do-dbls (suc n) = dbl (do-dbls n)
{-
xxx : {b : Bin} {n : ℕ}
  → (p : One b)
  →         n ≡ num-trailing-zeros b {p}
  → do-dbls n ≤ from b
xxx {⟨⟩ I}  {zero}       one  ntz = s≤s z≤n
xxx {b  I}  {zero} (ob withI) ntz = s≤s z≤n
xxx {b  O}  {zero} (ob withO) ntz = ≤-trans (oneb→1≤fromb ob) (dbl-mono (from b))
xxx {b  O} {suc n} (ob withO) ntz = {!!}
-}
-- bitstring is canonical if
data Can : Bin → Set where
  czero : Can (⟨⟩ O)  -- it consists of a single zero (representing zero)

  cone : ∀ {b : Bin}
    → One b           -- it has a leading one (representing a positive number)
      -----
    → Can b

{-
--------------------------------------------------
show that increment preserves canonical bitstrings
-}

oneb→one-incb : ∀ {b : Bin} → One b → One (inc b)
oneb→one-incb      one  =             one withO
oneb→one-incb (p withO) =               p withI
oneb→one-incb (p withI) = oneb→one-incb p withO

canb→canincb : ∀ {b : Bin}
  → Can      b
    ----------
  → Can (inc b)
canb→canincb {.(⟨⟩ O)}   czero  = cone one
canb→canincb       {b} (cone p) = cone (oneb→one-incb p)

{-
--------------------------------------------------
show that converting a natural to a bitstring always yields a canonical bitstring
-}

can-to-n : ∀ {n : ℕ} → Can (to n)
can-to-n  {zero} = czero
can-to-n {suc n} = canb→canincb (can-to-n {n})

{-
--------------------------------------------------
show that converting a canonical bitstring to a natural and back is the identity TODO
-}

ob→obO : ∀ {b : Bin} → One b → One (b O)
ob→obI : ∀ {b : Bin} → One b → One (b I)

ob→obI {.(⟨⟩ I)}     one  =           one withI
ob→obI {.(_ O)} (p withO) = ob→obO      p withI
ob→obI  {(b I)} (p withI) = ob→obI  {b} p withI

ob→obO {.(⟨⟩ I)}     one  =           one  withO
ob→obO {.(_ O)} (p withO) = (ob→obO     p) withO
ob→obO  {(b I)} (p withI) =  ob→obI {b} p  withO

dblb : Bin → Bin
dblb   ⟨⟩    = ⟨⟩
dblb  (⟨⟩ O) = ⟨⟩ O
dblb    b     = b O

dblbo : ∀ {b} → One b → Bin → Bin
dblbo _ b = b O

dblbc : ∀ {b} → Can b → Bin → Bin
dblbc   czero  _ = ⟨⟩ O
dblbc (cone _) b =  b O

xxxx : ∀ {b : Bin} {n : ℕ}
  → b ≡ (⟨⟩ I)
  → b ≡ to n
  → n ≡ 1
  → (⟨⟩ I O) ≡ to (dbl n)
xxxx p1 p2 p3 rewrite p3 = refl

xx : ∀ {b : Bin} → One b -> to (dbl (from b)) ≡ b O
xx      one  = refl
xx {b O} (p withO)              --             to (dbl (from (b O)))     ≡ ((b O) O)
                                --             to (dbl (dbl (from b)))   ≡ ((b O) O)
  rewrite
    sym (xx p)                  --             to (dbl (dbl (from b)))   ≡ (to (dbl (from b)) O)
  = {!!}
xx {b I} (p withI)              --             to (dbl (from (b I))      ≡ ((b I) O)
                                --   inc (inc (to (dbl (dbl (from b))))) ≡ ((b I) O)
  = {!!}

can-b→to-from-b≡b : ∀ {b : Bin}
  → Can      b
    ---------------
  → to (from b) ≡ b
can-b→to-from-b≡b             czero  = refl
can-b→to-from-b≡b {.⟨⟩ I} (cone one) = refl
can-b→to-from-b≡b {b O} (cone (p withO)) --      to (dbl (from b))  ≡ (b O)
  = xx p

can-b→to-from-b≡b {b I} (cone (p withI)) -- inc (to (dbl (from b))) ≡ (b I)
  rewrite xx p                           --                   (b I) ≡ (b I)
  = refl

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

defs in this chapter in standard library:

import Data.Nat using (_≤_; z≤n; s≤s)
import Data.Nat.Properties using (≤-refl; ≤-trans; ≤-antisym; ≤-total;
                                  +-monoʳ-≤; +-monoˡ-≤; +-mono-≤)

------------------------------------------------------------------------------
Unicode

≤  U+2264  LESS-THAN OR EQUAL TO    (\<=, \le)
≥  U+2265  GREATER-THAN OR EQUAL TO (\>=, \ge)
ˡ  U+02E1  MODIFIER LETTER SMALL L  (\^l)
ʳ  U+02B3  MODIFIER LETTER SMALL R  (\^r)
-}


module AuxDefs where

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

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

data Bool : Set where
  true  : Bool
  false : Bool

data Comparison : Set where
  less    : Comparison
  equal   : Comparison
  greater : Comparison

_<_ : ℕ → ℕ → Bool
zero < y      = true
suc x < zero  = false
suc x < suc y = x < y


module Hello where

-- Oh, you made it! Well done! This line is a comment.

-- In the beginning, Agda knows nothing, but we can teach it about numbers.

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

-- data Nat = Zero | Suc Nat -- in Haskell

-- Now we can say how to add numbers.

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

-- Now we can try adding some numbers.

four : Nat
four = (suc (suc zero)) +N (suc (suc zero))

-- To make it go, select "Evaluate term to normal form" from the
-- Agda menu, then type "four", without the quotes, and press return.

-- Hopefully, you should get a response
--   suc (suc (suc (suc zero)))

-- Done?

-- Now you can start Ex1.agda

-- WARNING Ex1.agda requires you to give a definition of addition.
-- There are lots of ways to define addition, and by the end of the
-- exercise, it will matter which you choose. If you start just by
-- copying the above definition, you will reach a point where you
-- may wish to reconsider it, and hopefully learn something useful
-- about the way Agda works.


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

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

open import BubbleSort _≤_ tot≤
open import Data.Product
open import Data.List
open import Data.Sum
open import Function using (_∘_)
open import List.Sorted _≤_
open import Order.Total _≤_ tot≤
open import Size
open import SList
open import SList.Order _≤_
open import SList.Order.Properties _≤_

lemma-swap*-≤*-≤ : {ι : Size}{x t : A}{xs : SList A {ι}} → x ≤ t → xs ≤* t → proj₁ (swap* x xs) ≤* t × proj₂ (swap* x xs) ≤ t
lemma-swap*-≤*-≤ x≤t lenx = lenx , x≤t
lemma-swap*-≤*-≤ {x = x} x≤t (lecx {x = y} y≤t ys≤*t)
    with tot≤ x y
... | inj₁ x≤y = lecx x≤t (proj₁ (lemma-swap*-≤*-≤ y≤t ys≤*t)), proj₂ (lemma-swap*-≤*-≤ y≤t ys≤*t)
... | inj₂ y≤x = lecx y≤t (proj₁ (lemma-swap*-≤*-≤ x≤t ys≤*t)), proj₂ (lemma-swap*-≤*-≤ x≤t ys≤*t)

lemma-bubbleSort-≤* : {ι : Size}{t : A}{xs : SList A {ι}} → xs ≤* t → bubbleSort xs ≤* t
lemma-bubbleSort-≤* lenx = lenx
lemma-bubbleSort-≤* (lecx x≤t xs≤*t)
    with lemma-swap*-≤*-≤ x≤t xs≤*t
... | (zs≤*t , z≤t) = lemma-⊕≤* z≤t (lemma-bubbleSort-≤* zs≤*t)

lemma-swap*-≤ : {ι : Size}(x : A) → (xs : SList A {ι}) → x ≤ proj₂ (swap* x xs)
lemma-swap*-≤ x snil = refl≤
lemma-swap*-≤ x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = trans≤ x≤y (lemma-swap*-≤ y ys)
... | inj₂ y≤x = lemma-swap*-≤ x ys

lemma-swap*-≤* : {ι : Size}(x : A) → (xs : SList A {ι}) → proj₁ (swap* x xs) ≤* proj₂ (swap* x xs)
lemma-swap*-≤* x snil = lenx
lemma-swap*-≤* x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = lecx (trans≤ x≤y (lemma-swap*-≤ y ys)) (lemma-swap*-≤* y ys)
... | inj₂ y≤x = lecx (trans≤ y≤x (lemma-swap*-≤ x ys)) (lemma-swap*-≤* x ys)

lemma-bubbleSort-sorted : {ι : Size}(xs : SList A {ι}) → Sorted (unsize A (bubbleSort xs))
lemma-bubbleSort-sorted snil = nils
lemma-bubbleSort-sorted (x ∙ xs) = lemma-sorted⊕ (lemma-bubbleSort-≤* (lemma-swap*-≤* x xs)) (lemma-bubbleSort-sorted (proj₁ (swap* x xs)))

theorem-bubbleSort-sorted : (xs : List A) → Sorted (unsize A (bubbleSort (size A xs)))
theorem-bubbleSort-sorted = lemma-bubbleSort-sorted ∘ (size A)


module Numeral.Natural.Relation.Divisibility where

import      Lvl
open import Functional
open import Logic
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Type

-- Divisibility relation of natural numbers.
-- `(y ∣ x)` means that `y` is divisible by `x`.
-- In other words: `x/y` is an integer.
-- Or: `∃(c: ℕ). x = c⋅y`.
-- Note on the definition of Div𝐒:
--   The order (y + x) works and depends on rewriting rules of ℕ at the moment (Specifically on the commuted identity and successor rules, I think).
--   Without rewriting rules, deconstruction of Div𝐒 seems not working.
--   Example:
--     div23 : ¬(2 ∣ 3)
--     div23(Div𝐒())
--     This is a "valid" proof, but would not type-check because deconstruction from (2 ∣ 3) to (2 ∣ 1) is impossible.
--     Seems like the compiler would see (3 = 2+x), but because of definition of (_+_), only (3 = x+2) can be found.
--   Defining Div𝐒 with (x + y) inside would work, but then the definition of DivN becomes more complicated because (_⋅_) is defined in this order.
-- Note on zero divisors:
--   (0 ∣ 0) is true, and it is the only number divisible by 0.
-- Example definitions of special cases of the divisibility relation and the divisibility with remainder relation:
--   data Even : ℕ → Stmt{Lvl.𝟎} where
--     Even0 : Even(𝟎)
--     Even𝐒 : ∀{x : ℕ} → Even(x) → Even(𝐒(𝐒(x)))
--   data Odd : ℕ → Stmt{Lvl.𝟎} where
--     Odd0 : Odd(𝐒(𝟎))
--     Odd𝐒 : ∀{x : ℕ} → Odd(x) → Odd(𝐒(𝐒(x)))
data _∣_ : ℕ → ℕ → Stmt{Lvl.𝟎} where
  Div𝟎 : ∀{y}   → (y ∣ 𝟎)
  Div𝐒 : ∀{y x} → (y ∣ x) → (y ∣ (y + x))

_∤_ : ℕ → ℕ → Stmt
y ∤ x = ¬(y ∣ x)

-- `Divisor(n)(d)` means that `d` is a divisor of `n`.
Divisor = swap(_∣_)

-- `Multiple(n)(m)` means that `m` is a multiple of `n`.
Multiple = _∣_

-- Elimination rule for (_∣_).
divides-elim : ∀{ℓ}{P : ∀{y x} → (y ∣ x) → Type{ℓ}} → (∀{y} → P(Div𝟎{y})) → (∀{y x}{p : y ∣ x} → P(p) → P(Div𝐒 p)) → (∀{y x} → (p : y ∣ x) → P(p))
divides-elim        z s Div𝟎     = z
divides-elim{P = P} z s (Div𝐒 p) = s(divides-elim{P = P} z s p)


module Numeral.Natural.Function where

open import Numeral.Natural
open import Numeral.Natural.Oper

-- Maximum function
-- Returns the greatest number
max : ℕ → ℕ → ℕ
max 𝟎      𝟎      = 𝟎
max (𝐒(a)) 𝟎      = 𝐒(a)
max 𝟎      (𝐒(b)) = 𝐒(b)
max (𝐒(a)) (𝐒(b)) = 𝐒(max a b)

-- Minimum function
-- Returns the smallest number
min : ℕ → ℕ → ℕ
min 𝟎      𝟎      = 𝟎
min (𝐒(_)) 𝟎      = 𝟎
min 𝟎      (𝐒(_)) = 𝟎
min (𝐒(a)) (𝐒(b)) = 𝐒(min a b)
-- min a b = (a + b) −₀ max(a)(b)

-- min and max as binary operators
infixl 100 _[max]_ _[min]_
_[max]_ = max
_[min]_ = min

-- Fibonacci numbers
fib : ℕ → ℕ
fib(𝟎)       = 𝟎
fib(𝐒(𝟎))    = 𝐒(𝟎)
fib(𝐒(𝐒(n))) = fib(n) + fib(𝐒(n))

arithmetic-sequence : ℕ → ℕ → (ℕ → ℕ)
arithmetic-sequence init diff 𝟎      = init
arithmetic-sequence init diff (𝐒(n)) = diff + arithmetic-sequence init diff n

geometric-sequence : ℕ → ℕ → (ℕ → ℕ)
geometric-sequence init diff 𝟎      = init
geometric-sequence init diff (𝐒(n)) = diff ⋅ arithmetic-sequence init diff n


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 30, 2007

                Hello Agda!

                Ulf Norell

-}

-- This is where the fun begins.
-- Unleashing datatypes, pattern matching and recursion.

module Datatypes where

{-

  Simple datatypes.

-}

-- Now which datatype should we start with...?

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

-- Let's start simple.
pred : Nat -> Nat
pred zero    = zero
pred (suc n) = n

-- Now let's do recursion.
_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

-- An aside on infix operators:
-- Any name containing _ can be used as a mixfix operator.
-- The arguments simply go in place of the _. For instance:

data Bool : Set where
  true  : Bool
  false : Bool

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

-- To declare the associativity and precedence of an operator
-- we write. In this case we need parenthesis around the else branch
-- if its precedence is lower than 10. For the condition and the then
-- branch we only need parenthesis for things like λs.
infix 10 if_then_else_

{-

  Parameterised datatypes

-}

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

infixr 50 _::_

-- The parameters are implicit arguments to the constructors.
nil : (A : Set) -> List A
nil A = [] {A}

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

{-

  Empty datatypes

-}

-- A very useful guy is the empty datatype.
data False : Set where

-- When pattern matching on an element of an empty type, something
-- interesting happens:

elim-False : {A : Set} -> False -> A
elim-False ()  -- Look Ma, no right hand side!

-- The pattern () is called an absurd pattern and matches elements
-- of an empty type.

{-

  What's next?

-}

-- Fun as they are, eventually you'll get bored with
-- inductive datatypes.

-- Move on to: Families.agda


{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

-- This is where the fun begins.
-- Unleashing datatypes, pattern matching and recursion.

module Datatypes where

{-

  Simple datatypes.

-}

-- Let's define natural numbers.

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

-- A simple function.
pred : Nat -> Nat
pred zero    = zero
pred (suc n) = n

-- Now let's do recursion.
_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

infixl 60 _+_

-- An aside on infix operators:
-- Any name containing _ can be used as a mixfix operator.
-- The arguments simply go in place of the _. For instance:

data Bool : Set where
  true  : Bool
  false : Bool

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

{-

  Parameterised datatypes

-}

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

-- The parameters are implicit arguments to the constructors.
nil : (A : Set) -> List A
nil A = [] {A}

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

{-

  Empty datatypes

-}

-- A very useful guy is the empty datatype.
data False : Set where

-- When pattern matching on an element of an empty type, something
-- interesting happens:

elim-False : {A : Set} -> False -> A
elim-False ()  -- Look Ma, no right hand side!

-- The pattern () is called an absurd pattern and matches elements
-- of an empty type.

{-

  What's next?

-}

-- The Curry-Howard isomorphism.
--   CurryHoward.agda


module x01-842Naturals-hc where

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

one : ℕ
one = suc zero

two : ℕ
two = suc (suc zero)

seven : ℕ
seven = suc (suc (suc (suc (suc (suc (suc zero))))))

{-# BUILTIN NATURAL ℕ #-}

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

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

_ : 2 + 3 ≡ 5
_ = refl

_ : 2 + 3 ≡ 5
_ =
  begin
    2                + 3                      ≡⟨⟩    -- is shorthand for
    (suc (suc zero)) + (suc (suc (suc zero))) ≡⟨⟩    -- many steps condensed
    5
  ∎

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

_ =
  begin
    2 * 3 ≡⟨⟩    -- many steps condensed
    6
  ∎

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

_ : 2 ^ 3 ≡ 8
_ = refl
_ : 2 ^ 4 ≡ 16
_ = refl
_ : 3 ^ 3 ≡ 27
_ = refl
_ : 3 ^ 10 ≡ 59049
_ = refl

-- Monus (subtraction for naturals, bottoms out at zero).

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

_ =
  begin
     3 ∸ 2
  ≡⟨⟩ -- many steps condensed
     1
  ∎

_ =
  begin
     2 ∸ 3
  ≡⟨⟩ -- many steps condensed
     0
  ∎

_ = begin 5 ∸ 3 ≡⟨⟩ 2 ∎
_ = begin 3 ∸ 5 ≡⟨⟩ 0 ∎

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

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

-- Binary representation.
-- Modified from PLFA exercise (thanks to David Darais).

data Bin-ℕ : Set where
  bits : Bin-ℕ
  _x0 : Bin-ℕ → Bin-ℕ
  _x1 : Bin-ℕ → Bin-ℕ

-- Our representation of zero is different from PLFA.
-- We use the empty sequence of bits (more consistent).

bin-zero : Bin-ℕ
bin-zero = bits

bin-one : Bin-ℕ
bin-one = bits x1     -- 1 in binary

bin-two : Bin-ℕ
bin-two = bits x1 x0  -- 10 in binary

-- 842 exercise: Increment (1 point)

inc : Bin-ℕ → Bin-ℕ
inc  bits  =  bits x1
inc (m x0) =     m x1
inc (m x1) = inc m x0

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

-- 842 exercise: To/From (2 points)
-- Hint: avoid addition and multiplication. Use the provided dbl.

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

tob : ℕ → Bin-ℕ
tob   zero   = bits
tob (suc m)  = inc (tob m)

fromb : Bin-ℕ → ℕ
fromb  bits  = 0
fromb (n x0) =      dbl (fromb n)
fromb (n x1) = suc (dbl (fromb n))

_ : tob 6 ≡    bits x1 x1 x0
_ = refl
_ : tob 7 ≡    bits x1 x1 x1
_ = refl
_ : tob 8 ≡ bits x1 x0 x0 x0
_ = refl

_ : fromb    (bits x1 x1 x0) ≡ 6
_ = refl
_ : fromb    (bits x1 x1 x1) ≡ 7
_ = refl
_ : fromb (bits x1 x0 x0 x0) ≡ 8
_ = refl

-- 842 exercise: BinAdd (2 points)
-- Write the addition function for binary notation.
-- Do NOT use 'to' and 'from'. Work with Bin-ℕ as if ℕ did not exist.
-- Hint: use recursion on both m and n.

_bin-+_ : Bin-ℕ → Bin-ℕ → Bin-ℕ
m      bin-+ bits   =       m
bits   bin-+  n     =               n
(m x0) bin-+ (n x0) =      (m bin-+ n) x0
(m x0) bin-+ (n x1) =      (m bin-+ n) x1
(m x1) bin-+ (n x0) =      (m bin-+ n) x1
(m x1) bin-+ (n x1) = inc ((m bin-+ n) x1)

-- Tests can use to/from, or write out binary constants as below.
-- Again: write more tests!

_ : (bits x1 x0) bin-+ (bits x1 x1) ≡ (bits x1 x0 x1)
_ = refl

_ : tob 0 bin-+ tob 0 ≡ tob 0
_ = refl

_ : tob 7 bin-+ tob 7 ≡ tob 14
_ = refl

_ : tob 3 bin-+ tob 4 ≡ tob 7
_ = refl

{-
-- Many definitions from above are also in the standard library.
-- open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _^_; _∸_)

-- Unicode used in this chapter:

    ℕ  U+2115  DOUBLE-STRUCK CAPITAL N (\bN)
    →  U+2192  RIGHTWARDS ARROW (\to, \r, \->)
    ∸  U+2238  DOT MINUS (\.-)
    ≡  U+2261  IDENTICAL TO (\==)
    ⟨  U+27E8  MATHEMATICAL LEFT ANGLE BRACKET (\<)
    ⟩  U+27E9  MATHEMATICAL RIGHT ANGLE BRACKET (\>)
    ∎  U+220E  END OF PROOF (\qed)
-}


{-
  Mathematical Foundations of Programming (G54FOP)
  Nicolai Kraus
  Lecture 3, 7 Feb 2018

  ====================
  INTRODUCTION TO AGDA
  ====================

  Your G54FPP project could involve Agda. If you want.

  Btw, text in {- -} is a comment. So is text after --.

  links to help you install and learn Agda:
  http://wiki.portal.chalmers.se/agda/pmwiki.php
  http://agda.readthedocs.io/en/latest/getting-started/index.html
  https://github.com/agda/agda

  Agda standard library:
  https://github.com/agda/agda-stdlib

  Some key combinations, where C is ctrl,
  i.e. C-c C-l means:
    press control and keep it pressed,
    press and release c,
    press and release l,
    release control.
  C-c C-l   load file, replace ? by hole
  C-c C-,   show goal
  C-c C-.   show goal and input type
  C-c C-n   normalise expression
  C-c C-space   give current hole input to Agda
  see links above for more

  I recommend using a monospace font.
-}

module lec3FOP where

  data ℕ : Set where     -- type: \bN
    zero : ℕ
    suc : ℕ → ℕ          -- type: \to or \->
                         -- (or just use ->)

  infix 6 _+_
  _+_ : ℕ → ℕ → ℕ        -- the arguments go where _ is
  zero + n = n
  (suc m) + n = suc (m + n)

  {- type of equalities on natural numbers *which
     we need to prove*. Some equalities can be hard
     to prove, so we cannot assume that Agda would
     find them automatically! -}
  infix 3 _==_
  data _==_ : (m n : ℕ) → Set where
    refl : {m : ℕ} → m == m

  suc-lem : {m n : ℕ} → m == n → suc m == suc n
  suc-lem refl = refl

  +-is-associative : (k m n : ℕ)
      → k + (m + n) == (k + m) + n
  +-is-associative zero m n = refl
  +-is-associative (suc k) m n =
      suc-lem (+-is-associative k m n)

  {- Next: implement the language of expressions
     from the lecture
     This language was given by a BNF:
     E:= t | f | z | s E | p E | iz E | if E then E else E
  -}

  data Expr : Set where
    t : Expr
    f : Expr
    z : Expr
    s : Expr → Expr
    p : Expr → Expr
    iz : Expr → Expr
    if_then_else_ : Expr → Expr → Expr → Expr

  -- denotational semantics from last week:
  -- ⟦_⟧ : Expr → S       type: \[[_\]]
  -- S was {True, False, 0, 1, 2, ..., ⊥}

  data Bool : Set where
    True : Bool
    False : Bool

  data S : Set where
    bool : Bool → S
    number : ℕ → S
    ⊥ : S

  -- Here we go:
  ⟦_⟧ : Expr → S
  ⟦ t ⟧ = bool True
  ⟦ f ⟧ = bool False
  ⟦ z ⟧ = number zero
  ⟦ s e ⟧ with ⟦ e ⟧
  ⟦ s e ⟧ | number n = number (suc n)
  ⟦ s e ⟧ | _ = ⊥
  ⟦ _ ⟧ = ⊥  -- not what we want, but
             -- at least Agda accepts it.
             -- Exercise: complete this definition.


{- --- 3. Natural numbers --- -}

{- 3.1 Definition -}
data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

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

{- 3.3 Multiplication -}
_*_ : ℕ → ℕ → ℕ
zero * b = zero
suc a * b = b + (a * b)

{- 3.4 Equality is a congruence for successor -}
data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

infix 4 _≡_

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

{- 3.5 Some properties -}
zeroL : (n : ℕ) → zero + n ≡ n
zeroL n = refl

zeroR : (n : ℕ) → n + zero ≡ n
zeroR zero = refl
zeroR (suc n) = suc-≡ (zeroR n)

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

one : ℕ
one = suc zero

+-assoc1 : (m n : ℕ) → ((m + n) + one) ≡ (m + (n + one))
+-assoc1 m n = +-assoc m n one

{- Falsity type, needed for the next property -}
data ⊥ : Set where

{- ¬ : Set → Set
¬ A = A → ⊥ -}

open import Relation.Nullary

suc-notzero : (n : ℕ) → ¬ (zero ≡ suc n)
suc-notzero n ()

{- 3.6 The recurrence principle -}
rec : (P : ℕ → Set) → (P zero) → ((n : ℕ) → (P n) → (P (suc n))) → ((n : ℕ) → P n)
rec p z h zero = z
rec p z h (suc n) = h n (rec p z h n)

{- 3.7 Properties of equality -}
sym : {A : Set} {x y : A} → x ≡ y → y ≡ x
sym refl = refl

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

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

p : {m n : ℕ} → (e : m ≡ n) → suc-≡ e ≡ cong suc e
p refl = refl

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

{- 3.8 Commutativity of addition -}
+-suc : (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n = refl
+-suc (suc m) n = suc-≡ (+-suc m n)

+-commut : (m n : ℕ) → m + n ≡ n + m
+-commut m zero = zeroR m
+-commut m (suc n) = trans (+-suc m n) (suc-≡ (+-commut m n))

{- 3.9 Injectivity of successor -}
suc-inj : {m n : ℕ} → suc m ≡ suc n → m ≡ n
suc-inj refl = refl

{- 3.10 Decidability of equality -}
open import Data.Sum renaming (_⊎_ to _∨_ ; inj₁ to left ; inj₂ to right)

ℕ-≡-dec : (m n : ℕ) → (m ≡ n) ∨ ¬ (m ≡ n)
ℕ-≡-dec zero zero = left refl
ℕ-≡-dec zero (suc n) = right (suc-notzero n)
ℕ-≡-dec (suc m) zero = right λ ()
ℕ-≡-dec (suc m) (suc n) with ℕ-≡-dec m n
ℕ-≡-dec (suc m) (suc n) | left e = left (suc-≡ e)
ℕ-≡-dec (suc m) (suc n) | right e' = right λ x → e' (suc-inj x)

{- 3.11 Recurrence for equality -}
J : (A : Set) → (P : (x : A) → (y : A) → (p : x ≡ y) → Set) → (r : (x : A) → P x x refl) → (x : A) → (y : A) → (p : x ≡ y) → P x y p
J A P r x .x refl = r x


module Naturals where

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

-- type definition
data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

-- bind builtin (aka Haskell integers) to my natural type
{-# BUILTIN NATURAL ℕ #-}

-- define addition proof
-- base case for identity rule
-- inductive case for associative rule
_+_ : ℕ → ℕ → ℕ
zero + n  = n
suc m + n = suc (m + n)

-- 2 + 3 proposition is reflexive
-- that means addition is a binary
-- relation that relates to itself
_ : 2 + 3 ≡ 5
_ = refl

-- same for 3 + 4 propositon
-- i manually proved it
_ : 3 + 4 ≡ 7
_ =
  begin
    3 + 4
  ≡⟨⟩
    suc (2 + 4)
  ≡⟨⟩
    suc (suc (1 + 4))
  ≡⟨⟩
    suc (suc (suc (0 + 4)))
  ≡⟨⟩
    suc (suc (suc 0)) + suc 3
  ≡⟨⟩
    suc (suc (suc 0)) + suc (suc 2)
  ≡⟨⟩
    suc (suc (suc 0)) + suc (suc (suc 1))
  ≡⟨⟩
    suc (suc (suc 0)) + suc (suc (suc (suc 0)))
  ≡⟨⟩
    7
  ∎
-- after addition we can efine
-- multiplication in terms of it
-- note the base case and the inductive case
_*_ : ℕ → ℕ → ℕ
zero * n = zero
suc m * n = n + (m * n)

_ =
  begin
    2 * 3
  ≡⟨⟩
    3 + (1 * 3)
  ≡⟨⟩
    3 + (3 + (0 * 3))
  ≡⟨⟩
    3 + (3 + 0)
  ≡⟨⟩
    6
  ∎

_ =
  begin
    3 * 4
  ≡⟨⟩
    4 + (2 * 4)
  ≡⟨⟩
    4 + (4 + (1 * 4))
  ≡⟨⟩
    4 + (4 + (4 + (0 * 4)))
  ≡⟨⟩
    12
  ∎

-- with multiplication we then can
-- define exponentiation
-- note that `m ^ zero` /= `zero ^ m`
_^_ : ℕ → ℕ → ℕ
n ^ zero  = 1
m ^ suc n = m * (m ^ n)

_ : 3 ^ 4 ≡ 81
_ =
  begin
    3 ^ 4
  ≡⟨⟩
    3 * (3 ^ 3)
  ≡⟨⟩
    3 * (3 * (3 ^ 2))
  ≡⟨⟩
    3 * (3 * (3 * (3 ^ 1)))
  ≡⟨⟩
    3 * (3 * (3 * (3 * (3 ^ 0))))
  ≡⟨⟩
    81
  ∎

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

_ : 3 ∸ 2 ≡ 1
_ =
  begin
    3 ∸ 2
  ≡⟨⟩
    2 ∸ 1
  ≡⟨⟩
    1 ∸ 0
  ≡⟨⟩
    1
  ∎

_ : 2 ∸ 3 ≡ 0
_ =
  begin
    2 ∸ 3
  ≡⟨⟩
    1 ∸ 2
  ≡⟨⟩
    0 ∸ 1
  ≡⟨⟩
    0
  ∎

_ : 5 ∸ 3 ≡ 2
_ =
  begin
    5 ∸ 3
  ≡⟨⟩
    4 ∸ 2
  ≡⟨⟩
    3 ∸ 1
  ≡⟨⟩
    2 ∸ 0
  ≡⟨⟩
    2
  ∎

_ : 3 ∸ 5 ≡ 0
_ =
  begin
    3 ∸ 5
  ≡⟨⟩
    2 ∸ 4
  ≡⟨⟩
    1 ∸ 3
  ≡⟨⟩
    0 ∸ 2
  ≡⟨⟩
    0
  ∎

-- here we define the precedence
-- of operators. all they are left associative
-- and addiction and monus have precedence less
-- than multiplication
infixl 6 _+_ _∸_
infixl 7 _*_
infixl 8 _^_

-- binding aforementioned operators
-- to the relevant Haskell integer operators
{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}
{-# BUILTIN NATMINUS _∸_ #-}


module OverloadedConstructors where

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

data Fin : Nat -> Set where
  zero : {n : Nat} -> Fin (suc n)
  suc  : {n : Nat} -> Fin n -> Fin (suc n)

three : Nat
three = suc (suc (suc zero))

ftwo : Fin three
ftwo = suc (suc zero)

inc : Nat -> Nat
inc = suc

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