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

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

@@ -4,11 +4,13 @@ Port of `Analysis/Constant.agda`.
Correspondence:
showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
ConstLattice (AboveBelow ℤ) ↦ ConstLattice
AB.Plain (+ 0) ↦ constFixedHeight
AB.Plain (+ 0) ↦ the AboveBelow FiniteHeightLattice instance,
seeded by `Inhabited ℤ` (default `0`)
plus, minus ↦ plus, minus
plus-Monoˡ/ʳ, minus-Monoˡ/ʳ (postulates in Agda!)
↦ 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₂
⟦_⟧ᶜ ↦ interpConst
⟦⟧ᶜ-respects-≈ᶜ ↦ (trivial with `=`)
@@ -30,10 +32,6 @@ namespace Spa
abbrev ConstLattice : Type := AboveBelow ℤ
/-- Agda: `AB.Plain (+ 0)`'s `fixedHeight`. -/
def constFixedHeight : FixedHeight ConstLattice 2 :=
AboveBelow.plainFixedHeight (0 : ℤ)
namespace ConstAnalysis
open AboveBelow in
@@ -54,81 +52,33 @@ def minus : ConstLattice → ConstLattice → ConstLattice
| _, top => top
| 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. -/
theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := by
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 _
theorem plus_mono_left (s₂ : ConstLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
/-- Agda: `plus-Monoʳ` — a postulate there, a theorem here. -/
theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := by
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 _
theorem plus_mono_right (s₁ : ConstLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
/-- Agda: `plus-Mono₂`. -/
theorem plus_mono₂ : Monotone₂ plus :=
⟨plus_mono_left, plus_mono_right⟩
/-- Agda: `minus-Mono₂` (likewise from strictness of `minus`). -/
theorem minus_mono₂ : Monotone₂ minus :=
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. -/
theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := by
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 _
theorem minus_mono_left (s₂ : ConstLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := by
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⟩
theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
/-- Agda: `⟦_⟧ᶜ`. -/
def interpConst : ConstLattice → Value → Prop
@@ -144,48 +94,18 @@ theorem interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Val
injection h₂ with hz
exact hne hz
/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨`. -/
/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨` (via the factored flat-lattice lemma). -/
theorem interpConst_sup {s₁ s₂ : ConstLattice} (v : Value)
(h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v := by
rcases s₁ with _ | _ | z₁
· 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
(h : interpConst s₁ v ∨ interpConst s₂ v) : interpConst (s₁ ⊔ s₂) v :=
AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧`. -/
/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧` (via the factored flat-lattice lemma). -/
theorem interpConst_inf {s₁ s₂ : ConstLattice} (v : Value)
(h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v := by
rcases s₁ with _ | _ | z₁
· 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)
(h : interpConst s₁ v ∧ interpConst s₂ v) : interpConst (s₁ ⊓ s₂) v :=
AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) v h
/-- Agda: `latticeInterpretationᶜ`. -/
def constInterpretation : LatticeInterpretation ConstLattice where
/-- Agda: `latticeInterpretationᶜ` (an instance there too). -/
instance constInterpretation : LatticeInterpretation ConstLattice where
interp := interpConst
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
@@ -224,12 +144,12 @@ theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
exact le_refl _
/-- Agda: the `ConstEval` instance. -/
def exprEvaluator : ExprEvaluator ConstLattice prog :=
instance exprEvaluator : ExprEvaluator ConstLattice prog :=
⟨eval prog, eval_mono prog⟩
/-- Agda: `WithProg.result`/`output`. -/
def output : String :=
show' (result constFixedHeight (exprEvaluator prog).toStmtEvaluator)
show' (result ConstLattice prog)
/-- Agda: `plus-valid`. -/
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₂)
rw [hz₁, hz₂]
/-- Agda: `eval-valid` / `ConstEvalValid`. -/
theorem eval_valid :
IsValidExprEvaluator (exprEvaluator prog) constInterpretation := by
/-- Agda: `eval-valid` / the `ConstEvalValid` instance. -/
instance eval_valid : ValidExprEvaluator ConstLattice prog := by
constructor
intro vs ρ e v hev
induction hev with
| num n =>
@@ -300,11 +220,8 @@ theorem eval_valid :
/-- Agda: `WithProg.analyze-correct`. -/
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
interpV constInterpretation
(variablesAt prog.finalState
(result constFixedHeight (exprEvaluator prog).toStmtEvaluator)) ρ :=
Spa.analyze_correct constFixedHeight
((exprEvaluator prog).toStmtEvaluator_valid (eval_valid prog)) hrun
interpV (variablesAt prog.finalState (result ConstLattice prog)) ρ :=
Spa.analyze_correct ConstLattice prog hrun
end ConstAnalysis