-- To be able to run the code download and install Agda with the standard
-- library from:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php
--
module GuestLecture where
open import Data.Nat
open import Relation.Binary.PropositionalEquality as PropEq hiding ([_])
open PropEq.≡-Reasoning
infixr 5 _∷_ _++_ _^_
data String Σ : Set where
ε : String Σ
_∷_ : Σ → String Σ → String Σ
exℕ : String ℕ
exℕ = 1 ∷ 2 ∷ 3 ∷ ε
-- concatenation
_++_ : ∀ {Σ} → String Σ -> String Σ -> String Σ
ε ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys
-- length
∣_∣ : ∀ {Σ} → String Σ → ℕ
∣ ε ∣ = 0
∣ x ∷ xs ∣ = 1 + ∣ xs ∣
-- power
_^_ : ∀ {Σ} → String Σ → ℕ → String Σ
xs ^ 0 = ε
xs ^ suc n = xs ++ xs ^ n
-- properties
length-concat : ∀ {Σ} (xs ys : String Σ) → ∣ xs ++ ys ∣ ≡ ∣ xs ∣ + ∣ ys ∣
length-concat ε ys = refl
length-concat (x ∷ xs) ys = cong suc (length-concat xs ys)
length-power : ∀ {Σ} (xs : String Σ) (n : ℕ) → ∣ xs ^ n ∣ ≡ n * ∣ xs ∣
length-power xs zero = refl
length-power xs (suc n) = begin
∣ xs ++ xs ^ n ∣ ≡⟨ length-concat xs (xs ^ n) ⟩
∣ xs ∣ + ∣ xs ^ n ∣ ≡⟨ cong (_+_ ∣ xs ∣) (length-power xs n) ⟩
∣ xs ∣ + n * ∣ xs ∣ ∎
-- This can be done with rewrite by:
-- rewrite length-concat xs (xs ^ n) | length-power xs n = refl
-- singleton
[_] : ∀ {Σ} → Σ → String Σ
[ x ] = x ∷ ε
-- reverse
rev : ∀ {Σ} → String Σ → String Σ
rev ε = ε
rev (x ∷ xs) = rev xs ++ [ x ]
concat-assoc : ∀ {Σ} (xs ys zs : String Σ) → xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs
concat-assoc ε ys zs = refl
concat-assoc (x ∷ xs) ys zs = cong (_∷_ x) (concat-assoc xs ys zs)
concat-nil : ∀ {Σ} (xs : String Σ) → xs ++ ε ≡ xs
concat-nil ε = refl
concat-nil (x ∷ xs) = cong (_∷_ x) (concat-nil xs)
rev-concat : ∀ {Σ} → (xs ys : String Σ) → rev (xs ++ ys) ≡ rev ys ++ rev xs
rev-concat ε ys = sym (concat-nil _)
rev-concat (x ∷ xs) ys = begin
rev (xs ++ ys) ++ x ∷ ε ≡⟨ cong (λ z → z ++ x ∷ ε) (rev-concat xs ys) ⟩
(rev ys ++ rev xs) ++ x ∷ ε ≡⟨ sym (concat-assoc (rev ys) (rev xs) (x ∷ ε)) ⟩
rev ys ++ rev xs ++ x ∷ ε ∎
-- rewrite rev-concat xs ys = sym (concat-assoc (rev ys) (rev xs) (x ∷ ε))
rev-rev : ∀ {Σ} → (xs : String Σ) → rev (rev xs) ≡ xs
rev-rev ε = refl
rev-rev (x ∷ xs) = begin
rev (rev xs ++ x ∷ ε) ≡⟨ rev-concat (rev xs) (x ∷ ε) ⟩
x ∷ rev (rev xs) ≡⟨ cong (_∷_ x) (rev-rev xs) ⟩
x ∷ xs ∎
-- Fibonacci:
-- fib 30
fib : ℕ → ℕ
fib 0 = 0
fib 1 = 1
fib (suc (suc n)) = fib n + fib (suc n)
-- tail-recursive version:
f : ℕ → ℕ → ℕ → ℕ
f 0 a b = a
f (suc n) a b = f n b (a + b)
-- fast_fib 30
fast_fib : ℕ → ℕ
fast_fib n = f n 0 1
n+0≡n : ∀ n → n + 0 ≡ n
n+0≡n 0 = refl
n+0≡n (suc n) = cong suc (n+0≡n n)
1+m+n≡m+1+n : ∀ m n → suc (m + n) ≡ m + suc n
1+m+n≡m+1+n 0 _ = refl
1+m+n≡m+1+n (suc m) n = cong suc (1+m+n≡m+1+n m n)
key-lemma : ∀ n k → f n (fib k) (fib (suc k)) ≡ fib (k + n)
key-lemma 0 k = sym (cong fib (n+0≡n k))
key-lemma (suc n) k = begin
f n (fib (suc k)) (fib k + fib (suc k)) ≡⟨ key-lemma n (suc k) ⟩
fib (suc (k + n)) ≡⟨ cong fib (1+m+n≡m+1+n k n) ⟩
fib (k + suc n) ∎
fast_fib_correct : ∀ n → fast_fib n ≡ fib n
fast_fib_correct n = key-lemma n 0