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,5 +1,6 @@
 import Spa.Analysis.Sign
 import Spa.Analysis.Constant
+import Spa.Analysis.Reaching
 import Spa.Language.Notation
 
 namespace Spa
@@ -26,10 +27,11 @@ def testCodeCond₂ : Stmt := [obj_stmt|
   if var { x := 1 } else { noop }
 ]
 
-def testProgram : Program := ⟨testCode⟩
+def testProgram : Program := { rootStmt := testCode }
 
 end Spa
 
 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,18 +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
@@ -22,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

@@ -29,15 +29,13 @@ def minus : ConstLattice → ConstLattice → ConstLattice
 
 lemma plus_mono₂ : Monotone₂ plus :=
   AboveBelow.monotone₂_of_strict plus
-    (fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
-    (fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
+    (fun y => by aesop) (fun x => by aesop)
+    (fun y hy => by aesop) (fun x hx => by aesop)
 
 lemma minus_mono₂ : Monotone₂ minus :=
   AboveBelow.monotone₂_of_strict minus
-    (fun y => by cases y <;> rfl) (fun x => by cases x <;> rfl)
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
-    (fun x hx => by cases x <;> first | exact absurd rfl hx | rfl)
+    (fun y => by aesop) (fun x => by aesop)
+    (fun y hy => by aesop) (fun x hx => by aesop)
 
 def interpConst : ConstLattice → Value → Prop
   | .bot, _ => False
@@ -96,36 +94,14 @@ def output : String :=
 lemma plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
     (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
     ⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
-  rcases g₁ with _ | _ | c₁
-  · exact h₁.elim
-  · rcases g₂ with _ | _ | c₂
-    · exact h₂.elim
-    · exact trivial
-    · exact trivial
-  · rcases g₂ with _ | _ | c₂
-    · exact h₂.elim
-    · exact trivial
-    · injection h₁ with hz₁
-      injection h₂ with hz₂
-      show Value.int (z₁ + z₂) = Value.int (c₁ + c₂)
-      rw [hz₁, hz₂]
+  rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
+    simp_all [plus, constInterpretation, interpConst]
 
 lemma minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
     (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
     ⟦minus g₁ g₂⟧ (.int (z₁ - z₂)) := by
-  rcases g₁ with _ | _ | c₁
-  · exact h₁.elim
-  · rcases g₂ with _ | _ | c₂
-    · exact h₂.elim
-    · exact trivial
-    · exact trivial
-  · rcases g₂ with _ | _ | c₂
-    · exact h₂.elim
-    · exact trivial
-    · injection h₁ with hz₁
-      injection h₂ with hz₂
-      show Value.int (z₁ - z₂) = Value.int (c₁ - c₂)
-      rw [hz₁, hz₂]
+  rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
+    simp_all [minus, constInterpretation, interpConst]
 
 instance eval_valid : ValidExprEvaluator ConstLattice prog := by
   constructor
@@ -161,6 +137,12 @@ theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
     ⟦ variablesAt prog.finalState (result ConstLattice prog) ⟧ ρ :=
   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
 
 end Spa

lean/Spa/Analysis/Forward.lean

@@ -10,12 +10,11 @@ namespace Forward
 variable {L : Type} [FiniteHeightLattice L] {prog : Program} [E : StmtEvaluator L prog]
 
 def updateVariablesForState (s : prog.State) (sv : StateVariables L prog) :
-    VariableValues L prog :=
-  (prog.code s).foldl (fun vs bs => E.eval s bs vs) (variablesAt s sv)
+    VariableValues L prog := E.eval s (variablesAt s sv)
 
 lemma updateVariablesForState_mono (s : prog.State) :
     Monotone (updateVariablesForState (L := L) s) := fun _ _ hle =>
-  foldl_mono' (prog.code s) _ (E.eval_mono s ·) (variablesAt_le hle s)
+  E.eval_mono s (variablesAt_le hle s)
 
 def updateAll (sv : StateVariables L prog) : StateVariables L prog :=
   FiniteMap.generalizedUpdate id updateVariablesForState
@@ -54,67 +53,103 @@ lemma joinForKey_initialState :
   rw [joinForKey, prog.incoming_initialState_eq_nil]
   rfl
 
-variable [I : LatticeInterpretation L] [V : ValidStmtEvaluator L prog]
+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 []))
+
+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
+
+section
+variable [S : StateInterpretation L prog] [V : ValidStateEvaluator L prog]
 
 omit [DecidableEq L] in
-lemma eval_fold_valid {s : prog.State} {bss : List BasicStmt}
-    {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
-    (hbss : EvalBasicStmts ρ₁ bss ρ₂) (hvs : ⟦ vs ⟧ ρ₁) :
-    ⟦ 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 [DecidableEq L] in
-lemma updateVariablesForState_matches {s : prog.State}
-    {sv : StateVariables L prog} {ρ₁ ρ₂ : Env}
-    (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
-    (hvs : ⟦ variablesAt s sv ⟧ ρ₁) :
-    ⟦ updateVariablesForState s sv ⟧ ρ₂ :=
-  eval_fold_valid hbss hvs
-
-omit [DecidableEq L] in
-lemma updateAll_matches {s : prog.State} {sv : StateVariables L prog}
-    {ρ₁ ρ₂ : Env} (hbss : EvalBasicStmts ρ₁ (prog.code s) ρ₂)
-    (hvs : ⟦ variablesAt s sv ⟧ ρ₁) :
-    ⟦ variablesAt s (updateAll sv) ⟧ ρ₂ := by
+lemma updateAll_matches {s₁ s₂ : prog.State} {sv : StateVariables L prog}
+    {ρ₁ ρ₂ ρ₃ : Env}
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂)
+    (hnode : EvalBasicStmtOpt ρ₂ (prog.code s₂) ρ₃)
+    (hvs : ⟦ variablesAt s₂ sv ⟧ (S.Pre tr)) :
+    ⟦ variablesAt s₂ (updateAll sv) ⟧ (S.Post (tr ++ hnode)) := by
   rw [variablesAt_updateAll]
-  exact updateVariablesForState_matches hbss hvs
+  exact V.valid s₁ s₂ tr hnode hvs
 
-lemma stepTrace {s₁ : prog.State} {ρ₁ ρ₂ : Env}
-    (hjoin : ⟦ joinForKey s₁ (result L prog) ⟧ ρ₁)
-    (hbss : EvalBasicStmts ρ₁ (prog.code s₁) ρ₂) :
-    ⟦ variablesAt s₁ (result L prog) ⟧ ρ₂ := by
+lemma stepTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
+    (tr : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂)
+    (hjoin : ⟦ joinForKey s₂ (result L prog) ⟧ (S.Pre tr))
+    (hnode : EvalBasicStmtOpt ρ₂ (prog.code s₂) ρ₃) :
+    ⟦ 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
 
-lemma walkTrace {s₁ s₂ : prog.State} {ρ₁ ρ₂ : Env}
-    (hjoin : ⟦ joinForKey s₁ (result L prog) ⟧ ρ₁)
-    (tr : Trace prog.cfg s₁ s₂ ρ₁ ρ₂) :
-    ⟦ variablesAt s₂ (result L prog) ⟧ ρ₂ := by
-  induction tr with
-  | single hbss => exact stepTrace hjoin hbss
-  | @edge _ ρ' _ i₁ i₂ _ hbss hedge _ ih =>
-    have hstep : ⟦ variablesAt i₁ (result L prog) ⟧ ρ' :=
-      stepTrace hjoin hbss
-    have hmem : variablesAt i₁ (result L prog)
-        ∈ (result L prog).valuesAt (prog.incoming i₂) :=
-      FiniteMap.mem_valuesAt prog.states_nodup
-        (prog.mem_incoming_of_edge hedge) (variablesAt_mem i₁ (result L prog))
-    exact ih (interp_foldr hstep hmem)
+/-- Soundness propagates along an execution prefix: if the analysis is sound at
+    `s₂` for the run so far (`trₗ`), then it is sound wherever the further prefix
+    `mid` ends up. -/
+lemma walkPrefix : ∀ {s₂ s : prog.State} {ρ₂ ρin : Env}
+    (mid : Traceₗ prog.cfg s₂ s ρ₂ ρin) {s₁ : prog.State} {ρ₁ : Env}
+    (trₗ : Traceₗ prog.cfg s₁ s₂ ρ₁ ρ₂),
+    ⟦ joinForKey s₂ (result L prog) ⟧ (S.Pre trₗ) →
+    ⟦ joinForKey s (result L prog) ⟧ (S.Pre (trₗ ++ mid)) := by
+  intro s₂ s ρ₂ ρin mid
+  match mid with
+  | Traceₗ.nil =>
+      intro s₁ ρ₁ trₗ hjoin
+      simpa only [HAppend.hAppend, Path.append_nil] using hjoin
+  | Traceₗ.cons hnode hedge rest =>
+      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
-lemma interp_joinForKey_initialState :
-    ⟦ joinForKey prog.initialState (result L prog) ⟧ [] := by
-  rw [joinForKey_initialState]
-  exact interp_botV_nil
+omit [DecidableEq L] in
+/-- The final node of a trace is always reached, with the environment/state the trace
+    ends in. Used to recover the final-state soundness theorem from `walkPrefix`. -/
+def reaches_final {s : prog.State} {ρ : Env}
+    (tr : Trace prog.cfg prog.initialState s [] ρ) : Σ ρin, Reaches s ρin ρ :=
+  ⟨_, ⟨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
-theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
+/-- Soundness at every program point an execution actually visits: the analysis
+    over-approximates both the environment entering that point and the one leaving
+    it. -/
+theorem analyze_correct_at {s : prog.State} {ρin ρout : Env} (hr : Reaches s ρin ρout) :
+    ⟦ 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) ⟧ ρ :=
-  walkTrace interp_joinForKey_initialState (prog.trace hrun)
+  analyze_correct' L prog hrun
 
 end Forward
 

lean/Spa/Analysis/Forward/Adapters.lean

@@ -14,44 +14,50 @@ lemma updateVariablesFromExpression_mono (k : String) (e : Expr) :
     Monotone (updateVariablesFromExpression (L := L) (prog := prog) k e) :=
   FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => E.eval_mono e)
 
-def evalBasicStmt (_ : prog.State) (bs : BasicStmt)
+def evalBasicStmt (bs : BasicStmt)
     (vs : VariableValues L prog) : VariableValues L prog :=
   match bs with
   | .assign k e => updateVariablesFromExpression k e vs
   | .noop => vs
 
-lemma evalBasicStmt_mono (s : prog.State) (bs : BasicStmt) :
-    Monotone (evalBasicStmt (L := L) (prog := prog) s bs) := by
+lemma evalBasicStmt_mono (bs : BasicStmt) :
+    Monotone (evalBasicStmt (L := L) (prog := prog) bs) := by
   cases bs with
   | assign k e => exact updateVariablesFromExpression_mono k e
   | noop => exact monotone_id
 
+def evalBasicStmtOpt (obs : Option BasicStmt)
+    (vs : VariableValues L prog) : VariableValues L prog :=
+  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 :=
-  ⟨evalBasicStmt, evalBasicStmt_mono⟩
+  ⟨evalBasicStmtOpt ∘ prog.code,
+   by intro s; simp; exact (evalBasicStmtOpt_mono (prog.code s))⟩
 
 instance ExprEvaluator.toStmtEvaluator_valid [LatticeInterpretation L]
     [ValidExprEvaluator L prog] : ValidStmtEvaluator L prog := by
   constructor
-  intro s vs ρ₁ ρ₂ bs hbs hvs
-  cases hbs with
-  | noop => exact hvs
-  | assign k e v hev =>
-    intro k' l hk'l v' hv'
-    cases hv' with
-    | here =>
-      have hk'l₀ : (k, l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
-          (fun _ vs => E.eval e vs) [k] vs := hk'l
-      have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
-        (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hk'l₀
-      rw [hl]
+  simp [StmtEvaluator.eval, evalBasicStmtOpt]
+  intro s vs ρ₁ ρ₂; generalize prog.code s = obs; intro hev hvs
+  rcases hev with _ | @⟨_,bs,hev⟩ <;> try simpa
+  rcases hev with _ | @⟨k, e, v, hev⟩ <;> try simpa
+  intros k' l' hkl' v' hρ
+  rcases hρ with _ | ⟨_,_,_,_,_,hne,hmem⟩ <;> simp [evalBasicStmt] at hkl'
+  · have hl := FiniteMap.generalizedUpdate_mem_eq (f := id)
+        (g := fun _ vs => E.eval e vs) (List.mem_singleton_self k) hkl'
+    rewrite [hl]; simp
     exact ValidExprEvaluator.valid hev hvs
-    | there _ _ _ _ _ hne hmem' =>
-      have hk'l₀ : (k', l) ∈ FiniteMap.generalizedUpdate (ks := prog.vars) id
-          (fun _ vs => E.eval e vs) [k] vs := hk'l
-      have hk'l' : (k', l) ∈ (id vs : VariableValues L prog) :=
-        FiniteMap.generalizedUpdate_not_mem_backward
-          (fun hmem => hne (List.mem_singleton.mp hmem)) hk'l₀
-      exact hvs _ _ hk'l' _ hmem'
+  · have hl := FiniteMap.generalizedUpdate_not_mem_backward
+        (fun hmem => hne (List.mem_singleton.mp hmem)) hkl'
+    apply hvs _ _ hl _ hmem
 
 end Forward
 

lean/Spa/Analysis/Forward/Evaluation.lean

@@ -7,8 +7,8 @@ namespace Forward
 variable (L : Type) [Lattice L] (prog : Program)
 
 class StmtEvaluator where
-  eval : prog.State → BasicStmt → VariableValues L prog → VariableValues L prog
-  eval_mono : ∀ s bs, Monotone (eval s bs)
+  eval : prog.State → VariableValues L prog → VariableValues L prog
+  eval_mono : ∀ s, Monotone (eval s)
 
 class ExprEvaluator where
   eval : Expr → VariableValues L prog → L
@@ -21,9 +21,8 @@ class ValidExprEvaluator [ExprEvaluator L prog] [I : LatticeInterpretation L] :
 
 class ValidStmtEvaluator [E : StmtEvaluator L prog] [LatticeInterpretation L] :
     Prop where
-  valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env}
-    {bs : BasicStmt},
-    EvalBasicStmt ρ₁ bs ρ₂ → ⟦ vs ⟧ ρ₁ → ⟦ E.eval s bs vs ⟧ ρ₂
+  valid : ∀ {s : prog.State} {vs : VariableValues L prog} {ρ₁ ρ₂ : Env},
+    EvalBasicStmtOpt ρ₁ (prog.code s) ρ₂ → ⟦ vs ⟧ ρ₁ → ⟦ E.eval s vs ⟧ ρ₂
 
 end Forward
 

lean/Spa/Analysis/Forward/Lattices.lean

@@ -64,39 +64,57 @@ lemma 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
-instance : Interp (VariableValues L prog) (Env → Prop) where
-  interp (vs : VariableValues L prog) (ρ : Env) : Prop :=
-    ∀ (k : String) (l : L), (k, l) ∈ vs →
-      ∀ (v : Value), Env.Mem (k, v) ρ → I.interp l v
+  post_pre : ∀ {vs} {s₁ s₂ s₃: prog.State} {ρ₁ ρ₂ : Env}
+    (tr : Trace prog.cfg s₁ s₂ ρ₁ ρ₂) (hedge : (s₂, s₃) ∈ prog.cfg.edges),
+    interp vs (Post tr) → interp vs (Pre (tr.addEdge hedge))
 
-lemma interp_botV_nil : ⟦ botV L prog ⟧ [] := by
-  intro k l _ v hmem
-  cases hmem
+instance [S : StateInterpretation L prog] :
+    Interp (VariableValues L prog) (S.Proj → Prop) :=
+  ⟨S.interp⟩
 
-omit [FiniteHeightLattice L] in
-lemma interp_sup {vs₁ vs₂ : VariableValues L prog} {ρ : Env}
-    (h : ⟦ vs₁⟧ ρ ∨ ⟦ vs₂ ⟧ ρ) : ⟦ vs₁ ⊔ vs₂ ⟧ ρ := 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))
-
-lemma interp_foldr {vs : VariableValues L prog}
-    {vss : List (VariableValues L prog)} {ρ : Env}
-    (hvs : ⟦ vs ⟧ ρ) (hmem : vs ∈ vss) :
-    ⟦ vss.foldr (· ⊔ ·) (botV L prog) ⟧ ρ := by
+lemma interp_foldr [S : StateInterpretation L prog]
+    {vs : VariableValues L prog} {vss : List (VariableValues L prog)}
+    {p : S.Proj} (hvs : ⟦ vs ⟧ p) (hmem : vs ∈ vss) :
+    ⟦ vss.foldr (· ⊔ ·) (botV L prog) ⟧ p := by
   induction vss with
   | nil => cases hmem
   | cons vs' vss' ih =>
     rcases List.mem_cons.mp hmem with rfl | hmem'
-    · exact interp_sup (Or.inl hvs)
-    · exact interp_sup (Or.inr (ih hmem'))
+    · exact S.interp_sup (Or.inl hvs)
+    · 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
 

lean/Spa/Analysis/Reaching.lean

@@ -1,34 +1,38 @@
 import Spa.Analysis.Forward
-import Spa.Lattice.Bool
+import Spa.Lattice.Finset
 import Spa.Showable
 
 namespace Spa
 
 open Forward
 
-instance : Showable Bool := ⟨fun b => if b then "true" else "false"⟩
+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 := FiniteMap prog.State Bool prog.states
+abbrev DefSet (prog : Program) : Type := Finset prog.State
 
 namespace ReachingAnalysis
 
 variable (prog : Program)
 
-def genSet (s : prog.State) : DefSet prog :=
-  FiniteMap.updating (⊥ : DefSet prog) [s] (fun _ => true)
+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
 
-def eval (s : prog.State) :
-    BasicStmt → VariableValues (DefSet prog) prog → VariableValues (DefSet prog) prog
-  | .assign k _, vs =>
-    FiniteMap.generalizedUpdate id (fun _ _ => genSet prog s) [k] vs
-  | .noop, vs => vs
-
-lemma eval_mono (s : prog.State) (bs : BasicStmt) :
-    Monotone (eval prog s bs) := by
-  cases bs with
-  | assign k e =>
-    exact FiniteMap.generalizedUpdate_monotone monotone_id (fun _ => monotone_const)
-  | noop => exact monotone_id
+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⟩
@@ -36,6 +40,92 @@ instance stmtEvaluator : StmtEvaluator (DefSet prog) 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

@@ -13,6 +13,8 @@ inductive Sign where
   | zero
   deriving DecidableEq
 
+attribute [aesop safe cases] Sign
+
 instance : Showable Sign :=
   ⟨fun
     | .plus => "+"
@@ -57,21 +59,13 @@ def minus : SignLattice → SignLattice → SignLattice
 
 lemma plus_mono₂ : Monotone₂ plus :=
   AboveBelow.monotone₂_of_strict plus
-    (fun y => by cases y <;> rfl)
-    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
-    (fun x hx => by
-      rcases x with _ | _ | s <;>
-        first | exact absurd rfl hx | rfl | (cases s <;> rfl))
+    (fun y => by aesop) (fun x => by aesop)
+    (fun y hy => by aesop) (fun x hx => by aesop)
 
 lemma minus_mono₂ : Monotone₂ minus :=
   AboveBelow.monotone₂_of_strict minus
-    (fun y => by cases y <;> rfl)
-    (fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
-    (fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
-    (fun x hx => by
-      rcases x with _ | _ | s <;>
-        first | exact absurd rfl hx | rfl | (cases s <;> rfl))
+    (fun y => by aesop) (fun x => by aesop)
+    (fun y hy => by aesop) (fun x hx => by aesop)
 
 def interpSign : SignLattice → Value → Prop
   | .bot, _ => False
@@ -117,13 +111,16 @@ 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 (_ + 1), _ => .mk .plus
+  | .num z, _ => signOf z
 
 lemma eval_mono (e : Expr) : Monotone (eval prog e) := by
   induction e with
@@ -145,7 +142,7 @@ lemma eval_mono (e : Expr) : Monotone (eval prog e) := by
           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⟩
@@ -165,6 +162,20 @@ private lemma int_neg_iff (z : ℤ) : (∃ n : ℕ, z = -((n : ℤ) + 1)) ↔ z
   · rintro ⟨n, rfl⟩; omega
   · intro h; exact ⟨(-z - 1).toNat, by omega⟩
 
+/-- `signOf` really does describe the literal it was computed from. -/
+lemma interp_signOf (z : ℤ) : ⟦signOf z⟧ (Value.int z) := by
+  unfold signOf
+  split
+  · case isTrue h => subst h; rfl
+  · rename_i hne
+    split
+    · case isTrue hpos =>
+        simp only [signInterpretation, interpSign, Value.int.injEq, int_pos_iff]
+        exact hpos
+    · case isFalse hnpos =>
+        simp only [signInterpretation, interpSign, Value.int.injEq, int_neg_iff]
+        omega
+
 lemma plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
     (h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
     ⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
@@ -190,9 +201,7 @@ instance eval_valid : ValidExprEvaluator SignLattice prog := by
   | num n =>
     intro _
     show ⟦eval prog (.num n) vs⟧ (.int n)
-    cases n with
-    | zero => rfl
-    | succ n' => exact ⟨n', congrArg Value.int (by norm_cast)⟩
+    exact interp_signOf n
   | var x v hxv =>
     intro hvs
     show ⟦eval prog (.var x) vs⟧ v
@@ -219,6 +228,12 @@ theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
     ⟦ variablesAt prog.finalState (result SignLattice prog) ⟧ ρ :=
   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
 
 end Spa

lean/Spa/Fixedpoint.lean

@@ -12,7 +12,7 @@ def doStep (f : α → α) (hf : Monotone f) :
     ∀ (g : ℕ) (c : LTSeries α), c.length + g = height (α := α) + 1 →
       c.last ≤ f c.last → {a : α // a = f a}
   | 0, c, hlen, _ =>
-    absurd (FiniteHeightLattice.chains_bounded c) (by simp only [height] at hlen; omega)
+    absurd (FiniteHeightLattice.chains_bounded c) (by omega)
   | g + 1, c, hlen, hle =>
     if heq : c.last = f c.last then
       ⟨c.last, heq⟩
@@ -24,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]
-          using FiniteHeightLattice.bot_le α (f ⊥))
+    (by simp)
 
 def aFix (f : α → α) (hf : Monotone f) : α :=
   (fix f hf).1
@@ -40,7 +39,7 @@ lemma doStep_le (f : α → α) (hf : Monotone f)
       (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 simp only [height] at hlen; omega)
+    absurd (FiniteHeightLattice.chains_bounded c) (by omega)
   | g + 1, c, hlen, hle => fun hcb => by
     rw [doStep]
     split
@@ -50,7 +49,7 @@ lemma 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 Fixedpoint
 

lean/Spa/Isomorphism.lean

@@ -1,16 +0,0 @@
-import Spa.Lattice
-
-namespace Spa
-
-def FiniteHeightLattice.transport {α β : Type*} [Lattice β]
-    [I : FiniteHeightLattice α] (f : α → β) (g : β → α)
-    (hf : Monotone f) (hg : Monotone g)
-    (hgf : Function.LeftInverse g f) (hfg : Function.LeftInverse f g) :
-    FiniteHeightLattice β where
-  toLattice := inferInstance
-  longestChain :=
-    I.longestChain.map f (hf.strictMono_of_injective hgf.injective)
-  chains_bounded := fun c =>
-    I.chains_bounded (c.map g (hg.strictMono_of_injective hfg.injective))
-
-end Spa

lean/Spa/Language.lean

@@ -3,56 +3,4 @@ import Spa.Language.Semantics
 import Spa.Language.Graphs
 import Spa.Language.Traces
 import Spa.Language.Properties
-import Mathlib.Data.Finset.Sort
-import Mathlib.Data.String.Basic
-
-namespace Spa
-
-structure Program where
-  rootStmt : Stmt
-
-namespace Program
-
-variable (p : Program)
-
-def cfg : Graph := Graph.wrap p.rootStmt.cfg
-
-abbrev State : Type := p.cfg.Index
-
-def initialState : p.State := p.rootStmt.cfg.wrapInput
-
-def finalState : p.State := p.rootStmt.cfg.wrapOutput
-
-theorem trace {ρ : Env} (h : EvalStmt [] p.rootStmt ρ) :
-    Trace p.cfg p.initialState p.finalState [] ρ := by
-  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
-
-def vars : List String := p.rootStmt.vars.sort (· ≤ ·)
-
-lemma vars_nodup : p.vars.Nodup := Finset.sort_nodup _ _
-
-def states : List p.State := p.cfg.indices
-
-lemma states_complete (s : p.State) : s ∈ p.states := p.cfg.mem_indices s
-
-lemma states_nodup : p.states.Nodup := p.cfg.nodup_indices
-
-def code (st : p.State) : List BasicStmt := p.cfg.nodes st
-
-def incoming (s : p.State) : List p.State := p.cfg.predecessors s
-
-lemma incoming_initialState_eq_nil : p.incoming p.initialState = [] :=
-  Graph.wrap_predecessors_eq_nil p.rootStmt.cfg p.initialState
-    (by rw [Graph.wrap_inputs]; exact List.mem_singleton_self _)
-
-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
-
-end Program
-
-end Spa
+import Spa.Language.Program

lean/Spa/Language/Base.lean

@@ -5,9 +5,13 @@ 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. The `Spa/Language/Tagged/Basic.lean`
-file provides an auto-derived version of the `Expr`, `BasicStmt`, and `Stmt` data
-types with unique IDs per condtructor, enabling in-AST pointers.
+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.
 
 -/
 
@@ -18,7 +22,7 @@ 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).

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

@@ -25,6 +25,15 @@ 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)
@@ -130,9 +139,9 @@ def loopOut (g : GGraph α) : Fin (2 + g.size) := (1 : Fin 2).castAdd g.size
 
     This is technically sloppy (see module comment), but it's simple.
 -/
-def loop (g : GGraph (List β)) : GGraph (List β) where
+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 := g.edges.finNatAddProd 2 ++
     ((g.loopIn, ·) <$> g.inputs.finNatAdd 2)  ++
     ((·, g.loopOut) <$> g.outputs.finNatAdd 2) ++
@@ -140,9 +149,9 @@ def loop (g : GGraph (List β)) : GGraph (List β) where
   inputs := [g.loopIn]
   outputs := [g.loopOut]
 
-@[simp] lemma loop_inputs (g : GGraph (List β)) : (loop g).inputs = [g.loopIn] := rfl
+@[simp] lemma loop_inputs (g : GGraph (Option β)) : (loop g).inputs = [g.loopIn] := rfl
 
-@[simp] lemma loop_outputs (g : GGraph (List β)) : (loop g).outputs = [g.loopOut] := rfl
+@[simp] lemma loop_outputs (g : GGraph (Option β)) : (loop g).outputs = [g.loopOut] := rfl
 
 /-- Creates a single-node graph whose node contains the given value. -/
 def singleton (a : α) : GGraph α where
@@ -154,8 +163,24 @@ def singleton (a : α) : GGraph α where
 
 /-- Creates a new graph with a single input and single output node. Useful to ensure there's
     a single point of entry and single point of exit. -/
-def wrap (g : GGraph (List β)) : GGraph (List β) :=
-  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
@@ -176,18 +201,118 @@ def wrap (g : GGraph (List β)) : GGraph (List β) :=
   funext i
   refine Fin.addCases ?_ ?_ i <;> intro j <;> simp [Fin.append_left, Fin.append_right]
 
-@[simp] lemma map_loop (h : β → γ) (g : GGraph (List β)) :
-    (List.map h) <$> (loop g) = loop (List.map h <$> g) := by
+@[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 (List β)) :
-    (List.map h) <$> wrap g = wrap (List.map h <$> g) := by
+@[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. -/
@@ -205,6 +330,35 @@ lemma nodup_indices : g.indices.Nodup :=
 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}
@@ -220,12 +374,12 @@ lemma edge_of_mem_predecessors {idx₁ idx₂ : g.Index}
 end GGraph
 
 /-- "Normal" graphs, for the purposes of the analyses in this
-    framework, have basic blocks in their nodes, and nothing else. -/
-abbrev Graph : Type := GGraph (List BasicStmt)
+    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)
+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
@@ -235,7 +389,7 @@ end Graph
 open Graph in
 def Stmt.cfg : Stmt → Graph
   -- A basic statement goes into a single basic block
-  | .basic bs => singleton [bs]
+  | .basic bs => singleton (some bs)
   -- Sequencing of statements corresponds naturally to CFG sequencing
   | .andThen s₁ s₂ => s₁.cfg ⤳  s₂.cfg
   -- An if can execute either one branch or the other; overlap them.

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,184 +1,217 @@
 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
 
-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
-
-/-! ### Trace embeddings -/
-
 section Embeddings
 
 variable {g₁ g₂ : Graph} {ρ₁ ρ₂ : Env}
 
-lemma Trace.overlay_left {idx₁ idx₂ : g₁.Index}
+/-- When two graphs are overlaid, for each trace in the left graph,
+    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
-  induction tr with
-  | 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)
+    Trace (g₁ ∙ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ :=
+  tr.embed (GGraph.Embed.overlayLeft g₁ g₂)
 
-lemma Trace.overlay_right {idx₁ idx₂ : g₂.Index}
+/-- When two graphs are overlaid, for each trace in the right graph,
+    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
-  induction tr with
-  | 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)
+    Trace (g₁ ∙ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ :=
+  tr.embed (GGraph.Embed.overlayRight g₁ g₂)
 
-lemma Trace.sequence_left {idx₁ idx₂ : g₁.Index}
+/-- When two graphs are sequenced, for each trace in the first graph,
+    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
-  induction tr with
-  | 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))
+    Trace (g₁ ⤳ g₂) (idx₁.castAdd g₂.size) (idx₂.castAdd g₂.size) ρ₁ ρ₂ :=
+  tr.embed (GGraph.Embed.sequenceLeft g₁ g₂)
 
-lemma Trace.sequence_right {idx₁ idx₂ : g₂.Index}
+/-- When two graphs are sequenced, for each trace in the second graph,
+   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
-  induction tr with
-  | 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))
+    Trace (g₁ ⤳ g₂) (idx₁.natAdd g₁.size) (idx₂.natAdd g₁.size) ρ₁ ρ₂ :=
+  tr.embed (GGraph.Embed.sequenceRight g₁ g₂)
 
-lemma EndToEndTrace.overlay_left (etr : EndToEndTrace g₁ ρ₁ ρ₂) :
+/-- Equivalent of `Trace.overlay_left` for end-to-end traces. -/
+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.overlay_left⟩
 
-lemma EndToEndTrace.overlay_right (etr : EndToEndTrace g₂ ρ₁ ρ₂) :
+/-- Equivalent of `Trace.overlay_right` for end-to-end traces. -/
+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.overlay_right⟩
 
-lemma EndToEndTrace.concat {ρ₃ : Env} (etr₁ : EndToEndTrace g₁ ρ₁ ρ₂)
-    (etr₂ : EndToEndTrace g₂ ρ₂ ρ₃) : EndToEndTrace (g₁ ⤳ g₂) ρ₁ ρ₃ := by
-  obtain ⟨i₁, h₁, i₂, h₂, tr₁⟩ := etr₁
-  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
-  refine ⟨i₁.castAdd g₂.size, List.mem_map_of_mem _ h₁,
-          j₂.natAdd g₁.size, List.mem_map_of_mem _ k₂,
-          Trace.concat tr₁.sequence_left ?_ tr₂.sequence_right⟩
+/-- Execute the left operand and follow the connecting edge to the right operand. -/
+noncomputable def EndToEndTrace.beforeRight {ρ₃ : Env}
+    (left : EndToEndTrace g₁ ρ₁ ρ₂) (right : EndToEndTrace g₂ ρ₂ ρ₃) :
+    Traceₗ (g₁ ⤳ g₂) (left.entry.castAdd g₂.size) (right.entry.natAdd g₁.size) ρ₁ ρ₂ := by
+  refine left.trace.sequence_left.addEdge ?_
   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}
 
-lemma Trace.loop {idx₁ idx₂ : g.Index} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) :
-    Trace (Graph.loop g) (idx₁.natAdd 2) (idx₂.natAdd 2) ρ₁ ρ₂ := by
-  induction tr with
-  | 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)))
+/-- A trace through a body CFG still exists (up to reindexing) in a zero-or-more loop CFG. -/
+noncomputable def Trace.loop {idx₁ idx₂ : g.Index} (tr : Trace g idx₁ idx₂ ρ₁ ρ₂) :
+    Trace (Graph.loop g) (idx₁.natAdd 2) (idx₂.natAdd 2) ρ₁ ρ₂ :=
+  tr.embed (GGraph.Embed.loop g)
 
+/-- The beginning node of a loop graph is empty. -/
 private lemma loop_nodes_at_in :
-    (Graph.loop g).nodes g.loopIn = [] :=
-  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
 
+/-- The ending node of a loop graph is empty. -/
 private lemma loop_nodes_at_out :
-    (Graph.loop g).nodes g.loopOut = [] :=
-  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
 
-lemma EndToEndTrace.loop (etr : EndToEndTrace g ρ₁ ρ₂) :
-    EndToEndTrace (Graph.loop g) ρ₁ ρ₂ := by
-  obtain ⟨i₁, h₁, i₂, h₂, tr⟩ := etr
-  -- the edge in → (2 ↑ʳ i₁), reached through the second edge group
-  have hin : (g.loopIn, i₁.natAdd 2) ∈ (Graph.loop g).edges := by
+/-- Execute the empty loop header and follow its edge into this body execution. -/
+noncomputable def EndToEndTrace.beforeBody (body : EndToEndTrace g ρ₁ ρ₂) :
+    Traceₗ (Graph.loop g) g.loopIn (body.entry.natAdd 2) ρ₁ ρ₁ := by
+  refine (Trace.single (loop_nodes_at_in ▸ EvalBasicStmtOpt.none)).addEdge ?_
   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₁)
-  -- 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)))
+  exact List.mem_map_of_mem _ (List.mem_map_of_mem _ body.entry_mem)
 
+/-- 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 _ _
 
-lemma EndToEndTrace.loop_concat (etr₁ : EndToEndTrace (Graph.loop g) ρ₁ ρ₂)
+/-- Complete an iteration and follow the back edge before the remaining loop execution. -/
+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₁
-  obtain ⟨j₁, k₁, j₂, k₂, tr₂⟩ := etr₂
-  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₂⟩
+  exact ⟨etr₁.entry, etr₁.entry_mem, etr₂.exit, etr₂.exit_mem,
+    etr₁.beforeRest etr₂ ++ etr₂.trace⟩
 
-lemma EndToEndTrace.loop_empty {ρ : Env} : EndToEndTrace (Graph.loop g) ρ ρ := by
+/-- A loop can be executed zero times. -/
+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_out ▸ EvalBasicStmts.nil))⟩
+    Trace.single (loop_nodes_at_in ▸ EvalBasicStmtOpt.none) ++< hedge >++
+      Trace.single (loop_nodes_at_out ▸ EvalBasicStmtOpt.none)⟩
 
 end Loop
 
-/-! ### Singletons, wrap, and the main result -/
-
-lemma EndToEndTrace.singleton {bss : List BasicStmt} {ρ₁ ρ₂ : Env}
-    (h : EvalBasicStmts ρ₁ bss ρ₂) : EndToEndTrace (Graph.singleton bss) ρ₁ ρ₂ :=
+/-- 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}
+    (h : EvalBasicStmtOpt ρ₁ o ρ₂) : EndToEndTrace (Graph.singleton o) ρ₁ ρ₂ :=
   ⟨(0 : Fin 1), List.mem_singleton_self _, (0 : Fin 1), List.mem_singleton_self _,
    Trace.single h⟩
 
-lemma EndToEndTrace.singleton_nil (ρ : Env) :
-    EndToEndTrace (Graph.singleton []) ρ ρ :=
-  EndToEndTrace.singleton EvalBasicStmts.nil
+/-- If a CFG's only node is empty, the no-op trace exists through it. -/
+noncomputable def EndToEndTrace.singleton_nil (ρ : Env) :
+    EndToEndTrace (Graph.singleton none) ρ ρ :=
+  EndToEndTrace.singleton EvalBasicStmtOpt.none
 
-lemma EndToEndTrace.wrap {g : Graph} {ρ₁ ρ₂ : Env}
+/-- Invoking 'Graph.wrap` (which ensures a single entry and exit node for a CFG)
+    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 ρ₂))
 
-theorem Stmt.cfg_sufficient {s : Stmt} {ρ₁ ρ₂ : Env}
+/-- Reach the selected root entry through the program's empty wrapper node. -/
+noncomputable def EndToEndTrace.beforeRoot {g : Graph} {ρ₁ ρ₂ : Env}
+    (root : EndToEndTrace g ρ₁ ρ₂) :
+    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 =>
@@ -190,44 +223,17 @@ theorem Stmt.cfg_sufficient {s : Stmt} {ρ₁ ρ₂ : Env}
   | whileFalse ρ e s _ =>
     exact EndToEndTrace.loop_empty
 
-/-! ### The wrapped graph's entry has no predecessors (Agda's "ugly" block) -/
+namespace Program
 
-def Graph.wrapInput (g : Graph) : (Graph.wrap g).Index :=
-  (0 : Fin 1).castAdd ((g ⤳ Graph.singleton []).size)
+noncomputable def trace (p : Program) {ρ : Env} (h : EvalStmt [] p.rootStmt ρ) :
+    Trace p.cfg p.initialState p.finalState [] ρ := by
+  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
 
-def Graph.wrapOutput (g : Graph) : (Graph.wrap g).Index :=
-  Fin.natAdd 1 ((Fin.natAdd g.size (0 : Fin 1)))
+end Program
 
-lemma Graph.wrap_inputs (g : Graph) :
-    (Graph.wrap g).inputs = [g.wrapInput] := rfl
-
-lemma Graph.wrap_outputs (g : Graph) :
-    (Graph.wrap g).outputs = [g.wrapOutput] := rfl
-
-private lemma not_mem_edges_castAdd_sequence {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, 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
-
-lemma 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 [GGraph.predecessors, List.filter_eq_nil_iff]
-  intro idx' _
-  simpa using not_mem_edges_castAdd_sequence (g₂ := g ⤳ Graph.singleton []) 0 idx'
 
 end Spa

lean/Spa/Language/Semantics.lean

@@ -2,12 +2,27 @@ 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)
 
 inductive Env.Mem : String × Value → Env → Prop
@@ -15,8 +30,10 @@ inductive Env.Mem : String × Value → Env → Prop
   | there (s s' : String) (v v' : Value) (ρ : Env) :
       ¬(s = s') → Env.Mem (s, v) ρ → Env.Mem (s, v) ((s', v') :: ρ)
 
+/-- 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₂ : ℤ) :
@@ -26,18 +43,25 @@ inductive EvalExpr : Env → Expr → Value → Prop
       EvalExpr ρ e₁ (.int z₁) → EvalExpr ρ e₂ (.int z₂) →
       EvalExpr ρ (.sub e₁ e₂) (.int (z₁ - z₂))
 
-inductive EvalBasicStmt : Env → BasicStmt → Env → Prop
+/-- Inference rules for evaluating a basic statement (`Spa.BasicStmt`) in
+    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) :: ρ)
 
-inductive EvalBasicStmts : Env → List BasicStmt → Env → Prop
-  | nil {ρ : Env} : EvalBasicStmts ρ [] ρ
-  | cons {ρ₁ ρ₂ ρ₃ : Env} {bs : BasicStmt} {bss : List BasicStmt} :
-      EvalBasicStmt ρ₁ bs ρ₂ → EvalBasicStmts ρ₂ bss ρ₃ →
-      EvalBasicStmts ρ₁ (bs :: bss) ρ₃
+/-- Inference rules for evaluating a basic-statement-or-nothing,
+    which is the current representation of CFGs nodes. -/
+inductive EvalBasicStmtOpt : Env → Option BasicStmt → Env → Type
+  | none {ρ : Env} : EvalBasicStmtOpt ρ Option.none ρ
+  | some {ρ₁ ρ₂ : Env} {bs : BasicStmt} :
+      EvalBasicStmt ρ₁ bs ρ₂ → EvalBasicStmtOpt ρ₁ (Option.some bs) ρ₂
 
-inductive EvalStmt : Env → Stmt → Env → Prop
+/-- Inference rules for evaluating statements (`Spa.Stmt`) in a given
+    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) :
@@ -57,6 +81,15 @@ inductive EvalStmt : Env → Stmt → Env → Prop
       EvalExpr ρ e (.int 0) →
       EvalStmt ρ (.whileLoop e s) ρ
 
+/-- For the purpose of static analysis, lattices we define describe program
+    state, or better yet, they describe _values_ in the program.
+    This class should be provided by each analysis' lattice (see also `Spa/Analysis/Forward.lean`)
+    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

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,26 +1,263 @@
-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
 
-inductive Trace (g : Graph) : g.Index → g.Index → Env → Env → Prop
-  | single {ρ₁ ρ₂ : Env} {idx : g.Index} :
-      EvalBasicStmts ρ₁ (g.nodes idx) ρ₂ → Trace g idx idx ρ₁ ρ₂
-  | edge {ρ₁ ρ₂ ρ₃ : Env} {idx₁ idx₂ idx₃ : g.Index} :
-      EvalBasicStmts ρ₁ (g.nodes idx₁) ρ₂ → (idx₁, idx₂) ∈ g.edges →
-      Trace g idx₂ idx₃ ρ₂ ρ₃ → Trace g idx₁ idx₃ ρ₁ ρ₃
+/-- A node together with the phase of its execution. -/
+inductive Position (α : Type) where
+  | before : α → Position α
+  | after : α → Position α
+  deriving DecidableEq
 
-lemma 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₂)
+abbrev Configuration (g : Graph) := Position g.Index × Env
 
-inductive EndToEndTrace (g : Graph) (ρ₁ ρ₂ : Env) : Prop
-  | intro (idx₁ : g.Index) (idx₁_mem : idx₁ ∈ g.inputs)
-      (idx₂ : g.Index) (idx₂_mem : idx₂ ∈ g.outputs)
-      (trace : Trace g idx₁ idx₂ ρ₁ ρ₂) : EndToEndTrace g ρ₁ ρ₂
+/-- Executing a node changes the environment; following an edge preserves it. -/
+inductive Step (g : Graph) : Configuration g → Configuration g → Type where
+  | execute {i : g.Index} {ρ ρ' : Env}
+      (h : EvalBasicStmtOpt ρ (g.nodes i) ρ') :
+      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

@@ -12,6 +12,18 @@ 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. -/
@@ -61,51 +73,79 @@ lemma foldl_mono' (l : List α) (f : β → α → β)
   | 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
 
+/-- Since a singleton type's preorder has no nonempty `<` chains,
+    they are vacuously bounded by any minimum height. -/
+lemma 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 _ _)
+
 /-- A finite height lattice is a lattice in which all chains $a < \ldots < z$ have a maximum height `height`. -/
-class FiniteHeightLattice (α : Type*) extends Lattice α where
-  longestChain : LTSeries α
-  chains_bounded : BoundedChains α longestChain.length
+class FiniteHeightLattice (α : Type*) extends Lattice α, OrderBot α, OrderTop α where
+  height : ℕ
+  chains_bounded : BoundedChains α height
 
 -- a < ... < z
 -- ----------- length <= height
 
 namespace FiniteHeightLattice
 
-def height (α : Type*) [FiniteHeightLattice α] : ℕ :=
-  (longestChain (α := α)).length
+/-- 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.
 
-variable (α : Type*) [FiniteHeightLattice α]
+    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))
 
-instance (priority := 100) : Bot α := ⟨(longestChain (α := α)).head⟩
-instance (priority := 100) : Top α := ⟨(longestChain (α := α)).last⟩
-
-/-- The bottom element `⊥` of a finite height lattice is _actually_ the least element. -/
-lemma bot_le (a : α) : (⊥ : α) ≤ a := by
-  by_cases heq : ⊥ ⊓ a = ⊥
-  · exact inf_eq_left.mp heq
-  · exfalso
-    have hlt : ⊥ ⊓ a < (longestChain (α := α)).head :=
-      lt_of_le_of_ne inf_le_left heq
-    have hbound := chains_bounded ((longestChain (α := α)).cons (⊥ ⊓ a) hlt)
-    rw [RelSeries.cons_length] at hbound
-    omega
-
-/-- The top element `⊤` of a finite height lattice is _actually_ the greatest element. -/
-lemma le_top (a : α) : a ≤ (⊤ : α) := by
-  by_cases heq : a ⊔ ⊤ = ⊤
-  · exact sup_eq_right.mp heq
-  · exfalso
-    have hlt : (longestChain (α := α)).last < a ⊔ ⊤ :=
-      lt_of_le_of_ne le_sup_right (Ne.symm heq)
-    have hbound := chains_bounded ((longestChain (α := α)).snoc (a ⊔ ⊤) hlt)
-    rw [RelSeries.snoc_length] at hbound
-    omega
+/-- 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,7 +1,38 @@
 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
 
+/-- The above-below lattice, with bottom element `bot` and top element `top`. -/
+@[aesop safe cases]
 inductive AboveBelow (α : Type*) where
   | bot
   | top
@@ -48,37 +79,12 @@ instance : Min (AboveBelow α) where
 @[simp] lemma mk_inf_mk (x y : α) :
     (mk x ⊓ mk y : AboveBelow α) = if x = y then mk x else bot := rfl
 
-protected lemma sup_comm (a b : AboveBelow α) : a ⊔ b = b ⊔ a := by
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp only
-    [bot_sup, sup_bot, top_sup, sup_top, mk_sup_mk]
-  split_ifs with h₁ h₂ h₂ <;> simp_all
-
-protected lemma 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
-
-protected lemma 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
-
-protected lemma 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
-
-protected lemma 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)
-
-protected lemma 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)
+protected lemma sup_comm (a b : AboveBelow α) : a ⊔ b = b ⊔ a := by aesop
+protected lemma sup_assoc (a b c : AboveBelow α) : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) := by aesop
+protected lemma inf_comm (a b : AboveBelow α) : a ⊓ b = b ⊓ a := by aesop
+protected lemma inf_assoc (a b c : AboveBelow α) : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) := by aesop
+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
 
 instance : Lattice (AboveBelow α) :=
   Lattice.mk' AboveBelow.sup_comm AboveBelow.sup_assoc
@@ -93,129 +99,80 @@ lemma bot_le' (a : AboveBelow α) : (bot : AboveBelow α) ≤ a :=
 lemma le_top' (a : AboveBelow α) : a ≤ (top : AboveBelow α) :=
   le_iff.mpr (sup_top a)
 
-lemma bot_lt_mk (x : α) : (bot : AboveBelow α) < mk x :=
-  lt_of_le_of_ne (bot_le' _) (by simp)
+instance : OrderBot (AboveBelow α) where
+  bot := bot
+  bot_le := bot_le'
 
-lemma mk_lt_top (x : α) : (mk x : AboveBelow α) < top :=
-  lt_of_le_of_ne (le_top' _) (by simp)
+instance : OrderTop (AboveBelow α) where
+  top := top
+  le_top := le_top'
 
-lemma bot_lt_top : (bot : AboveBelow α) < top :=
-  lt_of_le_of_ne (bot_le' _) (by simp)
+lemma bot_lt_mk (x : α) : (bot : AboveBelow α) < mk x := 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)
 
 lemma le_cases {a b : AboveBelow α} (h : a ≤ b) :
     a = bot ∨ b = top ∨ a = b := by
-  have hsup := le_iff.mp h
-  rcases a with _ | _ | x <;> rcases b with _ | _ | y
-  · 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)
+  rw [le_iff] at h
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;> simp_all
 
-/-- Monotonicity for *strict* operations on flat lattices: if `f` sends `⊥` to
-`⊥` (in either argument) and `⊤` to `⊤` (against any non-`⊥` argument), it is
-monotone in both arguments — regardless of its values on plain elements.
-`Analysis/Sign.agda` and `Analysis/Constant.agda` postulated exactly these
-monotonicity facts for their `plus`/`minus`, all of which have this shape. -/
+/-- If `f` sends `⊥` to `⊥` (in both arguments) and `⊤` to `⊤`
+    (against any non-`⊥` argument), it is monotone in both arguments.
+    The values of the the elements in `α` are irrelevant since they
+    are always incomparable. This makes it easy to prove monotonicity
+    for operations that "just" combine their flat elements, or give up. -/
 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
-  · intro y a b hab
-    show f a y ≤ f b y
-    rcases le_cases hab with rfl | rfl | rfl
-    · rw [hbotl]; exact bot_le' _
-    · rcases eq_or_ne y bot with rfl | hy
-      · rw [hbotr, hbotr]
-      · rw [htopl y hy]; exact le_top' _
-    · exact le_rfl
-  · intro x a b hab
-    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 -/
+  constructor <;> intro c a b hab <;>
+    rcases eq_or_ne c bot with rfl | hc <;>
+    rcases le_cases hab with rfl | rfl | rfl <;>
+    simp [hbotl, hbotr, htopl, htopr, bot_le', le_top', *]
 
 section Interp
 
 variable {V : Type*} {P : AboveBelow α → V → Prop}
 
+/-- As long as the interpretation of a the above-below lattice respects the
+    fact that `bot` means "impossible", interpreting the above-below
+    lattice agrees with its `⊔`. -/
 lemma interp_sup_of (hbot : ∀ v, ¬P bot v) (htop : ∀ v, P top v)
-    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by
-  rcases s₁ with _ | _ | x
-  · rw [bot_sup]; exact h.resolve_left (hbot v)
-  · rw [top_sup]; exact htop v
-  · rcases s₂ with _ | _ | y
-    · rw [sup_bot]; exact h.resolve_right (hbot v)
-    · rw [sup_top]; exact htop v
-    · rw [mk_sup_mk]
-      split
-      · next heq => subst heq; exact h.elim id id
-      · exact htop v
+    {s₁ s₂ : AboveBelow α} (v : V) (h : P s₁ v ∨ P s₂ v) : P (s₁ ⊔ s₂) v := by aesop
 
+/-- As long as two distinct values in the flat domain don't overlap,
+    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
-  · 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]
+  rcases s₁ with _ | _ | x <;> rcases s₂ with _ | _ | y <;> simp_all
   split
-      · next heq => subst heq; exact h.1
-      · next hne => exact absurd h (hdisj hne v)
+  · exact h.2
+  · 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
-(Agda's `isLongest` / `x≺[y]⇒x≡⊥` / `[x]≺y⇒y≡⊤` case analysis lives here). -/
-def rank : AboveBelow α → ℕ
+/-- synthetic rank of an element, used to prove chain bounds. -/
+private def rank : AboveBelow α → ℕ
   | bot => 0
   | mk _ => 1
   | top => 2
 
-/-- Agda: the impossibility of `[x] ≺ [y]` (combines `x≺[y]⇒x≡⊥` and
-`[x]≺y⇒y≡⊤`: the flat middle layer is an antichain). -/
+/-- It's not possible for any two lifted flat-domain elements to be less
+    than one another. -/
 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
-  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)
+  rcases le_cases hle with h | h | h <;> simp_all
 
+/-- 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
-  · exact absurd hab (lt_irrefl _)
-  · 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)
+  rcases a with _ | _ | x <;> rcases b with _ | _ | y <;>
+    simp_all [rank, not_mk_lt_mk, (bot_le' _).not_lt, (le_top' _).not_lt]
 
+/-- All chains in the above-below lattice have at most 2 comparisons. -/
 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
@@ -224,10 +181,9 @@ lemma boundedChains : BoundedChains (AboveBelow α) 2 := fun c => by
 
 instance [Inhabited α] : FiniteHeightLattice (AboveBelow α) where
   toLattice := inferInstance
-  longestChain :=
-    ((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)
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
+  height := 2
   chains_bounded := boundedChains
 
 end AboveBelow

lean/Spa/Lattice/Bool.lean

@@ -29,8 +29,9 @@ lemma boundedChains : BoundedChains Bool 1 := fun c => by
 
 instance : FiniteHeightLattice Bool where
   toLattice := inferInstance
-  longestChain := (RelSeries.singleton _ (⊥ : Bool)).snoc (⊤ : Bool)
-    (by rw [RelSeries.last_singleton]; exact bot_lt_top)
+  toOrderBot := inferInstance
+  toOrderTop := inferInstance
+  height := 1
   chains_bounded := boundedChains
 
 end Bool

lean/Spa/Lattice/FiniteMap.lean

@@ -1,64 +1,79 @@
 import Spa.Lattice.Tuple
 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 _ := Fin ks.length → B
+/-- Key-value map with domain `α` and codomain `β`, with possible keys $\textit{ks} \subseteq \alpha$. -/
+def FiniteMap (α β : Type*) (ks : List α) : Type _ := Fin ks.length → β
 
 namespace FiniteMap
 
-variable {A B : Type*} {ks : List A}
+variable {α β : Type*} {ks : List α}
 
-instance [Lattice B] : Lattice (FiniteMap A B ks) :=
-  inferInstanceAs (Lattice (Fin ks.length → B))
+instance [Lattice β] : Lattice (FiniteMap α β ks) :=
+  inferInstanceAs (Lattice (Fin ks.length → β))
 
-instance [FiniteHeightLattice B] : FiniteHeightLattice (FiniteMap A B ks) :=
-  inferInstanceAs (FiniteHeightLattice (Fin ks.length → B))
+instance [FiniteHeightLattice β] : FiniteHeightLattice (FiniteMap α β ks) :=
+  inferInstanceAs (FiniteHeightLattice (Fin ks.length → β))
 
-instance [DecidableEq B] : DecidableEq (FiniteMap A B ks) :=
-  inferInstanceAs (DecidableEq (Fin ks.length → B))
+instance [DecidableEq β] : DecidableEq (FiniteMap α β ks) :=
+  inferInstanceAs (DecidableEq (Fin ks.length → β))
 
-instance : Membership (A × B) (FiniteMap A B ks) :=
+instance : Membership (α × β) (FiniteMap α β ks) :=
   ⟨fun fm p => ∃ i : Fin ks.length, ks.get i = p.1 ∧ fm i = p.2⟩
 
-lemma mem_iff {fm : FiniteMap A B ks} {p : A × B} :
+lemma mem_iff {fm : FiniteMap α β ks} {p : α × β} :
     p ∈ fm ↔ ∃ i : Fin ks.length, ks.get i = p.1 ∧ fm i = p.2 := Iff.rfl
 
-def MemKey (k : A) (_fm : FiniteMap A B ks) : Prop := k ∈ ks
+def MemKey (k : α) (_fm : FiniteMap α β ks) : Prop := k ∈ ks
 
-lemma MemKey_iff {k : A} {fm : FiniteMap A B ks} : MemKey k fm ↔ k ∈ ks := Iff.rfl
+lemma MemKey_iff {k : α} {fm : FiniteMap α β ks} : MemKey k fm ↔ k ∈ ks := Iff.rfl
 
-instance {k : A} {fm : FiniteMap A B ks} [DecidableEq A] : Decidable (MemKey k fm) :=
+instance {k : α} {fm : FiniteMap α β ks} [DecidableEq α] : Decidable (MemKey k fm) :=
   decidable_of_iff _ MemKey_iff.symm
 
-lemma mem_key_of_mem {k : A} {v : B} {fm : FiniteMap A B ks}
+lemma mem_key_of_mem {k : α} {v : β} {fm : FiniteMap α β ks}
     (h : (k, v) ∈ fm) : MemKey k fm := by
   obtain ⟨i, hi, _⟩ := h
   have hik : ks.get i = k := hi
   exact hik ▸ ks.get_mem i
 
-def toList (fm : FiniteMap A B ks) : List (A × B) :=
+def toList (fm : FiniteMap α β ks) : List (α × β) :=
   (List.finRange ks.length).map fun i => (ks.get i, fm i)
 
-lemma le_def [Lattice B] {fm₁ fm₂ : FiniteMap A B ks} :
+lemma le_def [Lattice β] {fm₁ fm₂ : FiniteMap α β ks} :
     fm₁ ≤ fm₂ ↔ ∀ i, fm₁ i ≤ fm₂ i := Iff.rfl
 
 section Locate
 
-variable [DecidableEq A]
+variable [DecidableEq α]
 
 /-- Recover the value stored under a present key. -/
-def locate {k : A} {fm : FiniteMap A B ks} (h : MemKey k fm) :
-    {v : B // (k, v) ∈ fm} :=
+def locate {k : α} {fm : FiniteMap α β ks} (h : MemKey k fm) :
+    {v : β // (k, v) ∈ fm} :=
   let i : Fin ks.length := ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩
   ⟨fm i, i, List.idxOf_get _, rfl⟩
 
 end Locate
 
-variable [Lattice B]
+variable [Lattice β]
 
-lemma le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap A B ks}
-    (hle : fm₁ ≤ fm₂) {k : A} {v₁ v₂ : B}
+lemma le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap α β ks}
+    (hle : fm₁ ≤ fm₂) {k : α} {v₁ v₂ : β}
     (h₁ : (k, v₁) ∈ fm₁) (h₂ : (k, v₂) ∈ fm₂) : v₁ ≤ v₂ := by
   obtain ⟨i, hi, rfl⟩ := h₁
   obtain ⟨j, hj, rfl⟩ := h₂
@@ -66,38 +81,44 @@ lemma le_of_mem_mem (hks : ks.Nodup) {fm₁ fm₂ : FiniteMap A B ks}
   subst hij
   exact le_def.mp hle i
 
-lemma mem_sup {fm₁ fm₂ : FiniteMap A B ks} {k : A} {v : B}
+lemma mem_sup {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⟩⟩
 
+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) : FiniteMap A B ks :=
+def updating (fm : FiniteMap α β ks) (ks' : List α) (g : α → β) : FiniteMap α β ks :=
   fun i => if ks.get i ∈ ks' then g (ks.get i) else fm i
 
-omit [Lattice B] in
-lemma eq_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
-    {ks' : List A} {g : A → B} (hk : k ∈ ks')
+omit [Lattice β] in
+lemma eq_of_mem_updating {k : α} {v : β} {fm : FiniteMap α β ks}
+    {ks' : List α} {g : α → β} (hk : k ∈ ks')
     (h : (k, v) ∈ updating fm ks' g) : v = g k := by
   obtain ⟨i, hi, rfl⟩ := h
   show (if ks.get i ∈ ks' then g (ks.get i) else fm i) = g k
   rw [if_pos (by rw [hi]; exact hk), hi]
 
-omit [Lattice B] in
-lemma mem_of_mem_updating {k : A} {v : B} {fm : FiniteMap A B ks}
-    {ks' : List A} {g : A → B} (hk : k ∉ ks')
+omit [Lattice β] in
+lemma mem_of_mem_updating {k : α} {v : β} {fm : FiniteMap α β ks}
+    {ks' : List α} {g : α → β} (hk : k ∉ ks')
     (h : (k, v) ∈ updating fm ks' g) : (k, v) ∈ fm := by
   obtain ⟨i, hi, rfl⟩ := h
   refine ⟨i, hi, ?_⟩
   show fm i = (if ks.get i ∈ ks' then g (ks.get i) else fm i)
   rw [if_neg (by rw [hi]; exact hk)]
 
-lemma updating_mono {fm₁ fm₂ : FiniteMap A B ks} {ks' : List A}
-    {g₁ g₂ : A → B} (hfm : fm₁ ≤ fm₂) (hg : ∀ k, g₁ k ≤ g₂ k) :
+lemma updating_mono {fm₁ fm₂ : FiniteMap α β ks} {ks' : List α}
+    {g₁ g₂ : α → β} (hfm : fm₁ ≤ fm₂) (hg : ∀ k, g₁ k ≤ g₂ k) :
     updating fm₁ ks' g₁ ≤ updating fm₂ ks' g₂ := by
   rw [le_def]
   intro i
@@ -111,25 +132,25 @@ 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)
-    (ks' : List A) : L → FiniteMap A B ks := fun l =>
+def generalizedUpdate (f : L → FiniteMap α β ks) (g : α → L → β)
+    (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 α}
 
 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
-lemma generalizedUpdate_mem_eq {k : A} {v : B} {l : L} (hk : k ∈ ks')
+omit [Lattice β] [Lattice L] in
+lemma generalizedUpdate_mem_eq {k : α} {v : β} {l : L} (hk : k ∈ ks')
     (h : (k, v) ∈ generalizedUpdate f g ks' l) : v = g k l :=
   eq_of_mem_updating (g := fun k => g k l) hk h
 
-omit [Lattice B] [Lattice L] in
-lemma generalizedUpdate_not_mem_backward {k : A} {v : B} {l : L} (hk : k ∉ ks')
+omit [Lattice β] [Lattice L] in
+lemma generalizedUpdate_not_mem_backward {k : α} {v : β} {l : L} (hk : k ∉ ks')
     (h : (k, v) ∈ generalizedUpdate f g ks' l) : (k, v) ∈ f l :=
   mem_of_mem_updating hk h
 
@@ -137,19 +158,19 @@ end GeneralizedUpdate
 
 section ValuesAt
 
-variable [DecidableEq A]
+variable [DecidableEq α]
 
 /-- The value stored under `k`, if `k` is a key. -/
-private def lookup (fm : FiniteMap A B ks) (k : A) : Option B :=
+private def lookup (fm : FiniteMap α β ks) (k : α) : Option β :=
   if h : k ∈ ks then some (fm ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none
 
 /-- The values stored under the keys `ks'` (skipping any that are not keys). -/
-def valuesAt (fm : FiniteMap A B ks) (ks' : List A) : List B :=
+def valuesAt (fm : FiniteMap α β ks) (ks' : List α) : List β :=
   ks'.filterMap fm.lookup
 
-omit [Lattice B] in
-lemma mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap A B ks} {k : A} {v : B}
-    {ks' : List A} (hk : k ∈ ks') (h : (k, v) ∈ fm) : v ∈ valuesAt fm ks' := by
+omit [Lattice β] in
+lemma mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap α β ks} {k : α} {v : β}
+    {ks' : List α} (hk : k ∈ ks') (h : (k, v) ∈ fm) : v ∈ valuesAt fm ks' := by
   refine List.mem_filterMap.mpr ⟨k, hk, ?_⟩
   obtain ⟨i, hi, rfl⟩ := h
   have hik : ks.get i = k := hi
@@ -161,7 +182,7 @@ lemma mem_valuesAt (hks : ks.Nodup) {fm : FiniteMap A B ks} {k : A} {v : B}
     hks.get_inj_iff.mp (by rw [List.idxOf_get, hi])
   rw [this]
 
-private lemma lookup_rel {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂) (k : A) :
+private lemma lookup_rel {fm₁ fm₂ : FiniteMap α β ks} (hle : fm₁ ≤ fm₂) (k : α) :
     Option.Rel (· ≤ ·) (fm₁.lookup k) (fm₂.lookup k) := by
   show Option.Rel _
     (if h : k ∈ ks then some (fm₁ ⟨ks.idxOf k, List.idxOf_lt_length_iff.mpr h⟩) else none)
@@ -170,8 +191,8 @@ private lemma lookup_rel {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂
   · 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
 
-lemma valuesAt_le {fm₁ fm₂ : FiniteMap A B ks} (hle : fm₁ ≤ fm₂)
-    (ks' : List A) :
+lemma valuesAt_le {fm₁ fm₂ : FiniteMap α β ks} (hle : fm₁ ≤ fm₂)
+    (ks' : List α) :
     List.Forall₂ (· ≤ ·) (valuesAt fm₁ ks') (valuesAt fm₂ ks') := by
   induction ks' with
   | nil => exact List.Forall₂.nil

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,35 +0,0 @@
-import Spa.Lattice.Prod
-import Spa.Lattice.Unit
-
-namespace Spa
-
-universe u
-
-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 decidableEq [DecidableEq A] [DecidableEq B] :
-    ∀ k, DecidableEq (IterProd A B k)
-  | 0 => inferInstanceAs (DecidableEq B)
-  | k + 1 => @instDecidableEqProd A (IterProd A B k) _ (decidableEq k)
-
-def build (a : A) (b : B) : (k : ℕ) → IterProd A B k
-  | 0 => b
-  | k + 1 => (a, build a b k)
-
-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) _ (fixedHeight k)
-
-instance finiteHeight [FiniteHeightLattice A] [FiniteHeightLattice B] (k : ℕ) :
-    FiniteHeightLattice (IterProd A B k) := fixedHeight k
-
-end IterProd
-
-end Spa

lean/Spa/Lattice/Prod.lean

@@ -1,82 +0,0 @@
-import Spa.Lattice
-
-namespace Spa
-
-section Unzip
-
-variable {α β : Type*} [PartialOrder α] [PartialOrder β]
-
-lemma 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
-    haveI : NeZero c.length := ⟨h0⟩
-    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 := c.strictMono Fin.one_pos'
-    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*}
-
-instance prod [A : FiniteHeightLattice α] [B : FiniteHeightLattice β] :
-    FiniteHeightLattice (α × β) where
-  toLattice := inferInstance
-  longestChain :=
-    RelSeries.smash
-      (A.longestChain.map (fun a => (a, (⊥ : β)))
-        (fun _ _ h => Prod.mk_lt_mk_iff_left.mpr h))
-      (B.longestChain.map (fun b => ((⊤ : α), b))
-        (fun _ _ h => Prod.mk_lt_mk_iff_right.mpr h))
-      rfl
-  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₂
-    show c.length ≤ A.longestChain.length + B.longestChain.length
-    omega
-
-end FixedHeight
-
-end Spa

lean/Spa/Lattice/Tuple.lean

@@ -1,64 +1,127 @@
-import Spa.Lattice.IterProd
-import Spa.Isomorphism
+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
 
-universe u
+variable {β : Type*}
 
-variable {B : Type u}
+section Unzip
 
-private def iterOfFun : {n : ℕ} → (Fin n → B) → IterProd B PUnit n
-  | 0, _ => PUnit.unit
-  | _ + 1, f => (f 0, iterOfFun (Fin.tail f))
+variable [PartialOrder β]
 
-private def funOfIter : {n : ℕ} → IterProd B PUnit n → (Fin n → B)
-  | 0, _ => Fin.elim0
-  | _ + 1, ip => Fin.cons ip.1 (funOfIter ip.2)
+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⟩)
 
-private lemma funOfIter_iterOfFun : ∀ {n : ℕ} (f : Fin n → B),
-    funOfIter (iterOfFun f) = f
-  | 0, _ => funext fun i => i.elim0
-  | _ + 1, f => by
-    show Fin.cons (f 0) (funOfIter (iterOfFun (Fin.tail f))) = f
-    rw [funOfIter_iterOfFun (Fin.tail f), Fin.cons_self_tail]
+end Unzip
 
-private lemma iterOfFun_funOfIter : ∀ {n : ℕ} (ip : IterProd B PUnit n),
-    iterOfFun (funOfIter ip) = ip
-  | 0, PUnit.unit => rfl
-  | _ + 1, ip => by
-    show (funOfIter ip 0, iterOfFun (Fin.tail (funOfIter ip))) = ip
-    rw [show funOfIter ip = Fin.cons ip.1 (funOfIter ip.2) from rfl]
-    simp [Fin.cons_zero, Fin.tail_cons, iterOfFun_funOfIter ip.2]
+section FiniteHeight
 
-variable [FiniteHeightLattice B]
+variable [FiniteHeightLattice β]
 
-private lemma funOfIter_mono {n : ℕ} :
-    Monotone (funOfIter : IterProd B PUnit n → (Fin n → B)) := by
-  induction n with
-  | zero => intro _ _ _ i; exact i.elim0
-  | succ n ih =>
-    intro ip₁ ip₂ h i
-    obtain ⟨h1, h2⟩ := Prod.le_def.mp h
-    rw [show funOfIter ip₁ = Fin.cons ip₁.1 (funOfIter ip₁.2) from rfl,
-        show funOfIter ip₂ = Fin.cons ip₂.1 (funOfIter ip₂.2) from rfl]
-    induction i using Fin.cases with
-    | zero => rw [Fin.cons_zero, Fin.cons_zero]; exact h1
-    | succ j => rw [Fin.cons_succ, Fin.cons_succ]; exact ih h2 j
+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]
 
-private lemma iterOfFun_mono {n : ℕ} :
-    Monotone (iterOfFun : (Fin n → B) → IterProd B PUnit n) := by
-  induction n with
-  | zero => intro f g _; exact le_of_eq rfl
-  | succ n ih =>
-    intro f g h
-    exact Prod.le_def.mpr ⟨h 0, ih fun i => h i.succ⟩
-
-instance instFiniteHeight {n : ℕ} :
-    FiniteHeightLattice (Fin n → B) :=
-  FiniteHeightLattice.transport funOfIter iterOfFun
-    funOfIter_mono iterOfFun_mono iterOfFun_funOfIter funOfIter_iterOfFun
+end FiniteHeight
 
 end Tuple
 

lean/Spa/Lattice/Unit.lean

@@ -1,16 +1,14 @@
 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
 
-lemma 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 _ _)
-
-instance : FiniteHeightLattice PUnit where
-  toLattice := inferInstance
-  longestChain := RelSeries.singleton _ PUnit.unit
-  chains_bounded := boundedChains_of_subsingleton PUnit 0
+instance : FiniteHeightLattice PUnit := FiniteHeightLattice.ofUnique PUnit
 
 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