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

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

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

open import Categories.Category.Core using (Category)

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

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

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

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

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

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

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

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

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

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

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


module Lec6Done where

open import Lec1Done

data List (X : Set) : Set where
  []   : List X
  _,-_ : X -> List X -> List X
infixr 4 _,-_

-- ListF : Set -> Set -> Set
-- ListF X T = One + (X * T)

mkList : {X : Set} -> One + (X * List X) -> List X
mkList (inl <>)        = []
mkList (inr (x , xs))  = x ,- xs

foldr : {X T : Set} -> ((One + (X * T)) -> T) -> List X -> T
foldr alg []         = alg (inl <>)
foldr alg (x ,- xs)  = alg (inr (x , foldr alg xs))

ex1 = foldr mkList (1 ,- 2 ,- 3 ,- [])

length : {X : Set} -> List X -> Nat
length = foldr \ { (inl <>) -> zero ; (inr (x , n)) -> suc n }

record CoList (X : Set) : Set where
  coinductive
  field
    force : One + (X * CoList X)
open CoList

[]~ : {X : Set} -> CoList X
force []~ = inl <>

_,~_ : {X : Set} -> X -> CoList X -> CoList X
force (x ,~ xs) = inr (x , xs)
infixr 4 _,~_

unfoldr : {X S : Set} -> (S -> (One + (X * S))) -> S -> CoList X
force (unfoldr coalg s) with coalg s
force (unfoldr coalg s) | inl <>       = inl <>
force (unfoldr coalg s) | inr (x , s') = inr (x , unfoldr coalg s')

ex2 = unfoldr force (1 ,~ 2 ,~ 3 ,~ []~)

repeat : {X : Set} -> X -> CoList X
repeat = unfoldr \ x -> inr (x , x)

prefix : {X : Set} -> Nat -> CoList X -> List X
prefix zero xs = []
prefix (suc n) xs with force xs
prefix (suc n) xs | inl <> = []
prefix (suc n) xs | inr (x , xs') = x ,- prefix n xs'

ex2' = prefix 3 ex2

record Stream (X : Set) : Set where
  coinductive
  field
    hdTl : X * Stream X
open Stream

forever : {X : Set} -> X -> Stream X
fst (hdTl (forever x)) = x
snd (hdTl (forever x)) = forever x

unfold : {X S : Set} -> (S -> X * S) -> S -> Stream X
fst (hdTl (unfold coalg s)) = fst (coalg s)
snd (hdTl (unfold coalg s)) = unfold coalg (snd (coalg s))


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

module qsort where

  _o_ : {a : Set} -> {b : Set} -> {c : Set} -> (b -> c) -> (a -> b) -> a -> c
  f o g = \x -> f (g x)

  data Bool : Set where
    true  : Bool
    false : Bool

  not : Bool -> Bool
  not true  = false
  not false = true

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

  data List (a : Set) : Set where
    nil  : List a
    _::_ : a -> List a -> List a

  listrec : {a : Set} -> List a -> (a -> List a -> List a) -> List a -> List a
  listrec e _  nil    = e
  listrec e b (x :: xs) = b x (listrec e b xs)

  filter : {a : Set} -> (a -> Bool) -> List a -> List a
  filter f = listrec nil (\x ih -> if (f x) then (x :: ih) else ih)

  _++_ : {a : Set} -> List a -> List a -> List a
  nil ++ ys = ys
  (x :: xs) ++ ys = x :: (xs ++ ys)

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

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

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

  one : Nat
  one = succ zero

  fact : Nat -> Nat
  fact  zero    = one
  fact (succ n) = succ n * fact n

  _<_ : Nat -> Nat -> Bool
  zero     < zero     = false
  zero     < n        = true
  n        < zero     = false
  (succ n) < (succ m) = n < m

  --

  qsort : {a : Set} -> (a -> a -> Bool) -> List a -> List a
  qsort f nil       = nil
  qsort f (x :: xs) = (qsort f (filter (not o (f x)) xs)) ++
                    (x :: (qsort f (filter (f x) xs)))


open import Tutorials.Monday-Complete
module Tutorials.Tuesday-Complete where

-----------
-- Pi and Sigma types
-----------

module Product where
  -- The open keyword opens a given module in the current namespace
  -- By default all of the public names of the module are opened
  -- The using keyword limits the imported definitions to those explicitly listed
  open Fin
  open Vec using (Vec; []; _∷_)
  open Simple using (¬_)

  variable
    P Q : A → Set

  -- Pi types: dependent function types
  -- For every x of type A, the predicate P x holds
  Π : (A : Set) → (Pred A) → Set
  Π A P = (x : A) → P x

  infix 5 _,_
  -- Sigma types: dependent product types, existential types
  -- For this x of type A, the predicate P x holds
  record Σ (A : Set) (P : Pred A) : Set where
    -- In the type P fst, fst refers to a previously introduced field
    constructor _,_
    field
      fst : A
      snd : P fst

  open Σ public

  -- By depending on a boolean we can use pi types to represent product types
  Π-× : Set → Set → Set
  Π-× A B = Π Bool λ where
    true  → A
    false → B

  -- By depending on a boolean we can use sigma types to represent sum types
  Σ-⊎ : Set → Set → Set
  Σ-⊎ A B = Σ Bool λ where
    true  → A
    false → B

  -- Use pi types to recover function types
  Π-→ : Set → Set → Set
  Π-→ A B = Π A λ where
    _     → B

  -- Use sigma types to recover product types
  Σ-× : Set → Set → Set
  Σ-× A B = Σ A λ where
    _     → B

  infix 5 _×_
  _×_ : Set → Set → Set
  _×_ = Σ-×

  -- 1) If we can transform the witness and
  -- 2) transform the predicate as per the transformation on the witness
  -- ⇒) then we can transform a sigma type
  map : (f : A → B) → (∀ {x} → P x → Q (f x)) → (Σ A P → Σ B Q)
  map f g (x , y) = (f x , g y)

  -- The syntax keyword introduces notation that can include binders
  infix 4 Σ-syntax
  Σ-syntax : (A : Set) → (A → Set) → Set
  Σ-syntax = Σ
  syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

  example₁ : Σ ℕ EvenData
  example₁ = 0 , zero

  one-is-not-even : ¬ EvenData 1
  one-is-not-even ()

  example₂ : ¬ Π ℕ EvenData
  example₂ f = one-is-not-even (f 1)

  ¬∘ : Pred A → Pred A
  ¬∘ P = ¬_ ∘ P

  -- These can be proven regardless of A

  ¬∃⇒∀¬ : ¬ (Σ A P) → Π A (¬∘ P)
  ¬∃⇒∀¬ f x px = f (x , px)

  ∃¬⇒¬∀ : Σ A (¬∘ P) → ¬ Π A P
  ∃¬⇒¬∀ (a , ¬pa) f = ¬pa (f a)

  ∀¬⇒¬∃ : Π A (¬∘ P) → ¬ Σ A P
  ∀¬⇒¬∃ f (a , pa) = f a pa

  -- Works in classical, not in constructive mathematics
  postulate ¬∀⇒∃¬ : ¬ Π A P → Σ A (¬∘ P)

  -- Show that ≤ is antisymmetric
  ≤-≡ : n ≤ m → m ≤ n → n ≡ m
  ≤-≡ z≤n z≤n = refl
  ≤-≡ (s≤s x) (s≤s y) = cong suc (≤-≡ x y)

  -- By using n ≤ m instead of Fin m we can mention n in the output
  take : Vec A m → n ≤ m → Vec A n
  take xs z≤n = []
  take (x ∷ xs) (s≤s lte) = x ∷ take xs lte

  Fin-to-≤ : (i : Fin m) → to-ℕ i < m
  Fin-to-≤ zero = s≤s z≤n
  Fin-to-≤ (suc i) = s≤s (Fin-to-≤ i)

  -- Proof combining sigma types and equality
  ≤-to-Fin : n < m → Fin m
  ≤-to-Fin (s≤s z≤n) = zero
  ≤-to-Fin (s≤s (s≤s i)) = suc (≤-to-Fin (s≤s i))

  Fin-≤-inv : (i : Fin m) → ≤-to-Fin (Fin-to-≤ i) ≡ i
  Fin-≤-inv zero = refl
  Fin-≤-inv (suc zero) = refl
  Fin-≤-inv (suc (suc i)) = cong suc (Fin-≤-inv (suc i))

  ≤-Fin-inv : (lt : Σ[ n ∈ ℕ ] n < m)
            → (to-ℕ (≤-to-Fin (snd lt)) , Fin-to-≤ (≤-to-Fin (snd lt))) ≡ lt
  ≤-Fin-inv (.zero , s≤s z≤n) = refl
  ≤-Fin-inv (.(suc _) , s≤s (s≤s i)) =
    cong (map suc s≤s) (≤-Fin-inv (_ , s≤s i))


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

module Lecture2 where

import Basics
open Basics public

-- Definition 2.2.3 define the identity function, and show lambda-abstraction in so doing
id : {i : Level} {A : UU i} → A → A
id = λ a → a -- can also use plain backslash \ instead of lambda (as it resembles lambda?)

-- Definition 2.2.4
comp : {i j k : Level} {A : UU i} {B : UU j} {C : UU k} → (B → C) → ((A → B) → (A → C))
comp = λ g f a → g(f(a)) -- the lambda extends to cover g, f and a
_∘_ : {i j k : Level} {A : UU i} {B : UU j} {C : UU k} → (B → C) → ((A → B) → (A → C))
g ∘ f = comp g f

data ℕ : U where
  Nzero : ℕ
  Nsucc : ℕ → ℕ

add : ℕ → ℕ → ℕ
add Nzero = id
add (Nsucc n) = Nsucc ∘ (add n)

-- try some examples, hit C-c C-n (or whatever "compute normal form" is bound to)
-- and try entering "add (Nsucc Nzero) (Nsucc (Nsucc Nzero))"
-- you should get "Nsucc (Nsucc (Nsucc Nzero))"

_+_ : ℕ → ℕ → ℕ
n + m = add n m

-- Exercise 2.3
const : {i j : Level} (A : UU i) (B : UU j) (b : B) → A → B
const A B b x = b

-- Exercise 2.4
Pi-swap : {i j k : Level} {A : UU i} {B : UU j} {C : A → (B → UU k)} →
  ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
Pi-swap f y x = f x y

-- Exercise 2.5(a)
_**_ : ℕ → (ℕ → ℕ)
Nzero ** n = Nzero
(Nsucc m) ** n = (m ** n) + n

-- Exercise 2.5(b)
_^_ : ℕ → (ℕ → ℕ)
m ^ Nzero = Nsucc Nzero
m ^ (Nsucc n) = m ** (m ^ n)

-- Exercise 2.5(c)
factorial : ℕ → ℕ
factorial Nzero = Nsucc Nzero
factorial (Nsucc m) = (Nsucc m) ** (factorial m)

-- Exercise 2.6(a)
Nmax : ℕ → (ℕ → ℕ)
Nmax Nzero n = n
Nmax (Nsucc m) Nzero = Nsucc m
Nmax (Nsucc m) (Nsucc n) = Nsucc (Nmax m n)

-- Exercise 2.6(b)
Nmin : ℕ → (ℕ → ℕ)
Nmin Nzero n = Nzero
Nmin (Nsucc m) Nzero = Nzero
Nmin (Nsucc m) (Nsucc n) = Nsucc (Nmin m n)

-- Exercise 2.7
-- induction: for any dependent type P over ℕ, define a section of P
-- built out of a term in P 0 and a section of P n → P(Nsucc n)
ind-N : {i : Level} {P : ℕ → UU i} → P Nzero → ((n : ℕ) → P n → P(Nsucc n)) → ((n : ℕ) → P n)
ind-N p0 pS Nzero = p0
ind-N p0 pS (Nsucc n) = pS n (ind-N p0 pS n)


module Bin where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import Naturals using (ℕ; zero; suc; _+_; _*_)

-- 2進数の表現
data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

-- 2進数のインクリメント
inc : Bin → Bin
inc ⟨⟩    = ⟨⟩ I
inc (b O) = b I
inc (b I) = inc b O

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

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

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

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

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

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

-- 自然数から2進数への変換
to : ℕ → Bin
to zero    = ⟨⟩ O
to (suc n) = inc (to n)

_ : to 0 ≡ ⟨⟩ O
_ = refl

_ : to 1 ≡ ⟨⟩ I
_ = refl

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

_ : to 3 ≡ ⟨⟩ I I
_ = refl

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

-- 2進数から自然数への変換
from : Bin → ℕ
from ⟨⟩    = zero
from (b O) = 2 * (from b)
from (b I) = 2 * (from b) + 1

_ : from (⟨⟩ O) ≡ 0
_ = refl

_ : from (⟨⟩ I) ≡ 1
_ = refl

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

_ : from (⟨⟩ I I) ≡ 3
_ = refl

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


module Two where

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

import Data.Nat as ℕ
import Data.Nat.Properties as ℕₚ

open ℕ using (ℕ; zero; suc; _+_)

-- Our language consists of constants and addition
data Expr : Set where
  const : ℕ → Expr
  plus : Expr → Expr → Expr

-- Straightforward semantics
eval-expr : Expr → ℕ
eval-expr (const n) = n
eval-expr (plus e1 e2) = eval-expr e1 + eval-expr e2

-- Tail recursive semantics
eval-expr-tail' : Expr → ℕ → ℕ
eval-expr-tail' (const n) acc = n + acc
eval-expr-tail' (plus e1 e2) acc = eval-expr-tail' e2 (eval-expr-tail' e1 acc)

eval-expr-tail : Expr → ℕ
eval-expr-tail e = eval-expr-tail' e 0

--
-- Task: prove that eval-expr-tail is equivalent to eval-expr.
--

-- The tail recursive evaluation does not depend on its accumulator
eval-expr-tail-correct-lemma : ∀ e acc → eval-expr-tail' e acc ≡ eval-expr-tail' e 0 + acc
eval-expr-tail-correct-lemma e acc = ?

-- The tail recursive evaluation agrees with the straightforward evaluation
eval-expr-tail-correct : ∀ e → eval-expr-tail e ≡ eval-expr e
eval-expr-tail-correct e = ?


{-

Part 3: Univalence and the SIP

- Univalence from ua and uaβ
- Transporting with ua (examples: ua not : Bool = Bool, ua suc : Z = Z, ...)
- Subst using ua
- The SIP as a consequence of ua
- Examples of using the SIP for math and programming (algebra, data
  structures, etc.)

-}

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

open import Cubical.Foundations.Prelude hiding (refl ; transport ; subst ; sym)
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Data.Int

open import Part2 public

-- Another key concept in HoTT/UF is the Univalence Axiom. In Cubical
-- Agda this is provable, we hence refer to it as the Univalence
-- Theorem.

-- The univalence theorem: equivalences of types give paths of types
ua' : {A B : Type ℓ} → A ≃ B → A ≡ B
ua' = ua

-- Any isomorphism of types gives rise to an equivalence
isoToEquiv' : {A B : Type ℓ} → Iso A B → A ≃ B
isoToEquiv' = isoToEquiv

-- And hence to a path
isoToPath' : {A B : Type ℓ} → Iso A B → A ≡ B
isoToPath' e = ua' (isoToEquiv' e)

-- ua satisfies the following computation rule
-- This suffices to be able to prove the standard formulation of univalence.
uaβ' : {A B : Type ℓ} (e : A ≃ B) (x : A)
     → transport (ua' e) x ≡ fst e x
uaβ' e x = transportRefl (equivFun e x)

-- Time for an example!

-- Booleans
data Bool : Type₀ where
  false true : Bool

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

notPath : Bool ≡ Bool
notPath = isoToPath' (iso not not rem rem)
  where
  rem : (b : Bool) → not (not b) ≡ b
  rem false = refl
  rem true  = refl

_ : transport notPath true ≡ false
_ = refl

-- Another example, integers:

sucPath : Int ≡ Int
sucPath = isoToPath' (iso sucInt predInt sucPred predSuc)

_ : transport sucPath (pos 0) ≡ pos 1
_ = refl

_ : transport (sucPath ∙ sucPath) (pos 0) ≡ pos 2
_ = refl

_ : transport (sym sucPath) (pos 0) ≡ negsuc 0
_ = refl

-------------------------------------------------------------------------
-- The structure identity principle

-- A more efficient version of finite multisets based on association lists
open import Cubical.HITs.AssocList.Base

-- data AssocList (A : Type) : Type where
--  ⟨⟩ : AssocList A
--  ⟨_,_⟩∷_ : (a : A) (n : ℕ) (xs : AssocList A) → AssocList A
--  per : (a b : A) (m n : ℕ) (xs : AssocList A)
--      → ⟨ a , m ⟩∷ ⟨ b , n ⟩∷ xs ≡ ⟨ b , n ⟩∷ ⟨ a , m ⟩∷ xs
--  agg : (a : A) (m n : ℕ) (xs : AssocList A)
--      → ⟨ a , m ⟩∷ ⟨ a , n ⟩∷ xs ≡ ⟨ a , m + n ⟩∷ xs
--  del : (a : A) (xs : AssocList A) → ⟨ a , 0 ⟩∷ xs ≡ xs
--  trunc : (xs ys : AssocList A) (p q : xs ≡ ys) → p ≡ q

-- Programming and proving is more complicated with AssocList compared
-- to FMSet. This kind of example occurs everywhere in programming and
-- mathematics: one representation is easier to work with, but not
-- efficient, while another is efficient but difficult to work with.

-- Solution: substitute using univalence
substIso : {A B : Type ℓ} (P : Type ℓ → Type ℓ') (e : Iso A B) → P A → P B
substIso P e = subst P (isoToPath e)

-- Can transport for example Monoid structure from FMSet to AssocList
-- this way, but the achieved Monoid structure is not very efficient
-- to work with. A better solution is to prove that FMSet and
-- AssocList are equal *as monoids*, but how to do this?

-- Solution: structure identity principle (SIP)
-- This is a very useful consequence of univalence
open import Cubical.Foundations.SIP

{-
sip' : {ℓ : Level} {S : Type ℓ → Type ℓ} {ι : StrEquiv S ℓ}
       (θ : UnivalentStr S ι) (A B : TypeWithStr ℓ S) → A ≃[ ι ] B → A ≡ B
sip' = sip
-}
-- The tricky thing is to prove that (S,ι) is a univalent structure.
-- Luckily we provide automation for this in the library, see for example:
-- open import Cubical.Algebra.Monoid.Base

-- Another cool application of the SIP: matrices represented as
-- functions out of pairs of Fin's and vectors are equal as abelian
-- groups:
open import Cubical.Algebra.Matrix


-- Properties involving susbets and membership
-- between sets.

module sv20.assign2.SetTheory.Subset where

open import sv20.assign2.SetTheory.Logic
open import sv20.assign2.SetTheory.ZAxioms

memberEq : (x y z : 𝓢) → x ∈ y ∧ y ≡ z → x ∈ z
memberEq x y z (x₁ , x₂) = subs _ x₂ x₁

-- Theorem 1, p. 21 (Suppes 1960)
notInEmpty : ∀ x → x ∉ ∅
notInEmpty x h  = (proj₂ _ empt) x h

prop-∅ : (x A : 𝓢) → x ∈ A → A ≢ ∅
prop-∅ x A x∈A h = notInEmpty x (subs _ h x∈A)

prop₂-∅ : (x : 𝓢) → ∃ (λ y → y ∈ x) → x ≢ ∅
prop₂-∅ x h₁ h₂ = cont _ (h₂ , prop-∅ _ _ aux-p)
  where
  aux : 𝓢
  aux = proj₁ h₁

  aux-p : aux ∈ x
  aux-p = proj₂ _ h₁

-- Theorem 3, p. 22 (Suppes 1960)
subsetOfItself : ∀ {x} → x ⊆ x
subsetOfItself _ t∈x = t∈x

-- Theorem 4, p. 22 (Suppes 1960)
equalitySubset :  (x y : 𝓢) → x ⊆ y ∧ y ⊆ x → x ≡ y
equalitySubset x y (x⊆y , y⊆x) = ext x y ((x⊆y x) , (y⊆x x))

-- Theorem 6, p. 23 (Suppes 1960)
trans-⊆ : (x y z : 𝓢) → x ⊆ y ∧ y ⊆ z → x ⊆ z
trans-⊆ x y z (x⊆y , y⊆z) t t∈x = y⊆z t (x⊆y t t∈x)

-- Theorem 7, p. 23 (Suppes 1960)
notContainedInItself : ∀ {x} → ¬ (x ⊂ x)
notContainedInItself (_ , x≢x) = x≢x refl

-- Theorem 8, p. 23 (Suppes 1960)
nonSymmetry-⊂ : (x y : 𝓢) (p : x ⊂ y) → ¬ (y ⊂ x)
nonSymmetry-⊂ x y (x⊆y , x≢y) (y⊆x , _) = x≢y (equalitySubset x y (x⊆y , y⊆x))

-- Theorem 10, p. 23 (Suppes 1960)
⊂→⊆ : ∀ {x y} → x ⊂ y → x ⊆ y
⊂→⊆ (x⊆y , _) z z∈x = x⊆y z z∈x

prop-⊆ : (x A B : 𝓢) → x ∈ A → A ⊆ B → x ∈ B
prop-⊆ x A B x₁ x₂ = i x₁
  where
  i : x ∈ A → x ∈ B
  i = x₂ _

-- References
--
-- Suppes, Patrick (1960). Axiomatic Set Theory.
-- The University Series in Undergraduate Mathematics.
-- D. Van Nostrand Company, inc.
--
-- Enderton, Herbert B. (1977). Elements of Set Theory.
-- Academic Press Inc.


------------------------------------------------------------------------------
-- Group theory properties
------------------------------------------------------------------------------

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

module GroupTheory.PropertiesATP where

open import GroupTheory.Base

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

postulate leftCancellation : ∀ {a b c} → a · b ≡ a · c → b ≡ c
{-# ATP prove leftCancellation #-}

postulate rightIdentity : ∀ a → a · ε ≡ a
{-# ATP prove rightIdentity #-}

postulate rightInverse : ∀ a → a · a ⁻¹ ≡ ε
{-# ATP prove rightInverse #-}

postulate rightCancellation : ∀ {a b c} → b · a ≡ c · a → b ≡ c
{-# ATP prove rightCancellation #-}

postulate y≡x⁻¹[xy] : ∀ a b → b ≡ a ⁻¹ · (a · b)
{-# ATP prove y≡x⁻¹[xy] #-}

postulate x≡[xy]y⁻¹ : ∀ a b → a ≡ (a · b) · b ⁻¹
{-# ATP prove x≡[xy]y⁻¹ #-}

postulate rightIdentityUnique : ∀ r → (∀ a → a · r ≡ a) → r ≡ ε
{-# ATP prove rightIdentityUnique #-}

-- A more appropiate version to be used in the proofs.
postulate rightIdentityUnique' : ∀ a r → a · r ≡ a → r ≡ ε
{-# ATP prove rightIdentityUnique' #-}

postulate leftIdentityUnique : ∀ l → (∀ a → l · a ≡ a) → l ≡ ε
{-# ATP prove leftIdentityUnique #-}

-- A more appropiate version to be used in the proofs.
postulate leftIdentityUnique' : ∀ a l → l · a ≡ a → l ≡ ε
{-# ATP prove leftIdentityUnique' #-}

postulate
  rightInverseUnique : ∀ {a} → ∃[ r ] (a · r ≡ ε) ∧ (∀ r' → a · r' ≡ ε → r ≡ r')
{-# ATP prove rightInverseUnique #-}

-- A more appropiate version to be used in the proofs.
postulate rightInverseUnique' : ∀ {a r} → a · r ≡ ε → a ⁻¹ ≡ r
{-# ATP prove rightInverseUnique' #-}

postulate
  leftInverseUnique : ∀ {a} → ∃[ l ] (l · a ≡ ε) ∧ (∀ l' → l' · a ≡ ε → l ≡ l')
{-# ATP prove leftInverseUnique #-}

-- A more appropiate version to be used in the proofs.
postulate leftInverseUnique' : ∀ {a l} → l · a ≡ ε → a ⁻¹ ≡ l
{-# ATP prove leftInverseUnique' #-}

postulate ⁻¹-involutive : ∀ a → a ⁻¹ ⁻¹ ≡ a
{-# ATP prove ⁻¹-involutive #-}

postulate identityInverse : ε ⁻¹ ≡ ε
{-# ATP prove identityInverse #-}

postulate inverseDistributive : ∀ a b → (a · b) ⁻¹ ≡ b ⁻¹ · a ⁻¹
{-# ATP prove inverseDistributive #-}

-- The equation xa = b has an unique solution.
postulate
  xa≡b-uniqueSolution : ∀ a b → ∃[ x ] (x · a ≡ b) ∧ (∀ x' → x' · a ≡ b → x ≡ x')
{-# ATP prove xa≡b-uniqueSolution #-}

-- The equation ax = b has an unique solution.
postulate
  ax≡b-uniqueSolution : ∀ a b → ∃[ x ] (a · x ≡ b) ∧ (∀ x' → a · x' ≡ b → x ≡ x')
{-# ATP prove ax≡b-uniqueSolution #-}

-- If the square of every element is the identity, the system is
-- commutative. From: TPTP 6.4.0 problem GRP/GRP001-2.p.
postulate x²≡ε→comm : (∀ a → a · a ≡ ε) → ∀ {b c d} → b · c ≡ d → c · b ≡ d
{-# ATP prove x²≡ε→comm #-}


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

open import LogicalFormulae
open import Numbers.Naturals.Definition

module Numbers.Naturals.Addition where

infix 15 _+N_
_+N_ : ℕ → ℕ → ℕ
zero +N y = y
succ x +N y = succ (x +N y)
{-# BUILTIN NATPLUS _+N_ #-}

addZeroRight : (x : ℕ) → (x +N zero) ≡ x
addZeroRight zero = refl
addZeroRight (succ x) rewrite addZeroRight x = refl

private
  succExtracts : (x y : ℕ) → (x +N succ y) ≡ (succ (x +N y))
  succExtracts zero y = refl
  succExtracts (succ x) y = applyEquality succ (succExtracts x y)

succCanMove : (x y : ℕ) → (x +N succ y) ≡ (succ x +N y)
succCanMove x y = transitivity (succExtracts x y) refl

additionNIsCommutative : (x y : ℕ) → (x +N y) ≡ (y +N x)
additionNIsCommutative zero y = equalityCommutative (addZeroRight y)
additionNIsCommutative (succ x) zero = transitivity (addZeroRight (succ x)) refl
additionNIsCommutative (succ x) (succ y) = transitivity refl (applyEquality succ (transitivity (succCanMove x y) (additionNIsCommutative (succ x) y)))

addingPreservesEqualityRight : {a b : ℕ} (c : ℕ) → (a ≡ b) → (a +N c ≡ b +N c)
addingPreservesEqualityRight {a} {b} c pr = applyEquality (λ n -> n +N c) pr
addingPreservesEqualityLeft : {a b : ℕ} (c : ℕ) → (a ≡ b) → (c +N a ≡ c +N b)
addingPreservesEqualityLeft {a} {b} c pr = applyEquality (λ n -> c +N n) pr

additionNIsAssociative : (a b c : ℕ) → ((a +N b) +N c) ≡ (a +N (b +N c))
additionNIsAssociative zero b c = refl
additionNIsAssociative (succ a) zero c = transitivity (transitivity (applyEquality (λ n → n +N c) (applyEquality succ (addZeroRight a))) refl) (transitivity refl refl)
additionNIsAssociative (succ a) (succ b) c = transitivity refl (transitivity refl (transitivity (applyEquality succ (additionNIsAssociative a (succ b) c)) refl))

succIsAddOne : (a : ℕ) → succ a ≡ a +N succ zero
succIsAddOne a = equalityCommutative (transitivity (additionNIsCommutative a (succ zero)) refl)

canSubtractFromEqualityRight : {a b c : ℕ} → (a +N b ≡ c +N b) → a ≡ c
canSubtractFromEqualityRight {a} {zero} {c} pr = transitivity (equalityCommutative (addZeroRight a)) (transitivity pr (addZeroRight c))
canSubtractFromEqualityRight {a} {succ b} {c} pr rewrite additionNIsCommutative a (succ b) | additionNIsCommutative c (succ b) | additionNIsCommutative b a | additionNIsCommutative b c = canSubtractFromEqualityRight {a} {b} {c} (succInjective pr)

canSubtractFromEqualityLeft : {a b c : ℕ} → (a +N b ≡ a +N c) → b ≡ c
canSubtractFromEqualityLeft {a} {b} {c} pr rewrite additionNIsCommutative a b | additionNIsCommutative a c = canSubtractFromEqualityRight {b} {a} {c} pr


module examplesPaperJFP.finn where

open import Data.Nat

data Fin : ℕ → Set where
  zero : {n : ℕ} → Fin (suc n)
  suc  : {n : ℕ} (i : Fin n) → Fin (suc n)

mutual
  data Even : ℕ → Set where
    0p    : Even 0
    sucp  : {n : ℕ}  →  Odd n   →  Even  (suc  n)

  data Odd : ℕ → Set where
    sucp  : {n : ℕ}  →  Even n  →  Odd   (suc  n)


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

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

infixl 6 _+_
_+_ : ℕ → ℕ → ℕ
zero + x = x
(suc a) + x = suc (a + x)

-- Exercise: Write the reasoning chain of 3 + 4
_ : 3 + 4 ≡ 7
_ =
  begin
    3 + 4
  ≡⟨⟩
    suc (2 + 4)
  ≡⟨⟩
    suc (suc (1 + 4))
  ≡⟨⟩
    suc (suc (suc (0 + 4)))
  ≡⟨⟩
    suc (suc (suc 4))
  ≡⟨⟩
    7
  ∎

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

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

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

-- Kinda like minus, but not exactly
infixl 6 _monus_
_monus_ : ℕ → ℕ → ℕ
zero monus y = zero
suc x monus zero = suc x
suc x monus suc y = x monus y

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

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

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

data Bin : Set where
  -- Empty bitstring
  ⟨⟩ : Bin
  -- Append a zero
  _O : Bin → Bin
  -- Append a one
  _I : Bin → Bin

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

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

from : Bin → ℕ
from ⟨⟩ = zero
from (b O) = from b * 2
from (b I) = from b * 2 + 1

-- I tried to prove these things doing some basic stuff but sadly got nowhere
-- I probably should just read the next chapter! (lol)
--multCommutes : (a : ℕ) → (b : ℕ) → a * b ≡ b * a
--multCommutes zero zero = refl
--multCommutes zero (suc b) = multCommutes zero b
--multCommutes (suc a) zero = multCommutes a zero
--multCommutes (suc a) (suc b) = {! cong (multCommutes a b) !}

--multIsAssociative : (a : ℕ) → (b : ℕ) → (c : ℕ) → (a * b) * c ≡ a * (b * c)
--multIsAssociative zero b c = refl
--multIsAssociative (suc a) zero c = refl
--multIsAssociative (suc a) (suc b) zero = refl
--multIsAssociative (suc a) (suc b) (suc c) = {! multIsAssociative a b c  !}


module _<?_ where

open import Data.Nat using (ℕ; zero; suc)
open import Relation.Nullary using (¬_)
open import decidable using (Dec; yes; no)

-- 厳密な不等式 (strict inequality)
infix 4 _<_
data _<_ : ℕ → ℕ → Set where
  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n

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

-- 0未満の自然数は存在しない
¬m<z : ∀ {m : ℕ} → ¬ (m < zero)
¬m<z ()

-- m < n が成り立たなければ (m + 1) < (n + 1) も成り立たない
¬s<s : ∀ {m n : ℕ} → ¬ (m < n) → ¬ (suc m < suc n)
¬s<s ¬m<n (s<s m<n) = ¬m<n m<n

-- decidableを使った厳密な不等式
_<?_ : ∀ (m n : ℕ) → Dec (m < n)
m     <? zero                = no ¬m<z
zero  <? suc n               = yes z<s
suc m <? suc n with m <? n
...               | yes m<n  = yes (s<s m<n)
...               | no  ¬m<n = no (¬s<s ¬m<n)


module 050-group where

-- We need monoids.

open import 040-monoid

-- A group is a monoid where every element has an inverse. This is
-- equivalent to saying that we have a function mapping every element
-- to an inverse of that element: this function is called "invert"
-- below.

record Group
  {M : Set}
  (_==_ : M -> M -> Set)
  (_*_ : M -> M -> M)
  (id : M)
  (invert : M -> M)
  : Set1 where
  field
    monoid : Monoid _==_ _*_ id
    icong : ∀ {r s} -> (r == s) -> (invert r) == (invert s)
    r*ir==id : ∀ {r} -> (r * (invert r)) == id
    ir*r==id : ∀ {r} -> ((invert r) * r) == id

  open Monoid monoid public

  -- Trivial but useful equalities.
  id==r*ir : ∀ {r} -> id == (r * (invert r))
  id==r*ir = symm r*ir==id
  id==ir*r : ∀ {r} -> id == ((invert r) * r)
  id==ir*r = symm ir*r==id

  -- Double inverse gets back original.
  iir==r : ∀ {r} -> (invert (invert r)) == r
  iir==r {r} = trans3 iir==r*ir*iir r*ir*iir==r*id r*id==r
    where iir==r*ir*iir :
            (invert (invert r)) == (r * ((invert r) * (invert (invert r))))
          iir==r*ir*iir = trans3 r==id*r (cong id==r*ir refl) assoc
          -- assoc {r} {ir} {iir} : (r * ir) * iir == r * (ir * iir)
          -- id==r*ir             : id == r * ir
          -- cong % (refl {iir})  : id * iir == (r * ir) * iir
          -- id*r==r {iir}        : iir == id * iir
          -- trans3 % %% %%%%     : iir == r * (ir * iir)
          r*ir*iir==r*id : (r * ((invert r) * (invert (invert r)))) == (r * id)
          r*ir*iir==r*id = cong refl r*ir==id

  -- Uniqueness of (left and right) inverse.
  irleftunique : ∀ {r} -> ∀ {s} -> (s * r) == id -> s == (invert r)
  irleftunique {r} {s} s*r==id = trans (symm s*r*ir==s) (s*r*ir==ir)
    where s*r*ir==ir : ((s * r) * (invert r)) == (invert r)
          s*r*ir==ir = trans (cong s*r==id refl) id*r==r
          s*r*ir==s : ((s * r) * (invert r)) == s
          s*r*ir==s = trans3 assoc (cong refl r*ir==id) r*id==r
  irrightunique : ∀ {r} -> ∀ {s} -> (r * s) == id -> s == (invert r)
  irrightunique {r} {s} r*s==id = trans (symm ir*r*s==s) (ir*r*s==ir)
    where ir*r*s==ir : ((invert r) * (r * s)) == (invert r)
          ir*r*s==ir = trans (cong refl r*s==id) r*id==r
          ir*r*s==s : ((invert r) * (r * s)) == s
          ir*r*s==s = trans3 (symm assoc) (cong ir*r==id refl) id*r==r


-- {-# OPTIONS -v tc.size:100 #-}

module SizedTypesMergeSort where

open import Common.Size
open import Common.Prelude using (Bool; true; false; if_then_else_)
open import Common.Product

module Old where

  -- sized lists

  data List (A : Set) : {_ : Size} -> Set where
    []   : {size : Size} -> List A {↑ size}
    _::_ : {size : Size} -> A -> List A {size} -> List A {↑ size}

  -- CPS split (non-size increasing)

  split : {A : Set}{i : Size} -> List A {i} ->
          {C : Set} -> (List A {i} -> List A {i} -> C) -> C
  split []        k = k [] []
  split (x :: xs) k = split xs (\ l r -> k (x :: r) l)

  module Sort (A : Set) (compare : A -> A -> {B : Set} -> B -> B -> B) where

    -- Andreas, 4 Sep 2008
    -- the size indices i and j should not be necessary here
    -- but without them, the termination checker does not recognise that
    -- the pattern x :: xs is equal to the term x :: xs
    -- I suspect that _::_ {∞} x xs is not equal to itself since ∞ is a term
    -- not a constructor or variable
    merge : {i j : Size} -> List A {i} -> List A {j} -> List A
    merge [] ys = ys
    merge xs [] = xs
    merge (x :: xs) (y :: ys) =
      compare x y (x :: merge xs (y :: ys))
                  (y :: merge (x :: xs) ys)

    sort : {i : Size} -> List A {i} -> List A
    sort [] = []
    sort (x :: []) = x :: []
    sort (x :: (y :: xs)) = split xs (\ l r -> merge (sort (x :: l))
                                                     (sort (y :: r)))

module New where

  -- sized lists

  data List A {i} : Set where
    []   : List A
    _::_ : {i' : Size< i} → A → List A {i'} → List A

  module CPS where

    -- CPS split (non-size increasing)

    split : ∀ {A i} → List A {i} →
            {C : Set} → (List A {i} → List A {i} → C) → C
    split []        k = k [] []
    split (x :: xs) k = split xs (\ l r → k (x :: r) l)

    module Sort (A : Set) (compare : A → A → {B : Set} → B → B → B) where

      merge : List A → List A → List A
      merge [] ys = ys
      merge xs [] = xs
      merge (x :: xs) (y :: ys) =
        compare x y (x :: merge xs (y :: ys))
                    (y :: merge (x :: xs) ys)

      sort : {i : Size} → List A {i} → List A
      sort []               = []
      sort (x :: [])        = x :: []
      sort (x :: (y :: xs)) = split xs (\ l r → merge (sort (x :: l))
                                                      (sort (y :: r)))

  module Direct where

    split : ∀ {A i} → List A {i} → List A {i} × List A {i}
    split []        = [] , []
    split (x :: xs) = let l , r = split xs in (x :: r) , l

    module Sort (A : Set) (_≤_ : A → A → Bool) where

      merge : List A → List A → List A
      merge [] ys = ys
      merge xs [] = xs
      merge (x :: xs) (y :: ys) =
        if x ≤ y then (x :: merge xs (y :: ys))
                 else (y :: merge (x :: xs) ys)

      sort : {i : Size} → List A {i} → List A
      sort []               = []
      sort (x :: [])        = x :: []
      sort (x :: (y :: xs)) = let l , r = split xs in merge (sort (x :: l))
                                                            (sort (y :: r))


-- There was a bug which caused the type checker to forget
-- the name of implicit arguments which weren't used in the
-- return type.
module UnusedNamedImplicits where

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

-- Simple example
f : {n m : Nat} -> Nat
f {m = m} = m

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

data Even : Nat -> Set where
  evenZ  : Even zero
  evenSS : {n : Nat} -> Even n -> Even (suc (suc n))

index : {n : Nat} -> Even n -> Nat
index  evenZ     = zero
index (evenSS e) = suc (suc (index e))

sameIndex : {n : Nat}(e : Even n) -> index e == n
sameIndex evenZ = refl
sameIndex (evenSS e) with index e | sameIndex e
... | ._ | refl = refl

-- It could also show up when the argument is used in the top level type,
-- but not by the generated type for the with function.
* : {n : Nat}{e : Even n} -> Even (index e)
* {e = e} with index e | sameIndex e
... | ._ | refl = e


open import Relation.Binary.Core

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

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Data.Sum
open import InsertSort.Impl2 _≤_ tot≤
open import List.Permutation.Base A
open import OList _≤_

lemma-forget-insert : {b : Bound} → (x : A) → (b≤x : LeB b (val x)) → (xs : OList b) → forget (insert b≤x xs) / x ⟶ forget xs
lemma-forget-insert x b≤x onil = /head
lemma-forget-insert x b≤x (:< {x = y} b≤y ys)
    with tot≤ x y
... | inj₁ x≤y = /head
... | inj₂ y≤x = /tail (lemma-forget-insert x (lexy y≤x) ys)

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


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

open import Part1 hiding (B)

variable
  B : A → Type ℓ

-- Solutions to ExerciseSession1

-- Exercise 1:
funExtDep : {f g : (x : A) → B x}
          → ((x : A) → f x ≡ g x)
          → f ≡ g
funExtDep p i x = p x i

-- Exercise 2:
congP : {x y : A} {B : A → Type ℓ'}
        (f : (a : A) → B a) (p : x ≡ y) →
        PathP (λ i → B (p i)) (f x) (f y)
congP f p i = f (p i)

-- Exercise 3:
isContrInhProp : isProp A → A → isContr A
isContrInhProp p x = x , p x

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

-- Exercise 4:
isProp'→isProp : isProp' A → isProp A
isProp'→isProp h = λ x y → h x y .fst

-- Exercise 5:
isPropΠ : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x)
isPropΠ h p q i x = h x (p x) (q x) i

-- Exercise 6:
funExt⁻ : {f g : (x : A) → B x} → f ≡ g → ((x : A) → f x ≡ g x)
funExt⁻ eq x i = eq i x

-- Exercise 7:
isSetΠ : (h : (x : A) → isSet (B x)) → isSet ((x : A) → B x)
isSetΠ h f g p q i j x = h x (f x) (g x) (funExt⁻ p x) (funExt⁻ q x) i j

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

-- Exercise 8:
isContrSingl' : (x : A) → isContr (singl' x)
isContrSingl' x = ctr , prf
  where
  ctr : singl' x
  ctr = x , refl

  prf : (s : singl' x) → ctr ≡ s
  prf (y , pax) i = (pax (~ i)) , λ j → pax (~ i ∨ j)


module z04-lists where

open import bool
open import eq
open import nat
open import nat-thms
open import product-thms using (keep)
open import logic -- needed for filter-idem

{-
-- p 75

'data' : datatype declaration
'𝕃'    : name of type being declared
{ℓ}    : level
A      : element type (polymorphic)

𝕃 is a type level function
- takes a type (bound to 'A') - at level ℓ
- returns a type - at level same level ℓ
-}

data  𝕃 {ℓ} (A : Set ℓ) : Set ℓ where
  []   :                      𝕃 A
  _::_ : (x : A) (xs : 𝕃 A) → 𝕃 A

-- from lists.agda

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

-- p 77

length : ∀ {ℓ} {A : Set ℓ } → 𝕃 A → ℕ
length       []  = 0
length (x :: xs) = suc (length xs)

-- 78

_++_ : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → 𝕃 A → 𝕃 A
[]        ++ ys =             ys
(x :: xs) ++ ys = x :: (xs ++ ys)

-- 79

map : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'}  → (A → B) → 𝕃 A → 𝕃 B
map f       []  = []
map f (x :: xs) = f x :: map f xs

-- 80

filter : ∀ {ℓ} {A : Set ℓ} → (A → 𝔹) → 𝕃 A → 𝕃 A
filter p       []  = []
filter p (x :: xs) = if p x then x :: r else r
 where
  r = filter p xs

-- p 81

remove : ∀ {ℓ} {A : Set ℓ} (eq : A → A → 𝔹) (a : A) (l : 𝕃 A) → 𝕃 A
remove eq a l = filter (λ x → ~ (eq a x)) l

-- p 82

data maybe {ℓ} (A : Set ℓ) : Set ℓ where
  just    : A → maybe A
  nothing :     maybe A

nth : ∀ {ℓ} {A : Set ℓ} → ℕ → 𝕃 A → maybe A
nth _             []  = nothing
nth 0       (x :: xs) = just x
nth (suc n) (x :: xs) = nth n xs

-- p 83

-- inefficient
sreverse : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → 𝕃 A
sreverse      []  = []
sreverse (h :: t) = sreverse t ++ [ h ]

reverse-helper : ∀ {ℓ}{A : Set ℓ} → 𝕃 A → 𝕃 A → 𝕃 A
reverse-helper h       []  = h
reverse-helper h (x :: xs) = reverse-helper (x :: h) xs

reverse : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → 𝕃 A
reverse l = reverse-helper [] l

------------------------------------------------------------------------------
-- p 84 Reasong about List Operations

length-++ : ∀ {ℓ}{A : Set ℓ} (l1 l2 : 𝕃 A)
          → length (l1 ++ l2) ≡ length l1 + length l2
length-++ [] l2 -- length ([] ++ l2) ≡ length [] + length l2
                -- length        l2  ≡             length l2
  = refl
length-++ (x :: xs) l2 --      length ((x :: xs) ++ l2)  ≡      length (x :: xs) + length l2
                       -- suc (length       (xs  ++ l2)) ≡ suc (length       xs  + length l2)
                       --                 |
  rewrite              -- IH              ≡
                       --                 v
    length-++ xs l2    -- suc (length  xs +  length l2)  ≡ suc (length       xs  + length l2)
  = refl

-- p 86

++-assoc : ∀ {ℓ} {A : Set ℓ} (l1 l2 l3 : 𝕃 A)
         → (l1 ++  l2) ++ l3
         ≡  l1 ++ (l2  ++ l3)
++-assoc [] l2 l3                  -- (([] ++ l2) ++ l3) ≡ ([] ++ (l2 ++ l3))
                                   --        (l2  ++ l3) ≡        (l2 ++ l3)
  = refl
++-assoc (x :: xs) l2 l3 -- (((x ::   xs) ++ l2) ++ l3)   ≡ ((x ::  xs) ++ (l2 ++ l3))
                         --   (x :: ((xs  ++ l2) ++ l3))  ≡  (x :: (xs  ++ (l2 ++ l3)))
  rewrite                -- IH               v
    ++-assoc xs l2 l3    --   (x ::  (xs ++ (l2  ++ l3))) ≡  (x :: (xs  ++ (l2 ++ l3)))
  = refl

{-
------------------------------------------------------------------------------
-- p 87 - WITH

for
- any type A (of any level),
- any predicate p on A
- any list of A
the length of the list after filtering l with p
<=
length of l
-}

length-filter : ∀ {ℓ} {A : Set ℓ} (p : A → 𝔹) (l : 𝕃 A)
              → length (filter p l) ≤ length l ≡ tt

-- proof case-splits input list

length-filter p      []         -- length (filter p []) ≤ length [] ≡ tt
                                --                   0  ≤         0 ≡ tt
  = refl

-- Consider cases where predicate returns tt or ff.
-- The predicate return value is NOT an input to length-filter.
-- WITH : extend pattern on left side with an additional pattern, here : | tt     and   | ff

length-filter p (x :: l) with p x
length-filter p (x :: l) | tt   --    length (filter p l)  <      length l
                                -- || length (filter p l) =ℕ      length l  ≡ tt
  = length-filter p l           -- IH
length-filter p (x :: l) | ff   --    length (filter p l)  < suc (length l)
  =                             -- || length (filter p l) =ℕ suc (length l) ≡ tt
  ≤-trans {length (filter p l)}
          (length-filter p l)   -- IH
          (≤-suc (length l))    -- ≤-suc proves length l ≤ suc (length l)

{- this is to see the goal for the non-nil case
lf : ∀ {ℓ} {A : Set ℓ} (p : A → 𝔹) (l : 𝕃 A)
   → length (filter p l) ≤ length l ≡ tt
lf p      []  = refl
lf p (x :: l) -- length                  (filter p (x :: l))                ≤      length (x :: l) ≡ tt
              -- length (if p x then x :: filter p       l else filter p l) ≤ suc (length       l) ≡ tt
  = {!!}

------------------------------------------------------------------------------
-- p 90 KEEP (called INSPECT in Agda standard library)

filtering a list twice using same predicate gives the same result as filtering it once

cannot use WITH because Agda only applies the p ≡ tt to the goal once, not the next iteration
(see page 92 for more details)

'with keep (p x)' : make additional variable (here p') available
-}

filter-idem : ∀ {ℓ} {A : Set ℓ} (p : A → 𝔹) (l : 𝕃 A)
            → (filter p (filter p l)) ≡ (filter p l)
filter-idem p []            -- filter p (filter p []) ≡ filter p []
                            --                    []  ≡          []
  = refl
{-
filter-idem p (x :: l)           -- filter p (filter p (x :: l)) ≡ filter p (x :: l)
                                 --
                                 -- filter p (if p x then x :: filter p l else filter p l)
                                 -- ≡ if p x then x :: filter p l else filter p l
  = {!!}
-}
filter-idem p (x :: l) with keep (p x)

filter-idem p (x :: l) | tt , p' -- filter p (if p x then x :: filter p l else filter p l)
                                 -- ≡ if p x then x :: filter p l else filter p l

  rewrite
    -- agda does not instantiate 'p x' in goal
    -- must explicit use it below to change 'p x' to 'tt' (or 'ff' further below)

    p'                           -- filter p (if tt then x :: filter p l else filter p l)
                                 -- ≡ if tt then x :: filter p l else filter p l
                                 --
                                 --   if p x then x :: filter p (filter p l) else filter p (filter p l)
                                 -- ≡ (x :: filter p l)

  -- use it again to eliminate the if

  | p'                           --   if tt  then x :: filter p (filter p l) else filter p (filter p l)
                                 -- ≡ (x :: filter p l)
                                 --
                                 --   (x :: filter p (filter p l)) ≡ (x :: filter p l)

  | filter-idem p l              --   (x :: filter p l) ≡ (x :: filter p l)
  = refl

filter-idem p (x :: l) | ff , p' -- filter p (if p x then x :: filter p l else filter p l)
                                 -- ≡ if p x then x :: filter p l else filter p l

  rewrite p'                     -- filter p (if ff then x :: filter p l else filter p l)
                                 -- ≡ if ff  then x :: filter p l else filter p l
                                 --
                                 -- filter p (filter p l) ≡ filter p l
  = filter-idem p l

{-
------------------------------------------------------------------------------
-- p 93

reverse-helper args
- reverse of the list processed so far
- rest of list to be reversed

tricky to figure out what general property of reverse-helper to prove
-length of reverse-helper h l is sum of lengths of h and l
-}

length-reverse-helper
  : ∀ {ℓ} {A : Set ℓ} (h l : 𝕃 A)
  → length (reverse-helper h l) ≡ length h + length l

length-reverse-helper h []                     -- length (reverse-helper h []) ≡ length h + length []
                                               -- length h                     ≡ length h + 0
  rewrite
    +comm (length h) 0                         -- length h                     ≡ length h
  -- also can do via
  -- rewrite +0 (length h) = refl
  = refl
length-reverse-helper h (x :: xs)
                                               -- length (reverse-helper h (x :: xs)) ≡ length h + length (x :: xs)
                                               -- length (reverse-helper (x :: h) xs) ≡ length h + suc (length xs)
  rewrite
    length-reverse-helper (x :: h) xs -- IH    --          suc (length h + length xs) ≡ length h + suc (length xs)
  | +suc (length h) (length xs)                --          suc (length h + length xs) ≡ suc (length h + length xs)
  = refl

length-reverse : ∀ {ℓ} {A : Set ℓ} (l : 𝕃 A)
               → length (reverse l) ≡ length l
length-reverse l = length-reverse-helper [] l

{-
------------------------------------------------------------------------------
-- p 95  conclusion : WITH     and    KEEP (aka INSPECT)

-- p 96 EXERCISES

-- 1
-}

-------------------------
-- NOT TRUE
-- 1a : ∀ {ℓ} {A : Set ℓ} (l1 l2 : 𝕃 A) → l1 ++ l2 ≡ l2 ++ l1

-------------------------
-- NOT TRUE
-- 1b : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) (l : 𝕃 A) → length (map f l) ≡ suc (length l)

-------------------------
-- 1c: TRUE

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

1c : ∀ {ℓ} {A : Set ℓ} {p : A → 𝔹} {a : A} (n : ℕ)
   → p a ≡ ff
   → filter p (repeat n a) ≡ []
1c 0 prop            -- filter p (repeat zero a) ≡ []
                     --                       [] ≡ []
  = refl
1c (suc n) prop      -- filter p (repeat (suc n) a) ≡ []
                     -- if p a then a :: filter p (repeat n a) else filter p (repeat n a) ≡ []
  rewrite
    prop             -- if ff  then a :: filter p (repeat n a) else filter p (repeat n a) ≡ []
                     --                                             filter p (repeat n a) ≡ []
  = 1c n prop -- IH

-------------------------
-- NOT TRUE
-- 1d : ∀ {ℓ} {A : Set ℓ} (l : 𝕃 A) → is-empty l ≡ tt → is-empty (reverse l) ≡ ff

-------------------------
-- TRUE
1e : ∀ {ℓ} {A : Set ℓ} (p : A -> 𝔹) (l1 l2 : 𝕃 A)
   → filter p (l1 ++          l2)
   ≡ filter p  l1 ++ filter p l2
1e p       []  l2               -- filter p ([] ++ l2) ≡ (filter p [] ++ filter p l2)
                                -- filter p        l2  ≡  filter p                l2
  = refl
1e p (x :: xs) l2 with keep (p x)
1e p (x :: xs) l2 | tt , p' --     if p x then x :: filter p (xs ++ l2) else filter p (xs ++ l2)
                            -- ≡ ((if p x then x :: filter p xs else filter p xs) ++ filter p l2)
  rewrite
    p'                      --     if tt  then x :: filter p (xs ++ l2) else filter p (xs ++ l2)
                            -- ≡ ((if tt  then x :: filter p xs else filter p xs) ++ filter p l2)
                            --
                            --   (x ::  filter p (xs ++          l2))
                            -- ≡ (x :: (filter p  xs ++ filter p l2))

  | 1e p xs l2              --   (x :: (filter p  xs ++ filter p l2))
                            -- ≡ (x :: (filter p  xs ++ filter p l2))
  = refl
1e p (x :: xs) l2 | ff , p' --     if p x then x :: filter p (xs ++ l2) else filter p (xs ++ l2)
                            -- ≡ ((if p x then x :: filter p xs else filter p xs) ++ filter p l2)
  rewrite
    p'                      --     if ff  then x :: filter p (xs ++ l2) else filter p (xs ++ l2)
                            -- ≡ ((if ff  then x :: filter p xs else filter p xs) ++ filter p l2)
                            --
                            -- filter p (xs ++ l2) ≡ (filter p xs ++ filter p l2)
  = 1e p xs l2              -- IH

--------------------------------------------------
-- 2

-------------------------
-- 2a [] : 𝕃 Set  (𝕃 _A_277)

-------------------------
2b : ∀ {ℓ} {A : Set ℓ} → 𝕃 A → ℕ
2b       []  = 0
2b (x :: xs) = suc (2b xs)

-------------------------
-- Note: 2ci does not explicitly give ℓ
-- Note: some other answers are probably OK - did not check
2c : ∀ {ℓ} {A : Set ℓ} {B : Set ℓ} {C : Set ℓ}
   → (A → B)
   → (B → C)
   → 𝕃 A
   → 𝕃 C
2c f g x = map g (map f x)

--------------------------------------------------
-- 3

takeWhile : ∀ {ℓ} {A : Set ℓ} → (A → 𝔹) -> 𝕃 A → 𝕃 A
takeWhile p       []  = []
takeWhile p (x :: xs) = if p x then x :: takeWhile p xs else takeWhile p xs

--------------------------------------------------
-- 4

4twr : ∀ {ℓ} {A : Set ℓ} {p : A → 𝔹} {a : A} (n : ℕ)
     → p a ≡ tt
     → takeWhile p (repeat n a) ≡ repeat n a
4twr  zero p               -- takeWhile p₁ (repeat zero a) ≡ repeat zero a
                           --                           [] ≡ []
  = refl
4twr {l} {A} {pred} {a} (suc n) p -- takeWhile p₁ (repeat (suc n) a) ≡ repeat (suc n) a
                                  --   if p₁ a then a :: takeWhile p₁ (repeat n a) else takeWhile p₁ (repeat n a)
                                  -- ≡             (a ::               repeat n a)
  rewrite
    p                             --   if tt   then a :: takeWhile p₁ (repeat n a) else takeWhile p₁ (repeat n a)
                                  -- ≡             (a ::               repeat n a)
                                  --               (a :: takeWhile p₁ (repeat n a))
                                  -- ≡             (a ::               repeat n a)
  | 4twr {l} {A} {pred} {a} n p   --               (a ::               repeat n a) ≡ (a :: repeat n a)
  = refl

--------------------------------------------------
-- 5

take    : ∀ {ℓ} {A : Set ℓ} → ℕ → 𝕃 A → 𝕃 A
take         0         _  = []
take         _        []  = []
take    (suc n) (x :: xs) = x :: take n xs

--------------------------------------------------
-- 6

nthTail : ∀ {ℓ} {A : Set ℓ} → ℕ → 𝕃 A → 𝕃 A
nthTail      0        xs  = xs
nthTail      _        []  = []
nthTail (suc n) (x :: xs) = nthTail n xs
{-
6tn : ∀ {ℓ} {A : Set ℓ} {a : A} (n : ℕ) (l : 𝕃 A)
    → take n l ++ nthTail n l ≡ l
6tn  zero   l              -- (take zero l ++ nthTail zero l) ≡ l
                           --                             l  ≡ l
  = refl
6tn {ℓ} {A} {a} (suc n) l  -- (take (suc n) l ++ nthTail (suc n) l) ≡ l
  rewrite
    6tn {ℓ} {A} {a} n l
  = {!!}
-}

6tn : ∀ {ℓ} {A : Set ℓ} {a : A} (n : ℕ) (l : 𝕃 A)
    → take n l ++ nthTail n l ≡ l
6tn               zero        []  --       (take zero      []      ++ nthTail   zero        []) ≡ []
                                  --                                                        []  ≡ []
  = refl
6tn             (suc n)       []  --       (take (suc n)       []  ++ nthTail (suc n)       [])  ≡ []
                                  --                                                        []   ≡ []
  = refl
6tn               zero  (x :: xs) --       (take   zero  (x :: xs) ++ nthTail   zero  (x :: xs)) ≡ (x :: xs)
                                  -- (x :: xs)  ≡ (x :: xs)
  = refl
6tn {ℓ} {A} {a} (suc n) (x :: xs) --       (take (suc n) (x :: xs) ++ nthTail (suc n) (x :: xs)) ≡ (x :: xs)
                                  -- (x :: (take      n        xs  ++ nthTail      n        xs)) ≡ (x :: xs)
  rewrite
    6tn {ℓ} {A} {a} n xs          -- (x :: xs)                                                   ≡ (x :: xs)
  = refl


{-
  Copyright 2019 Lisandra Silva

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

open import Prelude
open import Data.Nat.Divisibility

open import StateMachineModel

{-
  This State Machine begins in a state equal to 0 or 1 and if :
    - The current state s is Even then jump to state (s + 2)
    - The current state is Odd jump to state (s + 1)

  We want to prove that a state s always leads-to a state Even
-}

module Examples.SMCounterEven where

  -- DEFINITIONS and proofs about Even and Odd
  Even : ℕ → Set
  Even n = 2 ∣ n

  Odd : ℕ → Set
  Odd = ¬_ ∘ Even

  even? : (n : ℕ) → Dec (Even n)
  even? n = 2 ∣? n

  evenK⇒even2+K : ∀ {k} → Even k → Even (2 + k)
  evenK⇒even2+K (divides q₁ refl) = divides (1 + q₁) refl

  -- The following are mutually recursive properties.
  oddK⇒even1+K : ∀ {k} → Odd k → Even (suc k)
  oddK⇒evenK-1 : ∀ {k} → Odd k → Even (pred k)

  oddK⇒even1+K {zero} x = ⊥-elim (x (divides 0 refl))
  oddK⇒even1+K {suc k} x = evenK⇒even2+K (oddK⇒evenK-1 x)

  oddK⇒evenK-1 {zero} x = ⊥-elim (x (divides 0 refl))
  oddK⇒evenK-1 {suc k} x with even? k
  ...| no imp = ⊥-elim (x (oddK⇒even1+K imp))
  ...| yes prf = prf

  odd1 : Odd 1
  odd1 (divides zero ())
  odd1 (divides (suc q₁) ())

   -----------------------------------------------------------------------------
   -- SPECIFICATION
   -----------------------------------------------------------------------------

  data MyEvent : Set where
    inc  : MyEvent
    inc2 : MyEvent
    -- TODO : Try with an event iddle that doesn't do anything and is in another
    -- EventSet in the weakFairness relation (just to try)

  -- If we are in a state that is odd then the enabled event is inc
  -- otherwise the enabled event is inc2
  data MyEnabled : MyEvent → ℕ → Set where
    odd  : ∀ {n} → Odd n  → MyEnabled inc  n
    even : ∀ {n} → Even n → MyEnabled inc2 n

  MyStateMachine : StateMachine ℕ MyEvent
  MyStateMachine = record
                   { initial =  (0 ≡_) ∪ (1 ≡_)
                   ; enabled = MyEnabled
                   ; action  = λ { {pre} {inc}  cond → 1 + pre
                                 ; {pre} {inc2} cond → 2 + pre }
                   }

  MyEventSet : EventSet {Event = MyEvent}
  MyEventSet inc  = ⊤
  MyEventSet inc2 = ⊤

  data MyWeakFairness : EventSet → Set where
    wf : MyWeakFairness MyEventSet

  MySystem : System ℕ MyEvent
  MySystem = record
             { stateMachine = MyStateMachine
             ; weakFairness = MyWeakFairness
             }

   -----------------------------------------------------------------------------
   -- PROOFS
   -----------------------------------------------------------------------------

  open LeadsTo ℕ MyEvent MySystem

  -- In every state there is always an enabled transition
  alwaysEnabled : ∀ (s : ℕ) → enabledSet MyStateMachine MyEventSet s
  alwaysEnabled s with even? s
  ... | yes p = inc2 , tt , even p
  ... | no ¬p = inc  , tt , odd ¬p

  -- Any state n leads to an Even state
  progressEven : ∀ {n : ℕ} → (n ≡_) l-t Even
  progressEven = viaEvSet
                   MyEventSet wf
                   (λ { inc  ⊤ → hoare λ { refl (odd x)  → oddK⇒even1+K  x }
                      ; inc2 ⊤ → hoare λ { refl (even x) → evenK⇒even2+K x } })
                   (λ { inc  ⊥ → ⊥-elim (⊥ tt)
                      ; inc2 ⊥ → ⊥-elim (⊥ tt) })
                   λ {s} rs n≡s → alwaysEnabled s

  -- QUESTION : Although we don't have weakfairness (WF) on event inc it was
  -- possible to prove this.
  -- ANSWER : This is because of the 2nd constraint in the viaEvSet constructor:
  --      - ∀ event e ∉ WF (in this case only inc) → [P] e [P ∪ Q], in this case
  --   we achieve Q (Even), because the event inc is enabled only in Odd states.

  -- REFACTOR: Maybe m is the one that should be explicit
  myWFR : ∀ {m} → ℕ → Z → Set
  myWFR {m} d s = m ≡ d + s

  -- For every m and even state s, or s is greater than m or there is a distance
  -- x between s and m
  [Q∪Fx] :  ∀ {m} → (s : Z) → Even s
                       → (m ≤ s × Even s) ⊎ ∃[ x ] myWFR {m} x s
  [Q∪Fx] {m} s sEven with m ≤? s
  ... | yes m≤s = inj₁ (m≤s , sEven)
  ... | no  s<m = inj₂ ( m ∸ s , sym (m∸n+n≡m (<⇒≤ (≰⇒> s<m))) )

  -- First constraint for WFR rule
  [P]l-t[Q∪Fx] : ∀ {n m}
                 → (n ≡_) l-t ( ((m ≤_) ∩ Even) ∪ [∃ x ∶ myWFR {m} x ] )
  [P]l-t[Q∪Fx] {n} {m} = viaEvSet
                           MyEventSet wf
                           (λ { inc ⊤
                                    → hoare λ { refl (odd x)
                                      → [Q∪Fx] (1 + n) (oddK⇒even1+K x) }
                              ; inc2 ⊤
                                    → hoare λ { refl (even x)
                                      → [Q∪Fx] (2 + n) (evenK⇒even2+K x) }})
                           (λ { inc  ⊥ → ⊥-elim (⊥ tt)
                              ; inc2 ⊥ → ⊥-elim (⊥ tt) })
                           λ {s} rs n≡s → alwaysEnabled s

  -- If we are at distance 0 from m, which means state s ≡ m, then it leads-to a
  -- state s₁ > m ∩ Even s₁, because or we increment 1 if s is odd or we
  -- increment 2 if s is even.
  d≡0⇒Q : ∀ {m}
          → myWFR {m} 0
            l-t
            ( (m ≤_) ∩ Even )
  d≡0⇒Q {m} = viaEvSet
                MyEventSet wf
                (λ { inc  ⊤
                          → hoare λ { refl (odd x)
                           → m≤n+m m 1 , oddK⇒even1+K x }
                   ; inc2 ⊤
                          → hoare λ { refl (even x)
                            → m≤n+m m 2 , evenK⇒even2+K x }})
                (λ { inc  ⊥ → ⊥-elim (⊥ tt)
                   ; inc2 ⊥ → ⊥-elim (⊥ tt) })
                λ {s} rs F0 → alwaysEnabled s

  -- If we are at distance 1 from m, which means m ≡ s + 1.
  -- If s is odd then s is incremented by 1 (because of the enabling
  -- condition) then we go to an even state s₁ ≡ s + 1 ≡ m.
  -- If if s is even then s is incremented by 2, which leads to a state
  -- s₁ ≡ s + 2 > s + 1 ≡ m. As so, m ≤ s₁ ∩ Even s₁ will always  hold.
  d≡1⇒Q∪d≡0 : ∀ {m}
              → myWFR {m} 1
                l-t
                ( ((m ≤_) ∩ Even) ∪ [∃ x ⇒ _< 1 ∶ myWFR {m} x ] )
  d≡1⇒Q∪d≡0 {m} = viaEvSet
                    MyEventSet wf
                    (λ { inc  ⊤
                          → hoare λ { {ps} refl (odd x)
                           → inj₁ (≤-refl , oddK⇒even1+K x) }
                       ; inc2 ⊤
                         → hoare λ { {ps} refl (even x)
                           → inj₁ (m≤n+m (suc ps) 1 , evenK⇒even2+K x) }})
                    (λ { inc  ⊥ → ⊥-elim (⊥ tt)
                       ; inc2 ⊥ → ⊥-elim (⊥ tt) })
                    λ {s} rs F1 → alwaysEnabled s

  -- Auxiliary properties
  assoc∘comm : ∀ {w s : ℕ} n → n + w + s ≡ w + (n + s)
  assoc∘comm {w} {s} n = trans (cong (_+ s) (+-comm n w)) (+-assoc w n s)

  assoc∘assoc : ∀ {w s : ℕ} n p → (n + p) + w + s ≡ n + w + (p + s)
  assoc∘assoc {w} {s} n p
    rewrite +-assoc n p w
          | +-comm p w
          | +-assoc n (w + p) s
          | +-assoc w p s
          | +-assoc n w (p + s) = refl

  -- If we are at a distance greater o equal to 2 then with we decrease the
  -- distance in 1 or 2, because we can jump 1 or 2 states (inc or onc2)
  -- This property together with d≡0⇒Q and d≡1⇒Q∪d≡0 allows to prove the
  -- second constraint for the WFR rule (see below)
  [d≡2+w]⇒[d≡1+w]∪[d≡w] : ∀ {m w}
                → myWFR {m} (2 + w)
                  l-t
                  ( myWFR {m} (1 + w) ∪ myWFR {m} w )
  [d≡2+w]⇒[d≡1+w]∪[d≡w] {m} {w} =
    viaEvSet
      MyEventSet wf
      (λ { inc  ⊤
                → hoare λ { {ps} refl (odd x) → inj₁ (assoc∘assoc 1 1) }
         ; inc2 ⊤
                → hoare λ { {ps} refl enEv → inj₂ (assoc∘comm 2) }})
      (λ { inc  ⊥ → ⊥-elim (⊥ tt)
         ; inc2 ⊥ → ⊥-elim (⊥ tt) })
      λ {s} rs F2+d → alwaysEnabled s

  -- Second constraint for WFR rule
  [Fw]l-t[Q∪Fx] : ∀ {m w}
                  → myWFR {m} w
                    l-t
                    ( ((m ≤_) ∩ Even) ∪ [∃ x ⇒ _< w ∶ myWFR {m} x ] )
  [Fw]l-t[Q∪Fx] {m} {zero}        = viaTrans d≡0⇒Q (viaInv (λ rs x → inj₁ x))
  [Fw]l-t[Q∪Fx] {m} {suc zero}    = d≡1⇒Q∪d≡0
  [Fw]l-t[Q∪Fx] {m} {suc (suc w)} =
    viaTrans
      [d≡2+w]⇒[d≡1+w]∪[d≡w]
      (viaInv (λ { rs (inj₁ mfr[1+w]) → inj₂ ( 1 + w , s≤s ≤-refl , mfr[1+w] )
                 ; rs (inj₂ mfr[w])   → inj₂ ( w , s≤s (m≤n+m w 1) , mfr[w]) }))

  ------------------------------------------------------------------------------
  -- MAIN PROPERTY
  ------------------------------------------------------------------------------
  -- From any n, we can reach any state m such that m is Even
  progressAlwaysEven : ∀ {n m : ℕ} → (n ≡_) l-t ((m ≤_) ∩ Even)
  progressAlwaysEven {n} {m} = viaWFR
                                 (myWFR {m})
                                 [P]l-t[Q∪Fx]
                                 λ w → [Fw]l-t[Q∪Fx]


module RandomAccessList.Standard.Numeral where

open import Data.List
open import Data.Nat
open import Data.Nat.Properties.Simple
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; trans; sym; inspect)
open PropEq.≡-Reasoning

data Digit : Set where
    zero : Digit
    one  : Digit

Binary : Set
Binary = List Digit

incr : Binary → Binary
incr []          = one  ∷ []
incr (zero ∷ xs) = one  ∷ xs
incr (one  ∷ xs) = zero ∷ incr xs

⟦_⟧ : Binary → ℕ
⟦ []        ⟧ = 0
⟦ zero ∷ xs ⟧ =     2 * ⟦ xs ⟧
⟦ one  ∷ xs ⟧ = 1 + 2 * ⟦ xs ⟧

*-0-absorb : (n m : ℕ) → n ≡ 0 → m * n ≡ 0
*-0-absorb n m p =
    begin
        m * n
    ≡⟨ cong (_*_ m) p ⟩
        m * 0
    ≡⟨ *-right-zero m ⟩
        0
    ∎

decr : (xs : Binary) → ⟦ xs ⟧ ≢ 0 → Binary
decr []          p = ⊥-elim (p refl)
decr (zero ∷ xs) p = one  ∷ decr xs (contraposition (*-0-absorb ⟦ xs ⟧ 2) p)
decr (one  ∷ xs) p = zero ∷ xs


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

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

  data _even : ℕ → Set where
    ZERO : zero even
    STEP : ∀ x → x even → suc (suc x) even

  proof₁ : suc (suc (suc (suc zero))) even
  proof₁ = STEP (suc (suc zero)) (STEP zero ZERO)


-- Long version, the final version is Nat.agda
module NatTry where

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

one two three four : ℕ
one   = suc zero
two   = suc one
three = suc two
four  = suc three

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

data Bool : Set where
  true  : Bool
  false : Bool

_≟_ : ℕ → ℕ → Bool
zero  ≟ zero  = true
suc a ≟ suc b = a ≟ b
_     ≟ _     = false

infix 4 _≟_

assocProp : ℕ → ℕ → ℕ → Bool
assocProp a b c =  (a + b) + c ≟ a + (b + c)

reflProp : ℕ → Bool
reflProp n =  n ≟ n

module isTrue-direct where

  data isTrue : Bool → Set where
    ok : isTrue true

  unitTest : isTrue (assocProp one one two)
  unitTest = ok

  refl-True : (n : ℕ) → isTrue (reflProp n)
  refl-True zero = ok
  refl-True (suc n) = refl-True n

  assocProp-zero-True : (n m : ℕ) → isTrue (assocProp zero n m)
  assocProp-zero-True n m = refl-True (n + m)

  assocProp-True : (n m k : ℕ) → isTrue (assocProp n m k)
  assocProp-True zero    m k = assocProp-zero-True m k
  assocProp-True (suc n) m k = assocProp-True n m k

-------- switch to _≡_

module ≡-Bool where

  -- propositional equalitiy on Bool
  data _≡_ : Bool → Bool → Set where
    refl : {a : Bool} → a ≡ a  -- the Bool paramter is hidden

  infix 4 _≡_

  isTrue : Bool → Set
  isTrue x = x ≡ true

-- generic propositional equality
data _≡_ {A : Set} : A → A → Set where
  refl : {a : A} → a ≡ a

infix 4 _≡_

-- This is the type of the refl constructor
-- The parameters are hidden
refl′ : {A : Set} {a : A} → a ≡ a
refl′ = refl

isTrue : Bool → Set
isTrue x = x ≡ true

refl-True : (n : ℕ) → isTrue (reflProp n)
refl-True zero = refl
refl-True (suc n) = refl-True n

unitTest : isTrue (assocProp one one two)
unitTest = refl

assocProp-zero-True : (n m : ℕ) → isTrue (assocProp zero n m)
assocProp-zero-True n m = refl-True (n + m)

assocProp-True : (n m k : ℕ) → isTrue (assocProp n m k)
assocProp-True zero    m k = assocProp-zero-True m k
assocProp-True (suc n) m k = assocProp-True n m k

---- switch from _≟_

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

cong-suc : {a b : ℕ} → a ≡ b → suc a ≡ suc b
cong-suc = cong suc

≡-to-≟ : {a b : ℕ} → a ≡ b → isTrue (a ≟ b)
≡-to-≟ {a} refl = refl-True a

≟-to-≡ : (a b : ℕ) → isTrue (a ≟ b) → a ≡ b
≟-to-≡ zero zero i = refl
≟-to-≡ zero (suc b) ()
≟-to-≡ (suc a) zero ()
≟-to-≡ (suc a) (suc b) i = cong-suc (≟-to-≡ a b i)

-- the rest is in Nat.agda


module Numeral.Natural.Relation.Properties where

import Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Induction
open import Numeral.Natural.Relation
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Domain
open import Structure.Operator.Properties
open import Structure.Relator.Ordering
open import Structure.Relator.Properties
open import Type

[ℕ]-zero-or-nonzero : ∀{n : ℕ} → (n ≡ 𝟎)∨(n ≢ 𝟎)
[ℕ]-zero-or-nonzero {𝟎}    = [∨]-introₗ [≡]-intro
[ℕ]-zero-or-nonzero {𝐒(_)} = [∨]-introᵣ \()

[≡][ℕ]-excluded-middle : ∀{a b : ℕ} → (a ≡ b)∨(a ≢ b)
[≡][ℕ]-excluded-middle {𝟎}   {𝟎}    = [∨]-introₗ [≡]-intro
[≡][ℕ]-excluded-middle {𝟎}   {𝐒(_)} = [∨]-introᵣ \()
[≡][ℕ]-excluded-middle {𝐒(_)}{𝟎}    = [∨]-introᵣ \()
[≡][ℕ]-excluded-middle {𝐒(a)}{𝐒(b)} = [∨]-elim ([∨]-introₗ ∘ [≡]-with(𝐒)) ([∨]-introᵣ ∘ (contrapositiveᵣ(injective(𝐒)))) ([≡][ℕ]-excluded-middle {a}{b})


module Nats.Multiply.Comm where

open import Nats
open import Equality
open import Function

open import Nats.Add.Comm
open import Nats.Add.Assoc

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

private

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

  a+a*b=a*++b : ∀ a b → a + a * b ≡ a * suc b
  a+a*b=a*++b  zero   _ = refl
  a+a*b=a*++b (suc a) b
    rewrite nat-add-comm b $ a * suc b
          | nat-add-comm b $ a * b
          | sym $ nat-add-assoc a (a * b) b
          | a+a*b=a*++b a b
            = refl

  a*b=b*a : ∀ a b → a * b ≡ b * a
  a*b=b*a  zero   b
    rewrite a*0=0*a b = refl
  a*b=b*a (suc a) b
    rewrite a*b=b*a a b
          | a+a*b=a*++b b a
            = refl

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

nat-multiply-comm : ∀ a b → a * b ≡ b * a
nat-multiply-comm = a*b=b*a


module plfa.part1.Equality where

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

infix 4 _≡_

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

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

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

cong₂ : ∀ {A B C : Set} (f : A → B → C) {u x : A} {v y : B} → u ≡ x → v ≡ y → f u v ≡ f x y
cong₂ f refl refl = refl

cong-app : ∀ {A B : Set} {f g : A → B} → f ≡ g → ∀ (x : A) → f x ≡ g x
cong-app refl x = refl

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

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

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

postulate
  +-identity : ∀ (m : ℕ) → m + zero ≡ m
  +-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)


------------------------------------------------------------------------------
-- Well-founded induction on natural numbers
------------------------------------------------------------------------------

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

-- Adapted from
-- http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/
-- and the Agda standard library 0.8.1.

module FOTC.Induction.WF where

open import Common.Relation.Unary

open import FOTC.Base

------------------------------------------------------------------------------
-- The accessibility predicate: x is accessible if everything which is
-- smaller than x is also accessible (inductively).
data Acc (P : D → Set)(_<_ : D → D → Set)(x : D) : Set where
 acc : (∀ {y} → P y → y < x → Acc P _<_ y) → Acc P _<_ x

accFold : {P Q : D → Set}(_<_ : D → D → Set) →
          (∀ {x} → Q x → (∀ {y} → Q y → y < x → P y) → P x) →
          ∀ {x} → Q x → Acc Q _<_ x → P x
accFold _<_ f Qx (acc h) = f Qx (λ Qy y<x → accFold _<_ f Qy (h Qy y<x))

-- The accessibility predicate encodes what it means to be
-- well-founded; if all elements are accessible, then _<_ is
-- well-founded.
WellFounded : {P : D → Set} → (D → D → Set) → Set
WellFounded {P} _<_ = ∀ {x} → P x → Acc P _<_ x

WellFoundedInduction : {P Q : D → Set}
                       {_<_ : D → D → Set} →
                       WellFounded _<_ →
                       (∀ {x} → Q x → (∀ {y} → Q y → y < x → P y) → P x) →
                       ∀ {x} → Q x → P x
WellFoundedInduction {_<_ = _<_} wf f Qx = accFold _<_ f Qx (wf Qx)

module Subrelation {P        : D → Set}
                   {_<_ _<'_ : D → D → Set}
                   (<⇒<'     : ∀ {x y} → P x → x < y → x <' y)
                   where

  accessible : Acc P _<'_ ⊆ Acc P _<_
  accessible (acc h) = acc (λ Py y<x → accessible (h Py (<⇒<' Py y<x)))

  well-founded : WellFounded _<'_ → WellFounded _<_
  well-founded wf = λ Px → accessible (wf Px)

module InverseImage {P Q : D → Set}
                    {_<_ : D → D → Set}
                    {f   : D → D}
                    (f-Q : ∀ {x} → P x → Q (f x))
                    where

  accessible : ∀ {x} → P x →
               Acc Q _<_ (f x) → Acc P (λ x' y' → f x' < f y') x
  accessible Px (acc h) =
    acc (λ {y} Py fy<fx → accessible Py (h (f-Q Py) fy<fx))

  wellFounded : WellFounded _<_ → WellFounded (λ x y → f x < f y)
  wellFounded wf = λ Px → accessible Px (wf (f-Q Px))


open import Relation.Binary.Core

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

open import BBSTree _≤_
open import Bound.Total A
open import Bound.Total.Order _≤_
open import Data.List
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import TreeSort.Impl2 _≤_ tot≤

lemma-insert-/ : {a b : Bound}{x : A}(a≤x : LeB a (val x))(x≤b : LeB (val x) b)(t : BBSTree a b) → (flatten (insert a≤x x≤b t)) / x ⟶ (flatten t)
lemma-insert-/ a≤x x≤b (bslf _) = /head
lemma-insert-/ {x = x} b≤x x≤t (bsnd {x = y} b≤y y≤t l r)
    with tot≤ x y
... | inj₁ x≤y = lemma++/r (lemma-insert-/ b≤x (lexy x≤y) l)
... | inj₂ y≤x = lemma++/l {xs = flatten l} (/tail (lemma-insert-/ (lexy y≤x) x≤t r))

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


{-
   Copyright (c) 2017 Diego Pedraza.

   This is Free/Libre Open Source Software, released under the MIT License.
   For the full copyright and license information, please view the LICENSE
   file that was distributed with this source code.
 -}

module R2 where

open import Data.List using (List; _∷_; _++_; [_]; [])
open import Data.Nat
open import Data.Bool

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

{- ---------------------------------------------------------------
  Ejercicio 1.1. Definir la función
     sumaImpares :: nat ⇒ nat
  tal que (sumaImpares n) es la suma de los n primeros números
  impares. Por ejemplo,
     sumaImpares 5  =  25
  ---------------------------------------------------------------- -}

sumaImpares : ℕ → ℕ
sumaImpares 0 = 0
sumaImpares (suc n) = (2 * n + 1) + sumaImpares n

{- ---------------------------------------------------------------
  Ejercicio 1.2. Demostrar que
     sumaImpares n = n*n
  ----------------------------------------------------------------- -}
_≡_ : ℕ → ℕ → Bool
0 ≡ 0 = true
(suc n) ≡ (suc m) = n ≡ m
n ≡ 0 = false
0 ≡ m = false

lemaSumaImpares : {n : ℕ} → (sumaImpares n) ≡ (n * n)
lemaSumaImpares {zero} = ?
lemaSumaImpares {suc n} = ?

{-

{- ---------------------------------------------------------------
  Ejercicio 2.1. Definir la función
     sumaPotenciasDeDosMasUno :: nat ⇒ nat
  tal que
     (sumaPotenciasDeDosMasUno n) = 1 + 2^0 + 2^1 + 2^2 + ... + 2^n.
  Por ejemplo,
     sumaPotenciasDeDosMasUno 3  =  16
  ---------------------------------------------------------------- -}

fun sumaPotenciasDeDosMasUno :: "nat ⇒ nat" where
  "sumaPotenciasDeDosMasUno n = undefined"

{- ---------------------------------------------------------------
  Ejercicio 2.2. Demostrar que
     sumaPotenciasDeDosMasUno n = 2^(n+1)
  ----------------------------------------------------------------- -}

lemma "sumaPotenciasDeDosMasUno n = 2^(n+1)"
  oops

{- ---------------------------------------------------------------
  Ejercicio 3.1. Definir la función
     copia :: nat ⇒ 'a ⇒ 'a list
  tal que (copia n x) es la lista formado por n copias del elemento
  x. Por ejemplo,
     copia 3 x = [x,x,x]
  ---------------------------------------------------------------- -}

fun copia :: "nat ⇒ 'a ⇒ 'a list" where
  "copia n x = undefined"

{- ---------------------------------------------------------------
  Ejercicio 3.2. Definir la función
     todos :: ('a ⇒ bool) ⇒ 'a list ⇒ bool
  tal que (todos p xs) se verifica si todos los elementos de xs cumplen
  la propiedad p. Por ejemplo,
     todos (λx. x>(1::nat)) [2,6,4] = True
     todos (λx. x>(2::nat)) [2,6,4] = False
  Nota: La conjunción se representa por ∧
  --------------------------------------------------------------- -}

fun todos :: "('a ⇒ bool) ⇒ 'a list ⇒ bool" where
  "todos p xs = undefined"

{- ---------------------------------------------------------------
  Ejercicio 3.3. Demostrar que todos los elementos de (copia n x) son
  iguales a x.
  ----------------------------------------------------------------- -}

lemma "todos (λy. y=x) (copia n x)"
  oops

{- ---------------------------------------------------------------
  Ejercicio 4.1. Definir, recursivamente y sin usar (@), la función
     amplia :: 'a list ⇒ 'a ⇒ 'a list
  tal que (amplia xs y) es la lista obtenida añadiendo el elemento y al
  final de la lista xs. Por ejemplo,
     amplia [d,a] t = [d,a,t]
  ---------------------------------------------------------------- -}

fun amplia :: "'a list ⇒ 'a ⇒ 'a list" where
  "amplia xs y = undefined"

{- ---------------------------------------------------------------
  Ejercicio 4.2. Demostrar que
     amplia xs y = xs @ [y]
  ----------------------------------------------------------------- -}

lemma "amplia xs y = xs @ [y]"
  oops
-}


module Agda.Builtin.Nat where

open import Agda.Builtin.Bool

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

{-# BUILTIN NATURAL Nat #-}

infix  4 _==_ _<_
infixl 6 _+_ _-_
infixl 7 _*_

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

{-# BUILTIN NATPLUS _+_ #-}

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

{-# BUILTIN NATMINUS _-_ #-}

_*_ : Nat → Nat → Nat
zero  * m = zero
suc n * m = m + n * m

{-# BUILTIN NATTIMES _*_ #-}

_==_ : Nat → Nat → Bool
zero  == zero  = true
suc n == suc m = n == m
_     == _     = false

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

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

{-# BUILTIN NATLESS _<_ #-}

div-helper : Nat → Nat → Nat → Nat → Nat
div-helper k m  zero    j      = k
div-helper k m (suc n)  zero   = div-helper (suc k) m n m
div-helper k m (suc n) (suc j) = div-helper k m n j

{-# BUILTIN NATDIVSUCAUX div-helper #-}

mod-helper : Nat → Nat → Nat → Nat → Nat
mod-helper k m  zero    j      = k
mod-helper k m (suc n)  zero   = mod-helper 0 m n m
mod-helper k m (suc n) (suc j) = mod-helper (suc k) m n j

{-# BUILTIN NATMODSUCAUX mod-helper #-}


module *-assoc where

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

open import *-distrib-+ using (*-distrib-+)

-- 積の結合律 (associativity)
*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc zero n p =
  begin
    (zero * n) * p
  ≡⟨⟩
    zero * p
  ≡⟨⟩
    zero
  ≡⟨⟩
    zero * (n * p)
  ∎
*-assoc (suc m) n p =
  begin
    ((suc m) * n) * p
  ≡⟨⟩
    (n + m * n) * p
  ≡⟨ *-distrib-+ n (m * n) p ⟩
    (n * p) + m * n * p
  ≡⟨ cong ((n * p) +_) (*-assoc m n p) ⟩
    (n * p) + m * (n * p)
  ≡⟨⟩
    (suc m) * (n * p)
  ∎


module nat where

open import product
open import bool
open import maybe
open import eq

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

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

nat = ℕ

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

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

-- pragmas to get decimal notation:

{-# BUILTIN NATURAL ℕ #-}

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

---------------------------------------
-- basic arithmetic operations
---------------------------------------

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

{-# BUILTIN NATPLUS _+_ #-}

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

{-# BUILTIN NATTIMES _*_ #-}

pred : ℕ → ℕ
pred 0 = 0
pred (suc n) = n

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

-- see nat-division.agda for division function

{-# BUILTIN NATMINUS _∸_ #-}

square : ℕ → ℕ
square x = x * x

--------------------------------------------------
-- comparisons
--------------------------------------------------

_<_ : ℕ → ℕ → 𝔹
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

_≤_ : ℕ → ℕ → 𝔹
x ≤ y = (x < y) || x =ℕ y

_>_ : ℕ → ℕ → 𝔹
a > b = b < a

_≥_ : ℕ → ℕ → 𝔹
a ≥ b = b ≤ a

min : ℕ → ℕ → ℕ
min x y = if x < y then x else y

max : ℕ → ℕ → ℕ
max x y = if x < y then y else x

data compare-t : Set where
  compare-lt : compare-t
  compare-eq : compare-t
  compare-gt : compare-t

compare : ℕ → ℕ → compare-t
compare 0 0 = compare-eq
compare 0 (suc y) = compare-lt
compare (suc x) 0 = compare-gt
compare (suc x) (suc y) = compare x y

iszero : ℕ → 𝔹
iszero 0 = tt
iszero _ = ff

parity : ℕ → 𝔹
parity 0 = ff
parity (suc x) = ~ (parity x)

_pow_ : ℕ → ℕ → ℕ
x pow 0 = 1
x pow (suc y) = x * (x pow y)

factorial : ℕ → ℕ
factorial 0 = 1
factorial (suc x) = (suc x) * (factorial 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


module Sandbox.PrimitiveRecursion where

open import Data.Nat
open import Data.Fin using (Fin)
open import Data.Vec

data PR : ℕ → Set where
    -- Constant function: The 0-ary constant function 0 is primitive recursive.
    K : PR 0

    -- Successor function: The 1-ary successor function S, which returns the
    -- successor of its argument (see Peano postulates), is primitive recursive.
    -- That is, S(k) = k + 1.
    S : PR 1

    -- Projection function: For every n≥1 and each i with 1≤i≤n, the n-ary
    -- projection function Pᵢⁿ, which returns its i-th argument, is primitive
    -- recursive.
    Proj : ∀ {n} → (i : Fin n) → PR n

    -- Composition: Given f, a m-ary primitive recursive function, and m n-ary
    -- primitive recursive functions g1,...,gm, the composition of f with
    -- g1,...,gk, is primitive recursive
    --  f(
    --      g₁(x₁, x₂, ..., xₙ)
    --      g₂(x₁, x₂, ..., xₙ)
    --      ...
    --      gₘ(x₁, x₂, ..., xₙ)
    --  )
    Comp : ∀ {m n} → (f : PR m) → Vec (PR n) m → PR n
    -- Primitive recursion: Given f, a m-ary primitive recursive function,
    -- and g, a (m+2)-ary primitive recursive function, the (m+1)-ary function
    -- h is defined as the primitive recursion of f and g, i.e. the function h
    -- is primitive recursive when
    --  h(0   , x₁, x₂, .. xₘ) = f(x₁, x₂, .. xₘ)
    --  h(S(n), x₁, x₂, .. xₘ) = g(n, h(n, x₁, x₂, .. xₘ), x₁, x₂, .. xₘ)
    Rec : ∀ {n} → (f : PR {!   !}) (g : PR (suc (suc n))) → PR (suc n)

mutual
    ⟦_⟧_ : ∀ {a} → PR a → Vec ℕ a → ℕ
    ⟦ K         ⟧ args           = zero
    ⟦ S         ⟧ args           = suc zero
    ⟦ Proj i    ⟧ args           = lookup i args
    ⟦ Comp f gs ⟧ args           = ⟦ f ⟧ (⟦ gs ⟧* args)
    ⟦ Rec  f g  ⟧ (zero  ∷ args) = ⟦ f ⟧ args
    ⟦ Rec  f g  ⟧ (suc x ∷ args) = ⟦ g ⟧ (x ∷ (⟦ f ⟧ args) ∷ args)

    ⟦_⟧* : {m n : ℕ} (gs : Vec (PR n) m) → Vec ℕ n → Vec ℕ m
    ⟦ []     ⟧* args = []
    ⟦ g ∷ gs ⟧* args = (⟦ g ⟧ args) ∷ ⟦ gs ⟧* args


module naturals where

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

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

{-# BUILTIN NATURAL ℕ #-}

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

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

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

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

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

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

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

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

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

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

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

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

-- 6)
data Bin : Set where
  - : Bin
  _O : Bin → Bin
  _I : Bin → Bin

inc : Bin → Bin
inc - = - I
inc (rest O) = rest I
inc (rest I) = (inc rest) O

to : ℕ → Bin
to zero = - O
to (suc n) = inc (to n)

from : Bin → ℕ
from - = 0
from (rest O) = 2 * from rest
from (rest I) = 2 * from rest + 1


module even where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Empty
open import Data.Unit using (⊤ ; tt)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Definitions
open import nat
open import logic

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

even? : (n : ℕ ) → Dec ( even n )
even? zero = yes tt
even? (suc zero) = no (λ ())
even? (suc (suc n)) = even? n

n+even : {n m : ℕ } → even n → even m  → even ( n + m )
n+even {zero} {zero} tt tt = tt
n+even {zero} {suc m} tt em = em
n+even {suc (suc n)} {m} en em = n+even {n} {m} en em

n*even : {m n : ℕ } → even n → even ( m * n )
n*even {zero} {n} en = tt
n*even {suc m} {n} en = n+even {n} {m * n} en (n*even {m} {n} en)

even*n : {n m : ℕ } → even n → even ( n * m )
even*n {n} {m} en = subst even (*-comm m n) (n*even {m} {n} en)

record Even (i : ℕ) : Set where
  field
     j : ℕ
     is-twice : i ≡ 2 * j

e2 : (i : ℕ) → even i → Even i
e2 zero en = record { j = 0 ; is-twice = refl }
e2 (suc (suc i)) en = record { j = suc (Even.j (e2 i en )) ; is-twice = e21 } where
   e21 : suc (suc i) ≡ 2 * suc (Even.j (e2 i en))
   e21 = begin
    suc (suc i)  ≡⟨ cong (λ k → suc (suc k)) (Even.is-twice (e2 i en))  ⟩
    suc (suc (2 * Even.j (e2 i en)))  ≡⟨ sym (*-distribˡ-+ 2 1 _) ⟩
    2 * suc (Even.j (e2 i en))      ∎ where open ≡-Reasoning

record Odd (i : ℕ) : Set where
  field
     j : ℕ
     is-twice : i ≡ suc (2 * j )

odd2 : (i : ℕ) → ¬ even i → even (suc i)
odd2 zero ne = ⊥-elim ( ne tt )
odd2 (suc zero) ne = tt
odd2 (suc (suc i)) ne = odd2 i ne

odd3 : (i : ℕ) → ¬ even i →  Odd i
odd3 zero ne = ⊥-elim ( ne tt )
odd3 (suc zero) ne = record { j = 0 ; is-twice = refl }
odd3 (suc (suc i))  ne = record { j = Even.j (e2 (suc i) (odd2 i ne)) ; is-twice = odd31 } where
  odd31 : suc (suc i) ≡ suc (2 * Even.j (e2 (suc i) (odd2 i ne)))
  odd31 = begin
    suc (suc i) ≡⟨  cong suc (Even.is-twice (e2 (suc i) (odd2 i ne)))  ⟩
    suc (2 * (Even.j (e2 (suc i) (odd2 i ne))))      ∎ where open ≡-Reasoning

odd4 : (i : ℕ) → even i → ¬ even ( suc i )
odd4 (suc (suc i)) en en1 = odd4 i en en1


module Nat.Sum where

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

open DecTotalOrder decTotalOrder hiding (refl)

+id : (n : ℕ) → n + zero ≡  n
+id zero = refl
+id (suc n) = cong suc (+id n)

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


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

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

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Data.Product
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import List.Permutation.Pair A
open import List.Permutation.Pair.Properties A
open import Mergesort.Impl1 _≤_ tot≤
open import Size
open import SList
open import SList.Properties
open import SOList.Lower _≤_

lemma-deal : {ι : Size} → (xs : SList A {ι}) → unsize A xs ≈ unsize× A (deal xs)
lemma-deal snil = ≈[]l []
lemma-deal (x ∙ snil) = ≈[]r (x ∷ [])
lemma-deal (x ∙ (y ∙ xs))
    with lemma-deal xs
... | xs≈ys,zs = ≈xl (≈xr xs≈ys,zs)

lemma-merge : {ι ι' : Size}{b : Bound}(xs : SOList {ι} b)(ys : SOList {ι'} b) → forget (merge xs ys) ≈ (forget xs , forget ys)
lemma-merge onil ys = ≈[]l (forget ys)
lemma-merge xs onil
    with xs
... | onil = ≈[]r []
... | (:< {x = z} b≤z zs) = ≈[]r (z ∷ forget zs)
lemma-merge (:< {x = x} b≤x xs)  (:< {x = y} b≤y ys)
    with tot≤ x y
... | inj₁ x≤y = ≈xl (lemma-merge xs (:< (lexy x≤y) ys))
... | inj₂ y≤x = ≈xr (lemma-merge (:< (lexy y≤x) xs) ys)

lemma-mergesort : {ι : Size}(xs : SList A {↑ ι}) → unsize A xs ∼ forget (mergesort xs)
lemma-mergesort snil = ∼[]
lemma-mergesort (x ∙ snil) = ∼x /head /head ∼[]
lemma-mergesort (x ∙ (y ∙ xs)) = lemma≈ (≈xl (≈xr (lemma-deal xs))) (lemma-mergesort (x ∙ ys)) (lemma-mergesort (y ∙ zs)) (lemma-merge (mergesort (x ∙ ys)) (mergesort (y ∙ zs)))
                where d = deal xs
                      ys = proj₁ d
                      zs = proj₂ d

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


module Nat where

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

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

{-# BUILTIN NATURAL ℕ #-}

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

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


module treeThms where

open import lib

-- simple Tree type storing natural numbers
data Tree : Set where
  Node : ℕ → Tree → Tree → Tree
  Leaf : Tree

mirror : Tree → Tree
mirror (Node x t1 t2) = Node x (mirror t2) (mirror t1)
mirror Leaf = Leaf

mirror-mirror : ∀ (t : Tree) → mirror (mirror t) ≡ t
mirror-mirror Leaf = refl
mirror-mirror (Node x t1 t2) rewrite mirror-mirror t2 | mirror-mirror t1 = refl

size : Tree → ℕ
size (Node x t t₁) = 1 + size t + size t₁
size Leaf = 1

height : Tree → ℕ
height (Node x t t₁) = 1 + (max (height t) (height t₁))
height Leaf = 0

numLeaves : Tree → ℕ
numLeaves (Node x t t₁) = numLeaves t + numLeaves t₁
numLeaves Leaf = 1

perfect : ℕ → Tree
perfect zero = Leaf
perfect (suc n) = Node 1 (perfect n) (perfect n)

-- I found I needed the +0 theorem from nat-thms.agda in the IAL
perfect-numLeaves : ∀(n : ℕ) → numLeaves (perfect n) ≡ 2 pow n
perfect-numLeaves zero = refl
perfect-numLeaves (suc n) rewrite +0 (2 pow n) |  perfect-numLeaves n  = refl

perfect-size : ∀(n : ℕ) → suc (size (perfect n)) ≡ 2 pow (suc n)
perfect-size zero = refl
perfect-size (suc n) rewrite  sym (perfect-size n) | +0 (size(perfect n)) | sym (+suc(size(perfect n))(size(perfect n)))= refl

-- helper lemma I found I needed below
max-same : ∀ (n : ℕ) → max n n ≡ n
max-same n rewrite <-irrefl n = refl

perfect-height : ∀(n : ℕ) → height (perfect n) ≡ n
perfect-height zero = refl
perfect-height (suc n) rewrite max-same (height(perfect n)) | perfect-height n = refl

numNodes : Tree → ℕ
numNodes (Node x t1 t2) = 1 + numNodes t1 + numNodes t2
numNodes Leaf = 0

-- flatten a tree into a list of all the values stored at the nodes
prefixFlatten : Tree → 𝕃 ℕ
prefixFlatten (Node x t1 t2) = x :: prefixFlatten t1 ++ prefixFlatten t2
prefixFlatten Leaf = []

-- I found I needed a theorem from list-thms.agda in the IAL
length-flatten : ∀(t : Tree) → numNodes t ≡ length (prefixFlatten t)
length-flatten (Node x t1 t2) rewrite length-++(prefixFlatten t1) (prefixFlatten t2) | length-flatten t1 | length-flatten t2 = refl
length-flatten Leaf = refl


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

open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Product
open import Data.Bool hiding (_≤_;_<_)
open import Data.Nat.Properties

open ≡-Reasoning

div-mod2 : ℕ → ℕ × Bool
div-mod2 0 = 0 , false
div-mod2 (suc 0) = 0 , true
div-mod2 (suc (suc n)) = let q , r = div-mod2 n in suc q , r

-- The first argument (k) helps Agda to prove
-- that the function terminates
pow-sqr-aux : ℕ → ℕ → ℕ → ℕ
pow-sqr-aux 0 _ _ = 1
pow-sqr-aux _ _ 0 = 1
pow-sqr-aux (suc k) b e with div-mod2 e
... | e' , false = pow-sqr-aux k (b * b) e'
... | e' , true = b * pow-sqr-aux k (b * b) e'

pow-sqr : ℕ → ℕ → ℕ
pow-sqr b e = pow-sqr-aux e b e

div-mod2-spec : ∀ n → let q , r = div-mod2 n in 2 * q + (if r then 1 else 0) ≡ n
div-mod2-spec 0 = refl
div-mod2-spec 1 = refl
div-mod2-spec (suc (suc n)) with div-mod2 n | div-mod2-spec n
... | q , r | eq rewrite +-suc q (q + 0) | eq = refl

div-mod2-lt : ∀ n → 0 < n → proj₁ (div-mod2 n) < n
div-mod2-lt 0 lt = lt
div-mod2-lt 1 lt = lt
div-mod2-lt 2 lt = s≤s (s≤s z≤n)
div-mod2-lt (suc (suc (suc n))) lt with
  div-mod2 (suc n) | div-mod2-lt (suc n) (s≤s z≤n)
... | q , r | ih = ≤-step (s≤s ih)

pow-lemma : ∀ b e → (b * b) ^ e ≡ b ^ (2 * e)
pow-lemma b e = begin
  (b * b) ^ e ≡⟨ cong (λ t → (b * t) ^ e) (sym (*-identityʳ b)) ⟩
  (b ^ 2) ^ e ≡⟨ ^-*-assoc b 2 e ⟩
  b ^ (2 * e) ∎

pow-sqr-lemma : ∀ k b e → e ≤ k → pow-sqr-aux k b e ≡ b ^ e
pow-sqr-lemma 0 _ 0 _ = refl
pow-sqr-lemma (suc k) _ 0 _ = refl
pow-sqr-lemma (suc k) b (suc e) (s≤s le) with
  div-mod2 (suc e) | div-mod2-spec (suc e) | div-mod2-lt (suc e) (s≤s z≤n)
... | e' , false | eq | lt = begin
  pow-sqr-aux k (b * b) e' ≡⟨ pow-sqr-lemma k (b * b) e' (≤-trans (≤-pred lt) le) ⟩
  (b * b) ^ e' ≡⟨ pow-lemma b e' ⟩
  b ^ (2 * e') ≡⟨ cong (b ^_) (trans (sym (+-identityʳ (e' + (e' + 0)))) eq) ⟩
  b ^ suc e ∎
... | e' , true | eq | lt = cong (b *_) (begin
  pow-sqr-aux k (b * b) e' ≡⟨ pow-sqr-lemma k (b * b) e' (≤-trans (≤-pred lt) le) ⟩
  (b * b) ^ e' ≡⟨ pow-lemma b e' ⟩
  b ^ (2 * e') ≡⟨ cong (b ^_) (suc-injective (trans (+-comm 1 _) eq)) ⟩
  b ^ e ∎)


open import Relation.Binary.Core

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

open import BBSTree _≤_
open import Bound.Total A
open import Bound.Total.Order.Properties _≤_ trans≤
open import List.Order.Simple _≤_
open import List.Order.Simple.Properties _≤_ trans≤
open import List.Sorted _≤_

lemma-bbst-*≤ : {b : Bound}(x : A) → (t : BBSTree b (val x)) → flatten t *≤ x
lemma-bbst-*≤ x (bslf _) = lenx
lemma-bbst-*≤ x (bsnd {x = y} b≤y y≤x l r) = lemma-++-*≤ (lemma-LeB≤ y≤x) (lemma-bbst-*≤ y l) (lemma-bbst-*≤ x r)

lemma-bbst-≤* : {b : Bound}(x : A) → (t : BBSTree (val x) b) → x ≤* flatten t
lemma-bbst-≤* x (bslf _) = genx
lemma-bbst-≤* x (bsnd {x = y} x≤y y≤t l r) = lemma-≤*-++ (lemma-LeB≤ x≤y) (lemma-bbst-≤* x l) (lemma-bbst-≤* y r)

lemma-bbst-sorted : {b t : Bound}(t : BBSTree b t) → Sorted (flatten t)
lemma-bbst-sorted (bslf _) = nils
lemma-bbst-sorted (bsnd {x = x} b≤x x≤t l r) = lemma-sorted++ (lemma-bbst-*≤ x l) (lemma-bbst-≤* x r) (lemma-bbst-sorted l) (lemma-bbst-sorted r)


module x01-842Naturals-hc-2 where

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

one : ℕ
one = suc zero

two : ℕ
two = suc (suc zero)

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

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

_ : seven ≡ 7
_ = refl

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

_ : 2 + 3 ≡ 5
_ = refl

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

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

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

_ : 3 * 4 ≡ 12
_ = refl

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

_ : 2 ^ 0 ≡ 1
_ = refl

_ : 2 ^ 1 ≡ 2
_ = refl

_ : 2 ^ 2 ≡ 4
_ = refl

_ : 2 ^ 3 ≡ 8
_ = refl

_ : 3 ^ 3 ≡ 27
_ = refl

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

_ : 3 ∸ 2 ≡ 1
_ = refl

_ : 2 ∸ 3 ≡ 0
_ = refl

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

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

-- Binary representation.

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

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

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

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

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

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

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

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

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

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

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

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

_ : fromb  bits           ≡ 0
_ = refl
_ : fromb (bits       x0) ≡ 0
_ = refl
_ : fromb (bits       x1) ≡ 1
_ = refl
_ : fromb (bits    x1 x0) ≡ 2
_ = refl
_ : fromb (bits    x1 x1) ≡ 3
_ = refl
_ : fromb (bits x1 x1 x0) ≡ 6
_ = refl
_ : fromb (bits x1 x1 x0) ≡ 6
_ = refl

-- Do NOT use 'to' and 'from'. Work with Bin-ℕ as if ℕ did not exist.
_bin-+_ : Bin-ℕ → Bin-ℕ → Bin-ℕ
bits   bin-+     n  =                    n
m      bin-+  bits  =            m
(m x0) bin-+ (n x0) =           (m bin-+ n) x0
(m x0) bin-+ (n x1) =      inc ((m bin-+ n) x0)
(m x1) bin-+ (n x0) =      inc ((m bin-+ n) x0)
(m x1) bin-+ (n x1) = inc (inc ((m bin-+ n) x0))

_ : (bits x1 x0 x0 x0) bin-+ (bits x1) ≡ (bits x1 x0 x0 x1)
_ = refl
_ : (bits x1 x0 x0 x1) bin-+ (bits x1) ≡ (bits x1 x0 x1 x0)
_ = refl
_ : (bits x1 x0 x0 x0) bin-+ (bits x1 x1 x1) ≡ (bits x1 x1 x1 x1)
_ = refl
_ : (tob 6) bin-+ (tob 2) ≡ (tob 8)
_ = refl
_ : (bits x1 x0) bin-+ (bits x1 x1) ≡ (bits x1 x0 x1)
_ = refl


module Logic.Relations where

import Logic.Base
import Data.Bool

Rel : Set -> Set1
Rel A = A -> A -> Set

Reflexive : {A : Set} -> Rel A -> Set
Reflexive {A} _R_ = (x : A) -> x R x

Symmetric : {A : Set} -> Rel A -> Set
Symmetric {A} _R_  = (x y : A) -> x R y -> y R x

Transitive : {A : Set} -> Rel A -> Set
Transitive {A} _R_ = (x y z : A) -> x R y -> y R z -> x R z

Congruent : {A : Set} -> Rel A -> Set
Congruent {A} _R_ = (f : A -> A)(x y : A) -> x R y -> f x R f y

Substitutive : {A : Set} -> Rel A -> Set1
Substitutive {A} _R_ = (P : A -> Set)(x y : A) -> x R y -> P x -> P y

module PolyEq (_≡_ : {A : Set} -> Rel A) where

  Antisymmetric : {A : Set} -> Rel A -> Set
  Antisymmetric {A} _R_ = (x y : A) -> x R y -> y R x -> x ≡ y

module MonoEq {A : Set}(_≡_ : Rel A) where

  Antisymmetric : Rel A -> Set
  Antisymmetric _R_ = (x y : A) -> x R y -> y R x -> x ≡ y

open Logic.Base

Total : {A : Set} -> Rel A -> Set
Total {A} _R_ = (x y : A) -> (x R y) \/ (y R x)

Decidable : (P : Set) -> Set
Decidable P = P \/ ¬ P


module Peano where
  open import IPL

  data ℕ : Set where
    zero : ℕ -- Axiom 2.1. 0 is a natural number
    _++ : ℕ → ℕ -- Axiom 2.2. If n is a natural number, then n++ is also a natural number

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

  axiom23 : {n : ℕ} → ¬ (zero ≡ (n ++))
  axiom23 = λ ()

  axiom24 : {n m : ℕ} → (n ++) ≡ (m ++) → n ≡ m
  axiom24 refl = refl

  _+_ : ℕ → ℕ → ℕ -- Definition 2.2.1
  zero + m = m
  (n ++) + m = (n + m) ++

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

  ≡-comm : {n m : ℕ} → n ≡ m → m ≡ n
  ≡-comm refl = refl

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

  lemma222 : (n : ℕ) → (n + zero) ≡ n
  lemma222 zero = refl
  lemma222 (n ++) = ≡-sec (lemma222 n)

  lemma223 : (n m : ℕ) → (n + (m ++)) ≡ ((n + m) ++)
  lemma223 zero m = refl
  lemma223 (n ++) m = ≡-sec (lemma223 n m)

  -- Addition is commutative
  prop224 : (n m : ℕ) → (n + m) ≡ (m + n)
  prop224 zero m = ≡-comm (lemma222 m)
  prop224 (n ++) m = ≡-trans (≡-sec (prop224 n m)) (≡-comm (lemma223 m n))

  -- Addition is associative
  prop225 : (a b c : ℕ) → ((a + b) + c) ≡ (a + (b + c))
  prop225 zero b c = refl
  prop225 (a ++) b c = ≡-sec (prop225 a b c)

  -- Cancellation law
  prop226 : (a b c : ℕ) → (a + b) ≡ (a + c) → b ≡ c
  prop226 zero b c = λ z → z
  prop226 (a ++) b c = λ z → (prop226 a b c) (axiom24 z)