Conclude restricted LICM proof

1. no writes = save value
2. embedding commutation with steps
3. all variables in code end up in the set of vars

lean/Main.lean

@@ -1,40 +1,37 @@
-/-
-Port of `Main.agda`. Prints the constant- and sign-analysis results for the
-test program (Agda: `putStrLn (output-Const ++ "\n" ++ output-Sign)`).
--/
 import Spa.Analysis.Sign
 import Spa.Analysis.Constant
+import Spa.Analysis.Reaching
+import Spa.Language.Notation
 
 namespace Spa
 
-/-- Agda: `testCode`. -/
+def testCode : Stmt := [obj_stmt|
-def testCode : Stmt :=
+  zero    := 0;
-  .andThen (.basic (.assign "zero" (.num 0)))
+  pos     := zero + 1;
-    (.andThen (.basic (.assign "pos" (.add (.var "zero") (.num 1))))
+  neg     := zero - 1;
-      (.andThen (.basic (.assign "neg" (.sub (.var "zero") (.num 1))))
+  unknown := pos + neg
-        (.basic (.assign "unknown" (.add (.var "pos") (.var "neg"))))))
+]
 
-/-- Agda: `testCodeCond₁`. -/
+def testCodeCond₁ : Stmt := [obj_stmt|
-def testCodeCond₁ : Stmt :=
+  var := 1;
-  .andThen (.basic (.assign "var" (.num 1)))
+  if var {
-    (.ifElse (.var "var")
+    var := var + 1
-      (.basic (.assign "var" (.add (.var "var") (.num 1))))
+  } else {
-      (.andThen (.basic (.assign "var" (.sub (.var "var") (.num 1))))
+    var := var - 1;
-        (.basic (.assign "var" (.num 1)))))
+    var := 1
+  }
+]
 
-/-- Agda: `testCodeCond₂`. -/
+def testCodeCond₂ : Stmt := [obj_stmt|
-def testCodeCond₂ : Stmt :=
+  var := 1;
-  .andThen (.basic (.assign "var" (.num 1)))
+  if var { x := 1 } else { noop }
-    (.ifElse (.var "var")
+]
-      (.basic (.assign "x" (.num 1)))
-      (.basic .noop))
 
-/-- Agda: `testProgram`. -/
+def testProgram : Program := { rootStmt := testCode }
-def testProgram : Program := ⟨testCode⟩
 
 end Spa
 
-/-- Agda: `main`. -/
 def main : IO Unit :=
   IO.println (Spa.ConstAnalysis.output Spa.testProgram ++ "\n" ++
-              Spa.SignAnalysis.output Spa.testProgram)
+              Spa.SignAnalysis.output Spa.testProgram ++ "\n" ++
+              Spa.ReachingAnalysis.output Spa.testProgram)

lean/Spa.lean

@@ -1,16 +1,17 @@
 import Spa.Lattice
 import Spa.Fixedpoint
-import Spa.Isomorphism
 import Spa.Lattice.Unit
-import Spa.Lattice.Prod
 import Spa.Lattice.AboveBelow
-import Spa.Lattice.IterProd
 import Spa.Lattice.FiniteMap
+import Spa.Lattice.Bool
 import Spa.Language.Base
+import Spa.Language.Notation
 import Spa.Language.Semantics
+import Spa.Language.Equivalence
 import Spa.Language.Graphs
 import Spa.Language.Traces
 import Spa.Language.Properties
+import Spa.Language.TraceProperties
 import Spa.Language
 import Spa.Analysis.Forward.Lattices
 import Spa.Analysis.Forward.Evaluation
@@ -20,3 +21,8 @@ import Spa.Showable
 import Spa.Analysis.Utils
 import Spa.Analysis.Sign
 import Spa.Analysis.Constant
+import Spa.Analysis.Reaching
+import Spa.Analysis.Reaching.Paths
+import Spa.Transformation.Licm
+import Spa.Transformation.Licm.Correctness
+import Spa.Transformation.Constant

lean/Spa/Analysis/Constant.lean

@@ -1,41 +1,17 @@
-/-
-Port of `Analysis/Constant.agda`.
-
-Correspondence:
-  showable, ≡-equiv, ≡-Decidable-ℤ ↦ (mathlib/derived instances)
-  ConstLattice (AboveBelow ℤ)      ↦ ConstLattice
-  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.monotone₂_of_strict
-  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.Interp
 import Spa.Showable
 
 namespace Spa
 
+open Forward
+
 abbrev ConstLattice : Type := AboveBelow ℤ
 
 namespace ConstAnalysis
 
 open AboveBelow in
-/-- Agda: `plus`. -/
 def plus : ConstLattice → ConstLattice → ConstLattice
   | bot, _ => bot
   | _, bot => bot
@@ -44,7 +20,6 @@ def plus : ConstLattice → ConstLattice → ConstLattice
   | mk z₁, mk z₂ => mk (z₁ + z₂)
 
 open AboveBelow in
-/-- Agda: `minus`. -/
 def minus : ConstLattice → ConstLattice → ConstLattice
   | bot, _ => bot
   | _, bot => bot
@@ -52,67 +27,35 @@ 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
+lemma plus_mono₂ : Monotone₂ plus :=
-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 => by aesop) (fun x => by aesop)
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun y hy => by aesop) (fun x hx => by aesop)
-    (fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
 
-/-- Agda: `plus-Monoˡ` — a postulate there, a theorem here. -/
+lemma minus_mono₂ : Monotone₂ minus :=
-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₁) := plus_mono₂.2 s₁
-
-/-- 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 => by aesop) (fun x => by aesop)
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
+    (fun y hy => by aesop) (fun x hx => by aesop)
-    (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₂) := minus_mono₂.1 s₂
-
-/-- Agda: `minus-Monoʳ` — a postulate there, a theorem here. -/
-theorem minus_mono_right (s₁ : ConstLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
-
-/-- Agda: `⟦_⟧ᶜ`. -/
 def interpConst : ConstLattice → Value → Prop
   | .bot, _ => False
   | .top, _ => True
   | .mk z, v => v = .int z
 
-/-- Agda: `s₁≢s₂⇒¬s₁∧s₂`. -/
+lemma interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Value} :
-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: `⟦⟧ᶜ-⊔ᶜ-∨` (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 :=
-  AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
-
-/-- 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 :=
-  AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) v h
-
-/-- 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_sup := fun v h => AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
-  interp_inf := fun {l₁ l₂} v h => interpConst_inf (s₁ := l₁) (s₂ := l₂) v h
+  interp_inf := fun v h => AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) 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)
@@ -120,8 +63,7 @@ def eval : Expr → VariableValues ConstLattice prog → ConstLattice
     if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
   | .num n, _ => .mk n
 
-/-- Agda: `WithProg.eval-Monoʳ`. -/
+lemma eval_mono (e : Expr) : Monotone (eval prog e) := by
-theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
   induction e with
   | add e₁ e₂ ih₁ ih₂ =>
     intro vs₁ vs₂ h
@@ -133,72 +75,45 @@ theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
     intro vs₁ vs₂ h
     simp only [eval]
     by_cases hk : k ∈ prog.vars
-    · rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
+    · rw [dif_pos (FiniteMap.MemKey_iff.mpr hk),
-          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)),
+    · rw [dif_neg (fun hm => hk (FiniteMap.MemKey_iff.mp hm)),
-          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. -/
 instance exprEvaluator : ExprEvaluator ConstLattice prog :=
   ⟨eval prog, eval_mono prog⟩
 
-/-- Agda: `WithProg.result`/`output`. -/
 def output : String :=
   show' (result ConstLattice prog)
 
-/-- Agda: `plus-valid`. -/
+lemma plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
-theorem plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
+    (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
-    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
+    ⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
-    interpConst (plus g₁ g₂) (.int (z₁ + z₂)) := by
+  rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
-  rcases g₁ with _ | _ | c₁
+    simp_all [plus, constInterpretation, interpConst]
-  · 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`. -/
+lemma minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
-theorem minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
+    (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
-    (h₁ : interpConst g₁ (.int z₁)) (h₂ : interpConst g₂ (.int z₂)) :
+    ⟦minus g₁ g₂⟧ (.int (z₁ - z₂)) := by
-    interpConst (minus g₁ g₂) (.int (z₁ - z₂)) := by
+  rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
-  rcases g₁ with _ | _ | c₁
+    simp_all [minus, constInterpretation, interpConst]
-  · 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` / the `ConstEvalValid` instance. -/
 instance eval_valid : ValidExprEvaluator ConstLattice prog := by
   constructor
   intro vs ρ e v hev
   induction hev with
   | num n =>
     intro _
-    show interpConst (eval prog (.num n) vs) (.int n)
+    show ⟦eval prog (.num n) vs⟧ (.int n)
     rfl
   | var x v hxv =>
     intro hvs
-    show interpConst (eval prog (.var x) vs) v
+    show ⟦eval prog (.var x) vs⟧ v
     simp only [eval]
     by_cases hk : FiniteMap.MemKey x vs
     · rw [dif_pos hk]
@@ -207,21 +122,26 @@ instance eval_valid : ValidExprEvaluator ConstLattice prog := by
       exact trivial
   | add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
     intro hvs
-    have h₁ : interpConst (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
-    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
-    show interpConst (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
+    show ⟦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₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
-    have h₂ : interpConst (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
-    show interpConst (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
+    show ⟦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 (variablesAt prog.finalState (result ConstLattice prog)) ρ :=
+    ⟦ variablesAt prog.finalState (result ConstLattice prog) ⟧ ρ :=
-  Spa.analyze_correct ConstLattice prog hrun
+  Forward.analyze_correct ConstLattice prog hrun
+
+theorem analyze_correct_at {s : prog.State} {ρin ρout : Env}
+    (hr : Reaches s ρin ρout) :
+    ⟦ joinForKey s (result ConstLattice prog) ⟧ ρin
+      ∧ ⟦ variablesAt s (result ConstLattice prog) ⟧ ρout :=
+  Forward.analyze_correct_at ConstLattice prog hr
 
 end ConstAnalysis
 

lean/Spa/Analysis/Forward.lean

@@ -1,30 +1,3 @@
-/-
-Port of `Analysis/Forward.agda` (`WithProg`, `WithStmtEvaluator`,
-`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:
-  updateVariablesForState, -Monoʳ   ↦ updateVariablesForState, _mono
-  updateAll, updateAll-Mono,
-  updateAll-k∈ks-≡                  ↦ updateAll, updateAll_mono, updateAll_mem_eq
-  analyze, analyze-Mono             ↦ analyze, analyze_mono
-  result, result≈analyze-result     ↦ result, result_eq
-  variablesAt-updateAll             ↦ variablesAt_updateAll
-  eval-fold-valid                   ↦ eval_fold_valid
-  updateVariablesForState-matches   ↦ updateVariablesForState_matches
-  updateAll-matches                 ↦ updateAll_matches
-  stepTrace                         ↦ stepTrace   (the `subst`/`⟦⟧ᵛ-respects-≈ᵛ`
-                                       plumbing becomes plain rewriting with `=`)
-  walkTrace                         ↦ walkTrace
-  joinForKey-initialState-⊥ᵛ        ↦ joinForKey_initialState
-  ⟦joinAll-initialState⟧ᵛ∅          ↦ interpV_joinForKey_initialState
-  analyze-correct                   ↦ analyze_correct
--/
 import Spa.Analysis.Forward.Lattices
 import Spa.Analysis.Forward.Evaluation
 import Spa.Analysis.Forward.Adapters
@@ -32,136 +5,152 @@ import Spa.Fixedpoint
 
 namespace Spa
 
-variable {L : Type} [Lattice L] {prog : Program} [E : StmtEvaluator L prog]
+namespace Forward
+
+variable {L : Type} [FiniteHeightLattice L] {prog : Program} [E : StmtEvaluator L prog]
 
-/-- Agda: `updateVariablesForState`. -/
 def updateVariablesForState (s : prog.State) (sv : StateVariables L prog) :
-    VariableValues L prog :=
+    VariableValues L prog := E.eval s (variablesAt s sv)
-  (prog.code s).foldl (fun vs bs => E.eval s bs vs) (variablesAt s sv)
 
-/-- Agda: `updateVariablesForState-Monoʳ`. -/
+lemma updateVariablesForState_mono (s : prog.State) :
-theorem updateVariablesForState_mono (s : prog.State) :
     Monotone (updateVariablesForState (L := L) s) := fun _ _ hle =>
-  foldl_mono' (prog.code s) _ (fun bs => E.eval_mono s bs) (variablesAt_le hle s)
+  E.eval_mono s (variablesAt_le hle s)
 
-/-- Agda: `updateAll`. -/
 def updateAll (sv : StateVariables L prog) : StateVariables L prog :=
-  FiniteMap.generalizedUpdate id (fun s sv => updateVariablesForState s sv)
+  FiniteMap.generalizedUpdate id updateVariablesForState
     prog.states sv
 
-/-- Agda: `updateAll-Mono`. -/
+lemma updateAll_mono : Monotone (updateAll (L := L) (prog := prog)) :=
-theorem updateAll_mono : Monotone (updateAll (L := L) (prog := prog)) :=
   FiniteMap.generalizedUpdate_monotone monotone_id updateVariablesForState_mono
 
-/-- Agda: `updateAll-k∈ks-≡`. -/
+lemma 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 sv) :
     vs = updateVariablesForState s sv :=
   FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) hmem
 
-/-- Agda: `variablesAt-updateAll`. -/
+lemma variablesAt_updateAll (s : prog.State) (sv : StateVariables L prog) :
-theorem variablesAt_updateAll (s : prog.State) (sv : StateVariables L prog) :
     variablesAt s (updateAll sv) = updateVariablesForState s sv :=
   updateAll_mem_eq (variablesAt_mem s (updateAll sv))
 
-variable [FiniteHeightLattice L]
-
-/-- Agda: `analyze`. -/
 def analyze (sv : StateVariables L prog) : StateVariables L prog :=
   updateAll (joinAll sv)
 
-/-- Agda: `analyze-Mono`. -/
+lemma analyze_mono : Monotone (analyze (L := L) (prog := prog)) := fun _ _ hle =>
-theorem analyze_mono : Monotone (analyze (L := L) (prog := prog)) := fun _ _ hle =>
   updateAll_mono (joinAll_mono hle)
 
 variable [DecidableEq L]
 
 variable (L prog) in
-/-- Agda: `result` (the least fixpoint of `analyze`). -/
 def result : StateVariables L prog :=
   Fixedpoint.aFix analyze analyze_mono
 
 variable (L prog) in
-/-- Agda: `result≈analyze-result`. -/
+lemma result_eq : result L prog = analyze (result L prog) :=
-theorem result_eq : result L prog = analyze (result L prog) :=
   Fixedpoint.aFix_eq analyze analyze_mono
 
-/-- Agda: `joinForKey-initialState-⊥ᵛ`. -/
+lemma 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`) -/
+class ValidStateEvaluator (L : Type) [FiniteHeightLattice L] (prog : Program)
+    [E : StmtEvaluator L prog] [S : StateInterpretation L prog] where
+  valid : ∀ (s₁ s₂ : prog.State) {ρ₁ ρ₂ ρ₃: Env}
+    {vs : VariableValues L prog},
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂) →
+    (hbs : EvalBasicStmtOpt ρ₂ (prog.cfg.nodes s₂) ρ₃) → ⟦ vs ⟧ (S.Pre tr) →
+    ⟦ E.eval s₂ vs ⟧ (S.Post (tr ++ hbs))
+  botV_init : ⟦ botV L prog ⟧ (S.Pre (Traceₗ.single prog.cfg prog.initialState []))
 
-variable [I : LatticeInterpretation L] [V : ValidStmtEvaluator L prog]
+instance [LatticeInterpretation L] [ValidStmtEvaluator L prog] :
+    ValidStateEvaluator L prog where
+  valid := by intro _ _ _ _ _ _ tr hbs hvs; exact ValidStmtEvaluator.valid hbs hvs
+  botV_init := by intro k l _ v hmem; cases hmem
 
-omit [FiniteHeightLattice L] [DecidableEq L] in
+section
-/-- Agda: `eval-fold-valid`. -/
+variable [S : StateInterpretation L prog] [V : ValidStateEvaluator L prog]
-theorem eval_fold_valid {s : prog.State} {bss : List BasicStmt}
-    {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
-    (hbss : EvalBasicStmts ρ₁ bss ρ₂) (hvs : interpV vs ρ₁) :
-    interpV (bss.foldl (fun vs bs => E.eval s bs vs) vs) ρ₂ := by
-  induction hbss generalizing vs with
-  | nil => exact hvs
-  | cons hbs _ ih => exact ih (ValidStmtEvaluator.valid hbs hvs)
 
-omit [FiniteHeightLattice L] [DecidableEq L] in
+omit [DecidableEq L] in
-/-- Agda: `updateVariablesForState-matches`. -/
+lemma updateAll_matches {s₁ s₂ : prog.State} {sv : StateVariables L prog}
-theorem updateVariablesForState_matches {s : prog.State}
+    {ρ₁ ρ₂ ρ₃ : Env}
-    {sv : StateVariables L prog} {ρ₁ ρ₂ : Env}
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂)
-    (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
+    (hnode : EvalBasicStmtOpt ρ₂ (prog.code s₂) ρ₃)
-    (hvs : interpV (variablesAt s sv) ρ₁) :
+    (hvs : ⟦ variablesAt s₂ sv ⟧ (S.Pre tr)) :
-    interpV (updateVariablesForState s sv) ρ₂ :=
+    ⟦ variablesAt s₂ (updateAll sv) ⟧ (S.Post (tr ++ hnode)) := by
-  eval_fold_valid hbss hvs
-
-omit [FiniteHeightLattice L] [DecidableEq L] in
-/-- Agda: `updateAll-matches`. -/
-theorem updateAll_matches {s : prog.State} {sv : StateVariables L prog}
-    {ρ₁ ρ₂ : Env} (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
-    (hvs : interpV (variablesAt s sv) ρ₁) :
-    interpV (variablesAt s (updateAll sv)) ρ₂ := by
   rw [variablesAt_updateAll]
-  exact updateVariablesForState_matches hbss hvs
+  exact V.valid s₁ s₂ tr hnode hvs
 
-/-- Agda: `stepTrace`. -/
+lemma stepTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
-theorem stepTrace {s₁ : prog.State} {ρ₁ ρ₂ : Env}
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂)
-    (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
+    (hjoin : ⟦ joinForKey s₂ (result L prog) ⟧ (S.Pre tr))
-    (hbss : EvalBasicStmts ρ₁ (prog.code s₁) ρ₂) :
+    (hnode : EvalBasicStmtOpt ρ₂ (prog.code s₂) ρ₃) :
-    interpV (variablesAt s₁ (result L prog)) ρ₂ := by
+    ⟦ variablesAt s₂ (result L prog) ⟧ (S.Post (tr ++ hnode)) := by
   rw [result_eq L prog]
-  refine updateAll_matches hbss ?_
+  refine updateAll_matches tr hnode ?_
   rw [variablesAt_joinAll]
   exact hjoin
 
-/-- Agda: `walkTrace`. -/
+/-- Soundness propagates along an execution prefix: if the analysis is sound at
-theorem walkTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
+    `s₂` for the run so far (`trₗ`), then it is sound wherever the further prefix
-    (hjoin : interpV (joinForKey s₁ (result L prog)) ρ₁)
+    `mid` ends up. -/
-    (tr : Trace prog.graph s₁ s₂ ρ₁ ρ₂) :
+lemma walkPrefix : ∀ {s₂ s : prog.State} {ρ₂ ρin : Env}
-    interpV (variablesAt s₂ (result L prog)) ρ₂ := by
+    (mid : Traceₗ prog.cfg s₂ s ρ₂ ρin) {s₁ : prog.State} {ρ₁ : Env}
-  induction tr with
+    (trₗ : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂),
-  | single hbss => exact stepTrace hjoin hbss
+    ⟦ joinForKey s₂ (result L prog) ⟧ (S.Pre trₗ) →
-  | @edge _ ρ' _ i₁ i₂ _ hbss hedge _ ih =>
+    ⟦ joinForKey s (result L prog) ⟧ (S.Pre (trₗ ++ mid)) := by
-    have hstep : interpV (variablesAt i₁ (result L prog)) ρ' :=
+  intro s₂ s ρ₂ ρin mid
-      stepTrace hjoin hbss
+  match mid with
-    have hmem : variablesAt i₁ (result L prog)
+  | Traceₗ.nil =>
-        ∈ (result L prog).valuesAt (prog.incoming i₂) :=
+      intro s₁ ρ₁ trₗ hjoin
-      FiniteMap.mem_valuesAt prog.states_nodup
+      simpa only [HAppend.hAppend, Path.append_nil] using hjoin
-        (prog.mem_incoming_of_edge hedge) (variablesAt_mem i₁ (result L prog))
+  | Traceₗ.cons hnode hedge rest =>
-    exact ih (interpV_foldr hstep hmem)
+      intro s₁ ρ₁ trₗ hjoin
+      have hstep := stepTrace trₗ hjoin hnode
+      have hmem := FiniteMap.mem_valuesAt prog.states_nodup
+        (prog.mem_incoming_of_edge hedge) (variablesAt_mem _ (result L prog))
+      simpa only [HAppend.hAppend, Traceₗ.appendStep, Trace.addEdge,
+        Path.append_assoc, Path.single, Path.append] using
+        walkPrefix rest ((trₗ ++ hnode).addEdge hedge)
+          (interp_foldr (S.post_pre (trₗ ++ hnode) hedge hstep) hmem)
 
-omit V in
+omit [DecidableEq L] in
-/-- Agda: `⟦joinAll-initialState⟧ᵛ∅`. -/
+/-- The final node of a trace is always reached, with the environment/state the trace
-theorem interpV_joinForKey_initialState :
+    ends in. Used to recover the final-state soundness theorem from `walkPrefix`. -/
-    interpV (joinForKey prog.initialState (result L prog)) [] := by
+def reaches_final {s : prog.State} {ρ : Env}
-  rw [joinForKey_initialState]
+    (tr : Trace prog.cfg prog.initialState s [] ρ) : Σ ρin, Reaches s ρin ρ :=
-  exact interpV_botV_nil
+  ⟨_, ⟨tr.split.2.1, tr.split.2.2⟩⟩
+
+omit [DecidableEq L] in
+@[simp] lemma reaches_final_post {s : prog.State} {ρ : Env}
+    (tr : Trace prog.cfg prog.initialState s [] ρ) :
+    (reaches_final tr).2.post = tr := Trace.split_append tr
 
 variable (L prog) in
-/-- Agda: `analyze-correct` — the analysis result at the final state soundly
+/-- Soundness at every program point an execution actually visits: the analysis
-describes every terminating execution of the program. -/
+    over-approximates both the environment entering that point and the one leaving
-theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    it. -/
-    interpV (variablesAt prog.finalState (result L prog)) ρ :=
+theorem analyze_correct_at {s : prog.State} {ρin ρout : Env} (hr : Reaches s ρin ρout) :
-  walkTrace interpV_joinForKey_initialState (prog.trace hrun)
+    ⟦ joinForKey s (result L prog) ⟧ (S.Pre hr.pre)
+      ∧ ⟦ variablesAt s (result L prog) ⟧ (S.Post hr.post) :=
+  have hpre := walkPrefix hr.pre Traceₗ.nil
+    (by rw [joinForKey_initialState]; exact ValidStateEvaluator.botV_init)
+  ⟨hpre, stepTrace hr.pre hpre hr.step⟩
+
+variable (L prog) in
+theorem analyze_correct'
+    {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    ⟦ variablesAt prog.finalState (result L prog) ⟧ (S.Post (prog.trace hrun)) := by
+  have h := (analyze_correct_at L prog (reaches_final (prog.trace hrun)).2).2
+  rwa [reaches_final_post] at h
+
+end
+
+variable (L prog) in
+theorem analyze_correct [LatticeInterpretation L] [ValidStmtEvaluator L prog]
+    {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    ⟦ variablesAt prog.finalState (result L prog) ⟧ ρ :=
+  analyze_correct' L prog hrun
+
+end Forward
 
 end Spa

lean/Spa/Analysis/Forward/Adapters.lean

@@ -1,75 +1,64 @@
-/-
-Port of `Analysis/Forward/Adapters.agda` (`ExprToStmtAdapter`).
-
-Correspondence:
-  updateVariablesFromExpression           ↦ updateVariablesFromExpression
-  updateVariablesFromExpression-Mono      ↦ updateVariablesFromExpression_mono
-  (the -k∈ks-≡ / -k∉ks-backward renames   ↦ used directly from FiniteMap)
-  evalᵇ, evalᵇ-Monoʳ                      ↦ evalB, evalB_mono
-  stmtEvaluator (instance)                ↦ instance StmtEvaluator L prog
-  evalᵇ-valid, validStmtEvaluator         ↦ instance ValidStmtEvaluator L prog
-                                            (the Agda `k ≟ˢ k'` case split is
-                                            subsumed by `cases` on `Env.Mem`,
-                                            whose `here` case forces `k' = k`)
--/
 import Spa.Analysis.Forward.Evaluation
 
 namespace Spa
 
+namespace Forward
+
 variable {L : Type} [Lattice L] {prog : Program} [E : ExprEvaluator L prog]
 
-/-- Agda: `updateVariablesFromExpression` — set the single key `k` to the
-value of `e` (the `GeneralizedUpdate` with `ks = [k]`). -/
 def updateVariablesFromExpression (k : String) (e : Expr)
     (vs : VariableValues L prog) : VariableValues L prog :=
   FiniteMap.generalizedUpdate id (fun _ vs => E.eval e vs) [k] vs
 
-/-- Agda: `updateVariablesFromExpression-Mono`. -/
+lemma updateVariablesFromExpression_mono (k : String) (e : Expr) :
-theorem updateVariablesFromExpression_mono (k : String) (e : Expr) :
     Monotone (updateVariablesFromExpression (L := L) (prog := prog) k e) :=
   FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => E.eval_mono e)
 
-/-- Agda: `evalᵇ`. -/
+def evalBasicStmt (bs : BasicStmt)
-def evalB (_ : prog.State) (bs : BasicStmt)
     (vs : VariableValues L prog) : VariableValues L prog :=
   match bs with
   | .assign k e => updateVariablesFromExpression k e vs
   | .noop => vs
 
-/-- Agda: `evalᵇ-Monoʳ`. -/
+lemma evalBasicStmt_mono (bs : BasicStmt) :
-theorem evalB_mono (s : prog.State) (bs : BasicStmt) :
+    Monotone (evalBasicStmt (L := L) (prog := prog) bs) := by
-    Monotone (evalB (L := L) (prog := prog) s bs) := by
   cases bs with
   | assign k e => exact updateVariablesFromExpression_mono k e
   | noop => exact monotone_id
 
-/-- Agda: the `stmtEvaluator` instance of `ExprToStmtAdapter`. -/
+def evalBasicStmtOpt (obs : Option BasicStmt)
-instance ExprEvaluator.toStmtEvaluator : StmtEvaluator L prog :=
+    (vs : VariableValues L prog) : VariableValues L prog :=
-  ⟨evalB, evalB_mono⟩
+  match obs with
+  | none => vs
+  | some bs => evalBasicStmt bs vs
+
+lemma evalBasicStmtOpt_mono (obs : Option BasicStmt) :
+    Monotone (evalBasicStmtOpt (L := L) (prog := prog) obs) := by
+  cases obs <;> unfold evalBasicStmtOpt
+  · exact monotone_id
+  · apply evalBasicStmt_mono
+
+instance ExprEvaluator.toStmtEvaluator : StmtEvaluator L prog :=
+  ⟨evalBasicStmtOpt ∘ prog.code,
+   by intro s; simp; exact (evalBasicStmtOpt_mono (prog.code s))⟩
 
-/-- Agda: `evalᵇ-valid` / the `validStmtEvaluator` instance. -/
 instance ExprEvaluator.toStmtEvaluator_valid [LatticeInterpretation L]
     [ValidExprEvaluator L prog] : ValidStmtEvaluator L prog := by
   constructor
-  intro s vs ρ₁ ρ₂ bs hbs hvs
+  simp [StmtEvaluator.eval, evalBasicStmtOpt]
-  cases hbs with
+  intro s vs ρ₁ ρ₂; generalize prog.code s = obs; intro hev hvs
-  | noop => exact hvs
+  rcases hev with _ | @⟨_,bs,hev⟩ <;> try simpa
-  | assign k e v hev =>
+  rcases hev with _ | @⟨k, e, v, hev⟩ <;> try simpa
-    intro k' l hk'l v' hv'
+  intros k' l' hkl' v' hρ
-    cases hv' with
+  rcases hρ with _ | ⟨_,_,_,_,_,hne,hmem⟩ <;> simp [evalBasicStmt] at hkl'
-    | here =>
+  · have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
-      have hk'l₀ : (k, l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
+        (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hkl'
-          (fun _ vs => E.eval e vs) [k] vs := hk'l
+    rewrite [hl]; simp
-      have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
-        (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hk'l₀
-      rw [hl]
     exact ValidExprEvaluator.valid hev hvs
-    | there _ _ _ _ _ hne hmem' =>
+  · have hl := FiniteMap.generalizedUpdate_not_mem_backward
-      have hk'l₀ : (k', l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
+        (fun hmem => hne (List.mem_singleton.mp hmem)) hkl'
-          (fun _ vs => E.eval e vs) [k] vs := hk'l
+    apply hvs _ _ hl _ hmem
-      have hk'l' : (k', l) ∈ (id vs : VariableValues L prog) :=
+
-        FiniteMap.generalizedUpdate_not_mem_backward
+end Forward
-          (fun hmem => hne (List.mem_singleton.mp hmem)) hk'l₀
-      exact hvs _ _ hk'l' _ hmem'
 
 end Spa

lean/Spa/Analysis/Forward/Evaluation.lean

@@ -1,43 +1,29 @@
-/-
-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:
-  StmtEvaluator (eval, eval-Monoʳ)  ↦ StmtEvaluator (eval, eval_mono)
-  ExprEvaluator (eval, eval-Monoʳ)  ↦ ExprEvaluator (eval, eval_mono)
-  ValidExprEvaluator                ↦ ValidExprEvaluator (valid)
-  ValidStmtEvaluator                ↦ ValidStmtEvaluator (valid)
--/
 import Spa.Analysis.Forward.Lattices
 
 namespace Spa
 
+namespace Forward
+
 variable (L : Type) [Lattice L] (prog : Program)
 
-/-- Agda: `StmtEvaluator`. -/
 class StmtEvaluator where
-  eval : prog.State → BasicStmt → VariableValues L prog → VariableValues L prog
+  eval : prog.State → VariableValues L prog → VariableValues L prog
-  eval_mono : ∀ s bs, Monotone (eval s bs)
+  eval_mono : ∀ s, Monotone (eval s)
 
-/-- Agda: `ExprEvaluator`. -/
 class ExprEvaluator where
   eval : Expr → VariableValues L prog → L
   eval_mono : ∀ e, Monotone (eval e)
 
-/-- 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
+    EvalExpr ρ e v → ⟦ vs ⟧ ρ → I.interp (ExprEvaluator.eval e vs) v
 
-/-- Agda: `ValidStmtEvaluator`. -/
 class ValidStmtEvaluator [E : StmtEvaluator L prog] [LatticeInterpretation L] :
     Prop where
-  valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
+  valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env},
-    {bs : BasicStmt},
+    EvalBasicStmtOpt ρ₁ (prog.code s) ρ₂ → ⟦ vs ⟧ ρ₁ → ⟦ E.eval s vs ⟧ ρ₂
-    EvalBasicStmt ρ₁ bs ρ₂ → interpV vs ρ₁ → interpV (E.eval s bs vs) ρ₂
+
+end Forward
 
 end Spa

lean/Spa/Analysis/Forward/Lattices.lean

@@ -1,143 +1,121 @@
-/-
-Port of `Analysis/Forward/Lattices.agda`.
-
-The Agda module instantiates `Lattice.FiniteMap` twice (variables ↦ abstract
-values, states ↦ variable maps) and re-exports everything with ᵛ/ᵐ suffixes.
-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)
-become section variables, with the finite-height structure and the lattice
-interpretation arriving by instance resolution as in Agda.
-
-Correspondence:
-  VariableValues, StateVariables  ↦ VariableValues, StateVariables
-  isLatticeᵛ/isLatticeᵐ, ⊔ᵛ, ≼ᵛ … ↦ (the FiniteMap Lattice instances)
-  fixedHeightᵛ, fixedHeightᵐ      ↦ (the FiniteMap FiniteHeightLattice instance)
-  ⊥ᵛ, ⊥ᵛ-contains-bottoms         ↦ botV, FiniteMap.bot_contains_bots
-  states-in-Map                   ↦ states_memKey
-  variablesAt                     ↦ variablesAt
-  variablesAt-∈                   ↦ variablesAt_mem
-  variablesAt-≈                   ↦ (congruence, trivial with `=`)
-  joinForKey, joinForKey-Mono     ↦ joinForKey, joinForKey_mono
-  joinAll, joinAll-Mono,
-  joinAll-k∈ks-≡                  ↦ joinAll, joinAll_mono, joinAll_mem_eq
-  variablesAt-joinAll             ↦ variablesAt_joinAll
-  ⟦_⟧ᵛ                            ↦ interpV
-  ⟦⊥ᵛ⟧ᵛ∅                          ↦ interpV_botV_nil
-  ⟦⟧ᵛ-respects-≈ᵛ                 ↦ (trivial with `=`)
-  ⟦⟧ᵛ-⊔ᵛ-∨                        ↦ interpV_sup
-  ⟦⟧ᵛ-foldr                       ↦ interpV_foldr
--/
 import Spa.Language
 import Spa.Lattice.FiniteMap
+import Spa.Interp
 
 namespace Spa
 
+namespace Forward
+
 variable (L : Type) [Lattice L] (prog : Program)
 
-/-- Agda: `VariableValues`. -/
 abbrev VariableValues : Type := FiniteMap String L prog.vars
 
-/-- Agda: `StateVariables`. -/
 abbrev StateVariables : Type := FiniteMap prog.State (VariableValues L prog) prog.states
 
-/-- Agda: `⊥ᵛ` (the bottom of `fixedHeightᵛ`, now found by instance search). -/
 def botV [FiniteHeightLattice L] : VariableValues L prog :=
   (⊥ : VariableValues L prog)
 
 variable {L prog}
 
 omit [Lattice L] in
-/-- Agda: `states-in-Map`. -/
+lemma states_memKey (s : prog.State) (sv : StateVariables L prog) :
-theorem states_memKey (s : prog.State) (sv : StateVariables L prog) :
     FiniteMap.MemKey s sv :=
-  FiniteMap.memKey_iff.mpr (prog.states_complete s)
+  FiniteMap.MemKey_iff.mpr (prog.states_complete s)
 
-/-- Agda: `variablesAt`. -/
 def variablesAt (s : prog.State) (sv : StateVariables L prog) :
     VariableValues L prog :=
   (FiniteMap.locate (states_memKey s sv)).1
 
 omit [Lattice L] in
-/-- Agda: `variablesAt-∈`. -/
+lemma variablesAt_mem (s : prog.State) (sv : StateVariables L prog) :
-theorem variablesAt_mem (s : prog.State) (sv : StateVariables L prog) :
     (s, variablesAt s sv) ∈ sv :=
   (FiniteMap.locate (states_memKey s sv)).2
 
-/-- Agda: `m₁≼m₂⇒m₁[k]ᵐ≼m₂[k]ᵐ`, specialized the way `Forward.agda` uses it. -/
+lemma variablesAt_le {sv₁ sv₂ : StateVariables L prog} (hle : sv₁ ≤ sv₂)
-theorem variablesAt_le {sv₁ sv₂ : StateVariables L prog} (hle : sv₁ ≤ sv₂)
     (s : prog.State) : variablesAt s sv₁ ≤ variablesAt s sv₂ :=
   FiniteMap.le_of_mem_mem prog.states_nodup hle
     (variablesAt_mem s sv₁) (variablesAt_mem s sv₂)
 
 variable [FiniteHeightLattice L]
 
-/-- Agda: `joinForKey`. -/
 def joinForKey (k : prog.State) (sv : StateVariables L prog) :
     VariableValues L prog :=
   (sv.valuesAt (prog.incoming k)).foldr (· ⊔ ·) (botV L prog)
 
-/-- Agda: `joinForKey-Mono`. -/
+lemma joinForKey_mono (k : prog.State) :
-theorem joinForKey_mono (k : prog.State) :
     Monotone (joinForKey (L := L) k) := by
   intro sv₁ sv₂ hle
   exact foldr_mono _ (FiniteMap.valuesAt_le hle (prog.incoming k)) (le_refl _)
     (fun b _ _ hab => sup_le_sup_right hab b)
     (fun a _ _ hab => sup_le_sup_left hab a)
 
-/-- Agda: `joinAll` (the "Exercise 4.26" generalized update with `f = id`). -/
 def joinAll (sv : StateVariables L prog) : StateVariables L prog :=
   FiniteMap.generalizedUpdate id joinForKey prog.states sv
 
-/-- Agda: `joinAll-Mono`. -/
+lemma joinAll_mono : Monotone (joinAll (L := L) (prog := prog)) :=
-theorem joinAll_mono : Monotone (joinAll (L := L) (prog := prog)) :=
   FiniteMap.generalizedUpdate_monotone monotone_id joinForKey_mono
 
-/-- Agda: `joinAll-k∈ks-≡`. -/
+lemma 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 sv) :
     vs = joinForKey s sv :=
   FiniteMap.generalizedUpdate_mem_eq (prog.states_complete s) h
 
-/-- Agda: `variablesAt-joinAll`. -/
+lemma variablesAt_joinAll (s : prog.State) (sv : StateVariables L prog) :
-theorem variablesAt_joinAll (s : prog.State) (sv : StateVariables L prog) :
     variablesAt s (joinAll sv) = joinForKey s sv :=
   joinAll_mem_eq (variablesAt_mem s (joinAll sv))
 
-/-! ### Lifting an interpretation to variable maps -/
+class StateInterpretation (L : Type) [Lattice L] (prog : Program) where
+  Proj : Type
+  Pre : ∀ {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}, Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂ → Proj
+  Post : ∀ {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}, Trace prog.cfg s₁ s₂ ρ₁ ρ₂ → Proj
 
-variable [I : LatticeInterpretation L]
+  interp : VariableValues L prog → (p : Proj) → Prop
+  interp_sup : ∀ {vs₁ vs₂ : VariableValues L prog} {p : Proj},
+    interp vs₁ p ∨ interp vs₂ p → interp (vs₁ ⊔ vs₂) p
+  interp_inf : ∀ {vs₁ vs₂ : VariableValues L prog} {p : Proj},
+    interp vs₁ p ∧ interp vs₂ p → interp (vs₁ ⊓ vs₂) p
 
-omit [FiniteHeightLattice L] in
+  post_pre : ∀ {vs} {s₁ s₂ s₃: prog.State} {ρ₁ ρ₂ : Env}
-/-- Agda: `⟦_⟧ᵛ`. -/
+    (tr : Trace prog.cfg s₁ s₂ ρ₁ ρ₂) (hedge : (s₂, s₃) ∈ prog.cfg.edges),
-def interpV (vs : VariableValues L prog) (ρ : Env) : Prop :=
+    interp vs (Post tr) → interp vs (Pre (tr.addEdge hedge))
-  ∀ (k : String) (l : L), (k, l) ∈ vs →
-    ∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v
 
-/-- Agda: `⟦⊥ᵛ⟧ᵛ∅`. -/
+instance [S : StateInterpretation L prog] :
-theorem interpV_botV_nil : interpV (botV L prog) [] := by
+    Interp (VariableValues L prog) (S.Proj → Prop) :=
-  intro k l _ v hmem
+  ⟨S.interp⟩
-  cases hmem
 
-omit [FiniteHeightLattice L] in
+lemma interp_foldr [S : StateInterpretation L prog]
-/-- Agda: `⟦⟧ᵛ-⊔ᵛ-∨`. -/
+    {vs : VariableValues L prog} {vss : List (VariableValues L prog)}
-theorem interpV_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env}
+    {p : S.Proj} (hvs : ⟦ vs ⟧ p) (hmem : vs ∈ vss) :
-    (h : interpV vs₁ ρ ∨ interpV vs₂ ρ) : interpV (vs₁ ⊔ vs₂) ρ := by
+    ⟦ vss.foldr (· ⊔ ·) (botV L prog) ⟧ p := by
-  intro k l hmem v hv
-  obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem
-  rcases h with h | h
-  · exact I.interp_sup v (Or.inl (h _ _ h₁ _ hv))
-  · exact I.interp_sup v (Or.inr (h _ _ h₂ _ hv))
-
-/-- Agda: `⟦⟧ᵛ-foldr`. -/
-theorem interpV_foldr {vs : VariableValues L prog}
-    {vss : List (VariableValues L prog)} {ρ : Env}
-    (hvs : interpV vs ρ) (hmem : vs ∈ vss) :
-    interpV (vss.foldr (· ⊔ ·) (botV L prog)) ρ := by
   induction vss with
   | nil => cases hmem
   | cons vs' vss' ih =>
     rcases List.mem_cons.mp hmem with rfl | hmem'
-    · exact interpV_sup (Or.inl hvs)
+    · exact S.interp_sup (Or.inl hvs)
-    · exact interpV_sup (Or.inr (ih hmem'))
+    · exact S.interp_sup (Or.inr (ih hmem'))
+
+variable [I : LatticeInterpretation L]
+
+instance : StateInterpretation L prog where
+  Proj := Env
+  Pre := fun {_ _ _ ρ₂} _ => ρ₂
+  Post := fun {_ _ _ ρ₂} _ => ρ₂
+
+  interp vs ρ := ∀ (k : String) (l : L), (k, l) ∈ vs →
+    ∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v
+  interp_sup := by
+    intro vs₁ vs₂ ρ h k l hmem v hv
+    obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem
+    rcases h with h | h
+    · exact I.interp_sup v (Or.inl (h _ _ h₁ _ hv))
+    · exact I.interp_sup v (Or.inr (h _ _ h₂ _ hv))
+  interp_inf := by
+    intro vs₁ vs₂ ρ h k l hmem v hv
+    obtain ⟨l₁, l₂, rfl, h₁, h₂⟩ := FiniteMap.mem_inf hmem
+    exact I.interp_inf v ⟨h.1 _ _ h₁ _ hv, h.2 _ _ h₂ _ hv⟩
+  post_pre := by simp
+
+
+end Forward
 
 end Spa

lean/Spa/Analysis/Reaching.lean

@@ -0,0 +1,131 @@
+import Spa.Analysis.Forward
+import Spa.Lattice.Finset
+import Spa.Showable
+
+namespace Spa
+
+open Forward
+
+instance {n : ℕ} : Showable (Finset (Fin n)) :=
+  ⟨fun s =>
+    "{" ++ (List.finRange n).foldr
+        (fun i rest => if i ∈ s then show' i ++ ", " ++ rest else rest) ""
+        ++ "}"⟩
+
+abbrev DefSet (prog : Program) : Type := Finset prog.State
+
+namespace ReachingAnalysis
+
+variable (prog : Program)
+
+def eval (s : prog.State) (vs : VariableValues (DefSet prog) prog) : VariableValues (DefSet prog) prog :=
+  match prog.code s with
+  | none => vs
+  | some bs =>
+    match bs with
+    | .assign k _ => FiniteMap.generalizedUpdate id (fun _ _ => {s}) [k] vs
+    | .noop => vs
+
+lemma eval_mono (s : prog.State) :
+    Monotone (eval prog s) := by
+  intros vs₁ vs₂ hle
+  unfold eval; split <;> try simpa
+  split <;> try simpa
+  apply FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => monotone_const)
+  assumption
+
+instance stmtEvaluator : StmtEvaluator (DefSet prog) prog :=
+  ⟨eval prog, eval_mono prog⟩
+
+def output : String :=
+  show' (result (DefSet prog) prog)
+
+/-- Executed nodes, most recent first. Instructions are read from `prog.code`.
+    This is `Path.steps` (chronological) reversed, so facts about concatenating
+    traces reduce to mathlib's `List.append`/`List.reverse` lemmas. -/
+abbrev Run (prog : Program) : Type := List prog.State
+
+/-- The first node in a newest-first history whose instruction assigns `x`. -/
+@[aesop unsafe cases]
+inductive LastAssign (prog : Program) (x : String) : Run prog → prog.State → Prop
+  | here (s : prog.State) (e : Expr) (rest : Run prog)
+      (hc : prog.code s = some (.assign x e)) :
+      LastAssign prog x (s :: rest) s
+  | there (s : prog.State) (rest : Run prog) {n : prog.State} :
+      (∀ e, prog.code s ≠ some (.assign x e)) → LastAssign prog x rest n →
+      LastAssign prog x (s :: rest) n
+
+def runOfPath {a b : Configuration prog.cfg} (p : Path prog.cfg a b) : Run prog :=
+  p.steps.reverse
+
+abbrev runOfTraceₗ {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂) : Run prog := runOfPath prog tr
+
+abbrev runOfTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
+    (tr : Trace prog.cfg s₁ s₂ ρ₁ ρ₂) : Run prog := runOfPath prog tr
+
+instance stateInterp : StateInterpretation (DefSet prog) prog where
+  Proj := Run prog
+  Pre := fun tr => runOfPath prog tr
+  Post := fun tr => runOfPath prog tr
+
+  interp vs run := ∀ (x : String) (assigners : DefSet prog), (x, assigners) ∈ vs →
+    ∀ (n : prog.State), LastAssign prog x run n → n ∈ assigners
+  interp_sup := by
+    intro vs₁ vs₂ run h x assigners hmem n hla
+    obtain ⟨a₁, a₂, rfl, h₁, h₂⟩ := FiniteMap.mem_sup hmem
+    aesop (add simp Finset.mem_union)
+  interp_inf := by
+    intro vs₁ vs₂ run h x assigners hmem n hla
+    obtain ⟨a₁, a₂, rfl, h₁, h₂⟩ := FiniteMap.mem_inf hmem
+    aesop (add simp Finset.mem_inter)
+
+  post_pre := by
+    intro vs s₁ s₂ s₃ ρ₁ ρ₂ tr hedge hvs
+    simpa only [runOfPath, Trace.addEdge, Path.steps_append, Path.single,
+      Path.steps, Step.steps, List.append_nil] using hvs
+
+private lemma valid_step (s : prog.State)
+    {vs : VariableValues (DefSet prog) prog} {run : Run prog}
+    (hvs : ⟦vs⟧ run) :
+    ⟦eval prog s vs⟧ ((match prog.code s with | none => [] | some _ => [s]) ++ run) := by
+  cases hcode : prog.code s with
+  | none => simpa [eval, hcode] using hvs
+  | some bs =>
+    cases bs with
+    | noop =>
+      simp [eval, hcode]
+      intro x assigners hmem n hla; aesop (add simp hcode)
+    | assign x e =>
+      simp [eval, hcode]; intro k assigners hmem n hla
+      by_cases hx : k = x
+      · subst hx
+        have hd := FiniteMap.generalizedUpdate_mem_eq (List.mem_singleton.mpr rfl) hmem
+        rcases hla <;> simp [hd] <;> aesop (add simp hcode)
+      · have hmem' := FiniteMap.generalizedUpdate_not_mem_backward
+          (fun hc => hx (List.mem_singleton.mp hc)) hmem
+        aesop (add simp hcode)
+
+instance validStateEvaluator : ValidStateEvaluator (DefSet prog) prog where
+  valid := by
+    intro s₁ s₂ ρ₁ ρ₂ ρ₃ vs tr hbs hvs
+    change ⟦vs⟧ (runOfPath prog tr) at hvs
+    change ⟦eval prog s₂ vs⟧ (runOfPath prog (Path.append tr (.single (.execute hbs))))
+    cases hcode : prog.code s₂ <;>
+      simpa [runOfPath, Path.single, Path.steps, Step.steps, hcode] using valid_step prog s₂ hvs
+  botV_init := by intro x assigners _ n hla; cases hla
+
+theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+    ⟦ variablesAt prog.finalState (result (DefSet prog) prog) ⟧
+      (runOfTrace prog (prog.trace hrun)) :=
+  Forward.analyze_correct' (DefSet prog) prog hrun
+
+theorem analyze_correct_at {s : prog.State} {ρin ρout : Env}
+    (hr : Reaches s ρin ρout) :
+    ⟦ joinForKey s (result (DefSet prog) prog) ⟧ (runOfTraceₗ prog hr.pre)
+      ∧ ⟦ variablesAt s (result (DefSet prog) prog) ⟧ (runOfTrace prog hr.post) :=
+  Forward.analyze_correct_at (DefSet prog) prog hr
+
+end ReachingAnalysis
+
+end Spa

lean/Spa/Analysis/Reaching/Paths.lean

@@ -0,0 +1,54 @@
+import Spa.Analysis.Reaching
+import Spa.Language.TraceProperties
+
+namespace Spa
+namespace ReachingAnalysis
+
+/-- The most recent assignment occurs in the history being searched. -/
+lemma LastAssign.mem {prog : Program} {x : String} {run : Run prog} {d : prog.State}
+    (h : LastAssign prog x run d) : d ∈ run := by
+  induction h <;> aesop
+
+/-- Appending older history cannot displace an already-found assignment. -/
+lemma LastAssign.append {prog : Program} {x : String} {new : Run prog} {d : prog.State}
+    (h : LastAssign prog x new d) (old : Run prog) :
+    LastAssign prog x (new ++ old) d := by
+  induction h with
+  | here s rhs rest hc => exact .here s rhs _ hc
+  | there s rest hn h ih => exact .there s _ hn ih
+
+/-- A history containing a write to `x` has a most recent assignment to `x`. -/
+lemma lastAssign_of_write {prog : Program} {x : String} {run : Run prog}
+    (hw : ∃ d ∈ run, ∃ rhs, prog.code d = some (.assign x rhs)) :
+    ∃ d, LastAssign prog x run d := by
+  induction run with
+  | nil => simp at hw
+  | cons d rest ih =>
+      by_cases hx : ∃ rhs, prog.code d = some (.assign x rhs)
+      · obtain ⟨rhs, hc⟩ := hx
+        exact ⟨d, .here d rhs rest hc⟩
+      · have hw' : ∃ j ∈ rest, ∃ rhs, prog.code j = some (.assign x rhs) := by
+          obtain ⟨j, hm, rhs, hc⟩ := hw
+          rcases List.mem_cons.mp hm with rfl | hm
+          · exact False.elim (hx ⟨rhs, hc⟩)
+          · exact ⟨j, hm, rhs, hc⟩
+        obtain ⟨j, hj⟩ := ih hw'
+        exact ⟨j, .there d rest (by simpa using hx) hj⟩
+
+/-- Outside reaching definitions rule out any write in a confined intervening
+path. No equality of static sites is used to infer equality of events. -/
+lemma Path.preserves_of_lastAssign_outside {prog : Program}
+    {a b c : Configuration prog.cfg} (pre : Path prog.cfg a b) (seg : Path prog.cfg b c)
+    {x : String} (sites : Set prog.State)
+    (hin : ∀ d ∈ seg.steps, d ∈ sites)
+    (hout : ∀ d, LastAssign prog x (runOfPath prog (pre.append seg)) d → d ∉ sites) :
+    ∀ v, Env.Mem (x, v) b.2 ↔ Env.Mem (x, v) c.2 := by
+  apply seg.preserves_unwritten
+  intro d hm rhs hc
+  obtain ⟨j, hl⟩ := lastAssign_of_write ⟨d, List.mem_reverse.mpr hm, rhs, hc⟩
+  apply hout j
+  · simpa [runOfPath, List.reverse_append] using hl.append (runOfPath prog pre)
+  · exact hin j (List.mem_reverse.mp hl.mem)
+
+end ReachingAnalysis
+end Spa

lean/Spa/Analysis/Sign.lean

@@ -1,15 +1,20 @@
 import Spa.Analysis.Forward
 import Spa.Analysis.Utils
+import Spa.Interp
 import Spa.Showable
 
 namespace Spa
 
+open Forward
+
 inductive Sign where
   | plus
   | minus
   | zero
   deriving DecidableEq
 
+attribute [aesop safe cases] Sign
+
 instance : Showable Sign :=
   ⟨fun
     | .plus => "+"
@@ -52,31 +57,15 @@ def minus : SignLattice → SignLattice → SignLattice
   | mk .zero, mk .minus => mk .plus
   | mk .zero, mk .zero => mk .zero
 
-theorem plus_mono₂ : Monotone₂ plus :=
+lemma plus_mono₂ : Monotone₂ plus :=
   AboveBelow.monotone₂_of_strict plus
-    (fun y => by cases y <;> rfl)
+    (fun y => by aesop) (fun x => by aesop)
-    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
+    (fun y hy => by aesop) (fun x hx => by aesop)
-    (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))
 
-theorem plus_mono_left (s₂ : SignLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
+lemma minus_mono₂ : Monotone₂ minus :=
-
-theorem plus_mono_right (s₁ : SignLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
-
-theorem minus_mono₂ : Monotone₂ minus :=
   AboveBelow.monotone₂_of_strict minus
-    (fun y => by cases y <;> rfl)
+    (fun y => by aesop) (fun x => by aesop)
-    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
+    (fun y hy => by aesop) (fun x hx => by aesop)
-    (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))
-
-theorem minus_mono_left (s₂ : SignLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
-
-theorem minus_mono_right (s₁ : SignLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
 
 def interpSign : SignLattice → Value → Prop
   | .bot, _ => False
@@ -85,7 +74,7 @@ def interpSign : SignLattice → Value → Prop
   | .mk .zero, v => v = .int 0
   | .mk .minus, v => ∃ n : ℕ, v = .int (-(n + 1))
 
-theorem interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Value} :
+lemma interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Value} :
     ¬(interpSign (.mk s₁) v ∧ interpSign (.mk s₂) v) := by
   rintro ⟨h₁, h₂⟩
   rcases s₁ <;> rcases s₂ <;> try exact hne rfl
@@ -113,32 +102,27 @@ theorem interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Val
     injection hv with hz
     omega
 
-theorem interpSign_sup {s₁ s₂ : SignLattice} (v : Value)
-    (h : interpSign s₁ v ∨ interpSign s₂ v) : interpSign (s₁ ⊔ s₂) v :=
-  AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
-
-theorem interpSign_inf {s₁ s₂ : SignLattice} (v : Value)
-    (h : interpSign s₁ v ∧ interpSign s₂ v) : interpSign (s₁ ⊓ s₂) v :=
-  AboveBelow.interp_inf_of (fun hne _ => interpSign_mk_disjoint hne) v h
-
 instance signInterpretation : LatticeInterpretation SignLattice where
   interp := interpSign
-  interp_sup := fun {l₁ l₂} v h => interpSign_sup (s₁ := l₁) (s₂ := l₂) v h
+  interp_sup := fun v h => AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
-  interp_inf := fun {l₁ l₂} v h => interpSign_inf (s₁ := l₁) (s₂ := l₂) v h
+  interp_inf := fun v h => AboveBelow.interp_inf_of (fun hne _ => interpSign_mk_disjoint hne) v h
 
 namespace SignAnalysis
 
 variable (prog : Program)
 
+/-- The sign of an integer literal. -/
+def signOf (z : ℤ) : SignLattice :=
+  if z = 0 then .mk .zero else if 0 < z then .mk .plus else .mk .minus
+
 def eval : Expr → VariableValues SignLattice prog → SignLattice
   | .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 0, _ => .mk .zero
+  | .num z, _ => signOf z
-  | .num (_ + 1), _ => .mk .plus
 
-theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
+lemma eval_mono (e : Expr) : Monotone (eval prog e) := by
   induction e with
   | add e₁ e₂ ih₁ ih₂ =>
     intro vs₁ vs₂ h
@@ -150,15 +134,15 @@ theorem eval_mono (e : Expr) : Monotone (eval prog e) := by
     intro vs₁ vs₂ h
     simp only [eval]
     by_cases hk : k ∈ prog.vars
-    · rw [dif_pos (FiniteMap.memKey_iff.mpr hk),
+    · rw [dif_pos (FiniteMap.MemKey_iff.mpr hk),
-          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)),
+    · rw [dif_neg (fun hm => hk (FiniteMap.MemKey_iff.mp hm)),
-          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₂ _
-    cases n <;> exact le_refl _
+    exact le_refl _
 
 instance exprEvaluator : ExprEvaluator SignLattice prog :=
   ⟨eval prog, eval_mono prog⟩
@@ -166,78 +150,48 @@ instance exprEvaluator : ExprEvaluator SignLattice prog :=
 def output : String :=
   show' (result SignLattice prog)
 
-theorem plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
+/-- A nonneg-shifted interpretation `∃ n : ℕ, z = n + 1` just means `z` is positive. -/
-    (h₁ : interpSign g₁ (.int z₁)) (h₂ : interpSign g₂ (.int z₂)) :
+private lemma int_pos_iff (z : ℤ) : (∃ n : ℕ, z = (n : ℤ) + 1) ↔ 0 < z := by
-    interpSign (plus g₁ g₂) (.int (z₁ + z₂)) := by
+  constructor
-  rcases g₁ with _ | _ | s₁
+  · rintro ⟨n, rfl⟩; omega
-  · exact h₁.elim
+  · intro h; exact ⟨(z - 1).toNat, by omega⟩
-  · rcases g₂ with _ | _ | s₂
+
-    · exact h₂.elim
+/-- Dually, `∃ n : ℕ, z = -(n + 1)` just means `z` is negative. -/
-    · exact trivial
+private lemma int_neg_iff (z : ℤ) : (∃ n : ℕ, z = -((n : ℤ) + 1)) ↔ z < 0 := by
-    · exact trivial
+  constructor
-  · rcases g₂ with _ | _ | s₂
+  · rintro ⟨n, rfl⟩; omega
-    · exact h₂.elim
+  · intro h; exact ⟨(-z - 1).toNat, by omega⟩
-    · rcases s₁ <;> exact trivial
+
-    · rcases s₁ <;> rcases s₂ <;>
+/-- `signOf` really does describe the literal it was computed from. -/
-        simp only [plus, interpSign, Value.int.injEq] at h₁ h₂ ⊢ <;>
+lemma interp_signOf (z : ℤ) : ⟦signOf z⟧ (Value.int z) := by
-        try trivial
+  unfold signOf
-      · obtain ⟨n₁, rfl⟩ := h₁
+  split
-        obtain ⟨n₂, rfl⟩ := h₂
+  · case isTrue h => subst h; rfl
-        exact ⟨n₁ + n₂ + 1, by omega⟩
+  · rename_i hne
-      · obtain ⟨n₁, rfl⟩ := h₁
+    split
-        subst h₂
+    · case isTrue hpos =>
-        exact ⟨n₁, by omega⟩
+        simp only [signInterpretation, interpSign, Value.int.injEq, int_pos_iff]
-      · obtain ⟨n₁, rfl⟩ := h₁
+        exact hpos
-        obtain ⟨n₂, rfl⟩ := h₂
+    · case isFalse hnpos =>
-        exact ⟨n₁ + n₂ + 1, by omega⟩
+        simp only [signInterpretation, interpSign, Value.int.injEq, int_neg_iff]
-      · obtain ⟨n₁, rfl⟩ := h₁
-        subst h₂
-        exact ⟨n₁, by omega⟩
-      · subst h₁
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₂, by omega⟩
-      · subst h₁
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₂, by omega⟩
-      · subst h₁
-        subst h₂
         omega
 
-theorem minus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
+lemma plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
-    (h₁ : interpSign g₁ (.int z₁)) (h₂ : interpSign g₂ (.int z₂)) :
+    (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
-    interpSign (minus g₁ g₂) (.int (z₁ - z₂)) := by
+    ⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
-  rcases g₁ with _ | _ | s₁
+  rcases g₁ with _ | _ | s₁ <;> rcases g₂ with _ | _ | s₂ <;>
-  · exact h₁.elim
+    (try rcases s₁) <;> (try rcases s₂) <;>
-  · rcases g₂ with _ | _ | s₂
+    simp only [plus, signInterpretation, interpSign, Value.int.injEq, int_pos_iff, int_neg_iff]
-    · exact h₂.elim
+      at h₁ h₂ ⊢ <;>
-    · exact trivial
+    omega
-    · exact trivial
+
-  · rcases g₂ with _ | _ | s₂
+lemma minus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
-    · exact h₂.elim
+    (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
-    · rcases s₁ <;> exact trivial
+    ⟦minus g₁ g₂⟧ (.int (z₁ - z₂)) := by
-    · rcases s₁ <;> rcases s₂ <;>
+  rcases g₁ with _ | _ | s₁ <;> rcases g₂ with _ | _ | s₂ <;>
-        simp only [minus, interpSign, Value.int.injEq] at h₁ h₂ ⊢ <;>
+    (try rcases s₁) <;> (try rcases s₂) <;>
-        try trivial
+    simp only [minus, signInterpretation, interpSign, Value.int.injEq, int_pos_iff, int_neg_iff]
-      · obtain ⟨n₁, rfl⟩ := h₁
+      at h₁ h₂ ⊢ <;>
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₁ + n₂ + 1, by omega⟩
-      · obtain ⟨n₁, rfl⟩ := h₁
-        subst h₂
-        exact ⟨n₁, by omega⟩
-      · obtain ⟨n₁, rfl⟩ := h₁
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₁ + n₂ + 1, by omega⟩
-      · obtain ⟨n₁, rfl⟩ := h₁
-        subst h₂
-        exact ⟨n₁, by omega⟩
-      · subst h₁
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₂, by omega⟩
-      · subst h₁
-        obtain ⟨n₂, rfl⟩ := h₂
-        exact ⟨n₂, by omega⟩
-      · subst h₁
-        subst h₂
     omega
 
 instance eval_valid : ValidExprEvaluator SignLattice prog := by
@@ -246,13 +200,11 @@ instance eval_valid : ValidExprEvaluator SignLattice prog := by
   induction hev with
   | num n =>
     intro _
-    show interpSign (eval prog (.num n) vs) (.int n)
+    show ⟦eval prog (.num n) vs⟧ (.int n)
-    cases n with
+    exact interp_signOf n
-    | zero => rfl
-    | succ n' => exact ⟨n', congrArg Value.int (by norm_cast)⟩
   | var x v hxv =>
     intro hvs
-    show interpSign (eval prog (.var x) vs) v
+    show ⟦eval prog (.var x) vs⟧ v
     simp only [eval]
     by_cases hk : FiniteMap.MemKey x vs
     · rw [dif_pos hk]
@@ -261,20 +213,26 @@ instance eval_valid : ValidExprEvaluator SignLattice prog := by
       exact trivial
   | add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
     intro hvs
-    have h₁ : interpSign (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
-    have h₂ : interpSign (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
-    show interpSign (eval prog (.add e₁ e₂) vs) (.int (z₁ + z₂))
+    show ⟦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₁ : interpSign (eval prog e₁ vs) (.int z₁) := ih₁ hvs
+    have h₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
-    have h₂ : interpSign (eval prog e₂ vs) (.int z₂) := ih₂ hvs
+    have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
-    show interpSign (eval prog (.sub e₁ e₂) vs) (.int (z₁ - z₂))
+    show ⟦eval prog (.sub e₁ e₂) vs⟧ (.int (z₁ - z₂))
     exact minus_valid h₁ h₂
 
 theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
-    interpV (variablesAt prog.finalState (result SignLattice prog)) ρ :=
+    ⟦ variablesAt prog.finalState (result SignLattice prog) ⟧ ρ :=
-  Spa.analyze_correct SignLattice prog hrun
+  Forward.analyze_correct SignLattice prog hrun
+
+theorem analyze_correct_at {s : prog.State} {ρin ρout : Env}
+    (hr : Reaches s ρin ρout) :
+    ⟦ joinForKey s (result SignLattice prog) ⟧ ρin
+      ∧ ⟦ variablesAt s (result SignLattice prog) ⟧ ρout :=
+  Forward.analyze_correct_at SignLattice prog hr
 
 end SignAnalysis
 

lean/Spa/Analysis/Utils.lean

@@ -1,13 +1,8 @@
-/-
-Port of `Analysis/Utils.agda`. The `≼ᴼ-trans` module parameter lifts into the
-`Preorder` instance.
--/
 import Spa.Lattice
 
 namespace Spa
 
-/-- Agda: `eval-combine₂`. -/
+lemma eval_combine₂ {O : Type*} [Preorder O] {combine : O → O → O}
-theorem eval_combine₂ {O : Type*} [Preorder O] {combine : O → O → O}
     (hmono : Monotone₂ combine) {o₁ o₂ o₃ o₄ : O}
     (h₁ : o₁ ≤ o₃) (h₂ : o₂ ≤ o₄) : combine o₁ o₂ ≤ combine o₃ o₄ :=
   le_trans (hmono.1 o₂ h₁) (hmono.2 o₃ h₂)

lean/Spa/Fixedpoint.lean

@@ -1,10 +1,12 @@
 import Spa.Lattice
 
-namespace Spa.Fixedpoint
+namespace Spa
+
+namespace Fixedpoint
 
 open FiniteHeightLattice (height)
 
-variable {α : Type*} [Lattice α] [DecidableEq α] [FiniteHeightLattice α]
+variable {α : Type*} [DecidableEq α] [FiniteHeightLattice α]
 
 def doStep (f : α → α) (hf : Monotone f) :
     ∀ (g : ℕ) (c : LTSeries α), c.length + g = height (α := α) + 1 →
@@ -22,8 +24,7 @@ def doStep (f : α → α) (hf : Monotone f) :
 def fix (f : α → α) (hf : Monotone f) : {a : α // a = f a} :=
   doStep f hf (height (α := α) + 1) (RelSeries.singleton _ ⊥)
     (by simp)
-    (by simpa [RelSeries.last_singleton]
+    (by simp)
-          using FiniteHeightLattice.bot_le α (f ⊥))
 
 def aFix (f : α → α) (hf : Monotone f) : α :=
   (fix f hf).1
@@ -32,12 +33,13 @@ theorem aFix_eq (f : α → α) (hf : Monotone f) :
     aFix f hf = f (aFix f hf) :=
   (fix f hf).2
 
-theorem doStep_le (f : α → α) (hf : Monotone f)
+lemma doStep_le (f : α → α) (hf : Monotone f)
     {b : α} (hb : b = f b) :
     ∀ (g : ℕ) (c : LTSeries α) (hlen : c.length + g = height (α := α) + 1)
       (hle : c.last ≤ f c.last), c.last ≤ b →
       (doStep f hf g c hlen hle : α) ≤ b
-  | 0, c, hlen, _ => fun _ => absurd (FiniteHeightLattice.chains_bounded c) (by omega)
+  | 0, c, hlen, _ => fun _ =>
+    absurd (FiniteHeightLattice.chains_bounded c) (by omega)
   | g + 1, c, hlen, hle => fun hcb => by
     rw [doStep]
     split
@@ -47,6 +49,8 @@ theorem doStep_le (f : α → α) (hf : Monotone f)
 
 theorem aFix_le (f : α → α) (hf : Monotone f)
     {a : α} (ha : a = f a) : aFix f hf ≤ a :=
-  doStep_le f hf ha _ _ _ _ (by simpa using FiniteHeightLattice.bot_le α a)
+  doStep_le f hf ha _ _ _ _ (by simp)
 
-end Spa.Fixedpoint
+end Fixedpoint
+
+end Spa

lean/Spa/Interp.lean

@@ -0,0 +1,20 @@
+import Mathlib.Tactic.TypeStar
+
+/-!
+
+# Interpretation to a Semantic Domain
+
+This file serves to introduce the double-angle-bracket "denotation"
+notation by prodiving a class instance `Interp`, whose single
+method `interp` is what the double brackets map to. -/
+
+namespace Spa
+
+/-- A type `α` that implements this class has denotation / meaning
+   in the semantic domain `dom`. -/
+class Interp (α : Type*) (dom : outParam Type*) where
+  interp : α → dom
+
+notation:max (priority := high) "⟦" v "⟧" => Interp.interp v
+
+end Spa

lean/Spa/Isomorphism.lean

@@ -1,27 +0,0 @@
-import Spa.Lattice
-
-namespace Spa
-
-/-- Agda: `TransportFiniteHeight.finiteHeightLattice`. Transport a
-`FiniteHeightLattice` structure along a monotone inverse pair `f : α → β`,
-`g : β → α`. -/
-def FiniteHeightLattice.transport {α β : Type*} [Lattice α] [Lattice β]
-    [I : FiniteHeightLattice α] (f : α → β) (g : β → α)
-    (hf : Monotone f) (hg : Monotone g)
-    (hgf : ∀ a, g (f a) = a) (hfg : ∀ b, f (g b) = b) :
-    FiniteHeightLattice β where
-  bot := f ⊥
-  top := f ⊤
-  height := I.height
-  longest_chain :=
-    { series :=
-        I.longest_chain.series.map f
-          (hf.strictMono_of_injective (Function.LeftInverse.injective hgf))
-      head_series := congrArg f I.longest_chain.head_series
-      last_series := congrArg f I.longest_chain.last_series
-      length_series := I.longest_chain.length_series }
-  chains_bounded := fun c =>
-    I.chains_bounded
-      (c.map g (hg.strictMono_of_injective (Function.LeftInverse.injective hfg)))
-
-end Spa

lean/Spa/Language.lean

@@ -1,90 +1,6 @@
-/-
-Port of `Language.agda` (the `Program` record and re-exports).
-
-Correspondence:
-  Program record      ↦ structure Program (defs in the `Program` namespace)
-  graph               ↦ Program.graph
-  State               ↦ Program.State
-  initialState        ↦ Program.initialState
-  finalState          ↦ Program.finalState
-  trace               ↦ Program.trace
-  vars, vars-Unique   ↦ Program.vars, Program.vars_nodup
-                        (Finset.toList + Finset.nodup_toList replace
-                        `to-Listˢ` and the intrinsic MapSet uniqueness)
-  states, states-complete, states-Unique
-                      ↦ Program.states, .states_complete, .states_nodup
-  code                ↦ Program.code
-  _≟_, _≟ᵉ_           ↦ (instances, automatic for Fin/products)
-  incoming            ↦ Program.incoming
-  initialState-pred-∅ ↦ Program.incoming_initialState_eq_nil
-  edge⇒incoming       ↦ Program.mem_incoming_of_edge
--/
 import Spa.Language.Base
 import Spa.Language.Semantics
 import Spa.Language.Graphs
 import Spa.Language.Traces
 import Spa.Language.Properties
-import Mathlib.Data.Finset.Sort
+import Spa.Language.Program
-import Mathlib.Data.String.Basic
-
-namespace Spa
-
-structure Program where
-  rootStmt : Stmt
-
-namespace Program
-
-variable (p : Program)
-
-def graph : Graph := Graph.wrap (buildCfg p.rootStmt)
-
-abbrev State : Type := p.graph.Index
-
-def initialState : p.State := (buildCfg p.rootStmt).wrapInput
-
-def finalState : p.State := (buildCfg p.rootStmt).wrapOutput
-
-/-- Agda: `Program.trace`. -/
-theorem trace {ρ : Env} (h : EvalStmt [] p.rootStmt ρ) :
-    Trace p.graph p.initialState p.finalState [] ρ := by
-  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := EndToEndTrace.wrap (buildCfg_sufficient h)
-  rw [Graph.wrap_inputs, List.mem_singleton] at h₁
-  rw [Graph.wrap_outputs, List.mem_singleton] at h₂
-  subst h₁; subst h₂
-  exact tr
-
-/-- Agda: `vars` (via `vars-Set = Stmt-vars rootStmt`). `Finset.toList` is
-noncomputable, so the variables are listed in sorted order instead — this is
-the computable stand-in for MapSet's `to-List`. -/
-def vars : List String := p.rootStmt.vars.sort (· ≤ ·)
-
-/-- Agda: `vars-Unique`. -/
-theorem vars_nodup : p.vars.Nodup := Finset.sort_nodup _ _
-
-def states : List p.State := p.graph.indices
-
-/-- Agda: `states-complete`. -/
-theorem states_complete (s : p.State) : s ∈ p.states := p.graph.mem_indices s
-
-/-- Agda: `states-Unique`. -/
-theorem states_nodup : p.states.Nodup := p.graph.nodup_indices
-
-/-- Agda: `code`. -/
-def code (st : p.State) : List BasicStmt := p.graph.nodes st
-
-/-- Agda: `incoming`. -/
-def incoming (s : p.State) : List p.State := p.graph.predecessors s
-
-/-- Agda: `initialState-pred-∅`. -/
-theorem incoming_initialState_eq_nil : p.incoming p.initialState = [] :=
-  Graph.wrap_predecessors_eq_nil (buildCfg p.rootStmt) p.initialState
-    (by rw [Graph.wrap_inputs]; exact List.mem_singleton_self _)
-
-/-- Agda: `edge⇒incoming`. -/
-theorem mem_incoming_of_edge {s₁ s₂ : p.State}
-    (h : (s₁, s₂) ∈ p.graph.edges) : s₁ ∈ p.incoming s₂ :=
-  p.graph.mem_predecessors_of_edge h
-
-end Program
-
-end Spa

lean/Spa/Language/Base.lean

@@ -1,37 +1,39 @@
-/-
-Port of `Language/Base.agda`.
-
-`StringSet` (built on `Lattice/MapSet.agda`, itself on `Lattice/Map.agda`) is
-lifted to mathlib's `Finset String`: `insertˢ ↦ insert`, `emptyˢ ↦ ∅`,
-`singletonˢ ↦ {·}`, `_⊔ˢ_ ↦ ∪`, `to-List ↦ Finset.toList` (with
-`Finset.nodup_toList` standing in for the intrinsic `Unique` proof).
-
-Constructor renaming (Agda mixfix has no direct Lean counterpart):
-  _+_ ↦ Expr.add      _-_ ↦ Expr.sub     `_ ↦ Expr.var    #_ ↦ Expr.num
-  _←_ ↦ BasicStmt.assign              noop ↦ BasicStmt.noop
-  ⟨_⟩ ↦ Stmt.basic    _then_ ↦ Stmt.andThen
-  if_then_else_ ↦ Stmt.ifElse         while_repeat_ ↦ Stmt.whileLoop
-
-The `_∈ᵉ_` / `_∈ᵇ_` variable-occurrence relations are ported as
-`Expr.HasVar` / `BasicStmt.HasVar`; the commented-out lemmas relating them to
-`Expr-vars` remain unported (they were commented out in the Agda, too).
--/
 import Mathlib.Data.Finset.Basic
 
+/-!
+
+# Base Language
+
+This file defines the core object language for the program analysis and
+transformation. It's a very basic imperative language.
+
+Program points are identified by their node in the control flow graph rather than
+by an identifier stored in the AST: a recursion over a `Stmt` threads a
+`Spa.GGraph.Embed` of the subtree's CFG into the whole program's (starting from
+`Spa.Program.rootEmbed`), which yields the CFG index of each basic statement
+along with a proof that the node carries it.
+
+-/
+
 namespace Spa
 
+/-- A value-producing expression. Currently, this cannot have side effects. -/
 inductive Expr where
   | add (e₁ e₂ : Expr)
   | sub (e₁ e₂ : Expr)
   | var (x : String)
-  | num (n : ℕ)
+  | num (z : ℤ)
   deriving DecidableEq
 
+/-- A statement that cannot alter control flow (and thus, can be part of a basic block).
+
+    This differs from, e.g., a loop, which can cause execution to jump to its top several times. -/
 inductive BasicStmt where
   | assign (x : String) (e : Expr)
   | noop
   deriving DecidableEq
 
+/-- Any statements, which may or may not change program state (variable assignments). -/
 inductive Stmt where
   | basic (bs : BasicStmt)
   | andThen (s₁ s₂ : Stmt)
@@ -39,40 +41,23 @@ inductive Stmt where
   | whileLoop (e : Expr) (s : Stmt)
   deriving DecidableEq
 
-/-- Agda: `_∈ᵉ_`. -/
+/-- Variables mentioned in this expression. -/
-inductive Expr.HasVar : String → Expr → Prop
-  | addLeft {e₁ e₂ k} : Expr.HasVar k e₁ → Expr.HasVar k (.add e₁ e₂)
-  | addRight {e₁ e₂ k} : Expr.HasVar k e₂ → Expr.HasVar k (.add e₁ e₂)
-  | subLeft {e₁ e₂ k} : Expr.HasVar k e₁ → Expr.HasVar k (.sub e₁ e₂)
-  | subRight {e₁ e₂ k} : Expr.HasVar k e₂ → Expr.HasVar k (.sub e₁ e₂)
-  | here {k} : Expr.HasVar k (.var k)
-
-/-- Agda: `_∈ᵇ_`. -/
-inductive BasicStmt.HasVar : String → BasicStmt → Prop
-  | assignLeft {k e} : BasicStmt.HasVar k (.assign k e)
-  | assignRight {k k' e} : Expr.HasVar k e → BasicStmt.HasVar k (.assign k' e)
-
-/-- Agda: `Expr-vars`. -/
 def Expr.vars : Expr → Finset String
   | .add l r => l.vars ∪ r.vars
   | .sub l r => l.vars ∪ r.vars
   | .var s => {s}
   | .num _ => ∅
 
-/-- Agda: `BasicStmt-vars`. -/
+/-- Variables assigned or mentioned in this basic statement. -/
 def BasicStmt.vars : BasicStmt → Finset String
   | .assign x e => {x} ∪ e.vars
   | .noop => ∅
 
-/-- Agda: `Stmt-vars`. -/
+/-- Variables assigned or mentioned in this statement. -/
 def Stmt.vars : Stmt → Finset String
   | .basic bs => bs.vars
   | .andThen s₁ s₂ => s₁.vars ∪ s₂.vars
   | .ifElse e s₁ s₂ => (e.vars ∪ s₁.vars) ∪ s₂.vars
   | .whileLoop e s => e.vars ∪ s.vars
 
-/-- Agda: `Stmts-vars`. -/
-def Stmt.varsList (ss : List Stmt) : Finset String :=
-  ss.foldr (fun s acc => s.vars ∪ acc) ∅
-
 end Spa

lean/Spa/Language/Equivalence.lean

@@ -0,0 +1,135 @@
+import Spa.Language.Semantics
+
+namespace Spa
+
+/-- Environments agree on the current values of the selected variables. -/
+def Env.AgreeOn (xs : Finset String) (ρ σ : Env) : Prop :=
+  ∀ x ∈ xs, ∀ v, Env.Mem (x, v) ρ ↔ Env.Mem (x, v) σ
+
+/-- Observable environment equality, ignoring shadowed bindings. -/
+def Env.Equiv (ρ σ : Env) : Prop :=
+  ∀ x v, Env.Mem (x, v) ρ ↔ Env.Mem (x, v) σ
+
+lemma Env.Mem.functional {ρ : Env} {x : String} {v w : Value}
+    (h : Env.Mem (x, v) ρ) (h' : Env.Mem (x, w) ρ) : v = w := by
+  induction ρ with
+  | nil => cases h
+  | cons pair rest ih =>
+      cases h <;> cases h' <;> aesop
+
+lemma Env.mem_cons {ρ : Env} {x y : String} {v w : Value} :
+    Env.Mem (x, v) ((y, w) :: ρ) ↔ (x = y ∧ v = w) ∨ (x ≠ y ∧ Env.Mem (x, v) ρ) := by
+  constructor
+  · intro h; cases h <;> aesop
+  · rintro (⟨rfl, rfl⟩ | ⟨hne, h⟩)
+    · exact .here _ _ _
+    · exact .there _ _ _ _ _ hne h
+
+lemma Env.Equiv.refl (ρ : Env) : Env.Equiv ρ ρ := fun _ _ => Iff.rfl
+lemma Env.Equiv.symm {ρ σ : Env} (h : Env.Equiv ρ σ) : Env.Equiv σ ρ :=
+  fun x v => (h x v).symm
+lemma Env.Equiv.trans {ρ σ τ : Env} (h : Env.Equiv ρ σ) (h' : Env.Equiv σ τ) :
+    Env.Equiv ρ τ := fun x v => (h x v).trans (h' x v)
+lemma Env.Equiv.cons {ρ σ : Env} (h : Env.Equiv ρ σ) (x : String) (v : Value) :
+    Env.Equiv ((x, v) :: ρ) ((x, v) :: σ) := by
+  intro y w; simp only [Env.mem_cons, h y w]
+
+lemma Env.cons_equiv_of_mem {ρ : Env} {x : String} {v : Value}
+    (h : Env.Mem (x, v) ρ) : Env.Equiv ((x, v) :: ρ) ρ := by
+  intro y w
+  rw [Env.mem_cons]
+  constructor
+  · rintro (⟨rfl, rfl⟩ | ⟨_, hw⟩) <;> assumption
+  · intro hw
+    by_cases he : y = x
+    · subst y; exact Or.inl ⟨rfl, hw.functional h⟩
+    · exact Or.inr ⟨he, hw⟩
+
+lemma EvalExpr.congr_env {ρ σ : Env} {e : Expr} {v : Value}
+    (h : EvalExpr ρ e v) (ha : Env.AgreeOn e.vars ρ σ) : EvalExpr σ e v := by
+  induction h with
+  | num => exact .num _ _
+  | var x v hm => exact .var _ _ _ ((ha x (by simp [Expr.vars]) v).mp hm)
+  | add a b u v _ _ iha ihb =>
+      exact .add _ _ _ _ _ (iha (fun x hx => ha x (Finset.mem_union_left _ hx)))
+        (ihb (fun x hx => ha x (Finset.mem_union_right _ hx)))
+  | sub a b u v _ _ iha ihb =>
+      exact .sub _ _ _ _ _ (iha (fun x hx => ha x (Finset.mem_union_left _ hx)))
+        (ihb (fun x hx => ha x (Finset.mem_union_right _ hx)))
+
+lemma EvalExpr.deterministic {ρ : Env} {e : Expr} {v w : Value}
+    (h : EvalExpr ρ e v) (h' : EvalExpr ρ e w) : v = w := by
+  induction h generalizing w with
+  | num => cases h'; rfl
+  | var _ _ hm => cases h' with | var _ _ hm' => exact hm.functional hm'
+  | add a b u v h₁ h₂ ih₁ ih₂ =>
+      cases h' with
+      | add _ _ u' v' h₁' h₂' =>
+          have := ih₁ h₁'; have := ih₂ h₂'; aesop
+  | sub a b u v h₁ h₂ ih₁ ih₂ =>
+      cases h' with
+      | sub _ _ u' v' h₁' h₂' =>
+          have := ih₁ h₁'; have := ih₂ h₂'; aesop
+
+/-- Variables a statement may assign. -/
+def Stmt.writes : Stmt → Finset String
+  | .basic .noop => ∅
+  | .basic (.assign x _) => {x}
+  | .andThen a b => a.writes ∪ b.writes
+  | .ifElse _ a b => a.writes ∪ b.writes
+  | .whileLoop _ b => b.writes
+
+lemma EvalStmt.preserves_unwritten {ρ σ : Env} {s : Stmt} (h : EvalStmt ρ s σ)
+    {x : String} (hx : x ∉ s.writes) :
+    ∀ v, Env.Mem (x, v) ρ ↔ Env.Mem (x, v) σ := by
+  induction h with
+  | basic _ _ _ hb =>
+      cases hb with
+      | noop => exact fun _ => Iff.rfl
+      | assign y _ _ _ =>
+          have hn : x ≠ y := by simpa [Stmt.writes] using hx
+          intro v; simp [Env.mem_cons, hn]
+  | andThen _ _ _ _ _ _ _ ih₁ ih₂ =>
+      simp only [Stmt.writes, Finset.mem_union, not_or] at hx
+      exact fun v => (ih₁ hx.1 v).trans (ih₂ hx.2 v)
+  | ifTrue _ _ _ _ _ _ _ _ _ ih =>
+      exact ih (fun hm => hx (Finset.mem_union_left _ hm))
+  | ifFalse _ _ _ _ _ _ _ ih =>
+      exact ih (fun hm => hx (Finset.mem_union_right _ hm))
+  | whileTrue _ _ _ _ _ _ _ _ _ _ ih₁ ih₂ =>
+      exact fun v => (ih₁ hx v).trans (ih₂ hx v)
+  | whileFalse => exact fun _ => Iff.rfl
+
+/-- Evaluations depend on current bindings, not the list of shadowed bindings. -/
+noncomputable def EvalStmt.congr_env {ρ ρ' : Env} {s : Stmt} (h : EvalStmt ρ s ρ') :
+    ∀ {σ}, Env.Equiv ρ σ → Σ σ', {_h : EvalStmt σ s σ' // Env.Equiv ρ' σ'} := by
+  induction h with
+  | basic _ _ _ hb =>
+      intro σ he
+      cases hb with
+      | noop => exact ⟨σ, .basic _ _ _ (.noop _), he⟩
+      | assign x rhs v hv =>
+          exact ⟨_, .basic _ _ _ (.assign _ _ _ _ (hv.congr_env (fun y _ => he y))), he.cons x v⟩
+  | andThen _ _ _ _ _ _ _ ih₁ ih₂ =>
+      intro σ he
+      obtain ⟨σ₁, h₁, he₁⟩ := ih₁ he
+      obtain ⟨σ₂, h₂, he₂⟩ := ih₂ he₁
+      exact ⟨σ₂, .andThen _ _ _ _ _ h₁ h₂, he₂⟩
+  | ifTrue _ _ _ _ _ _ hc hz _ ih =>
+      intro σ he
+      obtain ⟨σ', h', he'⟩ := ih he
+      exact ⟨σ', .ifTrue _ _ _ _ _ _ (hc.congr_env (fun x _ => he x)) hz h', he'⟩
+  | ifFalse _ _ _ _ _ hc _ ih =>
+      intro σ he
+      obtain ⟨σ', h', he'⟩ := ih he
+      exact ⟨σ', .ifFalse _ _ _ _ _ (hc.congr_env (fun x _ => he x)) h', he'⟩
+  | whileTrue _ _ _ _ _ _ hc hz _ _ ih₁ ih₂ =>
+      intro σ he
+      obtain ⟨σ₁, h₁, he₁⟩ := ih₁ he
+      obtain ⟨σ₂, h₂, he₂⟩ := ih₂ he₁
+      exact ⟨σ₂, .whileTrue _ _ _ _ _ _ (hc.congr_env (fun x _ => he x)) hz h₁ h₂, he₂⟩
+  | whileFalse _ _ _ hc =>
+      intro σ he
+      exact ⟨σ, .whileFalse _ _ _ (hc.congr_env (fun x _ => he x)), he⟩
+
+end Spa

lean/Spa/Language/Graphs.lean

@@ -1,169 +1,401 @@
-/-
-Port of `Language/Graphs.agda`.
-
-Representation note: `nodes : Vec (List BasicStmt) size` becomes
-`nodes : Fin size → List BasicStmt`. With that, the `Data.Vec` lookup/append
-lemma stack (`lookup-++ˡ/ʳ`, `cast-is-id`, …) lifts into mathlib's
-`Fin.append` with `Fin.append_left` / `Fin.append_right`.
-
-Correspondence:
-  _↑ˡ_/_↑ʳ_ (on Fin)  ↦ Fin.castAdd / Fin.natAdd (mathlib)
-  _↑ˡⁱ_/_↑ʳⁱ_         ↦ liftIdxL / liftIdxR
-  _↑ˡᵉ_/_↑ʳᵉ_         ↦ liftEdgeL / liftEdgeR
-  _∙_                 ↦ Graph.comp   (scoped notation ∙)
-  _↦_                 ↦ Graph.link   (scoped notation ⤳)
-  loop                ↦ Graph.loop
-  _skipto_            ↦ Graph.skipto
-  _[_]                ↦ Graph.nodes (plain application)
-  singleton, wrap     ↦ Graph.singleton, Graph.wrap
-  buildCfg            ↦ buildCfg
-  indices             ↦ List.finRange (mathlib; `fins` from Utils.agda)
-  indices-complete    ↦ List.mem_finRange
-  indices-Unique      ↦ List.nodup_finRange
-  predecessors        ↦ Graph.predecessors
-  edge⇒predecessor    ↦ Graph.mem_predecessors_of_edge
-  predecessor⇒edge    ↦ Graph.edge_of_mem_predecessors
--/
 import Spa.Language.Base
 import Mathlib.Data.Fin.Tuple.Basic
 import Mathlib.Data.List.ProdSigma
 import Mathlib.Data.List.FinRange
 
+/-!
+
+# Algebraic Control Flow Graphs
+
+This file defines control flow graphs and operations to naturally compose them,
+making it possible to inductively covnert a program in the object language
+(see `Spa.Stmt` in `Spa/Language/Base.lean`) into its corresponding graph.
+
+Graphs are, in general, parameterized by their "payload" (the per-node data); see `GGraph`.
+This is useful because other operations, such as finding the CFG node corresponding
+to an AST node, are performed by embellishing a graph's basic blocks with their AST
+identifiers.
+
+The operations are deliberately a little bit sloppy here, creating empty / statement-less
+CFG nodes. Additionally, the current CFG construction algorithm doesn't group
+consecutive statements in a single notional basic block into one node.
+This makes graph construction much easier to define, and might save us the
+trouble of (when trying to find the CFG node for an AST node) doing
+indexing into a list.
+
+-/
+
+/-- Logically, when combining `Fin`s from two distinct pools,
+    the combination is disjoint. -/
+lemma Fin.castAdd_ne_natAdd {n m : ℕ} (i : Fin n) (j : Fin m) :
+    Fin.castAdd m i ≠ Fin.natAdd n j := by
+  intro h
+  have := congrArg Fin.val h
+  simp only [Fin.coe_castAdd, Fin.coe_natAdd] at this
+  omega
+
+/-- Bump the upper bound of a list of `Fin`s without changing their value. -/
+def List.finCastAdd {n : ℕ} (l : List (Fin n)) (m : ℕ) : List (Fin (n + m)) :=
+  l.map (Fin.castAdd m)
+
+/-- Bump the upper bound of a list of `Fin`s by adding the amount to their value. -/
+def List.finNatAdd {m : ℕ} (l : List (Fin m)) (n : ℕ) : List (Fin (n + m)) :=
+  l.map (Fin.natAdd n)
+
+/-- Bump the upper bound of a list of `Fin` pairs without changing their value. -/
+def List.finCastAddProd {n : ℕ} (l : List (Fin n × Fin n)) (m : ℕ) :
+    List (Fin (n + m) × Fin (n + m)) :=
+  l.map (fun e => (e.1.castAdd m, e.2.castAdd m))
+
+/-- Bump the upper bound of a list of `Fin` pairs by adding the amount to their value. -/
+def List.finNatAddProd {m : ℕ} (l : List (Fin m × Fin m)) (n : ℕ) :
+    List (Fin (n + m) × Fin (n + m)) :=
+  l.map (fun e => (e.1.natAdd n, e.2.natAdd n))
+
 namespace Spa
 
-structure Graph where
+/-- Graph with general (`α`-labeled) nodes. By using a tuple `Fin size → α`
+    and writing `edges` over the `Fin size`, guarantees all edges are between real nodes.
+
+    To make graph composition via operations not force a
+    [`alga`](https://hackage.haskell.org/package/algebraic-graphs)-style "connect"-based
+    algebra, explicitly defines `inputs` and `outputs`, which are the only nodes that
+    get connected when graphs are sequenced. This makes the graph construction
+    operations more naturally fit with how CFGs are created from `Stmt`s. -/
+structure GGraph (α : Type) where
   size : ℕ
-  nodes : Fin size → List BasicStmt
+  nodes : Fin size → α
   edges : List (Fin size × Fin size)
   inputs : List (Fin size)
   outputs : List (Fin size)
 
-namespace Graph
+namespace GGraph
 
-abbrev Index (g : Graph) : Type := Fin g.size
+variable {α β : Type}
 
-abbrev Edge (g : Graph) : Type := g.Index × g.Index
+/-- An index (node) in the CFG. -/
+abbrev Index (g : GGraph α) : Type := Fin g.size
 
-/-- Agda: `_↑ˡⁱ_`. -/
+/-- An edge in the CFG. -/
-def liftIdxL {n : ℕ} (l : List (Fin n)) (m : ℕ) : List (Fin (n + m)) :=
+abbrev Edge (g : GGraph α) : Type := g.Index × g.Index
-  l.map (Fin.castAdd m)
 
-/-- Agda: `_↑ʳⁱ_`. -/
+instance : Functor GGraph where
-def liftIdxR (n : ℕ) {m : ℕ} (l : List (Fin m)) : List (Fin (n + m)) :=
+  map {α β : Type} (f : α → β) (g : GGraph α) : GGraph β :=
-  l.map (Fin.natAdd n)
+    { size := g.size,
+      nodes := f ∘ g.nodes
+      edges := g.edges,
+      inputs := g.inputs,
+      outputs := g.outputs }
 
-/-- Agda: `_↑ˡᵉ_` (with `_↑ˡ_` on pairs inlined). -/
+@[simp] lemma map_size (f : α → β) (g : GGraph α) : (f <$> g).size = g.size := rfl
-def liftEdgeL {n : ℕ} (l : List (Fin n × Fin n)) (m : ℕ) :
+@[simp] lemma map_edges (f : α → β) (g : GGraph α) : (f <$> g).edges = g.edges := rfl
-    List (Fin (n + m) × Fin (n + m)) :=
+@[simp] lemma map_inputs (f : α → β) (g : GGraph α) : (f <$> g).inputs = g.inputs := rfl
-  l.map (fun e => (e.1.castAdd m, e.2.castAdd m))
+@[simp] lemma map_outputs (f : α → β) (g : GGraph α) : (f <$> g).outputs = g.outputs := rfl
 
-/-- Agda: `_↑ʳᵉ_` (with `_↑ʳ_` on pairs inlined). -/
+/-- Overlay two graphs: create a new graph whose nodes and edges come from two
-def liftEdgeR (n : ℕ) {m : ℕ} (l : List (Fin m × Fin m)) :
+    sub-graphs, without inserting any additional edges. Also combines the
-    List (Fin (n + m) × Fin (n + m)) :=
+    input and output node sets. -/
-  l.map (fun e => (e.1.natAdd n, e.2.natAdd n))
+def overlay (g₁ g₂ : GGraph α) : GGraph α where
-
-/-- Agda: `_∙_` — disjoint union. -/
-def comp (g₁ g₂ : Graph) : Graph where
   size := g₁.size + g₂.size
   nodes := Fin.append g₁.nodes g₂.nodes
-  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges
+  edges := g₁.edges.finCastAddProd g₂.size ++ g₂.edges.finNatAddProd g₁.size
-  inputs := liftIdxL g₁.inputs g₂.size ++ liftIdxR g₁.size g₂.inputs
+  inputs := g₁.inputs.finCastAdd g₂.size ++ g₂.inputs.finNatAdd g₁.size
-  outputs := liftIdxL g₁.outputs g₂.size ++ liftIdxR g₁.size g₂.outputs
+  outputs := g₁.outputs.finCastAdd g₂.size ++ g₂.outputs.finNatAdd g₁.size
 
-@[inherit_doc] scoped infixr:70 " ∙ " => Graph.comp
+@[inherit_doc] scoped infixr:70 " ∙ " => GGraph.overlay
 
-/-- Agda: `_↦_` — sequencing: all outputs of `g₁` feed all inputs of `g₂`. -/
+/-- Sequence two CFGs: create a combined graph whose nodes and edges come
-def link (g₁ g₂ : Graph) : Graph where
+    from two subgraphs, __and__ make all the outputs of the left graph have edges to
+    all the inputs of the right graph. By the semantics of CFGs, this
+    encodes the fact that code first traverses the basic blocks in theleft
+    graph, and does the same for the right graph. -/
+def sequence (g₁ g₂ : GGraph α) : GGraph α where
   size := g₁.size + g₂.size
   nodes := Fin.append g₁.nodes g₂.nodes
-  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges ++
+  edges := g₁.edges.finCastAddProd g₂.size ++ g₂.edges.finNatAddProd g₁.size ++
-    (liftIdxL g₁.outputs g₂.size).product (liftIdxR g₁.size g₂.inputs)
+    (g₁.outputs.finCastAdd g₂.size).product (g₂.inputs.finNatAdd g₁.size)
-  inputs := liftIdxL g₁.inputs g₂.size
+  inputs := g₁.inputs.finCastAdd g₂.size
-  outputs := liftIdxR g₁.size g₂.outputs
+  outputs := g₂.outputs.finNatAdd g₁.size
 
-@[inherit_doc] scoped infixr:70 " ⤳ " => Graph.link
+@[inherit_doc] scoped infixr:70 " ⤳ " => GGraph.sequence
 
-/-- The entry node of a `loop` graph. -/
+/-- When a graph `g` is wrapped in a `loop`, the index / node corresponding
-def loopIn (g : Graph) : Fin (2 + g.size) := (0 : Fin 2).castAdd g.size
+    to the input of the new loop. -/
+def loopIn (g : GGraph α) : Fin (2 + g.size) := (0 : Fin 2).castAdd g.size
 
-/-- The exit node of a `loop` graph. -/
+/-- When a graph `g` is wrapped in a `loop`, the index / node corresponding
-def loopOut (g : Graph) : Fin (2 + g.size) := (1 : Fin 2).castAdd g.size
+    to the output of the new loop. -/
+def loopOut (g : GGraph α) : Fin (2 + g.size) := (1 : Fin 2).castAdd g.size
 
-/-- Agda: `loop`. -/
+/-- Creates a zero-or-more loop loop in the CFG: connects all the output
-def loop (g : Graph) : Graph where
+    nodes of the CFG back to the graph's beginning, and also introduces a path
+    to a new ending node (see `loopOut`) which bypasses the entire graph.
+
+    Notably, both the new input (`loopIn`) and new output (`loopOut`)
+    nodes are necessary for correctness: adding a path from inputs to a
+    hypothetical no-op end node encodes something like "just the first statement is executed".
+    Similarly, just adding a path from a a hypothetical no-op beginning node
+    to the outputs encodes "just the last statement is executed".
+
+    This is technically sloppy (see module comment), but it's simple.
+-/
+def loop (g : GGraph (Option β)) : GGraph (Option β) where
   size := 2 + g.size
-  nodes := Fin.append (fun _ : Fin 2 => []) g.nodes
+  nodes := Fin.append (fun _ : Fin 2 => none) g.nodes
-  edges := liftEdgeR 2 g.edges ++
+  edges := g.edges.finNatAddProd 2 ++
-    (liftIdxR 2 g.inputs).map (g.loopIn, ·) ++
+    ((g.loopIn, ·) <$> g.inputs.finNatAdd 2)  ++
-    (liftIdxR 2 g.outputs).map (·, g.loopOut) ++
+    ((·, g.loopOut) <$> g.outputs.finNatAdd 2) ++
     [(g.loopOut, g.loopIn), (g.loopIn, g.loopOut)]
   inputs := [g.loopIn]
   outputs := [g.loopOut]
 
-@[simp] theorem loop_inputs (g : Graph) : (loop g).inputs = [g.loopIn] := rfl
+@[simp] lemma loop_inputs (g : GGraph (Option β)) : (loop g).inputs = [g.loopIn] := rfl
 
-@[simp] theorem loop_outputs (g : Graph) : (loop g).outputs = [g.loopOut] := rfl
+@[simp] lemma loop_outputs (g : GGraph (Option β)) : (loop g).outputs = [g.loopOut] := rfl
 
-/-- Agda: `_skipto_` (unused by `buildCfg`, ported for parity). -/
+/-- Creates a single-node graph whose node contains the given value. -/
-def skipto (g₁ g₂ : Graph) : Graph where
+def singleton (a : α) : GGraph α where
-  size := g₁.size + g₂.size
-  nodes := Fin.append g₁.nodes g₂.nodes
-  edges := liftEdgeL g₁.edges g₂.size ++ liftEdgeR g₁.size g₂.edges ++
-    (liftIdxL g₁.inputs g₂.size).product (liftIdxR g₁.size g₂.inputs)
-  inputs := liftIdxL g₁.inputs g₂.size
-  outputs := liftIdxR g₁.size g₂.inputs
-
-/-- Agda: `singleton`. -/
-def singleton (bss : List BasicStmt) : Graph where
   size := 1
-  nodes := fun _ => bss
+  nodes := fun _ => a
   edges := []
   inputs := [0]
   outputs := [0]
 
-/-- Agda: `wrap`. -/
+/-- Creates a new graph with a single input and single output node. Useful to ensure there's
-def wrap (g : Graph) : Graph :=
+    a single point of entry and single point of exit. -/
-  singleton [] ⤳ g ⤳ singleton []
+def wrap (g : GGraph (Option β)) : GGraph (Option β) :=
+  singleton none ⤳ g ⤳ singleton none
+
+/-- The input / entry node generated by `GGraph.wrap`. -/
+def wrapInput (g : GGraph (Option β)) : (wrap g).Index :=
+  (0 : Fin 1).castAdd ((g ⤳ singleton none).size)
+
+/-- The output / exit node generated by `GGraph.wrap`. -/
+def wrapOutput (g : GGraph (Option β)) : (wrap g).Index :=
+  Fin.natAdd 1 ((Fin.natAdd g.size (0 : Fin 1)))
+
+/-- The `wrapInput` is, indeed, the graph's only input after `wrap`. -/
+lemma wrap_inputs (g : GGraph (Option β)) :
+    (wrap g).inputs = [g.wrapInput] := rfl
+
+/-- The `wrapInput` is, indeed, the graph's only output after `wrap`. -/
+lemma wrap_outputs (g : GGraph (Option β)) :
+    (wrap g).outputs = [g.wrapOutput] := rfl
+
+@[simp] lemma map_singleton (f : α → β) (a : α) :
+    f <$> singleton a = singleton (f a) := rfl
+
+@[simp] lemma map_overlay (f : α → β) (g₁ g₂ : GGraph α) :
+    f<$> (g₁ ∙ g₂) = f <$> g₁ ∙ f <$> g₂ := by
+  rcases g₁ with ⟨n₁, nd₁, e₁, i₁, o₁⟩; rcases g₂ with ⟨n₂, nd₂, e₂, i₂, o₂⟩
+  simp only [Functor.map, GGraph.overlay]
+  congr 1
+  funext i
+  refine Fin.addCases ?_ ?_ i <;> intro j <;> simp [Fin.append_left, Fin.append_right]
+
+@[simp] lemma map_sequence (f : α → β) (g₁ g₂ : GGraph α) :
+    f <$> (g₁ ⤳ g₂) = (f <$> g₁) ⤳  (f <$> g₂) := by
+  rcases g₁ with ⟨n₁, nd₁, e₁, i₁, o₁⟩; rcases g₂ with ⟨n₂, nd₂, e₂, i₂, o₂⟩
+  simp only [Functor.map, GGraph.sequence]
+  congr 1
+  funext i
+  refine Fin.addCases ?_ ?_ i <;> intro j <;> simp [Fin.append_left, Fin.append_right]
+
+@[simp] lemma map_loop (h : β → γ) (g : GGraph (Option β)) :
+    (Option.map h) <$> (loop g) = loop (Option.map h <$> g) := by
+  rcases g with ⟨n, nd, e, i, o⟩
+  simp only [Functor.map, GGraph.loop]
+  congr 1
+  funext i
+  refine Fin.addCases ?_ ?_ i <;> intro j <;> simp [Fin.append_left, Fin.append_right]
+
+@[simp] lemma map_wrap (h : β → γ) (g : GGraph (Option β)) :
+    (Option.map h) <$> wrap g = wrap (Option.map h <$> g) := by
+  simp [GGraph.wrap, GGraph.map_sequence, GGraph.map_singleton]
+
+/-! ### Embeddings
+
+To be able to reason compositionally about traces through the graphs,
+we need to be able to reason about how a trace within a sub-graph maps
+to the full graph. Fortunately, graphs are built using composition operators,
+and these composition operators always include their arguments as embedded
+subgraphs in the full result. Moreover, each embedding "just" offsets the
+existing node IDs by a given amount.
+
+This section formalizes this fact by providing an `Embed` type that
+represents an offset-based embedding, and showing that such an embedding
+exists for all arguments given to graph composition operators. Furthermore,
+because of the offset-based embedding, we can determine whether a node
+came from a particular subgraph simply by examining its offset and sub-graph
+size. This is captured by `Embed.mem_range_iff`. -/
+
+/-- A special-case embedding of `g` into `h` in which all edges and nodes
+    of `g` are present in `h` at a given offset `off`. -/
+structure Embed (g h : GGraph α) where
+  f : g.Index → h.Index
+  off : ℕ
+  f_val : ∀ i, (f i).val = off + i.val
+  nodes_eq : ∀ i, h.nodes (f i) = g.nodes i
+  edges_mem : ∀ {e : g.Edge}, e ∈ g.edges → (f e.1, f e.2) ∈ h.edges
+
+lemma Embed.f_inj {g h : GGraph α} (e : Embed g h) : Function.Injective e.f := by
+  intro i j hij
+  have := congrArg Fin.val hij
+  rw [e.f_val, e.f_val] at this
+  exact Fin.ext (by omega)
+
+/-- An embedding's range is the interval `[off, off + g.size)`. -/
+lemma Embed.mem_range_iff {g h : GGraph α} (e : Embed g h) (j : h.Index) :
+    (∃ i, e.f i = j) ↔ e.off ≤ j.val ∧ j.val < e.off + g.size := by
+  constructor
+  · rintro ⟨i, rfl⟩; have := i.isLt; rw [e.f_val]; omega
+  · rintro ⟨hlo, hhi⟩
+    refine ⟨⟨j.val - e.off, by omega⟩, Fin.ext ?_⟩
+    rw [e.f_val]
+    show e.off + (j.val - e.off) = j.val
+    omega
+
+/-- Build an embedding from an index map that is pointwise the shift.  The five
+    inclusions below are naturally written with `Fin.castAdd`/`Fin.natAdd` — the form
+    the `Fin.append` lemmas are stated in — so this lets them keep those proofs
+    verbatim.  The trailing argument is boilerplate at every call site and defaults
+    to discharging itself. -/
+private def Embed.ofIndexMap {g h : GGraph α} (off : ℕ) (k : g.Index → h.Index)
+    (hn : ∀ i, h.nodes (k i) = g.nodes i)
+    (hem : ∀ {e : g.Edge}, e ∈ g.edges → (k e.1, k e.2) ∈ h.edges)
+    (hk : ∀ i, (k i).val = off + i.val := by intro i; simp) :
+    Embed g h where
+  f := k
+  off := off
+  f_val := hk
+  nodes_eq := hn
+  edges_mem := hem
+
+/-- Embeddings compose (offsets add). -/
+def Embed.trans {g₁ g₂ g₃ : GGraph α} (e₁ : Embed g₁ g₂) (e₂ : Embed g₂ g₃) :
+    Embed g₁ g₃ :=
+  ofIndexMap (e₂.off + e₁.off) (fun i => e₂.f (e₁.f i))
+    (fun i => (e₂.nodes_eq (e₁.f i)).trans (e₁.nodes_eq i))
+    (fun he => e₂.edges_mem (e₁.edges_mem he))
+    (hk := fun i => by rw [e₂.f_val, e₁.f_val]; omega)
+
+/-- The left operand's inclusion into a sequenced graph. -/
+def Embed.sequenceLeft (g₁ g₂ : GGraph α) : Embed g₁ (g₁ ⤳ g₂) :=
+  ofIndexMap 0 (fun i => i.castAdd g₂.size) (Fin.append_left g₁.nodes g₂.nodes)
+    (fun he => List.mem_append_left _ (List.mem_append_left _ (List.mem_map_of_mem _ he)))
+
+/-- The right operand's inclusion into a sequenced graph. -/
+def Embed.sequenceRight (g₁ g₂ : GGraph α) : Embed g₂ (g₁ ⤳ g₂) :=
+  ofIndexMap g₁.size (fun i => i.natAdd g₁.size) (Fin.append_right g₁.nodes g₂.nodes)
+    (fun he => List.mem_append_left _ (List.mem_append_right _ (List.mem_map_of_mem _ he)))
+
+/-- The left operand's inclusion into an overlaid graph. -/
+def Embed.overlayLeft (g₁ g₂ : GGraph α) : Embed g₁ (g₁ ∙ g₂) :=
+  ofIndexMap 0 (fun i => i.castAdd g₂.size) (Fin.append_left g₁.nodes g₂.nodes)
+    (fun he => List.mem_append_left _ (List.mem_map_of_mem _ he))
+
+/-- The right operand's inclusion into an overlaid graph. -/
+def Embed.overlayRight (g₁ g₂ : GGraph α) : Embed g₂ (g₁ ∙ g₂) :=
+  ofIndexMap g₁.size (fun i => i.natAdd g₁.size) (Fin.append_right g₁.nodes g₂.nodes)
+    (fun he => List.mem_append_right _ (List.mem_map_of_mem _ he))
+
+/-- The body's inclusion into a `loop` graph. -/
+def Embed.loop (g : GGraph (Option β)) : Embed g (GGraph.loop g) :=
+  ofIndexMap 2 (fun i => i.natAdd 2) (Fin.append_right (fun _ : Fin 2 => none) g.nodes)
+    (fun he => List.mem_append_left _ (List.mem_append_left _
+      (List.mem_append_left _ (List.mem_map_of_mem _ he))))
+
+/-- A `singleton` subgraph has exactly one node; this is where it sits in the ambient graph. -/
+def Embed.singletonIndex {a : α} {h : GGraph α} (e : Embed (singleton a) h) : h.Index :=
+  e.f ⟨0, Nat.zero_lt_one⟩
+
+@[simp] lemma Embed.nodes_singletonIndex {a : α} {h : GGraph α}
+    (e : Embed (singleton a) h) : h.nodes e.singletonIndex = a :=
+  e.nodes_eq ⟨0, Nat.zero_lt_one⟩
+
+variable (g : GGraph α)
+
+/-- All the nodes in the graph. -/
+def indices : List g.Index := List.finRange g.size
+
+/-- All of the graph's indices are listed in `indices`. -/
+lemma mem_indices (idx : g.Index) : idx ∈ g.indices :=
+  List.mem_finRange idx
+
+/-- `indices` does not have duplicates. -/
+lemma nodup_indices : g.indices.Nodup :=
+  List.nodup_finRange g.size
+
+/-- Predecessors of a particular node in the graph. --/
+def predecessors (idx : g.Index) : List g.Index :=
+  g.indices.filter (fun idx' => (idx', idx) ∈ g.edges)
+
+/-- When sequencing (proven here with `Graph.singleton` on the left), no edges
+    exist from the right-hand graph back to the left. -/
+private lemma not_mem_edges_castAdd_sequence {g₂ : GGraph (Option β)} (i : Fin 1)
+    (idx : (singleton none ⤳ g₂).Index) :
+    ((idx, i.castAdd g₂.size) : (singleton none ⤳ g₂).Edge)
+      ∉ (singleton none ⤳ g₂).edges := by
+  intro h
+  rcases List.mem_append.mp h with h' | h'
+  · rcases List.mem_append.mp h' with h'' | h''
+    · -- lifted edges of `singleton []`: there are none
+      simp [singleton, List.finCastAddProd] at h''
+    · -- lifted edges of g₂: targets are natAdd
+      obtain ⟨e, _, heq⟩ := List.mem_map.mp h''
+      exact Fin.castAdd_ne_natAdd i e.2 (congrArg Prod.snd heq).symm
+  · -- product edges: targets are natAdd'd inputs of g₂
+    obtain ⟨-, hb⟩ := List.mem_product.mp h'
+    obtain ⟨j, -, heq⟩ := List.mem_map.mp hb
+    exact Fin.castAdd_ne_natAdd i j heq.symm
+
+/-- The input node of a graph after `Graph.wrap` has no predecessors. -/
+lemma wrap_predecessors_eq_nil (g : GGraph (Option β)) (idx : (wrap g).Index)
+    (h : idx ∈ (wrap g).inputs) :
+    (wrap g).predecessors idx = [] := by
+  rw [wrap_inputs, List.mem_singleton] at h
+  subst h
+  rw [GGraph.predecessors, List.filter_eq_nil_iff]
+  intro idx' _
+  simpa using not_mem_edges_castAdd_sequence (g₂ := g ⤳ singleton none) 0 idx'
+
+/-- There's there's an edge between two nodes `idx₁` and `idx₂`,
+    then `idx₁` is the predecessor of `idx₂`. -/
+lemma mem_predecessors_of_edge {idx₁ idx₂ : g.Index}
+    (h : (idx₁, idx₂) ∈ g.edges) : idx₁ ∈ g.predecessors idx₂ :=
+  List.mem_filter.mpr ⟨g.mem_indices idx₁, by simpa using h⟩
+
+/-- A node is a predecessor of another node only if there's an
+    edge between them. -/
+lemma edge_of_mem_predecessors {idx₁ idx₂ : g.Index}
+    (h : idx₁ ∈ g.predecessors idx₂) : (idx₁, idx₂) ∈ g.edges := by
+  simpa using (List.mem_filter.mp h).2
+
+end GGraph
+
+/-- "Normal" graphs, for the purposes of the analyses in this
+    framework, have basic statements in their nodes, and nothing else. -/
+abbrev Graph : Type := GGraph (Option BasicStmt)
+
+namespace Graph
+
+export GGraph (overlay sequence loop singleton wrap loop_inputs loop_outputs wrapInput wrapOutput wrap_inputs wrap_outputs)
+
+@[inherit_doc] scoped infixr:70 " ∙ " => GGraph.overlay
+@[inherit_doc] scoped infixr:70 " ⤳ " => GGraph.sequence
 
 end Graph
 
 open Graph in
-/-- Agda: `buildCfg`. -/
+def Stmt.cfg : Stmt → Graph
-def buildCfg : Stmt → Graph
+  -- A basic statement goes into a single basic block
-  | .basic bs => Graph.singleton [bs]
+  | .basic bs => singleton (some bs)
-  | .andThen s₁ s₂ => buildCfg s₁ ⤳ buildCfg s₂
+  -- Sequencing of statements corresponds naturally to CFG sequencing
-  | .ifElse _ s₁ s₂ => buildCfg s₁ ∙ buildCfg s₂
+  | .andThen s₁ s₂ => s₁.cfg ⤳  s₂.cfg
-  | .whileLoop _ s => Graph.loop (buildCfg s)
+  -- An if can execute either one branch or the other; overlap them.
-
+  -- Subsequent sequencing (etc.) will end up creating the forks and joins.
-namespace Graph
+  | .ifElse _ s₁ s₂ => s₁.cfg ∙ s₂.cfg
-
+  -- The `loop` construct was developed specifically for zero-or-more loops like this.
-variable (g : Graph)
+  | .whileLoop _ s => loop s.cfg
-
-/-- Agda: `indices` (`fins` is mathlib's `List.finRange`). -/
-def indices : List g.Index := List.finRange g.size
-
-/-- Agda: `indices-complete`. -/
-theorem mem_indices (idx : g.Index) : idx ∈ g.indices :=
-  List.mem_finRange idx
-
-/-- Agda: `indices-Unique`. -/
-theorem nodup_indices : g.indices.Nodup :=
-  List.nodup_finRange g.size
-
-/-- Agda: `predecessors`. -/
-def predecessors (idx : g.Index) : List g.Index :=
-  g.indices.filter (fun idx' => (idx', idx) ∈ g.edges)
-
-/-- Agda: `edge⇒predecessor`. -/
-theorem mem_predecessors_of_edge {idx₁ idx₂ : g.Index}
-    (h : (idx₁, idx₂) ∈ g.edges) : idx₁ ∈ g.predecessors idx₂ :=
-  List.mem_filter.mpr ⟨g.mem_indices idx₁, by simpa using h⟩
-
-/-- Agda: `predecessor⇒edge`. -/
-theorem edge_of_mem_predecessors {idx₁ idx₂ : g.Index}
-    (h : idx₁ ∈ g.predecessors idx₂) : (idx₁, idx₂) ∈ g.edges := by
-  simpa using (List.mem_filter.mp h).2
-
-end Graph
 
 end Spa

lean/Spa/Language/Notation.lean

@@ -0,0 +1,60 @@
+import Spa.Language.Base
+
+namespace Spa
+
+/-!
+Scoped quotation syntax for writing object-language programs.
+
+`[obj_expr| … ]` builds an `Expr`, `[obj_stmt| … ]` builds a `Stmt`.
+
+Example:
+```
+[obj_stmt|
+  zero := 0;
+  pos  := zero + 1;
+  if pos { x := 1 } else { noop };
+  while x { x := x - 1 }
+]
+```
+-/
+
+/-- Expressions of the object language. -/
+declare_syntax_cat obj_expr
+
+syntax num                              : obj_expr
+syntax ident                           : obj_expr
+syntax:65 obj_expr:65 " + " obj_expr:66 : obj_expr
+syntax:65 obj_expr:65 " - " obj_expr:66 : obj_expr
+syntax "(" obj_expr ")"                 : obj_expr
+
+/-- Statements of the object language. -/
+declare_syntax_cat obj_stmt
+
+syntax "noop"                                          : obj_stmt
+syntax ident " := " obj_expr                           : obj_stmt
+syntax "if " obj_expr " { " obj_stmt " } " "else" " { " obj_stmt " } " : obj_stmt
+syntax "while " obj_expr " { " obj_stmt " } "          : obj_stmt
+syntax:50 obj_stmt:51 "; " obj_stmt:50                 : obj_stmt
+syntax "(" obj_stmt ")"                                : obj_stmt
+
+scoped syntax "[obj_expr| " obj_expr " ]" : term
+scoped syntax "[obj_stmt| " obj_stmt " ]" : term
+
+scoped macro_rules
+  | `([obj_expr| $n:num])        => `(Expr.num $n)
+  | `([obj_expr| $x:ident])      => `(Expr.var $(Lean.quote x.getId.toString))
+  | `([obj_expr| $a + $b])       => `(Expr.add [obj_expr| $a] [obj_expr| $b])
+  | `([obj_expr| $a - $b])       => `(Expr.sub [obj_expr| $a] [obj_expr| $b])
+  | `([obj_expr| ($e:obj_expr)]) => `([obj_expr| $e])
+
+scoped macro_rules
+  | `([obj_stmt| noop])           => `(Stmt.basic .noop)
+  | `([obj_stmt| $x:ident := $e]) =>
+      `(Stmt.basic (.assign $(Lean.quote x.getId.toString) [obj_expr| $e]))
+  | `([obj_stmt| $s₁ ; $s₂])      => `(Stmt.andThen [obj_stmt| $s₁] [obj_stmt| $s₂])
+  | `([obj_stmt| if $e { $s₁ } else { $s₂ }]) =>
+      `(Stmt.ifElse [obj_expr| $e] [obj_stmt| $s₁] [obj_stmt| $s₂])
+  | `([obj_stmt| while $e { $s }]) => `(Stmt.whileLoop [obj_expr| $e] [obj_stmt| $s])
+  | `([obj_stmt| ($s:obj_stmt)])  => `([obj_stmt| $s])
+
+end Spa

lean/Spa/Language/Program.lean

@@ -0,0 +1,82 @@
+import Spa.Language.Base
+import Spa.Language.Semantics
+import Spa.Language.Graphs
+import Mathlib.Data.Finset.Sort
+import Mathlib.Data.String.Basic
+
+namespace Spa
+
+/-- A self-contained program to be evaluated, analyzed, and transformed. -/
+structure Program where
+  /-- The statement at the top level of the program. Since `Spa.Stmt` contains
+      sequencing via `Spa.Stmt.andThen`, this can encode any number of
+      statements. -/
+  rootStmt : Stmt
+  /-- A memoized copy of the control-flow graph. This field is an
+      implementation detail to avoid re-computing `Spa.GGraph.wrap` and `Spa.Stmt.cfg`
+      every time the program's control flow graph is needed -/
+  cfgCache : Thunk Graph := Thunk.mk fun _ => Graph.wrap rootStmt.cfg
+
+namespace Program
+
+variable (p : Program)
+
+-- Runtime implementation of `cfg`: read the memoized graph.
+private def cfgImpl : Graph := p.cfgCache.get
+
+/-- The control flow graph corresponding to this graph. -/
+@[implemented_by cfgImpl]
+def cfg : Graph := Graph.wrap p.rootStmt.cfg
+
+/-- A state in the control flow `Spa.Graph` of this program. -/
+abbrev State : Type := p.cfg.Index
+
+/-- The root statement's CFG sits inside the program's CFG. -/
+def rootEmbed : GGraph.Embed p.rootStmt.cfg p.cfg :=
+  (GGraph.Embed.sequenceLeft p.rootStmt.cfg (Graph.singleton none)).trans
+    (GGraph.Embed.sequenceRight (Graph.singleton none) _)
+
+/-- Variables mentioned or defined in this program. -/
+def vars : List String := p.rootStmt.vars.sort (· ≤ ·)
+
+/-- `vars` has no duplicates. -/
+lemma vars_nodup : p.vars.Nodup := Finset.sort_nodup _ _
+
+/-- All the states in the program's control flow `Spa.Graph`. -/
+def states : List p.State := p.cfg.indices
+
+/-- All states in the CFG are contained in `states`. -/
+lemma states_complete (s : p.State) : s ∈ p.states := p.cfg.mem_indices s
+
+/-- `states` has no duplicates. -/
+lemma states_nodup : p.states.Nodup := p.cfg.nodup_indices
+
+/-- Given a node of the program's CFG, return the code at that node.
+    At this time, for convenience of proofs, the CFGs have at most
+    one basic statement, and multi-statement basic blocks are encoded
+    as chains of blocks. Thus, this returns at most one `Spa.BasicStmt`. -/
+@[reducible]
+def code (st : p.State) : Option BasicStmt := p.cfg.nodes st
+
+/-- Get the predecessors of a particular CFG node / program state. -/
+def incoming (s : p.State) : List p.State := p.cfg.predecessors s
+
+/-- The entry point of the program's CFG. -/
+def initialState : p.State := Graph.wrapInput p.rootStmt.cfg
+
+/-- The exit point of the program's CFG. -/
+def finalState : p.State := Graph.wrapOutput p.rootStmt.cfg
+
+/-- `incoming` is a faithful representation of edges in the CFG. -/
+lemma mem_incoming_of_edge {s₁ s₂ : p.State}
+    (h : (s₁, s₂) ∈ p.cfg.edges) : s₁ ∈ p.incoming s₂ :=
+  p.cfg.mem_predecessors_of_edge h
+
+/-- The `initialState` has no incoming edges (it's the program start). -/
+lemma incoming_initialState_eq_nil : p.incoming p.initialState = [] :=
+  GGraph.wrap_predecessors_eq_nil p.rootStmt.cfg p.initialState
+    (by rw [Graph.wrap_inputs]; exact List.mem_singleton_self _)
+
+end Program
+
+end Spa

lean/Spa/Language/Properties.lean

@@ -1,282 +1,239 @@
-/-
-Port of `Language/Properties.agda`.
-
-Correspondence:
-  ↑-≢ (and the whole "ugly" Fin-disjointness block:
-    idx→f∉↑ʳᵉ, idx→f∉pair, idx→f∉cart, help, helpAll)
-                          ↦ Fin.castAdd_ne_natAdd + not_mem_edges_castAdd_link
-                            (mathlib `List.mem_append`/`mem_map`/`mem_product`
-                            replace the hand-rolled membership eliminations)
-  wrap-preds-∅            ↦ wrap_predecessors_eq_nil
-  wrap-input, wrap-output ↦ Graph.wrapInput/wrapOutput + wrap_inputs/wrap_outputs
-  Trace-∙ˡ/ʳ              ↦ Trace.comp_left / Trace.comp_right
-  Trace-↦ˡ/ʳ              ↦ Trace.link_left / Trace.link_right
-  Trace-loop              ↦ Trace.loop
-  EndToEndTrace-∙ˡ/ʳ      ↦ EndToEndTrace.comp_left / .comp_right
-  loop-edge-groups,
-  loop-edge-help          ↦ (inlined: the four edge groups are reached through
-                            `List.mem_append` directly)
-  EndToEndTrace-loop      ↦ EndToEndTrace.loop
-  EndToEndTrace-loop²     ↦ EndToEndTrace.loop_concat
-  EndToEndTrace-loop⁰     ↦ EndToEndTrace.loop_empty
-  _++_                    ↦ EndToEndTrace.concat
-  EndToEndTrace-singleton ↦ EndToEndTrace.singleton (+ .singleton_nil)
-  EndToEndTrace-wrap      ↦ EndToEndTrace.wrap
-  buildCfg-sufficient     ↦ buildCfg_sufficient
--/
 import Spa.Language.Traces
 
+/-!
+
+# Properties of the Object Language, CFGs, and Traces
+
+This module encodes some properties of the language, mostly those having to do
+with connecting the computational view (the `Spa.Graph`s, on which static
+analyses are executed) to the semantic view (such as `EvalStmt`, which
+encodes the expected formal behavior of the language). In particular,
+to prove that our computationally-implemented static analyses are correct,
+we need to show that our computational model of their execution (the CFG)
+matches the formal description. Thus, the key result `cfg_sufficient`.
+
+Many lemmas and definitions here aim are used to prove that result,
+by allowing inductive proofs on the construction of the CFG:
+the bits where we _build up_ the trace corresponding to each
+proof tree are exactly those when we have two graphs (through
+which traces exist) and we want to combine these graphs, while
+showing also that a combined trace exists as well. -/
+
 namespace Spa
 
 open Graph
 
-/-- Agda: `↑-≢`. -/
-theorem Fin.castAdd_ne_natAdd {n m : ℕ} (i : Fin n) (j : Fin m) :
-    Fin.castAdd m i ≠ Fin.natAdd n j := by
-  intro h
-  have := congrArg Fin.val h
-  simp only [Fin.coe_castAdd, Fin.coe_natAdd] at this
-  omega
-
-/-! ### Trace embeddings -/
-
 section Embeddings
 
 variable {g₁ g₂ : Graph} {ρ₁ ρ₂ : Env}
 
-/-- Agda: `Trace-∙ˡ`. -/
+/-- When two graphs are overlaid, for each trace in the left graph,
-theorem Trace.comp_left {idx₁ idx₂ : g₁.Index}
+    a corresponding trace exists in the combined graph. -/
+noncomputable def Trace.overlay_left {idx₁ idx₂ : g₁.Index}
     (tr : Trace g₁ idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (g₁ ∙ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ := by
+    Trace (g₁ ∙ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ :=
-  induction tr with
+  tr.embed (GGraph.Embed.overlayLeft g₁ g₂)
-  | single hbs =>
-    exact Trace.single (by rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
-      Fin.append_left])
-  | edge hbs he _ ih =>
-    refine Trace.edge ?_ ?_ ih
-    · rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_left]
-    · exact List.mem_append_left _ (List.mem_map_of_mem _ he)
 
-/-- Agda: `Trace-∙ʳ`. -/
+/-- When two graphs are overlaid, for each trace in the right graph,
-theorem Trace.comp_right {idx₁ idx₂ : g₂.Index}
+    a corresponding trace exists in the combined graph. -/
+noncomputable def Trace.overlay_right {idx₁ idx₂ : g₂.Index}
     (tr : Trace g₂ idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (g₁ ∙ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ := by
+    Trace (g₁ ∙ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ :=
-  induction tr with
+  tr.embed (GGraph.Embed.overlayRight g₁ g₂)
-  | single hbs =>
-    exact Trace.single (by rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
-      Fin.append_right])
-  | edge hbs he _ ih =>
-    refine Trace.edge ?_ ?_ ih
-    · rwa [show (g₁ ∙ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_right]
-    · exact List.mem_append_right _ (List.mem_map_of_mem _ he)
 
-/-- Agda: `Trace-↦ˡ`. -/
+/-- When two graphs are sequenced, for each trace in the first graph,
-theorem Trace.link_left {idx₁ idx₂ : g₁.Index}
+    a corresponding trace exists in the combined graph. -/
+noncomputable def Trace.sequence_left {idx₁ idx₂ : g₁.Index}
     (tr : Trace g₁ idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (g₁ ⤳ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ := by
+    Trace (g₁ ⤳ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ :=
-  induction tr with
+  tr.embed (GGraph.Embed.sequenceLeft g₁ g₂)
-  | single hbs =>
-    exact Trace.single (by rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
-      Fin.append_left])
-  | edge hbs he _ ih =>
-    refine Trace.edge ?_ ?_ ih
-    · rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_left]
-    · exact List.mem_append_left _ (List.mem_append_left _ (List.mem_map_of_mem _ he))
 
-/-- Agda: `Trace-↦ʳ`. -/
+/-- When two graphs are sequenced, for each trace in the second graph,
-theorem Trace.link_right {idx₁ idx₂ : g₂.Index}
+   a corresponding trace exists in the combined graph. -/
+noncomputable def Trace.sequence_right {idx₁ idx₂ : g₂.Index}
     (tr : Trace g₂ idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (g₁ ⤳ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ := by
+    Trace (g₁ ⤳ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ :=
-  induction tr with
+  tr.embed (GGraph.Embed.sequenceRight g₁ g₂)
-  | single hbs =>
-    exact Trace.single (by rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl,
-      Fin.append_right])
-  | edge hbs he _ ih =>
-    refine Trace.edge ?_ ?_ ih
-    · rwa [show (g₁ ⤳ g₂).nodes = Fin.append g₁.nodes g₂.nodes from rfl, Fin.append_right]
-    · exact List.mem_append_left _
-        (List.mem_append_right _ (List.mem_map_of_mem _ he))
 
-/-- Agda: `EndToEndTrace-∙ˡ`. -/
+/-- Equivalent of `Trace.overlay_left` for end-to-end traces. -/
-theorem EndToEndTrace.comp_left (etr : EndToEndTrace g₁ ρ₁ ρ₂) :
+noncomputable def EndToEndTrace.overlay_left (etr : EndToEndTrace g₁ ρ₁ ρ₂) :
     EndToEndTrace (g₁ ∙ g₂) ρ₁ ρ₂ := by
   obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
   exact ⟨i₁.castAdd g₂.size, List.mem_append_left _ (List.mem_map_of_mem _ h₁),
          i₂.castAdd g₂.size, List.mem_append_left _ (List.mem_map_of_mem _ h₂),
-         tr.comp_left⟩
+         tr.overlay_left⟩
 
-/-- Agda: `EndToEndTrace-∙ʳ`. -/
+/-- Equivalent of `Trace.overlay_right` for end-to-end traces. -/
-theorem EndToEndTrace.comp_right (etr : EndToEndTrace g₂ ρ₁ ρ₂) :
+noncomputable def EndToEndTrace.overlay_right (etr : EndToEndTrace g₂ ρ₁ ρ₂) :
     EndToEndTrace (g₁ ∙ g₂) ρ₁ ρ₂ := by
   obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
   exact ⟨i₁.natAdd g₁.size, List.mem_append_right _ (List.mem_map_of_mem _ h₁),
          i₂.natAdd g₁.size, List.mem_append_right _ (List.mem_map_of_mem _ h₂),
-         tr.comp_right⟩
+         tr.overlay_right⟩
 
-/-- Agda: `_++_` — sequencing end-to-end traces over `⤳`. -/
+/-- Execute the left operand and follow the connecting edge to the right operand. -/
-theorem EndToEndTrace.concat {ρ₃ : Env} (etr₁ : EndToEndTrace g₁ ρ₁ ρ₂)
+noncomputable def EndToEndTrace.beforeRight {ρ₃ : Env}
-    (etr₂ : EndToEndTrace g₂ ρ₂ ρ₃) : EndToEndTrace (g₁ ⤳ g₂) ρ₁ ρ₃ := by
+    (left : EndToEndTrace g₁ ρ₁ ρ₂) (right : EndToEndTrace g₂ ρ₂ ρ₃) :
-  obtain ⟨i₁, h₁, i₂, h₂, tr₁⟩ := etr₁
+    Traceₗ (g₁ ⤳ g₂) (left.entry.castAdd g₂.size) (right.entry.natAdd g₁.size) ρ₁ ρ₂ := by
-  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
+  refine left.trace.sequence_left.addEdge ?_
-  refine ⟨i₁.castAdd g₂.size, List.mem_map_of_mem _ h₁,
-          j₂.natAdd g₁.size, List.mem_map_of_mem _ k₂,
-          Trace.concat tr₁.link_left ?_ tr₂.link_right⟩
   exact List.mem_append_right _
-    (List.mem_product.mpr ⟨List.mem_map_of_mem _ h₂, List.mem_map_of_mem _ k₁⟩)
+    (List.mem_product.mpr
+      ⟨List.mem_map_of_mem _ left.exit_mem, List.mem_map_of_mem _ right.entry_mem⟩)
+
+/-- When two graphs are sequenced, two end-to-end traces through the respective
+    graphs can be sequenced to create an end-to-end trace in the combined
+    graph. This is only possible for end-to-end traces and not for general
+    `Trace`s, because sequencing only introduces edges from the output nodes
+    of one graph to the input nodes of another graph. A non-end-to-end trace
+    need to conclude at the output node, so it cannot necessarily be sequenced
+    with a trace in another graph. -/
+noncomputable def EndToEndTrace.concat {ρ₃ : Env} (etr₁ : EndToEndTrace g₁ ρ₁ ρ₂)
+    (etr₂ : EndToEndTrace g₂ ρ₂ ρ₃) : EndToEndTrace (g₁ ⤳ g₂) ρ₁ ρ₃ := by
+  exact ⟨etr₁.entry.castAdd g₂.size, List.mem_map_of_mem _ etr₁.entry_mem,
+    etr₂.exit.natAdd g₁.size, List.mem_map_of_mem _ etr₂.exit_mem,
+    (etr₁.beforeRight etr₂).appendTrace etr₂.trace.sequence_right⟩
+
 
 end Embeddings
 
-/-! ### Loops -/
-
 section Loop
 
 variable {g : Graph} {ρ₁ ρ₂ ρ₃ : Env}
 
-/-- Agda: `Trace-loop`. -/
+/-- A trace through a body CFG still exists (up to reindexing) in a zero-or-more loop CFG. -/
-theorem Trace.loop {idx₁ idx₂ : g.Index} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) :
+noncomputable def Trace.loop {idx₁ idx₂ : g.Index} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (Graph.loop g) (idx₁.natAdd 2) (idx₂.natAdd 2) ρ₁ ρ₂ := by
+    Trace (Graph.loop g) (idx₁.natAdd 2) (idx₂.natAdd 2) ρ₁ ρ₂ :=
-  induction tr with
+  tr.embed (GGraph.Embed.loop g)
-  | single hbs =>
-    exact Trace.single (by
-      rwa [show (Graph.loop g).nodes = Fin.append (fun _ : Fin 2 => []) g.nodes from rfl,
-        Fin.append_right])
-  | edge hbs he _ ih =>
-    refine Trace.edge ?_ ?_ ih
-    · rwa [show (Graph.loop g).nodes = Fin.append (fun _ : Fin 2 => []) g.nodes from rfl,
-        Fin.append_right]
-    · exact List.mem_append_left _ (List.mem_append_left _
-        (List.mem_append_left _ (List.mem_map_of_mem _ he)))
 
-private theorem loop_nodes_at_in :
+/-- The beginning node of a loop graph is empty. -/
-    (Graph.loop g).nodes g.loopIn = [] :=
+private lemma loop_nodes_at_in :
-  Fin.append_left (fun _ : Fin 2 => []) g.nodes 0
+    (Graph.loop g).nodes g.loopIn = none :=
+  Fin.append_left (fun _ : Fin 2 => none) g.nodes 0
 
-private theorem loop_nodes_at_out :
+/-- The ending node of a loop graph is empty. -/
-    (Graph.loop g).nodes g.loopOut = [] :=
+private lemma loop_nodes_at_out :
-  Fin.append_left (fun _ : Fin 2 => []) g.nodes 1
+    (Graph.loop g).nodes g.loopOut = none :=
+  Fin.append_left (fun _ : Fin 2 => none) g.nodes 1
 
-/-- Agda: `EndToEndTrace-loop`. -/
+/-- Execute the empty loop header and follow its edge into this body execution. -/
-theorem EndToEndTrace.loop (etr : EndToEndTrace g ρ₁ ρ₂) :
+noncomputable def EndToEndTrace.beforeBody (body : EndToEndTrace g ρ₁ ρ₂) :
-    EndToEndTrace (Graph.loop g) ρ₁ ρ₂ := by
+    Traceₗ (Graph.loop g) g.loopIn (body.entry.natAdd 2) ρ₁ ρ₁ := by
-  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
+  refine (Trace.single (loop_nodes_at_in ▸ EvalBasicStmtOpt.none)).addEdge ?_
-  -- the edge in → (2 ↑ʳ i₁), reached through the second edge group
-  have hin : (g.loopIn, i₁.natAdd 2) ∈ (Graph.loop g).edges := by
   refine List.mem_append_left _ (List.mem_append_left _ (List.mem_append_right _ ?_))
-    exact List.mem_map_of_mem _ (List.mem_map_of_mem _ h₁)
+  exact List.mem_map_of_mem _ (List.mem_map_of_mem _ body.entry_mem)
-  -- the edge (2 ↑ʳ i₂) → out, reached through the third edge group
-  have hout : (i₂.natAdd 2, g.loopOut) ∈ (Graph.loop g).edges := by
-    refine List.mem_append_left _ (List.mem_append_right _ ?_)
-    exact List.mem_map_of_mem _ (List.mem_map_of_mem _ h₂)
-  refine ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _, ?_⟩
-  exact Trace.concat (Trace.single (loop_nodes_at_in ▸ EvalBasicStmts.nil)) hin
-    (Trace.concat tr.loop hout (Trace.single (loop_nodes_at_out ▸ EvalBasicStmts.nil)))
 
-private theorem loop_edge_out_in :
+/-- Equivlaent of `Trace.loop` for end-to-end traces. -/
+noncomputable def EndToEndTrace.loop (etr : EndToEndTrace g ρ₁ ρ₂) :
+    EndToEndTrace (Graph.loop g) ρ₁ ρ₂ := by
+  -- the edge (2 ↑ʳ etr.exit) → out, reached through the third edge group
+  have hout : (etr.exit.natAdd 2, g.loopOut) ∈ (Graph.loop g).edges := by
+    refine List.mem_append_left _ (List.mem_append_right _ ?_)
+    exact List.mem_map_of_mem _ (List.mem_map_of_mem _ etr.exit_mem)
+  refine ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _, ?_⟩
+  exact (etr.beforeBody.appendTrace etr.trace.loop) ++< hout >++
+    Trace.single (loop_nodes_at_out ▸ EvalBasicStmtOpt.none)
+
+/-- The zero-or-more times loop has an edge to return back to the top, to continue after an iteration. -/
+private lemma loop_edge_out_in :
     ((g.loopOut, g.loopIn) : (Graph.loop g).Edge) ∈ (Graph.loop g).edges := by
   refine List.mem_append_right _ ?_
   exact List.mem_cons_self _ _
 
-/-- Agda: `EndToEndTrace-loop²`. -/
+/-- Complete an iteration and follow the back edge before the remaining loop execution. -/
-theorem EndToEndTrace.loop_concat (etr₁ : EndToEndTrace (Graph.loop g) ρ₁ ρ₂)
+noncomputable def EndToEndTrace.beforeRest
+    (iteration : EndToEndTrace (Graph.loop g) ρ₁ ρ₂)
+    (rest : EndToEndTrace (Graph.loop g) ρ₂ ρ₃) :
+    Traceₗ (Graph.loop g) iteration.entry rest.entry ρ₁ ρ₂ := by
+  refine iteration.trace.addEdge ?_
+  have hout := iteration.exit_mem
+  have hin := rest.entry_mem
+  simp only [Graph.loop_inputs, Graph.loop_outputs, List.mem_singleton] at hin hout
+  simpa only [hin, hout] using (loop_edge_out_in (g := g))
+
+/-- Two traces through a loop can be combined, since a loop can be executed any number of times. -/
+noncomputable def EndToEndTrace.loop_concat (etr₁ : EndToEndTrace (Graph.loop g) ρ₁ ρ₂)
     (etr₂ : EndToEndTrace (Graph.loop g) ρ₂ ρ₃) :
     EndToEndTrace (Graph.loop g) ρ₁ ρ₃ := by
-  obtain ⟨i₁, h₁, i₂, h₂, tr₁⟩ := etr₁
+  exact ⟨etr₁.entry, etr₁.entry_mem, etr₂.exit, etr₂.exit_mem,
-  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
+    etr₁.beforeRest etr₂ ++ etr₂.trace⟩
-  simp only [Graph.loop_inputs, Graph.loop_outputs, List.mem_singleton] at h₁ h₂ k₁ k₂
-  subst h₁; subst h₂; subst k₁; subst k₂
-  exact ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _,
-    Trace.concat tr₁ loop_edge_out_in tr₂⟩
 
-/-- Agda: `EndToEndTrace-loop⁰`. -/
+/-- A loop can be executed zero times. -/
-theorem EndToEndTrace.loop_empty {ρ : Env} : EndToEndTrace (Graph.loop g) ρ ρ := by
+noncomputable def EndToEndTrace.loop_empty {ρ : Env} : EndToEndTrace (Graph.loop g) ρ ρ := by
   have hedge : ((g.loopIn, g.loopOut) : (Graph.loop g).Edge) ∈ (Graph.loop g).edges :=
     List.mem_append_right _ (List.mem_cons_of_mem _ (List.mem_cons_self _ _))
   exact ⟨g.loopIn, List.mem_singleton_self _, g.loopOut, List.mem_singleton_self _,
-    Trace.concat (Trace.single (loop_nodes_at_in ▸ EvalBasicStmts.nil)) hedge
+    Trace.single (loop_nodes_at_in ▸ EvalBasicStmtOpt.none) ++< hedge >++
-      (Trace.single (loop_nodes_at_out ▸ EvalBasicStmts.nil))⟩
+      Trace.single (loop_nodes_at_out ▸ EvalBasicStmtOpt.none)⟩
 
 end Loop
 
-/-! ### Singletons, wrap, and the main result -/
+/-- A CFG consisting of only a single node has a trace through it corresponding to that node. -/
-
+noncomputable def EndToEndTrace.singleton {o : Option BasicStmt} {ρ₁ ρ₂ : Env}
-/-- Agda: `EndToEndTrace-singleton`. -/
+    (h : EvalBasicStmtOpt ρ₁ o ρ₂) : EndToEndTrace (Graph.singleton o) ρ₁ ρ₂ :=
-theorem EndToEndTrace.singleton {bss : List BasicStmt} {ρ₁ ρ₂ : Env}
-    (h : EvalBasicStmts ρ₁ bss ρ₂) : EndToEndTrace (Graph.singleton bss) ρ₁ ρ₂ :=
   ⟨(0 : Fin 1), List.mem_singleton_self _, (0 : Fin 1), List.mem_singleton_self _,
    Trace.single h⟩
 
-/-- Agda: `EndToEndTrace-singleton[]`. -/
+/-- If a CFG's only node is empty, the no-op trace exists through it. -/
-theorem EndToEndTrace.singleton_nil (ρ : Env) :
+noncomputable def EndToEndTrace.singleton_nil (ρ : Env) :
-    EndToEndTrace (Graph.singleton []) ρ ρ :=
+    EndToEndTrace (Graph.singleton none) ρ ρ :=
-  EndToEndTrace.singleton EvalBasicStmts.nil
+  EndToEndTrace.singleton EvalBasicStmtOpt.none
 
-/-- Agda: `EndToEndTrace-wrap`. -/
+/-- Invoking 'Graph.wrap` (which ensures a single entry and exit node for a CFG)
-theorem EndToEndTrace.wrap {g : Graph} {ρ₁ ρ₂ : Env}
+    does not invalidate traces in the original graph. -/
+noncomputable def EndToEndTrace.wrap {g : Graph} {ρ₁ ρ₂ : Env}
     (etr : EndToEndTrace g ρ₁ ρ₂) : EndToEndTrace (Graph.wrap g) ρ₁ ρ₂ :=
   (EndToEndTrace.singleton_nil ρ₁).concat (etr.concat (EndToEndTrace.singleton_nil ρ₂))
 
-/-- Agda: `buildCfg-sufficient` — every terminating execution is witnessed by
+/-- Reach the selected root entry through the program's empty wrapper node. -/
-an end-to-end trace through the control-flow graph. -/
+noncomputable def EndToEndTrace.beforeRoot {g : Graph} {ρ₁ ρ₂ : Env}
-theorem buildCfg_sufficient {s : Stmt} {ρ₁ ρ₂ : Env}
+    (root : EndToEndTrace g ρ₁ ρ₂) :
-    (h : EvalStmt ρ₁ s ρ₂) : EndToEndTrace (buildCfg s) ρ₁ ρ₂ := by
+    Traceₗ (Graph.wrap g) (Graph.wrapInput g)
+      (((GGraph.Embed.sequenceLeft g (Graph.singleton none)).trans
+        (GGraph.Embed.sequenceRight (Graph.singleton none) _)).f root.entry) ρ₁ ρ₁ :=
+  (EndToEndTrace.singleton_nil ρ₁).beforeRight (root.concat (EndToEndTrace.singleton_nil ρ₂))
+
+/-- Key result: the control flow graph admits every execution that's made
+    possible by a language's semantics. Thus, the CFG encodes _at least_ all
+    semantically-possible executions. Informally, we can conclude from this
+    that if we compute a result that using the graph's edges to determine
+    what's possible, this result will not disagree with the semantics.
+
+    Note that a CFG like $K_4$ (where the nodes are basic blocks) is
+    technically also a sufficient graph, but is very likely meaningless in that
+    it grossly overestimates the possible execution paths in the language, and
+    thus is bound to produce less-than-specific results. There is as yet no
+    result in this framework that the CFG we produce is _minimal_: loosely,
+    posessing only edges for things that are admitted by the semantics.
+    This is difficult to state (in its strongest form, this would
+    require the CFG to be able to detect something like `while (alwaysFalse)`,
+    and so remains a TODO. -/
+noncomputable def Stmt.cfg_sufficient {s : Stmt} {ρ₁ ρ₂ : Env}
+    (h : EvalStmt ρ₁ s ρ₂) : EndToEndTrace s.cfg ρ₁ ρ₂ := by
   induction h with
   | basic ρ₁ ρ₂ bs hbs =>
-    exact EndToEndTrace.singleton (EvalBasicStmts.cons hbs EvalBasicStmts.nil)
+    exact EndToEndTrace.singleton (EvalBasicStmtOpt.some hbs)
   | andThen ρ₁ ρ₂ ρ₃ s₁ s₂ _ _ ih₁ ih₂ =>
     exact ih₁.concat ih₂
   | ifTrue ρ₁ ρ₂ e z s₁ s₂ _ _ _ ih =>
-    exact ih.comp_left
+    exact ih.overlay_left
   | ifFalse ρ₁ ρ₂ e s₁ s₂ _ _ ih =>
-    exact ih.comp_right
+    exact ih.overlay_right
   | whileTrue ρ₁ ρ₂ ρ₃ e z s _ _ _ _ ih₁ ih₂ =>
     exact (ih₁.loop).loop_concat ih₂
   | whileFalse ρ e s _ =>
     exact EndToEndTrace.loop_empty
 
-/-! ### The wrapped graph's entry has no predecessors (Agda's "ugly" block) -/
+namespace Program
 
-/-- The input of `wrap g` (Agda: `wrap-input`). -/
+noncomputable def trace (p : Program) {ρ : Env} (h : EvalStmt [] p.rootStmt ρ) :
-def Graph.wrapInput (g : Graph) : (Graph.wrap g).Index :=
+    Trace p.cfg p.initialState p.finalState [] ρ := by
-  (0 : Fin 1).castAdd ((g ⤳ Graph.singleton []).size)
+  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := EndToEndTrace.wrap (Stmt.cfg_sufficient h)
+  rw [Graph.wrap_inputs, List.mem_singleton] at h₁
+  rw [Graph.wrap_outputs, List.mem_singleton] at h₂
+  subst h₁; subst h₂
+  exact tr
 
-/-- The output of `wrap g` (Agda: `wrap-output`). -/
+end Program
-def Graph.wrapOutput (g : Graph) : (Graph.wrap g).Index :=
-  Fin.natAdd 1 ((Fin.natAdd g.size (0 : Fin 1)))
 
-theorem Graph.wrap_inputs (g : Graph) :
-    (Graph.wrap g).inputs = [g.wrapInput] := rfl
-
-theorem Graph.wrap_outputs (g : Graph) :
-    (Graph.wrap g).outputs = [g.wrapOutput] := rfl
-
-/-- Agda: `help`/`helpAll` — no edge of `singleton [] ⤳ g₂` ends at a
-`castAdd`-injected node (all edge targets are `natAdd`s). -/
-private theorem not_mem_edges_castAdd_link {g₂ : Graph} (i : Fin 1)
-    (idx : (Graph.singleton [] ⤳ g₂).Index) :
-    ((idx, i.castAdd g₂.size) : (Graph.singleton [] ⤳ g₂).Edge)
-      ∉ (Graph.singleton [] ⤳ g₂).edges := by
-  intro h
-  rcases List.mem_append.mp h with h' | h'
-  · rcases List.mem_append.mp h' with h'' | h''
-    · -- lifted edges of `singleton []`: there are none
-      simp [Graph.singleton, Graph.liftEdgeL] at h''
-    · -- lifted edges of g₂: targets are natAdd
-      obtain ⟨e, _, heq⟩ := List.mem_map.mp h''
-      exact Fin.castAdd_ne_natAdd i e.2 (congrArg Prod.snd heq).symm
-  · -- product edges: targets are natAdd'd inputs of g₂
-    obtain ⟨-, hb⟩ := List.mem_product.mp h'
-    obtain ⟨j, -, heq⟩ := List.mem_map.mp hb
-    exact Fin.castAdd_ne_natAdd i j heq.symm
-
-/-- Agda: `wrap-preds-∅` — the entry node of a wrapped graph has no
-incoming edges. -/
-theorem Graph.wrap_predecessors_eq_nil (g : Graph) (idx : (Graph.wrap g).Index)
-    (h : idx ∈ (Graph.wrap g).inputs) :
-    (Graph.wrap g).predecessors idx = [] := by
-  rw [Graph.wrap_inputs, List.mem_singleton] at h
-  subst h
-  rw [Graph.predecessors, List.filter_eq_nil_iff]
-  intro idx' _
-  simpa using not_mem_edges_castAdd_link (g₂ := g ⤳ Graph.singleton []) 0 idx'
 
 end Spa

lean/Spa/Language/Semantics.lean

@@ -1,41 +1,39 @@
-/-
-Port of `Language/Semantics.agda`.
-
-Correspondence:
-  Value (↑ᶻ)        ↦ Value.int
-  Env               ↦ Env (= List (String × Value))
-  _∈_ (env lookup)  ↦ Env.Mem
-  _,_⇒ᵉ_            ↦ EvalExpr
-  _,_⇒ᵇ_            ↦ EvalBasicStmt
-  _,_⇒ᵇˢ_           ↦ EvalBasicStmts
-  _,_⇒ˢ_            ↦ EvalStmt
-  LatticeInterpretation:
-    ⟦_⟧             ↦ interp
-    ⟦⟧-respects-≈   ↦ (trivial with `=`; field dropped)
-    ⟦⟧-⊔-∨          ↦ interp_sup
-    ⟦⟧-⊓-∧          ↦ interp_inf
-    (the `Utils` combinators `_⇒_`, `_∨_`, `_∧_` are inlined as plain logic)
--/
 import Spa.Language.Base
 import Spa.Lattice
+import Spa.Interp
+
+/-!
+
+# Operational Semantics
+
+This file contains the operational semantics for the object language defined in
+`Spa.Language.Base`. Right now, all values in the language are integers.
+The semantics are big-step, and lead to a fully constructed proof tree
+containing the derivation connecting the initial and final states.
+All pretty standard.
+
+-/
 
 namespace Spa
 
+/-- A value in the object language. Currently, the only possible case is
+    an integer. -/
 inductive Value where
   | int (z : ℤ)
   deriving DecidableEq
 
+/-- An environment mapping variables to their values. -/
 def Env : Type := List (String × Value)
 
-/-- Agda: `_∈_` on environments — lookup respecting shadowing. -/
 inductive Env.Mem : String × Value → Env → Prop
   | here (s : String) (v : Value) (ρ : Env) : Env.Mem (s, v) ((s, v) :: ρ)
   | there (s s' : String) (v v' : Value) (ρ : Env) :
       ¬(s = s') → Env.Mem (s, v) ρ → Env.Mem (s, v) ((s', v') :: ρ)
 
-/-- Agda: `_,_⇒ᵉ_`. -/
+/-- Inference rules for evaluating an expression (`Spa.Expr`) in a given
+    environment. Pretty standard big-step expression evaluation. -/
 inductive EvalExpr : Env → Expr → Value → Prop
-  | num (ρ : Env) (n : ℕ) : EvalExpr ρ (.num n) (.int n)
+  | num (ρ : Env) (z : ℤ) : EvalExpr ρ (.num z) (.int z)
   | var (ρ : Env) (x : String) (v : Value) :
       Env.Mem (x, v) ρ → EvalExpr ρ (.var x) v
   | add (ρ : Env) (e₁ e₂ : Expr) (z₁ z₂ : ℤ) :
@@ -45,21 +43,25 @@ inductive EvalExpr : Env → Expr → Value → Prop
       EvalExpr ρ e₁ (.int z₁) → EvalExpr ρ e₂ (.int z₂) →
       EvalExpr ρ (.sub e₁ e₂) (.int (z₁ - z₂))
 
-/-- Agda: `_,_⇒ᵇ_`. -/
+/-- Inference rules for evaluating a basic statement (`Spa.BasicStmt`) in
-inductive EvalBasicStmt : Env → BasicStmt → Env → Prop
+    a given environment, potentially changing the environment.
+    Pretty standard big-step evaluation. -/
+inductive EvalBasicStmt : Env → BasicStmt → Env → Type
   | noop (ρ : Env) : EvalBasicStmt ρ .noop ρ
   | assign (ρ : Env) (x : String) (e : Expr) (v : Value) :
       EvalExpr ρ e v → EvalBasicStmt ρ (.assign x e) ((x, v) :: ρ)
 
-/-- Agda: `_,_⇒ᵇˢ_`. -/
+/-- Inference rules for evaluating a basic-statement-or-nothing,
-inductive EvalBasicStmts : Env → List BasicStmt → Env → Prop
+    which is the current representation of CFGs nodes. -/
-  | nil {ρ : Env} : EvalBasicStmts ρ [] ρ
+inductive EvalBasicStmtOpt : Env → Option BasicStmt → Env → Type
-  | cons {ρ₁ ρ₂ ρ₃ : Env} {bs : BasicStmt} {bss : List BasicStmt} :
+  | none {ρ : Env} : EvalBasicStmtOpt ρ Option.none ρ
-      EvalBasicStmt ρ₁ bs ρ₂ → EvalBasicStmts ρ₂ bss ρ₃ →
+  | some {ρ₁ ρ₂ : Env} {bs : BasicStmt} :
-      EvalBasicStmts ρ₁ (bs :: bss) ρ₃
+      EvalBasicStmt ρ₁ bs ρ₂ → EvalBasicStmtOpt ρ₁ (Option.some bs) ρ₂
 
-/-- Agda: `_,_⇒ˢ_`. -/
+/-- Inference rules for evaluating statements (`Spa.Stmt`) in a given
-inductive EvalStmt : Env → Stmt → Env → Prop
+    environment, potentially changing the environment.
+    Pretty standard big-step evaluation. -/
+inductive EvalStmt : Env → Stmt → Env → Type
   | basic (ρ₁ ρ₂ : Env) (bs : BasicStmt) :
       EvalBasicStmt ρ₁ bs ρ₂ → EvalStmt ρ₁ (.basic bs) ρ₂
   | andThen (ρ₁ ρ₂ ρ₃ : Env) (s₁ s₂ : Stmt) :
@@ -79,10 +81,16 @@ inductive EvalStmt : Env → Stmt → Env → Prop
       EvalExpr ρ e (.int 0) →
       EvalStmt ρ (.whileLoop e s) ρ
 
-/-- Agda: `LatticeInterpretation` (used there as an instance argument `⦃·⦄`,
+/-- For the purpose of static analysis, lattices we define describe program
-hence a typeclass here). -/
+    state, or better yet, they describe _values_ in the program.
-class LatticeInterpretation (L : Type*) [Lattice L] where
+    This class should be provided by each analysis' lattice (see also `Spa/Analysis/Forward.lean`)
-  interp : L → Value → Prop
+    to describe what each lattice value means in terms of the language.
+
+    In addition to providing the interpretation (`Spa.Interp`), the lattice
+    combinators `⊔` and `⊓` must respect disjunction and conjunction respectively.
+    This is because possible paths through a control flow graph (`Spa/Language/Graphs.lean`),
+    are tied to lattice operations used by the analysis engine. -/
+class LatticeInterpretation (L : Type*) [Lattice L] extends Interp L (Value → Prop) where
   interp_sup : ∀ {l₁ l₂ : L} (v : Value),
     interp l₁ v ∨ interp l₂ v → interp (l₁ ⊔ l₂) v
   interp_inf : ∀ {l₁ l₂ : L} (v : Value),

lean/Spa/Language/Tagged/DESCENDANT-TRACKING.md

@@ -0,0 +1,417 @@
+# Descendant tracking (parked)
+
+This is the formally-verified **interval-labeling / descendant** machinery that
+used to live in `Id.lean` and `Properties.lean`. It let you decide "is node `a`
+a descendant of node `b`?" with two integer comparisons on their identifiers,
+and *proved* that numeric test equivalent to structural subtree containment.
+
+It was removed because the descendant test is a *computational optimization*:
+the same question can be answered by walking the AST, and nothing in the current
+pipeline needs the fast test yet. The proofs (a rose-tree flattening + a
+postorder `Good` invariant) are a real mechanization cost to carry. Parked here
+so it can be restored verbatim when LICM actually wants it.
+
+## What stays in the live code
+
+- `NodeId` collapses to a single unique index (`{ post : ℕ }`); `tag` still
+  assigns each node a distinct postorder number.
+- The bidirectional mapping (`erase`/`tag` + `erase_tagStmt`) stays in
+  `Properties.lean`.
+- The labelled-CFG id↔state mapping (`Cfg.lean`) is independent of this and is
+  unaffected.
+
+## Revival checklist
+
+1. In `Id.lean`, give `NodeId` back its descendant-count field and the test:
+
+   ```lean
+   structure NodeId where
+     post : ℕ
+     desc : ℕ          -- number of proper descendants (subtree size − 1); leaf = 0
+     deriving DecidableEq, Repr
+
+   namespace NodeId
+
+   /-- Left endpoint of the node's postorder interval `[lo, post]`. -/
+   def lo (a : NodeId) : ℕ := a.post - a.desc
+
+   /-- `a` is a descendant-or-self of `b`: `a.post` lies in `b`'s interval. -/
+   def DescendantOf (a b : NodeId) : Prop := b.lo ≤ a.post ∧ a.post ≤ b.post
+
+   instance (a b : NodeId) : Decidable (DescendantOf a b) := by
+     unfold DescendantOf; infer_instance
+
+   end NodeId
+   ```
+
+2. In `Derive.lean`, make the generated `tag` store the descendant count again:
+   change the emitted identifier in `mkTag` from `(⟨$last⟩ : $nId)` back to
+   `(⟨$last, $last - n⟩ : $nId)`.
+
+3. Paste the Lean block below back into `Properties.lean` (after the round-trip
+   theorems). It builds against the `id.lo = lo`-premise form of `Good` and the
+   childcount (`desc`) identifier. The headline result is
+   `descendant_iff_tagStmt`; everything else is supporting machinery.
+
+## The parked proofs
+
+```lean
+/-- A rose tree of identifiers: the uniform shape underlying all three tagged
+AST types, used to reason about the postorder labeling generically. -/
+inductive IdTree where
+  | node (id : NodeId) (children : List IdTree)
+
+namespace IdTree
+
+def rootId : IdTree → NodeId
+  | .node id _ => id
+
+@[simp] theorem rootId_node (id : NodeId) (cs : List IdTree) :
+    (IdTree.node id cs).rootId = id := rfl
+
+mutual
+def subtrees : IdTree → List IdTree
+  | .node id cs => .node id cs :: subtreesList cs
+def subtreesList : List IdTree → List IdTree
+  | [] => []
+  | c :: cs => subtrees c ++ subtreesList cs
+end
+
+@[simp] theorem subtrees_node (id : NodeId) (cs : List IdTree) :
+    subtrees (.node id cs) = .node id cs :: subtreesList cs := rfl
+
+@[simp] theorem subtreesList_nil : subtreesList [] = [] := rfl
+
+@[simp] theorem subtreesList_cons (c : IdTree) (cs : List IdTree) :
+    subtreesList (c :: cs) = subtrees c ++ subtreesList cs := rfl
+
+def posts (t : IdTree) : List ℕ := (subtrees t).map (fun s => s.rootId.post)
+
+def postsList (cs : List IdTree) : List ℕ := (subtreesList cs).map (fun s => s.rootId.post)
+
+@[simp] theorem posts_node (id : NodeId) (cs : List IdTree) :
+    posts (.node id cs) = id.post :: postsList cs := rfl
+
+@[simp] theorem postsList_nil : postsList [] = [] := rfl
+
+@[simp] theorem postsList_cons (c : IdTree) (cs : List IdTree) :
+    postsList (c :: cs) = posts c ++ postsList cs := by
+  simp [posts, postsList]
+
+end IdTree
+
+def Expr.Tagged.toIdTree : Expr.Tagged NodeId → IdTree
+  | .add t a b => .node t [a.toIdTree, b.toIdTree]
+  | .sub t a b => .node t [a.toIdTree, b.toIdTree]
+  | .var t _ => .node t []
+  | .num t _ => .node t []
+
+def BasicStmt.Tagged.toIdTree : BasicStmt.Tagged NodeId → IdTree
+  | .assign t _ e => .node t [e.toIdTree]
+  | .noop t => .node t []
+
+def Stmt.Tagged.toIdTree : Stmt.Tagged NodeId → IdTree
+  | .basic t bs => .node t [bs.toIdTree]
+  | .andThen t a b => .node t [a.toIdTree, b.toIdTree]
+  | .ifElse t e a b => .node t [e.toIdTree, a.toIdTree, b.toIdTree]
+  | .whileLoop t e s => .node t [e.toIdTree, s.toIdTree]
+
+mutual
+inductive Good : ℕ → IdTree → Prop
+  | mk {lo : ℕ} {id : NodeId} {cs : List IdTree} :
+      id.lo = lo → GoodChildren lo cs id.post →
+      Good lo (.node id cs)
+inductive GoodChildren : ℕ → List IdTree → ℕ → Prop
+  | nil {pos : ℕ} : GoodChildren pos [] pos
+  | cons {cur : ℕ} {c : IdTree} {cs : List IdTree} {pos : ℕ} :
+      Good cur c → GoodChildren (c.rootId.post + 1) cs pos →
+      GoodChildren cur (c :: cs) pos
+end
+
+theorem Good.lo_le_post {lo : ℕ} {t : IdTree} (h : Good lo t) : lo ≤ t.rootId.post := by
+  cases h with
+  | mk hlo _ => simp only [NodeId.lo] at hlo; simp only [IdTree.rootId_node]; omega
+
+theorem GoodChildren.cur_le_pos : ∀ {cur : ℕ} (cs : List IdTree) {pos : ℕ},
+    GoodChildren cur cs pos → cur ≤ pos
+  | _, [], _, h => by cases h; exact le_rfl
+  | _, c :: cs, _, h => by
+      cases h with
+      | cons hc hcs =>
+        have := hc.lo_le_post
+        have := GoodChildren.cur_le_pos cs hcs
+        omega
+
+mutual
+theorem Good.mem_posts : ∀ {lo : ℕ} (t : IdTree), Good lo t →
+    ∀ x, x ∈ IdTree.posts t ↔ lo ≤ x ∧ x ≤ t.rootId.post
+  | _, .node id cs, h, x => by
+      cases h with
+      | mk hlo hch =>
+        simp only [IdTree.posts_node, List.mem_cons, IdTree.rootId_node]
+        rw [GoodChildren.mem_postsList cs hch x]
+        simp only [NodeId.lo] at hlo
+        omega
+theorem GoodChildren.mem_postsList : ∀ {cur : ℕ} (cs : List IdTree) {pos : ℕ},
+    GoodChildren cur cs pos → ∀ x, x ∈ IdTree.postsList cs ↔ cur ≤ x ∧ x < pos
+  | _, [], _, h, x => by
+      cases h
+      simp only [IdTree.postsList_nil]
+      constructor
+      · intro hx; exact absurd hx (List.not_mem_nil x)
+      · rintro ⟨h1, h2⟩; exfalso; omega
+  | _, c :: cs, _, h, x => by
+      cases h with
+      | cons hc hcs =>
+        simp only [IdTree.postsList_cons, List.mem_append]
+        rw [Good.mem_posts c hc x, GoodChildren.mem_postsList cs hcs x]
+        have := hc.lo_le_post
+        have := GoodChildren.cur_le_pos cs hcs
+        omega
+end
+
+mutual
+theorem Good.nodup_posts : ∀ {lo : ℕ} (t : IdTree), Good lo t → (IdTree.posts t).Nodup
+  | _, .node id cs, h => by
+      cases h with
+      | mk hlo hch =>
+        simp only [IdTree.posts_node, List.nodup_cons]
+        refine ⟨?_, GoodChildren.nodup_postsList cs hch⟩
+        intro hmem
+        rw [GoodChildren.mem_postsList cs hch id.post] at hmem
+        omega
+theorem GoodChildren.nodup_postsList : ∀ {cur : ℕ} (cs : List IdTree) {pos : ℕ},
+    GoodChildren cur cs pos → (IdTree.postsList cs).Nodup
+  | _, [], _, h => by cases h; simp only [IdTree.postsList_nil, List.nodup_nil]
+  | _, c :: cs, _, h => by
+      cases h with
+      | cons hc hcs =>
+        simp only [IdTree.postsList_cons, List.nodup_append]
+        refine ⟨Good.nodup_posts c hc, GoodChildren.nodup_postsList cs hcs, ?_⟩
+        intro x hx1 hx2
+        rw [Good.mem_posts c hc x] at hx1
+        rw [GoodChildren.mem_postsList cs hcs x] at hx2
+        omega
+end
+
+mutual
+theorem Good.subtree_good : ∀ {lo : ℕ} (t : IdTree), Good lo t →
+    ∀ s ∈ IdTree.subtrees t, Good s.rootId.lo s
+  | _, .node id cs, h, s, hs => by
+      cases h with
+      | mk hlo hch =>
+        rw [IdTree.subtrees_node, List.mem_cons] at hs
+        rcases hs with rfl | hs
+        · simp only [IdTree.rootId_node]; rw [hlo]; exact Good.mk hlo hch
+        · exact GoodChildren.subtree_good cs hch s hs
+theorem GoodChildren.subtree_good : ∀ {cur : ℕ} (cs : List IdTree) {pos : ℕ},
+    GoodChildren cur cs pos → ∀ s ∈ IdTree.subtreesList cs, Good s.rootId.lo s
+  | _, [], _, _, s, hs => by simp only [IdTree.subtreesList_nil, List.not_mem_nil] at hs
+  | _, c :: cs, _, h, s, hs => by
+      cases h with
+      | cons hc hcs =>
+        rw [IdTree.subtreesList_cons, List.mem_append] at hs
+        rcases hs with hs | hs
+        · exact Good.subtree_good c hc s hs
+        · exact GoodChildren.subtree_good cs hcs s hs
+end
+
+mutual
+theorem IdTree.subtrees_subset : ∀ (t : IdTree) {b : IdTree},
+    b ∈ subtrees t → subtrees b ⊆ subtrees t
+  | .node id cs, b, hb => by
+      rw [subtrees_node, List.mem_cons] at hb
+      rcases hb with rfl | hb
+      · exact fun _ h => h
+      · intro x hx
+        rw [subtrees_node, List.mem_cons]
+        exact Or.inr (IdTree.subtreesList_subset cs hb hx)
+theorem IdTree.subtreesList_subset : ∀ (cs : List IdTree) {b : IdTree},
+    b ∈ subtreesList cs → subtrees b ⊆ subtreesList cs
+  | [], b, hb => by simp only [subtreesList_nil, List.not_mem_nil] at hb
+  | c :: cs, b, hb => by
+      rw [subtreesList_cons, List.mem_append] at hb
+      intro x hx
+      rw [subtreesList_cons, List.mem_append]
+      rcases hb with hb | hb
+      · exact Or.inl (IdTree.subtrees_subset c hb hx)
+      · exact Or.inr (IdTree.subtreesList_subset cs hb hx)
+end
+
+theorem IdTree.eq_of_post_eq {l : List IdTree}
+    (h : (l.map (fun s => s.rootId.post)).Nodup) {a c : IdTree}
+    (ha : a ∈ l) (hc : c ∈ l) (hpost : a.rootId.post = c.rootId.post) : a = c := by
+  induction l with
+  | nil => exact absurd ha (List.not_mem_nil a)
+  | cons d ds ih =>
+    simp only [List.map_cons, List.nodup_cons] at h
+    obtain ⟨hd, htl⟩ := h
+    simp only [List.mem_cons] at ha hc
+    rcases ha with rfl | ha <;> rcases hc with rfl | hc
+    · rfl
+    · exfalso; apply hd; rw [hpost]; exact List.mem_map_of_mem _ hc
+    · exfalso; apply hd; rw [← hpost]; exact List.mem_map_of_mem _ ha
+    · exact ih htl ha hc
+
+theorem descendant_iff_of_good {lo : ℕ} {t : IdTree} (hg : Good lo t)
+    {a b : IdTree} (ha : a ∈ IdTree.subtrees t) (hb : b ∈ IdTree.subtrees t) :
+    a.rootId.DescendantOf b.rootId ↔ a ∈ IdTree.subtrees b := by
+  have hgb : Good b.rootId.lo b := Good.subtree_good t hg b hb
+  constructor
+  · rintro ⟨h1, h2⟩
+    have hmem : a.rootId.post ∈ IdTree.posts b := by
+      rw [Good.mem_posts b hgb a.rootId.post]; exact ⟨h1, h2⟩
+    rw [IdTree.posts, List.mem_map] at hmem
+    obtain ⟨c, hc_mem, hc_post⟩ := hmem
+    have hc_t : c ∈ IdTree.subtrees t := IdTree.subtrees_subset t hb hc_mem
+    have hac : a = c :=
+      IdTree.eq_of_post_eq (hg.nodup_posts t) ha hc_t hc_post.symm
+    rw [hac]; exact hc_mem
+  · intro hsub
+    have hmem : a.rootId.post ∈ IdTree.posts b := by
+      rw [IdTree.posts, List.mem_map]; exact ⟨a, hsub, rfl⟩
+    rw [Good.mem_posts b hgb a.rootId.post] at hmem
+    exact hmem
+
+/-! ### Tagging produces a good tree
+
+We bridge from the `tag` traversal to the abstract `Good` invariant, by induction
+on the plain AST.  Each lemma also records that the returned counter is one past
+the root's postorder index. -/
+
+theorem Expr.tag_spec : ∀ (e : Expr) (n : ℕ),
+    Good n (e.tag n).1.toIdTree ∧ (e.tag n).1.toIdTree.rootId.post + 1 = (e.tag n).2 := by
+  intro e
+  induction e with
+  | num k =>
+      intro n
+      refine ⟨?_, ?_⟩
+      · simp only [Expr.tag, Expr.Tagged.toIdTree]
+        exact Good.mk (by simp only [NodeId.lo]; omega) GoodChildren.nil
+      · simp only [Expr.tag, Expr.Tagged.toIdTree, IdTree.rootId_node]
+  | var x =>
+      intro n
+      refine ⟨?_, ?_⟩
+      · simp only [Expr.tag, Expr.Tagged.toIdTree]
+        exact Good.mk (by simp only [NodeId.lo]; omega) GoodChildren.nil
+      · simp only [Expr.tag, Expr.Tagged.toIdTree, IdTree.rootId_node]
+  | add a b iha ihb =>
+      intro n
+      obtain ⟨gA, pA⟩ := iha n
+      obtain ⟨gB, pB⟩ := ihb (a.tag n).2
+      have lA := gA.lo_le_post
+      have lB := gB.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Expr.tag, Expr.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gA ?_
+          rw [pA]; refine GoodChildren.cons gB ?_; rw [pB]; exact GoodChildren.nil
+      · simp only [Expr.tag, Expr.Tagged.toIdTree, IdTree.rootId_node]
+  | sub a b iha ihb =>
+      intro n
+      obtain ⟨gA, pA⟩ := iha n
+      obtain ⟨gB, pB⟩ := ihb (a.tag n).2
+      have lA := gA.lo_le_post
+      have lB := gB.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Expr.tag, Expr.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gA ?_
+          rw [pA]; refine GoodChildren.cons gB ?_; rw [pB]; exact GoodChildren.nil
+      · simp only [Expr.tag, Expr.Tagged.toIdTree, IdTree.rootId_node]
+
+theorem BasicStmt.tag_spec : ∀ (bs : BasicStmt) (n : ℕ),
+    Good n (bs.tag n).1.toIdTree ∧ (bs.tag n).1.toIdTree.rootId.post + 1 = (bs.tag n).2 := by
+  intro bs
+  cases bs with
+  | noop =>
+      intro n
+      refine ⟨?_, ?_⟩
+      · simp only [BasicStmt.tag, BasicStmt.Tagged.toIdTree]
+        exact Good.mk (by simp only [NodeId.lo]; omega) GoodChildren.nil
+      · simp only [BasicStmt.tag, BasicStmt.Tagged.toIdTree, IdTree.rootId_node]
+  | assign x e =>
+      intro n
+      obtain ⟨gE, pE⟩ := Expr.tag_spec e n
+      have lE := gE.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [BasicStmt.tag, BasicStmt.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gE ?_
+          rw [pE]; exact GoodChildren.nil
+      · simp only [BasicStmt.tag, BasicStmt.Tagged.toIdTree, IdTree.rootId_node]
+
+theorem Stmt.tag_spec : ∀ (s : Stmt) (n : ℕ),
+    Good n (s.tag n).1.toIdTree ∧ (s.tag n).1.toIdTree.rootId.post + 1 = (s.tag n).2 := by
+  intro s
+  induction s with
+  | basic bs =>
+      intro n
+      obtain ⟨gBs, pBs⟩ := BasicStmt.tag_spec bs n
+      have lBs := gBs.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gBs ?_
+          rw [pBs]; exact GoodChildren.nil
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree, IdTree.rootId_node]
+  | andThen a b iha ihb =>
+      intro n
+      obtain ⟨gA, pA⟩ := iha n
+      obtain ⟨gB, pB⟩ := ihb (a.tag n).2
+      have lA := gA.lo_le_post
+      have lB := gB.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gA ?_
+          rw [pA]; refine GoodChildren.cons gB ?_; rw [pB]; exact GoodChildren.nil
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree, IdTree.rootId_node]
+  | ifElse e a b iha ihb =>
+      intro n
+      obtain ⟨gE, pE⟩ := Expr.tag_spec e n
+      obtain ⟨gA, pA⟩ := iha (e.tag n).2
+      obtain ⟨gB, pB⟩ := ihb (a.tag (e.tag n).2).2
+      have lE := gE.lo_le_post
+      have lA := gA.lo_le_post
+      have lB := gB.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gE ?_
+          rw [pE]; refine GoodChildren.cons gA ?_
+          rw [pA]; refine GoodChildren.cons gB ?_; rw [pB]; exact GoodChildren.nil
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree, IdTree.rootId_node]
+  | whileLoop e s ih =>
+      intro n
+      obtain ⟨gE, pE⟩ := Expr.tag_spec e n
+      obtain ⟨gS, pS⟩ := ih (e.tag n).2
+      have lE := gE.lo_le_post
+      have lS := gS.lo_le_post
+      refine ⟨?_, ?_⟩
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree]
+        refine Good.mk ?_ ?_
+        · simp only [NodeId.lo]; omega
+        · refine GoodChildren.cons gE ?_
+          rw [pE]; refine GoodChildren.cons gS ?_; rw [pS]; exact GoodChildren.nil
+      · simp only [Stmt.tag, Stmt.Tagged.toIdTree, IdTree.rootId_node]
+
+/-- A freshly tagged program is a well-tagged tree (rooted at postorder start `0`). -/
+theorem good_tagStmt (s : Stmt) : Good 0 (tagStmt s).toIdTree :=
+  (Stmt.tag_spec s 0).1
+
+/-- **Descendant characterization.** The numeric `NodeId.DescendantOf` relation on
+two nodes of a tagged program holds exactly when one is structurally contained in
+the other's subtree. -/
+theorem descendant_iff_tagStmt (s : Stmt) {a b : IdTree}
+    (ha : a ∈ IdTree.subtrees (tagStmt s).toIdTree)
+    (hb : b ∈ IdTree.subtrees (tagStmt s).toIdTree) :
+    a.rootId.DescendantOf b.rootId ↔ a ∈ IdTree.subtrees b :=
+  descendant_iff_of_good (good_tagStmt s) ha hb
+```

lean/Spa/Language/Tagged/TODO.md

@@ -0,0 +1,46 @@
+# Tagged AST — follow-ups
+
+## Descendant tracking — parked
+
+The interval-labeling descendant test and its correctness proof
+(`descendant_iff_tagStmt` and supporting rose-tree/`Good` machinery) have been
+removed from the live code and parked in `DESCENDANT-TRACKING.md`, with a revival
+checklist. It's a computational optimization not yet needed; revive it (and the
+`NodeId.desc` field) when LICM wants fast ancestor queries.
+
+## ID → CFG-state mapping — plan part B — DONE
+
+`Graphs.lean` now defines a payload-generic `GGraph α` (with `Graph := GGraph
+(List BasicStmt)` as the concrete CFG), so the labelled CFG **reuses** the graph
+combinators instead of mirroring them. In `Cfg.lean`:
+`buildCfgL : Stmt.Tagged NodeId → GGraph (List (BasicStmt.Tagged NodeId))` is just
+`buildCfg` at the tagged payload; `buildCfgL_graph :
+(buildCfgL t).map (List.map erase) = buildCfg t.erase` connects it to the real
+CFG; and `GGraph.nodeLabel`/`GGraph.stateOf` read a node's id straight from its
+payload (`stateOf_label` is the soundness). No `LGraph`, no separate `label`
+field, no duplicated combinators.
+
+## ID → CFG-state mapping — totality — DONE
+
+The `Option`-valued `nodeIdOf`/`stateOfNodeId` are now proven total on the inputs
+that matter (`Graphs.lean`), via a payload-list characterization of the CFG:
+
+- `GGraph.nodeList` flattens `nodes` into the list of payloads, with combinator
+  lemmas (`nodeList_comp/link/loop/wrap`) reducing it through the CFG builders.
+- `Stmt.Tagged.basics` lists a program's basic statements; the master lemma
+  `Stmt.Tagged.cfg_nodeList_filter` (and its program-level
+  `taggedCfg_nodeList_filter`) shows the non-empty CFG nodes are *exactly* the
+  singletons `[bs]` for `bs ∈ basics`.
+- AST ⇒ CFG: `exists_state_of_mem_basics` (a state with payload `[bs]`) and
+  `stateOfNodeId_isSome` (the search succeeds).
+- CFG ⇒ AST: `exists_basic_of_code_ne_nil` (a non-empty node is `[bs]`, with
+  `code = [bs.erase]` and `nodeIdOf = some bs.rootTag`) and `nodeIdOf_isSome`.
+
+All `propext`/`Quot.sound`-only (no `sorry`, no choice).
+
+Remaining nice-to-have:
+- Injectivity: distinct basic-statement ids map to distinct states, giving a
+  two-sided id ↔ state correspondence (upgrading the existence results above to a
+  genuine bijection, and pinning `stateOfNodeId (bs.rootTag)` to *the* state
+  holding `bs`). The `tag`-uniqueness fact this needs (`Nodup` of postorder tags)
+  was part of the parked descendant machinery in `DESCENDANT-TRACKING.md`.

lean/Spa/Language/TraceProperties.lean

@@ -0,0 +1,114 @@
+import Spa.Language.Properties
+import Spa.Language.Equivalence
+
+namespace Spa
+open GGraph
+
+/-- Recorded nodes contain instructions; empty CFG nodes are omitted from the history. -/
+lemma Path.steps_nonempty {g : Graph} {a b : Configuration g} (p : Path g a b)
+    {d : g.Index} (hm : d ∈ p.steps) : g.nodes d ≠ none := by
+  induction p with
+  | nil => simp [Path.steps] at hm
+  | cons st p ih =>
+      rcases List.mem_append.mp hm with hs | hp
+      · cases st with
+        | edge => simp [Step.steps] at hs
+        | @execute i ρ σ h =>
+            cases hc : g.nodes i <;> aesop (add simp [Step.steps, hc])
+      · exact ih hp
+
+private lemma optional_preserves_unwritten {ρ σ : Env} {obs : Option BasicStmt}
+    (h : EvalBasicStmtOpt ρ obs σ) (x : String)
+    (hn : ∀ rhs, obs ≠ some (.assign x rhs)) :
+    ∀ v, Env.Mem (x, v) ρ ↔ Env.Mem (x, v) σ := by
+  cases h with
+  | none => exact fun _ => Iff.rfl
+  | some h =>
+      cases h with
+      | noop => exact fun _ => Iff.rfl
+      | assign y rhs w hv =>
+          have hxy : x ≠ y := by
+            rintro rfl
+            exact hn rhs rfl
+          intro v; simp [Env.mem_cons, hxy]
+
+/-- A path whose executed nodes do not assign `x` preserves its binding. -/
+lemma Path.preserves_unwritten {g : Graph} {a b : Configuration g} (p : Path g a b)
+    {x : String} (hn : ∀ d ∈ p.steps, ∀ rhs, g.nodes d ≠ some (.assign x rhs)) :
+    ∀ v, Env.Mem (x, v) a.2 ↔ Env.Mem (x, v) b.2 := by
+  induction p with
+  | nil => exact fun _ => Iff.rfl
+  | cons st p ih =>
+      have ht := ih (fun d hm => hn d (List.mem_append_right _ hm))
+      suffices hs : ∀ v, Env.Mem (x, v) _ ↔ Env.Mem (x, v) _ from
+        fun v => (hs v).trans (ht v)
+      cases st with
+      | edge => exact fun _ => Iff.rfl
+      | execute h =>
+          apply optional_preserves_unwritten h x
+          intro rhs hc
+          exact hn _ (List.mem_append_left _ (by simp [Step.steps, hc])) rhs hc
+
+lemma Step.steps_embed {g h : Graph} (e : Embed g h) {a b : Configuration g}
+    (s : Step g a b) :
+    (s.embed e).steps = s.steps.map e.f := by
+  cases s with
+  | edge => rfl
+  | @execute i ρ σ h =>
+      simp only [Step.embed, Step.steps, e.nodes_eq]
+      cases g.nodes i <;> rfl
+
+lemma Path.steps_embed {g h : Graph} (e : Embed g h) {a b : Configuration g}
+    (p : Path g a b) :
+    (p.embed e).steps = p.steps.map e.f := by
+  induction p <;> aesop (add simp [Path.embed, Path.steps, Step.steps_embed])
+
+/-- Every nonempty node in a loop belongs to its body. -/
+lemma GGraph.loop_node_in_body {g : Graph} {i : (Graph.loop g).Index} {bs : BasicStmt}
+    (hc : (Graph.loop g).nodes i = some bs) : ∃ j, (Embed.loop g).f j = i := by
+  refine Fin.addCases ?_ ?_ i hc
+  · intro j hj
+    simp [Graph.loop, Fin.append_left] at hj
+  · intro j _; exact ⟨j, rfl⟩
+
+/-- Variables at any CFG statement occur in its source statement. -/
+lemma Stmt.cfg_node_vars {s : Stmt} {i : s.cfg.Index} {bs : BasicStmt}
+    (hc : s.cfg.nodes i = some bs) : bs.vars ⊆ s.vars := by
+  induction s with
+  | basic b =>
+      have : b = bs := Option.some.inj hc
+      subst bs; exact Finset.Subset.refl _
+  | andThen a b iha ihb =>
+      refine Fin.addCases ?_ ?_ i hc
+      · intro j hj; have hv := iha (by simpa [Stmt.cfg, Graph.sequence] using hj)
+        exact fun x hx => Finset.mem_union_left _ (hv hx)
+      · intro j hj; have hv := ihb (by simpa [Stmt.cfg, Graph.sequence] using hj)
+        exact fun x hx => Finset.mem_union_right _ (hv hx)
+  | ifElse cond a b iha ihb =>
+      refine Fin.addCases ?_ ?_ i hc
+      · intro j hj; have hv := iha (by simpa [Stmt.cfg, Graph.overlay] using hj)
+        exact fun x hx => Finset.mem_union_left _ (Finset.mem_union_right _ (hv hx))
+      · intro j hj; have hv := ihb (by simpa [Stmt.cfg, Graph.overlay] using hj)
+        exact fun x hx => Finset.mem_union_right _ (hv hx)
+  | whileLoop cond body ih =>
+      obtain ⟨j, rfl⟩ := GGraph.loop_node_in_body hc
+      have hv := ih (((Embed.loop body.cfg).nodes_eq j).symm.trans hc)
+      exact fun x hx => Finset.mem_union_right _ (hv hx)
+
+lemma Program.code_vars {prog : Program} {i : prog.State} {bs : BasicStmt}
+    (hc : prog.code i = some bs) : ∀ x ∈ bs.vars, x ∈ prog.vars := by
+  have hroot : ∃ j, prog.rootStmt.cfg.nodes j = some bs := by
+    unfold Program.code Program.cfg Graph.wrap at hc
+    revert hc
+    refine Fin.addCases ?_ ?_ i
+    · intro j hj; simp [Graph.sequence, Graph.singleton] at hj
+    · intro j
+      refine Fin.addCases ?_ ?_ j
+      · intro k hk
+        exact ⟨k, by simpa [Graph.sequence] using hk⟩
+      · intro k hk; simp [Graph.sequence, Graph.singleton] at hk
+  obtain ⟨j, hj⟩ := hroot
+  intro x hx
+  simpa [Program.vars] using Stmt.cfg_node_vars hj hx
+
+end Spa

lean/Spa/Language/Traces.lean

@@ -1,38 +1,263 @@
-/-
-Port of `Language/Traces.agda`.
-
-Correspondence:
-  Trace          ↦ Trace (a `Prop`-valued inductive; only used in proofs)
-  _++⟨_⟩_        ↦ Trace.concat
-  EndToEndTrace  ↦ EndToEndTrace (a `Prop`-valued structure, like `∃`; its
-                   fields are accessed by destructuring inside proofs)
--/
-import Spa.Language.Semantics
 import Spa.Language.Graphs
+import Spa.Language.Program
+import Spa.Language.Semantics
+
+/-!
+
+# Program Traces
+
+This module defines program traces tied to Control Flow Graphs, or CFGs
+(see `Spa.GGraph` and `Spa.Graph`). These traces boil down to sequences of
+basic-block executions (really, `Spa.BasicStmt` executions), each of which must
+have an actual basic block in the graph _and_ be connected to the previous
+basic block by an edge. In this way, traces encode executions admitted
+by the CFG.
+
+`Path` interleaves execution and edge steps, with endpoints recording whether
+we are before or after a node. `Trace`, `Traceₗ`, and `Traceᵣ` are endpoint
+specializations of this one type. An `EndToEndTrace` runs from a graph input
+to a graph output, denoting full program execution.
+
+Properties about graphs and language semantics (especially,
+the fact that the graph contains the proper basic block and edges
+to represent any program execution according to the
+language's big-step semantics `EvalStmt`) is found
+in `Spa/Language/Properties.lean`.
+
+-/
 
 namespace Spa
 
-/-- Agda: `Trace`. -/
+/-- A node together with the phase of its execution. -/
-inductive Trace (g : Graph) : g.Index → g.Index → Env → Env → Prop
+inductive Position (α : Type) where
-  | single {ρ₁ ρ₂ : Env} {idx : g.Index} :
+  | before : α → Position α
-      EvalBasicStmts ρ₁ (g.nodes idx) ρ₂ → Trace g idx idx ρ₁ ρ₂
+  | after : α → Position α
-  | edge {ρ₁ ρ₂ ρ₃ : Env} {idx₁ idx₂ idx₃ : g.Index} :
+  deriving DecidableEq
-      EvalBasicStmts ρ₁ (g.nodes idx₁) ρ₂ → (idx₁, idx₂) ∈ g.edges →
-      Trace g idx₂ idx₃ ρ₂ ρ₃ → Trace g idx₁ idx₃ ρ₁ ρ₃
 
-/-- Agda: `_++⟨_⟩_`. -/
+abbrev Configuration (g : Graph) := Position g.Index × Env
-theorem Trace.concat {g : Graph} {idx₁ idx₂ idx₃ idx₄ : g.Index}
-    {ρ₁ ρ₂ ρ₃ : Env} (tr₁ : Trace g idx₁ idx₂ ρ₁ ρ₂)
-    (he : (idx₂, idx₃) ∈ g.edges) (tr₂ : Trace g idx₃ idx₄ ρ₂ ρ₃) :
-    Trace g idx₁ idx₄ ρ₁ ρ₃ := by
-  induction tr₁ with
-  | single hbs => exact Trace.edge hbs he tr₂
-  | edge hbs he' _ ih => exact Trace.edge hbs he' (ih he tr₂)
 
-/-- Agda: `EndToEndTrace` (an existential package, destructured in proofs). -/
+/-- Executing a node changes the environment; following an edge preserves it. -/
-inductive EndToEndTrace (g : Graph) (ρ₁ ρ₂ : Env) : Prop
+inductive Step (g : Graph) : Configuration g → Configuration g → Type where
-  | intro (idx₁ : g.Index) (idx₁_mem : idx₁ ∈ g.inputs)
+  | execute {i : g.Index} {ρ ρ' : Env}
-      (idx₂ : g.Index) (idx₂_mem : idx₂ ∈ g.outputs)
+      (h : EvalBasicStmtOpt ρ (g.nodes i) ρ') :
-      (trace : Trace g idx₁ idx₂ ρ₁ ρ₂) : EndToEndTrace g ρ₁ ρ₂
+      Step g (.before i, ρ) (.after i, ρ')
+  | edge {i j : g.Index} {ρ : Env} (h : (i, j) ∈ g.edges) :
+      Step g (.after i, ρ) (.before j, ρ)
+
+/-- A concrete CFG path, including executions of statement-less nodes. -/
+inductive Path (g : Graph) : Configuration g → Configuration g → Type where
+  | nil {a} : Path g a a
+  | cons {a b c} : Step g a b → Path g b c → Path g a c
+
+namespace Path
+
+variable {g : Graph} {a b c d : Configuration g}
+
+@[match_pattern] def single (s : Step g a b) : Path g a b := .cons s .nil
+
+def append {a b c : Configuration g} : Path g a b → Path g b c → Path g a c
+  | .nil, q => q
+  | .cons s p, q => .cons s (p.append q)
+
+instance : HAppend (Path g a b) (Path g b c) (Path g a c) := ⟨append⟩
+
+@[simp] lemma nil_append (p : Path g a b) : Path.nil.append p = p := rfl
+
+@[simp] lemma append_nil (p : Path g a b) : p.append Path.nil = p := by
+  induction p <;> aesop (add simp append)
+
+lemma append_assoc (p : Path g a b) (q : Path g b c) (r : Path g c d) :
+    (p.append q).append r = p.append (q.append r) := by
+  induction p <;> aesop (add simp append)
+
+end Path
+
+def GGraph.Embed.mapConfiguration {g h : Graph} (e : GGraph.Embed g h) :
+    Configuration g → Configuration h
+  | (.before i, ρ) => (.before (e.f i), ρ)
+  | (.after i, ρ) => (.after (e.f i), ρ)
+
+lemma GGraph.Embed.mapConfiguration_trans {g h k : Graph}
+    (e : GGraph.Embed g h) (f : GGraph.Embed h k) (a : Configuration g) :
+    f.mapConfiguration (e.mapConfiguration a) = (e.trans f).mapConfiguration a := by
+  rcases a with ⟨_ | _, ρ⟩ <;> rfl
+
+noncomputable def Step.embed {g h : Graph} (e : GGraph.Embed g h)
+    {a b : Configuration g} : Step g a b → Step h (e.mapConfiguration a) (e.mapConfiguration b)
+  | .execute h => .execute (_root_.cast (congrArg (EvalBasicStmtOpt _ · _) (e.nodes_eq _).symm) h)
+  | .edge h => .edge (e.edges_mem h)
+
+noncomputable def Path.embed {g h : Graph} (e : GGraph.Embed g h)
+    {a b : Configuration g} : Path g a b → Path h (e.mapConfiguration a) (e.mapConfiguration b)
+  | .nil => .nil
+  | .cons s p => .cons (s.embed e) (p.embed e)
+
+lemma Path.embed_append {g h : Graph} (e : GGraph.Embed g h)
+    {a b c : Configuration g} (p : Path g a b) (q : Path g b c) :
+    (p.append q).embed e = (p.embed e).append (q.embed e) := by
+  induction p <;> aesop (add simp [append, embed])
+
+/-- Transport endpoints without changing the path. -/
+def Path.cast {g : Graph} {a b a' b' : Configuration g}
+    (ha : a = a') (hb : b = b') (p : Path g a b) : Path g a' b' := ha ▸ hb ▸ p
+
+lemma Path.embed_trans {g h k : Graph} (e : GGraph.Embed g h) (f : GGraph.Embed h k)
+    {a b : Configuration g} (p : Path g a b) :
+    ((p.embed e).embed f).cast (e.mapConfiguration_trans f a)
+      (e.mapConfiguration_trans f b) = p.embed (e.trans f) := by
+  induction p with
+  | @nil a => rcases a with ⟨_ | _, ρ⟩ <;> rfl
+  | @cons a b c s p ih =>
+    rcases c with ⟨_ | _, ρ⟩ <;> cases s <;>
+      aesop (add simp [embed, Step.embed, cast, GGraph.Embed.mapConfiguration, cast_cast])
+
+/-- A trace includes the executions of both endpoint nodes. -/
+abbrev Trace (g : Graph) (i j : g.Index) (ρ ρ' : Env) :=
+  Path g (.before i, ρ) (.after j, ρ')
+
+/-- A prefix ending before execution of its final node. -/
+abbrev Traceₗ (g : Graph) (i j : g.Index) (ρ ρ' : Env) :=
+  Path g (.before i, ρ) (.before j, ρ')
+
+/-- A suffix starting after execution of its initial node. -/
+abbrev Traceᵣ (g : Graph) (i j : g.Index) (ρ ρ' : Env) :=
+  Path g (.after i, ρ) (.after j, ρ')
+
+/-- Compatibility patterns for an execution and an execution-edge pair. -/
+@[match_pattern] abbrev Trace.single {g : Graph} {ρ₁ ρ₂ : Env} {idx : g.Index}
+    (h : EvalBasicStmtOpt ρ₁ (g.nodes idx) ρ₂) : Trace g idx idx ρ₁ ρ₂ :=
+  .cons (.execute h) .nil
+
+@[match_pattern] abbrev Trace.edge {g : Graph} {ρ₁ ρ₂ ρ₃ : Env}
+    {idx₁ idx₂ idx₃ : g.Index} (h : EvalBasicStmtOpt ρ₁ (g.nodes idx₁) ρ₂)
+    (he : (idx₁, idx₂) ∈ g.edges) (p : Trace g idx₂ idx₃ ρ₂ ρ₃) :
+    Trace g idx₁ idx₃ ρ₁ ρ₃ := Path.cons (.execute h) (.cons (.edge he) p)
+
+@[match_pattern] abbrev Traceₗ.nil {g : Graph} {idx : g.Index} {ρ : Env} :
+    Traceₗ g idx idx ρ ρ := Path.nil
+
+@[match_pattern] abbrev Traceₗ.cons {g : Graph} {ρ₁ ρ₂ ρ₃ : Env}
+    {idx₁ idx₂ idx₃ : g.Index} (h : EvalBasicStmtOpt ρ₁ (g.nodes idx₁) ρ₂)
+    (he : (idx₁, idx₂) ∈ g.edges) (p : Traceₗ g idx₂ idx₃ ρ₂ ρ₃) :
+    Traceₗ g idx₁ idx₃ ρ₁ ρ₃ := Path.cons (.execute h) (.cons (.edge he) p)
+
+@[match_pattern] abbrev Traceᵣ.nil {g : Graph} {idx : g.Index} {ρ : Env} : Traceᵣ g idx idx ρ ρ := Path.nil
+
+abbrev Traceᵣ.cons {g : Graph} {ρ₁ ρ₂ ρ₃ : Env} {idx₁ idx₂ idx₃ : g.Index}
+    (p : Traceᵣ g idx₁ idx₂ ρ₁ ρ₂) (he : (idx₂, idx₃) ∈ g.edges)
+    (h : EvalBasicStmtOpt ρ₂ (g.nodes idx₃) ρ₃) : Traceᵣ g idx₁ idx₃ ρ₁ ρ₃ :=
+  p.append (.cons (.edge he) (.single (.execute h)))
+
+abbrev Traceₗ.single (g : Graph) (idx : g.Index) (ρ : Env) : Traceₗ g idx idx ρ ρ := .nil
+abbrev Traceᵣ.single (g : Graph) (idx : g.Index) (ρ : Env) : Traceᵣ g idx idx ρ ρ := .nil
+
+abbrev Trace.concat {g : Graph} {idx₁ idx₂ idx₃ idx₄ : g.Index} {ρ₁ ρ₂ ρ₃ : Env}
+    (p : Trace g idx₁ idx₂ ρ₁ ρ₂) (he : (idx₂, idx₃) ∈ g.edges)
+    (q : Trace g idx₃ idx₄ ρ₂ ρ₃) : Trace g idx₁ idx₄ ρ₁ ρ₃ :=
+  (p.append (.single (.edge he))).append q
+
+scoped notation:65 tr₁:66 " ++< " he " >++ " tr₂:65 => Trace.concat tr₁ he tr₂
+
+abbrev Trace.addEdge {g : Graph} {idx₁ idx₂ idx₃ : g.Index} {ρ₁ ρ₂ : Env}
+    (p : Trace g idx₁ idx₂ ρ₁ ρ₂) (he : (idx₂, idx₃) ∈ g.edges) :
+    Traceₗ g idx₁ idx₃ ρ₁ ρ₂ := p.append (.single (.edge he))
+
+abbrev Traceₗ.append {g : Graph} {i j k : g.Index} {ρ₁ ρ₂ ρ₃ : Env}
+    (p : Traceₗ g i j ρ₁ ρ₂) (q : Traceₗ g j k ρ₂ ρ₃) : Traceₗ g i k ρ₁ ρ₃ :=
+  Path.append p q
+
+abbrev Traceₗ.appendTrace {g : Graph} {i j k : g.Index} {ρ₁ ρ₂ ρ₃ : Env}
+    (p : Traceₗ g i j ρ₁ ρ₂) (q : Trace g j k ρ₂ ρ₃) : Trace g i k ρ₁ ρ₃ :=
+  Path.append p q
+
+abbrev Trace.appendRight {g : Graph} {i j k : g.Index} {ρ₁ ρ₂ ρ₃ : Env}
+    (p : Trace g i j ρ₁ ρ₂) (q : Traceᵣ g j k ρ₂ ρ₃) : Trace g i k ρ₁ ρ₃ :=
+  Path.append p q
+
+noncomputable abbrev Trace.embed {g h : Graph} (e : GGraph.Embed g h)
+    {i j : g.Index} {ρ₁ ρ₂ : Env} (p : Trace g i j ρ₁ ρ₂) :
+    Trace h (e.f i) (e.f j) ρ₁ ρ₂ := Path.embed e p
+
+abbrev Traceₗ.appendStep {g : Graph} {idx₁ idx₂ : g.Index} {ρ₁ ρ₂ ρ₃ : Env}
+    (p : Traceₗ g idx₁ idx₂ ρ₁ ρ₂) (h : EvalBasicStmtOpt ρ₂ (g.nodes idx₂) ρ₃) :
+    Trace g idx₁ idx₂ ρ₁ ρ₃ := Path.append p (.single (.execute h))
+
+instance {g : Graph} {idx₁ idx₂ : g.Index} {ρ₁ ρ₂ ρ₃ : Env} :
+    HAppend (Traceₗ g idx₁ idx₂ ρ₁ ρ₂) (EvalBasicStmtOpt ρ₂ (g.nodes idx₂) ρ₃)
+      (Trace g idx₁ idx₂ ρ₁ ρ₃) := ⟨Traceₗ.appendStep⟩
+
+/-- The nonempty node executed by this step; edges and empty nodes are omitted. -/
+def Step.steps {g : Graph} {a b : Configuration g} : Step g a b → List g.Index
+  | .execute (i := i) _ =>
+      match g.nodes i with
+      | none => []
+      | some _ => [i]
+  | .edge _ => []
+
+/-- Executed nodes in chronological order; edges and empty nodes contribute nothing.
+The instruction at each node is given by `g.nodes`, rather than copied into the history. -/
+def Path.steps {g : Graph} {a b : Configuration g} : Path g a b → List g.Index
+  | .nil => []
+  | .cons s p => s.steps ++ p.steps
+
+abbrev Trace.steps {g : Graph} {i j : g.Index} {ρ₁ ρ₂ : Env}
+    (p : Trace g i j ρ₁ ρ₂) : List g.Index := Path.steps p
+abbrev Traceₗ.steps {g : Graph} {i j : g.Index} {ρ₁ ρ₂ : Env}
+    (p : Traceₗ g i j ρ₁ ρ₂) : List g.Index := Path.steps p
+abbrev Traceᵣ.steps {g : Graph} {i j : g.Index} {ρ₁ ρ₂ : Env}
+    (p : Traceᵣ g i j ρ₁ ρ₂) : List g.Index := Path.steps p
+
+@[simp] lemma Path.steps_append {g : Graph} {a b c : Configuration g}
+    (p : Path g a b) (q : Path g b c) :
+    (p.append q).steps = p.steps ++ q.steps := by
+  induction p <;> aesop (add simp [append, steps, List.append_assoc])
+
+@[simp] lemma Traceₗ.steps_appendStep {g : Graph} {idx₁ idx₂ : g.Index}
+    {ρ₁ ρ₂ ρ₃ : Env} (tr : Traceₗ g idx₁ idx₂ ρ₁ ρ₂)
+    (hbs : EvalBasicStmtOpt ρ₂ (g.nodes idx₂) ρ₃) :
+    (tr ++ hbs).steps = tr.steps ++ (Step.execute hbs).steps := by
+  change Path.steps (Path.append tr (Path.single (.execute hbs))) = _
+  aesop (add simp [Trace.steps, Traceₗ.steps, Path.single, Path.steps, Step.steps])
+
+@[simp] lemma Trace.steps_addEdge {g : Graph} {idx₁ idx₂ idx₃ : g.Index}
+    {ρ₁ ρ₂ : Env} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) (he : (idx₂, idx₃) ∈ g.edges) :
+    (tr.addEdge he).steps = tr.steps := by
+  change Path.steps (Path.append tr (Path.single (.edge he))) = _
+  aesop (add simp [Trace.steps, Traceₗ.steps, Path.single, Path.steps, Step.steps])
+
+/-- A beginning-to-end trace corresponding to the CFG `g`. -/
+structure EndToEndTrace (g : Graph) (ρ₁ ρ₂ : Env) : Type where
+  intro ::
+  entry : g.Index
+  entry_mem : entry ∈ g.inputs
+  exit : g.Index
+  exit_mem : exit ∈ g.outputs
+  trace : Trace g entry exit ρ₁ ρ₂
+
+/-- Every trace splits into the prefix arriving at its last node and that node's execution. -/
+def Trace.split {g : Graph} {i₁ i₂ : g.Index} {ρ₁ ρ₂ : Env} :
+    Trace g i₁ i₂ ρ₁ ρ₂ → Σ ρ, Traceₗ g i₁ i₂ ρ₁ ρ × EvalBasicStmtOpt ρ (g.nodes i₂) ρ₂
+  | Trace.single h => ⟨_, .nil, h⟩
+  | Trace.edge h he rest =>
+      let ⟨ρ, pre, step⟩ := rest.split
+      ⟨ρ, Traceₗ.cons h he pre, step⟩
+
+@[simp] lemma Trace.split_append {g : Graph} {i₁ i₂ : g.Index} {ρ₁ ρ₂ : Env}
+    (tr : Trace g i₁ i₂ ρ₁ ρ₂) : tr.split.2.1 ++ tr.split.2.2 = tr := by
+  match tr with
+  | Trace.single h => rw [Trace.split.eq_1]; rfl
+  | Trace.edge h he rest =>
+      have ih := Trace.split_append rest
+      rw [Trace.split.eq_2]
+      aesop (add simp [HAppend.hAppend, Traceₗ.appendStep, Path.append])
+
+structure Reaches {prog : Program} (s : prog.State) (ρin ρout : Env) : Type where
+  pre : Traceₗ prog.cfg prog.initialState s [] ρin
+  step : EvalBasicStmtOpt ρin (prog.code s) ρout
+
+/-- Forget the environment before the last evaluated state. -/
+def Reaches.post {prog : Program} {s : prog.State} {ρin ρout : Env}
+    (r : Reaches s ρin ρout) : Trace prog.cfg prog.initialState s [] ρout :=
+  r.pre ++ r.step
 
 end Spa

lean/Spa/Lattice.lean

@@ -1,8 +1,32 @@
 import Mathlib.Order.Lattice
 import Mathlib.Order.RelSeries
 
+/-!
+
+# Lattice Definitions
+
+This file provides some definitions for lattices. It used to be more critical
+when this was an Agda project, since it defined (semi)lattices, the ordering
+relation, etc. However, these have been lifted into `Mathlib.Order.Lattice`
+etc.. What remains are a couple of theorems about folds, as well
+as `FiniteHeightLattice`, the core concept of lattice-based static
+program analyses. See the documentation on that class for more information. -/
+
+namespace Option
+
+/-- Equality-sensitive eliminator for options in which the `some` case
+    is sensitive to the base `β`. This makes it mirror a one-element fold
+    more closely. -/
+def elimEq {α : Type*} {β : Sort*} :
+    (o : Option α) → β → ((a : α) → o = some a → β → β) → β
+  | none, b, _ => b
+  | some a, b, f => f a rfl b
+
+end Option
+
 namespace Spa
 
+/-- Predicate for binary functions independently monotone in both their arguments. -/
 def Monotone₂ {α β γ : Type*} [Preorder α] [Preorder β] [Preorder γ]
     (f : α → β → γ) : Prop :=
   (∀ b, Monotone (f · b)) ∧ (∀ a, Monotone (f a ·))
@@ -11,18 +35,20 @@ section Folds
 
 variable {α β : Type*} [Preorder α] [Preorder β]
 
-theorem foldr_mono {l₁ l₂ : List α} (f : α → β → β) {b₁ b₂ : β}
+/-- (right) folds are monotonic in both their arguments if the underlying accumulator function is. -/
+lemma foldr_mono {l₁ l₂ : List α} (f : α → β → β) {b₁ b₂ : β}
     (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
-    (hf₁ : ∀ b, Monotone fun a => f a b) (hf₂ : ∀ a, Monotone (f a)) :
+    (hf₁ : ∀ b, Monotone (f · b)) (hf₂ : ∀ a, Monotone (f a ·)) :
     l₁.foldr f b₁ ≤ l₂.foldr f b₂ := by
   induction hl with
   | nil => exact hb
   | cons hxy _ ih =>
     exact le_trans (hf₁ _ hxy) (hf₂ _ ih)
 
-theorem foldl_mono {l₁ l₂ : List α} (f : β → α → β) {b₁ b₂ : β}
+/-- (left) folds are monotinic in both their arguments if the underlying accumulator function is. -/
+lemma foldl_mono {l₁ l₂ : List α} (f : β → α → β) {b₁ b₂ : β}
     (hl : List.Forall₂ (· ≤ ·) l₁ l₂) (hb : b₁ ≤ b₂)
-    (hf₁ : ∀ a, Monotone fun b => f b a) (hf₂ : ∀ b, Monotone (f b)) :
+    (hf₁ : ∀ a, Monotone (f · a)) (hf₂ : ∀ b, Monotone (f b ·)) :
     l₁.foldl f b₁ ≤ l₂.foldl f b₂ := by
   induction hl generalizing b₁ b₂ with
   | nil => exact hb
@@ -30,61 +56,96 @@ theorem foldl_mono {l₁ l₂ : List α} (f : β → α → β) {b₁ b₂ : β}
     exact ih (le_trans (hf₁ _ hb) (hf₂ _ hxy))
 
 omit [Preorder α] in
-theorem foldr_mono' (l : List α) (f : α → β → β)
+/-- (right) folds on a particular list are monotonic if the underlying accumulator is monotonic in its accumulator argument. -/
-    (hf : ∀ a, Monotone (f a ·)) : Monotone fun b => l.foldr f b := by
+lemma foldr_mono' (l : List α) (f : α → β → β)
+    (hf : ∀ a, Monotone (f a ·)) : Monotone (l.foldr f ·) := by
   intro b₁ b₂ hb
   induction l with
   | nil => exact hb
   | cons x xs ih => exact hf x ih
 
 omit [Preorder α] in
-theorem foldl_mono' (l : List α) (f : β → α → β)
+/-- (left) folds on a particular list are monotonic if the underlying accumulator is monotonic in its accumulator argument. -/
+lemma foldl_mono' (l : List α) (f : β → α → β)
     (hf : ∀ a, Monotone (f · a)) : Monotone fun b => l.foldl f b := by
   intro b₁ b₂ hb
   induction l generalizing b₁ b₂ with
   | nil => exact hb
   | cons x xs ih => exact ih (hf x hb)
 
+omit [Preorder α] in
+/-- The equality-aware eliminator (that also alters its behavior dependent on base case)
+    for option is monotonic. -/
+lemma elimEq_self_mono (o : Option α) (g : (a : α) → o = some a → β → β)
+    (hg : ∀ a h, Monotone (g a h)) :
+    Monotone (o.elimEq · g) := by
+  cases o with
+  | none => exact monotone_id
+  | some a => exact hg a rfl
+
 end Folds
 
+/-- Predicate on types with `Preorder` that claims all $<$ chains in the type have at most `n` comparisons. -/
 def BoundedChains (α : Type*) [Preorder α] (n : ℕ) : Prop :=
   ∀ c : LTSeries α, c.length ≤ n
 
-structure PointedLTSeries (α : Type*) (f t : α)(n : ℕ) [Preorder α] where
+/-- Since a singleton type's preorder has no nonempty `<` chains,
-  series : LTSeries α
+    they are vacuously bounded by any minimum height. -/
-  head_series : series.head = f
+lemma boundedChains_of_subsingleton (α : Type*) [Preorder α] [Subsingleton α]
-  last_series : series.last = t
+    (n : ℕ) : BoundedChains α n := fun c => by
-  length_series : series.length = n
+  by_contra hc
+  push_neg at hc
+  exact (c.step ⟨0, by omega⟩).ne (Subsingleton.elim _ _)
 
-class FiniteHeightLattice (α : Type*) [Lattice α] extends Bot α, Top α where
+/-- A finite height lattice is a lattice in which all chains $a < \ldots < z$ have a maximum height `height`. -/
+class FiniteHeightLattice (α : Type*) extends Lattice α, OrderBot α, OrderTop α where
   height : ℕ
-  longest_chain : PointedLTSeries α ⊥ ⊤ height
   chains_bounded : BoundedChains α height
 
-namespace FixedHeight
+-- a < ... < z
-
+-- ----------- length <= height
-variable {α : Type*} [Lattice α] {h : ℕ}
-
-theorem bot_le [FiniteHeightLattice α] : ∀ (a : α), ⊥ ≤ a := by
-  intro a
-  by_cases heq : ⊥ ⊓ a = ⊥
-  · exact inf_eq_left.mp heq
-  · exfalso
-    have lc := FiniteHeightLattice.longest_chain (α := α)
-    have hlt : ⊥ ⊓ a < lc.series.head := by
-      rw [lc.head_series]
-      exact lt_of_le_of_ne inf_le_left heq
-    have hbound := FiniteHeightLattice.chains_bounded (lc.series.cons (⊥ ⊓ a) hlt)
-    rw [RelSeries.cons_length, lc.length_series] at hbound
-    omega
-
-end FixedHeight
 
 namespace FiniteHeightLattice
 
-variable (α : Type*) [Lattice α] [FiniteHeightLattice α]
+/-- This is something like a lemma about isomorphic types having the same height.
+    Given a finite-height lattice `α`, lattice `β`, and a `Monotone` bijection
+    between the two, we can show that lattice `β` also has a finite height.
 
-theorem bot_le (a : α) : (⊥ : α) ≤ a := FixedHeight.bot_le a
+    The proof is fairly trivial: any chain in `β` can be transported to a chain in `α`,
+    and must be bounded by the same height by `FiniteHeightLattice.chains_bounded`. -/
+def transport {α β : Type*} [Lattice β]
+    [I : FiniteHeightLattice α] (f : α → β) (g : β → α)
+    (hf : Monotone f) (hg : Monotone g)
+    (hfg : Function.LeftInverse f g) :
+    FiniteHeightLattice β where
+  toLattice := inferInstance
+  toOrderBot := {
+    bot := f (⊥ : α)
+    bot_le := fun b => by
+      rw [← hfg b]
+      exact hf (_root_.bot_le : (⊥ : α) ≤ g b) }
+  toOrderTop := {
+    top := f (⊤ : α)
+    le_top := fun b => by
+      rw [← hfg b]
+      exact hf (_root_.le_top : g b ≤ (⊤ : α)) }
+  height := I.height
+  chains_bounded := fun c =>
+    I.chains_bounded (c.map g (hg.strictMono_of_injective hfg.injective))
+
+/-- A `Unique` lattice trivially has finite height: its only chain is the singleton
+    `[default]`, and there are no nontrivial `<` chains in a subsingleton. -/
+def ofUnique (α : Type*) [Lattice α] [Unique α] :
+    FiniteHeightLattice α where
+  toLattice := inferInstance
+  toOrderBot := {
+    bot := default
+    bot_le := fun _ => le_of_eq (Subsingleton.elim _ _) }
+  toOrderTop := {
+    top := default
+    le_top := fun _ => le_of_eq (Subsingleton.elim _ _) }
+  height := 0
+  chains_bounded := boundedChains_of_subsingleton α 0
 
 end FiniteHeightLattice
 

lean/Spa/Lattice/AboveBelow.lean

@@ -1,25 +1,38 @@
-/-
-Port of `Lattice/AboveBelow.agda`: the flat lattice obtained by adjoining a
-top and bottom element to an (unordered, decidable-equality) type.
-
-With propositional equality the `_≈_` data type and its equivalence/decidability
-proofs disappear (`deriving DecidableEq`). The lattice itself cannot be lifted:
-mathlib has no "flat lattice on a discrete type". The `Lattice` instance is
-built with `Lattice.mk'`, which — exactly like the Agda module — consumes the
-two semilattices (comm/assoc, idempotence derived) plus the absorption laws,
-and defines `a ≤ b ↔ a ⊔ b = b` (Agda's `_≼_`).
-
-The Agda module's `Plain x` submodule (the witness `x` seeds the longest chain
-`⊥ ≺ [x] ≺ ⊤`) becomes `plainFixedHeight x`; the boundedness proof `isLongest`
-is restated through a rank function since chains are mathlib `LTSeries` rather
-than a pattern-matchable inductive (the `¬-Chain-⊤`-style case analysis lives
-in `rank_strictMono`).
--/
 import Spa.Lattice
 
+/-!
+
+# The Above-Below Lattice
+
+This file defines the `AboveBelow` lattice, which takes a flat domain
+$a_1, \ldots, a_n \in \alpha$ and lifts it into a lattice bounded
+above by a synthetic $\top$ element, and below by a synthetic $\bot$
+element.
+
+$$
+\begin{array}{ccccc}
+  && \top && \\
+  & \swarrow & \downarrow & \searrow & \\
+  a_1 & & … & & a_n \\
+  & \searrow & \downarrow & \swarrow & \\
+  && \bot &&
+\end{array}
+$$
+
+This lattice is also a `Spa.FiniteHeightLattice`, because no chain can
+exceed the bottom-to-top chain $\bot < a_i < \top$.
+
+The above-below lattice is helpful for for analyses such as
+`Spa/Analysis/Sign.lean` and `Spa/Analysis/Constant.lean`, whose
+classifications of values (by sign or by exact value) do not have
+any inherent structure beyond "matching exactly".
+
+-/
+
 namespace Spa
 
-/-- Agda: `AboveBelow` with constructors `⊥`, `⊤`, `[_]`. -/
+/-- The above-below lattice, with bottom element `bot` and top element `top`. -/
+@[aesop safe cases]
 inductive AboveBelow (α : Type*) where
   | bot
   | top
@@ -28,7 +41,6 @@ inductive AboveBelow (α : Type*) where
 
 namespace AboveBelow
 
-/-- Agda: the `Showable` instance. -/
 instance {α : Type*} [ToString α] : ToString (AboveBelow α) where
   toString
     | bot => "⊥"
@@ -53,234 +65,125 @@ instance : Min (AboveBelow α) where
     | mk _, bot => bot
     | mk x, top => mk x
 
-/-! Agda: `⊥⊔x≡x`, `⊤⊔x≡⊤`, `x⊔⊥≡x`, `x⊔⊤≡⊤`, and the `[x]⊔[y]` reductions
+@[simp] lemma bot_sup (x : AboveBelow α) : bot ⊔ x = x := rfl
-(`x≈y⇒[x]⊔[y]≡[x]` / `x̷≈y⇒[x]⊔[y]≡⊤` are the two branches of `mk_sup_mk`). -/
+@[simp] lemma top_sup (x : AboveBelow α) : top ⊔ x = top := rfl
-
+@[simp] lemma sup_bot (x : AboveBelow α) : x ⊔ bot = x := by cases x <;> rfl
-@[simp] theorem bot_sup (x : AboveBelow α) : bot ⊔ x = x := rfl
+@[simp] lemma sup_top (x : AboveBelow α) : x ⊔ top = top := by cases x <;> rfl
-@[simp] theorem top_sup (x : AboveBelow α) : top ⊔ x = top := rfl
+@[simp] lemma mk_sup_mk (x y : α) :
-@[simp] theorem sup_bot (x : AboveBelow α) : x ⊔ bot = x := by cases x <;> rfl
-@[simp] theorem sup_top (x : AboveBelow α) : x ⊔ top = top := by cases x <;> rfl
-@[simp] theorem mk_sup_mk (x y : α) :
     (mk x ⊔ mk y : AboveBelow α) = if x = y then mk x else top := rfl
 
-@[simp] theorem bot_inf (x : AboveBelow α) : bot ⊓ x = bot := rfl
+@[simp] lemma bot_inf (x : AboveBelow α) : bot ⊓ x = bot := rfl
-@[simp] theorem top_inf (x : AboveBelow α) : top ⊓ x = x := rfl
+@[simp] lemma top_inf (x : AboveBelow α) : top ⊓ x = x := rfl
-@[simp] theorem inf_bot (x : AboveBelow α) : x ⊓ bot = bot := by cases x <;> rfl
+@[simp] lemma inf_bot (x : AboveBelow α) : x ⊓ bot = bot := by cases x <;> rfl
-@[simp] theorem inf_top (x : AboveBelow α) : x ⊓ top = x := by cases x <;> rfl
+@[simp] lemma inf_top (x : AboveBelow α) : x ⊓ top = x := by cases x <;> rfl
-@[simp] theorem mk_inf_mk (x y : α) :
+@[simp] lemma mk_inf_mk (x y : α) :
     (mk x ⊓ mk y : AboveBelow α) = if x = y then mk x else bot := rfl
 
-/-- Agda: `⊔-comm`. -/
+protected lemma sup_comm (a b : AboveBelow α) : a ⊔ b = b ⊔ a := by aesop
-protected theorem sup_comm (a b : AboveBelow α) : a ⊔ b = b ⊔ a := by
+protected lemma sup_assoc (a b c : AboveBelow α) : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) := by aesop
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp only
+protected lemma inf_comm (a b : AboveBelow α) : a ⊓ b = b ⊓ a := by aesop
-    [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk]
+protected lemma inf_assoc (a b c : AboveBelow α) : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) := by aesop
-  split_ifs with h₁ h₂ h₂ <;> simp_all
+protected lemma sup_inf_self (a b : AboveBelow α) : a ⊔ a ⊓ b = a := by aesop
+protected lemma inf_sup_self (a b : AboveBelow α) : a ⊓ (a ⊔ b) = a := by aesop
 
-/-- Agda: `⊔-assoc`. -/
-protected theorem sup_assoc (a b c : AboveBelow α) : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;>
-    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk]
-  split_ifs <;> simp_all
-
-/-- Agda: `⊓-comm`. -/
-protected theorem inf_comm (a b : AboveBelow α) : a ⊓ b = b ⊓ a := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp only
-    [bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk]
-  split_ifs with h₁ h₂ h₂ <;> simp_all
-
-/-- Agda: `⊓-assoc`. -/
-protected theorem inf_assoc (a b c : AboveBelow α) : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> rcases c with _ | _ | z <;>
-    simp only [bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk]
-  split_ifs <;> simp_all
-
-/-- Agda: `absorb-⊔-⊓`. -/
-protected theorem sup_inf_self (a b : AboveBelow α) : a ⊔ a ⊓ b = a := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
-    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk,
-               bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk] <;>
-    try (split_ifs <;> simp_all)
-
-/-- Agda: `absorb-⊓-⊔`. -/
-protected theorem inf_sup_self (a b : AboveBelow α) : a ⊓ (a ⊔ b) = a := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
-    simp only [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk,
-               bot_inf, inf_bot, top_inf, inf_top, mk_inf_mk] <;>
-    try (split_ifs <;> simp_all)
-
-/-- Agda: `isLattice` (via the two semilattices + absorption, like the Agda
-record; `Lattice.mk'` derives idempotence and sets `a ≤ b ↔ a ⊔ b = b`). -/
 instance : Lattice (AboveBelow α) :=
   Lattice.mk' AboveBelow.sup_comm AboveBelow.sup_assoc
     AboveBelow.inf_comm AboveBelow.inf_assoc
     AboveBelow.sup_inf_self AboveBelow.inf_sup_self
 
-theorem le_iff {a b : AboveBelow α} : a ≤ b ↔ a ⊔ b = b := sup_eq_right.symm
+lemma le_iff {a b : AboveBelow α} : a ≤ b ↔ a ⊔ b = b := sup_eq_right.symm
 
-/-- Agda: `⊥≺[x]` (the `≤` part; `⊥` is least). -/
+lemma bot_le' (a : AboveBelow α) : (bot : AboveBelow α) ≤ a :=
-theorem bot_le' (a : AboveBelow α) : (bot : AboveBelow α) ≤ a :=
   le_iff.mpr (bot_sup a)
 
-/-- Agda: `[x]≺⊤` (the `≤` part; `⊤` is greatest). -/
+lemma le_top' (a : AboveBelow α) : a ≤ (top : AboveBelow α) :=
-theorem le_top' (a : AboveBelow α) : a ≤ (top : AboveBelow α) :=
   le_iff.mpr (sup_top a)
 
-theorem bot_lt_mk (x : α) : (bot : AboveBelow α) < mk x :=
+instance : OrderBot (AboveBelow α) where
-  lt_of_le_of_ne (bot_le' _) (by simp)
+  bot := bot
+  bot_le := bot_le'
 
-theorem mk_lt_top (x : α) : (mk x : AboveBelow α) < top :=
+instance : OrderTop (AboveBelow α) where
-  lt_of_le_of_ne (le_top' _) (by simp)
+  top := top
+  le_top := le_top'
 
-theorem bot_lt_top : (bot : AboveBelow α) < top :=
+lemma bot_lt_mk (x : α) : (bot : AboveBelow α) < mk x := lt_of_le_of_ne (bot_le' _) (by simp)
-  lt_of_le_of_ne (bot_le' _) (by simp)
+lemma mk_lt_top (x : α) : (mk x : AboveBelow α) < top := lt_of_le_of_ne (le_top' _) (by simp)
+lemma bot_lt_top : (bot : AboveBelow α) < top := lt_of_le_of_ne (bot_le' _) (by simp)
 
-/-- The order of the flat lattice, by cases (used to discharge the
+lemma le_cases {a b : AboveBelow α} (h : a ≤ b) :
-monotonicity obligations that were `postulate`d in `Analysis/Sign.agda` and
-`Analysis/Constant.agda`). -/
-theorem le_cases {a b : AboveBelow α} (h : a ≤ b) :
     a = bot ∨ b = top ∨ a = b := by
-  have hsup := le_iff.mp h
+  rw [le_iff] at h
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp_all
-  · exact Or.inl rfl
-  · exact Or.inr (Or.inl rfl)
-  · exact Or.inl rfl
-  · exact absurd hsup (by simp)
-  · exact Or.inr (Or.inl rfl)
-  · exact absurd hsup (by simp)
-  · exact absurd hsup (by simp)
-  · exact Or.inr (Or.inl rfl)
-  · rw [mk_sup_mk] at hsup
-    by_cases hxy : x = y
-    · exact Or.inr (Or.inr (by rw [hxy]))
-    · rw [if_neg hxy] at hsup
-      exact absurd hsup (by simp)
 
-/-- Monotonicity for *strict* operations on flat lattices: if `f` sends `⊥` to
+/-- If `f` sends `⊥` to `⊥` (in both arguments) and `⊤` to `⊤`
-`⊥` (in either argument) and `⊤` to `⊤` (against any non-`⊥` argument), it is
+    (against any non-`⊥` argument), it is monotone in both arguments.
-monotone in both arguments — regardless of its values on plain elements.
+    The values of the the elements in `α` are irrelevant since they
-`Analysis/Sign.agda` and `Analysis/Constant.agda` postulated exactly these
+    are always incomparable. This makes it easy to prove monotonicity
-monotonicity facts for their `plus`/`minus`, all of which have this shape. -/
+    for operations that "just" combine their flat elements, or give up. -/
-theorem monotone₂_of_strict {β γ : Type*} [DecidableEq β] [DecidableEq γ]
+lemma 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
+  constructor <;> intro c a b hab <;>
-  · intro y a b hab
+    rcases eq_or_ne c bot with rfl | hc <;>
-    show f a y ≤ f b y
+    rcases le_cases hab with rfl | rfl | rfl <;>
-    rcases le_cases hab with rfl | rfl | rfl
+    simp [hbotl, hbotr, htopl, htopr, bot_le', le_top', *]
-    · 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
-    show f x a ≤ f x b
-    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. -/
+/-- As long as the interpretation of a the above-below lattice respects the
-theorem interp_sup_of (hbot : ∀ v, ¬P bot v) (htop : ∀ v, P top v)
+    fact that `bot` means "impossible", interpreting the above-below
-    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by
+    lattice agrees with its `⊔`. -/
-  rcases s₁ with _ | _ | x
+lemma interp_sup_of (hbot : ∀ v, ¬P bot v) (htop : ∀ v, P top v)
-  · rw [bot_sup]; exact h.resolve_left (hbot v)
+    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by aesop
-  · 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. -/
+/-- As long as two distinct values in the flat domain don't overlap,
-theorem interp_inf_of
+    interpreting the above-below lattice agrees with its `⊔` -/
+lemma 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
+  rcases s₁ with _ | _ | x <;> rcases s₂ with _ | _ | y <;> simp_all
-  · 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
+  · exact h.2
-      · next hne => exact absurd h (hdisj hne v)
+  · next hne => exact (hdisj hne v h.1 h.2).elim
 
 end Interp
 
-/-- Rank of an element: `⊥ ↦ 0`, `[x] ↦ 1`, `⊤ ↦ 2`. Used to bound chains
+/-- synthetic rank of an element, used to prove chain bounds. -/
-(Agda's `isLongest` / `x≺[y]⇒x≡⊥` / `[x]≺y⇒y≡⊤` case analysis lives here). -/
+private def rank : AboveBelow α → ℕ
-def rank : AboveBelow α → ℕ
   | bot => 0
   | mk _ => 1
   | top => 2
 
-/-- Agda: the impossibility of `[x] ≺ [y]` (combines `x≺[y]⇒x≡⊥` and
+/-- It's not possible for any two lifted flat-domain elements to be less
-`[x]≺y⇒y≡⊤`: the flat middle layer is an antichain). -/
+    than one another. -/
-theorem not_mk_lt_mk (x y : α) : ¬(mk x : AboveBelow α) < mk y := by
+lemma not_mk_lt_mk (x y : α) : ¬(mk x : AboveBelow α) < mk y := by
   intro h
   obtain ⟨hle, hne⟩ := lt_iff_le_and_ne.mp h
-  have hsup := le_iff.mp hle
+  rcases le_cases hle with h | h | h <;> simp_all
-  rw [mk_sup_mk] at hsup
-  by_cases hxy : x = y
-  · rw [if_pos hxy] at hsup
-    exact hne hsup
-  · rw [if_neg hxy] at hsup
-    exact absurd hsup (by simp)
 
-theorem rank_strictMono : StrictMono (rank : AboveBelow α → ℕ) := by
+/-- The rank of elements is strictly monotonic. -/
+lemma rank_strictMono : StrictMono (rank : AboveBelow α → ℕ) := by
   intro a b hab
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
-  · exact absurd hab (lt_irrefl _)
+    simp_all [rank, not_mk_lt_mk, (bot_le' _).not_lt, (le_top' _).not_lt]
-  · simp [rank]
-  · simp [rank]
-  · exact absurd hab (bot_le' _).not_lt
-  · exact absurd hab (lt_irrefl _)
-  · exact absurd hab (le_top' _).not_lt
-  · exact absurd hab (bot_le' _).not_lt
-  · simp [rank]
-  · exact absurd hab (not_mk_lt_mk x y)
 
-/-- Agda: `isLongest` — no chain is longer than 2. -/
+/-- All chains in the above-below lattice have at most 2 comparisons. -/
-theorem boundedChains : BoundedChains (AboveBelow α) 2 := fun c => by
+lemma boundedChains : BoundedChains (AboveBelow α) 2 := fun c => by
   have h := LTSeries.head_add_length_le_nat (c.map rank rank_strictMono)
   rw [LTSeries.head_map, LTSeries.last_map, LTSeries.map_length] at h
   have h2 : rank c.last ≤ 2 := by cases c.last <;> simp [rank]
   omega
 
-/-- Agda: `Plain.longestChain`/`Plain.fixedHeight` and
-`Plain.isFiniteHeightLattice`/`Plain.finiteHeightLattice` — the witness
-(`default`, playing the role of the Agda module parameter `x`) seeds the chain
-`⊥ ≺ [x] ≺ ⊤` of length 2. -/
 instance [Inhabited α] : FiniteHeightLattice (AboveBelow α) where
-  bot := bot
+  toLattice := inferInstance
-  top := top
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
   height := 2
-  longest_chain :=
-    { series :=
-        ((RelSeries.singleton _ bot).snoc (mk default)
-            (by rw [RelSeries.last_singleton]; exact bot_lt_mk default)).snoc top
-          (by rw [RelSeries.last_snoc]; exact mk_lt_top default)
-      head_series := by simp
-      last_series := by simp
-      length_series := by simp [RelSeries.snoc, RelSeries.append] }
   chains_bounded := boundedChains
 
 end AboveBelow

lean/Spa/Lattice/Bool.lean

@@ -0,0 +1,39 @@
+import Spa.Lattice
+import Mathlib.Order.BooleanAlgebra
+
+namespace Spa
+
+/-! ### `Bool` as a finite-height lattice
+
+`Bool` is the two-element lattice `false ≤ true` (with `⊥ = false`, `⊤ = true`).
+It is the building block of the "power set" lattice `FiniteMap A Bool ks`, used by
+the reaching-definitions analysis to represent sets of definition sites. -/
+
+namespace Bool
+
+/-- Rank of a boolean: `false ↦ 0`, `true ↦ 1`. Used to bound chains, mirroring
+`AboveBelow.rank`. -/
+def rank : Bool → ℕ
+  | false => 0
+  | true => 1
+
+lemma rank_strictMono : StrictMono rank := by
+  intro a b hab
+  cases a <;> cases b <;> revert hab <;> decide
+
+lemma boundedChains : BoundedChains Bool 1 := fun c => by
+  have h := LTSeries.head_add_length_le_nat (c.map rank rank_strictMono)
+  rw [LTSeries.head_map, LTSeries.last_map, LTSeries.map_length] at h
+  have h2 : rank c.last ≤ 1 := by cases c.last <;> simp [rank]
+  omega
+
+instance : FiniteHeightLattice Bool where
+  toLattice := inferInstance
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
+  height := 1
+  chains_bounded := boundedChains
+
+end Bool
+
+end Spa

lean/Spa/Lattice/FiniteMap.lean

@@ -1,425 +1,207 @@
-import Spa.Lattice.IterProd
+import Spa.Lattice.Tuple
-import Spa.Isomorphism
+import Mathlib.Data.List.Nodup
+
+/-!
+
+# Finite Maps
+
+This file defines _finite maps_, or key-value maps with a finite domain. This
+is encoded as a map from `Fin` into the value type. Finite maps form a
+lattice from pointwise composition: $(f \land g) k = f k \land g k$,
+and, provided the domain `\beta` is of finite height, so is the map
+lattice as a whole.
+
+In fact, the isomorphism is described and proven in `Spa/Lattice/Tuple.lean`.
+
+-/
 
 namespace Spa
 
-def FiniteMap (A B : Type*) (ks : List A) : Type _ :=
+/-- Key-value map with domain `α` and codomain `β`, with possible keys $\textit{ks} \subseteq \alpha$. -/
-  { l : List (A × B) // l.map Prod.fst = ks }
+def FiniteMap (α β : Type*) (ks : List α) : Type _ := Fin ks.length → β
 
 namespace FiniteMap
 
-variable {A B : Type*} {ks : List A}
+variable {α β : Type*} {ks : List α}
 
-instance [DecidableEq A] [DecidableEq B] : DecidableEq (FiniteMap A B ks) :=
+instance [Lattice β] : Lattice (FiniteMap α β ks) :=
-  fun a b => decidable_of_iff (a.val = b.val) Subtype.ext_iff.symm
+  inferInstanceAs (Lattice (Fin ks.length → β))
 
-theorem spine_eq (fm₁ fm₂ : FiniteMap A B ks) :
+instance [FiniteHeightLattice β] : FiniteHeightLattice (FiniteMap α β ks) :=
-    fm₁.val.map Prod.fst = fm₂.val.map Prod.fst :=
+  inferInstanceAs (FiniteHeightLattice (Fin ks.length → β))
-  fm₁.property.trans fm₂.property.symm
 
-def combine (f : B → B → B) (l₁ l₂ : List (A × B)) : List (A × B) :=
+instance [DecidableEq β] : DecidableEq (FiniteMap α β ks) :=
-  List.zipWith (fun p q => (p.1, f p.2 q.2)) l₁ l₂
+  inferInstanceAs (DecidableEq (Fin ks.length → β))
 
-theorem combine_spine (f : B → B → B) : ∀ {l₁ l₂ : List (A × B)},
+instance : Membership (α × β) (FiniteMap α β ks) :=
-    l₁.map Prod.fst = l₂.map Prod.fst →
+  ⟨fun fm p => ∃ i : Fin ks.length, ks.get i = p.1 ∧ fm i = p.2⟩
-    (combine f l₁ l₂).map Prod.fst = l₁.map Prod.fst
-  | [], [], _ => rfl
-  | p :: l₁, q :: l₂, h => by
-    simp only [List.map_cons, List.cons.injEq] at h
-    simp only [combine, List.zipWith_cons_cons, List.map_cons]
-    exact congrArg _ (combine_spine f h.2)
-  | [], _ :: _, h => by simp at h
-  | _ :: _, [], h => by simp at h
 
-theorem combine_comm (f : B → B → B) (hf : ∀ a b, f a b = f b a) :
+lemma mem_iff {fm : FiniteMap α β ks} {p : α × β} :
-    ∀ {l₁ l₂ : List (A × B)}, l₁.map Prod.fst = l₂.map Prod.fst →
+    p ∈ fm ↔ ∃ i : Fin ks.length, ks.get i = p.1 ∧ fm i = p.2 := Iff.rfl
-      combine f l₁ l₂ = combine f l₂ l₁
-  | [], [], _ => rfl
-  | p :: l₁, q :: l₂, h => by
-    simp only [List.map_cons, List.cons.injEq] at h
-    simp only [combine, List.zipWith_cons_cons]
-    rw [h.1, hf]
-    exact congrArg _ (combine_comm f hf h.2)
-  | [], _ :: _, h => by simp at h
-  | _ :: _, [], h => by simp at h
 
-theorem combine_assoc (f : B → B → B) (hf : ∀ a b c, f (f a b) c = f a (f b c)) :
+def MemKey (k : α) (_fm : FiniteMap α β ks) : Prop := k ∈ ks
-    ∀ {l₁ l₂ l₃ : List (A × B)},
-      l₁.map Prod.fst = l₂.map Prod.fst → l₂.map Prod.fst = l₃.map Prod.fst →
-      combine f (combine f l₁ l₂) l₃ = combine f l₁ (combine f l₂ l₃)
-  | [], [], [], _, _ => rfl
-  | p :: l₁, q :: l₂, r :: l₃, h₁₂, h₂₃ => by
-    simp only [List.map_cons, List.cons.injEq] at h₁₂ h₂₃
-    simp only [combine, List.zipWith_cons_cons]
-    rw [hf]
-    exact congrArg _ (combine_assoc f hf h₁₂.2 h₂₃.2)
-  | [], [], _ :: _, _, h => by simp at h
-  | [], _ :: _, _, h, _ => by simp at h
-  | _ :: _, [], _, h, _ => by simp at h
-  | _ :: _, _ :: _, [], _, h => by simp at h
 
-theorem combine_absorb (f g : B → B → B) (hfg : ∀ a b, f a (g a b) = a) :
+lemma MemKey_iff {k : α} {fm : FiniteMap α β ks} : MemKey k fm ↔ k ∈ ks := Iff.rfl
-    ∀ {l₁ l₂ : List (A × B)}, l₁.map Prod.fst = l₂.map Prod.fst →
-      combine f l₁ (combine g l₁ l₂) = l₁
-  | [], [], _ => rfl
-  | p :: l₁, q :: l₂, h => by
-    simp only [List.map_cons, List.cons.injEq] at h
-    simp only [combine, List.zipWith_cons_cons, hfg]
-    exact congrArg _ (combine_absorb f g hfg h.2)
-  | [], _ :: _, h => by simp at h
-  | _ :: _, [], h => by simp at h
 
-variable [Lattice B]
+instance {k : α} {fm : FiniteMap α β ks} [DecidableEq α] : Decidable (MemKey k fm) :=
+  decidable_of_iff _ MemKey_iff.symm
 
-instance : Max (FiniteMap A B ks) where
+lemma mem_key_of_mem {k : α} {v : β} {fm : FiniteMap α β ks}
-  max fm₁ fm₂ :=
+    (h : (k, v) ∈ fm) : MemKey k fm := by
-    ⟨combine (· ⊔ ·) fm₁.val fm₂.val,
+  obtain ⟨i, hi, _⟩ := h
-     (combine_spine _ (spine_eq fm₁ fm₂)).trans fm₁.property⟩
+  have hik : ks.get i = k := hi
+  exact hik ▸ ks.get_mem i
 
-instance : Min (FiniteMap A B ks) where
+def toList (fm : FiniteMap α β ks) : List (α × β) :=
-  min fm₁ fm₂ :=
+  (List.finRange ks.length).map fun i => (ks.get i, fm i)
-    ⟨combine (· ⊓ ·) fm₁.val fm₂.val,
-     (combine_spine _ (spine_eq fm₁ fm₂)).trans fm₁.property⟩
 
-@[simp] theorem sup_val (fm₁ fm₂ : FiniteMap A B ks) :
+lemma le_def [Lattice β] {fm₁ fm₂ : FiniteMap α β ks} :
-    (fm₁ ⊔ fm₂).val = combine (· ⊔ ·) fm₁.val fm₂.val := rfl
+    fm₁ ≤ fm₂ ↔ ∀ i, fm₁ i ≤ fm₂ i := Iff.rfl
-
-@[simp] theorem inf_val (fm₁ fm₂ : FiniteMap A B ks) :
-    (fm₁ ⊓ fm₂).val = combine (· ⊓ ·) fm₁.val fm₂.val := rfl
-
-instance : Lattice (FiniteMap A B ks) :=
-  Lattice.mk'
-    (fun a b => Subtype.ext (combine_comm _ sup_comm (spine_eq a b)))
-    (fun a b c => Subtype.ext (combine_assoc _ sup_assoc (spine_eq a b) (spine_eq b c)))
-    (fun a b => Subtype.ext (combine_comm _ inf_comm (spine_eq a b)))
-    (fun a b c => Subtype.ext (combine_assoc _ inf_assoc (spine_eq a b) (spine_eq b c)))
-    (fun a b => Subtype.ext (combine_absorb _ _ (fun _ _ => sup_inf_self) (spine_eq a b)))
-    (fun a b => Subtype.ext (combine_absorb _ _ (fun _ _ => inf_sup_self) (spine_eq a b)))
-
-instance : Membership (A × B) (FiniteMap A B ks) :=
-  ⟨fun fm p => p ∈ fm.val⟩
-
-omit [Lattice B] in
-theorem mem_def {p : A × B} {fm : FiniteMap A B ks} : p ∈ fm ↔ p ∈ fm.val :=
-  Iff.rfl
-
-def MemKey (k : A) (fm : FiniteMap A B ks) : Prop :=
-  k ∈ fm.val.map Prod.fst
-
-omit [Lattice B] in
-theorem memKey_iff {k : A} {fm : FiniteMap A B ks} : MemKey k fm ↔ k ∈ ks := by
-  rw [MemKey, fm.property]
-
-instance {k : A} {fm : FiniteMap A B ks} [DecidableEq A] :
-    Decidable (MemKey k fm) :=
-  decidable_of_iff _ memKey_iff.symm
-
-omit [Lattice B] in
-theorem mem_key_of_mem {k : A} {v : B} {fm : FiniteMap A B ks}
-    (h : (k, v) ∈ fm) : MemKey k fm :=
-  List.mem_map_of_mem _ h
 
 section Locate
 
-variable [DecidableEq A]
+variable [DecidableEq α]
 
-private def locateList (k : A) :
+/-- Recover the value stored under a present key. -/
-    (l : List (A × B)) → k ∈ l.map Prod.fst → {v : B // (k, v) ∈ l}
+def locate {k : α} {fm : FiniteMap α β ks} (h : MemKey k fm) :
-  | [], h => absurd h (by simp)
+    {v : β // (k, v) ∈ fm} :=
-  | p :: l', h =>
+  let i : Fin ks.length := ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩
-    if heq : p.1 = k then
+  ⟨fm i, i, List.idxOf_get _, rfl⟩
-      ⟨p.2, by rw [← heq]; exact List.mem_cons_self ..⟩
-    else
-      let ⟨v, hv⟩ := locateList k l' (by
-        rcases List.mem_cons.mp h with h' | h'
-        · exact absurd h'.symm heq
-        · exact h')
-      ⟨v, List.mem_cons_of_mem _ hv⟩
-
-def locate {k : A} {fm : FiniteMap A B ks} (h : MemKey k fm) :
-    {v : B // (k, v) ∈ fm} :=
-  locateList k fm.val h
 
 end Locate
 
-theorem combine_eq_right_iff : ∀ {l₁ l₂ : List (A × B)},
+variable [Lattice β]
-    l₁.map Prod.fst = l₂.map Prod.fst →
-    (combine (· ⊔ ·) l₁ l₂ = l₂ ↔
-      List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂)
-  | [], [], _ => by simp [combine]
-  | p :: l₁, q :: l₂, h => by
-    simp only [List.map_cons, List.cons.injEq] at h
-    simp only [combine, List.zipWith_cons_cons, List.cons.injEq,
-               List.forall₂_cons, Prod.ext_iff]
-    rw [show List.zipWith (fun p q : A × B => (p.1, p.2 ⊔ q.2)) l₁ l₂
-          = combine (· ⊔ ·) l₁ l₂ from rfl,
-        combine_eq_right_iff h.2]
-    constructor
-    · rintro ⟨⟨hk, hv⟩, hrest⟩
-      exact ⟨⟨hk, sup_eq_right.mp hv⟩, hrest⟩
-    · rintro ⟨⟨hk, hv⟩, hrest⟩
-      exact ⟨⟨hk, sup_eq_right.mpr hv⟩, hrest⟩
-  | [], _ :: _, h => by simp at h
-  | _ :: _, [], h => by simp at h
 
-theorem le_iff {fm₁ fm₂ : FiniteMap A B ks} :
+lemma le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap α β ks}
-    fm₁ ≤ fm₂ ↔
+    (hle : fm₁ ≤ fm₂) {k : α} {v₁ v₂ : β}
-      List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) fm₁.val fm₂.val := by
+    (h₁ : (k, v₁) ∈ fm₁) (h₂ : (k, v₂) ∈ fm₂) : v₁ ≤ v₂ := by
-  rw [← sup_eq_right, ← combine_eq_right_iff (spine_eq fm₁ fm₂), Subtype.ext_iff,
+  obtain ⟨i, hi, rfl⟩ := h₁
-      sup_val]
+  obtain ⟨j, hj, rfl⟩ := h₂
+  have hij : i = j := hks.get_inj_iff.mp (hi.trans hj.symm)
+  subst hij
+  exact le_def.mp hle i
 
-private theorem forall₂_spine : ∀ {l₁ l₂ : List (A × B)},
+lemma mem_sup {fm₁ fm₂ : FiniteMap α β ks} {k : α} {v : β}
-    List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂ →
-    l₁.map Prod.fst = l₂.map Prod.fst
-  | _, _, List.Forall₂.nil => rfl
-  | _, _, List.Forall₂.cons hpq hrest => by
-    simp [List.map_cons, hpq.1, forall₂_spine hrest]
-
-private theorem forall₂_mem_mem {l₁ l₂ : List (A × B)}
-    (hf : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) :
-    (l₁.map Prod.fst).Nodup →
-    ∀ {k : A} {v₁ v₂ : B}, (k, v₁) ∈ l₁ → (k, v₂) ∈ l₂ → v₁ ≤ v₂ := by
-  induction hf with
-  | nil =>
-    intro _ k v₁ v₂ h₁ _
-    simp at h₁
-  | @cons p q l₁' l₂' hpq hrest ih =>
-    intro hnd k v₁ v₂ h₁ h₂
-    simp only [List.map_cons, List.nodup_cons] at hnd
-    have hspine := forall₂_spine hrest
-    rcases List.mem_cons.mp h₁ with heq₁ | h₁'
-    · rcases List.mem_cons.mp h₂ with heq₂ | h₂'
-      · rw [← heq₁, ← heq₂] at hpq
-        exact hpq.2
-      · exfalso
-        apply hnd.1
-        rw [show p.1 = k from (congrArg Prod.fst heq₁).symm, hspine]
-        exact List.mem_map_of_mem _ h₂'
-    · rcases List.mem_cons.mp h₂ with heq₂ | h₂'
-      · exfalso
-        apply hnd.1
-        rw [hpq.1, show q.1 = k from (congrArg Prod.fst heq₂).symm]
-        exact List.mem_map_of_mem _ h₁'
-      · exact ih hnd.2 h₁' h₂'
-
-theorem le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap A B ks}
-    (hle : fm₁ ≤ fm₂) {k : A} {v₁ v₂ : B}
-    (h₁ : (k, v₁) ∈ fm₁) (h₂ : (k, v₂) ∈ fm₂) : v₁ ≤ v₂ :=
-  forall₂_mem_mem (le_iff.mp hle) (fm₁.property.symm ▸ hks) h₁ h₂
-
-omit [Lattice B] in
-private theorem mem_combine (f : B → B → B) : ∀ {l₁ l₂ : List (A × B)} {k : A} {v : B},
-    l₁.map Prod.fst = l₂.map Prod.fst →
-    (k, v) ∈ combine f l₁ l₂ →
-    ∃ v₁ v₂, v = f v₁ v₂ ∧ (k, v₁) ∈ l₁ ∧ (k, v₂) ∈ l₂
-  | [], [], _, _, _, h => by simp [combine] at h
-  | p :: l₁, q :: l₂, k, v, hsp, h => by
-    simp only [List.map_cons, List.cons.injEq] at hsp
-    simp only [combine, List.zipWith_cons_cons] at h
-    rcases List.mem_cons.mp h with heq | h'
-    · injection heq with hk hv
-      exact ⟨p.2, q.2, hv,
-        by rw [hk]; simp,
-        by rw [hk, hsp.1]; simp⟩
-    · obtain ⟨v₁, v₂, hv, h₁, h₂⟩ := mem_combine f hsp.2 h'
-      exact ⟨v₁, v₂, hv, List.mem_cons_of_mem _ h₁, List.mem_cons_of_mem _ h₂⟩
-
-theorem mem_sup {fm₁ fm₂ : FiniteMap A B ks} {k : A} {v : B}
     (h : (k, v) ∈ fm₁ ⊔ fm₂) :
-    ∃ v₁ v₂, v = v₁ ⊔ v₂ ∧ (k, v₁) ∈ fm₁ ∧ (k, v₂) ∈ fm₂ :=
+    ∃ v₁ v₂, v = v₁ ⊔ v₂ ∧ (k, v₁) ∈ fm₁ ∧ (k, v₂) ∈ fm₂ := by
-  mem_combine _ (spine_eq fm₁ fm₂) h
+  obtain ⟨i, hi, rfl⟩ := h
+  exact ⟨fm₁ i, fm₂ i, rfl, ⟨i, hi, rfl⟩, ⟨i, hi, rfl⟩⟩
+
+lemma mem_inf {fm₁ fm₂ : FiniteMap α β ks} {k : α} {v : β}
+    (h : (k, v) ∈ fm₁ ⊓ fm₂) :
+    ∃ v₁ v₂, v = v₁ ⊓ v₂ ∧ (k, v₁) ∈ fm₁ ∧ (k, v₂) ∈ fm₂ := by
+  obtain ⟨i, hi, rfl⟩ := h
+  exact ⟨fm₁ i, fm₂ i, rfl, ⟨i, hi, rfl⟩, ⟨i, hi, rfl⟩⟩
 
 section Updating
 
-variable [DecidableEq A]
+variable [DecidableEq α]
 
-def updating (fm : FiniteMap A B ks) (ks' : List A) (g : A → B) :
+def updating (fm : FiniteMap α β ks) (ks' : List α) (g : α → β) : FiniteMap α β ks :=
-    FiniteMap A B ks :=
+  fun i => if ks.get i ∈ ks' then g (ks.get i) else fm i
-  ⟨fm.val.map (fun p => if p.1 ∈ ks' then (p.1, g p.1) else p), by
-    rw [List.map_map,
-        show (Prod.fst ∘ fun p : A × B => if p.1 ∈ ks' then (p.1, g p.1) else p)
-          = Prod.fst from funext fun p => by by_cases h : p.1 ∈ ks' <;> simp [h]]
-    exact fm.property⟩
 
-omit [Lattice B] in
+omit [Lattice β] in
-@[simp] theorem updating_val (fm : FiniteMap A B ks) (ks' : List A) (g : A → B) :
+lemma eq_of_mem_updating {k : α} {v : β} {fm : FiniteMap α β ks}
-    (updating fm ks' g).val
+    {ks' : List α} {g : α → β} (hk : k ∈ ks')
-      = fm.val.map (fun p => if p.1 ∈ ks' then (p.1, g p.1) else p) := rfl
-
-omit [Lattice B] in
-theorem memKey_updating {k : A} {fm : FiniteMap A B ks} {ks' : List A} {g : A → B} :
-    MemKey k (updating fm ks' g) ↔ MemKey k fm := by
-  rw [memKey_iff, memKey_iff]
-
-omit [Lattice B] in
-theorem eq_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
-    {ks' : List A} {g : A → B} (hk : k ∈ ks')
     (h : (k, v) ∈ updating fm ks' g) : v = g k := by
-  obtain ⟨p, hp, heq⟩ := List.mem_map.mp h
+  obtain ⟨i, hi, rfl⟩ := h
-  by_cases hmem : p.1 ∈ ks'
+  show (if ks.get i ∈ ks' then g (ks.get i) else fm i) = g k
-  · rw [if_pos hmem] at heq
+  rw [if_pos (by rw [hi]; exact hk), hi]
-    injection heq with h1 h2
-    rw [← h2, h1]
-  · rw [if_neg hmem] at heq
-    rw [heq] at hmem
-    exact absurd hk hmem
 
-omit [Lattice B] in
+omit [Lattice β] in
-theorem mem_updating {k : A} {fm : FiniteMap A B ks} {ks' : List A} {g : A → B}
+lemma mem_of_mem_updating {k : α} {v : β} {fm : FiniteMap α β ks}
-    (hk : k ∈ ks') (hmem : MemKey k fm) : (k, g k) ∈ updating fm ks' g := by
+    {ks' : List α} {g : α → β} (hk : k ∉ ks')
-  obtain ⟨v, hv⟩ := locate hmem
-  exact List.mem_map.mpr ⟨(k, v), hv, by simp [hk]⟩
-
-omit [Lattice B] in
-theorem mem_updating_of_not_mem {k : A} {v : B} {fm : FiniteMap A B ks}
-    {ks' : List A} {g : A → B} (hk : k ∉ ks') (h : (k, v) ∈ fm) :
-    (k, v) ∈ updating fm ks' g :=
-  List.mem_map.mpr ⟨(k, v), h, by simp [hk]⟩
-
-omit [Lattice B] in
-theorem mem_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
-    {ks' : List A} {g : A → B} (hk : k ∉ ks')
     (h : (k, v) ∈ updating fm ks' g) : (k, v) ∈ fm := by
-  obtain ⟨p, hp, heq⟩ := List.mem_map.mp h
+  obtain ⟨i, hi, rfl⟩ := h
-  by_cases hmem : p.1 ∈ ks'
+  refine ⟨i, hi, ?_⟩
-  · rw [if_pos hmem] at heq
+  show fm i = (if ks.get i ∈ ks' then g (ks.get i) else fm i)
-    injection heq with h1 _
+  rw [if_neg (by rw [hi]; exact hk)]
-    rw [← h1] at hk
-    exact absurd hmem hk
-  · rw [if_neg hmem] at heq
-    exact heq ▸ hp
 
-private theorem updating_mono_list {ks' : List A} {g₁ g₂ : A → B}
+lemma updating_mono {fm₁ fm₂ : FiniteMap α β ks} {ks' : List α}
-    (hg : ∀ k, g₁ k ≤ g₂ k) {l₁ l₂ : List (A × B)}
+    {g₁ g₂ : α → β} (hfm : fm₁ ≤ fm₂) (hg : ∀ k, g₁ k ≤ g₂ k) :
-    (hl : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) :
-    List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2)
-      (l₁.map fun p => if p.1 ∈ ks' then (p.1, g₁ p.1) else p)
-      (l₂.map fun p => if p.1 ∈ ks' then (p.1, g₂ p.1) else p) := by
-  induction hl with
-  | nil => exact List.Forall₂.nil
-  | @cons x y l₁' l₂' hpq hrest ih =>
-    simp only [List.map_cons]
-    refine List.Forall₂.cons ?_ ih
-    obtain ⟨hk, hv⟩ := hpq
-    by_cases h : x.1 ∈ ks'
-    · rw [if_pos h, if_pos (hk ▸ h)]
-      exact ⟨hk, hk ▸ hg x.1⟩
-    · rw [if_neg h, if_neg (fun hy => h (hk.symm ▸ hy))]
-      exact ⟨hk, hv⟩
-
-theorem updating_mono {fm₁ fm₂ : FiniteMap A B ks} {ks' : List A}
-    {g₁ g₂ : A → B} (hfm : fm₁ ≤ fm₂) (hg : ∀ k, g₁ k ≤ g₂ k) :
     updating fm₁ ks' g₁ ≤ updating fm₂ ks' g₂ := by
-  rw [le_iff] at hfm ⊢
+  rw [le_def]
-  simp only [updating_val]
+  intro i
-  exact updating_mono_list hg hfm
+  show (if ks.get i ∈ ks' then g₁ (ks.get i) else fm₁ i)
+     ≤ (if ks.get i ∈ ks' then g₂ (ks.get i) else fm₂ i)
+  split
+  · exact hg (ks.get i)
+  · exact le_def.mp hfm i
 
 end Updating
 
 section GeneralizedUpdate
 
-variable [DecidableEq A] {L : Type*} [Lattice L]
+variable [DecidableEq α] {L : Type*} [Lattice L]
 
-def generalizedUpdate (f : L → FiniteMap A B ks) (g : A → L → B)
+def generalizedUpdate (f : L → FiniteMap α β ks) (g : α → L → β)
-    (ks' : List A) (l : L) : FiniteMap A B ks :=
+    (ks' : List α) : L → FiniteMap α β ks := fun l =>
   (f l).updating ks' (fun k => g k l)
 
-variable {f : L → FiniteMap A B ks} {g : A → L → B} {ks' : List A}
+variable {f : L → FiniteMap α β ks} {g : α → L → β} {ks' : List α}
 
-theorem generalizedUpdate_monotone (hf : Monotone f)
+lemma generalizedUpdate_monotone (hf : Monotone f)
     (hg : ∀ k, Monotone (g k)) : Monotone (generalizedUpdate f g ks') :=
   fun _ _ hl => updating_mono (hf hl) (fun k => hg k hl)
 
-omit [Lattice B] [Lattice L] in
+omit [Lattice β] [Lattice L] in
-theorem generalizedUpdate_memKey {k : A} {l : L}
+lemma generalizedUpdate_mem_eq {k : α} {v : β} {l : L} (hk : k ∈ ks')
-    (h : MemKey k (f l)) : MemKey k (generalizedUpdate f g ks' l) := by
+    (h : (k, v) ∈ generalizedUpdate f g ks' l) : v = g k l :=
-  unfold generalizedUpdate
+  eq_of_mem_updating (g := fun k => g k l) hk h
-  exact memKey_updating.mpr h
 
-omit [Lattice B] [Lattice L] in
+omit [Lattice β] [Lattice L] in
-theorem generalizedUpdate_mem {k : A} {l : L} (hk : k ∈ ks')
+lemma generalizedUpdate_not_mem_backward {k : α} {v : β} {l : L} (hk : k ∉ ks')
-    (h : MemKey k (f l)) : (k, g k l) ∈ generalizedUpdate f g ks' l := by
+    (h : (k, v) ∈ generalizedUpdate f g ks' l) : (k, v) ∈ f l :=
-  unfold generalizedUpdate
+  mem_of_mem_updating hk h
-  exact mem_updating hk h
-
-omit [Lattice B] [Lattice L] in
-theorem generalizedUpdate_mem_eq {k : A} {v : B} {l : L} (hk : k ∈ ks')
-    (h : (k, v) ∈ generalizedUpdate f g ks' l) : v = g k l := by
-  unfold generalizedUpdate at h
-  exact eq_of_mem_updating (g := fun k => g k l) hk h
-
-omit [Lattice B] [Lattice L] in
-theorem generalizedUpdate_not_mem_forward {k : A} {v : B} {l : L} (hk : k ∉ ks')
-    (h : (k, v) ∈ f l) : (k, v) ∈ generalizedUpdate f g ks' l := by
-  unfold generalizedUpdate
-  exact mem_updating_of_not_mem hk h
-
-omit [Lattice B] [Lattice L] in
-theorem generalizedUpdate_not_mem_backward {k : A} {v : B} {l : L} (hk : k ∉ ks')
-    (h : (k, v) ∈ generalizedUpdate f g ks' l) : (k, v) ∈ f l := by
-  unfold generalizedUpdate at h
-  exact mem_of_mem_updating hk h
 
 end GeneralizedUpdate
 
 section ValuesAt
 
-variable [DecidableEq A]
+variable [DecidableEq α]
 
-private def lookup? (k : A) : List (A × B) → Option B
+/-- The value stored under `k`, if `k` is a key. -/
-  | [] => none
+private def lookup (fm : FiniteMap α β ks) (k : α) : Option β :=
-  | p :: l' => if p.1 = k then some p.2 else lookup? k l'
+  if h : k ∈ ks then some (fm ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none
 
-def valuesAt (fm : FiniteMap A B ks) (ks' : List A) : List B :=
+/-- The values stored under the keys `ks'` (skipping any that are not keys). -/
-  ks'.filterMap (fun k => lookup? k fm.val)
+def valuesAt (fm : FiniteMap α β ks) (ks' : List α) : List β :=
+  ks'.filterMap fm.lookup
 
-omit [Lattice B] in
+omit [Lattice β] in
-private theorem lookup?_eq_some_of_mem : ∀ {l : List (A × B)},
+lemma mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap α β ks} {k : α} {v : β}
-    (l.map Prod.fst).Nodup → ∀ {k : A} {v : B}, (k, v) ∈ l →
+    {ks' : List α} (hk : k ∈ ks') (h : (k, v) ∈ fm) : v ∈ valuesAt fm ks' := by
-    lookup? k l = some v
+  refine List.mem_filterMap.mpr ⟨k, hk, ?_⟩
-  | [], _, _, _, h => by simp at h
+  obtain ⟨i, hi, rfl⟩ := h
-  | p :: l', hnd, k, v, h => by
+  have hik : ks.get i = k := hi
-    simp only [List.map_cons, List.nodup_cons] at hnd
+  have hmem : k ∈ ks := hik ▸ ks.get_mem i
-    rcases List.mem_cons.mp h with heq | h'
+  show (if h : k ∈ ks then
-    · rw [← heq]
+          some (fm ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none) = some (fm i)
-      simp [lookup?]
+  rw [dif_pos hmem]
-    · rw [lookup?, if_neg ?_]
+  have : (⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr hmem⟩ : Fin ks.length) = i :=
-      · exact lookup?_eq_some_of_mem hnd.2 h'
+    hks.get_inj_iff.mp (by rw [List.idxOf_get, hi])
-      · intro hpk
+  rw [this]
-        subst hpk
-        have := List.mem_map_of_mem Prod.fst h'
-        exact hnd.1 this
 
-omit [Lattice B] in
+private lemma lookup_rel {fm₁ fm₂ : FiniteMap α β ks} (hle : fm₁ ≤ fm₂) (k : α) :
-theorem mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap A B ks} {k : A} {v : B}
+    Option.Rel (· ≤ ·) (fm₁.lookup k) (fm₂.lookup k) := by
-    {ks' : List A} (hk : k ∈ ks') (h : (k, v) ∈ fm) : v ∈ valuesAt fm ks' :=
+  show Option.Rel _
-  List.mem_filterMap.mpr
+    (if h : k ∈ ks then some (fm₁ ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none)
-    ⟨k, hk, lookup?_eq_some_of_mem (fm.property.symm ▸ hks) h⟩
+    (if h : k ∈ ks then some (fm₂ ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none)
+  by_cases hk : k ∈ ks
+  · rw [dif_pos hk, dif_pos hk]; exact Option.Rel.some (le_def.mp hle _)
+  · rw [dif_neg hk, dif_neg hk]; exact Option.Rel.none
 
-private theorem lookup?_forall₂ {l₁ l₂ : List (A × B)}
+lemma valuesAt_le {fm₁ fm₂ : FiniteMap α β ks} (hle : fm₁ ≤ fm₂)
-    (h : List.Forall₂ (fun p q : A × B => p.1 = q.1 ∧ p.2 ≤ q.2) l₁ l₂) (k : A) :
+    (ks' : List α) :
-    Option.Rel (· ≤ ·) (lookup? k l₁) (lookup? k l₂) := by
-  induction h with
-  | nil => exact Option.Rel.none
-  | @cons p q l₁ l₂ hpq hrest ih =>
-    rw [lookup?, lookup?]
-    by_cases hc : q.1 = k
-    · rw [if_pos hc, if_pos (hpq.1.trans hc)]
-      exact Option.Rel.some hpq.2
-    · rw [if_neg hc, if_neg (fun hp => hc (hpq.1 ▸ hp))]
-      exact ih
-
-theorem valuesAt_le {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂)
-    (ks' : List A) :
     List.Forall₂ (· ≤ ·) (valuesAt fm₁ ks') (valuesAt fm₂ ks') := by
   induction ks' with
   | nil => exact List.Forall₂.nil
   | cons k ks'' ih =>
-    have hrel := lookup?_forall₂ (le_iff.mp hle) k
+    have hrel := lookup_rel hle k
     rw [valuesAt, valuesAt, List.filterMap_cons, List.filterMap_cons]
     revert hrel
-    generalize lookup? k fm₁.val = o₁
+    generalize fm₁.lookup k = o₁
-    generalize lookup? k fm₂.val = o₂
+    generalize fm₂.lookup k = o₂
     intro hrel
     cases hrel with
     | none => simpa [valuesAt] using ih
@@ -427,120 +209,6 @@ theorem valuesAt_le {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂)
 
 end ValuesAt
 
-section Iso
-
-omit [Lattice B] in
-theorem val_ne_nil {k : A} {ks' : List A} (fm : FiniteMap A B (k :: ks')) :
-    fm.val ≠ [] := fun h => by
-  have hp := fm.property
-  rw [h] at hp
-  simp at hp
-
-def headVal {k : A} {ks' : List A} : FiniteMap A B (k :: ks') → B
-  | ⟨[], h⟩ => absurd h (by simp)
-  | ⟨p :: _, _⟩ => p.2
-
-def pop {k : A} {ks' : List A} : FiniteMap A B (k :: ks') → FiniteMap A B ks'
-  | ⟨[], h⟩ => absurd h (by simp)
-  | ⟨_ :: l, h⟩ =>
-    ⟨l, by simp only [List.map_cons, List.cons.injEq] at h; exact h.2⟩
-
-omit [Lattice B] in
-theorem val_eq_cons {k : A} {ks' : List A} :
-    ∀ fm : FiniteMap A B (k :: ks'), fm.val = (k, fm.headVal) :: fm.pop.val
-  | ⟨[], h⟩ => absurd h (by simp)
-  | ⟨p :: l, h⟩ => by
-    simp only [List.map_cons, List.cons.injEq] at h
-    simp [headVal, pop, ← h.1]
-
-def toIter : {ks : List A} → FiniteMap A B ks → IterProd B PUnit ks.length
-  | [], _ => PUnit.unit
-  | _ :: _, fm => (fm.headVal, toIter fm.pop)
-
-def ofIter : (ks : List A) → IterProd B PUnit ks.length → FiniteMap A B ks
-  | [], _ => ⟨[], rfl⟩
-  | k :: ks', ip =>
-    ⟨(k, ip.1) :: (ofIter ks' ip.2).val, by
-      simp [(ofIter ks' ip.2).property]⟩
-
-omit [Lattice B] in
-theorem ofIter_toIter : ∀ {ks : List A} (fm : FiniteMap A B ks),
-    ofIter ks (toIter fm) = fm
-  | [], fm => by
-    obtain ⟨val, hprop⟩ := fm
-    cases val with
-    | nil => rfl
-    | cons p l => exact absurd hprop (by simp)
-  | k :: ks', fm => Subtype.ext (by
-      show (k, fm.headVal) :: (ofIter ks' (toIter fm.pop)).val = fm.val
-      rw [ofIter_toIter fm.pop, ← val_eq_cons fm])
-
-omit [Lattice B] in
-theorem toIter_ofIter : ∀ (ks : List A) (ip : IterProd B PUnit ks.length),
-    toIter (ofIter ks ip) = ip
-  | [], _ => rfl
-  | k :: ks', ip => by
-    show (headVal (ofIter (k :: ks') ip), toIter (pop (ofIter (k :: ks') ip))) = ip
-    rw [show pop (ofIter (k :: ks') ip) = ofIter ks' ip.2 from rfl,
-        toIter_ofIter ks' ip.2]
-    rfl
-
-theorem headVal_le {k : A} {ks' : List A} {fm₁ fm₂ : FiniteMap A B (k :: ks')}
-    (h : fm₁ ≤ fm₂) : fm₁.headVal ≤ fm₂.headVal := by
-  have h' := le_iff.mp h
-  rw [val_eq_cons fm₁, val_eq_cons fm₂] at h'
-  exact (List.forall₂_cons.mp h').1.2
-
-theorem pop_le {k : A} {ks' : List A} {fm₁ fm₂ : FiniteMap A B (k :: ks')}
-    (h : fm₁ ≤ fm₂) : fm₁.pop ≤ fm₂.pop := by
-  rw [le_iff]
-  have h' := le_iff.mp h
-  rw [val_eq_cons fm₁, val_eq_cons fm₂] at h'
-  exact (List.forall₂_cons.mp h').2
-
-theorem toIter_monotone : ∀ {ks : List A},
-    Monotone (toIter : FiniteMap A B ks → IterProd B PUnit ks.length)
-  | [] => fun _ _ _ => le_refl _
-  | _ :: _ => fun _ _ h =>
-    Prod.mk_le_mk.mpr ⟨headVal_le h, toIter_monotone (pop_le h)⟩
-
-theorem ofIter_monotone : ∀ (ks : List A), Monotone (ofIter (A := A) (B := B) ks)
-  | [] => fun _ _ _ => le_refl _
-  | k :: ks' => fun ip₁ ip₂ h => by
-    rw [le_iff]
-    show List.Forall₂ _ ((k, ip₁.1) :: (ofIter ks' ip₁.2).val)
-                        ((k, ip₂.1) :: (ofIter ks' ip₂.2).val)
-    exact List.Forall₂.cons ⟨rfl, h.1⟩ (le_iff.mp (ofIter_monotone ks' h.2))
-
-def fixedHeight [FiniteHeightLattice B] (ks : List A) :
-    FiniteHeightLattice (FiniteMap A B ks) :=
-  FiniteHeightLattice.transport
-    (ofIter ks) toIter (ofIter_monotone ks) toIter_monotone
-    (toIter_ofIter ks) (fun fm => ofIter_toIter fm)
-
-instance [FiniteHeightLattice B] : FiniteHeightLattice (FiniteMap A B ks) :=
-  fixedHeight ks
-
-omit [Lattice B] in
-theorem mem_ofIter_build {b : B} : ∀ {ks : List A} {k : A} {v : B},
-    (k, v) ∈ ofIter ks (IterProd.build b PUnit.unit ks.length) → v = b
-  | [], _, _, h => by simp [ofIter, mem_def] at h
-  | k' :: ks', k, v, h => by
-    rcases List.mem_cons.mp h with heq | h'
-    · exact (Prod.ext_iff.mp heq).2
-    · exact mem_ofIter_build h'
-
-theorem bot_contains_bots [FiniteHeightLattice B] {k : A} {v : B}
-    (h : (k, v) ∈ (fixedHeight ks).bot) : v = (⊥ : B) := by
-  have hbot : (fixedHeight ks).bot
-      = ofIter ks (IterProd.build (⊥ : B) (⊥ : PUnit) ks.length) := by
-    show ofIter ks (IterProd.fixedHeight (A := B) (B := PUnit) ks.length).bot = _
-    rw [IterProd.bot_fixedHeight]
-  rw [hbot] at h
-  exact mem_ofIter_build h
-
-end Iso
-
 end FiniteMap
 
 end Spa

lean/Spa/Lattice/Finset.lean

@@ -0,0 +1,38 @@
+import Spa.Lattice
+import Mathlib.Data.Finset.Lattice.Basic
+import Mathlib.Data.Fintype.Lattice
+import Mathlib.Data.Fintype.Card
+
+/-! # Power Sets of Finite Type
+
+For a `Fintype α`, `Finset α` is the power-set lattice: `⊔` is union, `⊓` is
+intersection, `⊥ = ∅`, `⊤ = univ`. This lattice also has a finite height.
+
+The `Finset α` representation s isomorphic to `Fin α → Bool`, but far more
+efficient because it avoids building up stacks of layered closures. -/
+
+namespace Spa
+
+variable {α : Type*} [Fintype α] [DecidableEq α]
+
+omit [Fintype α] [DecidableEq α] in
+private lemma finset_card_strictMono : StrictMono (Finset.card : Finset α → ℕ) :=
+  fun _ _ h => Finset.card_lt_card h
+
+omit [DecidableEq α] in
+/-- A strictly increasing chain of finsets grows its cardinality by at least one
+    each step, and cardinality is capped by `Fintype.card α`. -/
+lemma finset_boundedChains : BoundedChains (Finset α) (Fintype.card α) := fun c => by
+  have h := LTSeries.head_add_length_le_nat (c.map Finset.card finset_card_strictMono)
+  rw [LTSeries.head_map, LTSeries.last_map, LTSeries.map_length] at h
+  have h2 : c.last.card ≤ Fintype.card α := Finset.card_le_univ _
+  omega
+
+instance instFiniteHeightFinset : FiniteHeightLattice (Finset α) where
+  toLattice := inferInstance
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
+  height := Fintype.card α
+  chains_bounded := finset_boundedChains
+
+end Spa

lean/Spa/Lattice/IterProd.lean

@@ -1,71 +0,0 @@
-/-
-Port of `Lattice/IterProd.agda`: the `k`-fold product `A × (A × ⋯ × B)`.
-
-With propositional equality and typeclasses, the Agda `Everything` record
-(which threaded the lattice operations and the conditional fixed-height proof
-through one recursion, so that the operations built by separate recursions
-would agree) is no longer needed: the `Lattice` instance is one recursive
-definition, and the fixed-height structure is another recursion over it.
-
-Correspondence:
-  IterProd            ↦ Spa.IterProd
-  build               ↦ Spa.IterProd.build
-  isLattice/lattice   ↦ instance Spa.IterProd.instLattice
-  fixedHeight,
-  isFiniteHeightLattice,
-  finiteHeightLattice ↦ Spa.IterProd.fixedHeight (+ instFiniteHeight instance)
-  ⊥-built             ↦ Spa.IterProd.bot_fixedHeight
--/
-import Spa.Lattice.Prod
-import Spa.Lattice.Unit
-
-namespace Spa
-
-universe u
-
-/-- Agda: `IterProd k = iterate k (A × ·) B`. (As in the Agda module, `A` and
-`B` are constrained to the same universe to keep the recursion simple.) -/
-def IterProd (A B : Type u) : ℕ → Type u
-  | 0 => B
-  | k + 1 => A × IterProd A B k
-
-namespace IterProd
-
-variable {A B : Type u}
-
-instance instLattice [Lattice A] [Lattice B] :
-    ∀ k, Lattice (IterProd A B k)
-  | 0 => inferInstanceAs (Lattice B)
-  | k + 1 => @Prod.instLattice A (IterProd A B k) _ (instLattice k)
-
-instance instDecidableEq [DecidableEq A] [DecidableEq B] :
-    ∀ k, DecidableEq (IterProd A B k)
-  | 0 => inferInstanceAs (DecidableEq B)
-  | k + 1 => @instDecidableEqProd A (IterProd A B k) _ (instDecidableEq k)
-
-/-- Agda: `build`. -/
-def build (a : A) (b : B) : (k : ℕ) → IterProd A B k
-  | 0 => b
-  | k + 1 => (a, build a b k)
-
-variable [Lattice A] [Lattice B]
-
-def fixedHeight [FiniteHeightLattice A] [FiniteHeightLattice B] :
-    ∀ k, FiniteHeightLattice (IterProd A B k)
-  | 0 => inferInstanceAs (FiniteHeightLattice B)
-  | k + 1 => @Spa.prod A (IterProd A B k) _ (instLattice k) _ (fixedHeight k)
-
-instance instFiniteHeight [FiniteHeightLattice A] [FiniteHeightLattice B] (k : ℕ) :
-    FiniteHeightLattice (IterProd A B k) := fixedHeight k
-
-theorem bot_fixedHeight [FiniteHeightLattice A] [FiniteHeightLattice B] :
-    ∀ k, (fixedHeight (A := A) (B := B) k).bot = build (⊥ : A) (⊥ : B) k
-  | 0 => rfl
-  | k + 1 => by
-    show ((⊥ : A), (fixedHeight (A := A) (B := B) k).bot)
-        = ((⊥ : A), build (⊥ : A) (⊥ : B) k)
-    rw [bot_fixedHeight k]
-
-end IterProd
-
-end Spa

lean/Spa/Lattice/Prod.lean

@@ -1,98 +0,0 @@
-import Spa.Lattice
-
-namespace Spa
-
-section Unzip
-
-variable {α β : Type*} [PartialOrder α] [PartialOrder β]
-
-theorem LTSeries.exists_unzip (c : LTSeries (α × β)) :
-    ∃ (c₁ : LTSeries α) (c₂ : LTSeries β),
-      c₁.head = c.head.1 ∧ c₁.last = c.last.1 ∧
-      c₂.head = c.head.2 ∧ c₂.last = c.last.2 ∧
-      c.length ≤ c₁.length + c₂.length := by
-  suffices H : ∀ (n : ℕ) (c : LTSeries (α × β)), c.length = n →
-      ∃ (c₁ : LTSeries α) (c₂ : LTSeries β),
-        c₁.head = c.head.1 ∧ c₁.last = c.last.1 ∧
-        c₂.head = c.head.2 ∧ c₂.last = c.last.2 ∧
-        c.length ≤ c₁.length + c₂.length from H c.length c rfl
-  intro n
-  induction n with
-  | zero =>
-    intro c hn
-    refine ⟨RelSeries.singleton _ c.head.1, RelSeries.singleton _ c.head.2,
-      rfl, ?_, rfl, ?_, by simp [hn]⟩ <;>
-    · have hlast : Fin.last c.length = 0 := by ext; simp [hn]
-      simp [RelSeries.last, RelSeries.head, hlast]
-  | succ n ih =>
-    intro c hn
-    have h0 : c.length ≠ 0 := by omega
-    obtain ⟨c₁, c₂, hh₁, hl₁, hh₂, hl₂, hlen⟩ :=
-      ih (c.tail h0) (by simp [RelSeries.tail_length, hn])
-    rw [RelSeries.last_tail] at hl₁ hl₂
-    rw [RelSeries.head_tail] at hh₁ hh₂
-    rw [RelSeries.tail_length] at hlen
-    have hstep : c.head < c 1 := by
-      have h := c.step ⟨0, by omega⟩
-      have h1 : (⟨0, by omega⟩ : Fin c.length).succ = 1 := by
-        ext; simp [Fin.val_one, Nat.mod_eq_of_lt (by omega : 1 < c.length + 1)]
-      rwa [h1] at h
-    obtain ⟨hle1, hle2⟩ := Prod.le_def.mp hstep.le
-    rcases eq_or_lt_of_le hle1 with heq1 | hlt1 <;>
-      rcases eq_or_lt_of_le hle2 with heq2 | hlt2
-    · exact absurd (Prod.ext heq1 heq2) hstep.ne
-    · refine ⟨c₁, c₂.cons c.head.2 (hh₂ ▸ hlt2),
-        hh₁.trans heq1.symm, hl₁, RelSeries.head_cons .., by
-          rw [RelSeries.last_cons]; exact hl₂, by
-          simp only [RelSeries.cons_length]; omega⟩
-    · refine ⟨c₁.cons c.head.1 (hh₁ ▸ hlt1), c₂,
-        RelSeries.head_cons .., by
-          rw [RelSeries.last_cons]; exact hl₁,
-        hh₂.trans heq2.symm, hl₂, by
-          simp only [RelSeries.cons_length]; omega⟩
-    · refine ⟨c₁.cons c.head.1 (hh₁ ▸ hlt1), c₂.cons c.head.2 (hh₂ ▸ hlt2),
-        RelSeries.head_cons .., by
-          rw [RelSeries.last_cons]; exact hl₁,
-        RelSeries.head_cons .., by
-          rw [RelSeries.last_cons]; exact hl₂, by
-          simp only [RelSeries.cons_length]; omega⟩
-
-end Unzip
-
-section FixedHeight
-
-variable {α β : Type*} [Lattice α] [Lattice β]
-
-instance prod [A : FiniteHeightLattice α] [B : FiniteHeightLattice β] :
-    FiniteHeightLattice (α × β) where
-  bot := ((⊥ : α), (⊥ : β))
-  top := ((⊤ : α), (⊤ : β))
-  height := A.height + B.height
-  longest_chain :=
-    { series :=
-        RelSeries.smash
-          (A.longest_chain.series.map (fun a => (a, (⊥ : β)))
-            (fun _ _ h => Prod.mk_lt_mk_iff_left.mpr h))
-          (B.longest_chain.series.map (fun b => ((⊤ : α), b))
-            (fun _ _ h => Prod.mk_lt_mk_iff_right.mpr h))
-          (by simp [A.longest_chain.last_series, B.longest_chain.head_series])
-      head_series :=
-        (RelSeries.head_smash _).trans
-          ((LTSeries.head_map _ _ _).trans
-            (congrArg (·, (⊥ : β)) A.longest_chain.head_series))
-      last_series :=
-        (RelSeries.last_smash _).trans
-          ((LTSeries.last_map _ _ _).trans
-            (congrArg ((⊤ : α), ·) B.longest_chain.last_series))
-      length_series := by
-        show A.longest_chain.series.length + B.longest_chain.series.length = _
-        rw [A.longest_chain.length_series, B.longest_chain.length_series] }
-  chains_bounded := fun c => by
-    obtain ⟨c₁, c₂, -, -, -, -, hlen⟩ := LTSeries.exists_unzip c
-    have h₁ := A.chains_bounded c₁
-    have h₂ := B.chains_bounded c₂
-    omega
-
-end FixedHeight
-
-end Spa

lean/Spa/Lattice/Tuple.lean

@@ -0,0 +1,128 @@
+import Spa.Lattice
+import Mathlib.Data.Fin.Tuple.Basic
+import Mathlib.Algebra.Order.BigOperators.Group.Finset
+
+/-!
+
+# Finite Tuple Lattices
+
+This file provides a proof that, in addition to being a lattice, the function
+space `Fin n → β` is itself a `Spa.FiniteHeightLattice` if the element type
+`β` is a lattice.
+
+Finite tuple lattices are the workhorse behind `FiniteMap`, whose carrier is
+`Fin ks.length → β`.
+
+The proof proceeds by "unzipping" a chain (`LTSeries`):
+
+$$
+(a_1, b_1, c_1) < \ldots < (a_1, b_1, c_o) < \ldots < (a_1, b_m, c_o) <
+  \ldots < (a_n, b_m, c_o)
+$$
+
+In which, at each step, at least one of the components must have increased
+(otherwise, the chain is not striclty increasing), into `n` chains
+(`LTSeries`).
+
+$$
+\begin{aligned}
+a_1 < \ldots < a_n \\
+b_1 < \ldots < b_m \
+c_1 < \ldots < c_o \
+\end{aligned}
+$$
+
+Because at least one of the two "unzipped" chains grows with each element of
+the product chain, the full chain length can't exceed the sum of the
+components. By the definition of finite height, these two chains are bounded,
+and therefore, the product chain is bounded too. -/
+
+namespace Spa
+
+namespace Tuple
+
+variable {β : Type*}
+
+section Unzip
+
+variable [PartialOrder β]
+
+open Classical in -- chain bounds are in Prop, so classical helps here.
+/-- The generalized unzip: any chain in `Fin n → β` decomposes into a family of
+    per-tuple-coordinate chains in `β`, agreeing with the original at each end, whose
+    lengths sum to an upper bound on the original chain's length. -/
+lemma exists_unzip {n : ℕ} (c : LTSeries (Fin n → β)) :
+    ∃ cs : Fin n → LTSeries β,
+      (∀ i, (cs i).head = c.head i) ∧ (∀ i, (cs i).last = c.last i) ∧
+      c.length ≤ ∑ i, (cs i).length := by
+  suffices H : ∀ (m : ℕ) (c : LTSeries (Fin n → β)), c.length = m →
+      ∃ cs : Fin n → LTSeries β,
+        (∀ i, (cs i).head = c.head i) ∧ (∀ i, (cs i).last = c.last i) ∧
+        c.length ≤ ∑ i, (cs i).length from H c.length c rfl
+  intro m
+  induction m with
+  | zero =>
+    intro c hn
+    have hlast : (Fin.last c.length) = 0 := by ext; simp [hn]
+    have hhl : c.last = c.head := by rw [RelSeries.last, RelSeries.head, hlast]
+    refine ⟨fun i => RelSeries.singleton _ (c.head i), fun i => ?_, fun i => ?_, ?_⟩
+    · exact RelSeries.head_singleton _
+    · rw [RelSeries.last_singleton, hhl]
+    · simp [hn, RelSeries.singleton]
+  | succ m ih =>
+    intro c hn
+    have h0 : c.length ≠ 0 := by omega
+    haveI : NeZero c.length := ⟨h0⟩
+    obtain ⟨cs', hh', hl', hlen'⟩ := ih (c.tail h0) (by rw [RelSeries.tail_length]; omega)
+    have hstep : c.head < c 1 := c.strictMono Fin.one_pos'
+    obtain ⟨hle, j, hjlt⟩ := Pi.lt_def.mp hstep
+    have hh'1 : ∀ i, (cs' i).head = c 1 i := fun i => by rw [hh' i, RelSeries.head_tail]
+    refine ⟨fun i =>
+        if hlt : c.head i < c 1 i then
+          (cs' i).cons (c.head i) (by rw [hh'1 i]; exact hlt)
+        else cs' i,
+      fun i => ?_, fun i => ?_, ?_⟩
+    · by_cases hlt : c.head i < c 1 i
+      · simp only [dif_pos hlt, RelSeries.head_cons]
+      · simp only [dif_neg hlt]
+        rw [hh'1 i]
+        exact ((lt_or_eq_of_le (hle i)).resolve_left hlt).symm
+    · by_cases hlt : c.head i < c 1 i
+      · simp only [dif_pos hlt, RelSeries.last_cons, hl' i, RelSeries.last_tail]
+      · simp only [dif_neg hlt, hl' i, RelSeries.last_tail]
+    · calc c.length
+          = (c.tail h0).length + 1 := by rw [RelSeries.tail_length]; omega
+        _ ≤ (∑ i, (cs' i).length) + 1 := Nat.add_le_add_right hlen' 1
+        _ ≤ ∑ i, (if hlt : c.head i < c 1 i then
+              (cs' i).cons (c.head i) (by rw [hh'1 i]; exact hlt) else cs' i).length :=
+          Nat.succ_le_of_lt (Finset.sum_lt_sum (fun i _ => by
+              split
+              · rw [RelSeries.cons_length]; omega
+              · exact le_rfl)
+            ⟨j, Finset.mem_univ j, by rw [dif_pos hjlt, RelSeries.cons_length]; omega⟩)
+
+end Unzip
+
+section FiniteHeight
+
+variable [FiniteHeightLattice β]
+
+instance instFiniteHeight {n : ℕ} : FiniteHeightLattice (Fin n → β) where
+  toLattice := inferInstance
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
+  height := n * FiniteHeightLattice.height (α := β)
+  chains_bounded := fun c => by
+    obtain ⟨cs, _, _, hbound⟩ := exists_unzip c
+    refine hbound.trans ?_
+    calc ∑ i, (cs i).length
+        ≤ ∑ _i : Fin n, FiniteHeightLattice.height (α := β) :=
+          Finset.sum_le_sum (fun i _ => FiniteHeightLattice.chains_bounded (cs i))
+      _ = n * FiniteHeightLattice.height (α := β) := by
+          simp [Finset.sum_const, Finset.card_univ, Fintype.card_fin]
+
+end FiniteHeight
+
+end Tuple
+
+end Spa

lean/Spa/Lattice/Unit.lean

@@ -1,28 +1,14 @@
-/-
-Port of `Lattice/Unit.agda`.
-
-The lattice structure itself (`_⊔_`, `_⊓_`, all semilattice/lattice laws) is
-lifted into mathlib: `PUnit.instLinearOrder` provides `Lattice PUnit`.
-What remains is the fixed-height structure: the unit lattice has height 0.
--/
 import Spa.Lattice
 
+/-!
+
+# Unit Lattice
+
+This file provides a proof that in addition to being a lattice,
+`PUnit` is a `Spa.FiniteHeightLattice`. This is a fairly trivial result. -/
+
 namespace Spa
 
-/-- Chains in a subsingleton order are bounded by any `n` (Agda: the `bounded`
+instance : FiniteHeightLattice PUnit := FiniteHeightLattice.ofUnique PUnit
-field of `Lattice/Unit.agda`'s `fixedHeight`, generalized). -/
-theorem boundedChains_of_subsingleton (α : Type*) [Preorder α] [Subsingleton α]
-    (n : ℕ) : BoundedChains α n := fun c => by
-  by_contra hc
-  push_neg at hc
-  exact (c.step ⟨0, by omega⟩).ne (Subsingleton.elim _ _)
-
-/-- Agda: `Lattice/Unit.agda`'s `fixedHeight`. -/
-instance : FiniteHeightLattice PUnit where
-  bot := PUnit.unit
-  top := PUnit.unit
-  height := 0
-  longest_chain := { series := RelSeries.singleton _ PUnit.unit, head_series := refl _, last_series := refl _, length_series := refl _ }
-  chains_bounded := boundedChains_of_subsingleton PUnit 0
 
 end Spa

lean/Spa/Showable.lean

@@ -1,16 +1,8 @@
-/-
-Port of `Showable.agda` (plus the `Showable` instances that lived on
-`Lattice/Map.agda` and `Lattice/AboveBelow.agda`).
-
-Lean has `ToString`, but its `String` instance does not quote (the Agda one
-does), so to reproduce the Agda output exactly we port the class as-is.
--/
 import Spa.Lattice.FiniteMap
 import Spa.Lattice.AboveBelow
 
 namespace Spa
 
-/-- Agda: `Showable` (`show` is a Lean keyword, hence `show'`). -/
 class Showable (α : Type*) where
   show' : α → String
 
@@ -29,19 +21,17 @@ instance {α β : Type*} [Showable α] [Showable β] : Showable (α × β) :=
 
 instance : Showable PUnit := ⟨fun _ => "()"⟩
 
-/-- Agda: the `Showable` instance of `Lattice/AboveBelow.agda`. -/
 instance {α : Type*} [Showable α] : Showable (AboveBelow α) :=
   ⟨fun
     | .bot => "⊥"
     | .top => "⊤"
     | .mk x => show' x⟩
 
-/-- Agda: the `Showable` instance of `Lattice/Map.agda` (inherited by
-`FiniteMap`). -/
 instance {α β : Type*} {ks : List α} [Showable α] [Showable β] :
     Showable (FiniteMap α β ks) :=
   ⟨fun fm =>
-    "{" ++ fm.val.foldr (fun p rest => show' p.1 ++ " ↦ " ++ show' p.2 ++ ", " ++ rest) ""
+    "{" ++ (FiniteMap.toList fm).foldr
+        (fun p rest => show' p.1 ++ " ↦ " ++ show' p.2 ++ ", " ++ rest) ""
         ++ "}"⟩
 
 end Spa

lean/Spa/Transformation/Constant.lean

@@ -0,0 +1,178 @@
+import Spa.Language.Base
+import Spa.Language.Program
+import Spa.Lattice.FiniteMap
+import Spa.Analysis.Constant
+import Spa.Analysis.Forward
+
+/-!
+# Constant folding
+
+Rewrites each assignment's right-hand side to a literal wherever the constant
+analysis (`Spa/Analysis/Constant.lean`) pins its value down.
+
+The traversal recurses over the plain `Stmt`, threading a `GGraph.Embed` of the
+current subtree's CFG into the program's (`Program.rootEmbed`, then one
+`Embed.trans` per descent). At an assignment, `Embed.singletonIndex` gives its
+CFG state, and the facts to fold with are `Forward.joinForKey` at that state —
+the join over predecessors, i.e. the values *entering* the node, which is what
+the right-hand side reads. (`Forward.variablesAt` would be the values *leaving*
+it, which already include this assignment's own effect.)
+-/
+
+namespace Spa
+
+namespace ConstantTransform
+
+open GGraph Forward
+
+variable (prog : Program)
+
+abbrev result := Forward.result ConstLattice prog
+
+/-- Replace an expression by a literal when the analysis pins its value down,
+recursing into its subexpressions otherwise. Whole subexpressions are tried
+first, so `(x + 1) - x` folds outright when `x` is known, rather than only in its
+leaves. -/
+def foldExpr (vs : VariableValues ConstLattice prog) : Expr → Expr
+  | .num n => .num n
+  | .var k =>
+      match ConstAnalysis.eval prog (.var k) vs with
+      | .mk z => .num z
+      | _ => .var k
+  | .add a b =>
+      match ConstAnalysis.eval prog (.add a b) vs with
+      | .mk z => .num z
+      | _ => .add (foldExpr vs a) (foldExpr vs b)
+  | .sub a b =>
+      match ConstAnalysis.eval prog (.sub a b) vs with
+      | .mk z => .num z
+      | _ => .sub (foldExpr vs a) (foldExpr vs b)
+
+/-- Constant-fold every assignment in a statement.
+
+`sv` is the analysis result, taken as a parameter rather than read from `result`
+at each node: it is a fixpoint computation, so recomputing it per assignment
+would make folding quadratic in the analysis.
+
+Guards of `ifElse`/`whileLoop` are deliberately left alone. `Stmt.cfg` gives a
+conditional's guard no node at all (`ifElse` overlays the two branches), so there
+is no state whose entry facts describe where it is evaluated. A `whileLoop`'s
+guard does have a candidate — the loop header `GGraph.loopIn` — but tying the
+guard's evaluation environment to that node needs a lemma that does not exist
+yet, so folding it here would be an unproven soundness claim. -/
+def foldStmt (sv : StateVariables ConstLattice prog) :
+    (s : Stmt) → Embed s.cfg prog.cfg → Stmt
+  | .basic .noop, _ => .basic .noop
+  | .basic (.assign k v), e =>
+      .basic (.assign k (foldExpr prog (joinForKey e.singletonIndex sv) v))
+  | .andThen s₁ s₂, e =>
+      .andThen (foldStmt sv s₁ ((Embed.sequenceLeft s₁.cfg s₂.cfg).trans e))
+               (foldStmt sv s₂ ((Embed.sequenceRight s₁.cfg s₂.cfg).trans e))
+  | .ifElse cond s₁ s₂, e =>
+      .ifElse cond (foldStmt sv s₁ ((Embed.overlayLeft s₁.cfg s₂.cfg).trans e))
+                   (foldStmt sv s₂ ((Embed.overlayRight s₁.cfg s₂.cfg).trans e))
+  | .whileLoop cond body, e =>
+      .whileLoop cond (foldStmt sv body ((Embed.loop body.cfg).trans e))
+
+/-- Constant-fold a whole program, running the analysis once. -/
+def foldProgram : Stmt := foldStmt prog (result prog) prog.rootStmt prog.rootEmbed
+
+/-! ## Correctness
+
+Folding preserves meaning *provided the facts folded with actually hold of the
+environment folded in*. That proviso is the whole content: `foldExpr` is sound
+against any `vs` that over-approximates `ρ`, and it is the analysis engine's job
+(`Forward.analyze_correct_at`) to supply such a `vs` at each program point. -/
+
+variable {prog}
+
+/-- If the analysis pins an expression to a constant and its facts hold of `ρ`,
+then the expression really does evaluate to that constant. This is
+`ValidExprEvaluator` specialised to the `.mk` case, where `interpConst` says
+exactly `v = .int z`. -/
+lemma eq_int_of_eval_mk {vs : VariableValues ConstLattice prog} {ρ : Env}
+    {e : Expr} {v : Value} {z : ℤ}
+    (hev : EvalExpr ρ e v) (hvs : ⟦vs⟧ ρ) (hz : ConstAnalysis.eval prog e vs = .mk z) :
+    v = .int z := by
+  have h := ValidExprEvaluator.valid (L := ConstLattice) (prog := prog) hev hvs
+  rw [show ExprEvaluator.eval e vs = ConstAnalysis.eval prog e vs from rfl, hz] at h
+  exact h
+
+/-- **Expression folding is meaning-preserving.** Whenever `vs` over-approximates
+`ρ`, the folded expression evaluates in `ρ` to whatever the original did. -/
+theorem foldExpr_eval {vs : VariableValues ConstLattice prog} {ρ : Env} (hvs : ⟦vs⟧ ρ) :
+    ∀ {e : Expr} {v : Value}, EvalExpr ρ e v → EvalExpr ρ (foldExpr prog vs e) v := by
+  intro e
+  induction e with
+  | num n => intro v hev; simpa [foldExpr] using hev
+  | var k =>
+      intro v hev
+      simp only [foldExpr]
+      split
+      · case h_1 z hz => rw [eq_int_of_eval_mk hev hvs hz]; exact EvalExpr.num ρ z
+      · exact hev
+  | add a b iha ihb =>
+      intro v hev
+      simp only [foldExpr]
+      split
+      · case h_1 z hz => rw [eq_int_of_eval_mk hev hvs hz]; exact EvalExpr.num ρ z
+      · cases hev with
+        | add _ _ z₁ z₂ h₁ h₂ => exact EvalExpr.add ρ _ _ z₁ z₂ (iha h₁) (ihb h₂)
+  | sub a b iha ihb =>
+      intro v hev
+      simp only [foldExpr]
+      split
+      · case h_1 z hz => rw [eq_int_of_eval_mk hev hvs hz]; exact EvalExpr.num ρ z
+      · cases hev with
+        | sub _ _ z₁ z₂ h₁ h₂ => exact EvalExpr.sub ρ _ _ z₁ z₂ (iha h₁) (ihb h₂)
+
+/-- Fold a source evaluation using its actual whole-program execution prefix. -/
+noncomputable def foldStmt_eval (prog : Program) {s : Stmt} {ρ₀ ρ₁ : Env}
+    (h : EvalStmt ρ₀ s ρ₁) :
+    (e : Embed s.cfg prog.cfg) →
+    (pre : Traceₗ prog.cfg prog.initialState (e.f (Stmt.cfg_sufficient h).entry) [] ρ₀) →
+    EvalStmt ρ₀ (foldStmt prog (result prog) s e) ρ₁ := by
+  induction h with
+  | basic ρ₀ ρ₁ bs hbs =>
+      intro e pre
+      have hr : Reaches e.singletonIndex ρ₀ ρ₁ :=
+        ⟨pre, by rw [Program.code, e.nodes_singletonIndex]; exact .some hbs⟩
+      cases hbs with
+      | noop => exact .basic _ _ _ (.noop _)
+      | assign x expr v hev =>
+          exact .basic _ _ _ (.assign _ _ _ _
+            (foldExpr_eval (ConstAnalysis.analyze_correct_at prog hr).1 hev))
+  | andThen ρ₀ ρ₁ ρ₂ s₁ s₂ h₁ h₂ ih₁ ih₂ =>
+      intro e pre
+      exact .andThen _ _ _ _ _
+        (ih₁ ((Embed.sequenceLeft s₁.cfg s₂.cfg).trans e) pre)
+        (ih₂ ((Embed.sequenceRight s₁.cfg s₂.cfg).trans e)
+          (Path.append pre (Path.embed e
+            ((Stmt.cfg_sufficient h₁).beforeRight (Stmt.cfg_sufficient h₂)))))
+  | ifTrue ρ₀ ρ₁ cond z s₁ s₂ hc hz h ih =>
+      intro e pre
+      exact .ifTrue _ _ _ _ _ _ hc hz
+        (ih ((Embed.overlayLeft s₁.cfg s₂.cfg).trans e) pre)
+  | ifFalse ρ₀ ρ₁ cond s₁ s₂ hc h ih =>
+      intro e pre
+      exact .ifFalse _ _ _ _ _ hc
+        (ih ((Embed.overlayRight s₁.cfg s₂.cfg).trans e) pre)
+  | whileTrue ρ₀ ρ₁ ρ₂ cond z body hc hz hb hr ihb ihr =>
+      intro e pre
+      exact .whileTrue _ _ _ _ _ _ hc hz
+        (ihb ((Embed.loop body.cfg).trans e)
+          (Path.append pre (Path.embed e (Stmt.cfg_sufficient hb).beforeBody)))
+        (ihr e (Path.append pre (Path.embed e
+          ((Stmt.cfg_sufficient hb).loop.beforeRest (Stmt.cfg_sufficient hr)))))
+  | whileFalse ρ cond body hc =>
+      intro e pre
+      exact .whileFalse _ _ _ hc
+
+/-- Constant folding preserves every terminating source evaluation. -/
+noncomputable def foldProgram_eval (prog : Program) {ρ : Env}
+    (h : EvalStmt [] prog.rootStmt ρ) : EvalStmt [] (foldProgram prog) ρ :=
+  foldStmt_eval prog h prog.rootEmbed (Stmt.cfg_sufficient h).beforeRoot
+
+end ConstantTransform
+
+end Spa

lean/Spa/Transformation/Licm.lean

@@ -0,0 +1,167 @@
+import Spa.Analysis.Reaching
+import Spa.Language.Equivalence
+
+/-!
+# Loop-invariant code motion
+
+This wires the **reaching-definitions** analysis (`Spa/Analysis/Reaching.lean`)
+to the AST to find assignments inside a `while` loop whose right-hand side
+depends only on definitions made outside the loop. `licmCandidates` reports
+these assignments; `hoistProgram` moves eligible leading assignments.
+
+The traversal recurses over the plain `Stmt`, threading a `GGraph.Embed` of the
+current subtree's CFG into the program's (`Program.rootEmbed`, then one
+`Embed.trans` per descent). That embedding is what supplies program states:
+
+1. at an assignment, its CFG state is `Embed.singletonIndex` — the subtree's CFG
+   is a `singleton`, so its sole node is the state, and `nodes_eq` proves it
+   holds that very statement;
+2. read the reaching definitions at the assignment's *entry* (`joinForKey s
+   result` — the join over predecessors, i.e. before the assignment runs);
+3. union the definition sets of the RHS variables;
+4. check no definition site lies in the loop body's CFG range. Every embedding is
+   a constant index shift, so the body occupies the interval
+   `[off, off + size)` (`GGraph.Embed.mem_range_iff`) and the test is two
+   comparisons.
+
+If every reaching definition of every RHS variable lies outside the loop, the
+assignment is reported as loop-invariant. Hoisting additionally requires the
+assignment to lead the body, its destination to be absent from the guard, and
+no reassignment of that destination in the remaining body. The hoist is guarded
+by the original condition, preserving zero-iteration behavior.
+
+`LicmTransformation.hoistProgram_eval` in `Spa/Transformation/Licm/Correctness.lean`
+proves preservation of terminating executions and observable final bindings.
+
+Transitive invariance and motion of non-leading assignments are not implemented.
+-/
+
+namespace Spa
+
+namespace LicmTransformation
+
+open Forward GGraph
+
+/-- The CFG footprint of an enclosing loop: its entry node (for reporting) and
+the index interval its body occupies. -/
+structure Enclosing (prog : Program) where
+  /-- The loop's entry node, i.e. `GGraph.loopIn` embedded into the program. -/
+  loopState : prog.State
+  /-- Start of the body's index range. -/
+  bodyOff : ℕ
+  /-- Length of the body's index range. -/
+  bodySize : ℕ
+
+/-- Is this definition site inside the loop body's CFG range? -/
+def Enclosing.covers {prog : Program} (l : Enclosing prog) (d : prog.State) : Bool :=
+  decide (l.bodyOff ≤ d.val ∧ d.val < l.bodyOff + l.bodySize)
+
+/-- An assignment found inside a loop, paired with the data needed to test its
+invariance against that (immediately enclosing) loop. -/
+structure Candidate (prog : Program) where
+  /-- The enclosing loop. -/
+  encl : Enclosing prog
+  /-- The assignment's CFG state. -/
+  assignState : prog.State
+  /-- The variables read by the assignment's RHS. -/
+  rhsVars : List String
+
+/-- Collect every assignment together with its *immediately enclosing* loop.
+`enc` is `none` outside any loop, in which case assignments are skipped — only
+in-loop assignments are candidates. -/
+def collectCandidates (prog : Program) (enc : Option (Enclosing prog)) :
+    (s : Stmt) → Embed s.cfg prog.cfg → List (Candidate prog)
+  | .basic bs, e =>
+      match bs, enc with
+      | .assign _ ex, some l =>
+          [{ encl := l, assignState := e.singletonIndex,
+             rhsVars := ex.vars.sort (· ≤ ·) }]
+      | _, _ => []
+  | .andThen s₁ s₂, e =>
+      collectCandidates prog enc s₁ ((Embed.sequenceLeft s₁.cfg s₂.cfg).trans e) ++
+      collectCandidates prog enc s₂ ((Embed.sequenceRight s₁.cfg s₂.cfg).trans e)
+  | .ifElse _ s₁ s₂, e =>
+      collectCandidates prog enc s₁ ((Embed.overlayLeft s₁.cfg s₂.cfg).trans e) ++
+      collectCandidates prog enc s₂ ((Embed.overlayRight s₁.cfg s₂.cfg).trans e)
+  | .whileLoop _ body, e =>
+      let be := (Embed.loop body.cfg).trans e
+      collectCandidates prog
+        (some { loopState := e.f body.cfg.loopIn, bodyOff := be.off,
+                bodySize := body.cfg.size }) body be
+
+/-- Read the definition set assigned to variable `k`, or `⊥` if absent. -/
+def lookupDef (prog : Program) (vs : VariableValues (DefSet prog) prog)
+    (k : String) : DefSet prog :=
+  if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else ⊥
+
+/-- Is the candidate assignment loop-invariant: do all reaching definitions of
+its RHS variables lie outside the loop body? -/
+def isInvariant (prog : Program) (c : Candidate prog) : Bool :=
+  let entry := joinForKey c.assignState (result (DefSet prog) prog)
+  let combined : DefSet prog :=
+    c.rhsVars.foldl (fun acc k => acc ⊔ lookupDef prog entry k) ⊥
+  -- `Finset.toList` is noncomputable; the decidable bounded-∀ folds over the
+  -- underlying multiset and keeps `lake exe` working.
+  decide (∀ d ∈ combined, c.encl.covers d = false)
+
+/-- The loop-invariant assignments of `prog`, as `(loop, assignment)` state pairs. -/
+def licmCandidates (prog : Program) : List (prog.State × prog.State) :=
+  (collectCandidates prog none prog.rootStmt prog.rootEmbed).filterMap (fun c =>
+    if isInvariant prog c then some (c.encl.loopState, c.assignState) else none)
+
+/-- Candidate for the leading assignment of a loop body. -/
+def headCandidate (prog : Program) (cond : Expr) (x : String) (rhs : Expr) (tail : Stmt)
+    (e : Embed (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg prog.cfg) :
+    Candidate prog :=
+  let body := Stmt.andThen (.basic (.assign x rhs)) tail
+  let be := (Embed.loop body.cfg).trans e
+  let ae := (Embed.sequenceLeft (Stmt.basic (.assign x rhs)).cfg tail.cfg).trans be
+  { encl := { loopState := e.f body.cfg.loopIn, bodyOff := be.off, bodySize := body.cfg.size },
+    assignState := ae.singletonIndex, rhsVars := rhs.vars.sort (· ≤ ·) }
+
+/-- Guard the hoist so that a zero-iteration loop never evaluates the RHS. -/
+def hoistHead (cond : Expr) (x : String) (rhs : Expr) (tail : Stmt) : Stmt :=
+  .ifElse cond (.andThen (.basic (.assign x rhs)) (.whileLoop cond tail)) (.basic .noop)
+
+/-- Hoist a leading invariant assignment when its destination is neither
+reassigned in the remaining body nor read by the guard. -/
+def hoistLoop (prog : Program) (cond : Expr) (body : Stmt)
+    (e : Embed (Stmt.whileLoop cond body).cfg prog.cfg) : Option Stmt :=
+  match body with
+  | .andThen (.basic (.assign x rhs)) tail =>
+      if isInvariant prog (headCandidate prog cond x rhs tail e) &&
+          decide (x ∉ tail.writes ∧ x ∉ cond.vars) then
+        some (hoistHead cond x rhs tail)
+      else none
+  | _ => none
+
+/-- Apply guarded leading-assignment LICM throughout the source tree. When a
+loop is hoisted, keep its remaining body intact; further passes can reanalyze it. -/
+def hoistStmt (prog : Program) : (s : Stmt) → Embed s.cfg prog.cfg → Stmt
+  | .basic bs, _ => .basic bs
+  | .andThen a b, e =>
+      .andThen (hoistStmt prog a ((Embed.sequenceLeft a.cfg b.cfg).trans e))
+        (hoistStmt prog b ((Embed.sequenceRight a.cfg b.cfg).trans e))
+  | .ifElse cond a b, e =>
+      .ifElse cond (hoistStmt prog a ((Embed.overlayLeft a.cfg b.cfg).trans e))
+        (hoistStmt prog b ((Embed.overlayRight a.cfg b.cfg).trans e))
+  | .whileLoop cond body, e =>
+      match hoistLoop prog cond body e with
+      | some moved => moved
+      | none => .whileLoop cond (hoistStmt prog body ((Embed.loop body.cfg).trans e))
+
+/-- Run reaching definitions on the source program and perform guarded LICM. -/
+def hoistProgram (prog : Program) : Stmt := hoistStmt prog prog.rootStmt prog.rootEmbed
+
+/-- A human-readable report of the loop-invariant assignments. -/
+def output (prog : Program) : String :=
+  match licmCandidates prog with
+  | [] => "no loop-invariant assignments found"
+  | cands =>
+      "loop-invariant assignments (loop ↦ assignment):\n" ++
+        String.intercalate "\n"
+          (cands.map (fun p => s!"  loop #{p.1.val}: assignment #{p.2.val}"))
+
+end LicmTransformation
+
+end Spa

lean/Spa/Transformation/Licm/Correctness.lean

@@ -0,0 +1,259 @@
+import Spa.Transformation.Licm
+import Spa.Analysis.Reaching.Paths
+
+namespace Spa
+namespace LicmTransformation
+open GGraph Forward ReachingAnalysis
+
+private lemma mem_union_fold {α β : Type} [DecidableEq β] (f : α → Finset β)
+    (xs : List α) (acc : Finset β) (d : β) :
+    d ∈ xs.foldl (fun a x => a ∪ f x) acc ↔ d ∈ acc ∨ ∃ x ∈ xs, d ∈ f x := by
+  induction xs generalizing acc with
+  | nil => simp
+  | cons x xs ih => simp [List.foldl, ih, or_assoc, or_left_comm, or_comm]
+
+/-- The executable invariant test excludes each actual reaching definition. -/
+lemma isInvariant_sound_at {prog : Program} {c : Candidate prog} {ρ ρ' : Env}
+    {x : String} {d : prog.State}
+    (hinv : isInvariant prog c = true) (hx : x ∈ c.rhsVars) (hxp : x ∈ prog.vars)
+    (hr : Reaches c.assignState ρ ρ')
+    (hl : LastAssign prog x (runOfPath prog hr.pre) d) : c.encl.covers d = false := by
+  let entry := joinForKey c.assignState (result (DefSet prog) prog)
+  have hk : FiniteMap.MemKey x entry := hxp
+  have hd : d ∈ lookupDef prog entry x := by
+    have hs := (ReachingAnalysis.analyze_correct_at prog hr).1
+    have hm := (FiniteMap.locate hk).2
+    have hd := hs x (FiniteMap.locate hk).1 hm d hl
+    simpa [lookupDef, hk] using hd
+  have hall : ∀ d ∈ c.rhsVars.foldl (fun acc k => acc ∪ lookupDef prog entry k) ∅,
+      c.encl.covers d = false := by simpa [isInvariant, entry] using hinv
+  exact hall d ((mem_union_fold _ _ _ _).mpr (Or.inr ⟨x, hx, hd⟩))
+
+/-- A path inside the loop can execute statements only within its body range. -/
+lemma loop_steps_covered {prog : Program} {cond : Expr} {x : String} {rhs : Expr} {tail : Stmt}
+    (e : Embed (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg prog.cfg)
+    {a b : Configuration (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg}
+    (seg : Path _ a b) {d : prog.State}
+    (hm : d ∈ (seg.embed e).steps) :
+    (headCandidate prog cond x rhs tail e).encl.covers d = true := by
+  rw [Path.steps_embed] at hm
+  obtain ⟨j, hj, rfl⟩ := List.mem_map.mp hm
+  obtain ⟨bs, hcode⟩ := Option.ne_none_iff_exists'.mp (seg.steps_nonempty hj)
+  obtain ⟨i, hi⟩ := GGraph.loop_node_in_body hcode
+  apply decide_eq_true
+  apply (Embed.mem_range_iff ((Embed.loop _).trans e) _).mp
+  exact ⟨i, congrArg e.f hi⟩
+
+/-- The analysis and the actual intervening path together establish RHS
+stability. This is the bridge from static sites to unchanged runtime values. -/
+lemma head_rhs_agrees {prog : Program} {cond : Expr} {x : String} {rhs : Expr} {tail : Stmt}
+    (e : Embed (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg prog.cfg)
+    {i j : (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg.Index}
+    {ρ₀ ρ₁ ρ₂ : Env}
+    (pre : Traceₗ prog.cfg prog.initialState (e.f i) [] ρ₀)
+    (seg : Traceₗ _ i j ρ₀ ρ₁)
+    (hj : e.f j = (headCandidate prog cond x rhs tail e).assignState)
+    (step : EvalBasicStmt ρ₁ (.assign x rhs) ρ₂)
+    (hinv : isInvariant prog (headCandidate prog cond x rhs tail e) = true) :
+    Env.AgreeOn rhs.vars ρ₀ ρ₁ := by
+  have hj' : j = ((Embed.sequenceLeft (Stmt.basic (.assign x rhs)).cfg tail.cfg).trans
+      (Embed.loop (Stmt.andThen (.basic (.assign x rhs)) tail).cfg)).singletonIndex := e.f_inj hj
+  subst j
+  let c := headCandidate prog cond x rhs tail e
+  have hcode : prog.code c.assignState = some (.assign x rhs) :=
+    Embed.nodes_singletonIndex
+      ((Embed.sequenceLeft (Stmt.basic (.assign x rhs)).cfg tail.cfg).trans
+        ((Embed.loop (Stmt.andThen (.basic (.assign x rhs)) tail).cfg).trans e))
+  let reach : Reaches c.assignState ρ₁ ρ₂ :=
+    ⟨pre.append (seg.embed e), hcode ▸ .some step⟩
+  intro y hy
+  apply ReachingAnalysis.Path.preserves_of_lastAssign_outside pre (seg.embed e)
+    {d | c.encl.covers d = true}
+  · intro d hm; exact loop_steps_covered e seg hm
+  · intro d hl hd
+    have hl' : LastAssign prog y (runOfPath prog reach.pre) d := hl
+    have hf := isInvariant_sound_at hinv (by simpa [c, headCandidate] using hy)
+      (Program.code_vars hcode y (Finset.mem_union_right _ hy)) reach hl'
+    exact Bool.noConfusion (hd.symm.trans hf)
+
+private lemma loop_entry {cond : Expr} {body : Stmt} {ρ σ : Env}
+    (h : EvalStmt ρ (.whileLoop cond body) σ) :
+    (Stmt.cfg_sufficient h).entry = body.cfg.loopIn := by
+  cases h <;> rfl
+
+/-- Remove all subsequent executions of the leading assignment. The accumulated
+source path, rather than transformed histories, supplies the analysis facts. -/
+private noncomputable def removeHead_eval (prog : Program)
+    {cond : Expr} {x : String} {rhs : Expr} {tail : Stmt}
+    {ρ ρ' : Env} (h : EvalStmt ρ (.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)) ρ')
+    (e : Embed (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg prog.cfg)
+    (hinv : isInvariant prog (headCandidate prog cond x rhs tail e) = true)
+    (hwrite : x ∉ tail.writes)
+    {base : Env} {v : Value}
+    (pre : Traceₗ prog.cfg prog.initialState
+      (e.f (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn) [] base)
+    (hv : EvalExpr base rhs v)
+    (seg : Traceₗ (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg
+      (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn
+      (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn base ρ)
+    {σ : Env} (heq : Env.Equiv ρ σ) (hx : Env.Mem (x, v) σ) :
+    Σ σ', {_h : EvalStmt σ (.whileLoop cond tail) σ' // Env.Equiv ρ' σ'} := by
+  generalize hs : Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail) = s at h
+  induction h generalizing σ with
+  | basic => cases hs
+  | andThen => cases hs
+  | ifTrue => cases hs
+  | ifFalse => cases hs
+  | whileFalse ρ cond' body hc =>
+      cases hs
+      exact ⟨σ, .whileFalse _ _ _ (hc.congr_env (fun y _ => heq y)), heq⟩
+  | whileTrue ρ₀ ρ₁ ρ₂ cond' z body hc hz hb hr ihb ihr =>
+      cases hs
+      cases hb with
+      | andThen _ ρa _ _ _ ha ht =>
+        cases ha with
+        | basic _ _ _ ha =>
+          cases ha with
+          | assign _ _ w hw =>
+            let hb := EvalStmt.andThen _ _ _ _ _ (.basic _ _ _ (.assign _ _ _ _ hw)) ht
+            let toAssign := seg.append (Stmt.cfg_sufficient hb).beforeBody
+            have hagree := head_rhs_agrees e pre toAssign rfl (.assign _ _ _ _ hw) hinv
+            have hwv : w = v := hw.deterministic (hv.congr_env hagree)
+            subst w
+            have heqa : Env.Equiv ((x, v) :: ρ₀) σ :=
+              (heq.cons x v).trans (Env.cons_equiv_of_mem hx)
+            obtain ⟨σ₁, ht', heq₁⟩ := ht.congr_env heqa
+            have hx₁ : Env.Mem (x, v) σ₁ := (ht'.preserves_unwritten hwrite v).mp hx
+            let next := seg.append ((Stmt.cfg_sufficient hb).loop.beforeRest (Stmt.cfg_sufficient hr))
+            have next' : Traceₗ (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg
+                (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn
+                (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn base ρ₁ := by
+              simpa only [loop_entry hr] using next
+            obtain ⟨σ₂, hr', heq₂⟩ := ihr next' heq₁ hx₁ rfl
+            exact ⟨σ₂, .whileTrue _ _ _ _ _ _ (hc.congr_env (fun y _ => heq y)) hz ht' hr', heq₂⟩
+
+/-- Guarded hoisting preserves every terminating execution of an eligible loop,
+including its current bindings and definedness. -/
+noncomputable def hoistHead_eval (prog : Program)
+    {cond : Expr} {x : String} {rhs : Expr} {tail : Stmt} {ρ ρ' σ : Env}
+    (h : EvalStmt ρ (.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)) ρ')
+    (e : Embed (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg prog.cfg)
+    (pre : Traceₗ prog.cfg prog.initialState (e.f (Stmt.cfg_sufficient h).entry) [] ρ)
+    (hinv : isInvariant prog (headCandidate prog cond x rhs tail e) = true)
+    (hwrite : x ∉ tail.writes) (hguard : x ∉ cond.vars)
+    (heq : Env.Equiv ρ σ) :
+    Σ σ', {_h : EvalStmt σ (hoistHead cond x rhs tail) σ' // Env.Equiv ρ' σ'} := by
+  cases h with
+  | whileFalse _ _ _ hc =>
+      exact ⟨σ, .ifFalse _ _ _ _ _ (hc.congr_env (fun y _ => heq y))
+        (.basic _ _ _ (.noop _)), heq⟩
+  | whileTrue ρ₀ ρ₁ ρ₂ _ z _ hc hz hb hr =>
+      cases hb with
+      | andThen _ ρa _ _ _ ha ht =>
+        cases ha with
+        | basic _ _ _ ha =>
+          cases ha with
+          | assign _ _ v hv =>
+            let hb := EvalStmt.andThen _ _ _ _ _ (.basic _ _ _ (.assign _ _ _ _ hv)) ht
+            have hc' := hc.congr_env (fun y _ => heq y)
+            have hc'' : EvalExpr ((x, v) :: σ) cond (.int z) := by
+              apply hc'.congr_env
+              intro y hy w
+              have hne : y ≠ x := by rintro rfl; exact hguard hy
+              simp [Env.mem_cons, hne]
+            obtain ⟨σ₁, ht', heq₁⟩ := ht.congr_env (heq.cons x v)
+            have hx₁ : Env.Mem (x, v) σ₁ :=
+              (ht'.preserves_unwritten hwrite v).mp (.here _ _ _)
+            let next := (Stmt.cfg_sufficient hb).loop.beforeRest (Stmt.cfg_sufficient hr)
+            have next' : Traceₗ (Stmt.whileLoop cond (.andThen (.basic (.assign x rhs)) tail)).cfg
+                (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn
+                (Stmt.andThen (.basic (.assign x rhs)) tail).cfg.loopIn ρ ρ₁ := by
+              simpa only [loop_entry hr] using next
+            obtain ⟨σ₂, hr', heq₂⟩ := removeHead_eval prog hr e hinv hwrite pre hv next' heq₁ hx₁
+            exact ⟨σ₂, .ifTrue _ _ _ _ _ _ hc' hz
+              (.andThen _ _ _ _ _
+                (.basic _ _ _ (.assign _ _ _ _ (hv.congr_env (fun y _ => heq y))))
+                (.whileTrue _ _ _ _ _ _ hc'' hz ht' hr')), heq₂⟩
+
+private noncomputable def hoistLoop_eval (prog : Program)
+    {cond : Expr} {body moved : Stmt} {ρ ρ' σ : Env}
+    (h : EvalStmt ρ (.whileLoop cond body) ρ')
+    (e : Embed (Stmt.whileLoop cond body).cfg prog.cfg)
+    (pre : Traceₗ prog.cfg prog.initialState (e.f (Stmt.cfg_sufficient h).entry) [] ρ)
+    (hm : hoistLoop prog cond body e = some moved) (heq : Env.Equiv ρ σ) :
+    Σ σ', {_h : EvalStmt σ moved σ' // Env.Equiv ρ' σ'} := by
+  unfold hoistLoop at hm
+  split at hm
+  · rename_i x rhs tail e
+    split at hm
+    · rename_i hc
+      simp only [Bool.and_eq_true, decide_eq_true_eq] at hc
+      cases hm
+      exact hoistHead_eval prog h e pre hc.1 hc.2.1 hc.2.2 heq
+    · cases hm
+  · cases hm
+
+/-- Transform a source evaluation using its source CFG prefix. Recursive calls
+can start in any environment with the same current bindings. -/
+noncomputable def hoistStmt_eval (prog : Program) {s : Stmt} {ρ ρ' : Env}
+    (h : EvalStmt ρ s ρ') :
+    (e : Embed s.cfg prog.cfg) →
+    (pre : Traceₗ prog.cfg prog.initialState (e.f (Stmt.cfg_sufficient h).entry) [] ρ) →
+    ∀ {σ}, Env.Equiv ρ σ →
+    Σ σ', {_h : EvalStmt σ (hoistStmt prog s e) σ' // Env.Equiv ρ' σ'} := by
+  induction h with
+  | basic ρ₀ ρ₁ bs hb =>
+      intro e pre σ heq
+      exact (EvalStmt.basic _ _ _ hb).congr_env heq
+  | andThen ρ₀ ρ₁ ρ₂ a b ha hb iha ihb =>
+      intro e pre σ heq
+      obtain ⟨σ₁, ha', heq₁⟩ := iha ((Embed.sequenceLeft a.cfg b.cfg).trans e) pre heq
+      obtain ⟨σ₂, hb', heq₂⟩ := ihb ((Embed.sequenceRight a.cfg b.cfg).trans e)
+        (pre.append (Path.embed e ((Stmt.cfg_sufficient ha).beforeRight (Stmt.cfg_sufficient hb)))) heq₁
+      exact ⟨σ₂, .andThen _ _ _ _ _ ha' hb', heq₂⟩
+  | ifTrue ρ₀ ρ₁ cond z a b hc hz h ih =>
+      intro e pre σ heq
+      obtain ⟨σ', h', heq'⟩ := ih ((Embed.overlayLeft a.cfg b.cfg).trans e) pre heq
+      exact ⟨σ', .ifTrue _ _ _ _ _ _ (hc.congr_env (fun x _ => heq x)) hz h', heq'⟩
+  | ifFalse ρ₀ ρ₁ cond a b hc h ih =>
+      intro e pre σ heq
+      obtain ⟨σ', h', heq'⟩ := ih ((Embed.overlayRight a.cfg b.cfg).trans e) pre heq
+      exact ⟨σ', .ifFalse _ _ _ _ _ (hc.congr_env (fun x _ => heq x)) h', heq'⟩
+  | whileTrue ρ₀ ρ₁ ρ₂ cond z body hc hz hb hr ihb ihr =>
+      intro e pre σ heq
+      cases hm : hoistLoop prog cond body e with
+      | some moved =>
+          simp only [hoistStmt]
+          rw [hm]
+          exact hoistLoop_eval prog (.whileTrue _ _ _ _ _ _ hc hz hb hr) e pre hm heq
+      | none =>
+          obtain ⟨σ₁, hb', heq₁⟩ := ihb ((Embed.loop body.cfg).trans e)
+            (pre.append (Path.embed e (Stmt.cfg_sufficient hb).beforeBody)) heq
+          obtain ⟨σ₂, hr', heq₂⟩ := ihr e
+            (pre.append (Path.embed e
+              ((Stmt.cfg_sufficient hb).loop.beforeRest (Stmt.cfg_sufficient hr)))) heq₁
+          simp only [hoistStmt] at hr' ⊢
+          rw [hm] at hr' ⊢
+          exact ⟨σ₂, .whileTrue _ _ _ _ _ _ (hc.congr_env (fun x _ => heq x)) hz hb' hr', heq₂⟩
+  | whileFalse ρ cond body hc =>
+      intro e pre σ heq
+      cases hm : hoistLoop prog cond body e with
+      | some moved =>
+          simp only [hoistStmt]
+          rw [hm]
+          exact hoistLoop_eval prog (.whileFalse _ _ _ hc) e pre hm heq
+      | none =>
+          simp only [hoistStmt]
+          rw [hm]
+          exact ⟨σ, .whileFalse _ _ _ (hc.congr_env (fun x _ => heq x)), heq⟩
+
+/-- LICM preserves every terminating source execution and all observable final
+bindings. The source analysis is computed by `hoistProgram`; no soundness or
+invariance premise is required of callers. -/
+noncomputable def hoistProgram_eval (prog : Program) {ρ : Env}
+    (h : EvalStmt [] prog.rootStmt ρ) :
+    Σ σ, {_h : EvalStmt [] (hoistProgram prog) σ // Env.Equiv ρ σ} :=
+  hoistStmt_eval prog h prog.rootEmbed (Stmt.cfg_sufficient h).beforeRoot (Env.Equiv.refl [])
+
+end LicmTransformation
+end Spa