Lean migration: Phase 7 (Sign + Constant analyses, executable)
- Spa.Showable: port of Showable.agda (quoted strings, map format) for output parity - Spa.Analysis.Utils: eval_combine₂ - Spa.Lattice.AboveBelow.le_cases: order of the flat lattice by cases - Spa.Analysis.Sign / Spa.Analysis.Constant: the four monotonicity POSTULATES from the Agda files are now proved theorems (via le_cases); interpretations, evaluator validity, analyze_correct per analysis - Main + lake exe spa: runs both analyses on the Agda test program; constant analysis folds unknown=0, sign analysis gives unknown=⊤ Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
311
lean/Spa/Analysis/Constant.lean
Normal file
311
lean/Spa/Analysis/Constant.lean
Normal file
@@ -0,0 +1,311 @@
|
||||
/-
|
||||
Port of `Analysis/Constant.agda`.
|
||||
|
||||
Correspondence:
|
||||
showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
|
||||
ConstLattice (AboveBelow ℤ) ↦ ConstLattice
|
||||
AB.Plain (+ 0) ↦ constFixedHeight
|
||||
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
|
||||
plus-Mono₂, minus-Mono₂ ↦ plus_mono₂, minus_mono₂
|
||||
⟦_⟧ᶜ ↦ interpConst
|
||||
⟦⟧ᶜ-respects-≈ᶜ ↦ (trivial with `=`)
|
||||
⟦⟧ᶜ-⊔ᶜ-∨, ⟦⟧ᶜ-⊓ᶜ-∧ ↦ interpConst_sup, interpConst_inf
|
||||
s₁≢s₂⇒¬s₁∧s₂ ↦ interpConst_mk_disjoint
|
||||
latticeInterpretationᶜ ↦ constInterpretation
|
||||
WithProg.eval, eval-Monoʳ ↦ ConstAnalysis.eval, eval_mono
|
||||
ConstEval ↦ ConstAnalysis.exprEvaluator
|
||||
plus-valid, minus-valid ↦ plus_valid, minus_valid
|
||||
eval-valid, ConstEvalValid ↦ eval_valid
|
||||
output ↦ ConstAnalysis.output
|
||||
analyze-correct ↦ ConstAnalysis.analyze_correct
|
||||
-/
|
||||
import Spa.Analysis.Forward
|
||||
import Spa.Analysis.Utils
|
||||
import Spa.Showable
|
||||
|
||||
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
|
||||
/-- Agda: `plus`. -/
|
||||
def plus : ConstLattice → ConstLattice → ConstLattice
|
||||
| bot, _ => bot
|
||||
| _, bot => bot
|
||||
| top, _ => top
|
||||
| _, top => top
|
||||
| mk z₁, mk z₂ => mk (z₁ + z₂)
|
||||
|
||||
open AboveBelow in
|
||||
/-- Agda: `minus`. -/
|
||||
def minus : ConstLattice → ConstLattice → ConstLattice
|
||||
| bot, _ => bot
|
||||
| _, bot => bot
|
||||
| top, _ => top
|
||||
| _, top => top
|
||||
| mk z₁, mk z₂ => mk (z₁ - z₂)
|
||||
|
||||
/-- 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 _
|
||||
|
||||
/-- 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 _
|
||||
|
||||
/-- Agda: `plus-Mono₂`. -/
|
||||
theorem plus_mono₂ : Monotone₂ plus :=
|
||||
⟨plus_mono_left, plus_mono_right⟩
|
||||
|
||||
/-- 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 _
|
||||
|
||||
/-- 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⟩
|
||||
|
||||
/-- Agda: `⟦_⟧ᶜ`. -/
|
||||
def interpConst : ConstLattice → Value → Prop
|
||||
| .bot, _ => False
|
||||
| .top, _ => True
|
||||
| .mk z, v => v = .int z
|
||||
|
||||
/-- Agda: `s₁≢s₂⇒¬s₁∧s₂`. -/
|
||||
theorem interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Value} :
|
||||
¬(interpConst (.mk z₁) v ∧ interpConst (.mk z₂) v) := by
|
||||
rintro ⟨h₁, h₂⟩
|
||||
rw [h₁] at h₂
|
||||
injection h₂ with hz
|
||||
exact hne hz
|
||||
|
||||
/-- Agda: `⟦⟧ᶜ-⊔ᶜ-∨`. -/
|
||||
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
|
||||
|
||||
/-- Agda: `⟦⟧ᶜ-⊓ᶜ-∧`. -/
|
||||
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)
|
||||
|
||||
/-- Agda: `latticeInterpretationᶜ`. -/
|
||||
def 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
|
||||
|
||||
variable (prog : Program)
|
||||
|
||||
/-- Agda: `WithProg.eval`. -/
|
||||
def eval : Expr → VariableValues ConstLattice prog → ConstLattice
|
||||
| .add e₁ e₂, vs => plus (eval e₁ vs) (eval e₂ vs)
|
||||
| .sub e₁ e₂, vs => minus (eval e₁ vs) (eval e₂ vs)
|
||||
| .var k, vs =>
|
||||
if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
|
||||
| .num n, _ => .mk n
|
||||
|
||||
/-- Agda: `WithProg.eval-Monoʳ`. -/
|
||||
theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
|
||||
induction e with
|
||||
| add e₁ e₂ ih₁ ih₂ =>
|
||||
intro vs₁ vs₂ h
|
||||
exact eval_combine₂ plus_mono₂ (ih₁ h) (ih₂ h)
|
||||
| sub e₁ e₂ ih₁ ih₂ =>
|
||||
intro vs₁ vs₂ h
|
||||
exact eval_combine₂ minus_mono₂ (ih₁ h) (ih₂ h)
|
||||
| var k =>
|
||||
intro vs₁ vs₂ h
|
||||
simp only [eval]
|
||||
by_cases hk : k ∈ prog.vars
|
||||
· rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
|
||||
dif_pos (FiniteMap.memKey_iff.mpr hk)]
|
||||
exact FiniteMap.le_of_mem_mem prog.vars_nodup h
|
||||
(FiniteMap.locate _).2 (FiniteMap.locate _).2
|
||||
· rw [dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm)),
|
||||
dif_neg (fun hm => hk (FiniteMap.memKey_iff.mp hm))]
|
||||
| num n =>
|
||||
intro vs₁ vs₂ _
|
||||
exact le_refl _
|
||||
|
||||
/-- Agda: the `ConstEval` instance. -/
|
||||
def exprEvaluator : ExprEvaluator ConstLattice prog :=
|
||||
⟨eval prog, eval_mono prog⟩
|
||||
|
||||
/-- Agda: `WithProg.result`/`output`. -/
|
||||
def output : String :=
|
||||
show' (result constFixedHeight (exprEvaluator prog).toStmtEvaluator)
|
||||
|
||||
/-- Agda: `plus-valid`. -/
|
||||
theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
|
||||
(h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
|
||||
interpConst (plus g₁ g₂) (.int (z₁ + z₂)) := by
|
||||
rcases g₁ with _ | _ | c₁
|
||||
· exact h₁.elim
|
||||
· rcases g₂ with _ | _ | c₂
|
||||
· exact h₂.elim
|
||||
· exact trivial
|
||||
· exact trivial
|
||||
· rcases g₂ with _ | _ | c₂
|
||||
· exact h₂.elim
|
||||
· exact trivial
|
||||
· injection h₁ with hz₁
|
||||
injection h₂ with hz₂
|
||||
show Value.int (z₁ + z₂) = Value.int (c₁ + c₂)
|
||||
rw [hz₁, hz₂]
|
||||
|
||||
/-- Agda: `minus-valid`. -/
|
||||
theorem minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
|
||||
(h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
|
||||
interpConst (minus g₁ g₂) (.int (z₁ - z₂)) := by
|
||||
rcases g₁ with _ | _ | c₁
|
||||
· exact h₁.elim
|
||||
· rcases g₂ with _ | _ | c₂
|
||||
· exact h₂.elim
|
||||
· exact trivial
|
||||
· exact trivial
|
||||
· rcases g₂ with _ | _ | c₂
|
||||
· exact h₂.elim
|
||||
· exact trivial
|
||||
· injection h₁ with hz₁
|
||||
injection h₂ with hz₂
|
||||
show Value.int (z₁ - z₂) = Value.int (c₁ - c₂)
|
||||
rw [hz₁, hz₂]
|
||||
|
||||
/-- Agda: `eval-valid` / `ConstEvalValid`. -/
|
||||
theorem eval_valid :
|
||||
IsValidExprEvaluator (exprEvaluator prog) constInterpretation := by
|
||||
intro vs ρ e v hev
|
||||
induction hev with
|
||||
| num n =>
|
||||
intro _
|
||||
show interpConst (eval prog (.num n) vs) (.int n)
|
||||
rfl
|
||||
| var x v hxv =>
|
||||
intro hvs
|
||||
show interpConst (eval prog (.var x) vs) v
|
||||
simp only [eval]
|
||||
by_cases hk : FiniteMap.MemKey x vs
|
||||
· rw [dif_pos hk]
|
||||
exact hvs _ _ (FiniteMap.locate hk).2 _ hxv
|
||||
· rw [dif_neg hk]
|
||||
exact trivial
|
||||
| add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
|
||||
intro hvs
|
||||
have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
|
||||
have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
|
||||
show interpConst (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
|
||||
exact plus_valid h₁ h₂
|
||||
| sub e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
|
||||
intro hvs
|
||||
have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
|
||||
have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
|
||||
show interpConst (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
|
||||
exact minus_valid h₁ h₂
|
||||
|
||||
/-- 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
|
||||
|
||||
end ConstAnalysis
|
||||
|
||||
end Spa
|
||||
Reference in New Issue
Block a user