failed attempt to use std lib reasoning

This commit is contained in:
Jeremy Siek 2019-08-20 15:31:52 -04:00
parent 3f9f9c3c00
commit b88cd2478b
2 changed files with 99 additions and 75 deletions

View file

@ -94,10 +94,12 @@ sub- {v = v₁ ↦ v₂ ⊔ v₁ ↦ v₃} {v₁ ↦ (v₂ ⊔ v₃)} ⟨ N2
sub- d (⊑-trans x₁ x₂) = sub- (sub- d x₂) x₁ sub- d (⊑-trans x₁ x₂) = sub- (sub- d x₂) x₁
``` ```
<!--
[PLW: [PLW:
If denotations were strengthened to be downward closed, If denotations were strengthened to be downward closed,
we could rewrite the signature replacing ( N) by d : Denotation (Γ , ★)] we could rewrite the signature replacing ( N) by d : Denotation (Γ , ★)]
[JGS: I'll look into this.] [JGS: I'll look into this.]
-->
With this subsumption property in hand, we can prove the forward With this subsumption property in hand, we can prove the forward
direction of the semantic equation for lambda. The proof is by direction of the semantic equation for lambda. The proof is by
@ -357,13 +359,13 @@ lam-cong : ∀{Γ}{N N : Γ , ★ ⊢ ★}
(ƛ N) ≃ (ƛ N) (ƛ N) ≃ (ƛ N)
lam-cong {Γ}{N}{N} N≃N = lam-cong {Γ}{N}{N} N≃N =
start start
(ƛ N) (ƛ N)
≃⟨ lam-equiv ⟩ ≃⟨ lam-equiv ⟩
( N) ( N)
≃⟨ -cong N≃N ≃⟨ -cong N≃N
( N) ( N)
≃⟨ ≃-sym lam-equiv ⟩ ≃⟨ ≃-sym lam-equiv ⟩
(ƛ N) (ƛ N)
``` ```
@ -402,13 +404,13 @@ app-cong : ∀{Γ}{L L M M : Γ ⊢ ★}
(L · M) ≃ (L · M) (L · M) ≃ (L · M)
app-cong {Γ}{L}{L}{M}{M} L≅L M≅M = app-cong {Γ}{L}{L}{M}{M} L≅L M≅M =
start start
(L · M) (L · M)
≃⟨ app-equiv ⟩ ≃⟨ app-equiv ⟩
L ● M L ● M
≃⟨ ●-cong L≅L M≅M ≃⟨ ●-cong L≅L M≅M
L M L M
≃⟨ ≃-sym app-equiv ⟩ ≃⟨ ≃-sym app-equiv ⟩
(L · M) (L · M)
``` ```

View file

@ -54,20 +54,23 @@ down a denotational semantics of the lambda calculus.
## Imports ## Imports
<!-- JGS: for equational reasoning
open import Relation.Binary using (Setoid)
-->
``` ```
open import Agda.Primitive using (lzero; lsuc)
open import Data.Empty using (⊥-elim)
open import Data.Product using (_×_; Σ; Σ-syntax; ∃; ∃-syntax; proj₁; proj₂)
renaming (_,_ to ⟨_,_⟩)
open import Data.Sum
open import Relation.Binary.PropositionalEquality open import Relation.Binary.PropositionalEquality
using (_≡_; _≢_; refl; sym; cong; cong₂; cong-app) using (_≡_; _≢_; refl; sym; cong; cong₂; cong-app)
open import Data.Product using (_×_; Σ; Σ-syntax; ∃; ∃-syntax; proj₁; proj₂)
renaming (_,_ to ⟨_,_⟩)
open import Data.Sum
open import Agda.Primitive using (lzero)
open import Relation.Nullary using (¬_) open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using (contradiction) open import Relation.Nullary.Negation using (contradiction)
open import Data.Empty using (⊥-elim)
open import Function using (_∘_) open import Function using (_∘_)
open import plfa.part2.Untyped open import plfa.part2.Untyped
using (Context; ★; _∋_; ∅; _,_; Z; S_; _⊢_; `_; _·_; ƛ_; using (Context; ★; _∋_; ∅; _,_; Z; S_; _⊢_; `_; _·_; ƛ_;
#_; twoᶜ; ext; rename; exts; subst; subst-zero; _[_]) #_; twoᶜ; ext; rename; exts; subst; subst-zero; _[_])
open import plfa.part2.Substitution using (Rename; extensionality; rename-id) open import plfa.part2.Substitution using (Rename; extensionality; rename-id)
``` ```
@ -112,36 +115,36 @@ data _⊑_ : Value → Value → Set where
⊑-bot : ∀ {v} → ⊥ ⊑ v ⊑-bot : ∀ {v} → ⊥ ⊑ v
⊑-conj-L : ∀ {u v w} ⊑-conj-L : ∀ {u v w}
→ v ⊑ u → v ⊑ u
→ w ⊑ u → w ⊑ u
----------- -----------
→ (v ⊔ w) ⊑ u → (v ⊔ w) ⊑ u
⊑-conj-R1 : ∀ {u v w} ⊑-conj-R1 : ∀ {u v w}
→ u ⊑ v → u ⊑ v
----------- -----------
→ u ⊑ (v ⊔ w) → u ⊑ (v ⊔ w)
⊑-conj-R2 : ∀ {u v w} ⊑-conj-R2 : ∀ {u v w}
→ u ⊑ w → u ⊑ w
----------- -----------
→ u ⊑ (v ⊔ w) → u ⊑ (v ⊔ w)
⊑-trans : ∀ {u v w} ⊑-trans : ∀ {u v w}
→ u ⊑ v → u ⊑ v
→ v ⊑ w → v ⊑ w
----- -----
→ u ⊑ w → u ⊑ w
⊑-fun : ∀ {v w v w} ⊑-fun : ∀ {v w v w}
→ v ⊑ v → v ⊑ v
→ w ⊑ w → w ⊑ w
------------------- -------------------
→ (v ↦ w) ⊑ (v ↦ w) → (v ↦ w) ⊑ (v ↦ w)
⊑-dist : ∀{v w w} ⊑-dist : ∀{v w w}
--------------------------------- ---------------------------------
→ v ↦ (w ⊔ w) ⊑ (v ↦ w) ⊔ (v ↦ w) → v ↦ (w ⊔ w) ⊑ (v ↦ w) ⊔ (v ↦ w)
``` ```
@ -169,9 +172,9 @@ larger values it produces a larger value.
``` ```
⊔⊑⊔ : ∀ {v w v w} ⊔⊑⊔ : ∀ {v w v w}
→ v ⊑ v → w ⊑ w → v ⊑ v → w ⊑ w
----------------------- -----------------------
→ (v ⊔ w) ⊑ (v ⊔ w) → (v ⊔ w) ⊑ (v ⊔ w)
⊔⊑⊔ d₁ d₂ = ⊑-conj-L (⊑-conj-R1 d₁) (⊑-conj-R2 d₂) ⊔⊑⊔ d₁ d₂ = ⊑-conj-L (⊑-conj-R1 d₁) (⊑-conj-R2 d₂)
``` ```
@ -182,30 +185,32 @@ property.
``` ```
⊔↦⊔-dist : ∀{v v w w : Value} ⊔↦⊔-dist : ∀{v v w w : Value}
→ (v ⊔ v) ↦ (w ⊔ w) ⊑ (v ↦ w) ⊔ (v ↦ w) → (v ⊔ v) ↦ (w ⊔ w) ⊑ (v ↦ w) ⊔ (v ↦ w)
⊔↦⊔-dist = ⊑-trans ⊑-dist (⊔⊑⊔ (⊑-fun (⊑-conj-R1 ⊑-refl) ⊑-refl) ⊔↦⊔-dist = ⊑-trans ⊑-dist (⊔⊑⊔ (⊑-fun (⊑-conj-R1 ⊑-refl) ⊑-refl)
(⊑-fun (⊑-conj-R2 ⊑-refl) ⊑-refl)) (⊑-fun (⊑-conj-R2 ⊑-refl) ⊑-refl))
``` ```
<!-- above might read more nicely if we introduce inequational reasoning --> <!--
[PLW: above might read more nicely if we introduce inequational reasoning.]
-->
If the join `u ⊔ v` is less than another value `w`, If the join `u ⊔ v` is less than another value `w`,
then both `u` and `v` are less than `w`. then both `u` and `v` are less than `w`.
``` ```
⊔⊑-invL : ∀{u v w : Value} ⊔⊑-invL : ∀{u v w : Value}
→ u ⊔ v ⊑ w → u ⊔ v ⊑ w
--------- ---------
→ u ⊑ w → u ⊑ w
⊔⊑-invL (⊑-conj-L lt1 lt2) = lt1 ⊔⊑-invL (⊑-conj-L lt1 lt2) = lt1
⊔⊑-invL (⊑-conj-R1 lt) = ⊑-conj-R1 (⊔⊑-invL lt) ⊔⊑-invL (⊑-conj-R1 lt) = ⊑-conj-R1 (⊔⊑-invL lt)
⊔⊑-invL (⊑-conj-R2 lt) = ⊑-conj-R2 (⊔⊑-invL lt) ⊔⊑-invL (⊑-conj-R2 lt) = ⊑-conj-R2 (⊔⊑-invL lt)
⊔⊑-invL (⊑-trans lt1 lt2) = ⊑-trans (⊔⊑-invL lt1) lt2 ⊔⊑-invL (⊑-trans lt1 lt2) = ⊑-trans (⊔⊑-invL lt1) lt2
⊔⊑-invR : ∀{u v w : Value} ⊔⊑-invR : ∀{u v w : Value}
→ u ⊔ v ⊑ w → u ⊔ v ⊑ w
--------- ---------
→ v ⊑ w → v ⊑ w
⊔⊑-invR (⊑-conj-L lt1 lt2) = lt2 ⊔⊑-invR (⊑-conj-L lt1 lt2) = lt2
⊔⊑-invR (⊑-conj-R1 lt) = ⊑-conj-R1 (⊔⊑-invR lt) ⊔⊑-invR (⊑-conj-R1 lt) = ⊑-conj-R1 (⊔⊑-invR lt)
⊔⊑-invR (⊑-conj-R2 lt) = ⊑-conj-R2 (⊔⊑-invR lt) ⊔⊑-invR (⊑-conj-R2 lt) = ⊑-conj-R2 (⊔⊑-invR lt)
@ -246,10 +251,9 @@ last γ = γ Z
init-last : ∀ {Γ} → (γ : Env (Γ , ★)) → γ ≡ (init γ `, last γ) init-last : ∀ {Γ} → (γ : Env (Γ , ★)) → γ ≡ (init γ `, last γ)
init-last {Γ} γ = extensionality lemma init-last {Γ} γ = extensionality lemma
where where lemma : ∀ (x : Γ , ★ ∋ ★) → γ x ≡ (init γ `, last γ) x
lemma : ∀ (x : Γ , ★ ∋ ★) → γ x ≡ (init γ `, last γ) x lemma Z = refl
lemma Z = refl lemma (S x) = refl
lemma (S x) = refl
``` ```
The nth function takes a de Bruijn index and finds the corresponding The nth function takes a de Bruijn index and finds the corresponding
@ -309,35 +313,35 @@ infix 3 _⊢_↓_
data _⊢_↓_ : ∀{Γ} → Env Γ → (Γ ⊢ ★) → Value → Set where data _⊢_↓_ : ∀{Γ} → Env Γ → (Γ ⊢ ★) → Value → Set where
var : ∀ {Γ} {γ : Env Γ} {x} var : ∀ {Γ} {γ : Env Γ} {x}
--------------- ---------------
γ ⊢ (` x) ↓ γ x γ ⊢ (` x) ↓ γ x
↦-elim : ∀ {Γ} {γ : Env Γ} {L M v w} ↦-elim : ∀ {Γ} {γ : Env Γ} {L M v w}
γ ⊢ L ↓ (v ↦ w) γ ⊢ L ↓ (v ↦ w)
γ ⊢ M ↓ v γ ⊢ M ↓ v
--------------- ---------------
γ ⊢ (L · M) ↓ w γ ⊢ (L · M) ↓ w
↦-intro : ∀ {Γ} {γ : Env Γ} {N v w} ↦-intro : ∀ {Γ} {γ : Env Γ} {N v w}
γ `, v ⊢ N ↓ w γ `, v ⊢ N ↓ w
------------------- -------------------
γ ⊢ (ƛ N) ↓ (v ↦ w) γ ⊢ (ƛ N) ↓ (v ↦ w)
⊥-intro : ∀ {Γ} {γ : Env Γ} {M} ⊥-intro : ∀ {Γ} {γ : Env Γ} {M}
--------- ---------
γ ⊢ M ↓ ⊥ γ ⊢ M ↓ ⊥
⊔-intro : ∀ {Γ} {γ : Env Γ} {M v w} ⊔-intro : ∀ {Γ} {γ : Env Γ} {M v w}
γ ⊢ M ↓ v γ ⊢ M ↓ v
γ ⊢ M ↓ w γ ⊢ M ↓ w
--------------- ---------------
γ ⊢ M ↓ (v ⊔ w) γ ⊢ M ↓ (v ⊔ w)
sub : ∀ {Γ} {γ : Env Γ} {M v w} sub : ∀ {Γ} {γ : Env Γ} {M v w}
γ ⊢ M ↓ v γ ⊢ M ↓ v
→ w ⊑ v → w ⊑ v
--------- ---------
γ ⊢ M ↓ w γ ⊢ M ↓ w
``` ```
Consider the rule for lambda abstractions, `↦-intro`. It says that a Consider the rule for lambda abstractions, `↦-intro`. It says that a
@ -576,7 +580,25 @@ equal, that is, ` M ≃ N`.
The following submodule introduces equational reasoning for the `≃` The following submodule introduces equational reasoning for the `≃`
relation. relation.
<!--
JGS: I couldn't get this to work. The definitions here were accepted
by Agda, but then the uses in the Compositional chapter got rejected.
denotation-setoid : Context → Setoid (lsuc lzero) lzero
denotation-setoid Γ = record
{ Carrier = Denotation Γ
; _≈_ = _≃_
; isEquivalence = record { refl = ≃-refl ; sym = ≃-sym ; trans = ≃-trans } }
-->
<!--
The following went inside the module ≃-Reasoning:
open import Relation.Binary.Reasoning.Setoid (denotation-setoid Γ)
renaming (begin_ to start_; _≈⟨_⟩_ to _≃⟨_⟩_; _∎ to _☐) public
-->
``` ```
module ≃-Reasoning {Γ : Context} where module ≃-Reasoning {Γ : Context} where
infix 1 start_ infix 1 start_
@ -589,12 +611,6 @@ module ≃-Reasoning {Γ : Context} where
→ x ≃ y → x ≃ y
start x≃y = x≃y start x≃y = x≃y
_≃⟨⟩_ : ∀ (x : Denotation Γ) {y : Denotation Γ}
→ x ≃ y
-----
→ x ≃ y
x ≃⟨⟩ x≃y = x≃y
_≃⟨_⟩_ : ∀ (x : Denotation Γ) {y z : Denotation Γ} _≃⟨_⟩_ : ∀ (x : Denotation Γ) {y z : Denotation Γ}
→ x ≃ y → x ≃ y
→ y ≃ z → y ≃ z
@ -602,6 +618,12 @@ module ≃-Reasoning {Γ : Context} where
→ x ≃ z → x ≃ z
(x ≃⟨ x≃y ⟩ y≃z) = ≃-trans x≃y y≃z (x ≃⟨ x≃y ⟩ y≃z) = ≃-trans x≃y y≃z
_≃⟨⟩_ : ∀ (x : Denotation Γ) {y : Denotation Γ}
→ x ≃ y
-----
→ x ≃ y
x ≃⟨⟩ x≃y = x≃y
_☐ : ∀ (x : Denotation Γ) _☐ : ∀ (x : Denotation Γ)
----- -----
→ x ≃ x → x ≃ x