added trial of Reasoning

This commit is contained in:
wadler 2018-01-09 14:45:11 -02:00
parent 7d516c8a9f
commit cf7a6b5c56
6 changed files with 133 additions and 32 deletions

View file

@ -68,11 +68,11 @@ and `A × C ⊎ B × C` parses as `(A × C) ⊎ (B × C)`.
Distribution of `×` over `⊎` is an isomorphism.
\begin{code}
data _≃_ : Set → Set → Set where
iso : ∀ {A B : Set} → (f : A → B) → (g : B → A) →
mk-≃ : ∀ {A B : Set} → (f : A → B) → (g : B → A) →
(∀ (x : A) → g (f x) ≡ x) → (∀ (y : B) → f (g y) ≡ y) → A ≃ B
×-distributes-+ : ∀ {A B C : Set} → ((A ⊎ B) × C) ≃ ((A × C) ⊎ (B × C))
×-distributes-+ = iso f g gf fg
×-distributes-+ = mk-≃ f g gf fg
where
f : ∀ {A B C : Set} → (A ⊎ B) × C → (A × C) ⊎ (B × C)
@ -94,12 +94,12 @@ data _≃_ : Set → Set → Set where
Distribution of `⊎` over `×` is half an isomorphism.
\begin{code}
data _≃ʳ_ : Set → Set → Set where
isoʳ : ∀ {A B : Set} → (f : A → B) → (g : B → A) →
(∀ (x : A) → g (f x) ≡ x) → A ≃ʳ B
data __ : Set → Set → Set where
mk-≲ : ∀ {A B : Set} → (f : A → B) → (g : B → A) →
(∀ (x : A) → g (f x) ≡ x) → A B
+-distributes-× : ∀ {A B C : Set} → ((A × B) ⊎ C) ≃ʳ ((A ⊎ C) × (B ⊎ C))
+-distributes-× = isoʳ f g gf
+-distributes-× : ∀ {A B C : Set} → ((A × B) ⊎ C) ((A ⊎ C) × (B ⊎ C))
+-distributes-× = mk-≲ f g gf
where
f : ∀ {A B C : Set} → (A × B) ⊎ C → (A ⊎ C) × (B ⊎ C)

View file

@ -518,27 +518,27 @@ QED.
Lemma (xi).
n + suc m ≡ suc (n + m)
m + suc n ≡ suc (m + n)
Proof. By induction on `n`.
Proof. By induction on `m`.
Base case.
zero + suc m
zero + suc n
≡ (i)
suc m
suc n
≡ (i)
suc (zero + m)
suc (zero + n)
Inductive case.
suc n + suc m
suc m + suc n
≡ (ii)
suc (n + suc m)
suc (m + suc n)
≡ (inductive hypothesis)
suc (suc (n + m))
suc (suc (m + n))
≡ (ii)
suc (suc n + m)
suc (suc m + n)
QED.
@ -550,13 +550,13 @@ These proofs can be encoded concisely in Agda.
+-identity zero = refl
+-identity (suc n) rewrite +-identity n = refl
+-suc : ∀ (m n : ) → n + suc m ≡ suc (n + m)
+-suc m zero = refl
+-suc m (suc n) rewrite +-suc m n = refl
+-suc : ∀ (m n : ) → m + suc n ≡ suc (m + n)
+-suc zero n = refl
+-suc (suc m) n rewrite +-suc m n = refl
+-comm : ∀ (m n : ) → m + n ≡ n + m
+-comm zero n rewrite +-identity n = refl
+-comm (suc m) n rewrite +-suc m n | +-comm m n = refl
+-comm (suc m) n rewrite +-suc n m | +-comm m n = refl
\end{code}
Here we have renamed Lemma (x) and (xi) to `+-identity` and `+-suc`,
respectively. In the final line, rewriting with two equations is

View file

@ -457,17 +457,17 @@ data Trichotomy : → Set where
+ *Even and odd* Another example of a useful relation is to define
even and odd numbers, as done below. Using these definitions, show
that if `n` is even then there exists an `m` such that `n ≡ 2 * m`,
and if `n` is odd then there exists an `m` such that `n ≡ 2 * m + 1`.
(This exercise requires existentials from the chapter on Logic.)
- the sum of two even numbers is even
- the sum of an even and an odd number is odd
- the sum of two odd numbers is even
\begin{code}
mutual
data even : → Set where
zero : even zero
suc : ∀ {n : } → odd n → even (suc n)
ev-zero : even zero
ev-suc : ∀ {n : } → odd n → even (suc n)
data odd : → Set where
suc : ∀ {n : } → even n → odd (suc n)
od-suc : ∀ {n : } → even n → odd (suc n)
\end{code}
The keyword `mutual` indicates that the nested definitions
are mutually recursive.

View file

@ -46,6 +46,22 @@ trichotomy (suc m) (suc n) with trichotomy m n
*Even and odd*
\begin{code}
+-evev : ∀ {m n : } → even m → even n → even (m + n)
+-evev ev-zero evn = evn
+-evev (ev-suc (od-suc evm)) evn = ev-suc (od-suc (+-evev evm evn))
+-evod : ∀ {m n : } → even m → odd n → odd (m + n)
+-evod ev-zero odn = odn
+-evod (ev-suc (od-suc evm)) odn = od-suc (ev-suc (+-evod evm odn))
+-odev : ∀ {m n : } → odd m → even n → odd (m + n)
+-odev (od-suc evm) evn = od-suc (+-evev evm evn)
+-odod : ∀ {m n : } → odd m → odd n → even (m + n)
+-odod (od-suc evm) odn = ev-suc (+-evod evm odn)
\end{code}
\begin{code}
+-lemma : ∀ (m : ) → suc (suc (m + (m + 0))) ≡ suc m + (suc m + 0)
+-lemma m rewrite +-identity m | +-suc m m = refl
@ -55,12 +71,12 @@ trichotomy (suc m) (suc n) with trichotomy m n
mutual
is-even : ∀ (n : ) → even n → ∃(λ (m : ) → n ≡ 2 * m)
is-even zero zero = zero , refl
is-even (suc n) (suc oddn) with is-odd n oddn
is-even zero ev-zero = zero , refl
is-even (suc n) (ev-suc odn) with is-odd n odn
... | m , n≡1+2*m rewrite n≡1+2*m | +-lemma m = suc m , refl
is-odd : ∀ (n : ) → odd n → ∃(λ (m : ) → n ≡ 1 + 2 * m)
is-odd (suc n) (suc evenn) with is-even n evenn
is-odd (suc n) (od-suc evn) with is-even n evn
... | m , n≡2*m rewrite n≡2*m = m , refl
\end{code}

View file

@ -2,9 +2,9 @@ open import Data.Nat using (; zero; suc; _+_; _*_)
open import Data.Product using (∃; _,_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
+-identity : (n : ) n + zero n
+-identity : (m : ) m + zero m
+-identity zero = refl
+-identity (suc n) rewrite +-identity n = refl
+-identity (suc m) rewrite +-identity m = refl
+-suc : (m n : ) n + suc m suc (n + m)
+-suc m zero = refl
@ -35,7 +35,7 @@ mutual
... | m , n≡2*m rewrite n≡2*m = m , refl
+-lemma : (m : ) suc (suc (m + (m + 0))) suc m + suc (m + 0)
+-lemma m rewrite +-suc m (m + 0) = {!!}
+-lemma m rewrite +-suc (m + 0) m = refl
is-even : (n : ) even n (λ (m : ) n 2 * m)
is-even zero zero = zero , refl

85
src/extra/Reasoning.agda Normal file
View file

@ -0,0 +1,85 @@
open import Data.Nat using (; zero; suc; _+_)
import Relation.Binary.PropositionalEquality as Eq
import Relation.Binary.PreorderReasoning as Re
module ReEq = Re (Eq.preorder )
open ReEq using (begin_; _∎) renaming (_≈⟨⟩_ to _≡⟨⟩_; _⟨_⟩_ to _≡⟨_⟩_)
open Eq using (_≡_; refl; sym; trans)
lift : {m n : } m n suc m suc n
lift refl = refl
+-assoc : (m n p : ) (m + n) + p m + (n + p)
+-assoc zero n p =
begin
(zero + n) + p
≡⟨⟩
zero + (n + p)
+-assoc (suc m) n p =
begin
(suc m + n) + p
≡⟨⟩
suc ((m + n) + p)
≡⟨ lift (+-assoc m n p)
suc (m + (n + p))
≡⟨⟩
suc m + (n + p)
+-identity : (m : ) m + zero m
+-identity zero =
begin
zero + zero
≡⟨⟩
zero
+-identity (suc m) =
begin
suc m + zero
≡⟨⟩
suc (m + zero)
≡⟨ lift (+-identity m)
suc m
+-suc : (m n : ) m + suc n suc (m + n)
+-suc zero n =
begin
zero + suc n
≡⟨⟩
suc n
≡⟨⟩
suc (zero + n)
+-suc (suc m) n =
begin
suc m + suc n
≡⟨⟩
suc (m + suc n)
≡⟨ lift (+-suc m n)
suc (suc (m + n))
≡⟨⟩
suc (suc m + n)
+-comm : (m n : ) m + n n + m
+-comm m zero =
begin
m + zero
≡⟨ +-identity m
m
≡⟨⟩
zero + m
+-comm m (suc n) =
begin
m + suc n
≡⟨ +-suc m n
suc (m + n)
≡⟨ lift (+-comm m n)
suc (n + m)
≡⟨⟩
suc n + m