├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .vscode └── settings.json ├── LICENSE ├── Plfl.lean ├── Plfl ├── DeBruijn.lean ├── Init.lean ├── Lambda.lean ├── Lambda │ └── Properties.lean ├── More.lean ├── More │ ├── Bisimulation.lean │ ├── DoubleSubst.lean │ └── Inference.lean ├── Untyped.lean └── Untyped │ ├── BigStep.lean │ ├── Confluence.lean │ ├── Denotational.lean │ ├── Denotational │ ├── Adequacy.lean │ ├── Compositional.lean │ ├── ContextualEquivalence.lean │ └── Soundness.lean │ └── Substitution.lean ├── README.md ├── lake-manifest.json ├── lakefile.lean └── lean-toolchain /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Test 2 | 3 | # https://docs.github.com/en/actions/using-jobs/using-concurrency#example-only-cancel-in-progress-jobs-or-runs-for-the-current-workflow 4 | concurrency: 5 | group: ${{ github.workflow }}-${{ github.ref }} 6 | cancel-in-progress: true 7 | 8 | on: 9 | pull_request: 10 | push: 11 | branches: 12 | - master 13 | 14 | jobs: 15 | build: 16 | runs-on: ubuntu-latest 17 | 18 | steps: 19 | - uses: actions/checkout@v3 20 | 21 | - name: Install elan 22 | run: | 23 | curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh -s -- -y --default-toolchain $(cat lean-toolchain) 24 | echo "$HOME/.elan/bin" >> $GITHUB_PATH 25 | 26 | # src: https://harry.garrood.me/blog/easy-incremental-haskell-ci-builds-with-ghc-9.4/ 27 | - name: Cache dependencies 28 | uses: actions/cache@v3 29 | with: 30 | path: | 31 | ./lake-packages 32 | key: deps-${{ runner.os }}-${{ hashFiles('lean-toolchain') }}-${{ hashFiles('lake-manifest.json') }} 33 | restore-keys: | 34 | deps-${{ runner.os }}-${{ hashFiles('lean-toolchain') }} 35 | 36 | - name: Cache build 37 | uses: actions/cache@v3 38 | with: 39 | path: | 40 | ./build 41 | key: build-${{ runner.os }}-${{ hashFiles('lean-toolchain') }}-${{ github.sha }} 42 | restore-keys: | 43 | build-${{ runner.os }}-${{ hashFiles('lean-toolchain') }} 44 | 45 | - name: Test native build 46 | run: | 47 | lake exe cache get 48 | lake build 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cache 2 | /.lake/* 3 | /build 4 | /lake-packages/* 5 | /lakefile.olean 6 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "lean4.input.languages": ["lean4", "lean", "jsonc"], 3 | "lean4.input.customTranslations": { 4 | ",,": "‚‚", 5 | ",'": "‚'", 6 | ",": "‚", 7 | ";": "⨟", 8 | "::": "⦂⦂", 9 | ":": "⦂", 10 | "#prime": "#′", 11 | "`,": "`‚", 12 | "`n": "`ₙ", 13 | "~~": "~~", 14 | "~~e": "~~ₑ", 15 | "$n": "$ₙ", 16 | "ap": "□", 17 | "apn": "□ₙ", 18 | "d-": "↧", 19 | "d2": "￬", 20 | "Fun": "ƛ", 21 | "Funn": "ƛₙ", 22 | "mulp": "⋄", 23 | "Np": "ℕp", 24 | "Nt": "ℕt", 25 | "PRed": "⇛", 26 | "PReds": "⇛*", 27 | "Red": "—→", 28 | "Redp": "—→ₚ", 29 | "Reds": "—↠", 30 | "snoc": "‚", 31 | "st": "✶", 32 | "To": "=⇒", 33 | "u-": "↥", 34 | "unit": "◯", 35 | "vto": "⇾" 36 | }, 37 | "cSpell.words": [ 38 | "Bisimulation", 39 | "compositionality", 40 | "congr", 41 | "denot", 42 | "determ", 43 | "exfalso" 44 | ], 45 | "editor.rulers": [100] 46 | } 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 rami3l 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Plfl.lean: -------------------------------------------------------------------------------- 1 | import Plfl.Lambda 2 | import Plfl.Lambda.Properties 3 | import Plfl.DeBruijn 4 | import Plfl.More 5 | import Plfl.More.DoubleSubst 6 | import Plfl.More.Bisimulation 7 | import Plfl.More.Inference 8 | import Plfl.Untyped 9 | import Plfl.Untyped.Confluence 10 | import Plfl.Untyped.Substitution 11 | import Plfl.Untyped.BigStep 12 | import Plfl.Untyped.Denotational 13 | import Plfl.Untyped.Denotational.Compositional 14 | import Plfl.Untyped.Denotational.Soundness 15 | import Plfl.Untyped.Denotational.Adequacy 16 | import Plfl.Untyped.Denotational.ContextualEquivalence 17 | -------------------------------------------------------------------------------- /Plfl/DeBruijn.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/DeBruijn/ 2 | 3 | import Plfl.Init 4 | 5 | -- Sorry, nothing is inherited from previous chapters here. We have to start over. 6 | namespace DeBruijn 7 | 8 | -- https://plfa.github.io/DeBruijn/#types 9 | inductive Ty where 10 | | nat : Ty 11 | | fn : Ty → Ty → Ty 12 | deriving BEq, DecidableEq, Repr 13 | 14 | namespace Ty 15 | notation "ℕt" => nat 16 | infixr:70 " =⇒ " => fn 17 | 18 | example : Ty := (ℕt =⇒ ℕt) =⇒ ℕt 19 | 20 | theorem t_to_t'_ne_t (t t' : Ty) : (t =⇒ t') ≠ t := by 21 | by_contra h; match t with 22 | | nat => trivial 23 | | fn ta tb => injection h; have := t_to_t'_ne_t ta tb; contradiction 24 | end Ty 25 | 26 | -- https://plfa.github.io/DeBruijn/#contexts 27 | abbrev Context : Type := List Ty 28 | 29 | namespace Context 30 | abbrev snoc : Context → Ty → Context := flip (· :: ·) 31 | -- `‚` is not a comma! See: 32 | infixl:50 " ‚ " => snoc 33 | end Context 34 | 35 | -- https://plfa.github.io/DeBruijn/#variables-and-the-lookup-judgment 36 | inductive Lookup : Context → Ty → Type where 37 | | z : Lookup (Γ‚ t) t 38 | | s : Lookup Γ t → Lookup (Γ‚ t') t 39 | deriving DecidableEq, Repr 40 | 41 | namespace Lookup 42 | infix:40 " ∋ " => Lookup 43 | 44 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/macros.md#simplifying-macro-declaration 45 | syntax "get_elem" (ppSpace term) : tactic 46 | macro_rules | `(tactic| get_elem $n) => match n.1.toNat with 47 | | 0 => `(tactic | exact Lookup.z) 48 | | n+1 => `(tactic| apply Lookup.s; get_elem $(Lean.quote n)) 49 | 50 | macro "♯ " n:term:90 : term => `(by get_elem $n) 51 | 52 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt := .z 53 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt := ♯0 54 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt =⇒ ℕt := .s .z 55 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt =⇒ ℕt := ♯1 56 | end Lookup 57 | 58 | -- https://plfa.github.io/DeBruijn/#terms-and-the-typing-judgment 59 | /-- 60 | A term with typing judgement embedded in itself. 61 | -/ 62 | inductive Term : Context → Ty → Type where 63 | | var : Γ ∋ a → Term Γ a 64 | | lam : Term (Γ‚ a) b → Term Γ (a =⇒ b) 65 | | ap : Term Γ (a =⇒ b) → Term Γ a → Term Γ b 66 | | zero : Term Γ ℕt 67 | | succ : Term Γ ℕt → Term Γ ℕt 68 | | case : Term Γ ℕt → Term Γ a → Term (Γ‚ ℕt) a → Term Γ a 69 | | mu : Term (Γ‚ a) a → Term Γ a 70 | deriving DecidableEq, Repr 71 | 72 | namespace Term 73 | infix:40 " ⊢ " => Term 74 | 75 | prefix:50 "ƛ " => lam 76 | prefix:50 "μ " => mu 77 | notation "𝟘? " => case 78 | infixr:min " $ " => ap 79 | infixl:70 " □ " => ap 80 | prefix:80 "ι " => succ 81 | prefix:90 "` " => var 82 | notation "𝟘" => zero 83 | 84 | -- https://plfa.github.io/DeBruijn/#abbreviating-de-bruijn-indices 85 | macro "# " n:term:90 : term => `(`♯$n) 86 | 87 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #0 88 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt =⇒ ℕt := #1 89 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #1 $ #0 90 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #1 $ #1 $ #0 91 | example : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 92 | example : ∅ ⊢ (ℕt =⇒ ℕt) =⇒ ℕt =⇒ ℕt := ƛ ƛ (#1 $ #1 $ #0) 93 | 94 | def ofNat : ℕ → Γ ⊢ ℕt 95 | | 0 => zero 96 | | n + 1 => succ <| ofNat n 97 | 98 | instance : Coe ℕ (Γ ⊢ ℕt) where coe := ofNat 99 | instance : OfNat (Γ ⊢ ℕt) n where ofNat := ofNat n 100 | 101 | -- https://plfa.github.io/DeBruijn/#test-examples 102 | example : Γ ⊢ ℕt := ι ι 𝟘 103 | example : Γ ⊢ ℕt := 2 104 | 105 | @[simp] abbrev add : Γ ⊢ ℕt =⇒ ℕt =⇒ ℕt := μ ƛ ƛ (𝟘? (#1) (#0) (ι (#3 □ #0 □ #1))) 106 | @[simp] abbrev mul : Γ ⊢ ℕt =⇒ ℕt =⇒ ℕt := μ ƛ ƛ (𝟘? (#1) 𝟘 (add □ #1 $ #3 □ #0 □ #1)) 107 | 108 | example : Γ ⊢ ℕt := add □ 2 □ 2 109 | 110 | /-- 111 | The Church numeral Ty. 112 | -/ 113 | abbrev Ch (t : Ty) : Ty := (t =⇒ t) =⇒ t =⇒ t 114 | 115 | @[simp] abbrev succC : Γ ⊢ ℕt =⇒ ℕt := ƛ ι #0 116 | @[simp] abbrev twoC : Γ ⊢ Ch a := ƛ ƛ (#1 $ #1 $ #0) 117 | @[simp] abbrev addC : Γ ⊢ Ch a =⇒ Ch a =⇒ Ch a := ƛ ƛ ƛ ƛ (#3 □ #1 $ #2 □ #1 □ #0) 118 | example : Γ ⊢ ℕt := addC □ twoC □ twoC □ succC □ 𝟘 119 | 120 | -- https://plfa.github.io/DeBruijn/#exercise-mul-recommended 121 | @[simp] abbrev mulC : Γ ⊢ Ch a =⇒ Ch a =⇒ Ch a := ƛ ƛ ƛ ƛ (#3 □ (#2 □ #1) □ #0) 122 | end Term 123 | 124 | -- https://plfa.github.io/DeBruijn/#renaming 125 | /-- 126 | If one context maps to another, 127 | the mapping holds after adding the same variable to both contexts. 128 | -/ 129 | def ext : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ‚ b ∋ a → Δ‚ b ∋ a := by 130 | intro ρ; intro 131 | | .z => exact .z 132 | | .s x => refine .s ?_; exact ρ x 133 | 134 | /-- 135 | If one context maps to another, 136 | then the type judgements are the same in both contexts. 137 | -/ 138 | def rename : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ ⊢ a → Δ ⊢ a := by 139 | intro ρ; intro 140 | | ` x => exact ` (ρ x) 141 | | ƛ n => refine .lam ?_; refine rename ?_ n; exact ext ρ 142 | | l □ m => 143 | apply Term.ap 144 | · exact rename ρ l 145 | · exact rename ρ m 146 | | 𝟘 => exact 𝟘 147 | | ι n => refine ι ?_; exact rename ρ n 148 | | 𝟘? l m n => 149 | apply Term.case 150 | · exact rename ρ l 151 | · exact rename ρ m 152 | · refine rename ?_ n; exact ext ρ 153 | | μ n => refine .mu ?_; refine rename ?_ n; exact ext ρ 154 | 155 | example 156 | : let m : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 157 | let m' : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#2 $ #2 $ #0) 158 | rename .s m = m' 159 | := rfl 160 | 161 | -- https://plfa.github.io/DeBruijn/#simultaneous-substitution 162 | /-- 163 | If the variables in one context maps to some terms in another, 164 | the mapping holds after adding the same variable to both contexts. 165 | -/ 166 | def exts : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ‚ b ∋ a → Δ‚ b ⊢ a := by 167 | intro σ; intro 168 | | .z => exact `.z 169 | | .s x => apply rename .s; exact σ x 170 | 171 | /-- 172 | General substitution for multiple free variables. 173 | If the variables in one context maps to some terms in another, 174 | then the type judgements are the same before and after the mapping, 175 | i.e. after replacing the free variables in the former with (expanded) terms. 176 | -/ 177 | def subst : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ ⊢ a → Δ ⊢ a := by 178 | intro σ; intro 179 | | ` x => exact σ x 180 | | ƛ n => refine .lam ?_; refine subst ?_ n; exact exts σ 181 | | l □ m => 182 | apply Term.ap 183 | · exact subst σ l 184 | · exact subst σ m 185 | | 𝟘 => exact 𝟘 186 | | ι n => refine ι ?_; exact subst σ n 187 | | 𝟘? l m n => 188 | apply Term.case 189 | · exact subst σ l 190 | · exact subst σ m 191 | · refine subst ?_ n; exact exts σ 192 | | μ n => refine .mu ?_; refine subst ?_ n; exact exts σ 193 | 194 | /-- 195 | Substitution for one free variable `m` in the term `n`. 196 | -/ 197 | abbrev subst₁ (m : Γ ⊢ b) (n : Γ‚ b ⊢ a) : Γ ⊢ a := by 198 | refine subst ?_ n; introv; intro 199 | | .z => exact m 200 | | .s x => exact ` x 201 | 202 | notation:90 n "⟦" m "⟧" => subst₁ m n 203 | 204 | example 205 | : let m : ∅ ⊢ ℕt =⇒ ℕt := ƛ (ι #0) 206 | let m' : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 207 | let n : ∅ ⊢ ℕt =⇒ ℕt := ƛ (ƛ ι #0) □ ((ƛ ι #0) □ #0) 208 | m'⟦m⟧ = n 209 | := rfl 210 | 211 | example 212 | : let m : ∅‚ ℕt =⇒ ℕt ⊢ ℕt := #0 $ 𝟘 213 | let m' : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ (ℕt =⇒ ℕt) =⇒ ℕt := ƛ (#0 $ #1) 214 | let n : ∅‚ ℕt =⇒ ℕt ⊢ (ℕt =⇒ ℕt) =⇒ ℕt := ƛ (#0 $ #1 $ 𝟘) 215 | m'⟦m⟧ = n 216 | := rfl 217 | 218 | inductive Value : Γ ⊢ a → Type where 219 | | lam : Value (ƛ (n : Γ‚ a ⊢ b)) 220 | | zero: Value 𝟘 221 | | succ: Value n → Value (ι n) 222 | deriving BEq, DecidableEq, Repr 223 | 224 | namespace Value 225 | notation "V𝟘" => zero 226 | 227 | def ofNat : (n : ℕ) → @Value Γ ℕt (Term.ofNat n) 228 | | 0 => V𝟘 229 | | n + 1 => succ <| ofNat n 230 | end Value 231 | 232 | -- https://plfa.github.io/DeBruijn/#reduction 233 | /-- 234 | `Reduce t t'` says that `t` reduces to `t'`. 235 | -/ 236 | inductive Reduce : (Γ ⊢ a) → (Γ ⊢ a) → Type where 237 | | lamβ : Value w → Reduce ((ƛ n) □ w) (n⟦w⟧) 238 | | apξ₁ : Reduce l l' → Reduce (l □ m) (l' □ m) 239 | | apξ₂ : Value v → Reduce m m' → Reduce (v □ m) (v □ m') 240 | | zeroβ : Reduce (𝟘? 𝟘 m n) m 241 | | succβ : Value v → Reduce (𝟘? (ι v) m n) (n⟦v⟧) 242 | | succξ : Reduce m m' → Reduce (ι m) (ι m') 243 | | caseξ : Reduce l l' → Reduce (𝟘? l m n) (𝟘? l' m n) 244 | | muβ : Reduce (μ n) (n⟦μ n⟧) 245 | deriving Repr 246 | 247 | infix:40 " —→ " => Reduce 248 | 249 | namespace Reduce 250 | -- https://plfa.github.io/DeBruijn/#reflexive-and-transitive-closure 251 | /-- 252 | A reflexive and transitive closure, 253 | defined as a sequence of zero or more steps of the underlying relation `—→`. 254 | -/ 255 | inductive Clos : (Γ ⊢ a) → (Γ ⊢ a) → Type where 256 | | nil : Clos m m 257 | | cons : (l —→ m) → Clos m n → Clos l n 258 | deriving Repr 259 | 260 | infix:20 " —↠ " => Clos 261 | 262 | namespace Clos 263 | def length : (m —↠ n) → Nat 264 | | nil => 0 265 | | cons _ cdr => 1 + cdr.length 266 | 267 | @[simp] abbrev one (car : m —→ n) : (m —↠ n) := cons car nil 268 | instance : Coe (m —→ n) (m —↠ n) where coe := one 269 | 270 | def trans : (l —↠ m) → (m —↠ n) → (l —↠ n) 271 | | nil, c => c 272 | | cons h c, c' => cons h <| c.trans c' 273 | 274 | instance : Trans (α := Γ ⊢ a) Clos Clos Clos where 275 | trans := trans 276 | 277 | instance : Trans (α := Γ ⊢ a) Reduce Clos Clos where 278 | trans := cons 279 | 280 | instance : Trans (α := Γ ⊢ a) Reduce Reduce Clos where 281 | trans c c' := cons c <| cons c' nil 282 | 283 | def transOne : (l —↠ m) → (m —→ n) → (l —↠ n) 284 | | nil, c => c 285 | | cons h c, c' => cons h <| c.trans c' 286 | 287 | instance : Trans (α := Γ ⊢ a) Clos Reduce Clos where 288 | trans := transOne 289 | end Clos 290 | 291 | open Term 292 | 293 | -- https://plfa.github.io/DeBruijn/#examples 294 | example : twoC □ succC □ @zero ∅ —↠ 2 := calc 295 | twoC □ succC □ 𝟘 296 | _ —→ (ƛ (succC $ succC $ #0)) □ 𝟘 := by apply apξ₁; apply lamβ; exact Value.lam 297 | _ —→ (succC $ succC $ 𝟘) := by apply lamβ; exact V𝟘 298 | _ —→ succC □ 1 := by apply apξ₂; apply Value.lam; exact lamβ V𝟘 299 | _ —→ 2 := by apply lamβ; exact Value.ofNat 1 300 | end Reduce 301 | 302 | -- https://plfa.github.io/DeBruijn/#values-do-not-reduce 303 | def Value.empty_reduce : Value m → ∀ {n}, IsEmpty (m —→ n) := by 304 | introv v; is_empty; intro r 305 | cases v <;> try contradiction 306 | · case succ v => cases r; · case succξ => apply (empty_reduce v).false; trivial 307 | 308 | def Reduce.empty_value : m —→ n → IsEmpty (Value m) := by 309 | intro r; is_empty; intro v 310 | have : ∀ {n}, IsEmpty (m —→ n) := Value.empty_reduce v 311 | exact this.false r 312 | 313 | /-- 314 | If a term `m` is not ill-typed, then it either is a value or can be reduced. 315 | -/ 316 | inductive Progress (m : ∅ ⊢ a) where 317 | | step : (m —→ n) → Progress m 318 | | done : Value m → Progress m 319 | 320 | def progress : (m : ∅ ⊢ a) → Progress m := open Progress Reduce in by 321 | intro 322 | | ` _ => contradiction 323 | | ƛ _ => exact .done Value.lam 324 | | jl □ jm => cases progress jl with 325 | | step => apply step; · apply apξ₁; trivial 326 | | done vl => cases progress jm with 327 | | step => apply step; apply apξ₂ <;> trivial 328 | | done => cases vl with 329 | | lam => apply step; apply lamβ; trivial 330 | | 𝟘 => exact done V𝟘 331 | | ι j => cases progress j with 332 | | step => apply step; apply succξ; trivial 333 | | done => apply done; apply Value.succ; trivial 334 | | 𝟘? jl jm jn => cases progress jl with 335 | | step => apply step; apply caseξ; trivial 336 | | done vl => cases vl with 337 | | zero => exact step zeroβ 338 | | succ => apply step; apply succβ; trivial 339 | | μ _ => exact step muβ 340 | 341 | inductive Result (n : Γ ⊢ a) where 342 | | done (val : Value n) 343 | | dnf 344 | deriving BEq, DecidableEq, Repr 345 | 346 | inductive Steps (l : Γ ⊢ a) where 347 | | steps : ∀{n : Γ ⊢ a}, (l —↠ n) → Result n → Steps l 348 | deriving Repr 349 | 350 | def eval (gas : ℕ) (l : ∅ ⊢ a) : Steps l := 351 | if gas = 0 then 352 | ⟨.nil, .dnf⟩ 353 | else 354 | match progress l with 355 | | .done v => .steps .nil <| .done v 356 | | .step r => 357 | let ⟨rs, res⟩ := eval (gas - 1) (by trivial) 358 | ⟨.cons r rs, res⟩ 359 | 360 | section examples 361 | open Term 362 | 363 | -- def x : ℕ := x + 1 364 | abbrev succμ : ∅ ⊢ ℕt := μ ι #0 365 | 366 | #eval eval 3 succμ |> (·.3) 367 | #eval eval 100 (add □ 2 □ 2) |> (·.3) 368 | #eval eval 100 (mul □ 2 □ 3) |> (·.3) 369 | end examples 370 | -------------------------------------------------------------------------------- /Plfl/Init.lean: -------------------------------------------------------------------------------- 1 | import Std.Data.List.Lemmas 2 | 3 | import Mathlib.Data.Vector 4 | import Mathlib.Logic.IsEmpty 5 | import Mathlib.Tactic 6 | 7 | /-- 8 | `is_empty` converts `IsEmpty α` to `α → False`. 9 | -/ 10 | syntax "is_empty" : tactic 11 | macro_rules | `(tactic| is_empty) => `(tactic| apply Function.isEmpty (β := False)) 12 | 13 | /-- 14 | `Decidable'` is like `Decidable`, but allows arbitrary sorts. 15 | -/ 16 | abbrev Decidable' α := IsEmpty α ⊕' α 17 | 18 | namespace Decidable' 19 | def toDecidable : Decidable' α → Decidable (Nonempty α) := by intro 20 | | .inr a => right; exact ⟨a⟩ 21 | | .inl na => left; simpa 22 | end Decidable' 23 | 24 | instance [Repr α] : Repr (Decidable' α) where 25 | reprPrec da n := match da with 26 | | .inr a => ".inr " ++ reprPrec a n 27 | | .inl _ => ".inl _" 28 | 29 | theorem congr_arg₃ 30 | (f : α → β → γ → δ) {x x' : α} {y y' : β} {z z' : γ} 31 | (hx : x = x') (hy : y = y') (hz : z = z') 32 | : f x y z = f x' y' z' 33 | := by subst hx hy hz; rfl 34 | 35 | namespace Vector 36 | def dropLast (v : Vector α n) : Vector α (n - 1) := by 37 | exists v.1.dropLast; simp only [List.length_dropLast, Vector.length_val] 38 | 39 | theorem get_dropLast (v : Vector α (n + 1)) (i : Fin n) 40 | : v.dropLast.get i = v.get i.1 41 | := by 42 | simp only [ 43 | Vector.get, dropLast, v.1.dropLast_eq_take, 44 | Vector.length_val, Nat.pred_succ, Fin.coe_eq_castSucc 45 | ] 46 | change List.get _ _ = List.get _ _; rw [List.get_dropLast]; rfl 47 | end Vector 48 | -------------------------------------------------------------------------------- /Plfl/Lambda.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Lambda/ 2 | 3 | import Plfl.Init 4 | 5 | namespace Lambda 6 | 7 | open String 8 | 9 | def Sym : Type := String deriving BEq, DecidableEq, Repr 10 | 11 | -- https://plfa.github.io/Lambda/#syntax-of-terms 12 | inductive Term where 13 | | var : Sym → Term 14 | | lam : Sym → Term → Term 15 | | ap : Term → Term → Term 16 | | zero : Term 17 | | succ : Term → Term 18 | | case : Term → Term → Sym → Term → Term 19 | | mu : Sym → Term → Term 20 | deriving BEq, DecidableEq, Repr 21 | 22 | namespace Term 23 | notation:50 "ƛ " v " : " d => lam v d 24 | notation:50 " μ " v " : " d => mu v d 25 | notation:max "𝟘? " e " [zero: " o " |succ " n " : " i " ] " => case e o n i 26 | infixr:min " $ " => ap 27 | infixl:70 " □ " => ap 28 | prefix:80 "ι " => succ 29 | prefix:90 "` " => var 30 | notation "𝟘" => zero 31 | 32 | example : Term := `"foo" 33 | example : Term := 𝟘? `"bar" [zero: 𝟘 |succ "n" : ι 𝟘] 34 | 35 | @[simp] def ofNat | 0 => zero | n + 1 => succ <| ofNat n 36 | instance : Coe ℕ Term where coe := ofNat 37 | instance : OfNat Term n where ofNat := ofNat n 38 | 39 | example : Term := 1 40 | example : Term := 42 41 | 42 | abbrev add : Term := μ "+" : ƛ "m" : ƛ "n" : 𝟘? `"m" [zero: `"n" |succ "m": ι (`"+" □ `"m" □ `"n")] 43 | -- https://plfa.github.io/Lambda/#exercise-mul-recommended 44 | abbrev mul : Term := μ "*" : ƛ "m" : ƛ "n" : 𝟘? `"m" [zero: 𝟘 |succ "m": add □ `"n" $ `"*" □ `"m" □ `"n"] 45 | 46 | -- Church encoding... 47 | abbrev succC : Term := ƛ "n" : ι `"n" 48 | abbrev oneC : Term := ƛ "s" : ƛ "z" : `"s" $ `"z" 49 | abbrev twoC : Term := ƛ "s" : ƛ "z" : `"s" $ `"s" $ `"z" 50 | abbrev addC : Term := ƛ "m" : ƛ "n" : ƛ "s" : ƛ "z" : `"m" □ `"s" $ `"n" □ `"s" □ `"z" 51 | -- https://plfa.github.io/Lambda/#exercise-mul%E1%B6%9C-practice 52 | abbrev mulC : Term := ƛ "m" : ƛ "n" : ƛ "s" : ƛ "z" : `"m" □ (`"n" □ `"s") □ `"z" 53 | end Term 54 | 55 | -- https://plfa.github.io/Lambda/#values 56 | inductive Value : Term → Type where 57 | | lam : Value (ƛ v : d) 58 | | zero: Value 𝟘 59 | | succ: Value n → Value (ι n) 60 | deriving BEq, DecidableEq, Repr 61 | 62 | namespace Value 63 | notation "V𝟘" => zero 64 | 65 | def ofNat : (n : ℕ) → Value (Term.ofNat n) 66 | | 0 => V𝟘 67 | | n + 1 => succ <| ofNat n 68 | 69 | -- instance : CoeDep ℕ n (Value ↑n) where coe := ofNat n 70 | -- instance : OfNat (Value (Term.ofNat n)) n where ofNat := ofNat n 71 | end Value 72 | 73 | -- https://plfa.github.io/Lambda/#substitution 74 | namespace Term 75 | /-- 76 | `x.subst y v` substitutes term `v` for all free occurrences of variable `y` in term `x`. 77 | -/ 78 | def subst : Term → Sym → Term → Term 79 | | ` x, y, v => if x = y then v else ` x 80 | | ƛ x : n, y, v => if x = y then ƛ x : n else ƛ x : n.subst y v 81 | | ap l m, y, v => l.subst y v $ m.subst y v 82 | | 𝟘, _, _ => 𝟘 83 | | ι n, y, v => ι (n.subst y v) 84 | | 𝟘? l [zero: m |succ x: n], y, v => if x = y 85 | then 𝟘? l.subst y v [zero: m.subst y v |succ x: n] 86 | else 𝟘? l.subst y v [zero: m.subst y v |succ x: n.subst y v] 87 | | μ x : n, y, v => if x = y then μ x : n else μ x : n.subst y v 88 | 89 | notation:90 x " [ " y " := " v " ] " => subst x y v 90 | 91 | -- https://plfa.github.io/Lambda/#examples 92 | example 93 | : (ƛ "z" : `"s" □ `"s" □ `"z")["s" := succC] 94 | = (ƛ "z" : succC □ succC □ `"z") := rfl 95 | 96 | example : (succC □ succC □ `"z")["z" := 𝟘] = succC □ succC □ 𝟘 := rfl 97 | example : (ƛ "x" : `"y")["y" := 𝟘] = (ƛ "x" : 𝟘) := rfl 98 | example : (ƛ "x" : `"x")["x" := 𝟘] = (ƛ "x" : `"x") := rfl 99 | example : (ƛ "y" : `"y")["x" := 𝟘] = (ƛ "y" : `"y") := rfl 100 | 101 | -- https://plfa.github.io/Lambda/#quiz 102 | example 103 | : (ƛ "y" : `"x" $ ƛ "x" : `"x")["x" := 𝟘] 104 | = (ƛ "y" : 𝟘 $ ƛ "x" : `"x") 105 | := rfl 106 | 107 | -- https://plfa.github.io/Lambda/#reduction 108 | /-- 109 | `Reduce t t'` says that `t` reduces to `t'`. 110 | -/ 111 | inductive Reduce : Term → Term → Type where 112 | | lamβ : Value v → Reduce ((ƛ x : n) □ v) (n[x := v]) 113 | | apξ₁ : Reduce l l' → Reduce (l □ m) (l' □ m) 114 | | apξ₂ : Value v → Reduce m m' → Reduce (v □ m) (v □ m') 115 | | zeroβ : Reduce (𝟘? 𝟘 [zero: m |succ x : n]) m 116 | | succβ : Value v → Reduce (𝟘? ι v [zero: m |succ x : n]) (n[x := v]) 117 | | succξ : Reduce m m' → Reduce (ι m) (ι m') 118 | | caseξ : Reduce l l' → Reduce (𝟘? l [zero: m |succ x : n]) (𝟘? l' [zero: m |succ x : n]) 119 | | muβ : Reduce (μ x : m) (m[x := μ x : m]) 120 | deriving Repr 121 | 122 | infix:40 " —→ " => Reduce 123 | end Term 124 | 125 | namespace Term.Reduce 126 | -- https://plfa.github.io/Lambda/#quiz-1 127 | example : (ƛ "x" : `"x") □ (ƛ "x" : `"x") —→ (ƛ "x" : `"x") := by 128 | apply lamβ; exact Value.lam 129 | 130 | example : (ƛ "x" : `"x") □ (ƛ "x" : `"x") □ (ƛ "x" : `"x") —→ (ƛ "x" : `"x") □ (ƛ "x" : `"x") := by 131 | apply apξ₁; apply lamβ; exact Value.lam 132 | 133 | example : twoC □ succC □ 𝟘 —→ (ƛ "z" : succC $ succC $ `"z") □ 𝟘 := by 134 | unfold twoC; apply apξ₁; apply lamβ; exact Value.lam 135 | 136 | -- https://plfa.github.io/Lambda/#reflexive-and-transitive-closure 137 | /-- 138 | A reflexive and transitive closure, 139 | defined as a sequence of zero or more steps of the underlying relation `—→`. 140 | -/ 141 | inductive Clos : Term → Term → Type where 142 | | nil : Clos m m 143 | | cons : (l —→ m) → Clos m n → Clos l n 144 | deriving Repr 145 | 146 | infix:20 " —↠ " => Clos 147 | 148 | namespace Clos 149 | def length : (m —↠ n) → Nat 150 | | nil => 0 151 | | cons _ cdr => 1 + cdr.length 152 | 153 | abbrev one (car : m —→ n) : (m —↠ n) := cons car nil 154 | instance : Coe (m —→ n) (m —↠ n) where coe := one 155 | 156 | def trans : (l —↠ m) → (m —↠ n) → (l —↠ n) 157 | | nil, c => c 158 | | cons h c, c' => cons h <| c.trans c' 159 | 160 | instance : Trans Clos Clos Clos where 161 | trans := trans 162 | 163 | instance : Trans Reduce Clos Clos where 164 | trans := cons 165 | 166 | instance : Trans Reduce Reduce Clos where 167 | trans c c' := cons c <| cons c' nil 168 | 169 | def transOne : (l —↠ m) → (m —→ n) → (l —↠ n) 170 | | nil, c => c 171 | | cons h c, c' => cons h <| c.trans c' 172 | 173 | instance : Trans Clos Reduce Clos where 174 | trans := transOne 175 | end Clos 176 | 177 | inductive Clos' : Term → Term → Type where 178 | | refl : Clos' m m 179 | | step : (m —→ n) → Clos' m n 180 | | trans : Clos' l m → Clos' m n → Clos' l n 181 | 182 | infix:20 " —↠' " => Clos' 183 | 184 | def Clos.toClos' : (m —↠ n) → (m —↠' n) := by 185 | intro 186 | | nil => exact Clos'.refl 187 | | cons h h' => exact Clos'.trans (Clos'.step h) h'.toClos' 188 | 189 | def Clos'.toClos : (m —↠' n) → (m —↠ n) := by 190 | intro 191 | | refl => exact Clos.nil 192 | | step h => exact ↑h 193 | | trans h h' => apply Clos.trans <;> (apply toClos; assumption) 194 | 195 | -- https://plfa.github.io/Lambda/#exercise-practice 196 | lemma Clos.toClos'_left_inv : ∀ {x : m —↠ n}, x.toClos'.toClos = x := by intro 197 | | nil => rfl 198 | | cons car cdr => 199 | simp_all only [Clos'.toClos, trans, cons.injEq, heq_eq_eq, true_and] 200 | exact toClos'_left_inv (x := cdr) 201 | 202 | lemma Clos.toClos'_inj 203 | : @Function.Injective (m —↠ n) (m —↠' n) Clos.toClos' 204 | := by 205 | unfold Function.Injective 206 | intro a b h 207 | apply_fun Clos'.toClos at h 208 | rwa [←toClos'_left_inv (x := a), ←toClos'_left_inv (x := b)] 209 | 210 | instance Clos.embedsInClos' : (m —↠ n) ↪ (m —↠' n) where 211 | toFun := toClos' 212 | inj' := toClos'_inj 213 | end Term.Reduce 214 | 215 | -- https://plfa.github.io/Lambda/#confluence 216 | section confluence 217 | open Term.Reduce Term.Reduce.Clos 218 | 219 | -- `Σ` is used instead of `∃` because it's a `Type` that exists, not a `Prop`. 220 | def Diamond : Type := ∀ ⦃l m n⦄, (l —→ m) → (l —→ n) → (Σ p, (m —↠ p) × (n —↠ p)) 221 | def Confluence : Type := ∀ ⦃l m n⦄, (l —↠ m) → (l —↠ n) → (Σ p, (m —↠ p) × (n —↠ p)) 222 | def Deterministic : Prop := ∀ ⦃l m n⦄, (l —→ m) → (l —→ n) → (m = n) 223 | 224 | def Deterministic.toDiamond : Deterministic → Diamond := by 225 | unfold Deterministic Diamond; intro h l m n lm ln 226 | have heq := h lm ln; simp_all only 227 | exists n; exact ⟨nil, nil⟩ 228 | 229 | def Deterministic.toConfluence : Deterministic → Confluence 230 | | h, l, m, n, lm, ln => by match lm, ln with 231 | | nil, nil => exists n; exact ⟨ln, ln⟩ 232 | | nil, c@(cons _ _) => exists n; exact ⟨c, nil⟩ 233 | | c@(cons _ _), nil => exists m; exact ⟨nil, c⟩ 234 | | cons car cdr, cons car' cdr' => 235 | have := h car car'; subst this 236 | exact toConfluence h cdr cdr' 237 | end confluence 238 | 239 | -- https://plfa.github.io/Lambda/#examples-1 240 | section examples 241 | open Term Term.Reduce Term.Reduce.Clos 242 | 243 | example : twoC □ succC □ 𝟘 —↠ 2 := calc 244 | twoC □ succC □ 𝟘 245 | _ —→ (ƛ "z" : succC $ succC $ `"z") □ 𝟘 := by apply apξ₁; apply lamβ; exact Value.lam 246 | _ —→ (succC $ succC $ 𝟘) := by apply lamβ; exact Value.zero 247 | _ —→ succC □ 1 := by apply apξ₂; apply Value.lam; apply lamβ; exact Value.zero 248 | _ —→ 2 := by apply lamβ; exact Value.ofNat 1 249 | 250 | -- https://plfa.github.io/Lambda/#exercise-plus-example-practice 251 | example : add □ 1 □ 1 —↠ 2 := calc 252 | add □ 1 □ 1 253 | _ —→ (ƛ "m" : ƛ "n" : 𝟘? `"m" [zero: `"n" |succ "m": ι (add □ `"m" □ `"n")]) □ 1 □ 1 254 | := by apply apξ₁; apply apξ₁; apply muβ 255 | _ —↠ (ƛ "n" : 𝟘? 1 [zero: `"n" |succ "m": ι (add □ `"m" □ `"n")]) □ 1 256 | := .one <| by apply apξ₁; apply lamβ; exact Value.ofNat 1 257 | _ —→ 𝟘? 1 [zero: 1 |succ "m": ι (add □ `"m" □ 1)] 258 | := lamβ <| Value.ofNat 1 259 | _ —→ ι (add □ 𝟘 □ 1) 260 | := succβ Value.zero 261 | _ —→ ι ((ƛ "m" : ƛ "n" : 𝟘? `"m" [zero: `"n" |succ "m": ι (add □ `"m" □ `"n")]) □ 𝟘 □ 1) 262 | := by apply succξ; apply apξ₁; apply apξ₁; apply muβ 263 | _ —→ ι ((ƛ "n" : 𝟘? 𝟘 [zero: `"n" |succ "m": ι (add □ `"m" □ `"n")]) □ 1) 264 | := by apply succξ; apply apξ₁; apply lamβ; exact V𝟘 265 | _ —→ ι (𝟘? 𝟘 [zero: 1 |succ "m": ι (add □ `"m" □ 1)]) 266 | := by apply succξ; apply lamβ; exact Value.ofNat 1 267 | _ —→ 2 := succξ zeroβ 268 | end examples 269 | 270 | -- https://plfa.github.io/Lambda/#syntax-of-types 271 | inductive Ty where 272 | | nat 273 | | fn : Ty → Ty → Ty 274 | deriving BEq, DecidableEq, Repr 275 | 276 | namespace Ty 277 | notation "ℕt" => nat 278 | infixr:70 " =⇒ " => fn 279 | 280 | example : Ty := (ℕt =⇒ ℕt) =⇒ ℕt 281 | 282 | theorem t_to_t'_ne_t (t t' : Ty) : (t =⇒ t') ≠ t := by 283 | by_contra h; match t with 284 | | nat => trivial 285 | | fn ta tb => injection h; have := t_to_t'_ne_t ta tb; contradiction 286 | end Ty 287 | 288 | -- https://plfa.github.io/Lambda/#contexts 289 | def Context : Type := List (Sym × Ty) 290 | 291 | namespace Context 292 | open Term 293 | 294 | def nil : Context := [] 295 | def extend : Context → Sym → Ty → Context | c, s, ts => ⟨s, ts⟩ :: c 296 | 297 | notation "∅" => nil 298 | 299 | -- The goal is to make `_‚_⦂_` work like an `infixl`. 300 | -- https://matklad.github.io/2020/04/13/simple-but-powerful-pratt-parsing.html#From-Precedence-to-Binding-Power 301 | -- `‚` is not a comma! See: 302 | notation:50 c " ‚ " s:51 " ⦂ " t:51 => extend c s t 303 | 304 | example {Γ : Context} {s : Sym} {ts : Ty} : Context := Γ‚ s ⦂ ts 305 | 306 | -- https://plfa.github.io/Lambda/#lookup-judgment 307 | /-- 308 | A lookup judgement. 309 | `Lookup c s ts` means that `s` is of type `ts` by _looking up_ the context `c`. 310 | -/ 311 | @[aesop safe [constructors, cases]] 312 | inductive Lookup : Context → Sym → Ty → Type where 313 | | z : Lookup (Γ‚ x ⦂ t) x t 314 | | s : x ≠ y → Lookup Γ x t → Lookup (Γ‚ y ⦂ u) x t 315 | deriving DecidableEq 316 | 317 | notation:40 c " ∋ " s " ⦂ " t:51 => Lookup c s t 318 | 319 | example 320 | : ∅‚ "x" ⦂ ℕt =⇒ ℕt‚ "y" ⦂ ℕt‚ "z" ⦂ ℕt 321 | ∋ "x" ⦂ ℕt =⇒ ℕt 322 | := open Lookup in by 323 | apply s _; apply s _; apply z; repeat trivial 324 | 325 | -- https://plfa.github.io/Lambda/#lookup-is-functional 326 | theorem Lookup.functional : Γ ∋ x ⦂ t → Γ ∋ x ⦂ t' → t = t' := by intro 327 | | z, z => rfl 328 | | z, s _ e => trivial 329 | | s _ e, z => trivial 330 | | s _ e, s _ e' => exact functional e e' 331 | 332 | -- https://plfa.github.io/Lambda/#typing-judgment 333 | /-- 334 | A general typing judgement. 335 | `IsTy c t tt` means that `t` can be inferred to be of type `tt` in the context `c`. 336 | -/ 337 | inductive IsTy : Context → Term → Ty → Type where 338 | | tyVar : Γ ∋ x ⦂ t → IsTy Γ (` x) t 339 | | tyLam : IsTy (Γ‚ x ⦂ t) n u → IsTy Γ (ƛ x : n) (t =⇒ u) 340 | | tyAp : IsTy Γ l (t =⇒ u) → IsTy Γ x t → IsTy Γ (l □ x) u 341 | | tyZero : IsTy Γ 𝟘 ℕt 342 | | tySucc : IsTy Γ n ℕt → IsTy Γ (ι n) ℕt 343 | | tyCase : IsTy Γ l ℕt → IsTy Γ m t → IsTy (Γ‚ x ⦂ ℕt) n t → IsTy Γ (𝟘? l [zero: m |succ x: n]) t 344 | | tyMu : IsTy (Γ‚ x ⦂ t) m t → IsTy Γ (μ x : m) t 345 | deriving DecidableEq 346 | 347 | notation:40 c " ⊢ " t " ⦂ " tt:51 => IsTy c t tt 348 | 349 | /-- 350 | `NoTy c t` means that `t` cannot be inferred to be any type in the context `c`. 351 | -/ 352 | abbrev NoTy (c : Context) (t : Term) : Prop := ∀ {tt}, IsEmpty (c ⊢ t ⦂ tt) 353 | 354 | infix:40 " ⊬ " => NoTy 355 | 356 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/tactics.md#tactics-by-macro-expansion 357 | /-- 358 | `lookup_var` validates the type of a variable by looking it up in the current context. 359 | This tactic fails when the lookup fails. 360 | -/ 361 | syntax "lookup_var" : tactic 362 | macro_rules 363 | | `(tactic| lookup_var) => 364 | `(tactic| apply IsTy.tyVar; repeat (first | apply Lookup.s (by trivial) | exact Lookup.z)) 365 | 366 | -- Inform `trivial` of our new tactic. 367 | macro_rules | `(tactic| trivial) => `(tactic| lookup_var) 368 | 369 | open IsTy 370 | 371 | -- https://plfa.github.io/Lambda/#quiz-2 372 | lemma twice_ty : Γ ⊢ (ƛ "s" : `"s" $ `"s" $ 𝟘) ⦂ ((ℕt =⇒ ℕt) =⇒ ℕt) := by 373 | apply tyLam; apply tyAp 374 | · trivial 375 | · apply tyAp 376 | · trivial 377 | · exact tyZero 378 | 379 | theorem two_ty : Γ ⊢ (ƛ "s" : `"s" $ `"s" $ 𝟘) □ succC ⦂ ℕt := by 380 | apply tyAp twice_ty 381 | · apply tyLam; apply tySucc; trivial 382 | 383 | -- https://plfa.github.io/Lambda/#derivation 384 | abbrev NatC (t : Ty) : Ty := (t =⇒ t) =⇒ t =⇒ t 385 | 386 | theorem twoC_ty : Γ ⊢ twoC ⦂ NatC t := by 387 | apply tyLam; apply tyLam; apply tyAp 388 | · trivial 389 | · apply tyAp <;> trivial 390 | 391 | def addTy : Γ ⊢ add ⦂ ℕt =⇒ ℕt =⇒ ℕt := by 392 | repeat apply_rules [tyAp, tyMu, tyLam, tyCase, tySucc, tyZero] <;> trivial 393 | 394 | theorem addC_ty : Γ ⊢ addC ⦂ NatC t =⇒ NatC t =⇒ NatC t := by 395 | repeat apply tyLam <;> try trivial 396 | · repeat apply tyAp <;> try trivial 397 | 398 | -- https://plfa.github.io/Lambda/#exercise-mul-recommended-1 399 | def mulTy : Γ ⊢ mul ⦂ ℕt =⇒ ℕt =⇒ ℕt := by 400 | repeat apply_rules [tyAp, tyMu, tyLam, tyCase, tySucc, tyZero] <;> trivial 401 | 402 | -- https://plfa.github.io/Lambda/#exercise-mul%E1%B6%9C-practice-1 403 | theorem mulC_ty : Γ ⊢ mulC ⦂ NatC t =⇒ NatC t =⇒ NatC t := by 404 | repeat apply tyLam <;> try trivial 405 | · repeat apply tyAp <;> try trivial 406 | end Context 407 | 408 | section examples 409 | open Term Context Lookup IsTy 410 | 411 | -- https://plfa.github.io/Lambda/#non-examples 412 | example : ∅ ⊬ 𝟘 □ 1 := by 413 | by_contra h; simp_all only [not_isEmpty_iff] 414 | cases h.some; contradiction 415 | 416 | abbrev illLam := ƛ "x" : `"x" □ `"x" 417 | 418 | lemma nty_illLam : ∅ ⊬ illLam := by 419 | by_contra h; simp_all only [not_isEmpty_iff] 420 | let tyLam (tyAp (tyVar hx) (tyVar hx')) := h.some 421 | have := Lookup.functional hx hx'; simp_all only [Ty.t_to_t'_ne_t] 422 | 423 | -- https://plfa.github.io/Lambda/#quiz-3 424 | example : ∅‚ "y" ⦂ ℕt =⇒ ℕt‚ "x" ⦂ ℕt ⊢ `"y" □ `"x" ⦂ ℕt := by 425 | apply tyAp <;> trivial 426 | 427 | example : ∅‚ "y" ⦂ ℕt =⇒ ℕt‚ "x" ⦂ ℕt ⊬ `"x" □ `"y" := by 428 | by_contra h; simp_all only [not_isEmpty_iff] 429 | let ⟨ht⟩ := h 430 | cases ht; rename_i hy hx 431 | · cases hx; rename_i ty hx 432 | · cases hx; contradiction 433 | 434 | example : ∅‚ "y" ⦂ ℕt =⇒ ℕt ⊢ ƛ "x" : `"y" □ `"x" ⦂ ℕt =⇒ ℕt := by 435 | apply tyLam; apply tyAp <;> trivial 436 | 437 | example : ∅‚ "x" ⦂ t ⊬ `"x" □ `"x" := by 438 | by_contra h; simp_all only [not_isEmpty_iff] 439 | let ⟨ht⟩ := h 440 | cases ht; rename_i hx 441 | · cases hx; rename_i hx 442 | · cases hx <;> contradiction 443 | 444 | example 445 | : ∅‚ "x" ⦂ ℕt =⇒ ℕt‚ "y" ⦂ ℕt =⇒ ℕt 446 | ⊢ ƛ "z" : (`"x" $ `"y" $ `"z") ⦂ ℕt =⇒ ℕt 447 | := by 448 | apply tyLam; apply tyAp <;> try trivial 449 | · apply tyAp <;> trivial 450 | end examples 451 | -------------------------------------------------------------------------------- /Plfl/Lambda/Properties.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Properties/ 2 | 3 | import Plfl.Init 4 | import Plfl.Lambda 5 | 6 | open Lambda 7 | 8 | namespace Properties 9 | 10 | open Context Context.IsTy Term.Reduce 11 | open Sum 12 | 13 | -- https://plfa.github.io/Properties/#values-do-not-reduce 14 | def Value.empty_reduce : Value m → ∀ {n}, IsEmpty (m —→ n) := by 15 | introv v; is_empty; intro r 16 | cases v <;> try contradiction 17 | · case succ v => cases r; · case succξ => apply (empty_reduce v).false; trivial 18 | 19 | def Reduce.empty_value : m —→ n → IsEmpty (Value m) := by 20 | intro r; is_empty; intro v 21 | have : ∀ {n}, IsEmpty (m —→ n) := Value.empty_reduce v 22 | exact this.false r 23 | 24 | -- https://plfa.github.io/Properties/#exercise-canonical--practice 25 | inductive Canonical : Term → Ty → Type where 26 | | canLam : ∅‚ x ⦂ t ⊢ n ⦂ u → Canonical (ƛ x : n) (t =⇒ u) 27 | | canZero : Canonical 𝟘 ℕt 28 | | canSucc : Canonical n ℕt → Canonical (ι n) ℕt 29 | 30 | namespace Canonical 31 | def ofIsTy : ∅ ⊢ m ⦂ t → Value m → Canonical m t 32 | | tyLam l, Value.lam => canLam l 33 | | tyZero, V𝟘 => canZero 34 | | tySucc t, Value.succ m => canSucc <| ofIsTy t m 35 | 36 | def wellTyped : Canonical v t → ∅ ⊢ v ⦂ t × Value v := by 37 | intro 38 | | canLam h => exact ⟨tyLam h, Value.lam⟩ 39 | | canZero => exact ⟨tyZero, V𝟘⟩ 40 | | canSucc h => have ⟨ty, v⟩ := wellTyped h; exact ⟨tySucc ty, Value.succ v⟩ 41 | 42 | def wellTypedInv : ∅ ⊢ v ⦂ t × Value v → Canonical v t := by 43 | intro 44 | | ⟨tyLam ty, Value.lam⟩ => exact canLam ty 45 | | ⟨tyZero, Value.zero⟩ => exact canZero 46 | | ⟨tySucc ty, Value.succ v⟩ => apply canSucc; exact wellTypedInv ⟨ty, v⟩ 47 | 48 | lemma wellTyped_left_inv (c : Canonical v t) 49 | : wellTypedInv (wellTyped c) = c 50 | := by 51 | cases c with simp_all only [wellTypedInv, Prod.mk.eta, canSucc.injEq] 52 | | canSucc c' => rename_i v'; exact @wellTyped_left_inv v' ℕt c' 53 | 54 | lemma wellTyped_right_inv (c : ∅ ⊢ v ⦂ t × Value v) 55 | : wellTyped (wellTypedInv c) = c 56 | := by 57 | match c with 58 | | ⟨tyLam ty, Value.lam⟩ => simp_all only [wellTyped] 59 | | ⟨tyZero, Value.zero⟩ => simp_all only [wellTyped] 60 | | ⟨tySucc ty, Value.succ n⟩ => 61 | rename_i v'; have := @wellTyped_right_inv v' ℕt ⟨ty, n⟩; 62 | rw [wellTypedInv, wellTyped]; split 63 | · simp_all only [Prod.mk.injEq] 64 | 65 | /-- 66 | The Canonical forms are exactly the well-typed values. 67 | -/ 68 | instance : Canonical v t ≃ (∅ ⊢ v ⦂ t) × Value v where 69 | toFun := wellTyped 70 | invFun := wellTypedInv 71 | left_inv := wellTyped_left_inv 72 | right_inv := wellTyped_right_inv 73 | end Canonical 74 | 75 | def canonical : ∅ ⊢ m ⦂ t → Value m → Canonical m t := Canonical.ofIsTy 76 | 77 | -- https://plfa.github.io/Properties/#progress 78 | /-- 79 | If a term `m` is not ill-typed, then it either is a value or can be reduced. 80 | -/ 81 | inductive Progress (m : Term) where 82 | | step : (m —→ n) → Progress m 83 | | done : Value m → Progress m 84 | --^ In general, the rule of thumb is to consider the easy case (`step`) before the hard case (`done`) for easier proofs. 85 | 86 | namespace Progress 87 | def ofIsTy : ∅ ⊢ m ⦂ t → Progress m := by 88 | intro 89 | | tyVar _ => contradiction 90 | | tyLam _ => exact done Value.lam 91 | | tyAp jl jm => cases ofIsTy jl with 92 | | step => apply step; · apply apξ₁; trivial 93 | | done vl => cases ofIsTy jm with 94 | | step => apply step; apply apξ₂ <;> trivial 95 | | done => cases vl with 96 | | lam => apply step; apply lamβ; trivial 97 | | _ => contradiction 98 | | tyZero => exact done V𝟘 99 | | tySucc j => cases ofIsTy j with 100 | | step => apply step; apply succξ; trivial 101 | | done => apply done; apply Value.succ; trivial 102 | | tyCase jl jm jn => cases ofIsTy jl with 103 | | step => apply step; apply caseξ; trivial 104 | | done vl => cases vl with 105 | | lam => trivial 106 | | zero => exact step zeroβ 107 | | succ => apply step; apply succβ; trivial 108 | | tyMu _ => exact step muβ 109 | end Progress 110 | 111 | def progress : ∅ ⊢ m ⦂ t → Progress m := Progress.ofIsTy 112 | 113 | -- https://plfa.github.io/Properties/#exercise-value-practice 114 | def IsTy.isValue : ∅ ⊢ m ⦂ t → Decidable (Nonempty (Value m)) := by 115 | intro j; cases progress j 116 | · rename_i n r; have := Reduce.empty_value r 117 | apply isFalse; simp_all only [not_nonempty_iff] 118 | · exact isTrue ⟨by trivial⟩ 119 | 120 | def Progress' (m : Term) : Type := Value m ⊕ Σ n, m —→ n 121 | 122 | namespace Progress' 123 | -- https://plfa.github.io/Properties/#exercise-progress-practice 124 | def ofIsTy : ∅ ⊢ m ⦂ t → Progress' m := by 125 | intro 126 | | tyVar _ => contradiction 127 | | tyLam _ => exact inl Value.lam 128 | | tyAp jl jm => match ofIsTy jl with 129 | | inr ⟨n, r⟩ => exact inr ⟨_, apξ₁ r⟩ 130 | | inl vl => match ofIsTy jm with 131 | | inr ⟨n, r⟩ => apply inr; exact ⟨_, apξ₂ vl r⟩ 132 | | inl _ => cases canonical jl vl with 133 | | canLam => apply inr; refine ⟨_, lamβ ?_⟩; trivial 134 | | tyZero => exact inl V𝟘 135 | | tySucc j => match ofIsTy j with 136 | | inl v => apply inl; exact Value.succ v 137 | | inr ⟨n, r⟩ => exact inr ⟨_, succξ r⟩ 138 | | tyCase jl jm jn => match ofIsTy jl with 139 | | inr ⟨n, r⟩ => exact inr ⟨_, caseξ r⟩ 140 | | inl vl => cases vl with 141 | | lam => trivial 142 | | zero => exact inr ⟨_, zeroβ⟩ 143 | | succ v => exact inr ⟨_, succβ v⟩ 144 | | tyMu _ => exact inr ⟨_, muβ⟩ 145 | end Progress' 146 | 147 | namespace Progress 148 | -- https://plfa.github.io/Properties/#exercise-progress--practice 149 | @[simp] def toProgress' : Progress m → Progress' m | step r => inr ⟨_, r⟩ | done v => inl v 150 | @[simp] def fromProgress' : Progress' m → Progress m | inl v => done v | inr ⟨_, r⟩ => step r 151 | 152 | instance : Progress m ≃ Progress' m where 153 | toFun := toProgress' 154 | invFun := fromProgress' 155 | left_inv := by intro x; cases x <;> simp_all only [fromProgress', Progress', toProgress'] 156 | right_inv := by intro x; cases x <;> simp_all only [Progress', toProgress', fromProgress'] 157 | end Progress 158 | 159 | -- https://plfa.github.io/Properties/#renaming 160 | namespace Renaming 161 | open Lookup 162 | 163 | /-- 164 | If one context maps to another, the mapping holds after adding the same variable to both contexts. 165 | -/ 166 | def ext 167 | : (∀ {x tx}, Γ ∋ x ⦂ tx → Δ ∋ x ⦂ tx) 168 | → (∀ {x y tx ty}, Γ‚ y ⦂ ty ∋ x ⦂ tx → Δ‚ y ⦂ ty ∋ x ⦂ tx) 169 | := by 170 | introv ρ; intro 171 | | z => exact z 172 | | s nxy lx => exact s nxy <| ρ lx 173 | 174 | def rename 175 | : (∀ {x t}, Γ ∋ x ⦂ t → Δ ∋ x ⦂ t) 176 | → (∀ {m t}, Γ ⊢ m ⦂ t → Δ ⊢ m ⦂ t) 177 | := by 178 | introv ρ; intro 179 | | tyVar j => apply tyVar; exact ρ j 180 | | tyLam j => apply tyLam; exact rename (ext ρ) j 181 | | tyAp jl jm => 182 | apply tyAp 183 | · exact rename ρ jl 184 | · exact rename ρ jm 185 | | tyZero => apply tyZero 186 | | tySucc j => apply tySucc; exact rename ρ j 187 | | tyCase jl jm jn => 188 | apply tyCase 189 | · exact rename ρ jl 190 | · exact rename ρ jm 191 | · exact rename (ext ρ) jn 192 | | tyMu j => apply tyMu; exact rename (ext ρ) j 193 | 194 | def Lookup.weaken : ∅ ∋ m ⦂ t → Γ ∋ m ⦂ t := by 195 | intro. 196 | 197 | def weaken : ∅ ⊢ m ⦂ t → Γ ⊢ m ⦂ t := by 198 | intro j; refine rename ?_ j; exact Lookup.weaken 199 | 200 | def drop 201 | : Γ‚ x ⦂ t'‚ x ⦂ t ⊢ y ⦂ u 202 | → Γ‚ x ⦂ t ⊢ y ⦂ u 203 | := by 204 | intro j; refine rename ?_ j 205 | intro y u j; cases j 206 | · exact z 207 | · case s j => 208 | cases j 209 | · contradiction 210 | · case s j => refine s ?_ j; trivial 211 | 212 | def Lookup.swap 213 | : (x ≠ x') → (Γ‚ x' ⦂ t'‚ x ⦂ t ∋ y ⦂ u) 214 | → (Γ‚ x ⦂ t‚ x' ⦂ t' ∋ y ⦂ u) 215 | := by 216 | intro n j; cases j 217 | · exact s n z 218 | · case s j => 219 | cases j 220 | · exact z 221 | · apply s 222 | · trivial 223 | · apply s <;> trivial 224 | 225 | def swap 226 | : x ≠ x' → Γ‚ x' ⦂ t'‚ x ⦂ t ⊢ y ⦂ u 227 | → Γ‚ x ⦂ t‚ x' ⦂ t' ⊢ y ⦂ u 228 | := by 229 | intro n j; refine rename ?_ j; introv; exact Lookup.swap n 230 | end Renaming 231 | 232 | -- https://plfa.github.io/Properties/#substitution 233 | def subst 234 | : ∅ ⊢ y ⦂ t → Γ‚ x ⦂ t ⊢ n ⦂ u 235 | → Γ ⊢ n[x := y] ⦂ u 236 | := open Renaming in by 237 | intro j; intro 238 | | tyVar k => 239 | rename_i y; by_cases y = x <;> simp_all only [Term.subst, ite_true] 240 | · have := weaken (Γ := Γ) j; cases k <;> try trivial 241 | · cases k <;> simp_all only [not_true]; · repeat trivial 242 | | tyLam k => 243 | rename_i y _ _ _; by_cases h : y = x <;> ( 244 | simp_all only [Term.subst, ite_true]; apply tyLam 245 | ) 246 | · subst h; apply drop; trivial 247 | · apply subst j; exact swap (by trivial) k 248 | | tyAp k l => apply tyAp <;> (apply subst j; trivial) 249 | | tyZero => exact tyZero 250 | | tySucc _ => apply tySucc; apply subst j; trivial 251 | | tyCase k l m => 252 | rename_i y _; by_cases h : y = x <;> simp_all only [Term.subst, ite_true] 253 | · apply tyCase 254 | · apply subst j; exact k 255 | · apply subst j; exact l 256 | · subst h; exact drop m 257 | · apply tyCase <;> (apply subst j; try trivial) 258 | · exact swap (by trivial) m 259 | | tyMu k => 260 | rename_i y _; by_cases h : y = x <;> simp_all only [Term.subst, ite_true] 261 | · subst h; apply tyMu; exact drop k 262 | · apply tyMu; apply subst j; exact swap (by trivial) k 263 | 264 | -- https://plfa.github.io/Properties/#preservation 265 | def preserve : ∅ ⊢ m ⦂ t → (m —→ n) → ∅ ⊢ n ⦂ t := by 266 | intro 267 | | tyAp jl jm, lamβ _ => apply subst jm; cases jl; · trivial 268 | | tyAp jl jm, apξ₁ _ => 269 | apply tyAp <;> try trivial 270 | · apply preserve jl; trivial 271 | | tyAp jl jm, apξ₂ _ _ => 272 | apply tyAp <;> try trivial 273 | · apply preserve jm; trivial 274 | | tySucc j, succξ r => apply tySucc; exact preserve j r 275 | | tyCase k l m, zeroβ => trivial 276 | | tyCase k l m, succβ _ => refine subst ?_ m; cases k; · trivial 277 | | tyCase k l m, caseξ _ => 278 | apply tyCase <;> try trivial 279 | · apply preserve k; trivial 280 | | tyMu j, muβ => refine subst ?_ j; apply tyMu; trivial 281 | 282 | -- https://plfa.github.io/Properties/#evaluation 283 | inductive Result n where 284 | | done (val : Value n) 285 | | dnf 286 | deriving BEq, DecidableEq, Repr 287 | 288 | inductive Steps (l : Term) where 289 | | steps : ∀{n : Term}, (l —↠ n) → Result n → Steps l 290 | deriving Repr 291 | 292 | open Result Steps 293 | 294 | def eval (gas : ℕ) (j : ∅ ⊢ l ⦂ t) : Steps l := open Clos in 295 | if gas = 0 then 296 | ⟨nil, dnf⟩ 297 | else 298 | match progress j with 299 | | Progress.done v => steps nil <| done v 300 | | Progress.step r => 301 | let ⟨rs, res⟩ := eval (gas - 1) (preserve j r) 302 | ⟨cons r rs, res⟩ 303 | 304 | section examples 305 | open Term 306 | 307 | -- def x : ℕ := x + 1 308 | abbrev succμ := μ "x" : ι `"x" 309 | 310 | abbrev tySuccμ : ∅ ⊢ succμ ⦂ ℕt := by 311 | apply tyMu; apply tySucc; trivial 312 | 313 | #eval eval 3 tySuccμ |>.3 314 | 315 | abbrev add_2_2 := add □ 2 □ 2 316 | 317 | abbrev two_ty : ∅ ⊢ 2 ⦂ ℕt := by 318 | iterate 2 (apply tySucc) 319 | · exact tyZero 320 | 321 | abbrev tyAdd_2_2 : ∅ ⊢ add_2_2 ⦂ ℕt := by 322 | apply tyAp 323 | · apply tyAp 324 | · exact addTy 325 | · iterate 2 (apply tySucc) 326 | · exact tyZero 327 | · iterate 2 (apply tySucc) 328 | · exact tyZero 329 | 330 | #eval eval 100 tyAdd_2_2 |>.3 331 | end examples 332 | 333 | section subject_expansion 334 | open Term 335 | 336 | -- https://plfa.github.io/Properties/#exercise-subject_expansion-practice 337 | example : IsEmpty (∀ {n t m}, ∅ ⊢ n ⦂ t → (m —→ n) → ∅ ⊢ m ⦂ t) := by 338 | by_contra; simp_all only [isEmpty_pi, not_exists, not_isEmpty_iff] 339 | let illCase := 𝟘? 𝟘 [zero: 𝟘 |succ "x" : add] 340 | have nty_ill : ∅ ⊬ illCase := by 341 | by_contra; simp_all only [not_isEmpty_iff]; rename_i t j 342 | cases t <;> (simp only [illCase] at j; cases j; · contradiction) 343 | rename_i f; have := f 𝟘 ℕt illCase tyZero zeroβ 344 | exact nty_ill.false this.some 345 | 346 | example : IsEmpty (∀ {n t m}, ∅ ⊢ n ⦂ t → (m —→ n) → ∅ ⊢ m ⦂ t) := by 347 | by_contra; simp_all only [isEmpty_pi, not_exists, not_isEmpty_iff] 348 | let illAp := (ƛ "x" : 𝟘) □ illLam 349 | have nty_ill : ∅ ⊬ illAp := by 350 | by_contra; simp_all only [not_isEmpty_iff]; rename_i t j 351 | cases t <;> ( 352 | · cases j 353 | · rename_i j; simp only [illAp] at j; cases j 354 | · apply nty_illLam.false <;> trivial 355 | ) 356 | rename_i f; have := f 𝟘 ℕt illAp tyZero (lamβ Value.lam) 357 | exact nty_ill.false this.some 358 | end subject_expansion 359 | 360 | -- https://plfa.github.io/Properties/#well-typed-terms-dont-get-stuck 361 | abbrev Normal m := ∀ {n}, IsEmpty (m —→ n) 362 | abbrev Stuck m := Normal m ∧ IsEmpty (Value m) 363 | 364 | example : Stuck (` "x") := by 365 | unfold Stuck Normal; constructor 366 | · intro n; is_empty; nofun 367 | · is_empty; nofun 368 | 369 | -- https://plfa.github.io/Properties/#exercise-unstuck-recommended 370 | /-- 371 | No well-typed term can be stuck. 372 | -/ 373 | def unstuck : ∅ ⊢ m ⦂ t → IsEmpty (Stuck m) := by 374 | intro j; is_empty; simp_all only [and_imp] 375 | intro n ns; cases progress j 376 | · case step s => exact n.false s 377 | · case done v => exact ns.false v 378 | 379 | /-- 380 | After any number of steps, a well-typed term remains well typed. 381 | -/ 382 | def preserves : ∅ ⊢ m ⦂ t → (m —↠ n) → ∅ ⊢ n ⦂ t := by 383 | intro j; intro 384 | | Clos.nil => trivial 385 | | Clos.cons car cdr => refine preserves ?_ cdr; exact preserve j car 386 | 387 | /-- 388 | _Well-typed terms don't get stuck_ (WTTDGS): 389 | starting from a well-typed term, taking any number of reduction steps leads to a term that is not stuck. 390 | -/ 391 | def preserves_unstuck : ∅ ⊢ m ⦂ t → (m —↠ n) → IsEmpty (Stuck n) := by 392 | intro j r; have := preserves j r; exact unstuck this 393 | 394 | -- https://plfa.github.io/Properties/#reduction-is-deterministic 395 | def Reduce.det : (m —→ n) → (m —→ n') → n = n' := by 396 | intro r r'; cases r 397 | · case lamβ => 398 | cases r' <;> try trivial 399 | · case apξ₂ => exfalso; rename_i v _ _ r; exact (Value.empty_reduce v).false r 400 | · case apξ₁ => 401 | cases r' <;> try trivial 402 | · case apξ₁ => simp only [Term.ap.injEq, and_true]; apply det <;> trivial 403 | · case apξ₂ => exfalso; rename_i r _ v _; exact (Value.empty_reduce v).false r 404 | · case apξ₂ => 405 | cases r' <;> try trivial 406 | · case lamβ => exfalso; rename_i r _ _ _ v; exact (Value.empty_reduce v).false r 407 | · case apξ₁ => exfalso; rename_i v _ _ r; exact (Value.empty_reduce v).false r 408 | · case apξ₂ => simp only [Term.ap.injEq, true_and]; apply det <;> trivial 409 | · case zeroβ => cases r' <;> try trivial 410 | · case succβ => 411 | cases r' <;> try trivial 412 | · case caseξ => exfalso; rename_i v _ r; exact (Value.empty_reduce (Value.succ v)).false r 413 | · case succξ => cases r'; · case succξ => simp only [Term.succ.injEq]; apply det <;> trivial 414 | · case caseξ => 415 | cases r' <;> try trivial 416 | · case succβ => exfalso; rename_i v r; exact (Value.empty_reduce (Value.succ v)).false r 417 | · case caseξ => simp only [Term.case.injEq, and_self, and_true]; apply det <;> trivial 418 | · case muβ => cases r'; try trivial 419 | 420 | -- https://plfa.github.io/Properties/#quiz 421 | /- 422 | Suppose we add a new term zap with the following reduction rule 423 | 424 | -------- β-zap 425 | M —→ zap 426 | and the following typing rule: 427 | 428 | ----------- ⊢zap 429 | Γ ⊢ zap ⦂ A 430 | Which of the following properties remain true in the presence of these rules? For each property, write either "remains true" or "becomes false." If a property becomes false, give a counterexample: 431 | 432 | * Determinism 433 | 434 | Becomes false. 435 | The term `(ƛ x ⇒ `"x") □ 𝟘` can both be reduced via: 436 | · apξ₁, to zap □ 𝟘 437 | · zepβ, to zap 438 | ... and they're not equal. 439 | 440 | * Progress/Preservation 441 | 442 | Remains true. 443 | -/ 444 | 445 | 446 | -- https://plfa.github.io/Properties/#quiz-1 447 | /- 448 | Suppose instead that we add a new term foo with the following reduction rules: 449 | 450 | ------------------ β-foo₁ 451 | (λ x ⇒ ` x) —→ foo 452 | 453 | ----------- β-foo₂ 454 | foo —→ zero 455 | Which of the following properties remain true in the presence of this rule? For each one, write either "remains true" or else "becomes false." If a property becomes false, give a counterexample: 456 | 457 | * Determinism 458 | 459 | Becomes false. 460 | 461 | The term `(ƛ x ⇒ `"x") □ 𝟘` can both be reduced via: 462 | · apξ₁, to foo □ 𝟘 463 | · lamβ, to `"x" 464 | ... and they're not equal. 465 | 466 | * Progress 467 | 468 | Becomes false. 469 | The term `(ƛ x ⇒ `"x") □ 𝟘` can be reduced via: 470 | · apξ₁ fooβ₁, to foo □ 𝟘 471 | · then apξ₁ fooβ₂, to 𝟘 □ 𝟘 472 | ... and now the term get's stuck. 473 | 474 | * Preservation 475 | 476 | Becomes false. 477 | The term `(ƛ x ⇒ `"x") ⦂ ℕt =⇒ ℕt` can be reduced via: 478 | · fooβ₁, to foo 479 | · then fooβ₂, 𝟘 ⦂ ℕt 480 | ... and (ℕt =⇒ ℕt) ≠ ℕt 481 | 482 | -/ 483 | 484 | -- https://plfa.github.io/Properties/#quiz-2 485 | /- 486 | Suppose instead that we remove the rule ξ·₁ from the step relation. Which of the following properties remain true in the absence of this rule? For each one, write either "remains true" or else "becomes false." If a property becomes false, give a counterexample: 487 | 488 | * Determinism/Preservation 489 | 490 | Remains true. 491 | 492 | * Progress 493 | 494 | Becomes false. 495 | The term `(ƛ x ⇒ `"x") □ 𝟘` is well-typed but gets stucked. 496 | -/ 497 | 498 | -- https://plfa.github.io/Properties/#quiz-3 499 | /- 500 | We can enumerate all the computable function from naturals to naturals, by writing out all programs of type `ℕ ⇒ `ℕ in lexical order. Write fᵢ for the i’th function in this list. 501 | 502 | NB: A ℕ → ℕ function can be seen as a stream of ℕ's, where the i'th ℕ stands for f(i). 503 | 504 | Say we add a typing rule that applies the above enumeration to interpret a natural as a function from naturals to naturals: 505 | 506 | Γ ⊢ L ⦂ `ℕ 507 | Γ ⊢ M ⦂ `ℕ 508 | -------------- _·ℕ_ 509 | Γ ⊢ L · M ⦂ `ℕ 510 | And that we add the corresponding reduction rule: 511 | 512 | fᵢ(m) —→ n 513 | ---------- δ 514 | i · m —→ n 515 | Which of the following properties remain true in the presence of these rules? For each one, write either "remains true" or else "becomes false." If a property becomes false, give a counterexample: 516 | 517 | * Determinism/Preservation 518 | 519 | Remains true. 520 | The only change is that the terms that were once stuck now might continue to progress. 521 | 522 | * Progress 523 | 524 | Becomes false. 525 | Since a computable function can be partial, the reduction might not halt. 526 | 527 | 528 | Are all properties preserved in this case? Are there any other alterations we would wish to make to the system? 529 | -/ 530 | -------------------------------------------------------------------------------- /Plfl/More.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/More/ 2 | 3 | import Plfl.Init 4 | 5 | -- This module was extended from the original one for . 6 | namespace More 7 | 8 | -- https://plfa.github.io/More/#types 9 | inductive Ty where 10 | /-- Native natural type made of 𝟘 and ι. -/ 11 | | nat : Ty 12 | /-- Primitive natural type, a simple wrapper around LEAN's own ℕ type. -/ 13 | | natP : Ty 14 | /-- Product type. -/ 15 | | prod : Ty → Ty → Ty 16 | /-- Sum type. -/ 17 | | sum : Ty → Ty → Ty 18 | /-- Arrow type. -/ 19 | | fn : Ty → Ty → Ty 20 | /-- Unit type. -/ 21 | | unit : Ty 22 | /-- Void type. -/ 23 | | void : Ty 24 | /-- List type. -/ 25 | | list : Ty → Ty 26 | deriving BEq, DecidableEq, Repr 27 | 28 | namespace Notation 29 | open Ty 30 | 31 | scoped notation "ℕt" => nat 32 | scoped notation "ℕp" => natP 33 | 34 | -- Operator overloadings for `prod` and `sum` types. 35 | instance : Mul Ty where mul := prod 36 | instance : Add Ty where add := sum 37 | 38 | scoped infixr:70 " =⇒ " => fn 39 | scoped notation "◯" => unit 40 | scoped notation "∅" => void 41 | end Notation 42 | 43 | open Notation 44 | 45 | namespace Ty 46 | example : Ty := (ℕt =⇒ ℕt) =⇒ ℕt 47 | example : Ty := ℕp * ℕt 48 | 49 | theorem t_to_t'_ne_t (t t' : Ty) : (t =⇒ t') ≠ t := by 50 | by_contra h; match t with 51 | | nat => contradiction 52 | | fn ta tb => injection h; have := t_to_t'_ne_t ta tb; contradiction 53 | end Ty 54 | 55 | -- https://plfa.github.io/DeBruijn/#contexts 56 | abbrev Context : Type := List Ty 57 | 58 | namespace Context 59 | abbrev snoc (Γ : Context) (a : Ty) : Context := a :: Γ 60 | abbrev lappend (Γ : Context) (Δ : Context) : Context := Δ ++ Γ 61 | end Context 62 | 63 | namespace Notation 64 | open Context 65 | 66 | -- `‚` is not a comma! See: 67 | scoped infixl:50 "‚ " => snoc 68 | scoped infixl:45 "‚‚ " => lappend 69 | end Notation 70 | 71 | -- https://plfa.github.io/DeBruijn/#variables-and-the-lookup-judgment 72 | inductive Lookup : Context → Ty → Type where 73 | | z : Lookup (Γ‚ t) t 74 | | s : Lookup Γ t → Lookup (Γ‚ t') t 75 | deriving DecidableEq, Repr 76 | 77 | namespace Notation 78 | open Lookup 79 | 80 | scoped infix:40 " ∋ " => Lookup 81 | 82 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/macros.md#simplifying-macro-declaration 83 | scoped syntax "get_elem" (ppSpace term) : term 84 | scoped macro_rules | `(term| get_elem $n) => match n.1.toNat with 85 | | 0 => `(term| Lookup.z) 86 | | n+1 => `(term| Lookup.s (get_elem $(Lean.quote n))) 87 | 88 | scoped macro "♯" n:term:90 : term => `(get_elem $n) 89 | end Notation 90 | 91 | namespace Lookup 92 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt := .z 93 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt := ♯0 94 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt =⇒ ℕt := .s .z 95 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ∋ ℕt =⇒ ℕt := ♯1 96 | end Lookup 97 | 98 | -- https://plfa.github.io/DeBruijn/#terms-and-the-typing-judgment 99 | /-- 100 | A term with typing judgement embedded in itself. 101 | -/ 102 | inductive Term : Context → Ty → Type where 103 | -- Lookup 104 | | var : Γ ∋ a → Term Γ a 105 | -- Lambda 106 | | lam : Term (Γ‚ a) b → Term Γ (a =⇒ b) 107 | | ap : Term Γ (a =⇒ b) → Term Γ a → Term Γ b 108 | -- Native natural 109 | | zero : Term Γ ℕt 110 | | succ : Term Γ ℕt → Term Γ ℕt 111 | | case : Term Γ ℕt → Term Γ a → Term (Γ‚ ℕt) a → Term Γ a 112 | -- Fixpoint 113 | | mu : Term (Γ‚ a) a → Term Γ a 114 | -- Primitive natural 115 | | prim : ℕ → Term Γ ℕp 116 | | mulP : Term Γ ℕp → Term Γ ℕp → Term Γ ℕp 117 | -- Let expression 118 | | let : Term Γ a → Term (Γ‚ a) b → Term Γ b 119 | -- Product 120 | | prod : Term Γ a → Term Γ b → Term Γ (a * b) 121 | | fst : Term Γ (a * b) → Term Γ a 122 | | snd : Term Γ (a * b) → Term Γ b 123 | -- Product (alternative formulation) 124 | -- | caseProd : Term Γ (a * b) → Term (Γ‚ a‚ b) c → Term Γ c 125 | -- Sum 126 | | left : Term Γ a → Term Γ (a + b) 127 | | right : Term Γ b → Term Γ (a + b) 128 | | caseSum : Term Γ (a + b) → Term (Γ‚ a) c → Term (Γ‚ b) c → Term Γ c 129 | -- Void 130 | | caseVoid : Term Γ ∅ → Term Γ a 131 | -- Unit 132 | | unit : Term Γ ◯ 133 | -- List 134 | | nil : Term Γ (.list a) 135 | | cons : Term Γ a → Term Γ (.list a) → Term Γ (.list a) 136 | | caseList : Term Γ (.list a) → Term Γ b → Term (Γ‚ a‚ .list a) b → Term Γ b 137 | deriving DecidableEq, Repr 138 | 139 | namespace Notation 140 | open Term 141 | 142 | scoped infix:40 " ⊢ " => Term 143 | 144 | scoped prefix:50 "ƛ " => lam 145 | scoped prefix:50 "μ " => mu 146 | scoped notation "𝟘? " => case 147 | scoped infixr:min " $ " => ap 148 | scoped infixl:70 " □ " => ap 149 | scoped infixl:70 " ⋄ " => mulP 150 | scoped prefix:80 "ι " => succ 151 | scoped prefix:90 "` " => var 152 | 153 | scoped notation "𝟘" => zero 154 | scoped notation "◯" => unit 155 | 156 | -- https://plfa.github.io/DeBruijn/#abbreviating-de-bruijn-indices 157 | scoped macro "#" n:term:90 : term => `(`♯$n) 158 | end Notation 159 | 160 | namespace Term 161 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #0 162 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt =⇒ ℕt := #1 163 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #1 $ #0 164 | example : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt := #1 $ #1 $ #0 165 | example : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 166 | 167 | def ofNat : ℕ → Γ ⊢ ℕt 168 | | 0 => .zero 169 | | n + 1 => .succ <| ofNat n 170 | 171 | instance : Coe ℕ (Γ ⊢ ℕt) where coe := ofNat 172 | instance : OfNat (Γ ⊢ ℕt) n where ofNat := ofNat n 173 | 174 | -- https://plfa.github.io/DeBruijn/#test-examples 175 | example : Γ ⊢ ℕt := ι ι 𝟘 176 | example : Γ ⊢ ℕt := 2 177 | 178 | @[simp] abbrev add : Γ ⊢ ℕt =⇒ ℕt =⇒ ℕt := μ ƛ ƛ (𝟘? (#1) (#0) (ι (#3 □ #0 □ #1))) 179 | abbrev four : Γ ⊢ ℕt := add □ 2 □ 2 180 | 181 | /-- 182 | The Church numeral Ty. 183 | -/ 184 | abbrev Ch (t : Ty) : Ty := (t =⇒ t) =⇒ t =⇒ t 185 | 186 | @[simp] abbrev succC : Γ ⊢ ℕt =⇒ ℕt := ƛ ι #0 187 | @[simp] abbrev twoC : Γ ⊢ Ch a := ƛ ƛ (#1 $ #1 $ #0) 188 | @[simp] abbrev addC : Γ ⊢ Ch a =⇒ Ch a =⇒ Ch a := ƛ ƛ ƛ ƛ (#3 □ #1 $ #2 □ #1 □ #0) 189 | abbrev four' : Γ ⊢ ℕt := addC □ twoC □ twoC □ succC □ 𝟘 190 | 191 | @[simp] abbrev mul : Γ ⊢ ℕt =⇒ ℕt =⇒ ℕt := μ ƛ ƛ (𝟘? (#1) 𝟘 (add □ #1 $ #3 □ #0 □ #1)) 192 | abbrev four'' : Γ ⊢ ℕt := mul □ 2 □ 2 193 | 194 | -- https://plfa.github.io/DeBruijn/#exercise-mul-recommended 195 | @[simp] abbrev mulC : Γ ⊢ Ch a =⇒ Ch a =⇒ Ch a := ƛ ƛ ƛ ƛ (#3 □ (#2 □ #1) □ #0) 196 | 197 | -- https://plfa.github.io/More/#example 198 | example : ∅ ⊢ ℕp =⇒ ℕp := ƛ #0 ⋄ #0 ⋄ #0 199 | end Term 200 | 201 | namespace Subst 202 | -- https://plfa.github.io/DeBruijn/#renaming 203 | /-- 204 | If one context maps to another, 205 | the mapping holds after adding the same variable to both contexts. 206 | -/ 207 | def ext : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ‚ b ∋ a → Δ‚ b ∋ a := by 208 | intro ρ; intro 209 | | .z => exact .z 210 | | .s x => refine .s ?_; exact ρ x 211 | 212 | /-- 213 | If one context maps to another, 214 | then the type judgements are the same in both contexts. 215 | -/ 216 | def rename : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ ⊢ a → Δ ⊢ a := by 217 | intro ρ; intro 218 | | ` x => exact ` (ρ x) 219 | | ƛ n => exact ƛ (rename (ext ρ) n) 220 | | l □ m => exact rename ρ l □ rename ρ m 221 | | 𝟘 => exact 𝟘 222 | | ι n => exact ι (rename ρ n) 223 | | 𝟘? l m n => exact 𝟘? (rename ρ l) (rename ρ m) (rename (ext ρ) n) 224 | | μ n => exact μ (rename (ext ρ) n) 225 | | .prim n => exact .prim n 226 | | m ⋄ n => exact rename ρ m ⋄ rename ρ n 227 | | .let m n => exact .let (rename ρ m) (rename (ext ρ) n) 228 | | .prod m n => exact .prod (rename ρ m) (rename ρ n) 229 | | .fst n => exact .fst (rename ρ n) 230 | | .snd n => exact .snd (rename ρ n) 231 | | .left n => exact .left (rename ρ n) 232 | | .right n => exact .right (rename ρ n) 233 | | .caseSum s l r => exact .caseSum (rename ρ s) (rename (ext ρ) l) (rename (ext ρ) r) 234 | | .caseVoid v => exact .caseVoid (rename ρ v) 235 | | ◯ => exact ◯ 236 | | .nil => exact .nil 237 | | .cons m n => exact .cons (rename ρ m) (rename ρ n) 238 | | .caseList l m n => exact .caseList (rename ρ l) (rename ρ m) (rename (ext (ext ρ)) n) 239 | 240 | abbrev shift : Γ ⊢ a → Γ‚ b ⊢ a := rename .s 241 | 242 | example 243 | : let m : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 244 | let m' : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#2 $ #2 $ #0) 245 | shift m = m' 246 | := rfl 247 | 248 | -- https://plfa.github.io/DeBruijn/#simultaneous-substitution 249 | /-- 250 | If the variables in one context maps to some terms in another, 251 | the mapping holds after adding the same variable to both contexts. 252 | -/ 253 | def exts : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ‚ b ∋ a → Δ‚ b ⊢ a := by 254 | intro σ; intro 255 | | .z => exact `.z 256 | | .s x => apply shift; exact σ x 257 | 258 | /-- 259 | General substitution for multiple free variables. 260 | If the variables in one context maps to some terms in another, 261 | then the type judgements are the same before and after the mapping, 262 | i.e. after replacing the free variables in the former with (expanded) terms. 263 | -/ 264 | def subst : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ ⊢ a → Δ ⊢ a := by 265 | intro σ; intro 266 | | ` i => exact σ i 267 | | ƛ n => exact ƛ (subst (exts σ) n) 268 | | l □ m => exact subst σ l □ subst σ m 269 | | 𝟘 => exact 𝟘 270 | | ι n => exact ι (subst σ n) 271 | | 𝟘? l m n => exact 𝟘? (subst σ l) (subst σ m) (subst (exts σ) n) 272 | | μ n => exact μ (subst (exts σ) n) 273 | | .prim n => exact .prim n 274 | | m ⋄ n => exact subst σ m ⋄ subst σ n 275 | | .let m n => exact .let (subst σ m) (subst (exts σ) n) 276 | | .prod m n => exact .prod (subst σ m) (subst σ n) 277 | | .fst n => exact .fst (subst σ n) 278 | | .snd n => exact .snd (subst σ n) 279 | | .left n => exact .left (subst σ n) 280 | | .right n => exact .right (subst σ n) 281 | | .caseSum s l r => exact .caseSum (subst σ s) (subst (exts σ) l) (subst (exts σ) r) 282 | | .caseVoid v => exact .caseVoid (subst σ v) 283 | | ◯ => exact ◯ 284 | | .nil => exact .nil 285 | | .cons m n => exact .cons (subst σ m) (subst σ n) 286 | | .caseList l m n => exact .caseList (subst σ l) (subst σ m) (subst (exts (exts σ)) n) 287 | 288 | abbrev subst₁σ (v : Γ ⊢ b) : ∀ {a}, Γ‚ b ∋ a → Γ ⊢ a := by 289 | introv; intro 290 | | .z => exact v 291 | | .s x => exact ` x 292 | 293 | /-- 294 | Substitution for one free variable `v` in the term `n`. 295 | -/ 296 | abbrev subst₁ (v : Γ ⊢ b) (n : Γ‚ b ⊢ a) : Γ ⊢ a := by 297 | refine subst ?_ n; exact subst₁σ v 298 | 299 | /-- 300 | Substitution for two free variables `v` and `w'` in the term `n`. 301 | -/ 302 | abbrev subst₂ (v : Γ ⊢ b) (w : Γ ⊢ c) (n : Γ‚ b‚ c ⊢ a) : Γ ⊢ a := by 303 | refine subst ?_ n; introv; intro 304 | | .z => exact w 305 | | .s .z => exact v 306 | | .s (.s x) => exact ` x 307 | end Subst 308 | 309 | namespace Notation 310 | open Subst 311 | 312 | scoped notation:90 n "⟦" m "⟧" => subst₁ m n 313 | end Notation 314 | 315 | open Subst 316 | 317 | namespace Subst 318 | example 319 | : let m : ∅ ⊢ ℕt =⇒ ℕt := ƛ (ι #0) 320 | let m' : ∅‚ ℕt =⇒ ℕt ⊢ ℕt =⇒ ℕt := ƛ (#1 $ #1 $ #0) 321 | let n : ∅ ⊢ ℕt =⇒ ℕt := ƛ (ƛ ι #0) □ ((ƛ ι #0) □ #0) 322 | m'⟦m⟧ = n 323 | := rfl 324 | 325 | example 326 | : let m : ∅‚ ℕt =⇒ ℕt ⊢ ℕt := #0 $ 𝟘 327 | let m' : ∅‚ ℕt =⇒ ℕt‚ ℕt ⊢ (ℕt =⇒ ℕt) =⇒ ℕt := ƛ (#0 $ #1) 328 | let n : ∅‚ ℕt =⇒ ℕt ⊢ (ℕt =⇒ ℕt) =⇒ ℕt := ƛ (#0 $ #1 $ 𝟘) 329 | m'⟦m⟧ = n 330 | := rfl 331 | end Subst 332 | 333 | inductive Value : Γ ⊢ a → Type where 334 | | lam : Value (ƛ (n : Γ‚ a ⊢ b)) 335 | | zero : Value 𝟘 336 | | succ : Value n → Value (ι n) 337 | | prim : (n : ℕ) → Value (@Term.prim Γ n) 338 | | prod : Value (v : Γ ⊢ a) → Value (w : Γ ⊢ b) → Value (.prod v w) 339 | | left : Value v → Value (.left v) 340 | | right : Value v → Value (.right v) 341 | | unit : Value ◯ 342 | | nil : Value .nil 343 | | cons : ∀ {v : Γ ⊢ a} {vs : Γ ⊢ .list a}, Value v → Value vs → Value (.cons v vs) 344 | deriving DecidableEq, Repr 345 | 346 | namespace Notation 347 | scoped notation "V𝟘" => Value.zero 348 | end Notation 349 | 350 | namespace Value 351 | def ofNat : (n : ℕ) → @Value Γ ℕt (Term.ofNat n) 352 | | 0 => V𝟘 353 | | n + 1 => succ <| ofNat n 354 | end Value 355 | 356 | -- https://plfa.github.io/DeBruijn/#reduction 357 | /-- 358 | `Reduce t t'` says that `t` reduces to `t'` via a given step. 359 | -/ 360 | inductive Reduce : (Γ ⊢ a) → (Γ ⊢ a) → Prop where 361 | | lamβ : Value v → Reduce ((ƛ n) □ v) (n⟦v⟧) 362 | | apξ₁ : Reduce l l' → Reduce (l □ m) (l' □ m) 363 | | apξ₂ : Value v → Reduce m m' → Reduce (v □ m) (v □ m') 364 | | zeroβ : Reduce (𝟘? 𝟘 m n) m 365 | | succβ : Value v → Reduce (𝟘? (ι v) m n) (n⟦v⟧) 366 | | succξ : Reduce m m' → Reduce (ι m) (ι m') 367 | | caseξ : Reduce l l' → Reduce (𝟘? l m n) (𝟘? l' m n) 368 | | muβ : Reduce (μ n) (n⟦μ n⟧) 369 | -- https://plfa.github.io/More/#reduction 370 | | mulPξ₁ : Reduce l l' → Reduce (l ⋄ m) (l' ⋄ m) 371 | | mulPξ₂ : Reduce m m' → Reduce (l ⋄ m) (l ⋄ m') 372 | | mulPδ : Reduce ((.prim c) ⋄ (.prim d)) (.prim (c * d)) 373 | -- https://plfa.github.io/More/#reduction-1 374 | | letξ : Reduce m m' → Reduce (.let m n) (.let m' n) 375 | | letβ : Value v → Reduce (.let v n) (n⟦v⟧) 376 | -- https://plfa.github.io/More/#reduction-2 377 | | prodξ₁ : Reduce m m' → Reduce (.prod m n) (.prod m' n) 378 | | prodξ₂ : Reduce n n' → Reduce (.prod m n) (.prod m n') 379 | | fstξ : Reduce l l' → Reduce (.fst l) (.fst l') 380 | | fstβ : Value v → Value w → Reduce (.fst (.prod v w)) v 381 | | sndξ : Reduce l l' → Reduce (.snd l) (.snd l') 382 | | sndβ : Value v → Value w → Reduce (.snd (.prod v w)) w 383 | -- https://plfa.github.io/More/#reduction-3 384 | -- | caseProdξ : Reduce l l' → Reduce (.caseProd l m) (.caseProd l' m) 385 | -- | caseProdβ 386 | -- : Value (v : Γ ⊢ a) 387 | -- → Value (w : Γ ⊢ b) 388 | -- → Reduce (.caseProd (.prod v w) (m : Γ‚ a‚ b ⊢ c)) (subst₂ v w m) 389 | -- https://plfa.github.io/More/#reduction-4 390 | | caseSumξ : Reduce s s' → Reduce (.caseSum s l r) (.caseSum s' l r) 391 | | leftξ : Reduce m m' → Reduce (.left m) (.left m') 392 | | leftβ : Value v → Reduce (.caseSum (.left v) l r) (l⟦v⟧) 393 | | rightξ : Reduce m m' → Reduce (.right m) (.right m') 394 | | rightβ : Value v → Reduce (.caseSum (.right v) l r) (r⟦v⟧) 395 | -- https://plfa.github.io/More/#reduction-7 396 | | caseVoidξ : Reduce l l' → Reduce (.caseVoid l) (.caseVoid l') 397 | -- https://plfa.github.io/More/#reduction-8 398 | | caseListξ : Reduce l l' → Reduce (.caseList l m n) (.caseList l' m n) 399 | | nilβ : Reduce (.caseList .nil m n) m 400 | | consξ₁ : Reduce m m' → Reduce (.cons m n) (.cons m' n) 401 | | consξ₂ : Reduce n n' → Reduce (.cons v n) (.cons v n') 402 | | consβ : Reduce (.caseList (.cons v w) m n) (subst₂ v w n) 403 | 404 | -- https://plfa.github.io/DeBruijn/#reflexive-and-transitive-closure 405 | 406 | namespace Notation 407 | scoped infix:40 " —→ " => Reduce 408 | end Notation 409 | 410 | namespace Reduce 411 | /-- 412 | A reflexive and transitive closure, 413 | defined as a sequence of zero or more steps of the underlying relation `—→`. 414 | -/ 415 | abbrev Clos {Γ a} := Relation.ReflTransGen (α := Γ ⊢ a) Reduce 416 | end Reduce 417 | 418 | namespace Notation 419 | scoped infix:20 " —↠ " => Reduce.Clos 420 | end Notation 421 | 422 | namespace Reduce.Clos 423 | abbrev refl : m —↠ m := .refl 424 | abbrev tail : (m —↠ n) → (n —→ n') → (m —↠ n') := .tail 425 | abbrev head : (m —→ n) → (n —↠ n') → (m —↠ n') := .head 426 | abbrev single : (m —→ n) → (m —↠ n) := .single 427 | 428 | instance : Coe (m —→ n) (m —↠ n) where coe r := .single r 429 | 430 | instance : Trans (α := Γ ⊢ a) Clos Reduce Clos where trans c r := c.tail r 431 | instance : Trans (α := Γ ⊢ a) Reduce Reduce Clos where trans r r' := .tail r r' 432 | instance : Trans (α := Γ ⊢ a) Reduce Clos Clos where trans r c := .head r c 433 | end Reduce.Clos 434 | 435 | namespace Reduce 436 | -- https://plfa.github.io/DeBruijn/#examples 437 | open Term 438 | 439 | example : twoC □ succC □ @zero ∅ —↠ 2 := calc 440 | twoC □ succC □ 𝟘 441 | _ —→ (ƛ (succC $ succC $ #0)) □ 𝟘 := by apply apξ₁; apply lamβ; exact Value.lam 442 | _ —→ (succC $ succC $ 𝟘) := by apply lamβ; exact V𝟘 443 | _ —→ succC □ 1 := by apply apξ₂; apply Value.lam; exact lamβ V𝟘 444 | _ —→ 2 := by apply lamβ; exact Value.ofNat 1 445 | end Reduce 446 | 447 | -- https://plfa.github.io/DeBruijn/#values-do-not-reduce 448 | def Value.not_reduce : Value m → ∀ {n}, ¬ m —→ n := by 449 | introv v; intro r 450 | cases v with try contradiction 451 | | succ v => cases r; · case succξ => apply not_reduce v; trivial 452 | | prod => cases r with 453 | | prodξ₁ r => rename_i v _ _; apply not_reduce v; trivial 454 | | prodξ₂ r => rename_i v _; apply not_reduce v; trivial 455 | | left v => cases r; · case leftξ => apply not_reduce v; trivial 456 | | right v => cases r; · case rightξ => apply not_reduce v; trivial 457 | | cons => cases r with 458 | | consξ₁ r => rename_i v _ _; apply not_reduce v; trivial 459 | | consξ₂ r => rename_i v _; apply not_reduce v; trivial 460 | 461 | def Reduce.empty_value : m —→ n → IsEmpty (Value m) := by 462 | intro r; is_empty; intro v; exact Value.not_reduce v r 463 | 464 | /-- 465 | If a term `m` is not ill-typed, then it either is a value or can be reduced. 466 | -/ 467 | inductive Progress (m : ∅ ⊢ a) where 468 | | step : (m —→ n) → Progress m 469 | | done : Value m → Progress m 470 | 471 | def Progress.progress : (m : ∅ ⊢ a) → Progress m := open Reduce in by 472 | intro 473 | | ` _ => contradiction 474 | | ƛ _ => exact .done .lam 475 | | l □ m => match progress l with 476 | | .step _ => apply step; apply apξ₁; trivial 477 | | .done l => match progress m with 478 | | .step _ => apply step; apply apξ₂ <;> trivial 479 | | .done _ => match l with 480 | | .lam => apply step; apply lamβ; trivial 481 | | 𝟘 => exact .done V𝟘 482 | | ι n => match progress n with 483 | | .step _ => apply step; apply succξ; trivial 484 | | .done _ => apply done; apply Value.succ; trivial 485 | | 𝟘? l m n => match progress l with 486 | | .step _ => apply step; apply caseξ; trivial 487 | | .done v => match v with 488 | | .zero => exact .step zeroβ 489 | | .succ _ => apply step; apply succβ; trivial 490 | | μ _ => exact .step muβ 491 | | .prim n => exact .done (.prim n) 492 | | m ⋄ n => match progress m with 493 | | .step _ => apply step; apply mulPξ₁; trivial 494 | | .done m => match progress n with 495 | | .step _ => apply step; apply mulPξ₂; trivial 496 | | .done n => match m, n with 497 | | .prim m, .prim n => exact .step mulPδ 498 | | .let m n => match progress m with 499 | | .step _ => apply step; apply letξ; trivial 500 | | .done m => apply step; apply letβ; trivial 501 | | .prod m n => match progress m with 502 | | .step _ => apply step; apply prodξ₁; trivial 503 | | .done m => match progress n with 504 | | .step _ => apply step; apply prodξ₂; trivial 505 | | .done n => exact .done (.prod m n) 506 | | .fst n => match progress n with 507 | | .step _ => apply step; apply fstξ; trivial 508 | | .done n => match n with 509 | | .prod v w => apply step; apply fstβ <;> trivial 510 | | .snd n => match progress n with 511 | | .step _ => apply step; apply sndξ; trivial 512 | | .done n => match n with 513 | | .prod v w => apply step; apply sndβ <;> trivial 514 | | .left n => match progress n with 515 | | .step _ => apply step; apply leftξ; trivial 516 | | .done n => exact .done (.left n) 517 | | .right n => match progress n with 518 | | .step _ => apply step; apply rightξ; trivial 519 | | .done n => exact .done (.right n) 520 | | .caseSum s l r => match progress s with 521 | | .step _ => apply step; apply caseSumξ; trivial 522 | | .done s => match s with 523 | | .left _ => apply step; apply leftβ; trivial 524 | | .right _ => apply step; apply rightβ; trivial 525 | | .caseVoid v => match progress v with 526 | | .step _ => apply step; apply caseVoidξ; trivial 527 | | .done _ => contradiction 528 | | ◯ => exact .done .unit 529 | | .nil => exact .done .nil 530 | | .cons m n => match progress m with 531 | | .step _ => apply step; apply consξ₁; trivial 532 | | .done _ => match progress n with 533 | | .step _ => apply step; apply consξ₂; trivial 534 | | .done _ => refine .done (.cons ?_ ?_) <;> trivial 535 | | .caseList l m n => match progress l with 536 | | .step _ => apply step; apply caseListξ; trivial 537 | | .done l => match l with 538 | | .nil => apply step; exact nilβ 539 | | .cons _ w => apply step; exact consβ 540 | 541 | open Progress (progress) 542 | 543 | inductive Result (n : Γ ⊢ a) where 544 | | done (val : Value n) 545 | | dnf 546 | deriving BEq, DecidableEq, Repr 547 | 548 | inductive Steps (l : Γ ⊢ a) where 549 | | steps : ∀{n : Γ ⊢ a}, (l —↠ n) → Result n → Steps l 550 | 551 | def eval (gas : ℕ) (l : ∅ ⊢ a) : Steps l := 552 | if gas = 0 then 553 | ⟨.refl, .dnf⟩ 554 | else 555 | match progress l with 556 | | .done v => .steps .refl <| .done v 557 | | .step r => 558 | let ⟨rs, res⟩ := eval (gas - 1) (by trivial) 559 | ⟨Trans.trans r rs, res⟩ 560 | 561 | section examples 562 | open Term 563 | 564 | -- def x : ℕ := x + 1 565 | abbrev succμ : ∅ ⊢ ℕt := μ ι #0 566 | 567 | abbrev evalRes (l : ∅ ⊢ a) (gas := 100) := (eval gas l).3 568 | 569 | #eval evalRes (gas := 3) succμ 570 | #eval evalRes <| add □ 2 □ 1 571 | #eval evalRes <| mul □ 2 □ 2 572 | -- Prim 573 | #eval evalRes <| .prim 2 ⋄ .prim 3 574 | -- Let 575 | #eval evalRes <| .let (.prim 6) (#0 ⋄ .prim 7) 576 | #eval evalRes <| .let (.prim 3) <| .let (.prim 4) (.prod (#1) (#0)) 577 | -- Prod, Unit 578 | #eval evalRes <| .fst <| .snd <| .prod ◯ (.prod (.prim 6) (ι ι 0)) 579 | -- Sum 580 | #eval evalRes <| (.left (.prim 3) : ∅ ⊢ ℕp + ℕt) 581 | #eval evalRes <| (.right 4 : ∅ ⊢ ℕp + ℕt) 582 | #eval evalRes <| .caseSum (.right 1 : ∅ ⊢ ℕp + ℕt) 𝟘 (.succ (#0)) 583 | -- List 584 | #eval evalRes <| .nil (a := ℕt) 585 | #eval evalRes <| .cons (ι 𝟘) <| .cons 𝟘 .nil 586 | #eval evalRes <| .caseList (.cons (ι 𝟘) <| .cons 𝟘 .nil) 𝟘 (#1 /- 0:cdr, 1:car -/) 587 | end examples 588 | -------------------------------------------------------------------------------- /Plfl/More/Bisimulation.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Bisimulation/ 2 | 3 | import Plfl.Init 4 | import Plfl.More 5 | 6 | open More 7 | open Subst Notation 8 | 9 | -- https://plfa.github.io/Bisimulation/#simulation 10 | inductive Sim : (Γ ⊢ a) → (Γ ⊢ a) → Prop where 11 | | var : Sim (` x) (` x) 12 | | lam : Sim n n' → Sim (ƛ n) (ƛ n') 13 | | ap : Sim l l' → Sim m m' → Sim (l □ m) (l' □ m') 14 | | let : Sim l l' → Sim m m' → Sim (.let l m) (.let l' m') 15 | 16 | namespace Sim 17 | scoped infix:40 " ~ " => Sim 18 | 19 | theorem refl_dec (t : Γ ⊢ a) : Decidable (t ~ t) := by 20 | cases t with try (apply isFalse; intro s; contradiction) 21 | | var i => exact isTrue .var 22 | | lam t => 23 | if h : t ~ t 24 | then apply isTrue; exact .lam h 25 | else apply isFalse; intro (.lam s); exact h s 26 | | ap l m => 27 | if h : (l ~ l) ∧ (m ~ m) 28 | then apply isTrue; exact .ap h.1 h.2 29 | else apply isFalse; intro (.ap s s'); exact h ⟨s, s'⟩ 30 | | «let» m n => 31 | if h : (m ~ m) ∧ (n ~ n) 32 | then apply isTrue; exact .let h.1 h.2 33 | else apply isFalse; intro (.let s s'); exact h ⟨s, s'⟩ 34 | 35 | -- https://plfa.github.io/Bisimulation/#exercise-_-practice 36 | lemma of_eq {s : (m : Γ ⊢ a) ~ m'} : (m' = n) → (m ~ n) := by 37 | intro h; rwa [h] at s 38 | 39 | lemma to_eq {s : (m : Γ ⊢ a) ~ m'} : (m ~ n) → (m' = n) := by 40 | intro s'; match s, s' with 41 | | s, .var => cases s with 42 | | var => rfl 43 | | s, .lam s' => cases s with 44 | | lam s'' => simp only [to_eq (s := s'') s'] 45 | | s, .ap sl sm => cases s with 46 | | ap sl' sm' => simp only [to_eq (s := sl') sl, to_eq (s := sm') sm] 47 | | s, .let sm sn => cases s with 48 | | «let» sm' sn' => simp only [to_eq (s := sm') sm, to_eq (s := sn') sn] 49 | 50 | -- https://plfa.github.io/Bisimulation/#simulation-commutes-with-values 51 | def commValue {m m' : Γ ⊢ a} : (m ~ m') → Value m → Value m' := by 52 | intro s v; cases v with try contradiction 53 | | lam => cases m' with try contradiction 54 | | lam => exact .lam 55 | 56 | -- https://plfa.github.io/Bisimulation/#exercise-val¹-practice 57 | def commValue' {m m' : Γ ⊢ a} : (m ~ m') → Value m' → Value m := by 58 | intro s v; cases v with try contradiction 59 | | lam => cases m with try contradiction 60 | | lam => exact .lam 61 | 62 | -- https://plfa.github.io/Bisimulation/#simulation-commutes-with-renaming 63 | def comm_rename (ρ : ∀ {a}, Γ ∋ a → Δ ∋ a) {m m' : Γ ⊢ a} 64 | : m ~ m' → rename ρ m ~ rename ρ m' 65 | := by intro 66 | | .var => exact .var 67 | | .lam s => apply lam; exact comm_rename (ext ρ) s 68 | | .ap sl sm => apply ap; repeat (apply comm_rename ρ; trivial) 69 | | .let sl sm => apply «let»; repeat 70 | first | apply comm_rename ρ | apply comm_rename (ext ρ) 71 | trivial 72 | 73 | -- https://plfa.github.io/Bisimulation/#simulation-commutes-with-substitution 74 | def comm_exts {σ σ' : ∀ {a}, Γ ∋ a → Δ ⊢ a} 75 | (gs : ∀ {a}, (x : Γ ∋ a) → σ x ~ σ' x) 76 | : (∀ {a b}, (x : Γ‚ b ∋ a) → exts σ x ~ exts σ' x) 77 | := by introv; match x with 78 | | .z => simp only [exts]; exact .var 79 | | .s x => simp only [exts]; apply comm_rename Lookup.s; apply gs 80 | 81 | def comm_subst {σ σ' : ∀ {a}, Γ ∋ a → Δ ⊢ a} 82 | (gs : ∀ {a}, (x : Γ ∋ a) → @σ a x ~ @σ' a x) 83 | {m m' : Γ ⊢ a} 84 | : m ~ m' → subst σ m ~ subst σ' m' 85 | := by intro 86 | | .var => apply gs 87 | | .lam s => apply lam; exact comm_subst (comm_exts gs) s 88 | | .ap sl sm => apply ap; repeat (apply comm_subst gs; trivial) 89 | | .let sm sn => apply «let»; repeat 90 | first | apply comm_subst gs | apply comm_subst (comm_exts gs) 91 | trivial 92 | 93 | def comm_subst₁ {m m' : Γ ⊢ b} {n n' : Γ‚ b ⊢ a} 94 | (sm : m ~ m') (sn : n ~ n') : n⟦m⟧ ~ n'⟦m'⟧ 95 | := by 96 | let σ {a} : Γ‚ b ∋ a → Γ ⊢ a := subst₁σ m 97 | let σ' {a} : Γ‚ b ∋ a → Γ ⊢ a := subst₁σ m' 98 | let gs {a} (x : Γ‚ b ∋ a) : (@σ a x) ~ (@σ' a x) := match x with 99 | | .z => sm 100 | | .s x => .var 101 | simp only [subst₁]; 102 | exact comm_subst (Γ := Γ‚ b) (Δ := Γ) (σ := σ) (σ' := σ') gs sn 103 | end Sim 104 | 105 | /- 106 | Now we can actually prove that `Sim` is a real bisimulation by giving the construction 107 | of the lower leg of the diagram from the upper leg and vice versa. 108 | -/ 109 | 110 | open Sim Reduce 111 | 112 | -- https://plfa.github.io/Bisimulation/#the-relation-is-a-simulation 113 | /-- 114 | `Leg m' n` stands for the leg 115 | ```txt 116 | n 117 | | 118 | ~ 119 | | 120 | m' - —→ - n' 121 | ``` 122 | -/ 123 | inductive Leg (m' n : Γ ⊢ a) : Prop where 124 | | intro (sim : n ~ n') (red : m' —→ n') 125 | 126 | def Leg.fromLegInv {m m' n : Γ ⊢ a} (s : m ~ m') (r : m —→ n) : Leg m' n := by 127 | match s with 128 | | .ap sl sm => match r with 129 | | .lamβ v => cases sl with | lam sl => 130 | constructor 131 | · apply comm_subst₁ <;> trivial 132 | · apply lamβ; exact commValue sm v 133 | | .apξ₁ r => 134 | have ⟨s', r'⟩ := fromLegInv sl r; constructor 135 | · apply ap <;> trivial 136 | · apply apξ₁ r' 137 | | .apξ₂ v r => 138 | have ⟨s', r'⟩ := fromLegInv sm r; constructor 139 | · apply ap <;> trivial 140 | · refine apξ₂ ?_ r'; exact commValue sl v 141 | | .let sm sn => match r with 142 | | .letξ r => 143 | have ⟨s', r'⟩ := fromLegInv sm r; constructor 144 | · apply «let» <;> trivial 145 | · apply letξ; exact r' 146 | | .letβ v => 147 | constructor 148 | · apply comm_subst₁ <;> trivial 149 | · apply letβ; exact commValue sm v 150 | 151 | -- https://plfa.github.io/Bisimulation/#exercise-sim¹-practice 152 | /-- 153 | `LegInv m n'` stands for the leg 154 | ```txt 155 | m - —→ - n 156 | | 157 | ~ 158 | | 159 | n' 160 | ``` 161 | -/ 162 | inductive LegInv (m n' : Γ ⊢ a) : Prop where 163 | | intro (sim : n ~ n') (red : m —→ n) 164 | 165 | def LegInv.fromLeg {m m' n' : Γ ⊢ a} (s : m ~ m') (r : m' —→ n') : LegInv m n' := by 166 | match s with 167 | | .ap sl sm => match r with 168 | | .lamβ v => cases sl with | lam sl => 169 | constructor 170 | · apply comm_subst₁ <;> trivial 171 | · apply lamβ; exact commValue' sm v 172 | | .apξ₁ r => 173 | have ⟨s', r'⟩ := fromLeg sl r; constructor 174 | · apply ap <;> trivial 175 | · apply apξ₁ r' 176 | | .apξ₂ v r => 177 | have ⟨s', r'⟩ := fromLeg sm r; constructor 178 | · apply ap <;> trivial 179 | · refine apξ₂ ?_ r'; exact commValue' sl v 180 | | .let sm sn => match r with 181 | | .letξ r => 182 | have ⟨s', r'⟩ := fromLeg sm r; constructor 183 | · apply «let» <;> trivial 184 | · apply letξ; exact r' 185 | | .letβ v => 186 | constructor 187 | · apply comm_subst₁ <;> trivial 188 | · apply letβ; exact commValue' sm v 189 | -------------------------------------------------------------------------------- /Plfl/More/DoubleSubst.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/More/#exercise-double-subst-stretch 2 | 3 | -- Adapted from . 4 | 5 | import Plfl.Init 6 | import Plfl.More 7 | 8 | open More 9 | open Term Subst Notation 10 | 11 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L50 12 | /-- 13 | Applies `ext` repeatedly. 14 | -/ 15 | def ext' (ρ : ∀ {a}, Γ ∋ a → Δ ∋ a) : Γ‚‚ Φ ∋ a → Δ‚‚ Φ ∋ a := by 16 | match Φ with 17 | | [] => exact ρ (a := a) 18 | | b :: Φ => exact ext (a := a) (b := b) (ext' (Φ := Φ) ρ) 19 | 20 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L56 21 | /-- 22 | Applies `exts` repeatedly. 23 | -/ 24 | def exts' (σ : ∀ {a}, Γ ∋ a → Δ ⊢ a) : Γ‚‚ Φ ∋ a → Δ‚‚ Φ ⊢ a := by 25 | match Φ with 26 | | [] => exact σ (a := a) 27 | | b :: Φ => exact exts (a := a) (b := b) (exts' (Φ := Φ) σ) 28 | 29 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L64 30 | lemma exts_comp {ρ : ∀ {a}, Γ ∋ a → Δ ∋ a} {σ : ∀ {a}, Δ ∋ a → Φ ⊢ a} (i : Γ‚ b ∋ a) 31 | : (exts σ) (ext ρ i) = exts (σ ∘ ρ) i 32 | := by cases i <;> rfl 33 | 34 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L87 35 | lemma exts_var (i : Γ‚ b ∋ a) : exts var i = ` i := by cases i <;> rfl 36 | 37 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L73 38 | lemma subst_comp {ρ : ∀ {a}, Γ ∋ a → Δ ∋ a} {σ : ∀ {a}, Δ ∋ a → Φ ⊢ a} (t : Γ ⊢ a) 39 | : subst σ (rename ρ t) = subst (σ ∘ ρ) t 40 | := by 41 | match t with 42 | | ` i => trivial 43 | | ƛ t => 44 | apply congr_arg lam; rw [subst_comp t] 45 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 46 | | l □ m => apply congr_arg₂ ap <;> apply subst_comp 47 | | 𝟘 => trivial 48 | | ι t => apply congr_arg succ; apply subst_comp 49 | | 𝟘? l m n => 50 | apply congr_arg₃ case <;> try apply subst_comp 51 | · rw [subst_comp n] 52 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 53 | | μ t => 54 | apply congr_arg mu; rw [subst_comp t] 55 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 56 | | .prim t => trivial 57 | | .mulP m n => apply congr_arg₂ mulP <;> apply subst_comp 58 | | .let m n => 59 | apply congr_arg₂ «let» <;> try apply subst_comp 60 | · rw [subst_comp n] 61 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 62 | | .prod m n => apply congr_arg₂ prod <;> apply subst_comp 63 | | .fst t => apply congr_arg fst; apply subst_comp 64 | | .snd t => apply congr_arg snd; apply subst_comp 65 | | .left t => apply congr_arg left; apply subst_comp 66 | | .right t => apply congr_arg right; apply subst_comp 67 | | .caseSum s l r => 68 | apply congr_arg₃ caseSum <;> try apply subst_comp 69 | · rw [subst_comp l] 70 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 71 | · rw [subst_comp r] 72 | conv_lhs => arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 73 | | .caseVoid v => apply congr_arg caseVoid; apply subst_comp 74 | | ◯ => trivial 75 | | .nil => trivial 76 | | .cons m n => apply congr_arg₂ cons <;> apply subst_comp 77 | | .caseList l m n => 78 | apply congr_arg₃ caseList <;> try apply subst_comp 79 | · rw [subst_comp n] 80 | conv_lhs => 81 | arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 82 | arg 1; ext a t; simp only [Function.comp_apply, exts_comp t] 83 | 84 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L93 85 | lemma subst_var (t : Γ ⊢ a) : subst var t = t := by 86 | match t with 87 | | ` i => apply congr_arg var; trivial 88 | | ƛ t => 89 | apply congr_arg lam 90 | conv_lhs => arg 1; ext a i; rw [exts_var i] 91 | exact subst_var t 92 | | l □ m => apply congr_arg₂ ap <;> apply subst_var 93 | | 𝟘 => trivial 94 | | ι t => apply congr_arg succ; apply subst_var 95 | | 𝟘? l m n => 96 | apply congr_arg₃ case <;> try apply subst_var 97 | · conv_lhs => arg 1; ext a i; rw [exts_var i] 98 | exact subst_var n 99 | | μ t => 100 | apply congr_arg mu 101 | conv_lhs => arg 1; ext a i; rw [exts_var i] 102 | exact subst_var t 103 | | .prim t => trivial 104 | | .mulP m n => apply congr_arg₂ mulP <;> apply subst_var 105 | | .let m n => 106 | apply congr_arg₂ «let» <;> try apply subst_var 107 | · conv_lhs => arg 1; ext a i; rw [exts_var i] 108 | exact subst_var n 109 | | .prod m n => apply congr_arg₂ prod <;> apply subst_var 110 | | .fst t => apply congr_arg fst; apply subst_var 111 | | .snd t => apply congr_arg snd; apply subst_var 112 | | .left t => apply congr_arg left; apply subst_var 113 | | .right t => apply congr_arg right; apply subst_var 114 | | .caseSum s l r => 115 | apply congr_arg₃ caseSum <;> try apply subst_var 116 | · conv_lhs => arg 1; ext a i; rw [exts_var i] 117 | exact subst_var l 118 | · conv_lhs => arg 1; ext a i; rw [exts_var i] 119 | exact subst_var r 120 | | .caseVoid v => apply congr_arg caseVoid; apply subst_var 121 | | ◯ => trivial 122 | | .nil => trivial 123 | | .cons m n => apply congr_arg₂ cons <;> apply subst_var 124 | | .caseList l m n => 125 | apply congr_arg₃ caseList <;> try apply subst_var 126 | · conv_lhs => arg 1; ext a i; arg 1; ext a i; rw [exts_var i] 127 | conv_lhs => arg 1; ext a i; rw [exts_var i] 128 | exact subst_var n 129 | 130 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L104 131 | theorem subst₁_shift : (shift (t : Γ ⊢ a))⟦(t' : Γ ⊢ b)⟧ = t := by 132 | simp_all only [subst₁, subst₁σ, subst_comp] 133 | conv_lhs => arg 1; ext a t'; simp 134 | rw [subst_var] 135 | 136 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L112 137 | lemma insert_twice_idx {Γ Δ Φ : Context} {a b c : Ty} (i : Γ‚‚ Δ‚‚ Φ ∋ a) 138 | : ext' (Φ := Φ) 139 | (.s (t' := c)) 140 | (ext' (Φ := Φ) (ext' (Φ := Δ) (.s (t' := b))) i) 141 | = ext' (ext (ext' .s)) (ext' .s i) 142 | := by 143 | match Φ, i with 144 | | [], _ => rfl 145 | | _ :: _, .z => rfl 146 | | d :: Φ, .s i => apply congr_arg Lookup.s; exact insert_twice_idx i 147 | 148 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L120 149 | lemma insert_twice {Γ Δ Φ : Context} {a b c : Ty} (t : Γ‚‚ Δ‚‚ Φ ⊢ a) 150 | : rename 151 | (ext' (Φ := Φ) (.s (t' := c))) 152 | (rename (ext' (Φ := Φ) (ext' (Φ := Δ) (.s (t' := b)))) t) 153 | = (rename (ext' (ext (ext' .s))) (rename (ext' .s) t) : (Γ‚ b‚‚ Δ)‚ c‚‚ Φ ⊢ a) 154 | := by 155 | match t with 156 | | ` i => apply congr_arg var; exact insert_twice_idx i 157 | | ƛ t => apply congr_arg lam; rename_i a' b'; exact insert_twice (Φ := Φ‚ a') t 158 | | l □ m => apply congr_arg₂ ap <;> apply insert_twice 159 | | 𝟘 => trivial 160 | | ι t => apply congr_arg succ; apply insert_twice 161 | | 𝟘? l m n => 162 | apply congr_arg₃ case <;> try apply insert_twice 163 | · exact insert_twice (Φ := Φ‚ ℕt) n 164 | | μ t => apply congr_arg mu; exact insert_twice (Φ := Φ‚ a) t 165 | | .prim t => trivial 166 | | .mulP m n => apply congr_arg₂ mulP <;> apply insert_twice 167 | | .let m n => 168 | apply congr_arg₂ «let» <;> try apply insert_twice 169 | · rename_i a'; exact insert_twice (Φ := Φ‚ a') n 170 | | .prod m n => apply congr_arg₂ prod <;> apply insert_twice 171 | | .fst t => apply congr_arg fst; apply insert_twice 172 | | .snd t => apply congr_arg snd; apply insert_twice 173 | | .left t => apply congr_arg left; apply insert_twice 174 | | .right t => apply congr_arg right; apply insert_twice 175 | | .caseSum s l r => 176 | apply congr_arg₃ caseSum <;> try apply insert_twice 177 | · rename_i a' b'; exact insert_twice (Φ := Φ‚ a') l 178 | · rename_i a' b'; exact insert_twice (Φ := Φ‚ b') r 179 | | .caseVoid v => apply congr_arg caseVoid; apply insert_twice 180 | | ◯ => trivial 181 | | .nil => trivial 182 | | .cons m n => apply congr_arg₂ cons <;> apply insert_twice 183 | | .caseList l m n => 184 | apply congr_arg₃ caseList <;> try apply insert_twice 185 | · rename_i a'; exact insert_twice (Φ := Φ‚ a'‚ .list a') n 186 | 187 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L132 188 | lemma insert_subst_idx 189 | {σ : ∀ {a}, Γ ∋ a → Δ ⊢ a} 190 | (i : Γ‚‚ Φ ∋ a) 191 | : exts' (Φ := Φ) (exts (b := b) σ) (ext' .s i) = rename (ext' .s) (exts' σ i) 192 | := by 193 | match Φ, i with 194 | | [], i => rfl 195 | | _ :: _, .z => rfl 196 | | c :: Φ, .s i => 197 | conv_lhs => arg 2; unfold ext' ext; simp 198 | conv_lhs => change shift (exts' (exts σ) (ext' .s i)); rw [insert_subst_idx i] 199 | conv_rhs => arg 2; unfold ext' ext; simp 200 | exact insert_twice (Φ := []) (@exts' Γ Δ Φ a σ i) 201 | 202 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L141 203 | lemma insert_subst 204 | {σ : ∀ {a}, Γ ∋ a → Δ ⊢ a} 205 | (t : Γ‚‚ Φ ⊢ a) 206 | : subst (exts' (Φ := Φ) (exts (b := b) σ)) (rename (ext' .s) t) 207 | = rename (ext' .s) (subst (exts' σ) t) 208 | := by 209 | match t with 210 | | ` i => exact insert_subst_idx i 211 | | ƛ t => rename_i a b; apply congr_arg lam; exact insert_subst (Φ := Φ‚ a) t 212 | | l □ m => apply congr_arg₂ ap <;> apply insert_subst 213 | | 𝟘 => trivial 214 | | ι t => apply congr_arg succ; apply insert_subst 215 | | 𝟘? l m n => 216 | apply congr_arg₃ case <;> try apply insert_subst 217 | · exact insert_subst (Φ := Φ‚ ℕt) n 218 | | μ t => apply congr_arg mu; exact insert_subst (Φ := Φ‚ a) t 219 | | .prim t => trivial 220 | | .mulP m n => apply congr_arg₂ mulP <;> apply insert_subst 221 | | .let m n => 222 | apply congr_arg₂ «let» <;> try apply insert_subst 223 | · rename_i a'; exact insert_subst (Φ := Φ‚ a') n 224 | | .prod m n => apply congr_arg₂ prod <;> apply insert_subst 225 | | .fst t => apply congr_arg fst; apply insert_subst 226 | | .snd t => apply congr_arg snd; apply insert_subst 227 | | .left t => apply congr_arg left; apply insert_subst 228 | | .right t => apply congr_arg right; apply insert_subst 229 | | .caseSum s l r => 230 | apply congr_arg₃ caseSum <;> try apply insert_subst 231 | · rename_i a' b'; exact insert_subst (Φ := Φ‚ a') l 232 | · rename_i a' b'; exact insert_subst (Φ := Φ‚ b') r 233 | | .caseVoid v => apply congr_arg caseVoid; apply insert_subst 234 | | ◯ => trivial 235 | | .nil => trivial 236 | | .cons m n => apply congr_arg₂ cons <;> apply insert_subst 237 | | .caseList l m n => 238 | apply congr_arg₃ caseList <;> try apply insert_subst 239 | · rename_i a'; exact insert_subst (Φ := Φ‚ a'‚ .list a') n 240 | 241 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L154 242 | lemma shift_subst 243 | {σ : ∀ {a}, Γ ∋ a → Δ ⊢ a} 244 | (t : Γ ⊢ a) 245 | : subst (exts (b := b) σ) (shift t) = shift (subst σ t) 246 | := insert_subst (Φ := []) t 247 | 248 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L161 249 | lemma exts_subst_comp 250 | {σ : ∀ {a}, Γ ∋ a → Δ ⊢ a} {σ' : ∀ {a}, Δ ∋ a → Φ ⊢ a} 251 | (i : Γ‚ b ∋ a) 252 | : subst (exts σ') (exts σ i) = exts (subst σ' ∘ σ) i 253 | := by 254 | match i with 255 | | .z => trivial 256 | | .s i => exact shift_subst (σ i) 257 | 258 | -- https://github.com/kaa1el/plfa_solution/blob/c5869a34bc4cac56cf970e0fe38874b62bd2dafc/src/plfa/demo/DoubleSubstitutionDeBruijn.agda#L170 259 | theorem subst_subst_comp 260 | {σ : ∀ {a}, Γ ∋ a → Δ ⊢ a} {σ' : ∀ {a}, Δ ∋ a → Φ ⊢ a} 261 | (t : Γ ⊢ a) 262 | : subst σ' (subst σ t) = subst (subst σ' ∘ σ) t 263 | := by 264 | match t with 265 | | ` _ => trivial 266 | | ƛ t => 267 | apply congr_arg lam 268 | rw [subst_subst_comp (σ := exts σ) (σ' := exts σ') t] 269 | congr; ext; apply exts_subst_comp 270 | | l □ m => apply congr_arg₂ ap <;> apply subst_subst_comp 271 | | 𝟘 => trivial 272 | | ι t => apply congr_arg succ; apply subst_subst_comp 273 | | 𝟘? l m n => 274 | apply congr_arg₃ case <;> try apply subst_subst_comp 275 | · conv_lhs => 276 | rw [subst_subst_comp (σ := exts σ) (σ' := exts σ') n] 277 | arg 1; ext tt t; rw [Function.comp_apply, exts_subst_comp t] 278 | | μ t => 279 | apply congr_arg mu 280 | have := subst_subst_comp (σ := exts σ) (σ' := exts σ') t 281 | rw [this]; congr; ext; apply exts_subst_comp 282 | | .prim t => trivial 283 | | .mulP m n => apply congr_arg₂ mulP <;> apply subst_subst_comp 284 | | .let m n => 285 | apply congr_arg₂ «let» 286 | · apply subst_subst_comp 287 | · conv_lhs => 288 | rw [subst_subst_comp (σ := exts σ) (σ' := exts σ') n] 289 | arg 1; ext tt t; rw [Function.comp_apply, exts_subst_comp t] 290 | | .prod m n => apply congr_arg₂ prod <;> apply subst_subst_comp 291 | | .fst t => apply congr_arg fst; apply subst_subst_comp 292 | | .snd t => apply congr_arg snd; apply subst_subst_comp 293 | | .left t => apply congr_arg left; apply subst_subst_comp 294 | | .right t => apply congr_arg right; apply subst_subst_comp 295 | | .caseSum s l r => 296 | apply congr_arg₃ caseSum <;> try apply subst_subst_comp 297 | · conv_lhs => 298 | rw [subst_subst_comp (σ := exts σ) (σ' := exts σ') l] 299 | arg 1; ext tt t; rw [Function.comp_apply, exts_subst_comp t] 300 | · conv_lhs => 301 | rw [subst_subst_comp (σ := exts σ) (σ' := exts σ') r] 302 | arg 1; ext tt t; rw [Function.comp_apply, exts_subst_comp t] 303 | | .caseVoid v => apply congr_arg caseVoid; apply subst_subst_comp 304 | | ◯ => trivial 305 | | .nil => trivial 306 | | .cons m n => apply congr_arg₂ cons <;> apply subst_subst_comp 307 | | .caseList l m n => 308 | apply congr_arg₃ caseList <;> try apply subst_subst_comp 309 | · rw [subst_subst_comp (σ := exts (exts σ)) (σ' := exts (exts σ')) n] 310 | congr; ext _ t; rw [Function.comp_apply, exts_subst_comp t] 311 | congr; ext _ t; rw [Function.comp_apply, exts_subst_comp t] 312 | 313 | theorem double_subst 314 | : subst₂ (v : Γ ⊢ a) (w : Γ ⊢ b) (n : Γ‚ a‚ b ⊢ c) 315 | = n⟦rename .s w⟧⟦v⟧ 316 | := by 317 | simp only [subst₂, subst₁, subst_subst_comp]; congr; ext 318 | simp only [Function.comp_apply, subst₁σ]; split 319 | · simp only [subst₁_shift] 320 | · simp only [shift_subst]; rfl 321 | · simp only [shift_subst]; rfl 322 | -------------------------------------------------------------------------------- /Plfl/More/Inference.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Inference/ 2 | 3 | import Plfl.Init 4 | import Plfl.More 5 | 6 | namespace Inference 7 | 8 | -- https://plfa.github.io/Inference/#syntax 9 | open String 10 | 11 | def Sym : Type := String deriving BEq, DecidableEq, Repr 12 | 13 | inductive Ty where 14 | /-- Native natural type made of 𝟘 and ι. -/ 15 | | nat : Ty 16 | /-- Arrow type. -/ 17 | | fn : Ty → Ty → Ty 18 | /-- Product type. -/ 19 | | prod: Ty → Ty → Ty 20 | deriving BEq, DecidableEq, Repr 21 | 22 | namespace Notation 23 | open Ty 24 | 25 | scoped notation "ℕt" => nat 26 | scoped infixr:70 " =⇒ " => fn 27 | 28 | instance : Mul Ty where mul := .prod 29 | end Notation 30 | 31 | open Notation 32 | 33 | abbrev Context : Type := List (Sym × Ty) 34 | 35 | namespace Context 36 | abbrev extend (c : Context) (s : Sym) (t : Ty) : Context := ⟨s, t⟩ :: c 37 | end Context 38 | 39 | namespace Notation 40 | open Context 41 | 42 | -- The goal is to make `_‚_⦂_` work like an `infixl`. 43 | -- https://matklad.github.io/2020/04/13/simple-but-powerful-pratt-parsing.html#From-Precedence-to-Binding-Power 44 | -- `‚` is not a comma! See: 45 | notation:50 c "‚ " s:51 " ⦂ " t:51 => extend c s t 46 | end Notation 47 | 48 | open Notation 49 | 50 | /- 51 | An attribute is said to be Synthesized, 52 | if its parse tree node value is determined by the attribute value at its *child* nodes. 53 | 54 | An attribute is said to be Inherited, 55 | if its parse tree node value is determined by the attribute value at its *parent and/or siblings*. 56 | 57 | 58 | -/ 59 | 60 | mutual 61 | /-- 62 | A term with synthesized types. 63 | The main term in a constructor is typed via inheritance. 64 | -/ 65 | inductive TermS where 66 | | var : Sym → TermS 67 | | ap : TermS → TermI → TermS 68 | | prod : TermS → TermS → TermS 69 | | syn : TermI → Ty → TermS 70 | deriving BEq, Repr 71 | -- * `DecidableEq` derivations are not yet supported in `mutual` blocks. 72 | -- See: 73 | 74 | /-- 75 | A term with inherited types. 76 | The main term in an eliminator is typed via synthesis. 77 | -/ 78 | inductive TermI where 79 | | lam : Sym → TermI → TermI 80 | | zero : TermI 81 | | succ : TermI → TermI 82 | | case : TermS → TermI → Sym → TermI → TermI 83 | | mu : Sym → TermI → TermI 84 | | fst : TermS → TermI 85 | | snd : TermS → TermI 86 | | inh : TermS → TermI 87 | deriving BEq, Repr 88 | end 89 | 90 | namespace Notation 91 | open TermS TermI 92 | 93 | scoped notation:50 "ƛ " v " : " d => lam v d 94 | scoped notation:50 " μ " v " : " d => mu v d 95 | scoped notation:max "𝟘? " e " [zero: " o " |succ " n " : " i " ] " => case e o n i 96 | scoped infixr:min " $ " => ap 97 | -- scoped infix:60 " ↓ " => syn 98 | -- scoped postfix:60 "↑ " => inh 99 | scoped infixl:70 " □ " => ap 100 | scoped prefix:80 "ι " => succ 101 | scoped prefix:90 "` " => var 102 | scoped notation "𝟘" => zero 103 | end Notation 104 | 105 | -- https://plfa.github.io/Inference/#example-terms 106 | abbrev two : TermI := ι ι 𝟘 107 | 108 | -- * The coercion can only happen in this direction, 109 | -- since the other direction requires an extra type annotation. 110 | instance : Coe TermS TermI where coe := TermI.inh 111 | 112 | @[simp] abbrev TermI.the := TermS.syn 113 | 114 | abbrev add : TermS := 115 | (μ "+" : ƛ "m" : ƛ "n" : 116 | 𝟘? `"m" 117 | [zero: `"n" 118 | |succ "m" : ι (`"+" □ `"m" □ `"n")] 119 | ).the (ℕt =⇒ ℕt =⇒ ℕt) 120 | 121 | abbrev mul : TermS := 122 | (μ "*" : ƛ "m" : ƛ "n" : 123 | 𝟘? `"m" 124 | [zero: 𝟘 125 | |succ "m": add □ `"n" $ `"*" □ `"m" □ `"n"] 126 | ).the (ℕt =⇒ ℕt =⇒ ℕt) 127 | 128 | -- Note that the typing is only required for `add` due to the rule for `ap`. 129 | abbrev four : TermS := add □ two □ two 130 | 131 | /-- 132 | The Church numeral Ty. 133 | -/ 134 | @[simp] abbrev Ch (t : Ty := ℕt) : Ty := (t =⇒ t) =⇒ t =⇒ t 135 | 136 | -- Church encoding... 137 | abbrev succC : TermI := ƛ "n" : ι `"n" 138 | abbrev oneC : TermI := ƛ "s" : ƛ "z" : `"s" $ `"z" 139 | abbrev twoC : TermI := ƛ "s" : ƛ "z" : `"s" $ `"s" $ `"z" 140 | abbrev addC : TermS := 141 | (ƛ "m" : ƛ "n" : ƛ "s" : ƛ "z" : `"m" □ `"s" $ `"n" □ `"s" □ `"z" 142 | ).the (Ch =⇒ Ch =⇒ Ch) 143 | -- Note that the typing is only required for `addC` due to the rule for `ap`. 144 | abbrev four' : TermS := addC □ twoC □ twoC □ succC □ 𝟘 145 | 146 | -- https://plfa.github.io/Inference/#bidirectional-type-checking 147 | /-- 148 | A lookup judgement. 149 | `Lookup c s ts` means that `s` is of type `ts` by _looking up_ the context `c`. 150 | -/ 151 | inductive Lookup : Context → Sym → Ty → Type where 152 | | z : Lookup (Γ‚ x ⦂ a) x a 153 | | s : x ≠ y → Lookup Γ x a → Lookup (Γ‚ y ⦂ b) x a 154 | deriving DecidableEq 155 | 156 | namespace Lookup 157 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/tactics.md#tactics-by-macro-expansion 158 | /-- 159 | `elem` validates the type of a variable by looking it up in the current context. 160 | This tactic fails when the lookup fails. 161 | -/ 162 | scoped syntax "elem" : tactic 163 | macro_rules 164 | | `(tactic| elem) => 165 | `(tactic| repeat (first | apply Lookup.s (by trivial) | exact Lookup.z)) 166 | 167 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/macros.md#simplifying-macro-declaration 168 | scoped syntax "get_elem" (ppSpace term) : tactic 169 | macro_rules | `(tactic| get_elem $n) => match n.1.toNat with 170 | | 0 => `(tactic| exact Lookup.z) 171 | | n+1 => `(tactic| apply Lookup.s (by trivial); get_elem $(Lean.quote n)) 172 | end Lookup 173 | 174 | namespace Notation 175 | open Context Lookup 176 | 177 | scoped notation:40 Γ " ∋ " m " ⦂ " a:51 => Lookup Γ m a 178 | scoped macro "♯ " n:term:90 : term => `(by get_elem $n) 179 | end Notation 180 | 181 | instance : Repr (Γ ∋ m ⦂ a) where reprPrec i n := "♯" ++ reprPrec n (sizeOf i) 182 | 183 | #eval @Lookup.z (∅‚ "x" ⦂ ℕt) "x" ℕt 184 | 185 | mutual 186 | /-- 187 | Typing of `TermS` terms. 188 | -/ 189 | inductive TyS : Context → TermS → Ty → Type where 190 | | var : Γ ∋ x ⦂ a → TyS Γ (` x) a 191 | | ap: TyS Γ l (a =⇒ b) → TyI Γ m a → TyS Γ (l □ m) b 192 | | prod: TyS Γ m a → TyS Γ n b → TyS Γ (.prod m n) (a * b) 193 | | syn : TyI Γ m a → TyS Γ (m.the a) a 194 | deriving Repr 195 | 196 | /-- 197 | Typing of `TermI` terms. 198 | -/ 199 | inductive TyI : Context → TermI → Ty → Type where 200 | | lam : TyI (Γ‚ x ⦂ a) n b → TyI Γ (ƛ x : n) (a =⇒ b) 201 | | zero : TyI Γ 𝟘 ℕt 202 | | succ : TyI Γ m ℕt → TyI Γ (ι m) ℕt 203 | | case 204 | : TyS Γ l ℕt → TyI Γ m a → TyI (Γ‚ x ⦂ ℕt) n a 205 | → TyI Γ (𝟘? l [zero: m |succ x : n]) a 206 | | mu : TyI (Γ‚ x ⦂ a) n a → TyI Γ (μ x : n) a 207 | | fst: TyS Γ p (a * b) → TyI Γ (.fst p) a 208 | | snd: TyS Γ p (a * b) → TyI Γ (.snd p) b 209 | | inh : TyS Γ m a → TyI Γ m a 210 | deriving Repr 211 | end 212 | 213 | instance : Coe (TyI Γ m a) (TyS Γ (m.the a) a) where coe := TyS.syn 214 | instance : Coe (TyS Γ m a) (TyI Γ m a) where coe := TyI.inh 215 | 216 | namespace Notation 217 | scoped notation:40 Γ " ⊢ " m " ⇡ " a:51 => TyS Γ m a 218 | scoped notation:40 Γ " ⊢ " m " ↟ " a:51 => TyS Γ (TermS.syn m a) a 219 | scoped notation:40 Γ " ⊢ " m " ⇣ " a:51 => TyI Γ m a 220 | end Notation 221 | 222 | abbrev twoTy : Γ ⊢ two ↟ ℕt := open TyS TyI in by 223 | apply_rules [syn, succ, zero] 224 | 225 | abbrev addTy : Γ ⊢ add ⇡ (ℕt =⇒ ℕt =⇒ ℕt) := open TyS TyI Lookup in by 226 | repeat apply_rules 227 | [var, ap, prod, syn, 228 | lam, zero, succ, case, mu, fst, snd, inh] 229 | <;> elem 230 | 231 | -- https://plfa.github.io/Inference/#bidirectional-mul 232 | abbrev mulTy : Γ ⊢ mul ⇡ (ℕt =⇒ ℕt =⇒ ℕt) := open TyS TyI Lookup in by 233 | repeat apply_rules 234 | [var, ap, prod, syn, 235 | lam, zero, succ, case, mu, fst, snd, inh, 236 | addTy] 237 | <;> elem 238 | 239 | abbrev twoCTy : Γ ⊢ twoC ⇣ Ch := open TyS TyI Lookup in by 240 | repeat apply_rules 241 | [var, ap, prod, syn, 242 | lam, zero, succ, case, mu, fst, snd, inh] 243 | <;> elem 244 | 245 | abbrev addCTy : Γ ⊢ addC ⇡ (Ch =⇒ Ch =⇒ Ch) := open TyS TyI Lookup in by 246 | repeat apply_rules 247 | [var, ap, prod, syn, 248 | lam, zero, succ, case, mu, fst, snd, inh] 249 | <;> elem 250 | 251 | -- https://plfa.github.io/Inference/#bidirectional-products 252 | example : Γ ⊢ .prod (two.the ℕt) add ⇡ ℕt * (ℕt =⇒ ℕt =⇒ ℕt) 253 | := open TyS TyI Lookup in by 254 | repeat apply_rules 255 | [var, ap, prod, syn, 256 | lam, zero, succ, case, mu, fst, snd, inh, 257 | twoTy, addTy] 258 | <;> elem 259 | 260 | example : Γ ⊢ .fst (.prod (two.the ℕt) add) ↟ ℕt 261 | := open TyS TyI Lookup in by 262 | repeat apply_rules 263 | [var, ap, prod, syn, 264 | lam, zero, succ, case, mu, fst, snd, inh, 265 | twoTy] 266 | <;> elem 267 | 268 | example : Γ ⊢ .snd (.prod (two.the ℕt) add) ↟ (ℕt =⇒ ℕt =⇒ ℕt) 269 | := open TyS TyI Lookup in by 270 | repeat apply_rules 271 | [var, ap, prod, syn, 272 | lam, zero, succ, case, mu, fst, snd, inh, 273 | addTy] 274 | <;> elem 275 | 276 | -- https://plfa.github.io/Inference/#prerequisites 277 | 278 | /- 279 | Nothing to do. Relevant definitions have been derived. 280 | -/ 281 | 282 | -- https://plfa.github.io/Inference/#unique-types 283 | theorem Lookup.unique (i : Γ ∋ x ⦂ a) (j : Γ ∋ x ⦂ b) : a = b := by 284 | cases i with try trivial 285 | | z => cases j <;> trivial 286 | | s => cases j with try trivial 287 | | s => apply unique <;> trivial 288 | 289 | theorem TyS.unique (t : Γ ⊢ x ⇡ a) (u : Γ ⊢ x ⇡ b) : a = b := by 290 | match t with 291 | | .var i => cases u with | var j => apply Lookup.unique <;> trivial 292 | | .ap l _ => cases u with | ap l' _ => injection unique l l' 293 | | .prod m n => cases u with | prod m' n' => congr; exact unique m m'; exact unique n n' 294 | | .syn _ => cases u with | syn _ => trivial 295 | 296 | -- https://plfa.github.io/Inference/#lookup-type-of-a-variable-in-the-context 297 | lemma Lookup.empty_ext_empty 298 | : x ≠ y 299 | → IsEmpty (Σ a, Γ ∋ x ⦂ a) 300 | → IsEmpty (Σ a, Γ‚ y ⦂ b ∋ x ⦂ a) 301 | := by 302 | intro n ai; is_empty; intro ⟨a, i⟩; apply ai.false; exists a 303 | cases i <;> trivial 304 | 305 | def Lookup.lookup (Γ : Context) (x : Sym) : Decidable' (Σ a, Γ ∋ x ⦂ a) := by 306 | match Γ, x with 307 | | [], _ => left; is_empty; nofun 308 | | ⟨y, b⟩ :: Γ, x => 309 | if h : x = y then 310 | right; subst h; exact ⟨b, .z⟩ 311 | else match lookup Γ x with 312 | | .inr ⟨a, i⟩ => right; refine ⟨a, .s ?_ i⟩; trivial 313 | | .inl n => left; refine empty_ext_empty ?_ n; trivial 314 | 315 | -- https://plfa.github.io/Inference/#promoting-negations 316 | lemma TyS.empty_arg 317 | : Γ ⊢ l ⇡ a =⇒ b 318 | → IsEmpty (Γ ⊢ m ⇣ a) 319 | → IsEmpty (Σ b', Γ ⊢ l □ m ⇡ b') 320 | := by 321 | intro tl n; is_empty; intro ⟨b', .ap tl' tm'⟩ 322 | injection tl.unique tl'; rename_i h _; apply n.false; rwa [←h] at tm' 323 | 324 | lemma TyS.empty_switch : Γ ⊢ m ⇡ a → a ≠ b → IsEmpty (Γ ⊢ m ⇡ b) := by 325 | intro ta n; is_empty; intro tb; have := ta.unique tb; contradiction 326 | 327 | mutual 328 | def TermS.infer (m : TermS) (Γ : Context) : Decidable' (Σ a, Γ ⊢ m ⇡ a) := by 329 | match m with 330 | | ` x => match Lookup.lookup Γ x with 331 | | .inr ⟨a, i⟩ => right; exact ⟨a, .var i⟩ 332 | | .inl n => left; is_empty; intro ⟨a, .var _⟩; apply n.false; exists a 333 | | l □ m => match l.infer Γ with 334 | | .inr ⟨a =⇒ b, tab⟩ => match m.infer Γ a with 335 | | .inr ta => right; exact ⟨b, .ap tab ta⟩ 336 | | .inl n => left; exact tab.empty_arg n 337 | | .inr ⟨ℕt, t⟩ => left; is_empty; intro ⟨_, .ap tl _⟩; injection t.unique tl 338 | | .inr ⟨.prod _ _, t⟩ => left; is_empty; intro ⟨_, .ap tl _⟩; injection t.unique tl 339 | | .inl n => left; is_empty; intro ⟨a, .ap tl _⟩; rename_i b _; exact n.false ⟨b =⇒ a, tl⟩ 340 | | .prod m n => match m.infer Γ, n.infer Γ with 341 | | .inr ⟨a, tm⟩, .inr ⟨b, tn⟩ => right; exact ⟨a * b, tm.prod tn⟩ 342 | | .inr _, .inl nn => left; is_empty; intro ⟨_, tmn⟩; cases tmn; apply nn.false; constructor <;> trivial 343 | | .inl nm, _ => left; is_empty; intro ⟨_, .prod tm _⟩; apply nm.false; constructor <;> trivial 344 | | .syn m a => match m.infer Γ a with 345 | | .inr t => right; exact ⟨a, t⟩ 346 | | .inl n => left; is_empty; intro ⟨a', t'⟩; cases t'; apply n.false; trivial 347 | 348 | def TermI.infer (m : TermI) (Γ : Context) (a : Ty) : Decidable' (Γ ⊢ m ⇣ a) := by 349 | match m with 350 | | ƛ x : n => match a with 351 | | a =⇒ b => match n.infer (Γ‚ x ⦂ a) b with 352 | | .inr t => right; exact .lam t 353 | | .inl n => left; is_empty; intro (.lam t); exact n.false t 354 | | ℕt => left; is_empty; nofun 355 | | .prod _ _ => left; is_empty; nofun 356 | | 𝟘 => match a with 357 | | ℕt => right; exact .zero 358 | | _ =⇒ _ => left; is_empty; nofun 359 | | .prod _ _ => left; is_empty; nofun 360 | | ι n => match a with 361 | | ℕt => match n.infer Γ ℕt with 362 | | .inr t => right; exact .succ t 363 | | .inl n => left; is_empty; intro (.succ t); exact n.false t 364 | | _ =⇒ _ => left; is_empty; nofun 365 | | .prod _ _ => left; is_empty; nofun 366 | | .case l m x n => match l.infer Γ with 367 | | .inr ⟨ℕt, tl⟩ => match m.infer Γ a, n.infer (Γ‚ x ⦂ ℕt) a with 368 | | .inr tm, .inr tn => right; exact .case tl tm tn 369 | | .inl nm, _ => left; is_empty; intro (.case _ _ _); apply nm.false; trivial 370 | | .inr _, .inl nn => left; is_empty; intro (.case _ _ _); apply nn.false; trivial 371 | | .inr ⟨_ =⇒ _, tl⟩ => left; is_empty; intro (.case t _ _); injection t.unique tl 372 | | .inr ⟨.prod _ _, tl⟩ => left; is_empty; intro (.case t _ _); injection t.unique tl 373 | | .inl nl => left; is_empty; intro (.case _ _ _); apply nl.false; constructor <;> trivial 374 | | μ x : n => match n.infer (Γ‚ x ⦂ a) a with 375 | | .inr t => right; exact .mu t 376 | | .inl n => left; is_empty; intro (.mu t); exact n.false t 377 | | .fst m => match m.infer Γ with 378 | | .inr ⟨.prod b _, tm⟩ => if h : a = b then 379 | right; subst h; exact .fst tm 380 | else 381 | left; is_empty; intro (.fst t); injection t.unique tm; contradiction 382 | | .inr ⟨ℕt, tm⟩ => left; is_empty; intro (.fst t); injection t.unique tm 383 | | .inr ⟨_ =⇒ _, tm⟩ => left; is_empty; intro (.fst t); injection t.unique tm 384 | | .inl n => left; is_empty; intro (.fst t); apply n.false; constructor <;> trivial 385 | | .snd m => match m.infer Γ with 386 | | .inr ⟨.prod _ b, tm⟩ => if h : a = b then 387 | right; subst h; exact .snd tm 388 | else 389 | left; is_empty; intro (.snd t); injection t.unique tm; contradiction 390 | | .inr ⟨ℕt, tm⟩ => left; is_empty; intro (.snd t); injection t.unique tm 391 | | .inr ⟨_ =⇒ _, tm⟩ => left; is_empty; intro (.snd t); injection t.unique tm 392 | | .inl n => left; is_empty; intro (.snd t); apply n.false; constructor <;> trivial 393 | | .inh m => match m.infer Γ with 394 | | .inr ⟨b, tm⟩ => if h : a = b then 395 | right; subst h; exact .inh tm 396 | else 397 | left; rw [←Ne.def] at h; is_empty; intro (.inh _) 398 | apply (tm.empty_switch h.symm).false; trivial 399 | | .inl nm => left; is_empty; intro (.inh tm); apply nm.false; exists a 400 | end 401 | 402 | -- https://plfa.github.io/Inference/#testing-the-example-terms 403 | abbrev fourTy : Γ ⊢ four ⇡ ℕt := open TyS TyI Lookup in by 404 | repeat apply_rules 405 | [var, ap, prod, syn, 406 | lam, zero, succ, case, mu, fst, snd, inh, 407 | addTy, twoTy] 408 | <;> elem 409 | 410 | example : four.infer ∅ = .inr ⟨ℕt, fourTy⟩ := by rfl 411 | 412 | abbrev four'Ty : Γ ⊢ four' ⇡ ℕt := open TyS TyI Lookup in by 413 | repeat apply_rules 414 | [var, ap, prod, syn, 415 | lam, zero, succ, case, mu, fst, snd, inh, 416 | addCTy, twoCTy] 417 | <;> elem 418 | 419 | example : four'.infer ∅ = .inr ⟨ℕt, four'Ty⟩ := by rfl 420 | 421 | abbrev four'': TermS := mul □ two □ two 422 | 423 | abbrev four''Ty : Γ ⊢ four'' ⇡ ℕt := open TyS TyI Lookup in by 424 | repeat apply_rules 425 | [var, ap, prod, syn, 426 | lam, zero, succ, case, mu, fst, snd, inh, 427 | addCTy, twoCTy] 428 | <;> elem 429 | 430 | example : four''.infer ∅ = .inr ⟨ℕt, four''Ty⟩ := by rfl 431 | 432 | -- https://plfa.github.io/Inference/#testing-the-error-cases 433 | 434 | /- 435 | Sadly this won't work for now due to limitations with mutual recursions. 436 | See: 437 | -/ 438 | 439 | -- example := show ((ƛ "x" : `"y").the (ℕt =⇒ ℕt)).infer ∅ = .inl _ by rfl 440 | 441 | /- 442 | This won't work either, probably due to similar reasons... 443 | -/ 444 | 445 | -- instance : Decidable (Nonempty (Σ a, Γ ⊢ m ⇡ a)) := (m.infer Γ).toDecidable 446 | 447 | -- example := let m := (ƛ "x" : `"y").the (ℕt =⇒ ℕt); show IsEmpty (Σ a, ∅ ⊢ m ⇡ a) by 448 | -- rw [←not_nonempty_iff]; decide 449 | 450 | -- Unbound variable: 451 | #eval ((ƛ "x" : `"y").the (ℕt =⇒ ℕt)).infer ∅ 452 | 453 | -- Argument in application is ill typed: 454 | #eval (add □ succC).infer ∅ 455 | 456 | -- Function in application is ill typed: 457 | #eval (add □ succC □ two).infer ∅ 458 | 459 | -- Function in application has type natural: 460 | #eval (two.the ℕt □ two).infer ∅ 461 | 462 | -- Abstraction inherits type natural: 463 | #eval (twoC.the ℕt).infer ∅ 464 | 465 | -- Zero inherits a function type: 466 | #eval (𝟘.the (ℕt =⇒ ℕt)).infer ∅ 467 | 468 | -- Successor inherits a function type: 469 | #eval (two.the (ℕt =⇒ ℕt)).infer ∅ 470 | 471 | -- Successor of an ill-typed term: 472 | #eval ((ι twoC).the ℕt).infer ∅ 473 | 474 | -- Case of a term with a function type: 475 | #eval ((𝟘? twoC.the Ch [zero: 𝟘 |succ "x" : `"x"]).the ℕt).infer ∅ 476 | 477 | -- Case of an ill-typed term: 478 | #eval ((𝟘? twoC.the ℕt [zero: 𝟘 |succ "x" : `"x"]).the ℕt).infer ∅ 479 | 480 | -- Inherited and synthesized types disagree in a switch: 481 | #eval ((ƛ "x" : `"x").the (ℕt =⇒ ℕt =⇒ ℕt)).infer ∅ 482 | 483 | -- https://plfa.github.io/Inference/#erasure 484 | def Ty.erase : Ty → More.Ty 485 | | ℕt => .nat 486 | | a =⇒ b => .fn a.erase b.erase 487 | | .prod a b => a.erase * b.erase 488 | 489 | def Context.erase : Context → More.Context 490 | | [] => ∅ 491 | | ⟨_, a⟩ :: Γ => a.erase :: Context.erase Γ 492 | 493 | def Lookup.erase : Γ ∋ x ⦂ a → More.Lookup Γ.erase a.erase 494 | | .z => .z 495 | | .s _ i => .s i.erase 496 | 497 | mutual 498 | def TyS.erase : Γ ⊢ m ⇡ a → More.Term Γ.erase a.erase 499 | | .var i => .var i.erase 500 | | .ap l m => .ap l.erase m.erase 501 | | .prod m n => .prod m.erase n.erase 502 | | .syn m => m.erase 503 | 504 | def TyI.erase : Γ ⊢ m ⇣ a → More.Term Γ.erase a.erase 505 | | .lam m => .lam m.erase 506 | | .zero => .zero 507 | | .succ m => .succ m.erase 508 | | .case l m n => .case l.erase m.erase n.erase 509 | | .mu m => .mu m.erase 510 | | .fst m => .fst m.erase 511 | | .snd m => .snd m.erase 512 | | .inh m => m.erase 513 | end 514 | 515 | example : fourTy.erase (Γ := ∅) = More.Term.four := by rfl 516 | 517 | -- https://plfa.github.io/Inference/#exercise-inference-multiplication-recommended 518 | example : mul.infer ∅ = .inr ⟨ℕt =⇒ ℕt =⇒ ℕt, mulTy⟩ := by rfl 519 | 520 | -- ! BOOM! The commented lines below are very CPU/RAM-intensive, and might even make LEAN4 leak memory! 521 | -- example : mulTy.erase (Γ := ∅) = More.Term.mul := by rfl 522 | -- example : four'Ty.erase (Γ := ∅) = More.Term.four' := by rfl 523 | -- example : four''Ty.erase (Γ := ∅) = More.Term.four'' := by rfl 524 | -------------------------------------------------------------------------------- /Plfl/Untyped.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Untyped/ 2 | 3 | import Plfl.Init 4 | 5 | namespace Untyped 6 | 7 | -- https://plfa.github.io/Untyped/#types 8 | inductive Ty where 9 | | star: Ty 10 | deriving BEq, DecidableEq, Repr 11 | 12 | namespace Notation 13 | scoped notation "✶" => Ty.star 14 | end Notation 15 | 16 | open Notation 17 | 18 | -- https://plfa.github.io/Untyped/#exercise-type-practice 19 | instance : Ty ≃ Unit where 20 | toFun _ := () 21 | invFun _ := ✶ 22 | left_inv _ := by simp only 23 | right_inv _ := by simp only 24 | 25 | instance : Unique Ty where 26 | default := ✶ 27 | uniq := by simp only [implies_true] 28 | 29 | -- https://plfa.github.io/Untyped/#contexts 30 | abbrev Context : Type := List Ty 31 | 32 | namespace Context 33 | abbrev snoc (Γ : Context) (a : Ty) : Context := a :: Γ 34 | abbrev lappend (Γ : Context) (Δ : Context) : Context := Δ ++ Γ 35 | end Context 36 | 37 | namespace Notation 38 | open Context 39 | 40 | -- `‚` is not a comma! See: 41 | scoped infixl:50 "‚ " => snoc 42 | scoped infixl:45 "‚‚ " => lappend 43 | end Notation 44 | 45 | -- https://plfa.github.io/Untyped/#exercise-context%E2%84%95-practice 46 | instance Context.equiv_nat : Context ≃ ℕ where 47 | toFun := List.length 48 | invFun := (List.replicate · ✶) 49 | left_inv := left_inv 50 | right_inv := by intro; simp only [List.length_replicate] 51 | where 52 | left_inv := by intro 53 | | [] => trivial 54 | | ✶ :: ss => calc List.replicate (✶ :: ss).length ✶ 55 | _ = List.replicate (ss.length + 1) ✶ := by rw [List.length_cons ✶ ss] 56 | _ = ✶ :: List.replicate ss.length ✶ := by rw [List.replicate_succ ✶ ss.length] 57 | _ = ✶ :: ss := by have := left_inv ss; simp_all only 58 | 59 | instance : Coe ℕ Context where coe := Context.equiv_nat.invFun 60 | 61 | -- https://plfa.github.io/Untyped/#variables-and-the-lookup-judgment 62 | inductive Lookup : Context → Ty → Type where 63 | | z : Lookup (Γ‚ t) t 64 | | s : Lookup Γ t → Lookup (Γ‚ t') t 65 | deriving DecidableEq 66 | 67 | namespace Notation 68 | open Lookup 69 | 70 | scoped infix:40 " ∋ " => Lookup 71 | 72 | -- https://github.com/arthurpaulino/lean4-metaprogramming-book/blob/d6a227a63c55bf13d49d443f47c54c7a500ea27b/md/main/macros.md#simplifying-macro-declaration 73 | scoped syntax "get_elem" (ppSpace term) : term 74 | scoped macro_rules | `(term| get_elem $n) => match n.1.toNat with 75 | | 0 => `(term| Lookup.z) 76 | | n+1 => `(term| Lookup.s (get_elem $(Lean.quote n))) 77 | 78 | scoped macro "♯" n:term:90 : term => `(get_elem $n) 79 | end Notation 80 | 81 | def Lookup.toNat : (Γ ∋ a) → ℕ 82 | | .z => 0 83 | | .s i => i.toNat + 1 84 | 85 | instance : Repr (Γ ∋ a) where reprPrec i n := "♯" ++ reprPrec i.toNat n 86 | 87 | -- https://plfa.github.io/Untyped/#terms-and-the-scoping-judgment 88 | inductive Term : Context → Ty → Type where 89 | -- Lookup 90 | | var : Γ ∋ a → Term Γ a 91 | -- Lambda 92 | | lam : Term (Γ‚ ✶ /- a -/) ✶ /- b -/ → Term Γ ✶ /- (a =⇒ b) -/ 93 | | ap : Term Γ ✶ /- (a =⇒ b) -/ → Term Γ ✶ /- a -/ → Term Γ ✶ /- b -/ 94 | deriving DecidableEq, Repr 95 | 96 | namespace Notation 97 | open Term 98 | 99 | scoped infix:40 " ⊢ " => Term 100 | 101 | scoped prefix:50 "ƛ " => lam 102 | scoped infixr:min " $ " => ap 103 | scoped infixl:70 " □ " => ap 104 | scoped prefix:90 "` " => var 105 | 106 | -- https://plfa.github.io/Untyped/#writing-variables-as-numerals 107 | scoped macro "#" n:term:90 : term => `(`♯$n) 108 | end Notation 109 | 110 | namespace Term 111 | -- https://plfa.github.io/Untyped/#test-examples 112 | abbrev twoC : Γ ⊢ ✶ := ƛ ƛ (#1 $ #1 $ #0) 113 | abbrev fourC : Γ ⊢ ✶ := ƛ ƛ (#1 $ #1 $ #1 $ #1 $ #0) 114 | abbrev addC : Γ ⊢ ✶ := ƛ ƛ ƛ ƛ (#3 □ #1 $ #2 □ #1 □ #0) 115 | abbrev fourC' : Γ ⊢ ✶ := addC □ twoC □ twoC 116 | 117 | def church (n : ℕ) : Γ ⊢ ✶ := ƛ ƛ applyN n 118 | where 119 | applyN 120 | | 0 => #0 121 | | n + 1 => #1 □ applyN n 122 | end Term 123 | 124 | namespace Subst 125 | -- https://plfa.github.io/Untyped/#renaming 126 | /-- 127 | If one context maps to another, 128 | the mapping holds after adding the same variable to both contexts. 129 | -/ 130 | def ext : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ‚ b ∋ a → Δ‚ b ∋ a := by 131 | intro ρ; intro 132 | | .z => exact .z 133 | | .s x => refine .s ?_; exact ρ x 134 | 135 | /-- 136 | If one context maps to another, 137 | then the type judgements are the same in both contexts. 138 | -/ 139 | def rename : (∀ {a}, Γ ∋ a → Δ ∋ a) → Γ ⊢ a → Δ ⊢ a := by 140 | intro ρ; intro 141 | | ` x => exact ` (ρ x) 142 | | ƛ n => exact ƛ (rename (ext ρ) n) 143 | | l □ m => exact rename ρ l □ rename ρ m 144 | 145 | abbrev shift : Γ ⊢ a → Γ‚ b ⊢ a := rename .s 146 | 147 | -- https://plfa.github.io/Untyped/#simultaneous-substitution 148 | def exts : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ‚ b ∋ a → Δ‚ b ⊢ a := by 149 | intro σ; intro 150 | | .z => exact `.z 151 | | .s x => apply shift; exact σ x 152 | 153 | /-- 154 | General substitution for multiple free variables. 155 | If the variables in one context maps to some terms in another, 156 | then the type judgements are the same before and after the mapping, 157 | i.e. after replacing the free variables in the former with (expanded) terms. 158 | -/ 159 | def subst : (∀ {a}, Γ ∋ a → Δ ⊢ a) → Γ ⊢ a → Δ ⊢ a := by 160 | intro σ; intro 161 | | ` i => exact σ i 162 | | ƛ n => exact ƛ (subst (exts σ) n) 163 | | l □ m => exact subst σ l □ subst σ m 164 | 165 | -- https://plfa.github.io/Untyped/#single-substitution 166 | abbrev subst₁σ (v : Γ ⊢ b) : ∀ {a}, Γ‚ b ∋ a → Γ ⊢ a := by 167 | introv; intro 168 | | .z => exact v 169 | | .s x => exact ` x 170 | 171 | /-- 172 | Substitution for one free variable `v` in the term `n`. 173 | -/ 174 | abbrev subst₁ (v : Γ ⊢ b) (n : Γ‚ b ⊢ a) : Γ ⊢ a := by 175 | refine subst ?_ n; exact subst₁σ v 176 | end Subst 177 | 178 | open Subst 179 | 180 | namespace Notation 181 | scoped notation:90 n "⟦" m "⟧" => subst₁ m n 182 | scoped macro " ⟪" σ:term "⟫ " : term => `(subst $σ) 183 | end Notation 184 | 185 | -- https://plfa.github.io/Untyped/#neutral-and-normal-terms 186 | mutual 187 | inductive Neutral : Γ ⊢ a → Type 188 | | var : (x : Γ ∋ a) → Neutral (` x) 189 | | ap : Neutral l → Normal m → Neutral (l □ m) 190 | deriving Repr 191 | 192 | inductive Normal : Γ ⊢ a → Type 193 | | norm : Neutral m → Normal m 194 | | lam : Normal n → Normal (ƛ n) 195 | deriving Repr 196 | end 197 | 198 | -- instance : Coe (Neutral t) (Normal t) where coe := .norm 199 | 200 | namespace Notation 201 | open Neutral Normal 202 | 203 | scoped prefix:60 " ′" => Normal.norm 204 | scoped macro "#′" n:term:90 : term => `(var (♯$n)) 205 | 206 | scoped prefix:50 "ƛₙ " => lam 207 | scoped infixr:min " $ₙ " => ap 208 | scoped infixl:70 " □ₙ " => ap 209 | scoped prefix:90 "`ₙ " => var 210 | end Notation 211 | 212 | example : Normal (Term.twoC (Γ := ∅)) := ƛₙ ƛₙ (′#′1 □ₙ (′#′1 □ₙ (′#′0))) 213 | 214 | -- https://plfa.github.io/Untyped/#reduction-step 215 | /-- 216 | `Reduce t t'` says that `t` reduces to `t'` via a given step. 217 | 218 | _Note: This time there's no need to generate data out of `Reduce t t'`, 219 | so it can just be a `Prop`._ 220 | -/ 221 | inductive Reduce : (Γ ⊢ a) → (Γ ⊢ a) → Prop where 222 | | lamβ : Reduce ((ƛ n) □ v) (n⟦v⟧) 223 | | lamζ : Reduce n n' → Reduce (ƛ n) (ƛ n') 224 | | apξ₁ : Reduce l l' → Reduce (l □ m) (l' □ m) 225 | | apξ₂ : Reduce m m' → Reduce (v □ m) (v □ m') 226 | 227 | -- https://plfa.github.io/Untyped/#exercise-variant-1-practice 228 | inductive Reduce' : (Γ ⊢ a) → (Γ ⊢ a) → Type where 229 | | lamβ : Normal (ƛ n) → Normal v → Reduce' ((ƛ n) □ v) (n⟦v⟧) 230 | | lamζ : Reduce' n n' → Reduce' (ƛ n) (ƛ n') 231 | | apξ₁ : Reduce' l l' → Reduce' (l □ m) (l' □ m) 232 | | apξ₂ : Normal v → Reduce' m m' → Reduce' (v □ m) (v □ m') 233 | 234 | -- https://plfa.github.io/Untyped/#exercise-variant-2-practice 235 | inductive Reduce'' : (Γ ⊢ a) → (Γ ⊢ a) → Type where 236 | | lamβ : Reduce'' ((ƛ n) □ (ƛ v)) (n⟦ƛ v⟧) 237 | | apξ₁ : Reduce'' l l' → Reduce'' (l □ m) (l' □ m) 238 | | apξ₂ : Reduce'' m m' → Reduce'' (v □ m) (v □ m') 239 | /- 240 | Reduction of `four''C` under this variant might go as far as 241 | `ƛ ƛ (twoC □ #1 $ (twoC □ #1 □ #0))` and get stuck, 242 | since the next step uses `lamζ` which no longer exists. 243 | -/ 244 | 245 | -- https://plfa.github.io/Untyped/#reflexive-and-transitive-closure 246 | /-- 247 | A reflexive and transitive closure, 248 | defined as a sequence of zero or more steps of the underlying relation `—→`. 249 | 250 | _Note: Since `Reduce t t' : Prop`, `Clos` can be defined directly from `Reduce`._ 251 | -/ 252 | abbrev Reduce.Clos {Γ a} := Relation.ReflTransGen (α := Γ ⊢ a) Reduce 253 | 254 | namespace Notation 255 | -- https://plfa.github.io/DeBruijn/#reflexive-and-transitive-closure 256 | scoped infix:40 " —→ " => Reduce 257 | scoped infix:20 " —↠ " => Reduce.Clos 258 | end Notation 259 | 260 | namespace Reduce.Clos 261 | @[refl] abbrev refl : m —↠ m := .refl 262 | abbrev tail : (m —↠ n) → (n —→ n') → (m —↠ n') := .tail 263 | abbrev head : (m —→ n) → (n —↠ n') → (m —↠ n') := .head 264 | abbrev single : (m —→ n) → (m —↠ n) := .single 265 | 266 | instance : Coe (m —→ n) (m —↠ n) where coe r := .single r 267 | 268 | instance : Trans (α := Γ ⊢ a) Clos Clos Clos where trans := .trans 269 | instance : Trans (α := Γ ⊢ a) Clos Reduce Clos where trans c r := c.tail r 270 | instance : Trans (α := Γ ⊢ a) Reduce Reduce Clos where trans r r' := .tail r r' 271 | instance : Trans (α := Γ ⊢ a) Reduce Clos Clos where trans r c := .head r c 272 | end Reduce.Clos 273 | 274 | namespace Reduce 275 | -- https://plfa.github.io/Untyped/#example-reduction-sequence 276 | open Term 277 | 278 | example : fourC' (Γ := ∅) —↠ fourC := calc addC □ twoC □ twoC 279 | _ —→ (ƛ ƛ ƛ (twoC □ #1 $ (#2 □ #1 □ #0))) □ twoC := by apply_rules [apξ₁, lamβ] 280 | _ —→ ƛ ƛ (twoC □ #1 $ (twoC □ #1 □ #0)) := by exact lamβ 281 | _ —→ ƛ ƛ ((ƛ (#2 $ #2 $ #0)) $ (twoC □ #1 □ #0)) := by apply_rules [lamζ, apξ₁, lamβ] 282 | _ —→ ƛ ƛ (#1 $ #1 $ (twoC □ #1 □ #0)) := by apply_rules [lamζ, lamβ] 283 | _ —→ ƛ ƛ (#1 $ #1 $ ((ƛ (#2 $ #2 $ #0)) □ #0)) := by apply_rules [lamζ, apξ₁, apξ₂, lamβ] 284 | _ —→ ƛ ƛ (#1 $ #1 $ #1 $ #1 $ #0) := by apply_rules [lamζ, apξ₁, apξ₂, lamβ] 285 | end Reduce 286 | 287 | -- https://plfa.github.io/Untyped/#progress 288 | /-- 289 | If a term `m` is not ill-typed, then it either is a value or can be reduced. 290 | -/ 291 | inductive Progress (m : Γ ⊢ a) where 292 | | step : (m —→ n) → Progress m 293 | | done : Normal m → Progress m 294 | 295 | /-- 296 | If a term is well-scoped, then it satisfies progress. 297 | -/ 298 | def Progress.progress : (m : Γ ⊢ a) → Progress m := open Reduce in by 299 | intro 300 | | ` x => apply done; exact ′`ₙ x 301 | | ƛ n => 302 | have : sizeOf n < sizeOf (ƛ n) := by simp only [ 303 | Term.lam.sizeOf_spec, lt_add_iff_pos_left, 304 | add_pos_iff, zero_lt_one, true_or, 305 | ] 306 | match progress n with 307 | | .done n => apply done; exact ƛₙ n 308 | | .step n => apply step; exact lamζ n 309 | | ` x □ m => 310 | have : sizeOf m < sizeOf (` x □ m) := by simp only [ 311 | Term.ap.sizeOf_spec, Term.var.sizeOf_spec, 312 | Ty.star.sizeOf_spec, lt_add_iff_pos_left, 313 | add_pos_iff, zero_lt_one, true_or, or_self, 314 | ] 315 | match progress m with 316 | | .done m => apply done; exact ′`ₙx □ₙ m 317 | | .step m => apply step; exact apξ₂ m 318 | | (ƛ n) □ m => apply step; exact lamβ 319 | | l@(_ □ _) □ m => 320 | have : sizeOf l < sizeOf (l □ m) := by simp_arith 321 | match progress l with 322 | | .step l => simp_all only [namedPattern]; apply step; exact apξ₁ l 323 | | .done (′l') => 324 | simp_all only [namedPattern]; rename_i h; simp only [h.symm, Term.ap.sizeOf_spec] 325 | have : sizeOf m < sizeOf (l □ m) := by 326 | aesop_subst h; simp only [ 327 | Term.ap.sizeOf_spec, lt_add_iff_pos_left, add_pos_iff, 328 | zero_lt_one, true_or, or_self, 329 | ] 330 | match progress m with 331 | | .done m => apply done; exact ′l' □ₙ m 332 | | .step m => apply step; exact apξ₂ m 333 | 334 | open Progress (progress) 335 | 336 | -- https://plfa.github.io/Untyped/#evaluation 337 | inductive Result (n : Γ ⊢ a) where 338 | | done (val : Normal n) 339 | | dnf 340 | deriving Repr 341 | 342 | inductive Steps (l : Γ ⊢ a) where 343 | | steps : ∀{n : Γ ⊢ a}, (l —↠ n) → Result n → Steps l 344 | 345 | def eval (gas : ℕ) (l : ∅ ⊢ a) : Steps l := 346 | if gas = 0 then 347 | ⟨.refl, .dnf⟩ 348 | else 349 | match progress l with 350 | | .done v => .steps .refl <| .done v 351 | | .step r => 352 | let ⟨rs, res⟩ := eval (gas - 1) (by trivial) 353 | ⟨Trans.trans r rs, res⟩ 354 | 355 | namespace Term 356 | abbrev id : Γ ⊢ ✶ := ƛ #0 357 | abbrev delta : Γ ⊢ ✶ := ƛ #0 □ #0 358 | abbrev omega : Γ ⊢ ✶ := delta □ delta 359 | 360 | -- https://plfa.github.io/Untyped/#naturals-and-fixpoint 361 | /- 362 | The Scott encoding: 363 | zero := λ _ z => z 364 | succ n := λ s _ => s n 365 | 366 | e.g. one = succ zero 367 | = λ s _ => s zero 368 | = λ s _ => s (λ _ z => z) 369 | -/ 370 | abbrev zeroS : Γ ⊢ ✶ := ƛ ƛ #0 371 | abbrev succS (m : Γ ⊢ ✶) : Γ ⊢ ✶ := (ƛ ƛ ƛ (#1 □ #2)) □ m 372 | abbrev caseS (l : Γ ⊢ ✶) (m : Γ ⊢ ✶) (n : Γ‚ ✶ ⊢ ✶) : Γ ⊢ ✶ := l □ (ƛ n) □ m 373 | 374 | /-- 375 | The Y combinator: `Y f := (λ x => f (x x)) (λ x => f (x x))` 376 | -/ 377 | abbrev mu (n : Γ‚ ✶ ⊢ ✶) : Γ ⊢ ✶ := (ƛ (ƛ (#1 $ #0 $ #0)) □ (ƛ (#1 $ #0 $ #0))) □ (ƛ n) 378 | end Term 379 | 380 | namespace Notation 381 | open Term 382 | 383 | scoped prefix:50 "μ " => mu 384 | scoped prefix:80 "ι " => succS 385 | scoped notation "𝟘" => zeroS 386 | scoped notation "𝟘? " => caseS 387 | end Notation 388 | 389 | -- https://plfa.github.io/Untyped/#example 390 | section examples 391 | open Term 392 | 393 | abbrev addS : Γ ⊢ ✶ := μ ƛ ƛ (𝟘? (#1) (#0) (ι (#3 □ #0 □ #1))) 394 | 395 | -- https://plfa.github.io/Untyped/#exercise-multiplication-untyped-recommended 396 | abbrev mulS : Γ ⊢ ✶ := μ ƛ ƛ (𝟘? (#1) 𝟘 (addS □ #1 $ #3 □ #0 □ #1)) 397 | 398 | abbrev oneS : Γ ⊢ ✶ := ι 𝟘 399 | 400 | abbrev twoS : Γ ⊢ ✶ := ι ι 𝟘 401 | abbrev twoS'' : Γ ⊢ ✶ := mulS □ twoS □ oneS 402 | 403 | abbrev fourS : Γ ⊢ ✶ := ι ι twoS 404 | abbrev fourS' : Γ ⊢ ✶ := addS □ twoS □ twoS 405 | abbrev fourS'' : Γ ⊢ ✶ := mulS □ twoS □ twoS 406 | 407 | abbrev evalRes (l : ∅ ⊢ a) (gas := 100) := (eval gas l).3 408 | 409 | #eval evalRes (gas := 3) fourC' 410 | #eval evalRes fourC' 411 | 412 | #eval evalRes oneS 413 | 414 | #eval evalRes twoS 415 | #eval evalRes twoS'' 416 | 417 | #eval evalRes fourS 418 | #eval evalRes fourS' 419 | #eval evalRes fourS'' 420 | end examples 421 | 422 | -- https://plfa.github.io/Untyped/#multi-step-reduction-is-transitive 423 | 424 | /- 425 | Nothing to do. 426 | The `Trans` instance has been automatically generated by `Relation.ReflTransGen`. 427 | See: 428 | -/ 429 | 430 | -- https://plfa.github.io/Untyped/#multi-step-reduction-is-a-congruence 431 | /-- 432 | LEAN is being a bit weird here. 433 | Default structural recursion cannot be used since it depends on sizeOf, 434 | however this won't work for `Prop`. 435 | We have to find another way. 436 | -/ 437 | theorem Reduce.ap_congr₁ (rs : l —↠ l') : (l □ m) —↠ (l' □ m) := by 438 | refine rs.head_induction_on .refl ?_ 439 | · introv; intro r _ rs; refine .head ?_ rs; exact apξ₁ r 440 | 441 | theorem Reduce.ap_congr₂ (rs : m —↠ m') : (l □ m) —↠ (l □ m') := by 442 | refine rs.head_induction_on .refl ?_ 443 | · introv; intro r _ rs; refine .head ?_ rs; exact apξ₂ r 444 | 445 | theorem Reduce.lam_congr (rs : n —↠ n') : (ƛ n —↠ ƛ n') := by 446 | refine rs.head_induction_on .refl ?_ 447 | · introv; intro r _ rs; refine .head ?_ rs; exact lamζ r 448 | -------------------------------------------------------------------------------- /Plfl/Untyped/BigStep.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/BigStep/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped 5 | import Plfl.Untyped.Substitution 6 | 7 | namespace BigStep 8 | 9 | open Untyped (Context) 10 | open Untyped.Notation 11 | open Substitution (Subst ids sub_ids) 12 | 13 | -- https://plfa.github.io/BigStep/#environments 14 | /-- 15 | A closure in call-by-name is a term paired with its environment. 16 | -/ 17 | inductive Clos : Type where 18 | | clos : ∀ {Γ}, (m : Γ ⊢ ✶) → (γ : (Γ ∋ ✶) → Clos) → Clos 19 | 20 | /-- 21 | An environment in call-by-name is a mapping from variables to closures. 22 | -/ 23 | abbrev ClosEnv (Γ : Context) := (Γ ∋ ✶) → Clos 24 | 25 | def ClosEnv.empty : ClosEnv ∅ := by intro. 26 | 27 | instance ClosEnv.instEmptyCollection : EmptyCollection (ClosEnv ∅) where 28 | emptyCollection := empty 29 | 30 | def ClosEnv.tail (γ : ClosEnv Γ) (c : Clos) : ClosEnv (Γ‚ ✶) 31 | | .z => c 32 | | .s i => γ i 33 | 34 | namespace Notation 35 | -- `‚` is not a comma! See: 36 | scoped infixl:50 "‚' " => ClosEnv.tail 37 | end Notation 38 | 39 | open Notation 40 | 41 | inductive Eval : ClosEnv Γ → (Γ ⊢ ✶) → Clos → Prop where 42 | | var : γ i = .clos m δ → Eval δ m v → Eval γ (` i) v 43 | | lam : Eval γ (ƛ m) (.clos (ƛ m) γ) 44 | | ap : Eval γ l (.clos (ƛ n) δ) → Eval (δ‚' .clos m γ) n v → Eval γ (l □ m) v 45 | 46 | namespace Notation 47 | scoped notation:40 γ " ⊢ " m " ⇓ " c:51 => Eval γ m c 48 | end Notation 49 | 50 | -- https://plfa.github.io/BigStep/#exercise-big-step-eg-practice 51 | example 52 | : γ ⊢ (ƛ ƛ #1) $ (ƛ #0 □ #0) $ (ƛ #0 □ #0) 53 | -- (λ x y => x) ((λ f => f f) (λ f => f f)) ⇓ (λ y => ((λ f => f f) (λ f => f f))) 54 | ⇓ .clos (ƛ #1) (γ‚' .clos ((ƛ #0 □ #0) $ (ƛ #0 □ #0)) γ) 55 | := .ap .lam .lam 56 | 57 | -- https://plfa.github.io/BigStep/#the-big-step-semantics-is-deterministic 58 | theorem Eval.determ (e : γ ⊢ m ⇓ v) (e' : γ ⊢ m ⇓ v') : v = v' := by 59 | induction e generalizing v' with cases e' 60 | | lam => rfl 61 | | var h _ ih => 62 | subst_vars; rename_i h' e'; injection h.symm.trans h' 63 | rename_i h hh hh'; subst h; rw [←hh.eq, ←hh'.eq] at e'; exact ih e' 64 | | ap _ _ ih ih₁ => 65 | rename_i e' e₁'; apply ih₁; injection ih e' 66 | subst_vars; rename_i h; injection h; subst_vars; exact e₁' 67 | 68 | -- https://plfa.github.io/BigStep/#big-step-evaluation-implies-beta-reduction-to-a-lambda 69 | noncomputable def Clos.Equiv : Clos → (∅ ⊢ ✶) → Prop 70 | | .clos (Γ := Γ) m γ, n => 71 | ∃ (σ : Subst Γ ∅), (∀ i, Clos.Equiv (γ i) (σ i)) ∧ (n = ⟪σ⟫ m) 72 | 73 | abbrev ClosEnv.Equiv (γ : ClosEnv Γ) (σ : Subst Γ ∅) : Prop := 74 | ∀ i, Clos.Equiv (γ i) (σ i) 75 | 76 | namespace Notation 77 | -- The default precedence in Agda is 20. 78 | -- See: 79 | scoped infix:20 " ~~ " => Clos.Equiv 80 | scoped infix:20 " ~~ₑ " => ClosEnv.Equiv 81 | end Notation 82 | 83 | section 84 | open Untyped.Subst 85 | open Substitution 86 | 87 | @[simp] lemma ClosEnv.empty_equiv_ids : ∅ ~~ₑ ids := by intro. 88 | 89 | abbrev ext_subst (σ : Subst Γ Δ) (n : Δ ⊢ ✶) : Subst (Γ‚ ✶) Δ := (·⟦n⟧) ∘ exts σ 90 | 91 | lemma subst₁σ_exts {σ : Subst Γ Δ} {m : Δ ⊢ b} {i : Γ ∋ ✶} 92 | : (ext_subst σ m) (.s i) = σ i 93 | := by simp only [subst₁σ_exts_cons] 94 | 95 | theorem ClosEnv.ext {γ : ClosEnv Γ} {σ : Subst Γ ∅} {n : ∅ ⊢ ✶} 96 | (ee : γ ~~ₑ σ) (e : v ~~ n) : (γ‚' v ~~ₑ ext_subst σ n) 97 | := by intro 98 | | .z => exact e 99 | | .s i => simp only [subst₁σ_exts]; exact ee i 100 | 101 | theorem Eval.clos_env_equiv {γ : ClosEnv Γ} {σ : Subst Γ ∅} {m : Γ ⊢ ✶} 102 | (ev : γ ⊢ m ⇓ v) (ee : γ ~~ₑ σ) 103 | : ∃ (n : ∅ ⊢ ✶), (⟪σ⟫ m —↠ n) ∧ (v ~~ n) 104 | := open Untyped.Reduce in by induction ev with 105 | | lam => rename_i n; exists ⟪σ⟫ (ƛ n), by rfl, σ, ee 106 | | var h _ev ih => 107 | rename_i i; have := ee i; rw [h] at this; have ⟨τ, eeτ, hτ⟩ := this 108 | have ⟨n, rn, en⟩ := ih eeτ; rw [←hτ] at rn; exists n, rn 109 | | ap _ev _ev' ih ih' => 110 | have ⟨n, rn, τ, eeτ, hτ⟩ := ih ee; subst hτ 111 | have ⟨n', rn', en'⟩ := ih' <| ClosEnv.ext eeτ ⟨σ, ee, rfl⟩ 112 | refine ⟨n', ?_, en'⟩; simp only [sub_ap]; rename_i n _ m _ 113 | apply (ap_congr₁ rn).trans; unfold ext_subst at rn' 114 | calc ⟪τ⟫ (ƛ n) □ ⟪σ⟫ m 115 | _ = (ƛ (⟪exts τ⟫ n)) □ ⟪σ⟫ m := rfl 116 | _ —→ ⟪subst₁σ (⟪σ⟫ m)⟫ (⟪exts τ⟫ n) := lamβ 117 | _ = ⟪⟪subst₁σ (⟪σ⟫ m)⟫ ∘ exts τ⟫ n := Substitution.sub_sub 118 | _ —↠ n' := rn' 119 | 120 | /-- 121 | If call-by-name can produce a value, 122 | then the program can be reduced to a λ-abstraction via β-rules. 123 | -/ 124 | theorem Eval.reduce_of_cbn {m : ∅ ⊢ ✶} {δ : ClosEnv Δ} {n' : Δ‚ ✶ ⊢ ✶} 125 | (ev : ∅ ⊢ m ⇓ .clos (ƛ n') δ) 126 | : ∃ (n : ∅‚ ✶ ⊢ ✶), m —↠ ƛ n 127 | := by 128 | have ⟨n, rn, σ, _, h⟩ := ev.clos_env_equiv ClosEnv.empty_equiv_ids 129 | subst h; rw [sub_ids] at rn; exists ⟪exts σ⟫ n' 130 | end 131 | 132 | -- https://plfa.github.io/BigStep/#exercise-big-alt-implies-multi-practice 133 | namespace BySubst 134 | 135 | -- https://github.com/L-TChen/ModalTypeTheory/blob/a4d3cf67236716fa324daa3e5a929f38a33c39e9/src/STLC/BigStep.agda#L96-L121 136 | -- https://www.cs.cornell.edu/courses/cs6110/2014sp/Handouts/Sestoft.pdf 137 | inductive Eval : (Γ ⊢ ✶) → (Γ ⊢ ✶) → Prop where 138 | -- Hmmm, it's all ƛ's after all? 139 | | lam : ∀ {n : ∅‚ ✶ ⊢ ✶}, Eval (ƛ n) (ƛ n) 140 | | ap : Eval l (ƛ m) → Eval (m⟦n⟧) v → Eval (l □ n) v 141 | 142 | namespace Notation 143 | scoped infix:50 " ⇓' "=> Eval 144 | end Notation 145 | 146 | open Notation 147 | 148 | theorem Eval.determ : m ⇓' v → m ⇓' v' → v = v' := by intro 149 | | .lam, .lam => rfl 150 | | .ap mc mc₁, .ap mc' mc₁' => 151 | have := mc.determ mc'; injection this; subst_vars; exact mc₁.determ mc₁' 152 | 153 | open Untyped.Reduce 154 | open Untyped.Subst 155 | 156 | /-- 157 | If call-by-name can produce a value, 158 | then the program can be reduced to a λ-abstraction via β-rules. 159 | -/ 160 | theorem Eval.reduce_of_cbn {n : Γ‚ ✶ ⊢ ✶} (ev : m ⇓' (ƛ n)) : m —↠ ƛ n := by 161 | generalize hx : (ƛ n) = x, hx' : m = x' at * 162 | induction ev with 163 | | lam => rfl 164 | | ap _evl evmn' ih ih' => subst_vars; rename_i l m n'; calc l □ n' 165 | _ —↠ (ƛ m) □ n' := ap_congr₁ <| ih rfl rfl 166 | _ —→ m⟦n'⟧ := lamβ 167 | _ —↠ (ƛ n) := ih' rfl rfl 168 | -------------------------------------------------------------------------------- /Plfl/Untyped/Confluence.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Confluence/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped 5 | import Plfl.Untyped.Substitution 6 | 7 | namespace Confluence 8 | 9 | open Untyped.Notation 10 | 11 | -- https://plfa.github.io/Confluence/#parallel-reduction 12 | /-- 13 | Parallel reduction. 14 | -/ 15 | inductive PReduce : (Γ ⊢ a) → (Γ ⊢ a) → Prop where 16 | | var : PReduce (` x) (` x) 17 | | lamβ : PReduce n n' → PReduce v v' → PReduce ((ƛ n) □ v) (n'⟦v'⟧) 18 | | lamζ : PReduce n n' → PReduce (ƛ n) (ƛ n') 19 | | apξ : PReduce l l' → PReduce m m' → PReduce (l □ m) (l' □ m') 20 | 21 | namespace PReduce 22 | @[refl] 23 | theorem refl (m : Γ ⊢ a) : PReduce m m := by 24 | match m with 25 | | ` i => exact .var 26 | | ƛ n => apply lamζ; apply refl 27 | | l □ m => apply apξ <;> apply refl 28 | 29 | abbrev Clos {Γ a} := Relation.ReflTransGen (α := Γ ⊢ a) PReduce 30 | end PReduce 31 | 32 | open Relation.ReflTransGen (head_induction_on) 33 | 34 | namespace Notation 35 | scoped infix:20 " ⇛ " => PReduce 36 | scoped infix:20 " ⇛* " => PReduce.Clos 37 | end Notation 38 | 39 | open Notation 40 | 41 | namespace PReduce.Clos 42 | abbrev single (p : m ⇛ n) : (m ⇛* n) := .head p .refl 43 | abbrev tail : (m ⇛* n) → (n ⇛ n') → (m ⇛* n') := .tail 44 | abbrev trans : (m ⇛* n) → (n ⇛* n') → (m ⇛* n') := .trans 45 | 46 | instance : Coe (m ⇛ n) (m ⇛* n) where coe := .single 47 | end PReduce.Clos 48 | 49 | namespace PReduce 50 | instance : IsRefl (Γ ⊢ a) PReduce where refl := .refl 51 | 52 | instance : Trans (α := Γ ⊢ a) Clos Clos Clos where trans := .trans 53 | instance : Trans (α := Γ ⊢ a) Clos PReduce Clos where trans c r := c.tail r 54 | instance : Trans (α := Γ ⊢ a) PReduce PReduce Clos where trans r r' := .tail r r' 55 | instance : Trans (α := Γ ⊢ a) PReduce Clos Clos where trans r c := .head r c 56 | 57 | -- https://plfa.github.io/Confluence/#equivalence-between-parallel-reduction-and-reduction 58 | def fromReduce {Γ a} {m n : Γ ⊢ a} : m —→ n → (m ⇛ n) := by intro 59 | | .lamβ => refine .lamβ ?rn ?rv <;> rfl 60 | | .lamζ rn => refine .lamζ ?_; exact fromReduce rn 61 | | .apξ₁ rl => refine .apξ ?_ (by rfl); exact fromReduce rl 62 | | .apξ₂ rm => refine .apξ (by rfl) ?_; exact fromReduce rm 63 | 64 | def toReduceClos : (m ⇛ n) → (m —↠ n) := open Untyped.Reduce in by intro 65 | | .var => rfl 66 | | .lamβ rn rv => rename_i n n' v v'; calc (ƛ n) □ v 67 | _ —↠ (ƛ n') □ v := by refine ap_congr₁ (toReduceClos ?_); exact .lamζ rn 68 | _ —↠ (ƛ n') □ v' := ap_congr₂ rv.toReduceClos 69 | _ —→ n'⟦v'⟧ := .lamβ 70 | | .lamζ rn => apply lam_congr; exact rn.toReduceClos 71 | | .apξ rl rm => rename_i l l' m m'; calc l □ m 72 | _ —↠ l' □ m := ap_congr₁ rl.toReduceClos 73 | _ —↠ l' □ m' := ap_congr₂ rm.toReduceClos 74 | end PReduce 75 | 76 | instance instNonemptyPReduceReduceClos : (m ⇛* n) ≃ (m —↠ n) where 77 | toFun := toFun 78 | invFun := invFun 79 | left_inv _ := by simp only 80 | right_inv _ := by simp only 81 | where 82 | toFun {m n} : (m ⇛* n) → (m —↠ n) := by 83 | intro rs; induction rs using head_induction_on with 84 | | refl => rfl 85 | | head r _ => apply r.toReduceClos.trans; trivial 86 | 87 | invFun {m n} : (m —↠ n) → (m ⇛* n) := by 88 | intro rs; induction rs using head_induction_on with 89 | | refl => rfl 90 | | head r _ => refine .head (PReduce.fromReduce r) ?_; trivial 91 | 92 | open Untyped.Subst 93 | open Substitution 94 | 95 | -- https://plfa.github.io/Confluence/#substitution-lemma-for-parallel-reduction 96 | abbrev par_subst (σ : Subst Γ Δ) (σ' : Subst Γ Δ) := ∀ {a} {x : Γ ∋ a}, σ x ⇛ σ' x 97 | 98 | section 99 | lemma par_rename {ρ : Rename Γ Δ} {m m' : Γ ⊢ a} : (m ⇛ m') → (rename ρ m ⇛ rename ρ m') 100 | := open PReduce in by intro 101 | | .var => exact .var 102 | | .lamζ rn => apply lamζ; apply par_rename; trivial 103 | | .apξ rl rm => apply apξ <;> (apply par_rename; trivial) 104 | | .lamβ rn rv => 105 | rename_i n n' v v'; have rn' := par_rename (ρ := ext ρ) rn; have rv' := par_rename (ρ := ρ) rv 106 | have := lamβ rn' rv'; rwa [rename_subst_comm] at this 107 | 108 | theorem par_subst_exts {σ τ : Subst Γ Δ} (s : par_subst σ τ) 109 | : ∀ {b}, par_subst (exts (b := b) σ) (exts τ) 110 | := by 111 | intro _ _; intro 112 | | .z => exact .var 113 | | .s i => exact par_rename s 114 | 115 | theorem subst_par {σ τ : Subst Γ Δ} {m m' : Γ ⊢ a} 116 | (s : par_subst σ τ) (p : m ⇛ m') : (⟪σ⟫ m ⇛ ⟪τ⟫ m') 117 | := open PReduce in by 118 | match p with 119 | | .var => exact s 120 | | .lamβ pn pv => rw [←subst_comm]; apply_rules [lamβ, subst_par, par_subst_exts] 121 | | .lamζ pn => apply_rules [lamζ, subst_par, par_subst_exts] 122 | | .apξ pl pm => apply_rules [apξ, subst_par] 123 | 124 | variable {n n' : Γ‚ a ⊢ b} {m m': Γ ⊢ a} 125 | 126 | theorem par_subst₁σ (p : m ⇛ m') : par_subst (subst₁σ m) (subst₁σ m') := by 127 | intro _ i; cases i with simp only [subst₁σ] 128 | | z => exact p 129 | | s i => exact .var 130 | 131 | theorem sub_par (pn : n ⇛ n') (pm : m ⇛ m') : n⟦m⟧ ⇛ n'⟦m'⟧ := 132 | subst_par (par_subst₁σ pm) pn 133 | end 134 | 135 | -- https://plfa.github.io/Confluence/#parallel-reduction-satisfies-the-diamond-property 136 | /-- 137 | Many parallel reductions at once. 138 | -/ 139 | abbrev PReduce.plus : (Γ ⊢ a) → (Γ ⊢ a) 140 | | ` i => ` i 141 | | ƛ n => ƛ (plus n) 142 | | (ƛ n) □ m => plus n⟦plus m⟧ 143 | | l □ m => plus l □ plus m 144 | 145 | namespace Notation 146 | postfix:max "⁺" => PReduce.plus 147 | end Notation 148 | 149 | theorem par_triangle {m n : Γ ⊢ a} : (m ⇛ n) → (n ⇛ m⁺) := open PReduce in by 150 | intro 151 | | .var => exact .var 152 | | .lamβ pn pv => exact subst_par (par_subst₁σ (par_triangle pv)) (par_triangle pn) 153 | | .lamζ pn => exact lamζ (par_triangle pn) 154 | | .apξ pl pm => rename_i l l' m m'; match l with 155 | | ` _ => exact apξ (par_triangle pl) (par_triangle pm) 156 | | _ □ _ => exact apξ (par_triangle pl) (par_triangle pm) 157 | | ƛ _ => have .lamζ pl := pl; exact lamβ (par_triangle pl) (par_triangle pm) 158 | 159 | theorem par_diamond {m n n' : Γ ⊢ a} (p : m ⇛ n) (p' : m ⇛ n') 160 | : ∃ (l : Γ ⊢ a), (n ⇛ l) ∧ (n' ⇛ l) 161 | := by 162 | exists m⁺; constructor <;> (apply par_triangle; trivial) 163 | 164 | -- https://plfa.github.io/Confluence/#proof-of-confluence-for-parallel-reduction 165 | theorem strip {m n n' : Γ ⊢ a} (mn : m ⇛ n) (mn' : m ⇛* n') 166 | : ∃ (l : Γ ⊢ a), (n ⇛* l) ∧ (n' ⇛ l) 167 | := by induction mn' using head_induction_on generalizing n with 168 | | refl => exists n, .refl 169 | | head mm' _ r => 170 | rename_i m' f; have ⟨l, hl⟩ := r (par_triangle mm') 171 | exists l; refine ⟨?_, hl.2⟩; exact .trans (par_triangle mn) hl.1 172 | 173 | theorem par_confluence {l m m' : Γ ⊢ a} (lm : l ⇛* m) (lm' : l ⇛* m') 174 | : ∃ (n : Γ ⊢ a), (m ⇛* n) ∧ (m' ⇛* n) 175 | := by induction lm using head_induction_on generalizing m' with 176 | | refl => exists m', lm' 177 | | head lm₁ _ r => 178 | have ⟨n, m₁n, m'n⟩ := strip lm₁ lm' 179 | have ⟨n', mn', nn'⟩ := r m₁n 180 | exists n', mn'; exact .trans m'n nn' 181 | 182 | -- https://plfa.github.io/Confluence/#proof-of-confluence-for-reduction 183 | theorem confluence {l m m' : Γ ⊢ a} (lm : l —↠ m) (lm' : l —↠ m') 184 | : ∃ (n : Γ ⊢ a), (m —↠ n) ∧ (m' —↠ n) 185 | := by 186 | let equiv := @instNonemptyPReduceReduceClos Γ a 187 | have ⟨n, mn, m'n⟩:= par_confluence (equiv.invFun lm) (equiv.invFun lm') 188 | exists n; exact ⟨equiv.toFun mn, equiv.toFun m'n⟩ 189 | -------------------------------------------------------------------------------- /Plfl/Untyped/Denotational.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Denotational/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped 5 | import Plfl.Untyped.Substitution 6 | 7 | namespace Denotational 8 | 9 | -- https://plfa.github.io/Denotational/#values 10 | inductive Value : Type where 11 | /-- No information is provided about the computation. -/ 12 | | bot : Value 13 | /-- A single input-output mapping, from the first term to the second. -/ 14 | | fn : Value → Value → Value 15 | /-- A function that maps inputs to outputs according to both terms. -/ 16 | | conj : Value → Value → Value 17 | deriving BEq, DecidableEq, Repr 18 | 19 | namespace Value 20 | instance instBot : Bot Value where bot := .bot 21 | instance instSup : Sup Value where sup := .conj 22 | end Value 23 | 24 | namespace Notation 25 | scoped infixr:70 " ⇾ " => Value.fn 26 | end Notation 27 | 28 | open Notation 29 | 30 | /-- `Sub` adapts the familiar notion of subset to the `Value` type. -/ 31 | inductive Sub : Value → Value → Prop where 32 | | bot : Sub ⊥ v 33 | | conjL : Sub v u → Sub w u → Sub (v ⊔ w) u 34 | | conjR₁ : Sub u v → Sub u (v ⊔ w) 35 | | conjR₂ : Sub u w → Sub u (v ⊔ w) 36 | | trans : Sub u v → Sub v w → Sub u w 37 | | fn : Sub v' v → Sub w w' → Sub (v ⇾ w) (v' ⇾ w') 38 | | dist : Sub (v ⇾ (w ⊔ w')) ((v ⇾ w) ⊔ (v ⇾ w')) 39 | 40 | namespace Notation 41 | scoped infix:40 " ⊑ " => Sub 42 | end Notation 43 | 44 | instance : Trans Sub Sub Sub where trans := .trans 45 | 46 | @[refl] 47 | def Sub.refl : v ⊑ v := match v with 48 | | ⊥ => .bot 49 | | _ ⇾ _ => .fn refl refl 50 | | .conj _ _ => .conjL (.conjR₁ refl) (.conjR₂ refl) 51 | 52 | def sub_of_sub_bot (d : v ⊑ ⊥) : v ⊑ u := d.trans .bot 53 | 54 | /-- The `⊔` operation is monotonic with respect to `⊑`. -/ 55 | def conj_sub_conj (d₁ : v ⊑ v') (d₂ : w ⊑ w') : v ⊔ w ⊑ v' ⊔ w' := 56 | .conjL (.conjR₁ d₁) (.conjR₂ d₂) 57 | 58 | def fn_conj_sub_conj_fn : (v ⊔ v') ⇾ (w ⊔ w') ⊑ (v ⇾ w) ⊔ (v' ⇾ w') := calc 59 | _ ⊑ ((v ⊔ v') ⇾ w) ⊔ ((v ⊔ v') ⇾ w') := .dist 60 | _ ⊑ (v ⇾ w) ⊔ (v' ⇾ w') := open Sub in by 61 | apply conj_sub_conj <;> refine .fn ?_ .refl 62 | · apply conjR₁; rfl 63 | · apply conjR₂; rfl 64 | 65 | -- https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/Termination.20of.20head.20induction.20on.20.60ReflTransGen.60/near/375468050 66 | def conj_sub₁ (h : u ⊔ v ⊑ w) : u ⊑ w := by 67 | generalize hx : u ⊔ v = x at * 68 | induction h with (subst_vars; try cases hx) 69 | | conjL h _ => exact h 70 | | conjR₁ h ih => exact .conjR₁ (ih rfl) 71 | | conjR₂ h ih => exact .conjR₂ (ih rfl) 72 | | trans h h' ih => exact .trans (ih rfl) h' 73 | 74 | def conj_sub₂ (h : u ⊔ v ⊑ w) : v ⊑ w := by 75 | generalize hx : u ⊔ v = x at * 76 | induction h with (subst_vars; try cases hx) 77 | | conjL _ h => exact h 78 | | conjR₁ h ih => exact .conjR₁ (ih rfl) 79 | | conjR₂ h ih => exact .conjR₂ (ih rfl) 80 | | trans h h' ih => exact .trans (ih rfl) h' 81 | 82 | open Untyped (Context) 83 | open Untyped.Notation 84 | 85 | -- https://plfa.github.io/Denotational/#environments 86 | /-- 87 | An `Env` gives meaning to a term's free vars by mapping vars to values. 88 | -/ 89 | abbrev Env (Γ : Context) : Type := ∀ (_ : Γ ∋ ✶), Value 90 | 91 | namespace Env 92 | instance : EmptyCollection (Env ∅) where emptyCollection := nofun 93 | 94 | abbrev snoc (γ : Env Γ) (v : Value) : Env (Γ‚ ✶) 95 | | .z => v 96 | | .s i => γ i 97 | end Env 98 | 99 | namespace Notation 100 | scoped notation "`∅" => (∅ : Env ∅) 101 | 102 | -- `‚` is not a comma! See: 103 | scoped infixl:50 "`‚ " => Env.snoc 104 | end Notation 105 | 106 | namespace Env 107 | -- * I could have used Lisp jargons `cdr` and `car` here, 108 | -- * instead of the Haskell ones below... 109 | abbrev init (γ : Env (Γ‚ ✶)) : Env Γ := (γ ·.s) 110 | abbrev last (γ : Env (Γ‚ ✶)) : Value := γ .z 111 | 112 | theorem init_last (γ : Env (Γ‚ ✶)) : γ = (γ.init`‚ γ.last) := by 113 | ext x; cases x <;> rfl 114 | 115 | /-- We extend the `⊑` relation point-wise to `Env`s. -/ 116 | def Sub (γ δ : Env Γ) : Prop := ∀ (x : Γ ∋ ✶), γ x ⊑ δ x 117 | abbrev conj (γ δ : Env Γ) : Env Γ | x => γ x ⊔ δ x 118 | end Env 119 | 120 | namespace Notation 121 | instance : Bot (Env Γ) where bot _ := ⊥ 122 | instance : Sup (Env γ) where sup := Env.conj 123 | 124 | scoped infix:40 " `⊑ " => Env.Sub 125 | end Notation 126 | 127 | namespace Env.Sub 128 | @[refl] def refl : γ `⊑ γ | _ => .refl 129 | @[simp] def conjR₁ (γ δ : Env Γ) : γ `⊑ (γ ⊔ δ) | _ => .conjR₁ .refl 130 | @[simp] def conjR₂ (γ δ : Env Γ) : δ `⊑ (γ ⊔ δ) | _ => .conjR₂ .refl 131 | 132 | def ext_le (lt : v ⊑ v') : (γ`‚ v) `⊑ (γ`‚ v') 133 | | .z => lt 134 | | .s _ => .refl 135 | 136 | def le_ext (lt : γ `⊑ γ') : (γ`‚ v) `⊑ (γ'`‚ v) 137 | | .z => .refl 138 | | .s _ => by apply lt 139 | end Env.Sub 140 | 141 | -- https://plfa.github.io/Denotational/#denotational-semantics 142 | /-- 143 | `Eval γ m v` means that evaluating the term `m` in the environment `γ` gives `v`. 144 | -/ 145 | inductive Eval : Env Γ → (Γ ⊢ ✶) → Value → Prop where 146 | | var : Eval γ (` i) (γ i) 147 | | ap : Eval γ l (v ⇾ w) → Eval γ m v → Eval γ (l □ m) w 148 | | fn {v w} : Eval (γ`‚ v) n w → Eval γ (ƛ n) (v ⇾ w) 149 | | bot : Eval γ m ⊥ 150 | | conj : Eval γ m v → Eval γ m w → Eval γ m (v ⊔ w) 151 | | sub : Eval γ m v → w ⊑ v → Eval γ m w 152 | 153 | namespace Notation 154 | scoped notation:30 γ " ⊢ " m " ￬ " v:51 => Eval γ m v 155 | end Notation 156 | 157 | /-- 158 | Relaxation of table lookup in application, 159 | allowing an argument to match an input entry if the latter is less than the former. 160 | -/ 161 | def Eval.ap_sub (d : γ ⊢ l ￬ v ⇾ w) (d' : γ ⊢ m ￬ v') (lt : v ⊑ v') : γ ⊢ l □ m ￬ w 162 | := d.ap <| d'.sub lt 163 | 164 | namespace Example 165 | open Untyped.Term (id delta omega twoC addC) 166 | open Eval 167 | 168 | -- `id` can be seen as a mapping table for both `⊥ ⇾ ⊥` and `(⊥ ⇾ ⊥) ⇾ (⊥ ⇾ ⊥)`. 169 | def denot_id₁ : γ ⊢ id ￬ ⊥ ⇾ ⊥ := .fn .var 170 | def denot_id₂ : γ ⊢ id ￬ (⊥ ⇾ ⊥) ⇾ (⊥ ⇾ ⊥) := .fn .var 171 | 172 | -- `id` also produces a table containing both of the previous tables. 173 | def denot_id₃ : γ ⊢ id ￬ (⊥ ⇾ ⊥) ⊔ ((⊥ ⇾ ⊥) ⇾ (⊥ ⇾ ⊥)) := denot_id₁.conj denot_id₂ 174 | 175 | -- Oops, self application! 176 | def denot_id_ap_id : `∅ ⊢ id □ id ￬ v ⇾ v := .ap (.fn .var) (.fn .var) 177 | 178 | -- In `def twoC f u := f (f u)`, 179 | -- `f`'s table must include two entries, both `u ⇾ v` and `v ⇾ w`. 180 | -- `twoC` then merges those two entries into one: `u ⇾ w`. 181 | def denot_twoC : `∅ ⊢ twoC ￬ (u ⇾ v ⊔ v ⇾ w) ⇾ u ⇾ w := by 182 | apply fn; apply fn; apply ap 183 | · apply sub .var; exact .conjR₂ .refl 184 | · apply ap 185 | · apply sub .var; exact .conjR₁ .refl 186 | · exact .var 187 | 188 | def denot_delta : `∅ ⊢ delta ￬ (v ⇾ w ⊔ v) ⇾ w := by 189 | apply fn; apply ap (v := v) <;> apply sub .var 190 | · exact .conjR₁ .refl 191 | · exact .conjR₂ .refl 192 | 193 | example : `∅ ⊢ omega ￬ ⊥ := by 194 | apply ap denot_delta; apply conj 195 | · exact fn (v := ⊥) .bot 196 | · exact .bot 197 | 198 | def denot_omega : `∅ ⊢ omega ￬ ⊥ := .bot 199 | 200 | -- https://plfa.github.io/Denotational/#exercise-denot-plus%E1%B6%9C-practice 201 | 202 | /- 203 | For `def addC m n u v := (m u) (n u v)` we have the following mapping table: 204 | · n u v = w 205 | · m u w = x 206 | -/ 207 | def denot_addC 208 | : let m := u ⇾ w ⇾ x 209 | let n := u ⇾ v ⇾ w 210 | `∅ ⊢ addC ￬ m ⇾ n ⇾ u ⇾ v ⇾ x 211 | := by apply_rules [fn, ap, var] 212 | end Example 213 | 214 | -- https://plfa.github.io/Denotational/#denotations-and-denotational-equality 215 | /-- 216 | A denotational semantics can be seen as a function from a term 217 | to some relation between `Env`s and `Value`s. 218 | -/ 219 | abbrev Denot (Γ : Context) : Type := Env Γ → Value → Prop 220 | 221 | /-- 222 | `ℰ m` is the instance of `Denot` that corresponds to the `Eval` of `m`. 223 | -/ 224 | abbrev ℰ : (Γ ⊢ ✶) → Denot Γ | m, γ, v => γ ⊢ m ￬ v 225 | 226 | -- Denotational Equality 227 | 228 | -- Nothing to do thanks to proof irrelevance. 229 | -- Instead of defining a new `≃` operator to denote the equivalence of `Denot`s, 230 | -- the regular `=` should be enough in our case. 231 | 232 | section 233 | open Untyped.Subst 234 | open Substitution 235 | open Eval 236 | 237 | -- https://plfa.github.io/Denotational/#renaming-preserves-denotations 238 | variable {γ : Env Γ} {δ : Env Δ} 239 | 240 | def ext_sub (ρ : Rename Γ Δ) (lt : γ `⊑ δ ∘ ρ) 241 | : (γ`‚ v) `⊑ (δ`‚ v) ∘ ext ρ 242 | | .z => .refl 243 | | .s i => lt i 244 | 245 | def ext_sub' (ρ : Rename Γ Δ) (lt : δ ∘ ρ `⊑ γ) 246 | : (δ`‚ v) ∘ ext ρ `⊑ (γ`‚ v) 247 | | .z => .refl 248 | | .s i => lt i 249 | 250 | /-- The result of evaluation is conserved after renaming. -/ 251 | def rename_pres (ρ : Rename Γ Δ) (lt : γ `⊑ δ ∘ ρ) (d : γ ⊢ m ￬ v) 252 | : δ ⊢ rename ρ m ￬ v 253 | := by induction d generalizing Δ with 254 | | var => apply sub .var; apply lt 255 | | ap _ _ r r' => exact .ap (r ρ lt) (r' ρ lt) 256 | | fn _ r => apply fn; rename_i v _ _ _; exact r (ext ρ) (ext_sub ρ lt) 257 | | bot => exact .bot 258 | | conj _ _ r r' => exact .conj (r ρ lt) (r' ρ lt) 259 | | sub _ lt' r => exact (r ρ lt).sub lt' 260 | 261 | -- https://plfa.github.io/Denotational/#environment-strengthening-and-identity-renaming 262 | 263 | variable {γ δ : Env Γ} 264 | 265 | /-- The result of evaluation is conserved under a superset. -/ 266 | def sub_env (d : γ ⊢ m ￬ v) (lt : γ `⊑ δ) : δ ⊢ m ￬ v := by 267 | convert rename_pres id lt d; exact rename_id.symm 268 | 269 | lemma up_env (d : (γ`‚ u) ⊢ m ￬ v) (lt : u ⊑ u') : (γ`‚ u') ⊢ m ￬ v := by 270 | apply sub_env d; exact Env.Sub.ext_le lt 271 | end 272 | 273 | -- https://plfa.github.io/Denotational/#exercise-denot-church-recommended 274 | /-- 275 | A path consists of `n` edges (`⇾`s) and `n + 1` vertices (`Value`s). 276 | -/ 277 | def Value.path : (n : ℕ) → Vector Value (n + 1) → Value 278 | | 0, _ => ⊥ 279 | | i + 1, vs => path i vs.dropLast ⊔ vs.get i ⇾ vs.get (i + 1) 280 | 281 | /-- 282 | Returns the denotation of the nth Church numeral for a given path. 283 | -/ 284 | def Value.church (n : ℕ) (vs : Vector Value (n + 1)) : Value := 285 | path n vs ⇾ vs.get 0 ⇾ vs.get n 286 | 287 | namespace Example 288 | example : Value.church 0 ⟨[u], rfl⟩ = (⊥ ⇾ u ⇾ u) := rfl 289 | example : Value.church 1 ⟨[u, v], rfl⟩ = ((⊥ ⊔ u ⇾ v) ⇾ u ⇾ v) := rfl 290 | example : Value.church 2 ⟨[u, v, w], rfl⟩ = ((⊥ ⊔ u ⇾ v ⊔ v ⇾ w) ⇾ u ⇾ w) := rfl 291 | end Example 292 | 293 | section 294 | open Untyped.Term (church) 295 | open Eval 296 | open Env.Sub 297 | 298 | def denot_church {vs} : `∅ ⊢ church n ￬ Value.church n vs := by 299 | apply_rules [fn]; induction n with 300 | | zero => let ⟨_ :: [], _⟩ := vs; exact var 301 | | succ n r => 302 | unfold church.applyN; apply ap 303 | · apply sub var; simp only [Env.snoc, Value.path]; convert Sub.refl.conjR₂ 304 | rw [←Fin.instAddMonoidWithOne.proof_2] 305 | · convert sub_env (@r vs.dropLast) ?_ using 1 306 | · simp only [vs.get_dropLast n, Fin.coe_ofNat_eq_mod] 307 | congr; simp_arith [Nat.mod_eq_of_lt] 308 | · simp only [vs.get_dropLast 0, Fin.coe_ofNat_eq_mod] 309 | apply_rules [le_ext, ext_le]; exact .conjR₁ .refl 310 | end 311 | 312 | -- https://plfa.github.io/Denotational/#inversion-of-the-less-than-relation-for-functions 313 | def Value.Elem (u v : Value) : Prop := match v with 314 | | .conj v w => u.Elem v ∨ u.Elem w 315 | | v => u = v 316 | 317 | instance Value.membership : Membership Value Value where mem := Value.Elem 318 | 319 | namespace Value 320 | def Included (v w : Value) : Prop := ∀ {u}, u ∈ v → u ∈ w 321 | 322 | instance instTrans : Trans Included Included Included where trans := flip (· ∘ ·) 323 | instance : HasSubset Value where Subset := Included 324 | instance : Trans Included Subset Included where trans := instTrans.trans 325 | instance : Trans Subset Subset Included where trans := instTrans.trans 326 | 327 | variable {u v w : Value} 328 | def Included.fst (s : Included (u ⊔ v) w) : u ⊆ w := s ∘ .inl 329 | def Included.snd (s : Included (u ⊔ v) w) : v ⊆ w := s ∘ .inr 330 | end Value 331 | 332 | theorem sub_of_elem (e : u ∈ v) : u ⊑ v := by induction v with cases e 333 | | bot => exact .bot 334 | | fn => rfl 335 | | conj _ _ ih ih' => 336 | all_goals (rename_i h; first | exact (ih h).conjR₁ | exact (ih' h).conjR₂) 337 | 338 | theorem sub_of_included (s : u ⊆ v) : u ⊑ v := by induction u with 339 | | bot => exact .bot 340 | | fn => apply sub_of_elem; apply s; rfl 341 | | conj _ _ ih ih' => 342 | apply Sub.conjL 343 | · apply ih; intro _ e; apply s; left; exact e 344 | · apply ih'; intro _ e; apply s; right; exact e 345 | 346 | theorem conj_included_inv {u v w : Value} (s : u ⊔ v ⊆ w) : u ⊆ w ∧ v ⊆ w := by 347 | constructor <;> (intro _ _; apply s; first | left; trivial | right; trivial) 348 | 349 | lemma fn_elem (i : v ⇾ w ⊆ u) : v ⇾ w ∈ u := i rfl 350 | 351 | -- https://plfa.github.io/Denotational/#function-values 352 | /-- `IsFn u` means that `u` is a function value. -/ 353 | inductive IsFn (u : Value) : Prop where | isFn (h : u = v ⇾ w) 354 | 355 | /-- `AllFn v` means that all elements of `v` are function values. -/ 356 | def AllFn (v : Value) : Prop := ∀ {u}, u ∈ v → IsFn u 357 | 358 | namespace AllFn 359 | def fst (f : AllFn (u ⊔ v)) : AllFn u := f ∘ .inl 360 | def snd (f : AllFn (u ⊔ v)) : AllFn v := f ∘ .inr 361 | end AllFn 362 | 363 | lemma not_isFn_bot : ¬ IsFn ⊥ := nofun 364 | 365 | lemma elem_of_allFn (f : AllFn u) : ∃ v w, v ⇾ w ∈ u := by induction u with 366 | | bot => exact (not_isFn_bot <| f rfl).elim 367 | | fn v w => exists v, w 368 | | conj v w ih _ => 369 | -- In fact, the proof is also possible on the `.snd` side. 370 | -- There is some information loss in this step. 371 | have ⟨v, w, i⟩ := ih f.fst; exists v, w; left; exact i 372 | 373 | -- https://plfa.github.io/Denotational/#domains-and-codomains 374 | /-- Given a set `u` of functions, `u.conjDom` returns the join of their domains. -/ 375 | def Value.conjDom : Value → Value 376 | | ⊥ => ⊥ 377 | | v ⇾ _ => v 378 | | .conj u v => u.conjDom ⊔ v.conjDom 379 | 380 | /-- Given a set `u` of functions, `u.conjCodom` returns the join of their codomains. -/ 381 | def Value.conjCodom : Value → Value 382 | | ⊥ => ⊥ 383 | | _ ⇾ w => w 384 | | .conj u v => u.conjCodom ⊔ v.conjCodom 385 | 386 | /-- Given an element `v ⇾ w` of a set of functions `u`, we know that `v` is in `u.conjDom`. -/ 387 | theorem included_conjDom (f : AllFn u) (i : v ⇾ w ∈ u) : v ⊆ u.conjDom := by induction u with 388 | | bot => cases i 389 | | fn => cases i; exact id 390 | | conj u u' ih ih' => match i with 391 | | .inl h => calc v 392 | _ ⊆ u.conjDom := ih f.fst h 393 | _ ⊆ (u ⊔ u').conjDom := .inl 394 | | .inr h => calc v 395 | _ ⊆ u'.conjDom := ih' f.snd h 396 | _ ⊆ (u ⊔ u').conjDom := .inr 397 | 398 | /-- Given a set `u` of identical terms `v ⇾ w`, we know that `u.conjCodom` is included in `w`. -/ 399 | theorem conjCodom_included (s : u ⊆ v ⇾ w) : u.conjCodom ⊆ w := by induction u with 400 | | bot => cases s rfl 401 | | fn => cases s rfl; exact id 402 | | conj _ _ ih ih' => intro x; intro 403 | | .inl i => exact ih s.fst i 404 | | .inr i => exact ih' s.snd i 405 | 406 | /-- 407 | We say that `v ⇾ w` factors `u` into `u`, if: 408 | - `u'` contains only functions; 409 | - `u` is included in `u`; 410 | - `u'`'s domain is less than `v`; 411 | - `u'`'s codomain is greater than `w`. 412 | -/ 413 | def Factor (u u' v w : Value) : Prop := 414 | AllFn u' 415 | ∧ u' ⊆ u 416 | ∧ u'.conjDom ⊑ v 417 | ∧ w ⊑ u'.conjCodom 418 | 419 | -- https://plfa.github.io/Denotational/#inversion-of-less-than-for-functions 420 | theorem sub_inv (lt : u ⊑ u') {v w} (i : v ⇾ w ∈ u) : ∃ u'', Factor u' u'' v w := 421 | by induction lt generalizing v w with 422 | | bot => cases i 423 | | conjL _ _ ih ih' => exact i.elim ih ih' 424 | | conjR₁ _ ih => have ⟨u'', f, s, ss⟩ := ih i; exists u'', f, .inl ∘ s 425 | | conjR₂ _ ih => have ⟨u'', f, s, ss⟩ := ih i; exists u'', f, .inr ∘ s 426 | | fn lt lt' => cases i; rename_i v v' w' w _ _; exists v ⇾ w, .isFn, id 427 | | dist => 428 | cases i; rename_i v w w'; exists v ⇾ w ⊔ v ⇾ w' 429 | refine ⟨(Or.elim · .isFn .isFn), id, ?_, .refl⟩; exact .conjL .refl .refl 430 | | trans _ _ ih ih' => 431 | rename_i u' v' w'; have ⟨u'', f, s, ss⟩ := ih i; have ⟨u'', f, s, ss'⟩ := trans f s ih' 432 | exists u'', f, s; exact ⟨ss'.1.trans ss.1, ss.2.trans ss'.2⟩ 433 | where 434 | -- https://plfa.github.io/Denotational/#inversion-of-less-than-for-functions-the-case-for--trans 435 | trans {u u₁ u₂} (f : AllFn u₁) (s : u₁ ⊆ u) (ih : ∀ {v w}, v ⇾ w ∈ u → ∃ u₃, Factor u₂ u₃ v w) 436 | : ∃ u₃, Factor u₂ u₃ u₁.conjDom u₁.conjCodom 437 | := by induction u₁ with 438 | | bot => exfalso; apply not_isFn_bot; exact f rfl 439 | | fn => apply ih; apply fn_elem; exact s 440 | | conj _ _ ih ih' => 441 | have ⟨s, s'⟩ := conj_included_inv s 442 | have ⟨u₃, f₃, s, ss⟩ := ih f.fst s; have ⟨u₃', f₃', s', ss'⟩ := ih' f.snd s' 443 | exists u₃ ⊔ u₃', (Or.elim · f₃ f₃'), (Or.elim · s s') 444 | exact ⟨conj_sub_conj ss.1 ss'.1, conj_sub_conj ss.2 ss'.2⟩ 445 | 446 | lemma sub_inv_fn (lt : v ⇾ w ⊑ u) 447 | : ∃ u', 448 | AllFn u' 449 | ∧ u' ⊆ u 450 | ∧ (∀ {v' w'}, v' ⇾ w' ∈ u' → v' ⊑ v) 451 | ∧ w ⊑ u'.conjCodom 452 | := by 453 | have ⟨u', f, s, ss⟩ := sub_inv lt rfl; refine ⟨u', f, s, ?_, ss.2⟩ 454 | introv i; refine .trans ?_ ss.1; exact sub_of_included <| included_conjDom f i 455 | 456 | lemma fn_conj_fn_inv (lt : v ⇾ w ⊑ v' ⇾ w') : v' ⊑ v ∧ w ⊑ w' := by 457 | have ⟨_, f, s, ss⟩ := sub_inv_fn lt; have ⟨u, u', i⟩ := elem_of_allFn f 458 | cases s i; exists ss.1 i; apply ss.2.trans; exact sub_of_included <| conjCodom_included s 459 | -------------------------------------------------------------------------------- /Plfl/Untyped/Denotational/Adequacy.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Adequacy/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped.BigStep 5 | import Plfl.Untyped.Denotational.Soundness 6 | 7 | namespace Adequacy 8 | 9 | open Untyped Untyped.Notation 10 | open Untyped.Subst 11 | open BigStep (Clos ClosEnv Eval.reduce_of_cbn) 12 | open BigStep.Notation 13 | open Denotational Denotational.Notation 14 | open Soundness (soundness) 15 | 16 | -- https://plfa.github.io/Adequacy/#the-property-of-being-greater-or-equal-to-a-function 17 | /-- `GtFn u` means that it is "greater than" a certain function value. -/ 18 | def GtFn (u : Value) : Prop := ∃ v w, v ⇾ w ⊑ u 19 | 20 | /-- If `u` is greater than a function, then an even greater value `u'` is too. -/ 21 | lemma GtFn.sub (gt : GtFn u) (lt : u ⊑ u') : GtFn u' := 22 | let ⟨v, w, lt'⟩ := gt; ⟨v, w, lt'.trans lt⟩ 23 | 24 | /-- `⊥` is never greater than a function. -/ 25 | lemma not_gtFn_bot : ¬ GtFn ⊥ 26 | | ⟨v, w, lt⟩ => by 27 | have ⟨_, f, s, _⟩ := sub_inv_fn lt; have ⟨_, _, i⟩ := elem_of_allFn f; cases s i 28 | 29 | /-- If the join of two values is greater than a function, then at least one of them is too. -/ 30 | lemma GtFn.conj (gt : GtFn (u ⊔ v)) : GtFn u ∨ GtFn v := by 31 | have ⟨_, _, lt⟩ := gt; have ⟨_, f, s, _⟩ := sub_inv_fn lt; have ⟨v, w, i⟩ := elem_of_allFn f 32 | refine Or.imp ?inl ?inr <| s i <;> (intro i'; exists v, w; exact sub_of_elem i') 33 | 34 | /-- If neither of the two values is greater than a function, then nor is their join. -/ 35 | lemma not_gtFn_conj (ngt : ¬ GtFn u) (ngt' : ¬ GtFn v) : ¬ GtFn (u ⊔ v) := by 36 | intro gtuv; exfalso; exact gtuv.conj |>.elim ngt ngt' 37 | 38 | /-- 39 | If the join of two values is not greater than a function, 40 | then neither of them is individually. 41 | -/ 42 | lemma not_gtFn_conj_inv (ngtuv : ¬ GtFn (u ⊔ v)) : ¬ GtFn u ∧ ¬ GtFn v := by 43 | by_contra h; simp_all only [not_and, not_not] 44 | have ngtu := ngtuv ∘ (GtFn.sub · <| .conjR₁ .refl) 45 | have ngtv := ngtuv ∘ (GtFn.sub · <| .conjR₂ .refl) 46 | exact h ngtu |> ngtv 47 | 48 | lemma not_gtFn_conj_iff : (¬ GtFn u ∧ ¬ GtFn v) ↔ ¬ GtFn (u ⊔ v) := 49 | ⟨(λ nn => not_gtFn_conj nn.1 nn.2), not_gtFn_conj_inv⟩ 50 | 51 | instance GtFn.dec {v} : Decidable (GtFn v) := by match v with 52 | | ⊥ => left; exact not_gtFn_bot 53 | | v ⇾ w => right; exists v, w 54 | | .conj u v => cases @dec u with 55 | | isTrue h => right; have ⟨v, w, lt⟩ := h; exists v, w; exact lt.conjR₁ 56 | | isFalse h => cases @dec v with 57 | | isTrue h' => right; have ⟨v, w, lt⟩ := h'; exists v, w; exact lt.conjR₂ 58 | | isFalse h' => left; exact not_gtFn_conj h h' 59 | 60 | -- https://plfa.github.io/Adequacy/#relating-values-to-closures 61 | mutual 62 | /-- 63 | `𝕍 v c` will hold when: 64 | - `c` is in WHNF (i.e. is a λ-abstraction); 65 | - `v` is a function; 66 | - `c`'s body evaluates according to `v`. 67 | -/ 68 | def 𝕍 : Value → Clos → Prop 69 | | _, .clos (` _) _ => ⊥ 70 | | _, .clos (_ □ _) _ => ⊥ 71 | | ⊥, .clos (ƛ _) _ => ⊤ 72 | | vw@(v ⇾ w), .clos (ƛ n) γ => 73 | have : sizeOf w < sizeOf vw := by subst_vars; simp 74 | ∀ {c}, 𝔼 v c → GtFn w → ∃ c', (γ‚' c ⊢ n ⇓ c') ∧ 𝕍 w c' 75 | | uv@(.conj u v), c@(.clos (ƛ _) _) => 76 | have : sizeOf v < sizeOf uv := by subst_vars; simp 77 | 𝕍 u c ∧ 𝕍 v c 78 | 79 | /-- 80 | `𝔼 v c` will hold when: 81 | - `v` is greater than a function value; 82 | - `c` evaluates to a closure `c'` in WHNF; 83 | - `𝕍 v c` holds. 84 | -/ 85 | def 𝔼 (v : Value) : Clos → Prop | .clos m γ' => GtFn v → ∃ c, (γ' ⊢ m ⇓ c) ∧ 𝕍 v c 86 | end 87 | 88 | /-- `𝔾` relates `γ` to `γ'` if the corresponding values and closures are related by `𝔼` -/ 89 | def 𝔾 (γ : Env Γ) (γ' : ClosEnv Γ) : Prop := ∀ {i : Γ ∋ ✶}, 𝔼 (γ i) (γ' i) 90 | 91 | def 𝔾.empty : 𝔾 `∅ ∅ := nofun 92 | 93 | def 𝔾.ext (g : 𝔾 γ γ') (e : 𝔼 v c) : 𝔾 (γ`‚ v) (γ'‚' c) := by unfold 𝔾; intro 94 | | .z => exact e 95 | | .s _ => exact g 96 | 97 | /-- The proof of a term being in Weak-Head Normal Form. -/ 98 | def WHNF (t : Γ ⊢ a) : Prop := ∃ n : Γ‚ ✶ ⊢ ✶, t = (ƛ n) 99 | 100 | /-- A closure in a 𝕍 relation must be in WHNF. -/ 101 | lemma WHNF.of_𝕍 (vc : 𝕍 v (.clos m γ)) : WHNF m := by 102 | cases m with (try simp [𝕍] at vc; try contradiction) | lam n => exists n 103 | 104 | lemma 𝕍.conj (uc : 𝕍 u c) (vc : 𝕍 v c) : 𝕍 (u ⊔ v) c := by 105 | let .clos m γ := c; cases m with (try simp [𝕍] at *; try contradiction) 106 | | lam => unfold 𝕍; exact ⟨uc, vc⟩ 107 | 108 | lemma 𝕍.of_not_gtFn (nf : ¬ GtFn v) : 𝕍 v (.clos (ƛ n) γ') := by induction v with unfold 𝕍 109 | | bot => trivial 110 | | fn v w => exfalso; apply nf; exists v, w 111 | | conj _ _ ih ih' => exact not_gtFn_conj_inv nf |>.imp ih ih' 112 | 113 | lemma 𝕍.sub {v v'} (vvc : 𝕍 v c) (lt : v' ⊑ v) : 𝕍 v' c := by 114 | let .clos m γ := c; cases m with (try simp [𝕍] at *; try contradiction) | lam m => 115 | rename_i Γ; induction lt generalizing Γ with 116 | | bot => trivial 117 | | conjL _ _ ih ih' => unfold 𝕍; exact ⟨ih _ _ _ vvc, ih' _ _ _ vvc⟩ 118 | | conjR₁ _ ih => apply ih; unfold 𝕍 at vvc; exact vvc.1 119 | | conjR₂ _ ih => apply ih; unfold 𝕍 at vvc; exact vvc.2 120 | | trans _ _ ih ih' => apply_rules [ih, ih'] 121 | | @fn v₂ v₁ w₁ w₂ lt lt' ih ih' => 122 | unfold 𝕍 at vvc ⊢; intro _ c evc gtw 123 | have : 𝔼 v₂ c := by 124 | -- HACK: Broken mutual induction with `𝔼.sub` here. 125 | cases c; simp only [𝔼] at *; intro gtv' 126 | have ⟨c, ec, vv₁c⟩ := evc <| gtv'.sub lt; exists c, ec 127 | cases c with | clos m γ => have ⟨m', h'⟩ := WHNF.of_𝕍 vv₁c; subst h'; exact ih _ γ _ vv₁c 128 | have ⟨c', ec', vw₂c'⟩ := vvc this (gtw.sub lt'); exists c', ec' 129 | let .clos _ _ := c'; have ⟨m', h'⟩ := WHNF.of_𝕍 vw₂c'; subst h'; exact ih' _ _ _ vw₂c' 130 | | @dist v₁ w₁ w₂ => 131 | unfold 𝕍 at vvc ⊢; intro _ c ev₁c gt; unfold 𝕍 at vvc 132 | by_cases hgt₁ : GtFn w₁ <;> by_cases hgt₂ : GtFn w₂ 133 | · have ⟨c₁, ec₁, vw₁⟩ := vvc.1 ev₁c hgt₁; have ⟨c₂, ec₂, vw₂⟩ := vvc.2 ev₁c hgt₂ 134 | exists c₁, ec₁; cases c₁; have ⟨m', h'⟩ := WHNF.of_𝕍 vw₁; subst h'; unfold 𝕍 135 | exists vw₁; rwa [←ec₁.determ ec₂] at vw₂ 136 | · have ⟨.clos l γ₁, ec₁, vw₁⟩ := vvc.1 ev₁c hgt₁; exists .clos l γ₁, ec₁ 137 | have ⟨m', h'⟩ := WHNF.of_𝕍 vw₁; subst h'; apply vw₁.conj; exact of_not_gtFn hgt₂ 138 | · have ⟨.clos l γ₂, ec₂, vw₂⟩ := vvc.2 ev₁c hgt₂; exists .clos l γ₂, ec₂ 139 | have ⟨m', h'⟩ := WHNF.of_𝕍 vw₂; subst h'; apply (𝕍.conj · vw₂); exact of_not_gtFn hgt₁ 140 | · cases gt.conj <;> contradiction 141 | 142 | lemma 𝔼.sub (evc : 𝔼 v c) (lt : v' ⊑ v) : 𝔼 v' c := by 143 | let .clos m γ := c; simp only [𝔼] at *; intro gtv' 144 | have ⟨c, ec, vvc⟩ := evc <| gtv'.sub lt; exists c, ec; exact vvc.sub lt 145 | 146 | -- https://plfa.github.io/Adequacy/#programs-with-function-denotation-terminate-via-call-by-name 147 | theorem 𝔼.of_eval {Γ} {γ : Env Γ} {γ' : ClosEnv Γ} {m : Γ ⊢ ✶} (g : 𝔾 γ γ') (d : γ ⊢ m ￬ v) 148 | : 𝔼 v (.clos m γ') 149 | := by 150 | generalize hx : v = x at * 151 | induction d generalizing v with (unfold 𝔼; intro gt) 152 | | @var _ γ i => 153 | unfold 𝔾 𝔼 at g; have := @g i; split at this 154 | have ⟨c, em', vγi⟩ := this gt; refine ⟨c, ?_, vγi⟩; apply em'.var; trivial 155 | | @ap _ _ _ _ _ m _ _ ih ih' => 156 | unfold 𝔼 at ih; have ⟨.clos l' δ, e_cl', v_cl'⟩ := ih g rfl ⟨_, _, .refl⟩ 157 | have ⟨m', h'⟩ := WHNF.of_𝕍 v_cl'; subst h'; unfold 𝕍 at v_cl' 158 | have ⟨c', em'c', v_c'⟩ := @v_cl' (.clos m γ') (ih' g rfl) gt; exact ⟨c', e_cl'.ap em'c', v_c'⟩ 159 | | @fn _ _ n _ _ _ ih => 160 | unfold 𝔼 at ih; exists .clos (ƛ n) γ', .lam; unfold 𝕍; intro _ c ev₁c; exact ih (g.ext ev₁c) rfl 161 | | bot => subst_vars; exfalso; exact not_gtFn_bot gt 162 | | sub _ lt ih => 163 | unfold 𝔼 at ih; have ⟨c, e_c, v_c⟩ := ih g rfl <| gt.sub lt; exact ⟨c, e_c, v_c.sub lt⟩ 164 | | @conj _ _ _ w w' _ _ ih ih' => 165 | by_cases hgt : GtFn w <;> by_cases hgt' : GtFn w' 166 | · unfold 𝔼 at ih ih'; have ⟨c, e_c, vwc⟩ := ih g rfl hgt; exists c, e_c 167 | have ⟨_, e_c', vw'c⟩ := ih' g rfl hgt'; rw [←e_c.determ e_c'] at vw'c; exact vwc.conj vw'c 168 | · unfold 𝔼 at ih; have ⟨.clos l γ, e_cl, vw⟩ := ih g rfl hgt; exists .clos l γ, e_cl 169 | have ⟨m', h'⟩ := WHNF.of_𝕍 vw; subst h'; apply vw.conj; exact 𝕍.of_not_gtFn hgt' 170 | · unfold 𝔼 at ih'; have ⟨.clos l' γ', e_cl', vw'⟩ := ih' g rfl hgt'; exists .clos l' γ', e_cl' 171 | have ⟨m', h'⟩ := WHNF.of_𝕍 vw'; subst h'; apply (𝕍.conj · vw'); exact 𝕍.of_not_gtFn hgt 172 | · cases gt.conj <;> contradiction 173 | 174 | section 175 | variable {m : ∅ ⊢ ✶} {n : ∅‚ ✶ ⊢ ✶} 176 | 177 | -- https://plfa.github.io/Adequacy/#proof-of-denotational-adequacy 178 | theorem Eval.to_big_step (he : ℰ m = ℰ (ƛ n)) 179 | : ∃ (Γ : Context) (n' : Γ‚ ✶ ⊢ ✶) (γ : ClosEnv Γ), ClosEnv.empty ⊢ m ⇓ .clos (ƛ n') γ 180 | := by 181 | have : ℰ (ƛ n) ∅ (⊥ ⇾ ⊥) := by apply_rules [Eval.fn, Eval.bot] 182 | rw [←he] at this; have := 𝔼.of_eval 𝔾.empty this; unfold 𝔼 at this 183 | have ⟨.clos _ γ, emc, v_cl⟩ := this ⟨_, _, .refl⟩ 184 | have ⟨m', h'⟩ := WHNF.of_𝕍 v_cl; subst h'; exists _, m', γ 185 | 186 | theorem adequacy (he : ℰ m = ℰ (ƛ n)) : ∃ n', m —↠ ƛ n' := by 187 | have ⟨_, _, _, e⟩ := Eval.to_big_step he; exact e.reduce_of_cbn 188 | 189 | -- https://plfa.github.io/Adequacy/#call-by-name-is-equivalent-to-beta-reduction 190 | /-- 191 | If the program can be reduced to a λ-abstraction via β-rules, 192 | then call-by-name can produce a value. 193 | -/ 194 | theorem Eval.reduce_to_cbn (rs : m —↠ ƛ n) 195 | : ∃ (Δ : Context) (n' : Δ‚ ✶ ⊢ ✶) (δ : ClosEnv Δ), ClosEnv.empty ⊢ m ⇓ .clos (ƛ n') δ 196 | := soundness rs |> to_big_step 197 | end 198 | 199 | theorem Eval.reduce_iff_cbn {m : ∅ ⊢ ✶} 200 | : ∃ (n : ∅‚ ✶ ⊢ ✶), m —↠ ƛ n 201 | ↔ ∃ (Δ : Context) (n' : Δ‚ ✶ ⊢ ✶) (δ : ClosEnv Δ), ClosEnv.empty ⊢ m ⇓ .clos (ƛ n') δ 202 | := by 203 | constructor 204 | · intro ⟨_, r⟩; exact reduce_to_cbn r 205 | · intro ⟨_, _, _, e⟩; exact Eval.reduce_of_cbn e 206 | -------------------------------------------------------------------------------- /Plfl/Untyped/Denotational/Compositional.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Compositional/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped.Denotational 5 | 6 | namespace Compositional 7 | 8 | open Untyped.Notation 9 | open Denotational Denotational.Notation 10 | 11 | -- https://plfa.github.io/Compositional/#equation-for-lambda-abstraction 12 | def ℱ (d : Denot (Γ‚ ✶)) : Denot Γ 13 | | _, ⊥ => ⊤ 14 | | γ, v ⇾ w => d (γ`‚ v) w 15 | | γ, .conj u v => ℱ d γ u ∧ ℱ d γ v 16 | 17 | lemma sub_ℱ (d : ℱ (ℰ n) γ v) (lt : u ⊑ v) : ℱ (ℰ n) γ u := by induction lt with 18 | | bot => trivial 19 | | conjL _ _ ih ih' => exact ⟨ih d, ih' d⟩ 20 | | conjR₁ _ ih => exact ih d.1 21 | | conjR₂ _ ih => exact ih d.2 22 | | trans _ _ ih ih' => exact ih (ih' d); 23 | | fn lt lt' => exact .sub (up_env d lt) lt' 24 | | dist => exact .conj d.1 d.2 25 | 26 | lemma ℱ_ℰ (d : ℰ (ƛ n) γ v) : ℱ (ℰ n) γ v := by 27 | generalize hx : (ƛ n) = x at * 28 | induction d with try injection hx 29 | | fn d => subst_vars; exact d 30 | | bot => trivial 31 | | conj _ _ ih ih' => exact ⟨ih hx, ih' hx⟩ 32 | | sub _ lt ih => exact sub_ℱ (ih hx) lt 33 | 34 | theorem lam_inv (d : γ ⊢ ƛ n ￬ v ⇾ v') : (γ`‚ v) ⊢ n ￬ v' := ℱ_ℰ d 35 | 36 | lemma ℰ_lam (d : ℱ (ℰ n) γ v) : ℰ (ƛ n) γ v := match v with 37 | | .bot => .bot 38 | | .fn _ _ => .fn d 39 | | .conj _ _ => (ℰ_lam d.1).conj (ℰ_lam d.2) 40 | 41 | theorem lam_equiv : ℰ (ƛ n) = ℱ (ℰ n) := by ext; exact ⟨ℱ_ℰ, ℰ_lam⟩ 42 | 43 | -- https://plfa.github.io/Compositional/#equation-for-function-application 44 | abbrev 𝒜 (d d' : Denot Γ) : Denot Γ | γ, w => (w ⊑ ⊥) ∨ (∃ v, d γ (v ⇾ w) ∧ d' γ v) 45 | 46 | namespace Notation 47 | scoped infixl:70 " ● " => 𝒜 48 | end Notation 49 | 50 | open Notation 51 | 52 | lemma 𝒜_ℰ (d : ℰ (l □ m) γ v) : (ℰ l ● ℰ m) γ v := by 53 | generalize hx : l □ m = x at * 54 | induction d with try injection hx 55 | | bot => left; rfl 56 | | ap d d' => subst_vars; right; rename_i v' _ _ _ _; exists v' 57 | | sub _ lt ih => match ih hx with 58 | | .inl lt' => left; exact lt.trans lt' 59 | | .inr ⟨v', efv', ev'⟩ => right; refine ⟨v', efv'.sub ?_, ev'⟩; exact .fn .refl lt 60 | | conj _ _ ih ih' => match ih hx, ih' hx with 61 | | .inl lt, .inl lt' => left; exact lt.conjL lt' 62 | | .inl lt, .inr ⟨v', efv', ev'⟩ => 63 | right; refine ⟨v', efv'.sub ?_, ev'⟩; refine .fn .refl ?_ 64 | refine .conjL ?_ .refl; exact sub_of_sub_bot lt 65 | | .inr ⟨v', efv', ev'⟩, .inl lt => 66 | right; refine ⟨v', efv'.sub ?_, ev'⟩; refine .fn .refl ?_ 67 | refine .conjL .refl ?_; exact sub_of_sub_bot lt 68 | | .inr ⟨v', efv', ev'⟩, .inr ⟨v'', efv'', ev''⟩ => 69 | right; refine ⟨v' ⊔ v'', ?_, ev'.conj ev''⟩ 70 | exact (efv'.conj efv'').sub fn_conj_sub_conj_fn 71 | 72 | lemma ℰ_ap : (ℰ l ● ℰ m) γ v → ℰ (l □ m) γ v 73 | | .inl lt => .sub .bot lt 74 | | .inr ⟨_, efv, ev⟩ => efv.ap ev 75 | 76 | theorem ap_equiv : ℰ (l □ m) = (ℰ l ● ℰ m) := by ext; exact ⟨𝒜_ℰ, ℰ_ap⟩ 77 | 78 | abbrev 𝒱 (i : Γ ∋ ✶) (γ : Env Γ) (v : Value) : Prop := v ⊑ γ i 79 | 80 | theorem var_inv (d : ℰ (` i) γ v) : 𝒱 i γ v := by 81 | generalize hx : (` i) = x at * 82 | induction d with try injection hx 83 | | var => subst_vars; rfl 84 | | bot => exact .bot 85 | | conj _ _ ih ih' => exact (ih hx).conjL (ih' hx) 86 | | sub _ lt ih => exact lt.trans (ih hx) 87 | 88 | theorem var_equiv : ℰ (` i) = 𝒱 i := by ext; exact ⟨var_inv, .sub .var⟩ 89 | 90 | -- https://plfa.github.io/Compositional/#congruence 91 | lemma lam_congr (h : ℰ n = ℰ n') : ℰ (ƛ n) = ℰ (ƛ n') := calc _ 92 | _ = ℱ (ℰ n) := lam_equiv 93 | _ = ℱ (ℰ n') := by rw [h] 94 | _ = ℰ (ƛ n') := lam_equiv.symm 95 | 96 | lemma ap_congr (hl : ℰ l = ℰ l') (hm : ℰ m = ℰ m') : ℰ (l □ m) = ℰ (l' □ m') := calc _ 97 | _ = ℰ l ● ℰ m := ap_equiv 98 | _ = ℰ l' ● ℰ m' := by rw [hl, hm] 99 | _ = ℰ (l' □ m') := ap_equiv.symm 100 | 101 | -- https://plfa.github.io/Compositional/#compositionality 102 | open Untyped (Context) 103 | 104 | /-- 105 | `Holed Γ Δ` describes a program with a hole in it: 106 | - `Γ` is the `Context` for the hole. 107 | - `Δ` is the `Context` for the terms that result from filling the hole. 108 | -/ 109 | inductive Holed : Context → Context → Type where 110 | /-- A basic hole. -/ 111 | | hole : Holed Γ Γ 112 | /-- λ-abstracting the hole makes a bigger hole. -/ 113 | | lam : Holed (Γ‚ ✶) (Δ‚ ✶) → Holed (Γ‚ ✶) Δ 114 | /-- Applying to a holed function makes a bigger hole. -/ 115 | | apL : Holed Γ Δ → (Δ ⊢ ✶) → Holed Γ Δ 116 | /-- Applying a holed argument makes a bigger hole. -/ 117 | | apR : (Δ ⊢ ✶) → Holed Γ Δ → Holed Γ Δ 118 | 119 | /-- `plug`s a term into a `Holed` context, making a new term. -/ 120 | def Holed.plug : Holed Γ Δ → (Γ ⊢ ✶) → (Δ ⊢ ✶) 121 | | .hole, m => m 122 | | .lam c, n => ƛ c.plug n 123 | | .apL c n, l => c.plug l □ n 124 | | .apR l c, m => l □ c.plug m 125 | 126 | /-- 127 | Given two terms that are denotationally equal, 128 | plugging them both into any holed context produces two programs 129 | that are denotationally equal. 130 | -/ 131 | theorem compositionality {c : Holed Γ Δ} (h : ℰ m = ℰ n) : ℰ (c.plug m) = ℰ (c.plug n) := by 132 | induction c with unfold Holed.plug 133 | | hole => exact h 134 | | lam _ ih => exact lam_congr (ih h) 135 | | apL _ _ ih => exact ap_congr (ih h) (by rfl) 136 | | apR _ _ ih => exact ap_congr (by rfl) (ih h) 137 | 138 | -- https://plfa.github.io/Compositional/#the-denotational-semantics-defined-as-a-function 139 | /-- 140 | `ℰ₀ m` is the instance of `Denot` that corresponds to the `Eval` of `m`. 141 | It is like `ℰ m`, but defined computationally. 142 | -/ 143 | def ℰ₀ : (Γ ⊢ ✶) → Denot Γ 144 | | ` i => 𝒱 i 145 | | ƛ n => ℱ (ℰ₀ n) 146 | | l □ m => ℰ₀ l ● ℰ₀ m 147 | 148 | /-- The two definitions of `ℰ` are equivalent. -/ 149 | theorem ℰ_eq_ℰ₀ : ℰ (Γ := Γ) = ℰ₀ := by ext; rw [impl] 150 | where 151 | impl {a} {m : Γ ⊢ a} : ℰ m = ℰ₀ m := by 152 | induction m with (ext γ v; simp only [ℰ₀]) 153 | | var i => rw [var_equiv] 154 | | lam n ih => rw [←ih, lam_equiv] 155 | | ap l m ih ih' => rw [←ih, ←ih', ap_equiv] 156 | -------------------------------------------------------------------------------- /Plfl/Untyped/Denotational/ContextualEquivalence.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/ContextualEquivalence/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped.Denotational.Adequacy 5 | 6 | namespace ContextualEquivalence 7 | 8 | open Untyped Untyped.Notation 9 | open Adequacy 10 | open BigStep BigStep.Notation 11 | open Compositional 12 | open Denotational 13 | open Soundness (soundness) 14 | 15 | -- https://plfa.github.io/ContextualEquivalence/#contextual-equivalence 16 | abbrev Terminates (m : Γ ⊢ ✶) : Prop := ∃ n, m —↠ ƛ n 17 | 18 | /-- 19 | Two terms are contextually equivalent 20 | if plugging them into the same holed program always produces two programs 21 | that either terminate or diverge together. 22 | -/ 23 | abbrev ContextualEquiv (m n : Γ ⊢ ✶) : Prop := 24 | ∀ {c : Holed Γ ∅}, Terminates (c.plug m) = Terminates (c.plug n) 25 | 26 | namespace Notation 27 | scoped infixl:25 "≃ₕ" => ContextualEquiv 28 | end Notation 29 | 30 | open Notation 31 | 32 | -- https://plfa.github.io/ContextualEquivalence/#denotational-equivalence-implies-contextual-equivalence 33 | lemma Terminates.of_eq_ℰ {m n : Γ ⊢ ✶} {c : Holed Γ ∅} (he : ℰ m = ℰ n) : 34 | Terminates (c.plug m) → Terminates (c.plug n) 35 | := by 36 | intro ⟨n', rs⟩; apply Eval.reduce_iff_cbn.mpr; apply Eval.to_big_step 37 | calc ℰ (c.plug n) 38 | _ = ℰ (c.plug m) := compositionality he |>.symm 39 | _ = ℰ (ƛ n') := soundness rs 40 | 41 | theorem ContextualEquiv.of_eq_ℰ {m n : Γ ⊢ ✶} (he : ℰ m = ℰ n) : m ≃ₕ n := by 42 | intro c; simp only [eq_iff_iff]; constructor 43 | · exact Terminates.of_eq_ℰ he 44 | · exact Terminates.of_eq_ℰ he.symm 45 | -------------------------------------------------------------------------------- /Plfl/Untyped/Denotational/Soundness.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Soundness/ 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped.Denotational.Compositional 5 | 6 | namespace Soundness 7 | 8 | open Untyped Untyped.Notation 9 | open Untyped.Subst 10 | open Substitution (Rename Subst) 11 | open Denotational Denotational.Notation 12 | open Compositional Compositional.Notation 13 | 14 | -- https://plfa.github.io/Soundness/#simultaneous-substitution-preserves-denotations 15 | namespace Env 16 | /-- 17 | `Eval δ σ γ` means that for every variable `i`, 18 | `σ i` results in the same value as the one for `i` in the original environment `γ`. 19 | -/ 20 | abbrev Eval (δ : Env Δ) (σ : Subst Γ Δ) (γ : Env Γ) : Prop := ∀ (i : Γ ∋ ✶), δ ⊢ σ i ￬ γ i 21 | end Env 22 | 23 | namespace Notation 24 | scoped notation:30 δ " `⊢ " σ " ￬ " γ:51 => Env.Eval δ σ γ 25 | end Notation 26 | 27 | open Notation 28 | 29 | section 30 | variable {γ : Env Γ} {δ : Env Δ} 31 | 32 | lemma subst_ext (σ : Subst Γ Δ) (d : δ `⊢ σ ￬ γ) : δ`‚ v `⊢ exts σ ￬ (γ`‚ v) 33 | | .z => .var 34 | | .s i => rename_pres .s (λ _ => .refl) (d i) 35 | 36 | /-- The result of evaluation is conserved after simultaneous substitution. -/ 37 | theorem subst_pres (σ : Subst Γ Δ) (s : δ `⊢ σ ￬ γ) (d : γ ⊢ m ￬ v) 38 | : δ ⊢ subst σ m ￬ v 39 | := by induction d generalizing Δ with 40 | | var => apply s 41 | | ap _ _ ih ih'=> exact (ih σ s).ap (ih' σ s) 42 | | fn _ ih => refine .fn ?_; apply ih (exts σ); exact subst_ext σ s 43 | | bot => exact .bot 44 | | conj _ _ ih ih' => exact (ih σ s).conj (ih' σ s) 45 | | sub _ lt ih => exact (ih σ s).sub lt 46 | 47 | -- https://plfa.github.io/Soundness/#single-substitution-preserves-denotations 48 | /-- The result of evaluation is conserved after single substitution. -/ 49 | theorem subst₁_pres (dn : γ`‚ v ⊢ n ￬ w) (dm : γ ⊢ m ￬ v) : γ ⊢ n⟦m⟧ ￬ w 50 | := subst_pres (subst₁σ m) (λ | .z => dm | .s _ => .var) dn 51 | 52 | -- https://plfa.github.io/Soundness/#reduction-preserves-denotations 53 | theorem reduce_pres (d : γ ⊢ m ￬ v) (r : m —→ n) : γ ⊢ n ￬ v := by induction d with 54 | | var => contradiction 55 | | bot => exact .bot 56 | | fn _ ih => cases r with | lamζ r => exact (ih r).fn 57 | | conj _ _ ih ih' => exact (ih r).conj (ih' r) 58 | | sub _ lt ih => exact (ih r).sub lt 59 | | ap d d' ih ih' => cases r with 60 | | apξ₁ r => exact (ih r).ap d' 61 | | apξ₂ r => exact d.ap (ih' r) 62 | | lamβ => exact subst₁_pres (lam_inv d) d' 63 | 64 | -- https://plfa.github.io/Soundness/#renaming-reflects-meaning 65 | theorem rename_reflect {ρ : Rename Γ Δ} (lt : δ ∘ ρ `⊑ γ) (d : δ ⊢ rename ρ m ￬ v) 66 | : γ ⊢ m ￬ v 67 | := by 68 | generalize hx : rename ρ m = x at * 69 | induction d generalizing Γ with 70 | | bot => exact .bot 71 | | var => cases m with (injection hx; try subst_vars) 72 | | var i => exact .sub .var <| (var_inv .var).trans (lt i) 73 | | ap _ _ ih ih' => cases m with injection hx 74 | | ap => rename_i hx hx'; exact (ih lt hx).ap (ih' lt hx') 75 | | fn _ ih => cases m with injection hx 76 | | lam => refine .fn ?_; apply ih (ρ := ext ρ) (ext_sub' ρ lt); trivial 77 | | conj _ _ ih ih' => exact (ih lt hx).conj (ih' lt hx) 78 | | sub _ lt' ih => exact (ih lt hx).sub lt' 79 | 80 | theorem rename_shift_reflect (d : γ`‚ u ⊢ shift m ￬ v) : γ ⊢ m ￬ v := 81 | rename_reflect (by rfl) d 82 | end 83 | 84 | section 85 | -- https://plfa.github.io/Soundness/#substitution-reflects-denotations-the-variable-case 86 | /-- `const` is an `Env` with a single non-trivial mapping entry: from `i` to `v`. -/ 87 | def Env.const (i : Γ ∋ ✶) (v : Value) : Env Γ | j => if i = j then v else ⊥ 88 | 89 | variable {γ δ : Env Δ} 90 | 91 | lemma subst_reflect_var {i : Γ ∋ ✶} {σ : Subst Γ Δ} (d : γ ⊢ σ i ￬ v) 92 | : ∃ (δ : Env Γ), (γ `⊢ σ ￬ δ) ∧ (δ ⊢ ` i ￬ v) 93 | := by 94 | exists Env.const i v; unfold Env.const; constructor 95 | · intro j; by_cases h : i = j <;> simp only [h] at * 96 | · exact d 97 | · exact .bot 98 | · convert Eval.var; simp only [Env.const, ite_true] 99 | 100 | variable {γ₁ γ₂ : Env Γ} {σ : Subst Γ Δ} 101 | 102 | -- https://plfa.github.io/Soundness/#substitutions-and-environment-construction 103 | lemma subst_bot : γ `⊢ σ ￬ ⊥ | _ => .bot 104 | 105 | lemma subst_conj (d₁ : γ `⊢ σ ￬ γ₁) (d₂ : γ `⊢ σ ￬ γ₂) : γ `⊢ σ ￬ γ₁ ⊔ γ₂ 106 | | i => (d₁ i).conj (d₂ i) 107 | end 108 | 109 | -- https://plfa.github.io/Soundness/#simultaneous-substitution-reflects-denotations 110 | /-- Simultaneous substitution reflects denotations. -/ 111 | theorem subst_reflect {σ : Subst Γ Δ} (d : δ ⊢ l ￬ v) (h : ⟪σ⟫ m = l) 112 | : ∃ (γ : Env Γ), (δ `⊢ σ ￬ γ) ∧ (γ ⊢ m ￬ v) 113 | := by 114 | induction d generalizing Γ with 115 | | bot => exists ⊥; exact ⟨subst_bot, .bot⟩ 116 | | var => cases m with try contradiction 117 | | var j => apply subst_reflect_var; convert Eval.var 118 | | ap d d' ih ih' => rename_i l' _ _ m'; cases m with try contradiction 119 | | var => apply subst_reflect_var; convert d.ap d' 120 | | ap => 121 | injection h; rename_i h h' 122 | let ⟨γ, dγ, dm⟩ := ih h; let ⟨γ', dγ', dm'⟩ := ih' h'; exists γ ⊔ γ'; constructor 123 | · exact subst_conj dγ dγ' 124 | · exact (sub_env dm <| Env.Sub.conjR₁ γ γ').ap (sub_env dm' <| Env.Sub.conjR₂ γ γ') 125 | | fn d ih => cases m with try contradiction 126 | | var => apply subst_reflect_var; convert d.fn 127 | | lam => 128 | injection h; rename_i h; let ⟨γ, dγ, dm⟩ := ih h; exists γ.init; constructor 129 | · intro i; exact rename_shift_reflect <| dγ i.s 130 | · rw [Env.init_last γ] at dm; refine .fn (up_env dm ?_); exact var_inv <| dγ .z 131 | | conj _ _ ih ih' => 132 | let ⟨γ, dγ, dm⟩ := ih h; let ⟨γ', dγ', dm'⟩ := ih' h; exists γ ⊔ γ'; constructor 133 | · exact subst_conj dγ dγ' 134 | · exact (sub_env dm <| Env.Sub.conjR₁ γ γ').conj (sub_env dm' <| Env.Sub.conjR₂ γ γ') 135 | | sub _ lt' ih => let ⟨γ, dγ, dm⟩ := ih h; exact ⟨γ, dγ, dm.sub lt'⟩ 136 | 137 | -- https://plfa.github.io/Soundness/#single-substitution-reflects-denotations 138 | lemma subst₁σ_reflect {δ : Env Δ} {γ : Env (Δ‚ ✶)} (d : δ `⊢ subst₁σ m ￬ γ) 139 | : ∃ w, (γ `⊑ δ`‚ w) ∧ (δ ⊢ m ￬ w) 140 | := by 141 | exists γ.last; constructor 142 | · intro 143 | | .z => rfl 144 | | .s i => apply var_inv (d i.s) 145 | · exact d .z 146 | 147 | /-- Single substitution reflects denotations. -/ 148 | theorem subst₁_reflect {δ : Env Δ} (d : δ ⊢ n⟦m⟧ ￬ v) : ∃ w, (δ ⊢ m ￬ w) ∧ (δ`‚ w ⊢ n ￬ v) 149 | := by 150 | have ⟨γ, dγ, dn⟩ := subst_reflect d rfl; have ⟨w, ltw, dw⟩ := subst₁σ_reflect dγ 151 | exists w, dw; exact sub_env dn ltw 152 | 153 | -- https://plfa.github.io/Soundness/#reduction-reflects-denotations-1 154 | theorem reduce_reflect {γ : Env Γ} {m n : Γ ⊢ a} (d : γ ⊢ n ￬ v) (r : m —→ n) : γ ⊢ m ￬ v := by 155 | induction r generalizing v with 156 | | lamβ => 157 | rename_i n u; generalize hx : n⟦u⟧ = x at * 158 | induction d with 159 | | var => apply beta; rw [hx]; exact .var 160 | | ap d d' => apply beta; rw [hx]; exact d.ap d' 161 | | fn d => apply beta; rw [hx]; exact d.fn 162 | | bot => exact .bot 163 | | conj _ _ ih ih' => exact (ih hx).conj (ih' hx) 164 | | sub _ lt ih => exact (ih hx).sub lt 165 | | lamζ r ihᵣ => 166 | rename_i _ n'; generalize hx : (ƛ n') = x at * 167 | induction d with try contradiction 168 | | fn d ih => injection hx; subst_vars; exact (ihᵣ <| lam_inv d.fn).fn 169 | | bot => exact .bot 170 | | conj _ _ ih ih' => exact (ih r ihᵣ hx).conj (ih' r ihᵣ hx) 171 | | sub _ lt ih => exact (ih r ihᵣ hx).sub lt 172 | | apξ₁ r ihᵣ => 173 | rename_i l m; generalize hx : l □ m = x at * 174 | induction d with try contradiction 175 | | ap d d' _ _ => injection hx; subst_vars; exact (ihᵣ d).ap d' 176 | | bot => exact .bot 177 | | conj _ _ ih ih' => exact (ih r ihᵣ hx).conj (ih' r ihᵣ hx) 178 | | sub _ lt ih => exact (ih r ihᵣ hx).sub lt 179 | | apξ₂ r ihᵣ => 180 | rename_i m l; generalize hx : l □ m = x at * 181 | induction d with try contradiction 182 | | ap d d' _ _ => injection hx; subst_vars; exact d.ap <| ihᵣ d' 183 | | bot => exact .bot 184 | | conj _ _ ih ih' => exact (ih r ihᵣ hx).conj (ih' r ihᵣ hx) 185 | | sub _ lt ih => exact (ih r ihᵣ hx).sub lt 186 | where 187 | beta {Γ m n v} {γ : Env Γ} (d : γ ⊢ n⟦m⟧ ￬ v) : γ ⊢ (ƛ n) □ m ￬ v := by 188 | let ⟨v, dm, dn⟩ := subst₁_reflect d; exact dn.fn.ap dm 189 | 190 | -- https://plfa.github.io/Soundness/#reduction-implies-denotational-equality 191 | theorem reduce_eq (r : m —→ n) : ℰ m = ℰ n := by 192 | ext; exact ⟨(reduce_pres · r), (reduce_reflect · r)⟩ 193 | 194 | theorem soundness (rs : m —↠ ƛ n) : ℰ m = ℰ (ƛ n) := by 195 | induction rs using Relation.ReflTransGen.head_induction_on with 196 | | refl => rfl 197 | | head r _ ih => convert ih using 1; exact reduce_eq r 198 | -------------------------------------------------------------------------------- /Plfl/Untyped/Substitution.lean: -------------------------------------------------------------------------------- 1 | -- https://plfa.github.io/Substitution/#plfa_plfa-part2-Substitution-2341 2 | 3 | import Plfl.Init 4 | import Plfl.Untyped 5 | 6 | namespace Substitution 7 | 8 | open Untyped Notation 9 | 10 | abbrev Rename (Γ Δ) := ∀ {a : Ty}, Γ ∋ a → Δ ∋ a 11 | abbrev Subst (Γ Δ) := ∀ {a : Ty}, Γ ∋ a → Δ ⊢ a 12 | 13 | -- https://plfa.github.io/Substitution/#the-%CF%83-algebra-of-substitution 14 | abbrev ids : Subst Γ Γ := .var 15 | abbrev shift : Subst Γ (Γ‚ a) := .var ∘ .s 16 | 17 | abbrev cons (m : Δ ⊢ a) (σ : Subst Γ Δ) : Subst (Γ‚ a) Δ 18 | | _, .z => m 19 | | _, .s x => σ x 20 | 21 | abbrev seq (σ : Subst Γ Δ) (τ : Subst Δ Φ) : Subst Γ Φ := ⟪τ⟫ ∘ σ 22 | 23 | namespace Notation 24 | scoped infixr:60 " ⦂⦂ " => cons 25 | scoped infixr:50 " ⨟ " => seq 26 | end Notation 27 | 28 | open Notation 29 | open Subst 30 | 31 | -- https://plfa.github.io/Substitution/#relating-the-σ-algebra-and-substitution-functions 32 | def ren (ρ : Rename Γ Δ) : Subst Γ Δ := ids ∘ ρ 33 | 34 | section 35 | variable {m : Δ ⊢ a} {σ : Subst Γ Δ} {τ : Subst Δ Φ} 36 | 37 | -- https://plfa.github.io/Substitution/#proofs-of-sub-head-sub-tail-sub-η-z-shift-sub-idl-sub-dist-and-sub-app 38 | @[simp] theorem sub_head : ⟪m ⦂⦂ σ⟫ (`.z) = m := rfl 39 | @[simp] theorem sub_tail : (shift ⨟ m ⦂⦂ σ) = σ (a := b) := rfl 40 | @[simp] theorem sub_η {σ : Subst (Γ‚ a) Δ} : (⟪σ⟫ (`.z) ⦂⦂ (shift ⨟ σ)) = σ (a := b) := by ext i; cases i <;> rfl 41 | @[simp] theorem z_shift : ((`.z) ⦂⦂ shift) = @ids (Γ‚ a) b := by ext i; cases i <;> rfl 42 | @[simp] theorem ids_seq : (ids ⨟ σ) = σ (a := a) := rfl 43 | @[simp] theorem sub_ap {l m : Γ ⊢ ✶} : ⟪σ⟫ (l □ m) = (⟪σ⟫ l) □ (⟪σ⟫ m) := rfl 44 | @[simp] theorem sub_dist : @Eq (Γ‚ a ∋ b → Φ ⊢ b) ((m ⦂⦂ σ) ⨟ τ) ((⟪τ⟫ m) ⦂⦂ (σ ⨟ τ)) := by ext i; cases i <;> rfl 45 | end 46 | 47 | -- https://plfa.github.io/Substitution/#interlude-congruences 48 | /- 49 | Nothing to do. 50 | -/ 51 | 52 | section 53 | variable {m : Γ ⊢ a} {σ : Subst Γ Δ} {ρ : Rename Γ Δ} 54 | 55 | -- https://plfa.github.io/Substitution/#relating-rename-exts-ext-and-subst-zero-to-the-%CF%83-algebra 56 | @[simp] theorem ren_ext : @Eq (Γ‚ b ∋ c → Δ‚ b ⊢ c) (ren (ext ρ)) (exts (ren ρ)) := by ext i; cases i <;> rfl 57 | @[simp] theorem ren_shift : @Eq (Γ ∋ a → Γ‚ b ⊢ a) (ren .s) shift := by congr 58 | 59 | theorem rename_subst_ren {Γ Δ} {ρ : Rename Γ Δ} {m : Γ ⊢ a} : rename ρ m = ⟪ren ρ⟫ m := by 60 | match m with 61 | | ` _ => rfl 62 | | ƛ n => apply congr_arg Term.lam; rw [rename_subst_ren]; congr; funext _; exact ren_ext 63 | | l □ m => simp only [sub_ap]; apply congr_arg₂ Term.ap <;> exact rename_subst_ren 64 | 65 | theorem rename_shift : @Eq (Γ‚ ✶ ⊢ a) (rename .s m) (⟪shift⟫ m) := by 66 | simp only [rename_subst_ren]; congr 67 | 68 | theorem exts_cons_shift : exts (a := a) (b := b) σ = (`.z ⦂⦂ (σ ⨟ shift)) := by 69 | ext i; cases i <;> simp only [exts, rename_subst_ren, ren_shift]; rfl 70 | 71 | theorem ext_cons_z_shift : @Eq (Γ‚ b ∋ a → Δ‚ b ⊢ a) (ren (ext ρ)) (`.z ⦂⦂ (ren ρ ⨟ shift)) := by 72 | ext i; cases i <;> simp only [ren_ext, exts, rename_subst_ren, ren_shift]; rfl 73 | 74 | theorem subst_z_cons_ids {m : Γ ⊢ a} : @Eq (Γ‚ ✶ ∋ a → Γ ⊢ a) (subst₁σ m) (m ⦂⦂ ids) := by 75 | ext i; cases i <;> rfl 76 | 77 | -- https://plfa.github.io/Substitution/#proofs-of-sub-abs-sub-id-and-rename-id 78 | theorem sub_lam {σ : Subst Γ Δ} {n : Γ‚ ✶ ⊢ ✶} : ⟪σ⟫ (ƛ n) = (ƛ ⟪(`.z) ⦂⦂ (σ ⨟ shift)⟫ n) := by 79 | change (ƛ ⟪exts σ⟫ n) = _; congr; funext _; exact exts_cons_shift 80 | 81 | @[simp] theorem exts_ids : @Eq (Γ‚ b ∋ a → _) (exts ids) ids := by ext i; cases i <;> rfl 82 | 83 | theorem sub_ids {Γ} {m : Γ ⊢ a} : ⟪ids (Γ := Γ)⟫ m = m := by 84 | match m with 85 | | ` _ => rfl 86 | | ƛ n => apply congr_arg Term.lam; convert sub_ids; exact exts_ids 87 | | l □ m => simp only [sub_ap]; apply congr_arg₂ Term.ap <;> exact sub_ids 88 | 89 | theorem rename_id : rename (λ {a} x => x) m = m := by 90 | convert sub_ids; ext; simp only [rename_subst_ren, ren]; congr 91 | 92 | -- https://plfa.github.io/Substitution/#proof-of-sub-idr 93 | theorem seq_ids : @Eq (Γ ∋ a → Δ ⊢ a) (σ ⨟ ids) σ := by 94 | ext; simp only [Function.comp_apply, sub_ids] 95 | end 96 | 97 | section 98 | variable {m : Γ ⊢ a} {ρ : Rename Δ Φ} {ρ' : Rename Γ Δ} 99 | 100 | -- https://plfa.github.io/Substitution/#proof-of-sub-sub 101 | @[simp] theorem comp_ext : @Eq (Γ‚ b ∋ a → _) ((ext ρ) ∘ (ext ρ')) (ext (ρ ∘ ρ')) := by 102 | ext i; cases i <;> rfl 103 | 104 | theorem comp_rename {Γ Δ Φ} {m : Γ ⊢ a} {ρ : Rename Δ Φ} {ρ' : Rename Γ Δ} 105 | : rename ρ (rename ρ' m) = rename (ρ ∘ ρ') m := by 106 | match m with 107 | | ` _ => rfl 108 | | ƛ n => apply congr_arg Term.lam; convert comp_rename; exact comp_ext.symm 109 | | l □ m => apply congr_arg₂ Term.ap <;> exact comp_rename 110 | 111 | theorem comm_subst_rename {Γ Δ} {σ : Subst Γ Δ} {ρ : ∀ {Γ}, Rename Γ (Γ‚ ✶)} 112 | (r : ∀ {x : Γ ∋ ✶}, exts σ (ρ x) = rename ρ (σ x)) {m : Γ ⊢ ✶} 113 | : ⟪exts (b := ✶) σ⟫ (rename ρ m) = rename ρ (⟪σ⟫ m) 114 | := by 115 | match m with 116 | | ` _ => exact r 117 | | l □ m => apply congr_arg₂ Term.ap <;> exact comm_subst_rename r 118 | | ƛ n => 119 | apply congr_arg Term.lam 120 | 121 | let ρ' : ∀ {Γ}, Rename Γ (Γ‚ ✶) := by intro 122 | | [] => intro; intro. 123 | | ✶ :: Γ => intro; exact ext ρ 124 | 125 | apply comm_subst_rename (Γ := Γ‚ ✶) (Δ := Δ‚ ✶) (σ := exts σ) (ρ := ρ') (m := n); intro 126 | | .z => rfl 127 | | .s x => calc exts (exts σ) (ρ' (.s x)) 128 | _ = rename .s (exts σ (ρ x)) := rfl 129 | _ = rename .s (rename ρ (σ x)) := by rw [r] 130 | _ = rename (.s ∘ ρ) (σ x) := comp_rename 131 | _ = rename (ext ρ ∘ .s) (σ x) := by congr 132 | _ = rename (ext ρ) (rename .s (σ x)) := comp_rename.symm 133 | _ = rename ρ' (exts σ (.s x)) := rfl 134 | end 135 | 136 | section 137 | variable {ρ : Rename Γ Δ} {σ : Subst Γ Δ} {τ : Subst Δ Φ} {θ : Subst Φ Ψ} 138 | 139 | theorem exts_seq_exts : @Eq (Γ‚ ✶ ∋ a → _) (exts σ ⨟ exts τ) (exts (σ ⨟ τ)) := by 140 | ext i; match i with 141 | | .z => rfl 142 | | .s i => conv_lhs => 143 | change ⟪exts τ⟫ (rename .s (σ i)); rw [comm_subst_rename (σ := τ) (ρ := .s) rfl]; rfl 144 | 145 | theorem sub_sub {Γ Δ Φ} {σ : Subst Γ Δ} {τ : Subst Δ Φ} {m : Γ ⊢ a} 146 | : ⟪τ⟫ (⟪σ⟫ m) = ⟪σ ⨟ τ⟫ m 147 | := by match m with 148 | | ` _ => rfl 149 | | l □ m => apply congr_arg₂ Term.ap <;> exact sub_sub 150 | | ƛ n => calc ⟪τ⟫ (⟪σ⟫ (ƛ n)) 151 | _ = (ƛ ⟪exts τ⟫ (⟪exts σ⟫ n)) := rfl 152 | _ = (ƛ (⟪exts σ ⨟ exts τ⟫ n)) := by apply congr_arg Term.lam; exact sub_sub 153 | _ = (ƛ (⟪exts (σ ⨟ τ)⟫ n)) := by apply congr_arg Term.lam; congr; funext _; exact exts_seq_exts 154 | 155 | theorem rename_subst : ⟪τ⟫ (rename ρ m) = ⟪τ ∘ ρ⟫ m := by 156 | simp only [rename_subst_ren, sub_sub]; congr 157 | 158 | -- https://plfa.github.io/Substitution/#proof-of-sub-assoc 159 | theorem sub_assoc : @Eq (Γ ∋ a → _) ((σ ⨟ τ) ⨟ θ) (σ ⨟ (τ ⨟ θ)) := by 160 | ext; simp only [Function.comp_apply, sub_sub] 161 | 162 | -- https://plfa.github.io/Substitution/#proof-of-subst-zero-exts-cons 163 | theorem subst₁σ_exts_cons {m : Δ ⊢ b} : @Eq (Γ‚ ✶ ∋ a → _) (exts σ ⨟ subst₁σ m) (m ⦂⦂ σ) := by 164 | simp only [ 165 | exts_cons_shift, subst_z_cons_ids, sub_dist, sub_head, sub_assoc, sub_tail, seq_ids 166 | ] 167 | 168 | variable {n : Γ‚ ✶ ⊢ ✶} {m : Γ ⊢ ✶} 169 | 170 | -- https://plfa.github.io/Substitution/#proof-of-the-substitution-lemma 171 | theorem subst_comm : (⟪exts σ⟫ n)⟦⟪σ⟫ m⟧ = ⟪σ⟫ (n⟦m⟧) := calc _ 172 | _ = ⟪subst₁σ (⟪σ⟫ m)⟫ (⟪exts σ⟫ n) := rfl 173 | _ = ⟪⟪σ⟫ m ⦂⦂ ids⟫ (⟪exts σ⟫ n) := by congr; simp only [subst_z_cons_ids] 174 | _ = ⟪(exts σ) ⨟ ((⟪σ⟫ m) ⦂⦂ ids)⟫ n := sub_sub 175 | _ = ⟪(`.z ⦂⦂ (σ ⨟ shift)) ⨟ (⟪σ⟫ m ⦂⦂ ids)⟫ n := by congr; simp only [exts_cons_shift] 176 | _ = ⟪⟪⟪σ⟫ m ⦂⦂ ids⟫ (`.z) ⦂⦂ ((σ ⨟ shift) ⨟ (⟪σ⟫ m ⦂⦂ ids))⟫ n := by congr; simp only [sub_dist] 177 | _ = ⟪⟪σ⟫ m ⦂⦂ ((σ ⨟ shift) ⨟ (⟪σ⟫ m ⦂⦂ ids))⟫ n := rfl 178 | _ = ⟪⟪σ⟫ m ⦂⦂ (σ ⨟ shift ⨟ ⟪σ⟫ m ⦂⦂ ids)⟫ n := by congr; simp only [sub_assoc] 179 | _ = ⟪⟪σ⟫ m ⦂⦂ (σ ⨟ ids)⟫ n := by congr 180 | _ = ⟪⟪σ⟫ m ⦂⦂ (ids ⨟ σ)⟫ n := by congr; simp only [seq_ids, ids_seq] 181 | _ = ⟪m ⦂⦂ ids ⨟ σ⟫ n := by congr; simp only [sub_dist] 182 | _ = ⟪σ⟫ (⟪m ⦂⦂ ids⟫ n) := sub_sub.symm 183 | _ = ⟪σ⟫ (n⟦m⟧) := by congr; simp only [subst_z_cons_ids] 184 | 185 | theorem rename_subst_comm : (rename (ext ρ) n)⟦rename ρ m⟧ = rename ρ (n⟦m⟧) := calc _ 186 | _ = (⟪ren (ext ρ)⟫ n)⟦⟪ren ρ⟫ m⟧ := by rw [rename_subst_ren, rename_subst_ren] 187 | _ = (⟪exts (ren ρ)⟫ n)⟦⟪ren ρ⟫ m⟧ := by simp only [ren_ext] 188 | _ = ⟪ren ρ⟫ (n⟦m⟧) := subst_comm 189 | _ = rename ρ (n⟦m⟧) := rename_subst_ren.symm 190 | end 191 | 192 | /-- 193 | Substitute a term `m` for `♯1` within term `n`. 194 | -/ 195 | abbrev subst₁_under₁ (m : Γ ⊢ b) (n : Γ‚ b‚ c ⊢ a) : Γ‚ c ⊢ a := ⟪exts (subst₁σ m)⟫ n 196 | 197 | namespace Notation 198 | scoped notation:90 n "⟦" m "⟧₁" => subst₁_under₁ m n 199 | end Notation 200 | 201 | theorem substitution {m : Γ‚ ✶‚ ✶ ⊢ ✶} {n : Γ‚ ✶ ⊢ ✶} {l : Γ ⊢ ✶} : m⟦n⟧⟦l⟧ = m⟦l⟧₁⟦n⟦l⟧⟧ 202 | := subst_comm.symm 203 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PLFaLean 2 | 3 | My journey of learning Lean 4 by implementing proofs from the wonderful book [_Programming Language Foundations in Agda_](https://plfa.github.io). 4 | 5 | ## Table of Contents 6 | 7 | ### Volume 2 8 | 9 | - [x] 1. [Lambda](Plfl/Lambda.lean): Introduction to Lambda Calculus 10 | - [x] 2. [Properties](Plfl/Lambda/Properties.lean): Progress and Preservation 11 | - [x] 3. [DeBruijn](Plfl/DeBruijn.lean): Intrinsically-typed de Bruijn representation 12 | - [x] 4. [More](Plfl/More.lean): Additional constructs of simply-typed lambda calculus 13 | - [x] 5. [Bisimulation](Plfl/More/Bisimulation.lean): Relating reduction systems 14 | - [x] 6. [Inference](Plfl/More/Inference.lean): Bidirectional type inference 15 | - [x] 7. [Untyped](Plfl/Untyped.lean): Untyped lambda calculus with full normalisation 16 | - [x] 8. [Confluence](Plfl/Untyped/Confluence.lean): Confluence of untyped lambda calculus 17 | - [x] 9. [BigStep](Plfl/Untyped/BigStep.lean): Big-step semantics of untyped lambda calculus 18 | 19 | ### Volume 3 20 | 21 | - [x] 1. [Denotational](Plfl/Untyped/Denotational.lean): Denotational semantics of untyped lambda calculus 22 | - [x] 2. [Compositional](Plfl/Untyped/Denotational/Compositional.lean): The denotational semantics is compositional 23 | - [x] 3. [Soundness](Plfl/Untyped/Denotational/Soundness.lean): Soundness of reduction with respect to denotational semantics 24 | - [x] 4. [Adequacy](Plfl/Untyped/Denotational/Adequacy.lean): Adequacy of denotational semantics with respect to operational semantics 25 | - [x] 5. [ContextualEquivalence](Plfl/Untyped/Denotational/ContextualEquivalence.lean): Denotational equality implies contextual equivalence 26 | 27 | ### Appendix 28 | 29 | - [x] 1. [Substitution](Plfl/Untyped/Substitution.lean): Substitution in the untyped lambda calculus 30 | -------------------------------------------------------------------------------- /lake-manifest.json: -------------------------------------------------------------------------------- 1 | {"version": 7, 2 | "packagesDir": ".lake/packages", 3 | "packages": 4 | [{"url": "https://github.com/leanprover/std4", 5 | "type": "git", 6 | "subDir": null, 7 | "rev": "f58165d3d6e0b048d89e56944e98d9054b223d9b", 8 | "name": "std", 9 | "manifestFile": "lake-manifest.json", 10 | "inputRev": "main", 11 | "inherited": true, 12 | "configFile": "lakefile.lean"}, 13 | {"url": "https://github.com/leanprover-community/quote4", 14 | "type": "git", 15 | "subDir": null, 16 | "rev": "64365c656d5e1bffa127d2a1795f471529ee0178", 17 | "name": "Qq", 18 | "manifestFile": "lake-manifest.json", 19 | "inputRev": "master", 20 | "inherited": true, 21 | "configFile": "lakefile.lean"}, 22 | {"url": "https://github.com/leanprover-community/aesop", 23 | "type": "git", 24 | "subDir": null, 25 | "rev": "5fefb40a7c9038a7150e7edd92e43b1b94c49e79", 26 | "name": "aesop", 27 | "manifestFile": "lake-manifest.json", 28 | "inputRev": "master", 29 | "inherited": true, 30 | "configFile": "lakefile.lean"}, 31 | {"url": "https://github.com/leanprover-community/ProofWidgets4", 32 | "type": "git", 33 | "subDir": null, 34 | "rev": "fb65c476595a453a9b8ffc4a1cea2db3a89b9cd8", 35 | "name": "proofwidgets", 36 | "manifestFile": "lake-manifest.json", 37 | "inputRev": "v0.0.30", 38 | "inherited": true, 39 | "configFile": "lakefile.lean"}, 40 | {"url": "https://github.com/leanprover/lean4-cli", 41 | "type": "git", 42 | "subDir": null, 43 | "rev": "be8fa79a28b8b6897dce0713ef50e89c4a0f6ef5", 44 | "name": "Cli", 45 | "manifestFile": "lake-manifest.json", 46 | "inputRev": "main", 47 | "inherited": true, 48 | "configFile": "lakefile.lean"}, 49 | {"url": "https://github.com/leanprover-community/import-graph.git", 50 | "type": "git", 51 | "subDir": null, 52 | "rev": "61a79185b6582573d23bf7e17f2137cd49e7e662", 53 | "name": "importGraph", 54 | "manifestFile": "lake-manifest.json", 55 | "inputRev": "main", 56 | "inherited": true, 57 | "configFile": "lakefile.lean"}, 58 | {"url": "https://github.com/leanprover-community/mathlib4.git", 59 | "type": "git", 60 | "subDir": null, 61 | "rev": "afdc7729cafc1ca476165b2ade89d4150bcb1dd2", 62 | "name": "mathlib", 63 | "manifestFile": "lake-manifest.json", 64 | "inputRev": null, 65 | "inherited": false, 66 | "configFile": "lakefile.lean"}], 67 | "name": "plfl", 68 | "lakeDir": ".lake"} 69 | -------------------------------------------------------------------------------- /lakefile.lean: -------------------------------------------------------------------------------- 1 | import Lake 2 | open Lake DSL 3 | 4 | package plfl { 5 | leanOptions := #[⟨`relaxedAutoImplicit, false⟩] 6 | } 7 | 8 | require mathlib from git 9 | "https://github.com/leanprover-community/mathlib4.git" 10 | 11 | @[default_target] 12 | lean_lib Plfl { 13 | -- add library configuration options here 14 | } 15 | 16 | -- @[default_target] 17 | -- lean_exe plfl { 18 | -- root := `Main 19 | -- } 20 | -------------------------------------------------------------------------------- /lean-toolchain: -------------------------------------------------------------------------------- 1 | leanprover/lean4:v4.7.0 2 | --------------------------------------------------------------------------------