module Data.Fin where

open import Data.Nat hiding (_==_; _<_)
open import Data.Bool
open import Logic.Identity
open import Logic.Base

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

pred : {n : Nat} -> Fin (suc (suc n)) -> Fin (suc n)
pred fzero    = fzero
pred (fsuc i) = i

fzero≠fsuc : {n : Nat}{i : Fin n} -> fzero ≢ fsuc i
fzero≠fsuc ()

fsuc-inj : {n : Nat}{i j : Fin n} -> fsuc i ≡ fsuc j -> i ≡ j
fsuc-inj refl = refl

_==_ : {n : Nat}(i j : Fin n) -> i ≡ j \/ i ≢ j
fzero  == fzero  = \/-IL refl
fzero  == fsuc j = \/-IR fzero≠fsuc
fsuc i == fzero  = \/-IR (sym≢ fzero≠fsuc)
fsuc i == fsuc j = aux i j (i == j)
  where
    aux : {n : Nat}(i j : Fin n) -> i ≡ j \/ i ≢ j -> fsuc i ≡ fsuc j \/ fsuc i ≢ fsuc j
    aux i .i (\/-IL refl) = \/-IL refl
    aux i j  (\/-IR i≠j)  = \/-IR \si=sj -> i≠j (fsuc-inj si=sj)

_<_ : {n : Nat} -> Fin n -> Fin n -> Bool
_      < fzero  = false
fzero  < fsuc j = true
fsuc i < fsuc j = i < j

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

liftSuc : {n : Nat} -> Fin n -> Fin (suc n)
liftSuc  fzero	 = fzero
liftSuc (fsuc i) = fsuc (liftSuc i)

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

thin : {n : Nat} -> Fin (suc n) -> Fin n -> Fin (suc n)
thin  fzero i	       = fsuc i
thin (fsuc j) fzero    = fzero
thin (fsuc j) (fsuc i) = fsuc (thin j i)

-- Two elements of Fin n are either the same or one is the thinning of
-- something with respect to the other.
data ThinView : {n : Nat}(i j : Fin n) -> Set where
  same : {n : Nat}{i : Fin n}		       -> ThinView i i
  diff : {n : Nat}{i : Fin (suc n)}(j : Fin n) -> ThinView i (thin i j)

thinView : {n : Nat}(i j : Fin n) -> ThinView i j
thinView fzero fzero		      = same
thinView  fzero (fsuc j) = diff j
thinView {suc zero} (fsuc ()) fzero
thinView {suc (suc n)} (fsuc i) fzero	 = diff fzero
thinView (fsuc i) (fsuc j) = aux i j (thinView i j)
  where
    aux : {n : Nat}(i j : Fin n) -> ThinView i j -> ThinView (fsuc i) (fsuc j)
    aux i .i	       same    = same
    aux i .(thin i j) (diff j) = diff (fsuc j)

thin-ij≠i : {n : Nat}(i : Fin (suc n))(j : Fin n) -> thin i j ≢ i
thin-ij≠i  fzero    j	    ()
thin-ij≠i (fsuc i)  fzero   ()
thin-ij≠i (fsuc i) (fsuc j) eq = thin-ij≠i i j (fsuc-inj eq)

-- Thickening.
--    thin i (thick i j) ≡ j  ?
--    thick i (thin i j) ≡ j
thick : {n : Nat}(i j : Fin (suc n)) -> i ≢ j -> Fin n
thick i j i≠j = thick' i j i≠j (thinView i j) where
  thick' : {n : Nat}(i j : Fin (suc n)) -> i ≢ j -> ThinView i j -> Fin n
  thick' i .i	       i≠i same	   = elim-False (i≠i refl)
  thick' i .(thin i j) _  (diff j) = j

-- thin∘thick=id : {n : Nat}(i j : Fin (suc n))(p : i ≢ j) ->
-- 		thin i (thick i j p) ≡ j
-- thin∘thick=id i j p = ?
--
-- thick∘thin=id : {n : Nat}(i : Fin (suc n))(j : Fin n) ->
-- 		thick i (thin i j) (sym≢ (thin-ij≠i i j)) ≡ j
-- thick∘thin=id i j = ?
--


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

module Experiment.Zero where

open import Level using (_⊔_)

-- Empty type
data ⊥ : Set where

-- Unit type
record ⊤ : Set where
  constructor tt

-- Boolean
data Bool : Set where
  true false : Bool

-- Natural number
data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

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

-- Sum type
data _⊎_ {a} {b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

-- Dependent Product type
record Σ {a} {b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B fst

-- Induction
⊤-ind : ∀ {p} {P : ⊤ → Set p} → P tt → ∀ x → P x
⊤-ind P⊤ tt = P⊤

⊥-ind : ∀ {p} {P : ⊥ → Set p} → ∀ x → P x
⊥-ind ()

Bool-ind : ∀ {p} {P : Bool → Set p} → P true → P false → ∀ x → P x
Bool-ind t e true  = t
Bool-ind t e false = e

ℕ-ind : ∀ {p} {P : ℕ → Set p} → P zero → (∀ m → P m → P (suc m)) → ∀ n → P n
ℕ-ind P0 Ps zero    = P0
ℕ-ind P0 Ps (suc n) = Ps n (ℕ-ind P0 Ps n)

≡-ind : ∀ {a p} {A : Set a}
        (P : (x y : A) → x ≡ y → Set p) →
        (∀ x → P x x refl) →
        ∀ x y (eq : x ≡ y) → P x y eq
≡-ind P Pr x .x refl = Pr x

⊎-ind : ∀ {a b p} {A : Set a} {B : Set b} {P : A ⊎ B → Set p} →
        (∀ x → P (inj₁ x)) → (∀ y → P (inj₂ y)) → ∀ s → P s
⊎-ind i1 i2 (inj₁ x) = i1 x
⊎-ind i1 i2 (inj₂ y) = i2 y

Σ-ind : ∀ {a b p} {A : Set a} {B : A → Set b} {P : Σ A B → Set p} →
        (∀ x y → P (x , y)) → ∀ p → P p
Σ-ind f (x , y) = f x y


module Problem3 where

open import Problem1
open import Problem2

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

data False : Set where

-- 3.1

empty : Fin zero -> False
empty ()

-- 3.2

_!_ : {A : Set}{n : Nat} -> Vec A n -> Fin n -> A
ε        ! ()
(x ► xs) ! fzero  = x
(x ► xs) ! fsuc i = xs ! i

-- 3.3

-- The simply typed composition would do here, but the more
-- dependent version is more interesting.
-- _∘_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C

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

tabulate : {A : Set}{n : Nat} -> (Fin n -> A) -> Vec A n
tabulate {n = zero } f = ε
tabulate {n = suc n} f = f fzero ► tabulate (f ∘ fsuc)


module Nat where

data Nat : Set

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

plus : Nat -> Nat -> Nat
plus zero    n = n
plus (suc m) n = suc (plus m n)

elim : (P : (n : Nat) -> Set) ->
       (z : P (plus zero zero)) ->
       (s : (n : Nat) -> P (plus zero n) -> P (plus (suc zero) n)) ->
       (n : Nat) -> P n
elim P z s zero    = z
elim P z s (suc n) = s n (elim P z s n)


module Ag13 where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using ()
  renaming (contradiction to ¬¬-intro)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import Ag09 using (_⇔_)

data Bool : Set where
  true  : Bool
  false : Bool

T : Bool → Set
T true   =  ⊤
T false  =  ⊥

T→≡ : ∀ (b : Bool) → T b → b ≡ true
T→≡ true tt   =  refl
T→≡ false ()

≡→T : ∀ {b : Bool} → b ≡ true → T b
≡→T refl  =  tt

data Dec (A : Set) : Set where
  yes :   A → Dec A
  no  : ¬ A → Dec A

infix 4 _≤_

data _≤_ : ℕ → ℕ → Set where

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

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

¬s≤z : ∀ {m : ℕ} → ¬ (suc m ≤ zero)
¬s≤z ()

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

_≤?_ : ∀ (m n : ℕ) → Dec (m ≤ n)
zero  ≤? n                   =  yes z≤n
suc m ≤? zero                =  no ¬s≤z
suc m ≤? suc n with m ≤? n
...               | yes m≤n  =  yes (s≤s m≤n)
...               | no ¬m≤n  =  no (¬s≤s ¬m≤n)


module Algebra.Dioid where

record Dioid A (_≡_ : A -> A -> Set) : Set where
  field
    zero : A
    one  : A
    _+_  : A -> A -> A
    _*_  : A -> A -> A

    reflexivity  : ∀ {r     : A} ->                   r ≡ r
    symmetry     : ∀ {r s   : A} -> r ≡ s ->          s ≡ r
    transitivity : ∀ {r s t : A} -> r ≡ s -> s ≡ t -> r ≡ t

    +left-congruence  : ∀ {r s t : A} -> r ≡ s -> (r + t) ≡ (s + t)
    -- +right-congruence holds but as a theorem, please see below
    *left-congruence  : ∀ {r s t : A} -> r ≡ s -> (r * t) ≡ (s * t)
    *right-congruence : ∀ {r s t : A} -> r ≡ s -> (t * r) ≡ (t * s)

    +idempotence   : ∀ {r : A}      -> (r + r)       ≡ r
    +commutativity : ∀ {r s : A}    -> (r + s)       ≡ (s + r)
    +associativity : ∀ {r s t : A}  -> (r + (s + t)) ≡ ((r + s) + t)
    +zero-identity : ∀ {r : A}      -> (r + zero)    ≡ r

    *associativity  : ∀ {r s t : A} -> (r * (s * t)) ≡ ((r * s) * t)
    *left-zero      : ∀ {r : A}     -> (zero * r)    ≡ zero
    *right-zero     : ∀ {r : A}     -> (r * zero)    ≡ zero
    *left-identity  : ∀ {r : A}     -> (one * r)     ≡ r
    *right-identity : ∀ {r : A}     -> (r * one)     ≡ r

    left-distributivity  : ∀ {r s t : A} -> (r * (s + t)) ≡ ((r * s) + (r * t))
    right-distributivity : ∀ {r s t : A} -> ((r + s) * t) ≡ ((r * t) + (s * t))

  -- For convenience to avoid `Dioid._+_ d r s`
  plus : A -> A -> A
  plus x y = x + y

  times : A -> A -> A
  times x y = x * y

+right-congruence : ∀ {D eq} {d : Dioid D eq} {r s t : D} -> eq r s -> eq (Dioid.plus d t r) (Dioid.plus d t s)
+right-congruence {_} {_} {d} {r} {s} {t} e = trans commut (trans (Dioid.+left-congruence d e) commut)
  where
    trans = Dioid.transitivity d
    commut = Dioid.+commutativity d


module Acc where

data Acc ( A : Set ) ( Lt : A -> A -> Set) : A -> Set where
  acc :    (   b : A )
        -> ( ( a : A ) -> Lt a b  ->  Acc A Lt a )
        -> ( Acc A Lt b )

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

data Lt : Nat -> Nat -> Set where
  ltzero : ( x : Nat ) -> Lt zero (succ x)
  ltsucc : ( x : Nat ) -> (y : Nat) -> Lt x y -> Lt (succ x) (succ y)

ltstep : (x : Nat) ->  Lt x (succ x)
ltstep zero = ltzero _
ltstep (succ x) = ltsucc _ _ (ltstep x)

notLt0 : ( x : Nat ) -> Lt x zero -> (C : Set) -> C
notLt0 x ()

wkLt : ( x y : Nat ) -> Lt (succ x) (succ y) -> Lt x y
wkLt zero (succ y) _ = ltzero y
wkLt x zero (ltsucc .x .zero ())
wkLt x y (ltsucc .x .y p) = p

{-
wkLt1 : ( x y : Nat ) -> Lt (succ x) y -> Lt x y
wkLt1 x zero ()
wkLt1 zero (succ y) _ = ltzero y
wkLt1 (succ x) (succ y) (ltsucc .(succ x)  .y p) = ltsucc x y (wkLt1 x y p)
-}

wkLt2 : (x y : Nat ) -> Lt x y -> Lt x (succ y)
wkLt2 x zero ()
wkLt2 zero y p = ltzero y
wkLt2 (succ x) (succ y) (ltsucc .x .y p) = ltsucc x (succ y) (wkLt2 x y p)

ltcase : ( x : Nat ) -> ( y : Nat ) -> Lt x (succ y) ->
         ( P : Nat -> Set ) -> ( (x' : Nat ) -> Lt x' y -> P x') -> P y -> P x
ltcase zero zero      _ P hx' hy = hy
ltcase zero (succ y') _ P hx' hy = hx' zero (ltzero y')
ltcase (succ x') zero (ltsucc .x' .zero ()) _ _ _
ltcase (succ x') (succ y') (ltsucc .x' .(succ y') p) P hx' hy =
  ltcase x' y' p (\ n -> P (succ n))
    (\ x'' p' -> hx' (succ x'') (ltsucc x'' y' p')) hy

accSucc : (x : Nat) -> Acc Nat Lt x -> Acc Nat Lt (succ x)
accSucc x (acc .x h) = acc (succ x) (\ y p -> ltcase y x p (Acc Nat Lt) h (acc x h))

accLt : ( x : Nat ) -> Acc Nat Lt x
accLt zero = acc zero (\a -> \p -> notLt0 a p (Acc Nat Lt a) )
accLt (succ x) = accSucc x (accLt x)

-- subtraction x - y

sub : Nat -> Nat -> Nat
sub zero y = zero
sub (succ x) zero = succ x
sub (succ x) (succ y) = sub x y

subLt : (x y : Nat) -> Lt (sub (succ x) (succ y)) (succ x)
subLt zero y = ltzero _
subLt (succ x') zero = ltstep (succ x')
subLt (succ x') (succ y') = wkLt2 _ _ (subLt x' y')

-- division  x / (y + 1)

div' : (x y : Nat) -> Acc Nat Lt x -> Nat
div' zero _ _ = zero
div' (succ x') y' (acc ._ h) = succ (div' z y' (h _ p))
  where z = sub (succ x') (succ y')
        p = subLt x' y'

----

data WO ( A : Set ) ( Lt : A -> A -> Set ) : Set where
  wo : ((x : A) -> Acc A Lt x) -> WO A Lt

woLt : WO Nat Lt
woLt = wo accLt


module Issue637 where

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

infixl 60 _+_
_+_ : Nat → Nat → Nat
zero + n = n
suc m + n = suc (n + m)

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

`1 = suc zero
`2 = suc `1
`3 = suc `2
`4 = `2 + `2
`8 = `4 + `4
`16 = `8 + `8
`32 = `16 + `16
`50 = `32 + `16 + `2
`64 = `32 + `32
`100 = `64 + `32 + `4
`200 = `100 + `100
`400 = `200 + `200
`800 = `400 + `400
`1000 = `800 + `200
`2000 = `1000 + `1000
`4000 = `2000 + `2000

prf : `16 ≡ (`4 + (`4 + `8))
prf = refl

infixr 40 _∷_
data Vec : Nat → Set where
  [] : Vec zero
  _∷_ : ∀ {n} → Nat → Vec n → Vec (suc n)

fromN : ∀ {n} → Nat → Vec n
fromN {zero} _ = []
fromN {suc n} x = x ∷ fromN (suc x)

sum : ∀ {n} → Vec n → Nat
sum [] = zero
sum (n ∷ ns) = n + sum ns

prf₁ : sum (fromN {`100} `1) ≡ (`4000 + `1000 + `50)
prf₁ = refl


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

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

+-identityʳ : (x : Nat) → x + 0 ≡ x
+-identityʳ zero    = refl
+-identityʳ (suc n) = cong suc (+-identityʳ n)

+-assoc : (x y z : Nat) → (x + y) + z ≡ x + (y + z)
+-assoc zero    _ _ = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

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

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

to : Nat → Bin
to zero = (x0 nil)
to (suc x) = inc (to x)

postulate
  from : Bin → Nat

data Can : Bin → Set where
  Can- : ∀ {n} → from (to n) ≡ n → Can (to n)

data Σ (A : Set) (B : A → Set) : Set where
  ⟨_,_⟩ : (x : A) → B x → Σ A B

postulate
  to'' : (x : Nat) → Σ Bin Can

to∘from' : (a : Bin) → (b : Can a) → to'' (from a) ≡ ⟨ a , b ⟩
to∘from' .(to _) (Can- x) = {!!}


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring -- for length
open import Lists.Definition
open import Lists.Fold.Fold

module Lists.Length where

length : {a : _} {A : Set a} (l : List A) → ℕ
length [] = zero
length (x :: l) = succ (length l)

length' : {a : _} {A : Set a} → (l : List A) → ℕ
length' = fold (λ _ → succ) 0

length=length' : {a : _} {A : Set a} (l : List A) → length l ≡ length' l
length=length' [] = refl
length=length' (x :: l) = applyEquality succ (length=length' l)


module Prelude where

id : {A : Set} -> A -> A
id x = x

_·_ : {A B C : Set} -> (B -> C) -> (A -> B) -> (A -> C)
f · g = \ x -> f (g x)

flip : {A B C : Set} -> (A -> B -> C) -> B -> A -> C
flip f x y = f y x

Rel : Set -> Set1
Rel X = X -> X -> Set

data False : Set where
record True : Set where

tt : True
tt = _

! : {A : Set} -> A -> True
! = _

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

subst : {A : Set}(P : A -> Set){x y : A} -> x == y -> P y -> P x
subst P refl p = p

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

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 yz = yz

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

infixr 10 _,_

record Σ (A : Set)(B : A -> Set) : Set where
  field
    fst : A
    snd : B fst

_,,_ : {A : Set}{B : A -> Set}(x : A) -> B x -> Σ A B
x ,, y = record { fst = x; snd = y }

private module Σp {A : Set}{B : A -> Set} = Σ {A}{B}
open Σp public

data _∨_ (A B : Set) : Set where
  inl : A -> A ∨ B
  inr : B -> A ∨ B

data Bool : Set where
  false : Bool
  true  : Bool

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

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

data Inspect (b : Bool) : Set where
  itsTrue  : IsTrue b -> Inspect b
  itsFalse : IsFalse b -> Inspect b

inspect : (b : Bool) -> Inspect b
inspect true  = itsTrue  _
inspect false = itsFalse _

data LeqBool : Rel Bool where
  ref : {b : Bool} -> LeqBool b b
  up  : LeqBool false true

One : Rel True
One _ _ = True

_[×]_ : {A B : Set} -> Rel A -> Rel B -> Rel (A × B)
(R [×] S) (a₁ , b₁) (a₂ , b₂) = R a₁ a₂ × S b₁ b₂


module Numeric.Nat.GCD where

open import Prelude
open import Control.WellFounded
open import Numeric.Nat.Properties
open import Numeric.Nat.DivMod
open import Numeric.Nat.Divide
open import Numeric.Nat.Divide.Properties
open import Tactic.Nat

--- GCD ---

record IsGCD (d a b : Nat) : Set where
  no-eta-equality
  constructor is-gcd
  field d|a : d Divides a
        d|b : d Divides b
        g   : ∀ k → k Divides a → k Divides b → k Divides d

record GCD (a b : Nat) : Set where
  no-eta-equality
  constructor gcd-res
  field d     : Nat
        isGCD : IsGCD d a b

open GCD public using () renaming (d to get-gcd)

-- Projections --

is-gcd-factor₁ : ∀ {a b d} → IsGCD d a b → Nat
is-gcd-factor₁ g = get-factor (IsGCD.d|a g)

is-gcd-factor₂ : ∀ {a b d} → IsGCD d a b → Nat
is-gcd-factor₂ g = get-factor (IsGCD.d|b g)

gcd-factor₁ : ∀ {a b} → GCD a b → Nat
gcd-factor₁ g = is-gcd-factor₁ (GCD.isGCD g)

gcd-factor₂ : ∀ {a b} → GCD a b → Nat
gcd-factor₂ g = is-gcd-factor₂ (GCD.isGCD g)

-- Euclid's algorithm --

isGCD-step : ∀ {d r₀ r₁ r₂} q → q * r₁ + r₂ ≡ r₀ → IsGCD d r₁ r₂ → IsGCD d r₀ r₁
isGCD-step q refl (is-gcd d|r₁ d|r₂ g) =
  is-gcd (divides-add (divides-mul-r q d|r₁) d|r₂)
         d|r₁ (λ k k|r₀ k|r₁ → g k k|r₁ (divides-sub-l k|r₀ (divides-mul-r q k|r₁)))

private
  gcd-step : ∀ {a b} q {r} → q * suc b + r ≡ a → GCD (suc b) r → GCD a (suc b)
  gcd-step q eq (gcd-res d p) = gcd-res d (isGCD-step q eq p)

  gcd-cert-acc : ∀ a b → Acc _<_ b → GCD a b
  gcd-cert-acc a zero _ = gcd-res a (is-gcd (factor 1 auto) (factor! 0) (λ k k|a _ → k|a))
  gcd-cert-acc a (suc b) (acc wf) =
    case a divmod suc b of λ
    { (qr q r lt eq) → gcd-step q eq (gcd-cert-acc (suc b) r (wf r lt)) }

eraseIsGCD : ∀ {d a b} → IsGCD d a b → IsGCD d a b
eraseIsGCD (is-gcd d|a d|b g) =
  is-gcd (fast-divides d|a) (fast-divides d|b)
         λ k k|a k|b → fast-divides (g k k|a k|b)

eraseGCD : ∀ {a b} → GCD a b → GCD a b
eraseGCD (gcd-res d p) = gcd-res d (eraseIsGCD p)

gcd : ∀ a b → GCD a b
gcd 0 b = gcd-res b (is-gcd (factor! 0) divides-refl (λ _ _ k|b → k|b))
gcd 1 b = gcd-res 1 (is-gcd divides-refl (factor b auto) (λ _ k|1 _ → k|1))
gcd a b = eraseGCD (gcd-cert-acc a b (wfNat b))

gcd! : Nat → Nat → Nat
gcd! a b = get-gcd (gcd a b)

Coprime : Nat → Nat → Set
Coprime a b = gcd! a b ≡ 1


module Fin where

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

data Fin : Nat -> Set where
    fzero : {n : Nat} -> Fin (succ n)
    fsucc : {n : Nat} -> Fin n -> Fin (succ n)


module Problem2 where

open import Problem1

infixr 40 _►_

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

-- 2.1

vec : {A : Set}{n : Nat} -> A -> Vec A n
vec {n = zero } x = ε
vec {n = suc n} x = x ► vec x

-- 2.2

infixl 80 _<*>_

_<*>_ : {A B : Set}{n : Nat} -> Vec (A -> B) n -> Vec A n -> Vec B n
ε        <*> ε        = ε
(f ► fs) <*> (x ► xs) = f x ► fs <*> xs

-- 2.3

map : {A B : Set}{n : Nat} -> (A -> B) -> Vec A n -> Vec B n
map f xs = vec f <*> xs

-- 2.4

zip : {A B C : Set}{n : Nat} -> (A -> B -> C) ->
      Vec A n -> Vec B n -> Vec C n
zip f xs ys = vec f <*> xs <*> ys


module Prelude.Fin where

open import Prelude.Eq
open import Prelude.Nat

data Fin : Nat -> Set where
  fz : ∀{n} -> Fin (S n)
  fs : ∀{n} -> Fin n -> Fin (S n)

forget : {n : Nat} -> Fin n -> Nat
forget fz     = Z
forget (fs n) = S (forget n)

inject : (n : Nat) -> Fin (S n)
inject Z = fz
inject (S n) = fs (inject n)

inc : {n : Nat} -> Fin n -> Fin (S n)
inc fz     = fz
inc (fs n) = fs (inc n)


module plfa-exercises.part1.Decidable where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; pred)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using ()
  renaming (contradiction to ¬¬-intro)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import plfa.part1.Relations using (_<_; z<s; s<s)
open import plfa.part1.Isomorphism using (_⇔_)
open import Function.Base using (_∘_)

infix 4 _≤_

data _≤_ : ℕ → ℕ → Set where

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

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

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

¬4≤2 : ¬ (4 ≤ 2)
--¬4≤2 (s≤s (s≤s ())) = ? -- This causes Agda to die! TODO: Report
¬4≤2 (s≤s (s≤s ()))

data Bool : Set where
  true  : Bool
  false : Bool

infix 4 _≤ᵇ_

_≤ᵇ_ : ℕ → ℕ → Bool
zero ≤ᵇ n       =  true
suc m ≤ᵇ zero   =  false
suc m ≤ᵇ suc n  =  m ≤ᵇ n

_ : (2 ≤ᵇ 4) ≡ true
_ = refl
_ : (5 ≤ᵇ 4) ≡ false
_ = refl

T : Bool → Set
T true = ⊤
T false = ⊥

≤→≤ᵇ : ∀ {m n} → (m ≤ n) → T (m ≤ᵇ n)
≤→≤ᵇ z≤n = tt
≤→≤ᵇ (s≤s m≤n) = ≤→≤ᵇ m≤n

≤ᵇ→≤ : ∀ {m n} → T (m ≤ᵇ n) → (m ≤ n)
≤ᵇ→≤ {zero} {_} tt = z≤n
-- What is going on in here? Left `t` has type `T (suc m ≤ᵇ suc n)` and the right `t` has type `T (m ≤ᵇ n)`
-- λ m n → T (suc m ≤ᵇ suc n)   => reduces to:  λ m n → T (m ≤ᵇ n)
-- Ohh! Ok. It is because the third rule of `≤ᵇ` reduces `suc m ≤ᵇ suc n` to `m ≤ᵇ n`
≤ᵇ→≤ {suc m} {suc n} t = s≤s (≤ᵇ→≤ {m} {n} t)
-- λ m → T (suc m ≤ᵇ zero)   => reduces to:  λ m → ⊥
-- which means that there are no rules for `fromᵇ {suc m} {zero}`
≤ᵇ→≤ {suc m} {zero} ()

proof≡computation : ∀ {m n} → (m ≤ n) ⇔ T (m ≤ᵇ n)
proof≡computation {m} {n} =
  record
    { from = ≤ᵇ→≤
    ; to = ≤→≤ᵇ
    }

T→≡ : ∀ (b : Bool) → T b → b ≡ true
T→≡ true tt = refl
T→≡ false ()

--postulate
--  lie : false ≡ true

≡→T : ∀ {b : Bool} → b ≡ true → T b
--≡→T {false} refl = ? -- This is impossible because of refl's definition. Unification forces `b` to be `true`
--≡→T {false} rewrite lie = λ refl → ? -- Even postulating a lie, it is impossible to create a bottom value
≡→T refl = tt

_ : 2 ≤ 4
_ = ≤ᵇ→≤ tt

¬4≤2₂ : ¬ (4 ≤ 2)
--¬4≤2₂ 4≤2 = ≤→≤ᵇ 4≤2
--¬4≤2₂ = ≤→≤ᵇ {4} {2}
-- The type of `T (4 ≤ᵇ 2)` which reduces to `T false` and then `⊥`
¬4≤2₂ = ≤→≤ᵇ
-- Notice how defining ≤ᵇ lifts from us the demand of computing the correct
-- `evidence` (implementation) for the `proof` (function type)

data Dec (A : Set) : Set where
  yes :   A → Dec A
  no  : ¬ A → Dec A

¬s≤z : {m : ℕ} → ¬ (suc m) ≤ zero
--¬s≤z = ≤→≤ᵇ
¬s≤z ()

¬s≤s : {m n : ℕ} → ¬ m ≤ n → ¬ suc m ≤ suc n
¬s≤s ¬m≤n = λ { (s≤s m≤n) → ¬m≤n m≤n }

_≤?_ : (m n : ℕ) → Dec (m ≤ n)
zero    ≤? n       = yes z≤n
(suc m) ≤? zero    = no ¬s≤z
(suc m) ≤? (suc n) with m ≤? n
...                   | yes  m≤n = yes (s≤s m≤n)
...                   | no  ¬m≤n = no  (¬s≤s ¬m≤n)

-- `2 ≤? 4` reduces to `yes (s≤s (s≤s z≤n))`
_ : Dec (2 ≤ 4)
_ = 2 ≤? 4
_ = yes (s≤s (s≤s (z≤n {2})))

⌊_⌋ : ∀ {A : Set} → Dec A → Bool
⌊ yes x ⌋  =  true
⌊ no ¬x ⌋  =  false

_ : Bool
_ = true
_ = ⌊ 3 ≤? 4 ⌋

_ : ⌊ 3 ≤? 4 ⌋ ≡ true
_ = refl

_ : ⌊ 3 ≤? 2 ⌋ ≡ false
_ = refl

toWitness : ∀ {A : Set} {D : Dec A} → T ⌊ D ⌋ → A
toWitness {_} {yes v} tt = v
--toWitness {_} {no _} = ? -- `T ⌊ no x ⌋ → A` reduces to `⊥ → A`
toWitness {_} {no _} () -- Empty because there is no value for `⊥`

fromWitness : ∀ {A : Set} {D : Dec A} → A → T ⌊ D ⌋
fromWitness {_} {yes _} _ = tt
fromWitness {_} {no ¬a} a = ¬a a -- with type ⊥

_ : 2 ≤ 4
--_ = toWitness {D = 2 ≤? 4} tt
_ = toWitness {_} {2 ≤? 4} tt

¬4≤2₃ : ¬ (4 ≤ 2)
--¬4≤2₃ = fromWitness {D = 4 ≤? 2}
¬4≤2₃ = fromWitness {_} {4 ≤? 2}

¬z<z : ¬ (zero < zero)
¬z<z ()

¬s<z : ∀ {m : ℕ} → ¬ (suc m < zero)
¬s<z ()

_<?_ : ∀ (m n : ℕ) → Dec (m < n)
zero <? zero = no ¬z<z
zero <? suc n = yes z<s
suc m <? zero = no ¬s<z
suc m <? suc n with m <? n
...               | yes m<n = yes (s<s m<n)
...               | no ¬m<n = no λ{(s<s m<n) → ¬m<n m<n}

_ : ⌊ 2 <? 4 ⌋ ≡ true
_ = refl

¬z≡sn : ∀ {n : ℕ} → ¬ zero ≡ suc n
¬z≡sn ()

_≡ℕ?_ : ∀ (m n : ℕ) → Dec (m ≡ n)
zero    ≡ℕ? zero    = yes refl
zero    ≡ℕ? (suc n) = no ¬z≡sn
--(suc m) ≡ℕ? zero    = no (λ{sn≡z → ¬z≡sn (sym sn≡z)})
--(suc m) ≡ℕ? zero    = no (¬z≡sn ∘ sym)
(suc m) ≡ℕ? zero    = no ((λ()) ∘ sym)
--The following doesn't work though
--(suc m) ≡ℕ? zero    with zero ≡ℕ? (suc m)
--...                 | yes  z≡sm = yes (sym z≡sm)
--...                 | no  ¬z≡sm = no (¬z≡sm ∘ sym)
(suc m) ≡ℕ? (suc n) with m ≡ℕ? n
...               | yes m≡n = yes (cong suc m≡n)
...               | no ¬m≡n = no  (¬m≡n ∘ (cong pred))

infixr 6 _×-dec_

_×-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A × B)
yes x ×-dec yes y = yes ⟨ x , y ⟩
no ¬x ×-dec _     = no λ{ ⟨ x , y ⟩ → ¬x x }
_     ×-dec no ¬y = no λ{ ⟨ x , y ⟩ → ¬y y }

infixr 6 _⊎-dec_

_⊎-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⊎ B)
yes x ⊎-dec _     = yes (inj₁ x)
_     ⊎-dec yes y = yes (inj₂ y)
no ¬x ⊎-dec no ¬y = no λ{(inj₁ x) → ¬x x; (inj₂ y) → ¬y y}

¬? : ∀ {A : Set} → Dec A → Dec (¬ A)
¬? (yes x) = no (¬¬-intro x)
¬? (no ¬x) = yes ¬x

_→-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A → B)
_     →-dec yes y = yes (λ _ → y)
--no ¬x →-dec _     = yes ((λ()) ∘ ¬x)
no ¬x →-dec _     = yes (⊥-elim ∘ ¬x)
yes x →-dec no ¬y = no (λ{x→y → ¬y (x→y x)})

infixr 6 _∧_

_∧_ : Bool → Bool → Bool
true  ∧ true  = true
false ∧ _     = false
_     ∧ false = false

∧-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∧ ⌊ y ⌋ ≡ ⌊ x ×-dec y ⌋
∧-× (yes x) (yes y) = refl
∧-× (no ¬x) _       = refl
∧-× (yes x) (no ¬y) = refl

_iff_ : Bool → Bool → Bool
true  iff true  = true
false iff false = true
_     iff _     = false

_⇔-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⇔ B)
yes x ⇔-dec yes y = yes (record { from = λ{_ → x} ; to = λ{_ → y} })
no ¬x ⇔-dec no ¬y = yes (record { from = (λ()) ∘ ¬y ; to = (λ()) ∘ ¬x })
yes x ⇔-dec no ¬y = no (λ x⇔y → ¬y (_⇔_.to   x⇔y x))
no ¬x ⇔-dec yes y = no (λ x⇔y → ¬x (_⇔_.from x⇔y y))

iff-⇔ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ iff ⌊ y ⌋ ≡ ⌊ x ⇔-dec y ⌋
iff-⇔ (yes x) (yes y) = refl
iff-⇔ (no ¬x) (no ¬y) = refl
iff-⇔ (no ¬x) (yes y) = refl
iff-⇔ (yes x) (no ¬y) = refl


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

open import Groups.Definition
open import Groups.Abelian.Definition
open import Setoids.Setoids
open import Rings.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Modules.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+R_ : A → A → A} {_*_ : A → A → A} (R : Ring S _+R_ _*_) {m n : _} {M : Set m} {T : Setoid {m} {n} M} {_+_ : M → M → M} {G' : Group T _+_} (G : AbelianGroup G') (_·_ : A → M → M) where

record Module : Set (a ⊔ b ⊔ m ⊔ n) where
  field
    dotWellDefined : {r s : A} {t u : M} → Setoid._∼_ S r s → Setoid._∼_ T t u → Setoid._∼_ T (r · t) (s · u)
    dotDistributesLeft : {r : A} {x y : M} → Setoid._∼_ T (r · (x + y)) ((r · x) + (r · y))
    dotDistributesRight : {r s : A} {x : M} → Setoid._∼_ T ((r +R s) · x) ((r · x) + (s · x))
    dotAssociative : {r s : A} {x : M} → Setoid._∼_ T ((r * s) · x) (r · (s · x))
    dotIdentity : {x : M} → Setoid._∼_ T ((Ring.1R R) · x) x


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

open import Relation.Binary using (Rel)

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

open import Algebra.Linear.Core

open import Relation.Nullary using (¬_)

open import Algebra.Structures _≈_
open import Algebra.FunctionProperties _≈_

open import Level using (_⊔_)

record NonZero (0# : A) : Set (a ⊔ ℓ) where
  field
    value    : A
    non-zero : ¬ (value ≈ 0#)

MultiplicativeInverse : ∀ (0# : A) -> Set (a ⊔ ℓ)
MultiplicativeInverse 0# = NonZero 0# → NonZero 0#

record IsField (_+_ _*_ : Op₂ A) (0# 1# : A) (-_ : Op₁ A) (_⁻¹ : MultiplicativeInverse 0#) : Set (a ⊔ ℓ) where
  field
    isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0# 1#
    _⁻¹-involutive : ∀ (x : NonZero 0#) → NonZero.value ((x ⁻¹) ⁻¹) ≈ NonZero.value x
    _⁻¹-inverse  : ∀ (x : NonZero 0#) → ((NonZero.value x) * (NonZero.value (x ⁻¹))) ≈ 1#
    0#-not-1#    : ¬ (0# ≈ 1#)

  open IsCommutativeRing isCommutativeRing public

  open import Algebra.Properties.Ring (record { isRing = isRing }) public


module Data.List.First {ℓ}{A : Set ℓ} where

open import Data.Product
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Level
open import Function
open import Data.Empty

-- proof that an element is the first in a vector to satisfy the predicate B
data First {b}(B : A → Set b) : (x : A) → List A → Set (ℓ ⊔ b) where

  here  : ∀ {x : A} → (p : B x) → {v : List A} → First B x (x ∷ v)
  there : ∀ {x} {v : List A} (x' : A) → ¬ (B x') → First B x v → First B x (x' ∷ v)

-- get the witness of B x from the element ∈ First
first⟶witness : ∀ {B : A → Set} {x l} → First B x l → B x
first⟶witness (here p) = p
first⟶witness (there x ¬px f) = first⟶witness f

-- more likable syntax for the above structure
first_∈_⇒_ : ∀ {p} → A → List A → (B : A → Set p) → Set (p ⊔ ℓ)
first_∈_⇒_ x v p = First p x v

-- a decision procedure to find the first element in a vector that satisfies a predicate
find : ∀ (P : A → Set) → ((a : A) → Dec (P a)) → (v : List A) →
       Dec (∃ λ e → first e ∈ v ⇒ P)
find P dec [] = no (λ{ (e , ()) })
find P dec (x ∷ v) with dec x
find P dec (x ∷ v) | yes px = yes (x , here px)
find P dec (x ∷ v) | no ¬px with find P dec v
find P dec (x ∷ v) | no ¬px | yes firstv = yes (-, there x ¬px (proj₂ firstv))
find P dec (x ∷ v) | no ¬px | no ¬firstv = no $ helper ¬px ¬firstv
  where
    helper : ¬ (P x) → ¬ (∃ λ e → First P e v) → ¬ (∃ λ e → First P e (x ∷ v))
    helper ¬px ¬firstv (.x , here p) = ¬px p
    helper ¬px ¬firstv (u  , there ._ _ firstv) = ¬firstv (u , firstv)


-- This module introduces the basic structure of an Agda program.

{- Every Agda file contains a single top-level module. To make it possible to
   find the file corresponding to a particular module, the name of the file
   should correspond to the name of the module. In this case the module
   'Introduction.Basics' is defined in the file 'Introduction/Basics.agda'.
-}
module Basics where

{- The top-level module contains a sequence of declarations, such as datatype
   declarations and function definitions. The most common forms of declarations
   are introduced below.

   A module can also contain sub-modules, see 'Introduction.Modules.SubModules'
   for more information.
-}

-- Agda can be used as a pure logical framework. The 'postulate' declaration
-- introduces new constants :
postulate
  N : Set     -- Set is the first universe
  z : N
  s : N -> N  -- The independent function space is written A -> B

-- Using 'postulate' it is not possible to introduce new computation rules. A
-- better way is to introduce a datatype and define functions by pattern
-- matching on elements of the datatype.

-- A datatype is introduced with the 'data' keyword. All constructors of the
-- datatype are given with their types after the 'where'. Datatypes can be
-- parameterised (see 'Introduction.Data.Parameterised').

data Bool : Set where
  false : Bool
  true  : Bool

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

-- Functions over datatypes can be defined by pattern matching.

plus : Nat -> Nat -> Nat
plus  zero   m = m
plus (suc n) m = suc (plus n m)

-- With this definition plus (suc zero) (suc zero) will reduce to suc (suc
-- zero).

-- When defining mutually recursive functions you have to declare functions
-- before they can be called.

odd : Nat -> Bool

even : Nat -> Bool
even (suc n) = odd n
even zero    = true

odd zero    = false
odd (suc n) = even n

-- Agda is a monomorphic, but dependently typed, language. This means that
-- polymorphism is simulated by having functions take type arguments. For
-- instance, the polymorphic identity function can be represented as follows :

id : (A : Set) -> A -> A        -- the dependent function space is written (x : A) -> B
id A x = x

one : Nat
one = id Nat (suc zero) -- a silly use of the identity function

-- To faithfully simulate a polymorphic function we would like to omit the type
-- argument when using the function. See 'Introduction.Implicit' for
-- information on how to do this.

-- Agda is both a programming language and a formal proof language, so we
-- expect to be able to prove theorems about our programs. As an example we
-- prove the very simple theorem n + 0 == n.

-- First we introduce datatypes for truth (a singleton type) and falsity (an
-- empty type).

data True : Set where   -- Here it would make sense to declare True to be a
  tt : True             -- Prop (the universe of propositions) rather than a
                        -- Set. See 'Introduction.Universes' for more
                        -- information.

data False : Set where  -- see 'Introduction.Data.Empty' for more information
                        -- on empty types.

-- Second, we define what it means for two natural numbers to be equal. Infix
-- operators are declared by enclosing the operator in _. See
-- 'Introduction.Operators' for more information.

_==_ : Nat -> Nat -> Set
zero  == zero  = True
zero  == suc m = False
suc n == zero  = False
suc n == suc m = n == m

-- Now we are ready to state and prove our theorem. The proof is by induction
-- (i.e. recursion) on 'n'.

thmPlusZero : (n : Nat) -> plus n zero == n   -- A function from a number n to
                                            -- P n can be seen as the
                                            -- proposition ∀ n. P n.
thmPlusZero  zero   = tt
thmPlusZero (suc n) = thmPlusZero n

thmPlusZero' : (n : Nat) -> plus zero n == n
thmPlusZero'  zero   = tt
thmPlusZero' (suc n) = thmPlusZero' n

{- In both branches the reduction makes the proof very simple. In the first
   case the goal is

    plus zero zero == zero    which reduces to
    zero == zero              and
    True

  In the second case we have

    plus (suc n) zero == suc n
    suc (plus n zero) == suc n
    plus n zero == n

  so the induction hypothesis (the recursive call) is directly applicable.
-}


{-

This file introduces the "powerset" of a type in the style of
Escardó's lecture notes:

https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#propositionalextensionality

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Powerset where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence using (hPropExt)

open import Cubical.Data.Sigma

private
  variable
    ℓ : Level
    X : Type ℓ

ℙ : Type ℓ → Type (ℓ-suc ℓ)
ℙ X = X → hProp _

infix 5 _∈_

_∈_ : {X : Type ℓ} → X → ℙ X → Type ℓ
x ∈ A = ⟨ A x ⟩

_⊆_ : {X : Type ℓ} → ℙ X → ℙ X → Type ℓ
A ⊆ B = ∀ x → x ∈ A → x ∈ B

∈-isProp : (A : ℙ X) (x : X) → isProp (x ∈ A)
∈-isProp A = snd ∘ A

⊆-isProp : (A B : ℙ X) → isProp (A ⊆ B)
⊆-isProp A B = isPropΠ2 (λ x _ → ∈-isProp B x)

⊆-refl : (A : ℙ X) → A ⊆ A
⊆-refl A x = idfun (x ∈ A)

⊆-refl-consequence : (A B : ℙ X) → A ≡ B → (A ⊆ B) × (B ⊆ A)
⊆-refl-consequence A B p = subst (A ⊆_) p (⊆-refl A)
                          , subst (B ⊆_) (sym p) (⊆-refl B)

⊆-extensionality : (A B : ℙ X) → (A ⊆ B) × (B ⊆ A) → A ≡ B
⊆-extensionality A B (φ , ψ) =
  funExt (λ x → TypeOfHLevel≡ 1 (hPropExt (A x .snd) (B x .snd) (φ x) (ψ x)))

powersets-are-sets : isSet (ℙ X)
powersets-are-sets = isSetΠ (λ _ → isSetHProp)

⊆-extensionalityEquiv : (A B : ℙ X) → (A ⊆ B) × (B ⊆ A) ≃ (A ≡ B)
⊆-extensionalityEquiv A B = isoToEquiv (iso (⊆-extensionality A B)
                                            (⊆-refl-consequence A B)
                                            (λ _ → powersets-are-sets A B _ _)
                                            (λ _ → isPropΣ (⊆-isProp A B) (λ _ → ⊆-isProp B A) _ _))


{- 1. Booleans -}

data Bool : Set where
  true : Bool
  false : Bool

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

_∧_ : Bool → Bool → Bool
true ∧ true = true
true ∧ false = false
false ∧ true = false
false ∧ false = false

_∨_ : Bool → Bool → Bool
true ∨ true = true
true ∨ false = true
false ∨ true = true
false ∨ false = false

{- 2. Equality -}
data _≡_ {A : Set} (x : A) : (y : A) → Set where
  refl : x ≡ x

infix 4 _≡_

not-inv : (b : Bool) → not (not b) ≡ b
not-inv true = refl
not-inv false = refl

f : (b : Bool) → (not b) ∧ b ≡ false
f true = refl
f false = refl


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

open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Addition
open import Numbers.Naturals.Multiplication
open import Semirings.Definition
open import Monoids.Definition

module Numbers.Naturals.Semiring where

open Numbers.Naturals.Definition using (ℕ ; zero ; succ ; succInjective ; naughtE) public
open Numbers.Naturals.Addition using (_+N_ ; canSubtractFromEqualityRight ; canSubtractFromEqualityLeft) public
open Numbers.Naturals.Multiplication using (_*N_ ; multiplicationNIsCommutative) public

ℕSemiring : Semiring 0 1 _+N_ _*N_
Monoid.associative (Semiring.monoid ℕSemiring) a b c = equalityCommutative (additionNIsAssociative a b c)
Monoid.idLeft (Semiring.monoid ℕSemiring) _ = refl
Monoid.idRight (Semiring.monoid ℕSemiring) a = additionNIsCommutative a 0
Semiring.commutative ℕSemiring = additionNIsCommutative
Monoid.associative (Semiring.multMonoid ℕSemiring) = multiplicationNIsAssociative
Monoid.idLeft (Semiring.multMonoid ℕSemiring) a = additionNIsCommutative a 0
Monoid.idRight (Semiring.multMonoid ℕSemiring) a = transitivity (multiplicationNIsCommutative a 1) (additionNIsCommutative a 0)
Semiring.productZeroLeft ℕSemiring _ = refl
Semiring.productZeroRight ℕSemiring a = multiplicationNIsCommutative a 0
Semiring.+DistributesOver* ℕSemiring = productDistributes
Semiring.+DistributesOver*' ℕSemiring a b c rewrite multiplicationNIsCommutative (a +N b) c | multiplicationNIsCommutative a c | multiplicationNIsCommutative b c = productDistributes c a b

succExtracts : (x y : ℕ) → (x +N succ y) ≡ (succ (x +N y))
succExtracts x y = transitivity (Semiring.commutative ℕSemiring x (succ y)) (applyEquality succ (Semiring.commutative ℕSemiring y x))

productZeroImpliesOperandZero : {a b : ℕ} → a *N b ≡ 0 → (a ≡ 0) || (b ≡ 0)
productZeroImpliesOperandZero {zero} {b} pr = inl refl
productZeroImpliesOperandZero {succ a} {zero} pr = inr refl
productZeroImpliesOperandZero {succ a} {succ b} ()

*NWellDefined : {a b c d : ℕ} → (a ≡ c) → (b ≡ d) → a *N b ≡ c *N d
*NWellDefined refl refl = refl

+NWellDefined : {a b c d : ℕ} → (a ≡ c) → (b ≡ d) → a +N b ≡ c +N d
+NWellDefined refl refl = refl


open import Relation.Binary.Core

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

open import BTree {A}
open import Data.List
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import TreeSort.Impl1 _≤_ tot≤

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

lemma-flatten∼ : (x : A) → (t : BTree) → (x ∷ flatten t) ∼ flatten (insert x t)
lemma-flatten∼ x leaf = ∼x /head /head ∼[]
lemma-flatten∼ x (node y l r)
    with tot≤ x y
... | inj₁ x≤y = lemma++∼r (lemma-flatten∼ x l)
... | inj₂ y≤x = trans∼ (lemma-++∼ {xs = flatten l}) (lemma++∼l {xs = flatten l} (∼x (/tail /head) /head (lemma-flatten∼ x r)))

theorem-treeSort∼ : (xs : List A) → xs ∼ (flatten (treeSort xs))
theorem-treeSort∼ [] = ∼[]
theorem-treeSort∼ (x ∷ xs) = trans∼ (∼x /head /head (theorem-treeSort∼ xs)) (lemma-flatten∼ x (treeSort xs))


module Graph where

import      Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Data.List
open import Logic.Propositional{Lvl.𝟎}
open import Logic.Predicate{Lvl.𝟎}{Lvl.𝟎}
open import Relator.Equals{Lvl.𝟎}
open import Data.List.Relation.Membership{Lvl.𝟎} using (_∈_)

-- EdgeClass(V)(E) means that E is a type which can represent an edge between vertices of type V.
record EdgeClass (V : Set) (Self : Set) : Set where
  constructor edgeInstance
  field
    from           : Self → V
    to             : Self → V
    _withVertices_ : Self → (V ⨯ V) → Self

module Edge where
  open EdgeClass ⦃ ... ⦄ public

instance
  EdgeInstance-Tuple : ∀{V} → EdgeClass(V)(V ⨯ V)
  Edge.from          ⦃ EdgeInstance-Tuple ⦄ (v₁ , v₂) = v₁
  Edge.to            ⦃ EdgeInstance-Tuple ⦄ (v₁ , v₂) = v₂
  Edge._withVertices_ ⦃ EdgeInstance-Tuple ⦄ (v₁ , v₂) (w₁ , w₂) = (w₁ , w₂)

record Graph (V : Set) (E : Set) ⦃ _ : EdgeClass(V)(E) ⦄ : Set where
  constructor graph

  field
    edges : List(E)

  -- Propositions
  HasEdge[_⟶_] : V → V → Set
  HasEdge[_⟶_](v₁)(v₂) = ∃(edge ↦ (edge ∈ edges)∧(Edge.from(edge) ≡ v₁)∧(Edge.to(edge) ≡ v₂))

  HasEdge[_⟵_] : V → V → Set
  HasEdge[_⟵_](v₁)(v₂) = HasEdge[_⟶_](v₂)(v₁)

  HasEdge[_⟷_] : V → V → Set
  HasEdge[_⟷_](v₁)(v₂) = HasEdge[_⟵_](v₁)(v₂) ∧ HasEdge[_⟶_](v₁)(v₂)

  data Path : V → V → Set where
    PathIntro        : ∀{v₁ v₂ : V} → HasEdge[ v₁ ⟶ v₂ ] → Path(v₁)(v₂)
    PathTransitivity : ∀{v₁ v₂ v₃ : V} → Path(v₁)(v₂) → Path(v₂)(v₃) → Path(v₁)(v₃)

  Connected : V → V → Set
  Connected(v₁)(v₂) = Path(v₁)(v₂)

  Disconnected : V → V → Set
  Disconnected(v₁)(v₂) = ¬(Connected(v₁)(v₂))

  -- Constructions
  mapVertices : ∀{V₂} → ⦃ _ : EdgeClass(V₂)(E) ⦄ → (V → V₂) → Graph(V₂)(E)
  mapVertices(f) = record{edges = map(edge ↦ (edge Edge.withVertices(f(Edge.from(edge)) , f(Edge.to(edge))))) (edges)}

  -- Boolean testing
  -- with-edge
  -- without-edge
  -- has-edge
  -- is-connected
  -- is-disconnected


module fib1 where

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

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

one : ℕ
one = S Z

fib : ℕ -> ℕ
fib Z         = one
fib (S Z)     = one
fib (S (S n)) = fib n + fib (S n)


module start where

open import Relation.Binary.PropositionalEquality
open import Data.Product
open import Function hiding (id)

injective : {A B : Set} → (f : A → B) → Set
injective f = ∀ a₁ a₂ → f a₁ ≡ f a₂ → a₁ ≡ a₂

surjective : {A B : Set} → (f : A → B) → Set
surjective f = ∀ b → ∃ (λ a → f a ≡ b)

bijective : {A B : Set} → (f : A → B) → Set
bijective f = injective f × surjective f

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

lemma-suc-inj : ∀ {a₁ a₂} → suc a₁ ≡ suc a₂ → a₁ ≡ a₂
lemma-suc-inj refl = refl

suc-injective : injective suc
suc-injective a₁ a₂ = lemma-suc-inj

id : {A : Set} → A → A
id x = x

lemma-id-inj : ∀ {A} {a₁ a₂ : A} → id a₁ ≡ id a₂ → a₁ ≡ a₂
lemma-id-inj refl = refl

id-injective : ∀ {A} → injective (id {A})
id-injective a₁ a₂ = lemma-id-inj

lemma-id-surj : ∀ {A} (b : A) → ∃ (λ a → id a ≡ b)
lemma-id-surj b = b , refl

id-surjective : ∀ {A} → surjective (id {A})
id-surjective = lemma-id-surj

bijective→injective : ∀ {A B} {f : A → B} → bijective f → injective f
bijective→injective b = proj₁ b

bijective→surjective : ∀ {A B} {f : A → B} → bijective f → surjective f
bijective→surjective b = proj₂ b

left-inverse : ∀ {A B} → (f : A → B) → Set
left-inverse f = ∃ (λ g → g ∘ f ≡ id)

right-inverse : ∀ {A B} → (f : A → B) → Set
right-inverse f = ∃ (λ g → f ∘ g ≡ id)

infix 5 _s~_
_s~_ : {A : Set} {a b c : A} → a ≡ b → a ≡ c → c ≡ b
_s~_ refl refl = refl

infix 5 _~_
_~_ : {A : Set} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
_~_ = trans

lemma-left-id₁ : ∀ {A B : Set} (g : B → A) (f : A → B) → g ∘ f ≡ id → (∀ a → g (f a) ≡ a)
lemma-left-id₁ g f idcomp a = cong (λ f₁ → f₁ a) idcomp

lemma-left-id : ∀ {A B : Set} (a₁ a₂ : A) (g : B → A) (f : A → B) → g ∘ f ≡ id → g (f a₁) ≡ g (f a₂) → a₁ ≡ a₂
lemma-left-id a₁ a₂ g f idcomp comp = (comp ~ lemma-left-id₁ g f idcomp a₂) s~ lemma-left-id₁ g f idcomp a₁

lemma-left-inj : ∀ {A B : Set} (a₁ a₂ : A) → (f : A → B) → ∃ (λ g → g ∘ f ≡ id) → f a₁ ≡ f a₂ → a₁ ≡ a₂
lemma-left-inj a₁ a₂ f (g , idcomp) eq = lemma-left-id a₁ a₂ g f idcomp (cong (λ x → g x) eq)

left-inverse→injective : ∀ {A B} (f : A → B) → left-inverse f → injective f
left-inverse→injective f left-inv a₁ a₂ fas = lemma-left-inj a₁ a₂ f left-inv fas

right-inverse→surjective : ∀ {A B} (f : A → B) → right-inverse f → surjective f
right-inverse→surjective f (g , right) b = g b , cong (λ f₁ → f₁ b) right

postulate extensionality : {A : Set} {B : Set} {f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g

id-unique : ∀ {A : Set} → (f : A → A) → (∀ a → f a ≡ a) → f ≡ id
id-unique f fa-prop = extensionality {f = f} {g = id} fa-prop

surjective→right-inverse : ∀ {A B} (f : A → B) → surjective f → right-inverse f
surjective→right-inverse f right = g , id-unique (f ∘ g) (λ b → proj₂ (right b))
  where g = λ b → proj₁ (right b)


module nat-division where

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

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

-- we use an upper bound n on the dividend x.  For an alternative approach, see nat-division-wf.agda.
divh : (n : ℕ) → (x : ℕ) → (y : ℕ) → x ≤ n ≡ tt → y =ℕ 0 ≡ ff → div-result x y
divh 0 0 0 p1 ()
divh 0 0 (suc y) p1 p2 = 0 , 0 , refl , refl
divh 0 (suc x) y () p2
divh (suc n) x y p1 p2 with keep (x < y)
divh (suc n) x y p1 p2 | tt , pl = 0 , x , refl , pl
divh (suc n) x y p1 p2 | ff , pl with divh n (x ∸ y) y (∸≤2 n x y p1 p2) p2
divh (suc n) x y p1 p2 | ff , pl | q , r , pa , pb = suc q , r , lem{q}{r} pa , pb
  where lem : ∀{q r} → q * y + r ≡ x ∸ y → y + q * y + r ≡ x
        lem{q}{r} p rewrite sym (+assoc y (q * y) r) | p | +comm y (x ∸ y) = ∸+2{x}{y} (<ff{x}{y} pl)

-- the div-result contains the quotient, remainder, and proof relating them to the inputs
_÷_!_ : (x : ℕ) → (y : ℕ) → y =ℕ 0 ≡ ff → div-result x y
x ÷ y ! p = divh x x y (≤-refl x) p

-- return a pair of the quotient and remainder
_÷_!!_ : ℕ → (y : ℕ) → y =ℕ 0 ≡ ff → ℕ × ℕ
x ÷ y !! p with x ÷ y ! p
... | q , r , p' = q , r

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

-- return the remainder only
_÷_mod_ : ℕ → (y : ℕ) → y =ℕ 0 ≡ ff → ℕ
x ÷ y mod p with x ÷ y ! p
... | q , r , p' = r


module z where

------------------------------------------------------------------------------
-- 1 intro

-- data types

data Nat : Set where
  zero :       Nat
  suc  : Nat → Nat
{-# BUILTIN NATURAL Nat #-}

--------------------------------------------------
-- begin : from later - here to use in tests
data Bool : Set where
  true  : Bool
  false : Bool

data IsTrue : Bool → Set where
  is-true : IsTrue true

_=Nat_ : Nat → Nat → Bool
zero    =Nat  zero   = true
(suc x) =Nat (suc y) = x =Nat y
_       =Nat  _      = false
-- end : from later
--------------------------------------------------

-- pattern matching

_+_ : Nat → Nat → Nat
zero    + y =          y
(suc x) + y = suc (x + y)
infixl 9 _+_
-- {-# BUILTIN NATPLUS _+_ #-}

-- ex 1.1
halve : Nat → Nat
halve       zero    = zero
halve (suc  zero)   = zero
halve (suc (suc n)) = suc (halve n)

halve-0  : IsTrue (halve   0 =Nat 0)
halve-0  = is-true
halve-1  : IsTrue (halve   1 =Nat 0)
halve-1  = is-true
halve-2  : IsTrue (halve   2 =Nat 1)
halve-2  = is-true
halve-3  : IsTrue (halve   3 =Nat 1)
halve-3  = is-true
halve-4  : IsTrue (halve   4 =Nat 2)
halve-4  = is-true
halve-14 : IsTrue (halve  14 =Nat 7)
halve-14 = is-true
halve-15 : IsTrue (halve  15 =Nat 7)
halve-15 = is-true
halve-16 : IsTrue (halve  16 =Nat 8)
halve-16 = is-true

-- ex 1.2
_*_ : Nat → Nat → Nat
zero    * y    = zero
(suc x) * y = y + (x * y)

2*0 : IsTrue ((2 * 0) =Nat  0)
2*0 = is-true
2*1 : IsTrue ((2 * 1) =Nat  2)
2*1 = is-true
2*2 : IsTrue ((2 * 2) =Nat  4)
2*2 = is-true
3*3 : IsTrue ((3 * 3) =Nat  9)
3*3 = is-true
4*4 : IsTrue ((4 * 4) =Nat 16)
4*4 = is-true

{-
-- ex 1.3
data Bool : Set where
  true  : Bool
  false : Bool
-}

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

_&&_ : Bool → Bool → Bool
_&&_ true  y = y
_&&_ false _ = false

_||_ : Bool → Bool → Bool
_||_ true  _ = true
_||_ false y = y

-- types are 1st class
-- equivalent to Haskell type alias : type MyNat = Nat
MyNat : Set
MyNat = Nat

-- Set used to implement polymorphic functions
idA : (A : Set) → A → A
idA _ x = x

-- implicit args
id : {A : Set} → A → A
id  x = x

-- polymorphic data types
data List (A : Set) : Set where
  []   :              List A
  _::_ : A → List A → List A
infixr 5 _::_

-- ex 1.4
length : {A : Set} → List A → Nat
length       []  = zero
length (_ :: xs) = 1 + length xs

_++_ :  {A : Set} → List A → List A → List A
_++_       []  l2 =            l2
_++_ (x :: xs) l2 = x :: xs ++ l2

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

-- ex 1.5
data Maybe (A : Set) : Set where
  just    : A → Maybe A
  nothing :     Maybe A

lookup : {A : Set} → List A → Nat → Maybe A
lookup       []       _  = nothing
lookup (x ::  _)  zero   = just x
lookup (_ :: xs) (suc n) = lookup xs n

_=List-Nat_ : List Nat → List Nat → Bool
[]        =List-Nat       []  = true
(x :: xs) =List-Nat (y :: ys) = (x =Nat y) && (xs =List-Nat ys)
_         =List-Nat        _  = false

ex-xs  : List Nat
ex-xs  = 0 :: 1 :: 2 :: 3 :: []

length++ : IsTrue ((length ex-xs + length ex-xs) =Nat (length (ex-xs ++ ex-xs)))
length++ = is-true

map2* : IsTrue (map (2 *_) ex-xs =List-Nat (0 :: 2 :: 4 :: 6 :: []))
map2* = is-true

_=Maybe-Nat_ : Maybe Nat → Maybe Nat → Bool
nothing   =Maybe-Nat  nothing  = true
(just x)  =Maybe-Nat  (just y) = x =Nat y
_         =Maybe-Nat        _  = false

lookup[]0    : IsTrue (lookup    [] 0 =Maybe-Nat nothing)
lookup[]0    = is-true
lookupex-xs0 : IsTrue (lookup ex-xs 0 =Maybe-Nat (just 0))
lookupex-xs0 = is-true
lookupex-xs1 : IsTrue (lookup ex-xs 1 =Maybe-Nat (just 1))
lookupex-xs1 = is-true
lookupex-xs9 : IsTrue (lookup ex-xs 9 =Maybe-Nat nothing)
lookupex-xs9 = is-true

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B
infixr 4 _,_

fst : {A B : Set} → A × B → A
fst (a , _) = a

snd : {A B : Set} → A × B → B
snd (_ , b) = b

-- ex 1.6
-- NO.  Regardless of the value of 'Nat', there is NO way to construct an A if given [].

------------------------------------------------------------------------------
-- 2 dependent types

--      parameter         : bound for ENTIRE def
--                  index : varies according to constructor
--          v         v
data Vec (A : Set) : Nat → Set where              -- Vec is dependent TYPE
  []   :                           Vec A 0
  _::_ : {n : Nat} → A → Vec A n → Vec A (suc n)
--infixr 5 _::_

-- dependent FUNCTION : return TYPE depends on inputs
zeroes : (n : Nat) → Vec Nat n
zeroes  zero   = []
zeroes (suc n) = 0 :: zeroes n

-- ex 2.1
downFrom : (n : Nat) → Vec Nat n
downFrom   zero  = []
downFrom (suc n) = n :: downFrom n

_=Vec-Nat_ : {n : Nat} → Vec Nat n → Vec Nat n → Bool
[]        =Vec-Nat       []  = true
(x :: xs) =Vec-Nat (y :: ys) = (x =Nat y) && (xs =Vec-Nat ys)

downFrom0 : IsTrue (downFrom 0 =Vec-Nat                                     [])
downFrom0 = is-true
downFrom1 : IsTrue (downFrom 1 =Vec-Nat                               (0 :: []))
downFrom1 = is-true
downFrom2 : IsTrue (downFrom 2 =Vec-Nat                          (1 :: 0 :: []))
downFrom2 = is-true
downFrom3 : IsTrue (downFrom 3 =Vec-Nat                     (2 :: 1 :: 0 :: []))
downFrom3 = is-true
downFrom7 : IsTrue (downFrom 7 =Vec-Nat (6 :: 5 :: 4 :: 3 :: 2 :: 1 :: 0 :: []))
downFrom7 = is-true

-- ex 2.2
tail : {A : Set} {n : Nat} → Vec A (suc n) → Vec A n
tail (_ :: xs) = xs

-- ex 2.3
dotProduct : {n : Nat} → Vec Nat n → Vec Nat n → Nat
dotProduct       []        []  = 0
dotProduct (x :: xs) (y :: ys) = (x * y) + dotProduct xs ys

dotProduct32 : IsTrue (dotProduct (1 :: 2 :: 3 :: []) (1 :: 5 :: 7 :: []) =Nat 32)
dotProduct32 = is-true

-- finite type family
data Fin : Nat → Set where
  zero : {n : Nat} →         Fin (suc n)
  suc  : {n : Nat} → Fin n → Fin (suc n)

lookupVec : {A : Set} {n : Nat} → Vec A n → Fin n → A
lookupVec       []   ()
lookupVec (x ::  _)  zero   = x
lookupVec (_ :: xs) (suc i) = lookupVec xs i

-- ex 2.4
putVec : {A : Set} {n : Nat} → Fin n → A → Vec A n → Vec A n
putVec  zero   a (_ :: xs) = a ::            xs
putVec (suc i) a (x :: xs) = x :: putVec i a xs

ex-vxs  : Vec Nat 4
ex-vxs  = 0 :: 1 :: 2 :: 3 :: []

lookupVecex-vxs0 : IsTrue (lookupVec ex-vxs                zero    =Nat 0)
lookupVecex-vxs0 = is-true
lookupVecex-vxs3 : IsTrue (lookupVec ex-vxs (suc (suc (suc zero))) =Nat 3)
lookupVecex-vxs3 = is-true

putVecex-vxs3 : IsTrue (putVec (suc (suc zero)) 22 ex-vxs  =Vec-Nat (0 :: 1 :: 22 :: 3 :: []))
putVecex-vxs3 = is-true

{-
dependent pair type - aka Σ type

aka Σ type because can be seen as sum (or disjoint union) of all the types B x
- where 1st component is viewed as a label indicating
  which type of the family the 2nd belong to

generalization of pair type A × B
- where type of 2nd component can be different depending on value of 1st
- e.g.,                   Σ Nat (Vec Bool)
        (or equivalently, Σ Nat (λn → Vec Bool n))
 contains elements
        2 , (true :: false :: [])
 and
        0 , []
 but not
        2 , [] (since [] does not have type Vec Bool 2).
-}

--               function
--                  v
data Σ (A : Set) (B : A → Set) : Set where
  _,_ : (x : A) → B x → Σ A B

-- see Σ as generalization of normal pair : normal pair ignores its input
_×'_ : (A B : Set) → Set
A ×' B = Σ A (λ _ → B)

-- ex 2.5
×-to-×' : {A B : Set} → (A × B) → (A ×' B)
×-to-×' (a , b) =  a , b

×'-to-× : {A B : Set} → (A ×' B) → (A × B)
×'-to-× (a , b) =  a , b

-- Σ USE CASE : hide type info

-- e.g., hide length of vector

List' : (A : Set) → Set
List' A = Σ Nat (Vec A)

-- ex 2.6
list-to-vec : {A : Set} → (l : List A) → Vec A (length l)
list-to-vec       []  = []
list-to-vec (x :: xs) = x :: list-to-vec xs

vec-to-list : {A : Set} {n : Nat} → Vec A n → List A
vec-to-list       []  = []
vec-to-list (x :: xs) = x :: vec-to-list xs

list-to-list' : {A : Set} → List A → List' A
list-to-list' l = length l , list-to-vec l

list'-to-list : {A : Set} → List' A → List A
list'-to-list (_ , v) = vec-to-list v

-- if Nat relations existed at this point this function would be very different
lookup-List' : {A : Set} → List' A -> Nat -> Maybe A
lookup-List' (_ ,       [])       _  =  nothing
lookup-List' (_ , (x ::  _))  zero   = just x
lookup-List' (_ , (_ :: xs)) (suc n) = lookup-List' ((list-to-list' (vec-to-list xs))) n

ex-l'xs  : List' Nat
ex-l'xs  = (4 , 0 :: 1 :: 2 :: 3 :: [])

lookup-List'[]0      : IsTrue (lookup-List' (0 , []) 0 =Maybe-Nat nothing)
lookup-List'[]0      = is-true
lookup-List'ex-l'xs0 : IsTrue (lookup-List'  ex-l'xs 0 =Maybe-Nat (just 0))
lookup-List'ex-l'xs0 = is-true
lookup-List'ex-l'xs1 : IsTrue (lookup-List'  ex-l'xs 1 =Maybe-Nat (just 1))
lookup-List'ex-l'xs1 = is-true
lookup-List'ex-l'xs9 : IsTrue (lookup-List'  ex-l'xs 9 =Maybe-Nat nothing)
lookup-List'ex-l'xs9 = is-true

------------------------------------------------------------------------------
-- 3 The Curry-Howard correspondence
-- can interpret logical propositions — such as “P and Q”, “not P”, “P implies Q”, ...
-- as types whose inhabitants are valid proofs of that proposition.

--------------------------------------------------
-- PROPOSITIONAL LOGIC

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

cases : {A B C : Set} → Either A B → (A → C) → (B → C) → C
cases (left  a) fac   _ = fac a
cases (right b) _   fbc = fbc b

cases-left  : IsTrue (cases (left  3) (2 +_) (2 *_) =Nat 5)
cases-left  = is-true
cases-right : IsTrue (cases (right 3) (2 +_) (2 *_) =Nat 6)
cases-right = is-true

{-
-------------------------
TRUTH : true : the proposition that always holds no matter what.
Proving it is straightforward: do not need to provide any assumptions.
Assuming true in a proof does not provide any new information.
'true' corresponds to the unit type
-}

data ⊤ : Set where
  tt : ⊤

{-
-------------------------
FALSITY. the proposition that is never true.
There are no ways to prove it.
Represented by empty type : datatype with no constructors
-}

data ⊥ : Set where

{-
given a proof p of “false” (which can't happen because no constructors)
- “ex falso quodlibet” : “from falsity follows anything”)
- can can get a proof of any proposition
-}
absurd : {A : Set} → ⊥ → A
absurd ()

{-
-------------------------
NEGATION : the type P → ⊥
EQUIVALENCE. “P is equivalent to Q” as (P → Q) × (Q → P)

Propositional logic versus boolean logic.

types ⊤ and ⊥ seem similar to booleans true and false
- true and false are VALUES : can manipulate and return
- ⊤    and and ⊥ are TYPES
  - not possible to check whether a given type ⊤ or ⊥
-}

curryCompose : {P Q R : Set} → (P → Q) × (Q → R) -> (P → R)
curryCompose (f , g) = λ x → g (f x)

-- ex 3.2
if-A-then-B-implies-A : {A B : Set} → A → (B → A)
if-A-then-B-implies-A a = λ _ → a

if-A-and-true-then-A-or-false : {A : Set} → (A × ⊤) → Either A ⊥
if-A-and-true-then-A-or-false (a , ⊤) = left a

uncurry : {A B C : Set} → (A → (B → C)) → (A × B) → C
uncurry f = λ a×b → f (fst a×b) (snd a×b)

ex32x : {A B C : Set} → (A × Either B C) → Either (A × B) (A × C)
ex32x (a , left  b) = left  (a , b)
ex32x (a , right c) = right (a , c)

ex32y : {A B C D : Set} → ((A → C) × (B → D)) → (A × B) → (C × D)
ex32y (ac , bd) (a , b) = ac a , bd b

{-
--------------------------------------------------
-- PREDICATE LOGIC

to prove propositions that say something about a given VALUE or FUNCTION

e.g., 6 is even
      length (map f xs) is equal to length xs for all xs
      there exists a number n such that n + n = 12

Curry-Howard : propositions are types

can define new propositions by defining new data types

e.g.,
-}

--           index
--             v
data IsEven : Nat → Set where
  even-zero :                        IsEven  zero
  even-suc2 : {n : Nat} → IsEven n → IsEven (suc (suc n))

6-is-even : IsEven 6
6-is-even = even-suc2 (even-suc2 (even-suc2 even-zero))

7-is-not-even : IsEven 7 → ⊥
7-is-not-even (even-suc2 (even-suc2 (even-suc2 ())))
--                                             ^   -- absurb pattern as arg

{-
-- useful predicate
-- states that a given Bool is true
data IsTrue : Bool → Set where
  is-true : IsTrue true

_=Nat_ : Nat → Nat → Bool
zero    =Nat  zero   = true
(suc x) =Nat (suc y) = x =Nat y
_       =Nat  _      = false
-}

length-is-3 : IsTrue (length (1 :: 2 :: 3 :: []) =Nat 3)
length-is-3 = is-true

{-
Defining properties as functions.

Can define properties as
- data types, or
- functions that return a value of type Set
e..g.,
-}

IsTrue’ : Bool → Set
IsTrue’ true  = ⊤
IsTrue’ false = ⊥

{-
Function approach often results in proofs that are shorter, but less readable.

Also less general, as some types (e.g., identity type in next section)
can only be defined as a data type.

BEST PRACTICE: use data types (not functions)

--------------------------------------------------
UNIVERSAL QUANTIFICATION : “∀ x of type A, P(x)”

to prove : provide proof of P(v) for EVERY concrete value v : A.

i.e., a function λv → P v

in opposite direction
assume a f of “∀ x of type A, P(x)”
and given a concrete v : A
then can the proof to the case of v to get a proof f v of P(v)

under Curry-Howard, universal quantification corresponds to dependent function
  (x : A) → P x
-}

double : Nat → Nat
double  zero   = zero
double (suc n) = suc (suc (double n))

-- ∀ n : Nat, double n is an even number
-- 'double-is-even' is a dependent function : return TYPE depends on input VALUE
-- pattern matching here is "proof by cases"
-- recursion here is "induction on n"
double-is-even : (n : Nat) → IsEven (double n)
double-is-even  zero   = even-zero
double-is-even (suc m) = even-suc2 (double-is-even m)

n-equals-n : (n : Nat) → IsTrue (n =Nat n)
n-equals-n  zero   = is-true
n-equals-n (suc m) = n-equals-n m

{-
--------------------------------------------------
EXISTENTIAL QUANTIFICATION : “∃ a x : A such that P( x )”

to prove : provide a concrete v : A, and a proof that P(v) holds

i.e. a pair (v : A, P v)

in opposite direction
given proof z of “∃ a x : A such that P( x )”
then extract the witness fst z : A
and the proof snd z : P (fst z)

under Curry-Howard, existential quantification corresponds to the dependent pair type
  Σ A ( λ x → P x ).
-}

-- ∃ an n such that n + n = 12
half-a-dozen : Σ Nat (λ n → IsTrue ((n + n) =Nat 12))
half-a-dozen = 6 , is-true

-- any number n is either 0 or the successor of another number m
-- ∀ n, n is 0
-- or ∃ m such that n is suc m
zero-or-suc : (n : Nat) → Either (IsTrue (n =Nat 0))
                                 (Σ Nat (λ m → IsTrue (n =Nat (suc m))))
zero-or-suc  zero   = left is-true
zero-or-suc (suc m) = right (m , n-equals-n m)

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

Propositional logic                              Type System
------------------------------------------------------------
proposition                  P                   type
proof of a proposition       p : P               program of a type
conjunction                  P × Q               pair type
disjunction                  Either P Q          either type
implication                  P → Q               function type
truth                        ⊤                   unit type
falsity                      ⊥                   empty type
negation                     P → ⊥               function to ⊥
equivalence                  (P → Q) × (Q → P)   pair of two functions
------------------------------------------------------------
Predicate log
universal quantification     (x : A) → P x       dependent function type
existential quantification   Σ A (λ x → P x )    dependent pair type

--------------------------------------------------
-- IDENTITY TYPE : EQUALITY at any type (to avoid =Nat, =Vec-Nat, ...)

Martin-Löf introduced a new type x ≡ y, called the IDENTITY TYPE (NOT FUNCTION)

if x and y are equal, then x ≡ y has a single inhabitant refl
- behaves like the unit type ⊤

if x and y are distinct, then x ≡ y has no constructors
- behaves like the empty type ⊥
-}

data _≡_ {A : Set} : A → A → Set where
  -- ‘reflexivity’
  refl : {x : A} → x ≡ x
infix 4 _≡_
{-# BUILTIN EQUALITY _≡_ #-}

one-plus-one-IsTrue : IsTrue ((1 + 1) =Nat 2)
one-plus-one-IsTrue = is-true

one-plus-one : 1 + 1 ≡ 2
one-plus-one = refl

{-
zero-not-one-not-IsTrue : IsTrue (0 =Nat 1)
zero-not-one-not-IsTrue = {!!}
-}

zero-not-one : 0 ≡ 1 → ⊥
zero-not-one ()

-- prove facts about polymorphic types
id-returns-input : {A : Set}
                 → (x : A)
                 → id x ≡ x
id-returns-input _ = refl

-- unit tests using identity type
length-test1 : length (1 :: 2 :: []) ≡ 2
length-test1 = refl

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

-- transitivity of equality
trans : {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

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

{-
If a and b can be unified by instantiating some of the variables, then can match on refl.
If a and b are different (e.g. different constructors), then match on absurb pattern ().
Agda canNOT always tell if they are different.
-}

------------------------------------------------------------------------------
-- 4 EQUATIONAL REASONING

begin_ : {A : Set} → {x y : A} → x ≡ y → x ≡ y
begin p = p

_end : {A : Set} → (x : A) → x ≡ x
x end = refl

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

_=⟨⟩_  : {A : Set} → (x : A) → {y   : A} → x ≡ y         → x ≡ y
x =⟨⟩ q = x =⟨ refl ⟩ q

infix 1 begin_
infix 3 _end
infixr 2 _=⟨_⟩_
infixr 2 _=⟨⟩_

-- create singleton list
[_] : {A : Set} → A → List A
[ x ] = x :: []

reverse : {A : Set} → List A → List A
reverse       []  = []
reverse (x :: xs) = reverse xs ++ [ x ]

-- reverse has no effect on singleton lists
reverse-singleton : {A : Set}
                  → (x : A)
                  → reverse [ x ] ≡ [ x ]
reverse-singleton x =
  begin
  reverse       [ x ]  =⟨⟩ -- definition of [_]
  reverse   (x :: [])  =⟨⟩ -- applying reverse (second clause)
  reverse [] ++ [ x ]  =⟨⟩ -- applying reverse (first clause)
          [] ++ [ x ]  =⟨⟩ -- applying _++_
                [ x ]
  end

-- proof by cases and induction
not-not : (b : Bool)
        → not (not b) ≡ b

not-not true  =
  begin
  not (not true) =⟨⟩
       not false =⟨⟩ -- apply inner not
           true      -- apply not
  end

not-not false =
  begin
  not (not false) =⟨⟩
       not true   =⟨⟩
           false
  end

-- prove fact about Nat by induction (i.e., recursion)
add-n-zero : (n : Nat)
           → n + zero ≡ n
add-n-zero  zero   =
  begin
  zero + zero =⟨⟩
  zero        =⟨⟩
  zero
  end

add-n-zero (suc n) =
  begin
  (suc n) + zero  =⟨⟩                          -- applying +
  suc (n  + zero) =⟨ cong suc (add-n-zero n) ⟩ -- using induction hypothesis
  suc n
  end

add-n-zero' : (n : Nat)
            → n + zero ≡ n
add-n-zero'  zero   = refl
add-n-zero' (suc n) = cong suc (add-n-zero' n)

add-assoc : (x y z : Nat)
          → x + (y + z) ≡ (x + y) + z
add-assoc zero y z =
  begin
  zero + (y + z) =⟨⟩ -- def of +
          y + z  =⟨⟩ -- unapply +
  (zero + y) + z
  end
add-assoc (suc x) y z =
  begin
     (suc   x) + (y   + z)  =⟨⟩ -- def of +
      suc  (x  + (y   + z)) =⟨ cong suc (add-assoc x y z) ⟩ -- inductive hypo
      suc ((x  +  y)  + z)  =⟨⟩ -- unapply outer add
     (suc  (x  +  y)) + z   =⟨⟩ -- unapply inner add
    ((suc   x) +  y)  + z
  end

-- ex 4.1
add-suc : (m n : Nat)
        → m + suc n ≡ suc (m + n)
add-suc zero n    =
  begin
  zero + suc n =⟨⟩ -- def of +
         suc n =⟨⟩
  suc (zero + n)
  end
add-suc (suc m) n = -- cong suc (add-suc m n)
  begin
  suc m + suc n    =⟨⟩ -- def of +
  suc (m + suc n)  =⟨ cong suc (add-suc m n) ⟩
  suc (suc m + n)
  end

--use add-suc and add-n-zero
+-comm : (m n : Nat)
       → m + n ≡ n + m
+-comm zero n = sym (add-n-zero n)
+-comm (suc m) n
  rewrite                 -- suc  m     +     n  ≡ n + suc m
                          -- suc (m     +     n) ≡ n + suc m
    +-comm m n            -- suc (n     +     m) ≡ n + suc m
  | sym (add-suc n m)     --      n     + suc m  ≡ n + suc m
  = refl

+-comm' : (m n : Nat)
        → m + n ≡ n + m
+-comm' zero n =
  begin
  zero + n =⟨⟩                     -- def of +
         n =⟨ sym (add-n-zero n) ⟩ -- add zero to right
  n + zero
  end
+-comm' (suc m) n =
  begin
  suc  m     +     n  =⟨⟩ -- def of +
  suc (m     +     n) =⟨ cong suc (+-comm m n) ⟩
  suc (n     +     m) =⟨ sym (add-suc n m) ⟩
       n     + suc m
  end

--------------------------------------------------
-- induction on lists

-- ex 4.2
replicate : {A : Set} → Nat → A → List A
replicate  zero   x = []
replicate (suc n) x = x :: replicate n x

length-replicate : {A : Set} {a : A}
                 → (n : Nat)
                 → length (replicate n a) ≡ n
length-replicate  zero   = refl
length-replicate (suc n) = cong suc (length-replicate n)

-- ex 4.3
append-[] : {A : Set}
          → (xs : List A)
          → xs ++ [] ≡ xs
append-[]       []  = refl
append-[] (x :: xs) = cong (x ::_) (append-[] xs)

append-assoc : {A : Set}
             → (xs ys zs : List A)
             → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
append-assoc       []  ys zs = refl
append-assoc (x :: xs) ys zs -- (((x ::   xs) ++ ys) ++ zs) ≡ ((x ::  xs) ++ (ys ++ zs))
                             --    x :: ((xs  ++ ys) ++ zs) ≡   x :: (xs  ++ (ys ++ zs))
  = cong (x ::_) (append-assoc xs ys zs)

reverse-distributivity : {A : Set}
                       → (xs ys : List A)
                       → reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-distributivity       []  ys = sym (append-[] (reverse ys))
reverse-distributivity (x :: xs) ys
                   -- reverse ((x :: xs) ++ ys)         ≡ (reverse ys ++  reverse       (x :: xs))
                   -- (reverse (xs ++ ys) ++ (x :: [])) ≡ (reverse ys ++ (reverse xs ++ (x :: [])))
  rewrite
    reverse-distributivity xs ys
                   -- ((reverse ys ++ reverse xs) ++ (x :: []))
                   --                                   ≡ (reverse ys ++ (reverse xs ++ (x :: [])))
  | sym (append-assoc (reverse ys) (reverse xs) (x :: []))
  = refl

reverse-reverse : {A : Set}
                → (xs : List A)
                → reverse (reverse xs) ≡ xs
reverse-reverse       [] = refl
reverse-reverse (x :: xs) -- reverse (reverse (x :: xs))       ≡ x :: xs
                          -- reverse (reverse xs ++ (x :: [])) ≡ x :: xs
  rewrite
    --                       NOTE
    --                        v
    reverse-distributivity (reverse xs) [ x ]
                          --         x :: reverse (reverse xs) ≡ x :: xs
-- can rewrite here then refl
--| reverse-reverse xs    --                          x :: xs  ≡ x :: xs
--= refl
-- or use 'cong' on rightof '='
  = cong (x ::_) (reverse-reverse xs)

{-
map satisfies functor laws:
- identity    : map id      = id
- composition : map (g . h) = map g . h
-}

map-id : {A : Set}
       → (xs : List A)
       → map id xs ≡ xs
map-id       []  = refl
map-id (x :: xs) --         map id (x :: xs) ≡ x :: xs
                 -- id x :: map id       xs  ≡ x :: xs
  = cong (x ::_) (map-id xs)

_◦_ : {A B C : Set} → (B → C) → (A → B) → (A → C)
g ◦ h = λ x → g (h x)

map-compose : {A B C : Set}
            → (f : B → C) → (g : A → B) → (xs : List A)
            → map (f ◦ g) xs ≡ map f (map g xs)
map-compose f g       [] = refl
map-compose f g (x :: xs)
                         --              map (f ◦ g) (x :: xs) ≡            map f (map g (x :: xs))
                         -- (f ◦ g) x :: map (f ◦ g)       xs  ≡ f (g x) :: map f (map g       xs)
{- this
  rewrite
    sym (map-compose f g xs)
                         --   f (g x) :: map (λ x₁ → f (g x₁)) xs ≡
                              f (g x) :: map (λ x₁ → f (g x₁)) xs
  = refl
-}
  -- or this
  = cong (f (g x) ::_) (map-compose f g xs)

-- ex 4.4
length-map : {A B : Set} {f : A → B}
           → (xs : List A)
           → length (map f xs) ≡ length xs
length-map       []  = refl
length-map (x :: xs) --      length (map f (x :: xs)) ≡      length (x :: xs)
                     -- suc (length (map f       xs)) ≡ suc (length       xs)
  = cong suc (length-map xs)

-- ex 4.5
take : {A : Set} → List A → Nat → List A
take        _   zero   = []
take       []  (suc n) = []
take (x :: xs) (suc n) = x :: take xs n

take-0 : take ex-xs 0 ≡ []
take-0 = refl
take-1 : take ex-xs 1 ≡ 0 :: []
take-1 = refl
take-2 : take ex-xs 2 ≡ 0 :: 1 :: []
take-2 = refl
take-3 : take ex-xs 3 ≡ 0 :: 1 :: 2 :: []
take-3 = refl
take-4 : take ex-xs 4 ≡ ex-xs
take-4 = refl
take-5 : take ex-xs 5 ≡ ex-xs
take-5 = refl

drop : {A : Set} → List A → Nat → List A
drop       xs   zero   = xs
drop       []  (suc x) = []
drop (_ :: xs) (suc n) = drop xs n

drop-0 : drop ex-xs 0 ≡ ex-xs
drop-0 = refl
drop-1 : drop ex-xs 1 ≡ 1 :: 2 :: 3 :: []
drop-1 = refl
drop-2 : drop ex-xs 2 ≡      2 :: 3 :: []
drop-2 = refl
drop-3 : drop ex-xs 3 ≡           3 :: []
drop-3 = refl
drop-4 : drop ex-xs 4 ≡                []
drop-4 = refl
drop-5 : drop ex-xs 5 ≡                []
drop-5 = refl

take-drop : {A : Set} → (xs : List A) → (n : Nat) → take xs n ++ drop xs n ≡ xs
take-drop       []   zero   = refl
take-drop       []  (suc n) = refl
take-drop (x :: xs)  zero   = refl
take-drop (x :: xs) (suc n) --      (take (x :: xs) (suc n) ++ drop (x :: xs) (suc n)) ≡ x :: xs
                            -- x :: (take       xs       n  ++ drop       xs       n)  ≡ x :: xs
  = cong (x ::_) (take-drop xs n)

--------------------------------------------------
-- verifying optimizations

-- list optimization

reverse-acc : {A : Set} → List A → List A → List A
reverse-acc       []  ys = ys
reverse-acc (x :: xs) ys = reverse-acc xs (x :: ys)

reverse' : {A : Set} → List A → List A
reverse' xs = reverse-acc xs []

reverse-acc-lemma : {A : Set}
                  → (xs ys : List A)
                  → reverse-acc xs ys ≡ reverse xs ++ ys
reverse-acc-lemma       []   _ = refl
reverse-acc-lemma (x :: xs) ys   -- reverse-acc (x :: xs) ys  ≡  (reverse (x :: xs)        ++ ys)
                                 -- reverse-acc xs (x :: ys)  ≡ ((reverse xs ++ (x :: [])) ++ ys)
  rewrite
    append-assoc (reverse xs) [ x ] ys
                                 -- reverse-acc xs (x :: ys)  ≡ (reverse xs ++ (x :: ys))
  | reverse-acc-lemma xs (x :: ys)
                                 -- (reverse xs ++ (x :: ys)) ≡ (reverse xs ++ (x :: ys))
  = refl

reverse'-reverse : {A : Set}
                 → (xs : List A)
                 → reverse' xs ≡ reverse xs
reverse'-reverse       []  = refl
reverse'-reverse (x :: xs)     --  reverse' (x :: xs)       ≡  reverse (x :: xs)
                               --  reverse' (x :: xs)       ≡ (reverse xs ++ (x :: []))
  rewrite
    reverse-acc-lemma xs [ x ] -- (reverse xs ++ (x :: [])) ≡ (reverse xs ++ (x :: []))
  = refl

-- tree optimization

data Tree (A : Set) : Set where
  leaf : A               → Tree A
  node : Tree A → Tree A → Tree A

flatten : {A : Set} → Tree A → List A
flatten (leaf a)     = [ a ]
flatten (node t1 t2) = flatten t1 ++ flatten t2

flatten-acc : {A : Set} → Tree A → List A → List A
flatten-acc (leaf x)     xs = x :: xs
flatten-acc (node t1 t2) xs = flatten-acc t1 (flatten-acc t2 xs)

flatten' : {A : Set} → Tree A → List A
flatten' t = flatten-acc t []

flatten-acc-lemma : {A : Set}
                  → (t : Tree A) → (ys : List A)
                  → flatten-acc t ys ≡ flatten t ++ ys
flatten-acc-lemma (leaf x)    _ = refl
flatten-acc-lemma (node t1 t2) ys
                     --  flatten-acc (node t1 t2) ys         ≡  (flatten (node t1 t2)      ++ ys)
                     --  flatten-acc t1 (flatten-acc t2 ys)  ≡ ((flatten t1 ++ flatten t2) ++ ys)
  rewrite
    flatten-acc-lemma t1 (flatten-acc t2 ys)
                     -- (flatten t1 ++   flatten-acc t2 ys)  ≡ ((flatten t1 ++ flatten t2) ++ ys)
  | flatten-acc-lemma t2 ys
                     -- (flatten t1 ++  (flatten t2 ++  ys)) ≡ ((flatten t1 ++ flatten t2) ++ ys)
  | append-assoc (flatten t1) (flatten t2) ys
                     -- (flatten t1 ++  (flatten t2 ++  ys)) ≡  (flatten t1 ++ (flatten t2 ++ ys))
  = refl

flatten-acc-flatten : {A : Set}
                    → (t : Tree A) → (ys : List A)
                    → flatten-acc t ys ≡ flatten t ++ ys
flatten-acc-flatten (leaf x)     ys = refl
                      --  flatten-acc (leaf x)           ys   ≡  (flatten (leaf x)          ++ ys)
flatten-acc-flatten (node t1 t2) ys
                      --  flatten-acc (node t1 t2)       ys   ≡  (flatten (node t1 t2)      ++ ys)
                      --  flatten-acc t1 (flatten-acc t2 ys)  ≡ ((flatten t1 ++ flatten t2) ++ ys)
  rewrite
    flatten-acc-lemma t2 ys
                      --  flatten-acc t1 (flatten t2 ++  ys)  ≡ ((flatten t1 ++ flatten t2) ++ ys)
  | flatten-acc-lemma t1 (flatten t2 ++ ys)
                      -- (flatten t1 ++  (flatten t2 ++  ys)) ≡ ((flatten t1 ++ flatten t2) ++ ys)

  | append-assoc (flatten t1) (flatten t2) ys
                      -- (flatten t1 ++  (flatten t2 ++  ys)) ≡  (flatten t1 ++ (flatten t2 ++ ys))
  = refl

-- ex 4.6
flatten'-flatten : {A : Set}
                 → (t : Tree A)
                 → flatten' t ≡ flatten t
flatten'-flatten (leaf x)     = refl
flatten'-flatten (node t1 t2)
                    -- flatten' (node t1 t2)              ≡  flatten (node t1 t2)
                    -- flatten' (node t1 t2)              ≡ (flatten t1 ++ flatten t2)
  rewrite
    sym (flatten-acc-flatten t1 (flatten t2))
                    -- flatten-acc t1 (flatten-acc t2 []) ≡ flatten-acc t1 (flatten t2)
  | flatten-acc-flatten t2 []
                    -- flatten-acc t1 (flatten t2 ++  []) ≡ flatten-acc t1 (flatten t2)
  | append-[] (flatten t2)
                    -- flatten-acc t1 (flatten t2)        ≡ flatten-acc t1 (flatten t2)
  = refl

--------------------------------------------------
-- compiler correctness

data Expr : Set where
  valE : Nat  →        Expr
  addE : Expr → Expr → Expr

eval : Expr → Nat
eval (valE x)     = x
eval (addE e1 e2) = eval e1 + eval e2

data Op : Set where
  PUSH : Nat → Op
  ADD  : Op

Stack = List Nat
Code  = List Op

exec : Code → Stack → Stack
exec []                       s  = s
exec (PUSH x :: c)            s  = exec c (x :: s)
exec (ADD :: c)    (m :: n :: s) = exec c (n + m :: s)
exec (ADD :: c)               _  = []

compile' : Expr → Code → Code
compile' (valE x) c = PUSH x :: c
compile' (addE e1 e2) c = compile' e1 (compile' e2 (ADD :: c))

compile : Expr → Code
compile e = compile' e []

compile'-exec-eval : (e : Expr) → (s : Stack) → (c : Code)
                   → exec (compile' e c) s ≡ exec c (eval e :: s)
compile'-exec-eval (valE _)     _ _ = refl
compile'-exec-eval (addE e1 e2) s c
        -- exec (compile' (addE e1 e2) c)              s ≡ exec c (eval (addE e1 e2) :: s)
        -- exec (compile' e1 (compile' e2 (ADD :: c))) s ≡ exec c (eval e1 + eval e2 :: s)
  rewrite
    compile'-exec-eval e1 s (compile' e2 (ADD :: c))
        -- exec (compile' e2 (ADD :: c)) (eval e1 :: s)  ≡ exec c (eval e1 + eval e2 :: s)
  | compile'-exec-eval e2 (eval e1 :: s) (ADD :: c)
        -- exec c (eval e1 + eval e2 :: s)               ≡ exec c (eval e1 + eval e2 :: s)
  = refl

compile-exec-eval : (e : Expr) → exec (compile e) [] ≡ [ eval e ]
compile-exec-eval e = compile'-exec-eval e [] []


module my-nat where

open import product
open import bool
open import eq

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

{-# BUILTIN NATURAL ℕ #-}

infixl 10 _*_
infixl 9 _+_
--infixl 8 _<_ _=ℕ_ _≤_ _>_ _≥_

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

0+ : ∀ (x : ℕ) → 0 + x ≡ x
0+ x = refl

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

+assoc : ∀ (x y z : ℕ) → x + (y + z) ≡ (x + y) + z
+assoc zero y z = refl
+assoc (suc x) y z rewrite +assoc x y z = refl

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

+comm : ∀ (x y : ℕ) → x + y ≡ y + x
+comm zero y rewrite +0 y = refl
+comm (suc x) y rewrite +suc y x | +comm x y = refl

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

*distribr : ∀ (x y z : ℕ) → (x + y) * z ≡ x * z + y * z
--*distribr : ∀ (x y z : ℕ) → (x + y) * z ≡ x * z + y * z
*distribr zero y z = refl
*distribr (suc x) y z rewrite *distribr x y z = +assoc z (x * z) (y * z)

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

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

*comm : ∀ (x y : ℕ) → x * y ≡ y * x
*comm zero y rewrite *0 y = refl
*comm (suc x) y rewrite *suc y x | *comm x y = refl

*assoc : ∀ (x y z : ℕ) → x * (y * z) ≡ (x * y) * z
*assoc zero y z = refl
*assoc (suc x) y z rewrite *distribr y (x * y) z
                           | *assoc x y z = refl

_<_ : ℕ → ℕ → 𝔹
0 < 0 = ff
0 < (suc y) = tt
(suc x) < (suc y) = x < y
(suc x) < 0 = ff

_=ℕ_ : ℕ → ℕ → 𝔹
0 =ℕ 0 = tt
suc x =ℕ suc y = x =ℕ y
_ =ℕ _ = ff

=ℕ-refl : ∀ (x : ℕ) → (x =ℕ x) ≡ tt
=ℕ-refl zero = refl
=ℕ-refl (suc x) = =ℕ-refl x

=ℕ-to-≡ : ∀ {x y : ℕ} → x =ℕ y ≡ tt → x ≡ y
=ℕ-to-≡ {zero} {zero} u = refl
=ℕ-to-≡ {zero} {suc y} ()
=ℕ-to-≡ {suc x} {zero} ()
=ℕ-to-≡ {suc x} {suc y} u rewrite =ℕ-to-≡ {x} {y} u = refl

=ℕ-from-≡ : ∀ {x y : ℕ} → x ≡ y → x =ℕ y ≡ tt
=ℕ-from-≡ {x} {.x} refl = =ℕ-refl x

is-even : ℕ → 𝔹
is-odd : ℕ → 𝔹
is-even 0 = tt
is-even (suc x) = is-odd x
is-odd 0 = ff
is-odd (suc x) = is-even x

even~odd : ∀ (x : ℕ) → is-even x ≡ ~ is-odd x
odd~even : ∀ (x : ℕ) → is-odd x ≡ ~ is-even x
even~odd zero = refl
even~odd (suc x) = odd~even x
odd~even zero = refl
odd~even (suc x) = even~odd x


module Numeral.Natural.Oper.Divisibility where

import      Lvl
open import Data
open import Data.Boolean
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Modulo

-- Divisibility check
_∣?_ : ℕ → ℕ → Bool
𝟎    ∣? _ = 𝐹
𝐒(y) ∣? x = zero?(x mod 𝐒(y))

-- Divisibility check
_∣₀?_ : ℕ → ℕ → Bool
𝟎 ∣₀? 𝟎    = 𝑇
𝟎 ∣₀? 𝐒(_) = 𝐹
𝐒(y) ∣₀? x = zero?(x mod 𝐒(y))

{-
open import Numeral.Natural.Oper
open import Numeral.Natural.UnclosedOper
open import Data.Option as Option using (Option)

{-# TERMINATING #-}
_∣?_ : ℕ → ℕ → Bool
_    ∣? 𝟎    = 𝑇
𝟎    ∣? 𝐒(_) = 𝐹
𝐒(x) ∣? 𝐒(y) with (x −? y)
... | Option.Some(xy) = xy ∣? 𝐒(y)
... | Option.None     = 𝐹
-}


module Data.List.First.Properties {ℓ}{A : Set ℓ} where

open import Data.Product
open import Data.List
open import Data.List.Any
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Empty
open import Data.List.First
open import Data.List.Membership.Propositional

first⟶∈ : ∀ {B : A → Set} {x l} → First B x l → (x ∈ l × B x)
first⟶∈ (here {x = x} p) = here refl , p
first⟶∈ (there x' ¬px f) with (first⟶∈ f)
first⟶∈ (there x' ¬px f) | x∈l , p = there x∈l , p

first-unique : ∀ {P : A → Set}{x y v} → First P x v → First P y v → x ≡ y
first-unique (here x) (here y) = refl
first-unique (here {x = x} px) (there .x ¬px r) = ⊥-elim (¬px px)
first-unique (there x ¬px l) (here {x = .x} px) = ⊥-elim (¬px px)
first-unique (there x' _ l) (there .x' _ r) = first-unique l r


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

open import Categories.Category.Core
open import Categories.Object.Terminal hiding (up-to-iso)

module Categories.Object.NaturalNumber {o ℓ e} (𝒞 : Category o ℓ e) (𝒞-Terminal : Terminal 𝒞) where

open import Level

open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞

open Category 𝒞
open HomReasoning
open Equiv

open Terminal 𝒞-Terminal

private
  variable
    A B C D X Y Z : Obj
    h i j : A ⇒ B

record IsNaturalNumber (N : Obj) : Set (o ⊔ ℓ ⊔ e) where
  field
    z : ⊤ ⇒ N
    s : N ⇒ N
    universal : ∀ {A} → ⊤ ⇒ A → A ⇒ A → N ⇒ A
    z-commute : ∀ {A} {q : ⊤ ⇒ A} {f : A ⇒ A} → q ≈ universal q f ∘ z
    s-commute : ∀ {A} {q : ⊤ ⇒ A} {f : A ⇒ A} → f ∘ universal q f ≈ universal q f ∘ s
    unique    : ∀ {A} {q : ⊤ ⇒ A} {f : A ⇒ A} {u : N ⇒ A} → q ≈ u ∘ z → f ∘ u ≈ u ∘ s → u ≈ universal q f

  η : universal z s ≈ id
  η = ⟺ (unique (⟺ identityˡ) id-comm)

  universal-cong : ∀ {A} → {f f′ : ⊤ ⇒ A} → {g g′ : A ⇒ A} → f ≈ f′ → g ≈ g′ → universal f g ≈ universal f′ g′
  universal-cong f≈f′ g≈g′ = unique (⟺ f≈f′ ○  z-commute) (∘-resp-≈ˡ (⟺ g≈g′) ○ s-commute)

record NaturalNumber : Set (o ⊔ ℓ ⊔ e) where
  field
    N : Obj
    isNaturalNumber : IsNaturalNumber N

  open IsNaturalNumber isNaturalNumber public

open NaturalNumber

module _ (N : NaturalNumber) (N′ : NaturalNumber) where
  private
    module N = NaturalNumber N
    module N′ = NaturalNumber N′

  up-to-iso : N.N ≅ N′.N
  up-to-iso = record
    { from = N.universal N′.z N′.s
    ; to = N′.universal N.z N.s
    ; iso = record
      { isoˡ = universal-∘ N N′
      ; isoʳ = universal-∘ N′ N
      }
    }
    where
      universal-∘ : ∀ (N N′ : NaturalNumber) → universal N′ (z N) (s N) ∘ universal N (z N′) (s N′) ≈ id
      universal-∘ N N′ = unique N (z-commute N′ ○ pushʳ (z-commute N)) (pullˡ (s-commute N′) ○ assoc ○ ∘-resp-≈ʳ (s-commute N) ○ ⟺ assoc) ○ (η N)


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

module Ch2-1 where

open import Level

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Relation.Binary

isEquivalence : ∀ {a} {A : Set a} → IsEquivalence (_≡_ {a} {A})
isEquivalence = record
  { refl = refl
  ; sym = ¬_
  ; trans = _∙_
  }

setoid : ∀ {a} → Set a → Setoid _ _
setoid {a} A = record
  { Carrier       = A
  ; _≈_           = _≡_
  ; isEquivalence = isEquivalence {a} {A}
  }
-- module EckmannHilton where
--
--     -- begin
--     --   p ∙ refl
--     -- ≈⟨ ¬ ∙-identityʳ p ⟩
--     --   p
--     -- ≈⟨ α ⟩
--     --   q
--     -- ≈⟨ ∙-identityʳ q ⟩
--     --   q ∙ refl
--     -- ∎
--     -- where
--     --   open import Relation.Binary.Reasoning.Setoid (setoid (a ≡ x))
--
--   -- whisker right
--   infixl 6 _∙r_
--   _∙r_ : {A : Set} {a b c : A} {p q : a ≡ b}
--     → (α : p ≡ q) (r : b ≡ c)
--     → p ∙ r ≡ q ∙ r
--   _∙r_ {A} {a} {b} {c} {p} {q} α r = J A D d b c r a p q α
--     where
--       -- the predicate
--       D : (b c : A) (r : b ≡ c) → Set
--       D b c r = (a : A) (p q : a ≡ b) (α : p ≡ q)
--         → p ∙ r ≡ q ∙ r
--
--       -- base case
--       d : (x : A) → D x x refl
--       d x a p q α = J A E e a x p q
--         where
--           -- the predicate
--           E : (a x : A) (p : a ≡ x) → Set
--           E a x p = (q : a ≡ x) → p ∙ refl ≡ q ∙ refl
--
--           -- base case
--           e : (x : A) → E x x refl
--           e x q = {!   !}
--             where
--               -- the predicate
--               F : (a x : A) (q : a ≡ x) → Set
--               F a x q = {!   !}
--                 -- refl ∙ refl ≡ q ∙ refl
--                 -- refl ∙ refl ≡ q ∙ refl
--
--               -- base case
--               f : (x : A) → F x x refl
--               f x = {!   !}
--         --
--         -- ¬ ∙-identityʳ p ∙ α ∙ ∙-identityʳ q
--   --
--   --
--   -- -- whisker left
--   -- infixl 6 _∙l_
--   -- _∙l_ : {A : Set} {a b c : A} {r s : b ≡ c}
--   --   → (q : a ≡ b) (β : r ≡ s)
--   --   → q ∙ r ≡ q ∙ s
--   -- _∙l_ {A} {a} {b} {c} {r} {s} q β = J A D d a b q c r s β
--   --   where
--   --     -- the predicate
--   --     D : (a b : A) (q : a ≡ b) → Set
--   --     D a b q = (c : A) (r s : b ≡ c) (β : r ≡ s)
--   --       → q ∙ r ≡ q ∙ s
--   --
--   --     -- base case
--   --     d : (x : A) → D x x refl
--   --     d x c r s β = ¬ ∙-identityˡ r ∙ β ∙ ∙-identityˡ s
--   --
--   -- -- horizontal composition
--   -- _⋆_ : {A : Set} {a b c : A} {p q : a ≡ b} {r s : b ≡ c}
--   --   → (α : p ≡ q) (β : r ≡ s)
--   --   → p ∙ r ≡ q ∙ s
--   -- _⋆_ {A} {a} {b} {c} {p} {q} {r} {s} α β = (α ∙r r) ∙ (q ∙l β)
--   --
--   --   where
--   --     whisker-right-lemma : ∀ {A : Set} {a b : A}
--   --       → {p q : a ≡ b} {α : p ≡ q}
--   --       → α ∙r refl ≡ ¬ ∙-identityʳ p ∙ α ∙ ∙-identityʳ q
--   --     whisker-right-lemma {A} {a} {b} {p} {q} {α} = refl
--   --
--   --     whisker-left-lemma : ∀ {A : Set} {b c : A}
--   --       → {r s : b ≡ c} {β : r ≡ s}
--   --       → refl ∙l β ≡ ¬ ∙-identityˡ r ∙ β ∙ ∙-identityˡ s
--   --     whisker-left-lemma {A} {b} {c} {r} {s} {α} = refl
--   --
--   -- cong : {A B : Set} {x y : A}
--   --   → (f : A → B) (p : x ≡ y)
--   --   → f x ≡ f y
--   -- cong {A} {B} {x} {y} f p = J A D d x y p f
--   --   where
--   --     -- the predicate
--   --     D : (x y : A) (p : x ≡ y) → Set
--   --     D x y p = (f : A → B) → f x ≡ f y
--   --
--   --     -- base case
--   --     d : (x : A) → D x x refl
--   --     d x f = refl
--   --
--   -- cong2 : {A B C : Set} {x y : A} {a b : B}
--   --   → (f : A → B → C) (p : x ≡ y) (q : a ≡ b)
--   --   → f x a ≡ f y b
--   -- cong2 {A} {B} {C} {x} {y} {a} {b} f p q = J A D d x y p a b q f
--   --   -- J A D d x y p f
--   --   where
--   --     -- the predicate
--   --     D : (x y : A) (p : x ≡ y) → Set
--   --     D x y p = (a b : B) (q : a ≡ b) (f : A → B → C) → f x a ≡ f y b
--   --
--   --     -- base case
--   --     d : (x : A) → D x x refl
--   --     d x a b q f = cong (f x) q
--   --
--   --
--   -- -- theorem : {A : Set} {a b c : A}
--   -- --   → {p q : a ≡ b} {r s : b ≡ c}
--   -- --   → (α : p ≡ q) (β : r ≡ s)
--   -- --   → α ⋆ β ≡ cong2 _∙_ α β
--   -- -- theorem {A} {a} {b} {c} {p} {q} {r} {s} α β = J A D d a b p q c r s α β
--   -- --
--   -- --   where
--   -- --     -- the predicate
--   -- --     D : (a b : A) (p : a ≡ b) → Set
--   -- --     D a b p = (q : a ≡ b) (c : A) (r s : b ≡ c) (α : p ≡ q) (β : r ≡ s)
--   -- --       → α ⋆ β ≡ cong2 _∙_ α β
--   -- --
--   -- --     -- base case ʳˡ
--   -- --     d : (x : A) → D x x refl
--   -- --     d x q c r s α β = J A E e x c r s q α β
--   -- --
--   -- --       where
--   -- --         -- the predicate
--   -- --         E : (b c : A) (r : b ≡ c) → Set
--   -- --         E b c r = (s : b ≡ c) (q : b ≡ b) (α : refl ≡ q) (β : r ≡ s)
--   -- --           → α ⋆ β ≡ cong2 _∙_ α β
--   -- --
--   -- --         -- base case
--   -- --         e : (x : A) → E x x refl
--   -- --         e x s q α β = {!   !}


module Lectures.One where

-- Check background color
-- Check fontsize
-- Ask questions at *any* time

data ⊤ : Set where
  tt : ⊤

data ⊥ : Set where

absurd : ⊥ → {P : Set} → P
absurd ()

-- Introduce most common key bindings
-- C-c C-l     load
-- C-c C-,     show context
-- C-c C-.     show context + type
-- C-c C-SPACE input
-- C-c C-A     auto
-- C-c C-r     refine
-- C-c C-d     type inference
-- C-c C-c     pattern match

-- Briefly introduce syntax
-- Introduce Set 0

modus-ponens : {P Q : Set} → P → (P → Q) → Q
modus-ponens p f = f p

-- Introduce misfix operators

¬_ : Set → Set
¬ P = P → ⊥

contra-elim : {P : Set} → P → ¬ P → ⊥
contra-elim = modus-ponens

-- no-dne : {P : Set} → ¬ ¬ P → P
-- no-dne ¬¬P = {!!}

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

{-# BUILTIN NATURAL ℕ #-}

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

_isEven : ℕ → Set
zero isEven = ⊤
suc zero isEven = ⊥
suc (suc n) isEven = n isEven

half : (n : ℕ) → n isEven → ℕ
half zero tt = zero
half (suc (suc n)) p = suc (half n p)

_ : ℕ
_ = half 8 tt

-- Comment on termination checking

-- brexit : ⊥
-- brexit = brexit


------------------------------------------------------------------------
-- One form of induction for natural numbers
------------------------------------------------------------------------

-- I want universe polymorphism.

module Induction1.Nat where

open import Data.Nat
import Induction1.WellFounded as WF

------------------------------------------------------------------------
-- Complete induction based on <′

open WF _<′_ using (Acc; acc)

allAcc : ∀ n → Acc n
allAcc n = acc (helper n)
  where
  helper : ∀ n m → m <′ n → Acc m
  helper zero     _ ()
  helper (suc n) .n ≤′-refl        = acc (helper n)
  helper (suc n)  m (≤′-step m<′n) = helper n m m<′n

open WF _<′_ public using () renaming (WfRec to <-Rec)
open WF.All _<′_ allAcc public
  renaming ( wfRec-builder to <-rec-builder
           ; wfRec to <-rec
           )


module Logic where

-- The true proposition.
data ⊤ : Set where
  obvious : ⊤ -- The proof of truth.

-- The false proposition.
data ⊥ : Set where
  -- There is nothing here so one can never prove false.

-- The AND of two statments.
data _∧_ (A B : Set)  : Set where
  -- The only way to construct a proof of A ∧ B is by pairing a a
  -- proof of A with a proof of and B.
  ⟨_,_⟩ : (a : A)  -- Proof of A
        → (b : B)  -- Proof of B
        → A ∧ B    -- Proof of A ∧ B

-- The OR of two statements.
data _∨_ (A B : Set) : Set where
  -- There are two ways of constructing a proof of A ∨ B.
  inl : (a : A) →  A ∨ B   -- From a proof of A by left introduction
  inr : (b : B) →  A ∨ B   -- From a proof of B by right introduction

-- The not of statement A
¬_ : (A : Set) → Set
¬ A = A → ⊥  -- Given a proof of A one should be able to get a proof
             -- of ⊥.

-- The statement A ↔ B are equivalent.
_↔_ : (A B : Set) → Set
A ↔ B = (A → B) -- If
           ∧    -- and
        (B → A) -- only if

infixr 1 _∧_
infixr 1 _∨_
infixr 0 _↔_
infix  2 ¬_

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

-- Double negation
doubleNegation : ∀ {A : Set} → A → ¬ (¬ A)
doubleNegation a negNegA = negNegA a

{-

doubleNegation' : ∀ {A : Set} → ¬ ( ¬ (¬ A)) → ¬ A

-}

deMorgan1 : ∀ (A B : Set) → ¬ (A ∨ B) → ¬ A ∧ ¬ B
deMorgan1 A B notAorB = ⟨ notAorB ∘ inl , notAorB ∘ inr ⟩

deMorgan2 : ∀ (A B : Set) → ¬ A ∧ ¬ B → ¬ (A ∨ B)
deMorgan2 A B ⟨ notA , notB ⟩ (inl a) = notA a
deMorgan2 A B ⟨ notA , notB ⟩ (inr b) = notB b

deMorgan : ∀ (A B : Set) → ¬ (A ∨ B) ↔ ¬ A ∧ ¬ B
deMorgan A B = ⟨ deMorgan1 A B , deMorgan2 A B ⟩


module W where

open import Function using (_∘_)
open import Data.Bool using (Bool; true; false)
open import Data.Product
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)

data W (S : Set) (P : S → Set) : Set where
    max : (s : S) → (f : P s → W S P) → W S P

-- data ℕ : Set where
--     zero : ℕ             _^0
--     succ : ℕ → ℕ        ∣ℕ∣

ℕ : Set
ℕ = W Bool f
    where   f : Bool → Set
            f true = ⊤ -- 1
            f false = ⊥ -- 0

zero : ℕ
zero = max false ⊥-elim

succ : ℕ → ℕ
succ n = max true (λ _ → n)

_+_ : ℕ → ℕ → ℕ
(max true f) + y = max true (λ _ → f tt + y)
(max false f) + y = y

-- data Tree : Set where
--     leaf : Tree                   _^0
--     node : Tree → Tree → Tree    |ℕ| x |ℕ|

Tree : Set
Tree = W Bool λ { true → Bool ; false → ⊥ }

leaf : Tree
leaf = max false ⊥-elim       -- _^0

node : Tree → Tree → Tree
node l r = max true λ { true → l      -- ∣Tree∣^2
                     ; false → r }

data LW (S : Set) (LP : S → Set × Set) : Set where
     lmax : (s : Σ S (proj₁ ∘ LP)) → (proj₂ (LP (proj₁ s)) → LW S LP) → LW S LP

List : (X : Set) → Set
List X = LW Bool (λ { true → X , ⊤      -- cons
                    ; false → ⊤ , ⊥ })  -- nil

nil : {X : Set} → List X
nil = lmax (false , tt) ⊥-elim

cons : {X : Set} → (x : X) → List X → List X
cons {X} x xs = lmax (true , x) λ _ → xs

-- induction principle on W-types
indW : (S : Set)
     → (P : S → Set)
     → (C : W S P → Set)    --  property
     → (c : (s : S)                     -- given a shape
          → (f : P s → W S P)           -- and a bunch of kids
          → (h : (p : P s) → C (f p))   -- if C holds for all kids
          → C (max s f))                -- C holds for (max s f)
     → (x : W S P)
     → C x
indW S P C step (max s f) = step s f (λ p → {!   !} S P C step (f p))

indℕ : (C : ℕ → Set) → C zero → ((n : ℕ) → C n → C (succ n)) → (x : ℕ) → C x
indℕ C base step (max true f) = step (f tt) (indℕ C base step (f tt))
indℕ C base step (max false f) = {! base  !}


import      Lvl
open import Data.Boolean
open import Type

module Data.List.Sorting {ℓ} {T : Type{ℓ}} (_≤?_ : T → T → Bool) where

open import Functional using (_∘₂_)
open import Data.Boolean.Stmt
open import Data.List
import      Data.List.Relation.Pairwise
open import Data.List.Relation.Permutation
open import Logic

open Data.List.Relation.Pairwise using (empty ; single ; step) public
Sorted = Data.List.Relation.Pairwise.AdjacentlyPairwise(IsTrue ∘₂ (_≤?_))

-- A sorting algorithm is a function that given a list, always return a sorted list which is a permutation of the original one.
record SortingAlgorithm (f : List(T) → List(T)) : Stmt{Lvl.𝐒(ℓ)} where
  constructor intro
  field
    ⦃ sorts ⦄    : ∀{l} → Sorted(f(l))
    ⦃ permutes ⦄ : ∀{l} → (f(l) permutes l)


module examplesPaperJFP.Collatz where

open import Data.Nat.Base
open import Data.Nat.DivMod
open import Data.Fin using (Fin; zero; suc)

open import examplesPaperJFP.Colists

collatzStep            :  ℕ → ListF ℕ ℕ
collatzStep 1          =  nil
collatzStep n          with n divMod 2
... | result q zero _  =  cons n q
... | _                =  cons n (1 + 3 * n)

collatzSequence  :  ℕ → Colist ℕ
collatzSequence  =  unfold collatzStep

open Colist
open import Data.List

displayList : Colist ℕ → ℕ → List ℕ
displayList s 0 = []
displayList s (suc m) with  force s
... | nil = []
... | (cons k s′) =  k ∷ displayList s′ m

displayCollatz : ℕ → ℕ → List ℕ
displayCollatz n m = displayList (collatzSequence n) m