DanilaFe/agda-spa
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Lean migration: typeclass-based parameter passing, as in the Agda original

Browse Source 
The port had flattened Agda's instance arguments ({{flA}}, {{evaluator}},
{{latticeInterpretation}}, {{validEvaluator}}) into explicitly threaded
values (fhL, E, I, hE). Restore them as typeclasses:

- Spa.FiniteHeightLattice: now actually used — Fixedpoint takes the
  instance instead of a FixedHeight value; FiniteMap gets the missing
  instance (height = ks.length * height B), so varsFixedHeight /
  statesFixedHeight / signFixedHeight / constFixedHeight plumbing
  disappears (instance bottoms are defeq to the old ones)
- Spa.Analysis.Forward.Evaluation: StmtEvaluator/ExprEvaluator become
  classes; the Valid* Props become Prop-classes, as in Agda
- Spa.Analysis.Forward.Adapters: the expr→stmt adapter and its validity
  are instances (Agda: the ExprToStmtAdapter instances)
- LatticeInterpretation is a class; sign/const interpretations,
  evaluators and validity proofs are instances; use sites read like the
  Agda module applications: result SignLattice prog

Proof simplifications (same theorems, proofs factored):

- Spa.Lattice.AboveBelow.monotone₂_of_strict: any ⊥-strict/⊤-dominated
  operation on a flat lattice is monotone — replaces the four near-
  identical case bashes per analysis (postulates in Agda)
- Spa.Lattice.AboveBelow.interp_sup_of/interp_inf_of: the shared flat-
  lattice interpretation case analysis, making interpSign_sup/inf and
  interpConst_sup/inf one-liners

lake build green with zero warnings; lake exe spa output verified
byte-identical (diff) to the previous, Agda-verified output.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Danila Fedorin
2026-06-09 23:32:38 -07:00
parent b26d6b5acd
commit b16f14fdfd
12 changed files with 338 additions and 407 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
LEAN_MIGRATION.md
View File

@@ -45,8 +45,8 @@ validate phase by phase.
| `Language/Traces.agda` | custom, same `Trace`/`EndToEndTrace`/`++⟨_⟩` | | | `Language/Traces.agda` | custom, same `Trace`/`EndToEndTrace`/`++⟨_⟩` | |
| `Language/Properties.agda` | custom, same lemma inventory (`Trace-∙ˡ/ʳ`, `Trace-↦ˡ/ʳ`, `Trace-loop`, `EndToEndTrace-*`, `wrap-preds-∅`, `buildCfg-sufficient`) | the "ugly" `↑-≢` Fin-disjointness block should shrink via `Fin.castAdd_ne_natAdd`-style mathlib lemmas | | `Language/Properties.agda` | custom, same lemma inventory (`Trace-∙ˡ/ʳ`, `Trace-↦ˡ/ʳ`, `Trace-loop`, `EndToEndTrace-*`, `wrap-preds-∅`, `buildCfg-sufficient`) | the "ugly" `↑-≢` Fin-disjointness block should shrink via `Fin.castAdd_ne_natAdd`-style mathlib lemmas |
| `Language.agda` (`Program` record) | custom, same fields/lemmas (`trace`, `vars`, `states`, `incoming`, `initialState-pred-∅`, …) | | | `Language.agda` (`Program` record) | custom, same fields/lemmas (`trace`, `vars`, `states`, `incoming`, `initialState-pred-∅`, …) | |
| `Analysis/Forward/{Lattices,Evaluation,Adapters}.agda`, `Analysis/Forward.agda` | custom, same structure: `VariableValues`, `StateVariables`, `joinForKey`/`joinAll`, `StmtEvaluator`/`ExprEvaluator` + validity, expr→stmt adapter, `analyze`, `result`, `analyze-correct` | section variables instead of parameterized modules | | `Analysis/Forward/{Lattices,Evaluation,Adapters}.agda`, `Analysis/Forward.agda` | custom, same structure: `VariableValues`, `StateVariables`, `joinForKey`/`joinAll`, `StmtEvaluator`/`ExprEvaluator` + validity, expr→stmt adapter, `analyze`, `result`, `analyze-correct` | section variables instead of parameterized modules; everything Agda passed as an instance argument (`IsFiniteHeightLattice`, the evaluators, `LatticeInterpretation`, the validity records) is a typeclass resolved by instance search |
| `Analysis/Sign.agda`, `Analysis/Constant.agda` | custom, same definitions | the four monotonicity **postulates** become real proofs by `decide` (finite lattice, decidable `≤`) | | `Analysis/Sign.agda`, `Analysis/Constant.agda` | custom, same definitions | the four monotonicity **postulates** become real proofs (any `⊥`-strict/`⊤`-dominating operation on a flat lattice is monotone: `AboveBelow.monotone₂_of_strict`) |
| `Main.agda` | `lake exe spa` | same test programs, same printed output | | `Main.agda` | `lake exe spa` | same test programs, same printed output |
## Phases & checkpoints ## Phases & checkpoints
@@ -91,7 +91,9 @@ correspondence tables live in the header comment of each Lean file.
- The four monotonicity **postulates** in `Analysis/Sign.agda` and - The four monotonicity **postulates** in `Analysis/Sign.agda` and
`Analysis/Constant.agda` are now proved theorems (via `Analysis/Constant.agda` are now proved theorems (via
`AboveBelow.le_cases`), so the Lean development is postulate-free. `AboveBelow.monotone₂_of_strict`: any operation on the flat lattice that
is strict in `⊥` and dominated by `⊤` is monotone, whatever its table),
so the Lean development is postulate-free.
- ~2200 lines of map machinery (`Lattice/Map.agda`, `Lattice/MapSet.agda`, - ~2200 lines of map machinery (`Lattice/Map.agda`, `Lattice/MapSet.agda`,
much of `Lattice/FiniteMap.agda`) collapse into the spine-pinned much of `Lattice/FiniteMap.agda`) collapse into the spine-pinned
`FiniteMap` + `Finset`; the `IterProd` isomorphism no longer needs `FiniteMap` + `Finset`; the `IterProd` isomorphism no longer needs

159
lean/Spa/Analysis/Constant.lean
View File

@@ -4,11 +4,13 @@ Port of `Analysis/Constant.agda`.
Correspondence: Correspondence:
showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances) showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
ConstLattice (AboveBelow ℤ) ↦ ConstLattice ConstLattice (AboveBelow ℤ) ↦ ConstLattice
AB.Plain (+ 0) ↦ constFixedHeight AB.Plain (+ 0) ↦ the AboveBelow FiniteHeightLattice instance,
seeded by `Inhabited ℤ` (default `0`)
plus, minus ↦ plus, minus plus, minus ↦ plus, minus
plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!) plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
↦ plus_mono_left/right, minus_mono_left/right ↦ plus_mono_left/right, minus_mono_left/right
— now actually proved, via AboveBelow.le_cases — now actually proved, via
AboveBelow.monotone₂_of_strict
plus-Mono₂, minus-Mono₂ ↦ plus_mono₂, minus_mono₂ plus-Mono₂, minus-Mono₂ ↦ plus_mono₂, minus_mono₂
⟦_⟧ᶜ ↦ interpConst ⟦_⟧ᶜ ↦ interpConst
⟦⟧ᶜ-respects-≈ᶜ ↦ (trivial with `=`) ⟦⟧ᶜ-respects-≈ᶜ ↦ (trivial with `=`)
@@ -30,10 +32,6 @@ namespace Spa
abbrev ConstLattice : Type := AboveBelow ℤ abbrev ConstLattice : Type := AboveBelow ℤ
/-- Agda: `AB.Plain (+ 0)`'s `fixedHeight`. -/
def constFixedHeight : FixedHeight ConstLattice 2 :=
AboveBelow.plainFixedHeight (0 : ℤ)
namespace ConstAnalysis namespace ConstAnalysis
open AboveBelow in open AboveBelow in
@@ -54,81 +52,33 @@ def minus : ConstLattice → ConstLattice → ConstLattice
| _, top => top | _, top => top
| mk z₁, mk z₂ => mk (z₁ - z₂) | mk z₁, mk z₂ => mk (z₁ - z₂)
/-- Agda: `plus-Mono₂` (its components were postulates in Agda; `plus` is a
strict operation on the flat lattice, so monotonicity holds regardless of the
constant table). -/
theorem plus_mono₂ : Monotone₂ plus :=
AboveBelow.monotone₂_of_strict plus
(fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/ /-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := by theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/ /-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := by theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `plus-Mono₂`. -/ /-- Agda: `minus-Mono₂` (likewise from strictness of `minus`). -/
theorem plus_mono₂ : Monotone₂ plus := theorem minus_mono₂ : Monotone₂ minus :=
⟨plus_mono_left, plus_mono_right⟩ AboveBelow.monotone₂_of_strict minus
(fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
/-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/ /-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/
theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := by theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/ /-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := by theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `minus-Mono₂`. -/
theorem minus_mono₂ : Monotone₂ minus :=
⟨minus_mono_left, minus_mono_right⟩
/-- Agda: `⟦_⟧ᶜ`. -/ /-- Agda: `⟦_⟧ᶜ`. -/
def interpConst : ConstLattice → Value → Prop def interpConst : ConstLattice → Value → Prop
@@ -144,48 +94,18 @@ theorem interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Val
injection h₂ with hz injection h₂ with hz
exact hne hz exact hne hz
/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨`. -/ /-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨` (via the factored flat-lattice lemma). -/
theorem interpConst_sup {s₁ s₂ : ConstLattice} (v : Value) theorem interpConst_sup {s₁ s₂ : ConstLattice} (v : Value)
(h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v := by (h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v :=
rcases s₁ with _ | _ | z₁ AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
· rcases h with h | h
· exact h.elim
· rw [AboveBelow.bot_sup]
exact h
· exact trivial
· rcases s₂ with _ | _ | z₂
· rcases h with h | h
· rw [AboveBelow.sup_bot]
exact h
· exact h.elim
· rw [AboveBelow.sup_top]
exact trivial
· by_cases hz : z₁ = z₂
· subst hz
rw [AboveBelow.mk_sup_mk, if_pos rfl]
rcases h with h | h <;> exact h
· rw [AboveBelow.mk_sup_mk, if_neg hz]
exact trivial
/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧`. -/ /-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧` (via the factored flat-lattice lemma). -/
theorem interpConst_inf {s₁ s₂ : ConstLattice} (v : Value) theorem interpConst_inf {s₁ s₂ : ConstLattice} (v : Value)
(h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v := by (h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v :=
rcases s₁ with _ | _ | z₁ AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) v h
· exact h.1
· rw [AboveBelow.top_inf]
exact h.2
· rcases s₂ with _ | _ | z₂
· exact h.2
· rw [AboveBelow.inf_top]
exact h.1
· by_cases hz : z₁ = z₂
· subst hz
rw [AboveBelow.mk_inf_mk, if_pos rfl]
exact h.1
· exact absurd h (interpConst_mk_disjoint hz)
/-- Agda: `latticeInterpretationᶜ`. -/ /-- Agda: `latticeInterpretationᶜ` (an instance there too). -/
def constInterpretation : LatticeInterpretation ConstLattice where instance constInterpretation : LatticeInterpretation ConstLattice where
interp := interpConst interp := interpConst
interp_sup := fun {l₁ l₂} v h => interpConst_sup (s₁ := l₁) (s₂ := l₂) v h interp_sup := fun {l₁ l₂} v h => interpConst_sup (s₁ := l₁) (s₂ := l₂) v h
interp_inf := fun {l₁ l₂} v h => interpConst_inf (s₁ := l₁) (s₂ := l₂) v h interp_inf := fun {l₁ l₂} v h => interpConst_inf (s₁ := l₁) (s₂ := l₂) v h
@@ -224,12 +144,12 @@ theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
exact le_refl _ exact le_refl _
/-- Agda: the `ConstEval` instance. -/ /-- Agda: the `ConstEval` instance. -/
def exprEvaluator : ExprEvaluator ConstLattice prog := instance exprEvaluator : ExprEvaluator ConstLattice prog :=
⟨eval prog, eval_mono prog⟩ ⟨eval prog, eval_mono prog⟩
/-- Agda: `WithProg.result`/`output`. -/ /-- Agda: `WithProg.result`/`output`. -/
def output : String := def output : String :=
show' (result constFixedHeight (exprEvaluator prog).toStmtEvaluator) show' (result ConstLattice prog)
/-- Agda: `plus-valid`. -/ /-- Agda: `plus-valid`. -/
theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ} theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
@@ -267,9 +187,9 @@ theorem minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
show Value.int (z₁ - z₂) = Value.int (c₁ - c₂) show Value.int (z₁ - z₂) = Value.int (c₁ - c₂)
rw [hz₁, hz₂] rw [hz₁, hz₂]
/-- Agda: `eval-valid` / `ConstEvalValid`. -/ /-- Agda: `eval-valid` / the `ConstEvalValid` instance. -/
theorem eval_valid : instance eval_valid : ValidExprEvaluator ConstLattice prog := by
IsValidExprEvaluator (exprEvaluator prog) constInterpretation := by constructor
intro vs ρ e v hev intro vs ρ e v hev
induction hev with induction hev with
| num n => | num n =>
@@ -300,11 +220,8 @@ theorem eval_valid :
/-- Agda: `WithProg.analyze-correct`. -/ /-- Agda: `WithProg.analyze-correct`. -/
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) : theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
interpV constInterpretation interpV (variablesAt prog.finalState (result ConstLattice prog)) ρ :=
(variablesAt prog.finalState Spa.analyze_correct ConstLattice prog hrun
(result constFixedHeight (exprEvaluator prog).toStmtEvaluator)) ρ :=
Spa.analyze_correct constFixedHeight
((exprEvaluator prog).toStmtEvaluator_valid (eval_valid prog)) hrun
end ConstAnalysis end ConstAnalysis

127
lean/Spa/Analysis/Forward.lean
View File

@@ -2,6 +2,12 @@
Port of `Analysis/Forward.agda` (`WithProg`, `WithStmtEvaluator`, Port of `Analysis/Forward.agda` (`WithProg`, `WithStmtEvaluator`,
`WithValidInterpretation`). `WithValidInterpretation`).
As in Agda, the statement evaluator, the lattice interpretation and the
evaluator's validity proof are instance arguments (`{{evaluator}}`,
`{{latticeInterpretationˡ}}`, `{{validEvaluator}}`); `result` and
`analyze_correct` take `L` and `prog` explicitly, mirroring the Agda call
shape `WithProg.result L prog`.
Correspondence: Correspondence:
updateVariablesForState, -Monoʳ ↦ updateVariablesForState, _mono updateVariablesForState, -Monoʳ ↦ updateVariablesForState, _mono
updateAll, updateAll-Mono, updateAll, updateAll-Mono,
@@ -26,139 +32,136 @@ import Spa.Fixedpoint
namespace Spa namespace Spa
variable {L : Type} [Lattice L] [DecidableEq L] {prog : Program} {h : ℕ} variable {L : Type} [Lattice L] {prog : Program} [E : StmtEvaluator L prog]
(fhL : FixedHeight L h) (E : StmtEvaluator L prog)
/-- Agda: `updateVariablesForState`. -/ /-- Agda: `updateVariablesForState`. -/
def updateVariablesForState (s : prog.State) (sv : StateVariables L prog) : def updateVariablesForState (s : prog.State) (sv : StateVariables L prog) :
VariableValues L prog := VariableValues L prog :=
(prog.code s).foldl (fun vs bs => E.eval s bs vs) (variablesAt s sv) (prog.code s).foldl (fun vs bs => E.eval s bs vs) (variablesAt s sv)
omit [DecidableEq L] in
/-- Agda: `updateVariablesForState-Monoʳ`. -/ /-- Agda: `updateVariablesForState-Monoʳ`. -/
theorem updateVariablesForState_mono (s : prog.State) : theorem updateVariablesForState_mono (s : prog.State) :
Monotone (updateVariablesForState E s) := fun _ _ hle => Monotone (updateVariablesForState (L := L) s) := fun _ _ hle =>
foldl_mono' (prog.code s) _ (fun bs => E.eval_mono s bs) (variablesAt_le hle s) foldl_mono' (prog.code s) _ (fun bs => E.eval_mono s bs) (variablesAt_le hle s)
/-- Agda: `updateAll`. -/ /-- Agda: `updateAll`. -/
def updateAll (sv : StateVariables L prog) : StateVariables L prog := def updateAll (sv : StateVariables L prog) : StateVariables L prog :=
FiniteMap.generalizedUpdate id (fun s sv => updateVariablesForState E s sv) FiniteMap.generalizedUpdate id (fun s sv => updateVariablesForState s sv)
prog.states sv prog.states sv
omit [DecidableEq L] in
/-- Agda: `updateAll-Mono`. -/ /-- Agda: `updateAll-Mono`. -/
theorem updateAll_mono : Monotone (updateAll E) := theorem updateAll_mono : Monotone (updateAll (L := L) (prog := prog)) :=
FiniteMap.generalizedUpdate_monotone monotone_id (updateVariablesForState_mono E) FiniteMap.generalizedUpdate_monotone monotone_id updateVariablesForState_mono
omit [DecidableEq L] in
/-- Agda: `updateAll-k∈ks-≡`. -/ /-- Agda: `updateAll-k∈ks-≡`. -/
theorem updateAll_mem_eq {s : prog.State} {vs : VariableValues L prog} theorem updateAll_mem_eq {s : prog.State} {vs : VariableValues L prog}
{sv : StateVariables L prog} (hmem : (s, vs) ∈ updateAll E sv) : {sv : StateVariables L prog} (hmem : (s, vs) ∈ updateAll sv) :
vs = updateVariablesForState E s sv := vs = updateVariablesForState s sv :=
FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) hmem FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) hmem
omit [DecidableEq L] in
/-- Agda: `variablesAt-updateAll`. -/ /-- Agda: `variablesAt-updateAll`. -/
theorem variablesAt_updateAll (s : prog.State) (sv : StateVariables L prog) : theorem variablesAt_updateAll (s : prog.State) (sv : StateVariables L prog) :
variablesAt s (updateAll E sv) = updateVariablesForState E s sv := variablesAt s (updateAll sv) = updateVariablesForState s sv :=
updateAll_mem_eq E (variablesAt_mem s (updateAll E sv)) updateAll_mem_eq (variablesAt_mem s (updateAll sv))
variable [FiniteHeightLattice L]
/-- Agda: `analyze`. -/ /-- Agda: `analyze`. -/
def analyze (sv : StateVariables L prog) : StateVariables L prog := def analyze (sv : StateVariables L prog) : StateVariables L prog :=
updateAll E (joinAll fhL sv) updateAll (joinAll sv)
omit [DecidableEq L] in
/-- Agda: `analyze-Mono`. -/ /-- Agda: `analyze-Mono`. -/
theorem analyze_mono : Monotone (analyze fhL E) := fun _ _ hle => theorem analyze_mono : Monotone (analyze (L := L) (prog := prog)) := fun _ _ hle =>
updateAll_mono E (joinAll_mono fhL hle) updateAll_mono (joinAll_mono hle)
variable [DecidableEq L]
variable (L prog) in
/-- Agda: `result` (the least fixpoint of `analyze`). -/ /-- Agda: `result` (the least fixpoint of `analyze`). -/
def result : StateVariables L prog := def result : StateVariables L prog :=
Fixedpoint.aFix (statesFixedHeight L prog fhL) (analyze fhL E) (analyze_mono fhL E) Fixedpoint.aFix analyze analyze_mono
variable (L prog) in
/-- Agda: `result≈analyze-result`. -/ /-- Agda: `result≈analyze-result`. -/
theorem result_eq : result fhL E = analyze fhL E (result fhL E) := theorem result_eq : result L prog = analyze (result L prog) :=
Fixedpoint.aFix_eq (statesFixedHeight L prog fhL) (analyze fhL E) (analyze_mono fhL E) Fixedpoint.aFix_eq analyze analyze_mono
/-- Agda: `joinForKey-initialState-⊥ᵛ`. -/
theorem joinForKey_initialState :
joinForKey prog.initialState (result L prog) = botV L prog := by
rw [joinForKey, prog.incoming_initialState_eq_nil]
rfl
/-! ### Semantic correctness (Agda: `WithValidInterpretation`) -/ /-! ### Semantic correctness (Agda: `WithValidInterpretation`) -/
variable {I : LatticeInterpretation L} {E} variable [I : LatticeInterpretation L] [V : ValidStmtEvaluator L prog]
variable (hE : IsValidStmtEvaluator E I)
include hE
omit [DecidableEq L] in omit [FiniteHeightLattice L] [DecidableEq L] in
/-- Agda: `eval-fold-valid`. -/ /-- Agda: `eval-fold-valid`. -/
theorem eval_fold_valid {s : prog.State} {bss : List BasicStmt} theorem eval_fold_valid {s : prog.State} {bss : List BasicStmt}
{vs : VariableValues L prog} {ρ₁ ρ₂ : Env} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
(hbss : EvalBasicStmts ρ₁ bss ρ₂) (hvs : interpV I vs ρ₁) : (hbss : EvalBasicStmts ρ₁ bss ρ₂) (hvs : interpV vs ρ₁) :
interpV I (bss.foldl (fun vs bs => E.eval s bs vs) vs) ρ₂ := by interpV (bss.foldl (fun vs bs => E.eval s bs vs) vs) ρ₂ := by
induction hbss generalizing vs with induction hbss generalizing vs with
| nil => exact hvs | nil => exact hvs
| cons hbs _ ih => exact ih (hE hbs hvs) | cons hbs _ ih => exact ih (ValidStmtEvaluator.valid hbs hvs)
omit [DecidableEq L] in omit [FiniteHeightLattice L] [DecidableEq L] in
/-- Agda: `updateVariablesForState-matches`. -/ /-- Agda: `updateVariablesForState-matches`. -/
theorem updateVariablesForState_matches {s : prog.State} theorem updateVariablesForState_matches {s : prog.State}
{sv : StateVariables L prog} {ρ₁ ρ₂ : Env} {sv : StateVariables L prog} {ρ₁ ρ₂ : Env}
(hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂) (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
(hvs : interpV I (variablesAt s sv) ρ₁) : (hvs : interpV (variablesAt s sv) ρ₁) :
interpV I (updateVariablesForState E s sv) ρ₂ := interpV (updateVariablesForState s sv) ρ₂ :=
eval_fold_valid hE hbss hvs eval_fold_valid hbss hvs
omit [DecidableEq L] in omit [FiniteHeightLattice L] [DecidableEq L] in
/-- Agda: `updateAll-matches`. -/ /-- Agda: `updateAll-matches`. -/
theorem updateAll_matches {s : prog.State} {sv : StateVariables L prog} theorem updateAll_matches {s : prog.State} {sv : StateVariables L prog}
{ρ₁ ρ₂ : Env} (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂) {ρ₁ ρ₂ : Env} (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
(hvs : interpV I (variablesAt s sv) ρ₁) : (hvs : interpV (variablesAt s sv) ρ₁) :
interpV I (variablesAt s (updateAll E sv)) ρ₂ := by interpV (variablesAt s (updateAll sv)) ρ₂ := by
rw [variablesAt_updateAll] rw [variablesAt_updateAll]
exact updateVariablesForState_matches hE hbss hvs exact updateVariablesForState_matches hbss hvs
/-- Agda: `stepTrace`. -/ /-- Agda: `stepTrace`. -/
theorem stepTrace {s₁ : prog.State} {ρ₁ ρ₂ : Env} theorem stepTrace {s₁ : prog.State} {ρ₁ ρ₂ : Env}
(hjoin : interpV I (joinForKey fhL s₁ (result fhL E)) ρ₁) (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
(hbss : EvalBasicStmts ρ₁ (prog.code s₁) ρ₂) : (hbss : EvalBasicStmts ρ₁ (prog.code s₁) ρ₂) :
interpV I (variablesAt s₁ (result fhL E)) ρ₂ := by interpV (variablesAt s₁ (result L prog)) ρ₂ := by
rw [result_eq fhL E] rw [result_eq L prog]
refine updateAll_matches hE hbss ?_ refine updateAll_matches hbss ?_
rw [variablesAt_joinAll] rw [variablesAt_joinAll]
exact hjoin exact hjoin
/-- Agda: `walkTrace`. -/ /-- Agda: `walkTrace`. -/
theorem walkTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env} theorem walkTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
(hjoin : interpV I (joinForKey fhL s₁ (result fhL E)) ρ₁) (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
(tr : Trace prog.graph s₁ s₂ ρ₁ ρ₂) : (tr : Trace prog.graph s₁ s₂ ρ₁ ρ₂) :
interpV I (variablesAt s₂ (result fhL E)) ρ₂ := by interpV (variablesAt s₂ (result L prog)) ρ₂ := by
induction tr with induction tr with
| single hbss => exact stepTrace fhL hE hjoin hbss | single hbss => exact stepTrace hjoin hbss
| @edge _ ρ' _ i₁ i₂ _ hbss hedge _ ih => | @edge _ ρ' _ i₁ i₂ _ hbss hedge _ ih =>
have hstep : interpV I (variablesAt i₁ (result fhL E)) ρ' := have hstep : interpV (variablesAt i₁ (result L prog)) ρ' :=
stepTrace fhL hE hjoin hbss stepTrace hjoin hbss
have hmem : variablesAt i₁ (result fhL E) have hmem : variablesAt i₁ (result L prog)
∈ (result fhL E).valuesAt (prog.incoming i₂) := ∈ (result L prog).valuesAt (prog.incoming i₂) :=
FiniteMap.mem_valuesAt prog.states_nodup FiniteMap.mem_valuesAt prog.states_nodup
(prog.mem_incoming_of_edge hedge) (variablesAt_mem i₁ (result fhL E)) (prog.mem_incoming_of_edge hedge) (variablesAt_mem i₁ (result L prog))
exact ih (interpV_foldr fhL I hstep hmem) exact ih (interpV_foldr hstep hmem)
omit hE in omit V in
/-- Agda: `joinForKey-initialState-⊥ᵛ`. -/
theorem joinForKey_initialState :
joinForKey fhL prog.initialState (result fhL E) = botV L prog fhL := by
rw [joinForKey, prog.incoming_initialState_eq_nil]
rfl
omit hE in
/-- Agda: `⟦joinAll-initialState⟧ᵛ∅`. -/ /-- Agda: `⟦joinAll-initialState⟧ᵛ∅`. -/
theorem interpV_joinForKey_initialState : theorem interpV_joinForKey_initialState :
interpV I (joinForKey fhL prog.initialState (result fhL E)) [] := by interpV (joinForKey prog.initialState (result L prog)) [] := by
rw [joinForKey_initialState] rw [joinForKey_initialState]
exact interpV_botV_nil fhL I exact interpV_botV_nil
variable (L prog) in
/-- Agda: `analyze-correct` — the analysis result at the final state soundly /-- Agda: `analyze-correct` — the analysis result at the final state soundly
describes every terminating execution of the program. -/ describes every terminating execution of the program. -/
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) : theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
interpV I (variablesAt prog.finalState (result fhL E)) ρ := interpV (variablesAt prog.finalState (result L prog)) ρ :=
walkTrace fhL hE (interpV_joinForKey_initialState fhL (E := E) (I := I)) walkTrace interpV_joinForKey_initialState (prog.trace hrun)
(prog.trace hrun)
end Spa end Spa

38
lean/Spa/Analysis/Forward/Adapters.lean
View File

@@ -6,8 +6,8 @@ Correspondence:
updateVariablesFromExpression-Mono ↦ updateVariablesFromExpression_mono updateVariablesFromExpression-Mono ↦ updateVariablesFromExpression_mono
(the -k∈ks-≡ / -k∉ks-backward renames ↦ used directly from FiniteMap) (the -k∈ks-≡ / -k∉ks-backward renames ↦ used directly from FiniteMap)
evalᵇ, evalᵇ-Monoʳ ↦ evalB, evalB_mono evalᵇ, evalᵇ-Monoʳ ↦ evalB, evalB_mono
stmtEvaluator (instance) ↦ ExprEvaluator.toStmtEvaluator stmtEvaluator (instance) ↦ instance StmtEvaluator L prog
evalᵇ-valid, validStmtEvaluator ↦ ExprEvaluator.toStmtEvaluator_valid evalᵇ-valid, validStmtEvaluator ↦ instance ValidStmtEvaluator L prog
(the Agda `k ≟ˢ k'` case split is (the Agda `k ≟ˢ k'` case split is
subsumed by `cases` on `Env.Mem`, subsumed by `cases` on `Env.Mem`,
whose `here` case forces `k' = k`) whose `here` case forces `k' = k`)
@@ -16,43 +16,41 @@ import Spa.Analysis.Forward.Evaluation
namespace Spa namespace Spa
variable {L : Type} [Lattice L] {prog : Program} variable {L : Type} [Lattice L] {prog : Program} [E : ExprEvaluator L prog]
/-- Agda: `updateVariablesFromExpression` — set the single key `k` to the /-- Agda: `updateVariablesFromExpression` — set the single key `k` to the
value of `e` (the `GeneralizedUpdate` with `ks = [k]`). -/ value of `e` (the `GeneralizedUpdate` with `ks = [k]`). -/
def updateVariablesFromExpression (E : ExprEvaluator L prog) (k : String) def updateVariablesFromExpression (k : String) (e : Expr)
(e : Expr) (vs : VariableValues L prog) : VariableValues L prog := (vs : VariableValues L prog) : VariableValues L prog :=
FiniteMap.generalizedUpdate id (fun _ vs => E.eval e vs) [k] vs FiniteMap.generalizedUpdate id (fun _ vs => E.eval e vs) [k] vs
/-- Agda: `updateVariablesFromExpression-Mono`. -/ /-- Agda: `updateVariablesFromExpression-Mono`. -/
theorem updateVariablesFromExpression_mono (E : ExprEvaluator L prog) theorem updateVariablesFromExpression_mono (k : String) (e : Expr) :
(k : String) (e : Expr) : Monotone (updateVariablesFromExpression (L := L) (prog := prog) k e) :=
Monotone (updateVariablesFromExpression E k e) :=
FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => E.eval_mono e) FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => E.eval_mono e)
/-- Agda: `evalᵇ`. -/ /-- Agda: `evalᵇ`. -/
def evalB (E : ExprEvaluator L prog) (_ : prog.State) (bs : BasicStmt) def evalB (_ : prog.State) (bs : BasicStmt)
(vs : VariableValues L prog) : VariableValues L prog := (vs : VariableValues L prog) : VariableValues L prog :=
match bs with match bs with
| .assign k e => updateVariablesFromExpression E k e vs | .assign k e => updateVariablesFromExpression k e vs
| .noop => vs | .noop => vs
/-- Agda: `evalᵇ-Monoʳ`. -/ /-- Agda: `evalᵇ-Monoʳ`. -/
theorem evalB_mono (E : ExprEvaluator L prog) (s : prog.State) (bs : BasicStmt) : theorem evalB_mono (s : prog.State) (bs : BasicStmt) :
Monotone (evalB E s bs) := by Monotone (evalB (L := L) (prog := prog) s bs) := by
cases bs with cases bs with
| assign k e => exact updateVariablesFromExpression_mono E k e | assign k e => exact updateVariablesFromExpression_mono k e
| noop => exact monotone_id | noop => exact monotone_id
/-- Agda: the `stmtEvaluator` instance of `ExprToStmtAdapter`. -/ /-- Agda: the `stmtEvaluator` instance of `ExprToStmtAdapter`. -/
def ExprEvaluator.toStmtEvaluator (E : ExprEvaluator L prog) : instance ExprEvaluator.toStmtEvaluator : StmtEvaluator L prog :=
StmtEvaluator L prog := ⟨evalB, evalB_mono⟩
⟨evalB E, evalB_mono E⟩
/-- Agda: `evalᵇ-valid` / the `validStmtEvaluator` instance. -/ /-- Agda: `evalᵇ-valid` / the `validStmtEvaluator` instance. -/
theorem ExprEvaluator.toStmtEvaluator_valid (E : ExprEvaluator L prog) instance ExprEvaluator.toStmtEvaluator_valid [LatticeInterpretation L]
{I : LatticeInterpretation L} (hE : IsValidExprEvaluator E I) : [ValidExprEvaluator L prog] : ValidStmtEvaluator L prog := by
IsValidStmtEvaluator E.toStmtEvaluator I := by constructor
intro s vs ρ₁ ρ₂ bs hbs hvs intro s vs ρ₁ ρ₂ bs hbs hvs
cases hbs with cases hbs with
| noop => exact hvs | noop => exact hvs
@@ -65,7 +63,7 @@ theorem ExprEvaluator.toStmtEvaluator_valid (E : ExprEvaluator L prog)
have hl := FiniteMap.generalizedUpdate_mem_eq (f := id) have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
(g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hk'l₀ (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hk'l₀
rw [hl] rw [hl]
exact hE hev hvs exact ValidExprEvaluator.valid hev hvs
| there _ _ _ _ _ hne hmem' => | there _ _ _ _ _ hne hmem' =>
have hk'l₀ : (k', l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id have hk'l₀ : (k', l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
(fun _ vs => E.eval e vs) [k] vs := hk'l (fun _ vs => E.eval e vs) [k] vs := hk'l

39
lean/Spa/Analysis/Forward/Evaluation.lean
View File

@@ -1,15 +1,15 @@
/- /-
Port of `Analysis/Forward/Evaluation.agda`. Port of `Analysis/Forward/Evaluation.agda`.
All four records were consumed through Agda instance arguments (`{{evaluator :
StmtEvaluator}}`, `{{validEvaluator : ValidStmtEvaluator …}}`), so they are
typeclasses here as well.
Correspondence: Correspondence:
StmtEvaluator (eval, eval-Monoʳ) ↦ StmtEvaluator (eval, eval_mono) StmtEvaluator (eval, eval-Monoʳ) ↦ StmtEvaluator (eval, eval_mono)
ExprEvaluator (eval, eval-Monoʳ) ↦ ExprEvaluator (eval, eval_mono) ExprEvaluator (eval, eval-Monoʳ) ↦ ExprEvaluator (eval, eval_mono)
IsValidExprEvaluator ↦ IsValidExprEvaluator ValidExprEvaluator ↦ ValidExprEvaluator (valid)
IsValidStmtEvaluator ↦ IsValidStmtEvaluator ValidStmtEvaluator ↦ ValidStmtEvaluator (valid)
ValidExprEvaluator,
ValidStmtEvaluator (records) ↦ (the `IsValid…` Props are passed
directly; the wrapper records existed
for Agda instance resolution)
-/ -/
import Spa.Analysis.Forward.Lattices import Spa.Analysis.Forward.Lattices
@@ -18,27 +18,26 @@ namespace Spa
variable (L : Type) [Lattice L] (prog : Program) variable (L : Type) [Lattice L] (prog : Program)
/-- Agda: `StmtEvaluator`. -/ /-- Agda: `StmtEvaluator`. -/
structure StmtEvaluator where class StmtEvaluator where
eval : prog.State → BasicStmt → VariableValues L prog → VariableValues L prog eval : prog.State → BasicStmt → VariableValues L prog → VariableValues L prog
eval_mono : ∀ s bs, Monotone (eval s bs) eval_mono : ∀ s bs, Monotone (eval s bs)
/-- Agda: `ExprEvaluator`. -/ /-- Agda: `ExprEvaluator`. -/
structure ExprEvaluator where class ExprEvaluator where
eval : Expr → VariableValues L prog → L eval : Expr → VariableValues L prog → L
eval_mono : ∀ e, Monotone (eval e) eval_mono : ∀ e, Monotone (eval e)
variable {L prog} /-- Agda: `ValidExprEvaluator`. -/
class ValidExprEvaluator [ExprEvaluator L prog] [I : LatticeInterpretation L] :
Prop where
valid : ∀ {vs : VariableValues L prog} {ρ : Env} {e : Expr} {v : Value},
EvalExpr ρ e v → interpV vs ρ → I.interp (ExprEvaluator.eval e vs) v
/-- Agda: `IsValidExprEvaluator`. -/ /-- Agda: `ValidStmtEvaluator`. -/
def IsValidExprEvaluator (E : ExprEvaluator L prog) class ValidStmtEvaluator [E : StmtEvaluator L prog] [LatticeInterpretation L] :
(I : LatticeInterpretation L) : Prop := Prop where
∀ {vs : VariableValues L prog} {ρ : Env} {e : Expr} {v : Value}, valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
EvalExpr ρ e v → interpV I vs ρ → I.interp (E.eval e vs) v {bs : BasicStmt},
EvalBasicStmt ρ₁ bs ρ₂ → interpV vs ρ₁ → interpV (E.eval s bs vs) ρ₂
/-- Agda: `IsValidStmtEvaluator`. -/
def IsValidStmtEvaluator (E : StmtEvaluator L prog)
(I : LatticeInterpretation L) : Prop :=
∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env} {bs : BasicStmt},
EvalBasicStmt ρ₁ bs ρ₂ → interpV I vs ρ₁ → interpV I (E.eval s bs vs) ρ₂
end Spa end Spa

60
lean/Spa/Analysis/Forward/Lattices.lean
View File

@@ -5,12 +5,13 @@ The Agda module instantiates `Lattice.FiniteMap` twice (variables ↦ abstract
values, states ↦ variable maps) and re-exports everything with ᵛ/ᵐ suffixes. values, states ↦ variable maps) and re-exports everything with ᵛ/ᵐ suffixes.
In Lean the two instantiations are `abbrev`s and the FiniteMap API is used In Lean the two instantiations are `abbrev`s and the FiniteMap API is used
directly; the module parameters (the finite-height lattice `L`, the program) directly; the module parameters (the finite-height lattice `L`, the program)
become section variables. become section variables, with the finite-height structure and the lattice
interpretation arriving by instance resolution as in Agda.
Correspondence: Correspondence:
VariableValues, StateVariables ↦ VariableValues, StateVariables VariableValues, StateVariables ↦ VariableValues, StateVariables
isLatticeᵛ/isLatticeᵐ, ⊔ᵛ, ≼ᵛ … ↦ (the FiniteMap Lattice instances) isLatticeᵛ/isLatticeᵐ, ⊔ᵛ, ≼ᵛ … ↦ (the FiniteMap Lattice instances)
fixedHeightᵛ ↦ varsFixedHeight fixedHeightᵛ, fixedHeightᵐ ↦ (the FiniteMap FiniteHeightLattice instance)
⊥ᵛ, ⊥ᵛ-contains-bottoms ↦ botV, FiniteMap.bot_contains_bots ⊥ᵛ, ⊥ᵛ-contains-bottoms ↦ botV, FiniteMap.bot_contains_bots
states-in-Map ↦ states_memKey states-in-Map ↦ states_memKey
variablesAt ↦ variablesAt variablesAt ↦ variablesAt
@@ -39,22 +40,9 @@ abbrev VariableValues : Type := FiniteMap String L prog.vars
/-- Agda: `StateVariables`. -/ /-- Agda: `StateVariables`. -/
abbrev StateVariables : Type := FiniteMap prog.State (VariableValues L prog) prog.states abbrev StateVariables : Type := FiniteMap prog.State (VariableValues L prog) prog.states
variable {h : ℕ} /-- Agda: `⊥ᵛ` (the bottom of `fixedHeightᵛ`, now found by instance search). -/
def botV [FiniteHeightLattice L] : VariableValues L prog :=
/-- Agda: `fixedHeightᵛ`. -/ FiniteHeightLattice.bot (VariableValues L prog)
def varsFixedHeight (fhL : FixedHeight L h) :
FixedHeight (VariableValues L prog) (prog.vars.length * h) :=
FiniteMap.fixedHeight fhL prog.vars
/-- Agda: `⊥ᵛ`. -/
def botV (fhL : FixedHeight L h) : VariableValues L prog :=
(varsFixedHeight L prog fhL).bot
/-- Agda: `fixedHeight` on `StateVariables` (assembled in `Forward.agda`'s
fixpoint call; named here for reuse). -/
def statesFixedHeight (fhL : FixedHeight L h) :
FixedHeight (StateVariables L prog) (prog.states.length * (prog.vars.length * h)) :=
FiniteMap.fixedHeight (varsFixedHeight L prog fhL) prog.states
variable {L prog} variable {L prog}
@@ -81,16 +69,16 @@ theorem variablesAt_le {sv₁ sv₂ : StateVariables L prog} (hle : sv₁ ≤ sv
FiniteMap.le_of_mem_mem prog.states_nodup hle FiniteMap.le_of_mem_mem prog.states_nodup hle
(variablesAt_mem s sv₁) (variablesAt_mem s sv₂) (variablesAt_mem s sv₁) (variablesAt_mem s sv₂)
variable (fhL : FixedHeight L h) variable [FiniteHeightLattice L]
/-- Agda: `joinForKey`. -/ /-- Agda: `joinForKey`. -/
def joinForKey (k : prog.State) (sv : StateVariables L prog) : def joinForKey (k : prog.State) (sv : StateVariables L prog) :
VariableValues L prog := VariableValues L prog :=
(sv.valuesAt (prog.incoming k)).foldr (· ⊔ ·) (botV L prog fhL) (sv.valuesAt (prog.incoming k)).foldr (· ⊔ ·) (botV L prog)
/-- Agda: `joinForKey-Mono`. -/ /-- Agda: `joinForKey-Mono`. -/
theorem joinForKey_mono (k : prog.State) : theorem joinForKey_mono (k : prog.State) :
Monotone (joinForKey fhL k) := by Monotone (joinForKey (L := L) k) := by
intro sv₁ sv₂ hle intro sv₁ sv₂ hle
exact foldr_mono _ (FiniteMap.valuesAt_le hle (prog.incoming k)) (le_refl _) exact foldr_mono _ (FiniteMap.valuesAt_le hle (prog.incoming k)) (le_refl _)
(fun b _ _ hab => sup_le_sup_right hab b) (fun b _ _ hab => sup_le_sup_right hab b)
@@ -98,40 +86,42 @@ theorem joinForKey_mono (k : prog.State) :
/-- Agda: `joinAll` (the "Exercise 4.26" generalized update with `f = id`). -/ /-- Agda: `joinAll` (the "Exercise 4.26" generalized update with `f = id`). -/
def joinAll (sv : StateVariables L prog) : StateVariables L prog := def joinAll (sv : StateVariables L prog) : StateVariables L prog :=
FiniteMap.generalizedUpdate id (joinForKey fhL) prog.states sv FiniteMap.generalizedUpdate id joinForKey prog.states sv
/-- Agda: `joinAll-Mono`. -/ /-- Agda: `joinAll-Mono`. -/
theorem joinAll_mono : Monotone (joinAll (prog := prog) fhL) := theorem joinAll_mono : Monotone (joinAll (L := L) (prog := prog)) :=
FiniteMap.generalizedUpdate_monotone monotone_id (joinForKey_mono fhL) FiniteMap.generalizedUpdate_monotone monotone_id joinForKey_mono
/-- Agda: `joinAll-k∈ks-≡`. -/ /-- Agda: `joinAll-k∈ks-≡`. -/
theorem joinAll_mem_eq {s : prog.State} {vs : VariableValues L prog} theorem joinAll_mem_eq {s : prog.State} {vs : VariableValues L prog}
{sv : StateVariables L prog} (h : (s, vs) ∈ joinAll fhL sv) : {sv : StateVariables L prog} (h : (s, vs) ∈ joinAll sv) :
vs = joinForKey fhL s sv := vs = joinForKey s sv :=
FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) h FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) h
/-- Agda: `variablesAt-joinAll`. -/ /-- Agda: `variablesAt-joinAll`. -/
theorem variablesAt_joinAll (s : prog.State) (sv : StateVariables L prog) : theorem variablesAt_joinAll (s : prog.State) (sv : StateVariables L prog) :
variablesAt s (joinAll fhL sv) = joinForKey fhL s sv := variablesAt s (joinAll sv) = joinForKey s sv :=
joinAll_mem_eq fhL (variablesAt_mem s (joinAll fhL sv)) joinAll_mem_eq (variablesAt_mem s (joinAll sv))
/-! ### Lifting an interpretation to variable maps -/ /-! ### Lifting an interpretation to variable maps -/
variable (I : LatticeInterpretation L) variable [I : LatticeInterpretation L]
omit [FiniteHeightLattice L] in
/-- Agda: `⟦_⟧ᵛ`. -/ /-- Agda: `⟦_⟧ᵛ`. -/
def interpV (vs : VariableValues L prog) (ρ : Env) : Prop := def interpV (vs : VariableValues L prog) (ρ : Env) : Prop :=
∀ (k : String) (l : L), (k, l) ∈ vs → ∀ (k : String) (l : L), (k, l) ∈ vs →
∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v ∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v
/-- Agda: `⟦⊥ᵛ⟧ᵛ∅`. -/ /-- Agda: `⟦⊥ᵛ⟧ᵛ∅`. -/
theorem interpV_botV_nil : interpV I (botV L prog fhL) [] := by theorem interpV_botV_nil : interpV (botV L prog) [] := by
intro k l _ v hmem intro k l _ v hmem
cases hmem cases hmem
omit [FiniteHeightLattice L] in
/-- Agda: `⟦⟧ᵛ-⊔ᵛ-∨`. -/ /-- Agda: `⟦⟧ᵛ-⊔ᵛ-∨`. -/
theorem interpV_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env} theorem interpV_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env}
(h : interpV I vs₁ ρ ∨ interpV I vs₂ ρ) : interpV I (vs₁ ⊔ vs₂) ρ := by (h : interpV vs₁ ρ ∨ interpV vs₂ ρ) : interpV (vs₁ ⊔ vs₂) ρ := by
intro k l hmem v hv intro k l hmem v hv
obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem
rcases h with h | h rcases h with h | h
@@ -141,13 +131,13 @@ theorem interpV_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env}
/-- Agda: `⟦⟧ᵛ-foldr`. -/ /-- Agda: `⟦⟧ᵛ-foldr`. -/
theorem interpV_foldr {vs : VariableValues L prog} theorem interpV_foldr {vs : VariableValues L prog}
{vss : List (VariableValues L prog)} {ρ : Env} {vss : List (VariableValues L prog)} {ρ : Env}
(hvs : interpV I vs ρ) (hmem : vs ∈ vss) : (hvs : interpV vs ρ) (hmem : vs ∈ vss) :
interpV I (vss.foldr (· ⊔ ·) (botV L prog fhL)) ρ := by interpV (vss.foldr (· ⊔ ·) (botV L prog)) ρ := by
induction vss with induction vss with
| nil => cases hmem | nil => cases hmem
| cons vs' vss' ih => | cons vs' vss' ih =>
rcases List.mem_cons.mp hmem with rfl | hmem' rcases List.mem_cons.mp hmem with rfl | hmem'
· exact interpV_sup I (Or.inl hvs) · exact interpV_sup (Or.inl hvs)
· exact interpV_sup I (Or.inr (ih hmem')) · exact interpV_sup (Or.inr (ih hmem'))
end Spa end Spa

168
lean/Spa/Analysis/Sign.lean
View File

@@ -5,11 +5,13 @@ Correspondence:
Sign (+ / - / 0ˢ) ↦ Sign.plus / Sign.minus / Sign.zero Sign (+ / - / 0ˢ) ↦ Sign.plus / Sign.minus / Sign.zero
_≟ᵍ_, ≡-equiv, ≡-Decidable ↦ deriving DecidableEq _≟ᵍ_, ≡-equiv, ≡-Decidable ↦ deriving DecidableEq
SignLattice (AboveBelow) ↦ SignLattice SignLattice (AboveBelow) ↦ SignLattice
AB.Plain 0ˢ ↦ signFixedHeight (AboveBelow.plainFixedHeight .zero) AB.Plain 0ˢ ↦ the AboveBelow FiniteHeightLattice instance,
seeded by `Inhabited Sign := ⟨.zero⟩`
plus, minus ↦ plus, minus plus, minus ↦ plus, minus
plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!) plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
↦ plus_mono_left/right, minus_mono_left/right — ↦ plus_mono_left/right, minus_mono_left/right —
now actually proved, via AboveBelow.le_cases now actually proved, via
AboveBelow.monotone₂_of_strict
plus-Mono₂, minus-Mono₂ ↦ plus_mono₂, minus_mono₂ plus-Mono₂, minus-Mono₂ ↦ plus_mono₂, minus_mono₂
⟦_⟧ᵍ ↦ interpSign ⟦_⟧ᵍ ↦ interpSign
⟦⟧ᵍ-respects-≈ᵍ ↦ (trivial with `=`) ⟦⟧ᵍ-respects-≈ᵍ ↦ (trivial with `=`)
@@ -41,15 +43,12 @@ instance : Showable Sign :=
| .minus => "-" | .minus => "-"
| .zero => "0"⟩ | .zero => "0"⟩
/-- Agda: the module parameter `x = 0ˢ` of `AB.Plain`. -/ /-- Agda: the module parameter `x = 0ˢ` of `AB.Plain` (it seeds the
`FiniteHeightLattice (AboveBelow Sign)` instance). -/
instance : Inhabited Sign := ⟨.zero⟩ instance : Inhabited Sign := ⟨.zero⟩
abbrev SignLattice : Type := AboveBelow Sign abbrev SignLattice : Type := AboveBelow Sign
/-- Agda: `AB.Plain 0ˢ`'s `fixedHeight`. -/
def signFixedHeight : FixedHeight SignLattice 2 :=
AboveBelow.plainFixedHeight Sign.zero
open AboveBelow in open AboveBelow in
/-- Agda: `plus`. -/ /-- Agda: `plus`. -/
def plus : SignLattice → SignLattice → SignLattice def plus : SignLattice → SignLattice → SignLattice
@@ -84,81 +83,39 @@ def minus : SignLattice → SignLattice → SignLattice
| mk .zero, mk .minus => mk .plus | mk .zero, mk .minus => mk .plus
| mk .zero, mk .zero => mk .zero | mk .zero, mk .zero => mk .zero
/-- Agda: `plus-Mono₂` (its components were postulates in Agda; `plus` is a
strict operation on the flat lattice, so monotonicity holds regardless of the
sign table). -/
theorem plus_mono₂ : Monotone₂ plus :=
AboveBelow.monotone₂_of_strict plus
(fun y => by cases y <;> rfl)
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by
rcases x with _ | _ | s <;>
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/ /-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
theorem plus_mono_left (s₂ : SignLattice) : Monotone (plus · s₂) := by theorem plus_mono_left (s₂ : SignLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/ /-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
theorem plus_mono_right (s₁ : SignLattice) : Monotone (plus s₁) := by theorem plus_mono_right (s₁ : SignLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
simp only [plus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `plus-Mono₂`. -/ /-- Agda: `minus-Mono₂` (likewise from strictness of `minus`). -/
theorem plus_mono₂ : Monotone₂ plus := theorem minus_mono₂ : Monotone₂ minus :=
⟨plus_mono_left, plus_mono_right⟩ AboveBelow.monotone₂_of_strict minus
(fun y => by cases y <;> rfl)
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
(fun x hx => by
rcases x with _ | _ | s <;>
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
/-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/ /-- Agda: `minus-Monoˡ` — a postulate there, a theorem here. -/
theorem minus_mono_left (s₂ : SignLattice) : Monotone (minus · s₂) := by theorem minus_mono_left (s₂ : SignLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₂ with _ | _ | y <;> rcases b with _ | _ | x <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₂ with _ | _ | y <;> rcases a with _ | _ | x <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/ /-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
theorem minus_mono_right (s₁ : SignLattice) : Monotone (minus s₁) := by theorem minus_mono_right (s₁ : SignLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
intro a b h
rcases AboveBelow.le_cases h with rfl | rfl | rfl
· rcases s₁ with _ | _ | x <;> rcases b with _ | _ | y <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
| exact AboveBelow.bot_le' _
· rcases s₁ with _ | _ | x <;> rcases a with _ | _ | y <;>
simp only [minus] <;>
first
| exact le_refl _
| exact AboveBelow.le_top' _
· exact le_refl _
/-- Agda: `minus-Mono₂`. -/
theorem minus_mono₂ : Monotone₂ minus :=
⟨minus_mono_left, minus_mono_right⟩
/-- Agda: `⟦_⟧ᵍ`. -/ /-- Agda: `⟦_⟧ᵍ`. -/
def interpSign : SignLattice → Value → Prop def interpSign : SignLattice → Value → Prop
@@ -197,48 +154,18 @@ theorem interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Val
injection hv with hz injection hv with hz
omega omega
/-- Agda: `⟦⟧ᵍ-⊔ᵍ-∨`. -/ /-- Agda: `⟦⟧ᵍ-⊔ᵍ-∨` (via the factored flat-lattice lemma). -/
theorem interpSign_sup {s₁ s₂ : SignLattice} (v : Value) theorem interpSign_sup {s₁ s₂ : SignLattice} (v : Value)
(h : interpSign s₁ v ∨ interpSign s₂ v) : interpSign (s₁ ⊔ s₂) v := by (h : interpSign s₁ v ∨ interpSign s₂ v) : interpSign (s₁ ⊔ s₂) v :=
rcases s₁ with _ | _ | x AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
· rcases h with h | h
· exact h.elim
· rw [AboveBelow.bot_sup]
exact h
· exact trivial
· rcases s₂ with _ | _ | y
· rcases h with h | h
· rw [AboveBelow.sup_bot]
exact h
· exact h.elim
· rw [AboveBelow.sup_top]
exact trivial
· by_cases hxy : x = y
· subst hxy
rw [AboveBelow.mk_sup_mk, if_pos rfl]
rcases h with h | h <;> exact h
· rw [AboveBelow.mk_sup_mk, if_neg hxy]
exact trivial
/-- Agda: `⟦⟧ᵍ-⊓ᵍ-∧`. -/ /-- Agda: `⟦⟧ᵍ-⊓ᵍ-∧` (via the factored flat-lattice lemma). -/
theorem interpSign_inf {s₁ s₂ : SignLattice} (v : Value) theorem interpSign_inf {s₁ s₂ : SignLattice} (v : Value)
(h : interpSign s₁ v ∧ interpSign s₂ v) : interpSign (s₁ ⊓ s₂) v := by (h : interpSign s₁ v ∧ interpSign s₂ v) : interpSign (s₁ ⊓ s₂) v :=
rcases s₁ with _ | _ | x AboveBelow.interp_inf_of (fun hne _ => interpSign_mk_disjoint hne) v h
· exact h.1
· rw [AboveBelow.top_inf]
exact h.2
· rcases s₂ with _ | _ | y
· exact h.2
· rw [AboveBelow.inf_top]
exact h.1
· by_cases hxy : x = y
· subst hxy
rw [AboveBelow.mk_inf_mk, if_pos rfl]
exact h.1
· exact absurd h (interpSign_mk_disjoint hxy)
/-- Agda: `latticeInterpretationᵍ`. -/ /-- Agda: `latticeInterpretationᵍ` (an instance there too). -/
def signInterpretation : LatticeInterpretation SignLattice where instance signInterpretation : LatticeInterpretation SignLattice where
interp := interpSign interp := interpSign
interp_sup := fun {l₁ l₂} v h => interpSign_sup (s₁ := l₁) (s₂ := l₂) v h interp_sup := fun {l₁ l₂} v h => interpSign_sup (s₁ := l₁) (s₂ := l₂) v h
interp_inf := fun {l₁ l₂} v h => interpSign_inf (s₁ := l₁) (s₂ := l₂) v h interp_inf := fun {l₁ l₂} v h => interpSign_inf (s₁ := l₁) (s₂ := l₂) v h
@@ -282,12 +209,12 @@ theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
cases n <;> exact le_refl _ cases n <;> exact le_refl _
/-- Agda: the `SignEval` instance. -/ /-- Agda: the `SignEval` instance. -/
def exprEvaluator : ExprEvaluator SignLattice prog := instance exprEvaluator : ExprEvaluator SignLattice prog :=
⟨eval prog, eval_mono prog⟩ ⟨eval prog, eval_mono prog⟩
/-- Agda: `WithProg.result`/`output` — the analysis result, printed. -/ /-- Agda: `WithProg.result`/`output` — the analysis result, printed. -/
def output : String := def output : String :=
show' (result signFixedHeight (exprEvaluator prog).toStmtEvaluator) show' (result SignLattice prog)
/-- Agda: `plus-valid`. -/ /-- Agda: `plus-valid`. -/
theorem plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ} theorem plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
@@ -365,9 +292,9 @@ theorem minus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
subst h₂ subst h₂
omega omega
/-- Agda: `eval-valid` / `SignEvalValid`. -/ /-- Agda: `eval-valid` / the `SignEvalValid` instance. -/
theorem eval_valid : instance eval_valid : ValidExprEvaluator SignLattice prog := by
IsValidExprEvaluator (exprEvaluator prog) signInterpretation := by constructor
intro vs ρ e v hev intro vs ρ e v hev
induction hev with induction hev with
| num n => | num n =>
@@ -400,11 +327,8 @@ theorem eval_valid :
/-- Agda: `WithProg.analyze-correct`. -/ /-- Agda: `WithProg.analyze-correct`. -/
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) : theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
interpV signInterpretation interpV (variablesAt prog.finalState (result SignLattice prog)) ρ :=
(variablesAt prog.finalState Spa.analyze_correct SignLattice prog hrun
(result signFixedHeight (exprEvaluator prog).toStmtEvaluator)) ρ :=
Spa.analyze_correct signFixedHeight
((exprEvaluator prog).toStmtEvaluator_valid (eval_valid prog)) hrun
end SignAnalysis end SignAnalysis

49
lean/Spa/Fixedpoint.lean
View File

@@ -7,6 +7,10 @@ steps, or we would build a `<`-chain longer than the longest one. We
deliberately do *not* use mathlib's `OrderHom.lfp` (different proof approach, deliberately do *not* use mathlib's `OrderHom.lfp` (different proof approach,
and not computable). and not computable).
As in Agda — where the module took `{{flA : IsFiniteHeightLattice A h …}}` —
the finite-height structure arrives by instance resolution
(`[FiniteHeightLattice α]`); only `f` and its monotonicity are explicit.
Correspondence: Correspondence:
doStep ↦ Spa.Fixedpoint.doStep (the chain argument now carries doStep ↦ Spa.Fixedpoint.doStep (the chain argument now carries
`a₁ = ⊥` and its length in the `a₁ = ⊥` and its length in the
@@ -21,55 +25,58 @@ import Spa.Lattice
namespace Spa.Fixedpoint namespace Spa.Fixedpoint
variable {α : Type*} [Lattice α] [DecidableEq α] {h : ℕ} open FiniteHeightLattice (height fixedHeight)
variable {α : Type*} [Lattice α] [DecidableEq α] [FiniteHeightLattice α]
/-- Agda: `doStep`. `g` is gas; the invariant `c.length + g = h + 1` guarantees /-- Agda: `doStep`. `g` is gas; the invariant `c.length + g = h + 1` guarantees
that when gas runs out the chain contradicts boundedness. -/ that when gas runs out the chain contradicts boundedness. -/
def doStep (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) : def doStep (f : α → α) (hf : Monotone f) :
∀ (g : ℕ) (c : LTSeries α), c.length + g = h + 1 → ∀ (g : ℕ) (c : LTSeries α), c.length + g = height (α := α) + 1 →
c.last ≤ f c.last → {a : α // a = f a} c.last ≤ f c.last → {a : α // a = f a}
| 0, c, hlen, _ => | 0, c, hlen, _ =>
absurd (fh.bounded c) (by omega) absurd ((fixedHeight (α := α)).bounded c) (by omega)
| g + 1, c, hlen, hle => | g + 1, c, hlen, hle =>
if heq : c.last = f c.last then if heq : c.last = f c.last then
⟨c.last, heq⟩ ⟨c.last, heq⟩
else else
doStep fh f hf g (c.snoc (f c.last) (lt_of_le_of_ne hle heq)) doStep f hf g (c.snoc (f c.last) (lt_of_le_of_ne hle heq))
(by simp [RelSeries.snoc]; omega) (by simp [RelSeries.snoc]; omega)
(by rw [RelSeries.last_snoc]; exact hf hle) (by rw [RelSeries.last_snoc]; exact hf hle)
/-- Agda: `fix`. Start iterating from `⊥`. -/ /-- Agda: `fix`. Start iterating from `⊥`. -/
def fix (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) : {a : α // a = f a} := def fix (f : α → α) (hf : Monotone f) : {a : α // a = f a} :=
doStep fh f hf (h + 1) (RelSeries.singleton _ fh.bot) doStep f hf (height (α := α) + 1) (RelSeries.singleton _ (FiniteHeightLattice.bot α))
(by simp) (by simp)
(by simpa [RelSeries.last_singleton] using fh.bot_le (f fh.bot)) (by simpa [RelSeries.last_singleton]
using FiniteHeightLattice.bot_le α (f (FiniteHeightLattice.bot α)))
/-- Agda: `aᶠ`. -/ /-- Agda: `aᶠ`. -/
def aFix (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) : α := def aFix (f : α → α) (hf : Monotone f) : α :=
(fix fh f hf).1 (fix f hf).1
/-- Agda: `aᶠ≈faᶠ`. -/ /-- Agda: `aᶠ≈faᶠ`. -/
theorem aFix_eq (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) : theorem aFix_eq (f : α → α) (hf : Monotone f) :
aFix fh f hf = f (aFix fh f hf) := aFix f hf = f (aFix f hf) :=
(fix fh f hf).2 (fix f hf).2
/-- Agda: `stepPreservesLess` — iteration stays below any fixed point. -/ /-- Agda: `stepPreservesLess` — iteration stays below any fixed point. -/
theorem doStep_le (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) theorem doStep_le (f : α → α) (hf : Monotone f)
{b : α} (hb : b = f b) : {b : α} (hb : b = f b) :
∀ (g : ℕ) (c : LTSeries α) (hlen : c.length + g = h + 1) ∀ (g : ℕ) (c : LTSeries α) (hlen : c.length + g = height (α := α) + 1)
(hle : c.last ≤ f c.last), c.last ≤ b → (hle : c.last ≤ f c.last), c.last ≤ b →
(doStep fh f hf g c hlen hle : α) ≤ b (doStep f hf g c hlen hle : α) ≤ b
| 0, c, hlen, _ => fun _ => absurd (fh.bounded c) (by omega) | 0, c, hlen, _ => fun _ => absurd ((fixedHeight (α := α)).bounded c) (by omega)
| g + 1, c, hlen, hle => fun hcb => by | g + 1, c, hlen, hle => fun hcb => by
rw [doStep] rw [doStep]
split split
· exact hcb · exact hcb
· exact doStep_le fh f hf hb g _ _ _ · exact doStep_le f hf hb g _ _ _
(by rw [RelSeries.last_snoc]; exact le_of_le_of_eq (hf hcb) hb.symm) (by rw [RelSeries.last_snoc]; exact le_of_le_of_eq (hf hcb) hb.symm)
/-- Agda: `aᶠ≼` — `aFix` is below every fixed point of `f`. -/ /-- Agda: `aᶠ≼` — `aFix` is below every fixed point of `f`. -/
theorem aFix_le (fh : FixedHeight α h) (f : α → α) (hf : Monotone f) theorem aFix_le (f : α → α) (hf : Monotone f)
{a : α} (ha : a = f a) : aFix fh f hf ≤ a := {a : α} (ha : a = f a) : aFix f hf ≤ a :=
doStep_le fh f hf ha _ _ _ _ (by simpa using fh.bot_le a) doStep_le f hf ha _ _ _ _ (by simpa using FiniteHeightLattice.bot_le α a)
end Spa.Fixedpoint end Spa.Fixedpoint

5
lean/Spa/Language/Semantics.lean
View File

@@ -79,8 +79,9 @@ inductive EvalStmt : Env → Stmt → Env → Prop
EvalExpr ρ e (.int 0) → EvalExpr ρ e (.int 0) →
EvalStmt ρ (.whileLoop e s) ρ EvalStmt ρ (.whileLoop e s) ρ
/-- Agda: `LatticeInterpretation`. -/ /-- Agda: `LatticeInterpretation` (used there as an instance argument `⦃·⦄`,
structure LatticeInterpretation (L : Type*) [Lattice L] where hence a typeclass here). -/
class LatticeInterpretation (L : Type*) [Lattice L] where
interp : L → Value → Prop interp : L → Value → Prop
interp_sup : ∀ {l₁ l₂ : L} (v : Value), interp_sup : ∀ {l₁ l₂ : L} (v : Value),
interp l₁ v ∨ interp l₂ v → interp (l₁ ⊔ l₂) v interp l₁ v ∨ interp l₂ v → interp (l₁ ⊔ l₂) v

17
lean/Spa/Lattice.lean
View File

@@ -118,7 +118,10 @@ def FixedHeight.cast {α : Type*} [Preorder α] {m n : ℕ} (h : m = n)
@[simp] theorem FixedHeight.cast_bot {α : Type*} [Preorder α] {m n : ℕ} @[simp] theorem FixedHeight.cast_bot {α : Type*} [Preorder α] {m n : ℕ}
(h : m = n) (fh : FixedHeight α m) : (fh.cast h).bot = fh.bot := rfl (h : m = n) (fh : FixedHeight α m) : (fh.cast h).bot = fh.bot := rfl
/-- Agda: `IsFiniteHeightLattice` / `FiniteHeightLattice` (bundled). -/ /-- Agda: `IsFiniteHeightLattice` / `FiniteHeightLattice` (bundled). Like the
Agda code (which took `IsFiniteHeightLattice` as an instance argument `⦃·⦄`),
this is a typeclass; downstream modules pick it up by instance resolution
rather than threading a `FixedHeight` value. -/
class FiniteHeightLattice (α : Type*) [Lattice α] where class FiniteHeightLattice (α : Type*) [Lattice α] where
height : ℕ height : ℕ
fixedHeight : FixedHeight α height fixedHeight : FixedHeight α height
@@ -150,4 +153,16 @@ theorem bot_le (fh : FixedHeight α h) : fh.KnownBot := by
end FixedHeight end FixedHeight
namespace FiniteHeightLattice
variable (α : Type*) [Lattice α] [FiniteHeightLattice α]
/-- Agda: the `⊥` of `Chain.Height`, with the type explicit. -/
def bot : α := (fixedHeight (α := α)).bot
/-- Agda: `⊥≼` for the instance bottom. -/
theorem bot_le (a : α) : bot α ≤ a := FixedHeight.bot_le _ a
end FiniteHeightLattice
end Spa end Spa

69
lean/Spa/Lattice/AboveBelow.lean
View File

@@ -155,6 +155,75 @@ theorem le_cases {a b : AboveBelow α} (h : a ≤ b) :
· rw [if_neg hxy] at hsup · rw [if_neg hxy] at hsup
exact absurd hsup (by simp) exact absurd hsup (by simp)
/-- Monotonicity for *strict* operations on flat lattices: if `f` sends `⊥` to
`⊥` (in either argument) and `⊤` to `⊤` (against any non-`⊥` argument), it is
monotone in both arguments — regardless of its values on plain elements.
`Analysis/Sign.agda` and `Analysis/Constant.agda` postulated exactly these
monotonicity facts for their `plus`/`minus`, all of which have this shape. -/
theorem monotone₂_of_strict {β γ : Type*} [DecidableEq β] [DecidableEq γ]
(f : AboveBelow α → AboveBelow β → AboveBelow γ)
(hbotl : ∀ y, f bot y = bot) (hbotr : ∀ x, f x bot = bot)
(htopl : ∀ y, y ≠ bot → f top y = top)
(htopr : ∀ x, x ≠ bot → f x top = top) : Monotone₂ f := by
constructor
· intro y a b hab
show f a y ≤ f b y
rcases le_cases hab with rfl | rfl | rfl
· rw [hbotl]; exact bot_le' _
· rcases eq_or_ne y bot with rfl | hy
· rw [hbotr, hbotr]
· rw [htopl y hy]; exact le_top' _
· exact le_rfl
· intro x a b hab
rcases le_cases hab with rfl | rfl | rfl
· rw [hbotr]; exact bot_le' _
· rcases eq_or_ne x bot with rfl | hx
· rw [hbotl, hbotl]
· rw [htopr x hx]; exact le_top' _
· exact le_rfl
/-! ### Interpretations of flat lattices
The `⟦⟧-⊔-∨` / `⟦⟧-⊓-∧` proofs of `Analysis/Sign.agda` and
`Analysis/Constant.agda` are the same case analysis; only the meaning of the
plain elements differs. Factored here, they need just `P ⊥ ↦ False`,
`P ⊤ ↦ True`, and (for `⊓`) disjointness of distinct plain elements. -/
section Interp
variable {V : Type*} {P : AboveBelow α → V → Prop}
/-- Agda: `⟦⟧ᵍ-⊔ᵍ-∨` / `⟦⟧ᶜ-⊔ᶜ-∨`, generalized. -/
theorem interp_sup_of (hbot : ∀ v, ¬P bot v) (htop : ∀ v, P top v)
{s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by
rcases s₁ with _ | _ | x
· rw [bot_sup]; exact h.resolve_left (hbot v)
· rw [top_sup]; exact htop v
· rcases s₂ with _ | _ | y
· rw [sup_bot]; exact h.resolve_right (hbot v)
· rw [sup_top]; exact htop v
· rw [mk_sup_mk]
split
· next heq => subst heq; exact h.elim id id
· exact htop v
/-- Agda: `⟦⟧ᵍ-⊓ᵍ-∧` / `⟦⟧ᶜ-⊓ᶜ-∧`, generalized. -/
theorem interp_inf_of
(hdisj : ∀ {x y : α}, x ≠ y → ∀ v, ¬(P (mk x) v ∧ P (mk y) v))
{s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∧ P s₂ v) : P (s₁ ⊓ s₂) v := by
rcases s₁ with _ | _ | x
· rw [bot_inf]; exact h.1
· rw [top_inf]; exact h.2
· rcases s₂ with _ | _ | y
· rw [inf_bot]; exact h.2
· rw [inf_top]; exact h.1
· rw [mk_inf_mk]
split
· next heq => subst heq; exact h.1
· next hne => exact absurd h (hdisj hne v)
end Interp
/-- Rank of an element: `⊥ ↦ 0`, `[x] ↦ 1`, `⊤ ↦ 2`. Used to bound chains /-- Rank of an element: `⊥ ↦ 0`, `[x] ↦ 1`, `⊤ ↦ 2`. Used to bound chains
(Agda's `isLongest` / `x≺[y]⇒x≡⊥` / `[x]≺y⇒y≡⊤` case analysis lives here). -/ (Agda's `isLongest` / `x≺[y]⇒x≡⊥` / `[x]≺y⇒y≡⊤` case analysis lives here). -/
def rank : AboveBelow α → ℕ def rank : AboveBelow α → ℕ

6
lean/Spa/Lattice/FiniteMap.lean
View File

@@ -639,6 +639,12 @@ def fixedHeight {hB : ℕ} (fhB : FixedHeight B hB) (ks : List A) :
(ofIter ks) toIter (ofIter_monotone ks) toIter_monotone (ofIter ks) toIter (ofIter_monotone ks) toIter_monotone
(toIter_ofIter ks) (fun fm => ofIter_toIter fm)).cast (by ring) (toIter_ofIter ks) (fun fm => ofIter_toIter fm)).cast (by ring)
/-- Agda: `isFiniteHeightLattice`/`finiteHeightLattice` of `Lattice/FiniteMap.agda`
(there instance arguments; here an instance). -/
instance [IB : FiniteHeightLattice B] : FiniteHeightLattice (FiniteMap A B ks) where
height := ks.length * IB.height
fixedHeight := fixedHeight IB.fixedHeight ks
omit [Lattice B] in omit [Lattice B] in
/-- Agda: `to-build`. -/ /-- Agda: `to-build`. -/
theorem mem_ofIter_build {b : B} : ∀ {ks : List A} {k : A} {v : B}, theorem mem_ofIter_build {b : B} : ∀ {ks : List A} {k : A} {v : B},