From cb9e7a3d965258ffa1508102aaf0d825a92358b1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 17:54:17 +0100
Subject: [PATCH 001/106] Update
 Cslib/Computability/Machines/MultiTapeTuring/Basic.lean

Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 .../Machines/MultiTapeTuring/Basic.lean       | 19 +++++--------------
 1 file changed, 5 insertions(+), 14 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 6bf325db8b..b3c45032ac 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -343,21 +343,12 @@ public lemma eval_eq_some_iff_transformsTapes
   constructor
   · intro ⟨h_dom, h_get⟩
     use Nat.find h_dom
-    rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some]
-    rw [← configs, Option.eq_some_iff_get_eq]
-    use configs_isSome_of_haltsAtStep (Nat.find_spec h_dom)
-    ext1
-    · simp
-      grind [haltsAtStep, Nat.find_spec h_dom]
-    · exact h_get
+    grind [TransformsTapesInExactTime, configs, haltCfgTapes, haltsAtStep]
   · intro ⟨t, h_iter⟩
-    rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some] at h_iter
-    rw [← configs] at h_iter
-    have h_halts_at_t : tm.haltsAtStep tapes t := by simp [haltsAtStep, h_iter]
-    let h_halts : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩
-    use h_halts
-    have h_eq : Nat.find h_halts = t := halting_step_unique (Nat.find_spec h_halts) h_halts_at_t
-    simp [h_eq, h_iter]
+    rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some, ← configs] at h_iter
+    have h_halts_at_t : tm.haltsAtStep tapes t := by grind [haltsAtStep]
+    have : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩
+    grind [haltCfgTapes, halting_step_unique]
 
 end MultiTapeTM
 

From cc78278fa4262b7df7a3fe8ea316b4ade1680983 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 17:37:56 +0100
Subject: [PATCH 002/106] Extract common parts.

---
 Cslib.lean                                    |  1 +
 .../Machines/MultiTapeTuring/Basic.lean       | 14 ++++++-------
 .../Machines/SingleTapeTuring/Basic.lean      | 21 ++-----------------
 3 files changed, 10 insertions(+), 26 deletions(-)

diff --git a/Cslib.lean b/Cslib.lean
index d64e025eff..48a755f506 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -30,6 +30,7 @@ public import Cslib.Computability.Languages.OmegaLanguage
 public import Cslib.Computability.Languages.OmegaRegularLanguage
 public import Cslib.Computability.Languages.RegularLanguage
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+public import Cslib.Computability.Machines.TuringCommon
 public import Cslib.Computability.Machines.MultiTapeTuring.Basic
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index b3c45032ac..2ca7e81cd4 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -6,12 +6,12 @@ Authors: Christian Reitwiessner
 
 module
 
--- TODO create a "common file"?
-public import Cslib.Computability.Machines.SingleTapeTuring.Basic
-
 public import Mathlib.Data.Part
-
-import Mathlib.Algebra.Order.BigOperators.Group.Finset
+public import Mathlib.Data.Fintype.Defs
+public import Cslib.Foundations.Data.BiTape
+public import Cslib.Foundations.Data.RelatesInSteps
+public import Cslib.Computability.Machines.TuringCommon
+public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 
 /-!
 # Multi-Tape Turing Machines
@@ -84,7 +84,7 @@ public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   (q₀ : State)
   /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke
   for each tape and optionally the new state to transition to afterwards (`none` for halt) -/
-  (tr : State → (Fin k → Option Symbol) → ((Fin k → (SingleTapeTM.Stmt Symbol)) × Option State))
+  (tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State))
 
 namespace MultiTapeTM
 
@@ -104,7 +104,7 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩
 
 instance : Fintype tm.State := tm.stateFintype
 
-instance inhabitedStmt : Inhabited (SingleTapeTM.Stmt Symbol) := inferInstance
+instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
 
 
 /--
diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
index 4f31c1530f..adec507055 100644
--- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
@@ -9,6 +9,7 @@ module
 public import Cslib.Foundations.Data.BiTape
 public import Cslib.Foundations.Data.RelatesInSteps
 public import Mathlib.Algebra.Polynomial.Eval.Defs
+public import Cslib.Computability.Machines.TuringCommon
 
 @[expose] public section
 
@@ -44,7 +45,6 @@ for convenience in composition of machines.
 
 We define a number of structures related to Turing machine computation:
 
-* `Stmt`: the write and movement operations a TM can do in a single step.
 * `SingleTapeTM`: the TM itself.
 * `Cfg`: the configuration of a TM, including internal and tape state.
 * `TimeComputable f`: a TM for computing `f`, packaged with a bound on runtime.
@@ -70,21 +70,6 @@ open BiTape StackTape
 
 variable {Symbol : Type}
 
-namespace SingleTapeTM
-
-/--
-A Turing machine "statement" is just a `Option`al command to move left or right,
-and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape`
--/
-structure Stmt (Symbol : Type) where
-  /-- The symbol to write at the current head position -/
-  symbol : Option Symbol
-  /-- The direction to move the tape head -/
-  movement : Option Dir
-deriving Inhabited
-
-end SingleTapeTM
-
 /--
 A single-tape Turing machine
 over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol).
@@ -98,7 +83,7 @@ structure SingleTapeTM Symbol [Inhabited Symbol] [Fintype Symbol] where
   (q₀ : State)
   /-- Transition function, mapping a state and a head symbol to a `Stmt` to invoke,
   and optionally the new state to transition to afterwards (`none` for halt) -/
-  (tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State)
+  (tr : State → Option Symbol → Stmt Symbol × Option State)
 
 namespace SingleTapeTM
 
@@ -118,8 +103,6 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩
 
 instance : Fintype tm.State := tm.stateFintype
 
-instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
-
 /--
 The configurations of a Turing machine consist of:
 an `Option`al state (or none for the halting state),

From 07d7bcd3ac11e72f0823d6492bd369091594ec05 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 17:54:30 +0100
Subject: [PATCH 003/106] Simplify definitions and proofs.

---
 .../Machines/MultiTapeTuring/Basic.lean            | 14 ++++++--------
 1 file changed, 6 insertions(+), 8 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 2ca7e81cd4..900c4556c4 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -77,14 +77,14 @@ over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol)
 -/
 public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   /-- type of state labels -/
-  (State : Type)
+  State : Type
   /-- finiteness of the state type -/
   [stateFintype : Fintype State]
   /-- initial state -/
-  (q₀ : State)
+  q₀ : State
   /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke
   for each tape and optionally the new state to transition to afterwards (`none` for halt) -/
-  (tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State))
+  tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State)
 
 namespace MultiTapeTM
 
@@ -139,10 +139,8 @@ public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ)
     (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by
   rw [Function.iterate_succ_apply]
   induction n with
-  | zero => simp [step]
-  | succ n ih =>
-    simp only [Function.iterate_succ_apply', ih]
-    simp [step]
+  | zero => rfl
+  | succ n ih => grind [Function.iterate_succ_apply']
 
 /-- A collection of tapes where the first tape contains `s` -/
 public def firstTape (s : List Symbol) : Fin k → BiTape Symbol
@@ -280,7 +278,7 @@ public lemma relatesInSteps_iff_step_iter_eq_some
   | succ t ih =>
     rw [RelatesInSteps.succ_iff, Function.iterate_succ_apply']
     constructor
-    · grind only [TransitionRelation, = Option.bind_some]
+    · grind
     · intro h_configs
       cases h : (Option.bind · tm.step)^[t] cfg₁ with
       | none => grind

From 841be7f40ff647e163459e2394b9f5b3889e75f0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 18:26:03 +0100
Subject: [PATCH 004/106] Use "@[expose] public section"

---
 .../Machines/MultiTapeTuring/Basic.lean       | 57 +++++++++----------
 1 file changed, 26 insertions(+), 31 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 900c4556c4..e08ab23992 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -13,6 +13,8 @@ public import Cslib.Foundations.Data.RelatesInSteps
 public import Cslib.Computability.Machines.TuringCommon
 public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 
+@[expose] public section
+
 /-!
 # Multi-Tape Turing Machines
 
@@ -75,7 +77,7 @@ variable {k : ℕ}
 A `k`-tape Turing machine
 over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol).
 -/
-public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
+structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   /-- type of state labels -/
   State : Type
   /-- finiteness of the state type -/
@@ -113,7 +115,7 @@ an `Option`al state (or none for the halting state),
 and a `BiTape` representing the tape contents.
 -/
 @[ext]
-public structure Cfg : Type where
+structure Cfg : Type where
   /-- the state of the TM (or none for the halting state) -/
   state : Option tm.State
   /-- the BiTape contents -/
@@ -121,7 +123,7 @@ public structure Cfg : Type where
 deriving Inhabited
 
 /-- The step function corresponding to a `MultiTapeTM`. -/
-public def step : tm.Cfg → Option tm.Cfg
+def step : tm.Cfg → Option tm.Cfg
   | ⟨none, _⟩ =>
     -- If in the halting state, there is no next configuration
     none
@@ -135,7 +137,7 @@ public def step : tm.Cfg → Option tm.Cfg
 
 /-- Any number of positive steps run from a halting configuration lead to `none`. -/
 @[simp, scoped grind =]
-public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) :
+lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) :
     (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by
   rw [Function.iterate_succ_apply]
   induction n with
@@ -143,7 +145,7 @@ public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ)
   | succ n ih => grind [Function.iterate_succ_apply']
 
 /-- A collection of tapes where the first tape contains `s` -/
-public def firstTape (s : List Symbol) : Fin k → BiTape Symbol
+def firstTape (s : List Symbol) : Fin k → BiTape Symbol
   | ⟨0, _⟩ => BiTape.mk₁ s
   | ⟨_, _⟩ => default
 
@@ -153,46 +155,42 @@ Note that the entries of the tape constructed by `BiTape.mk₁` are all `some` v
 This is to ensure that distinct lists map to distinct initial configurations.
 -/
 @[simp]
-public def initCfg (s : List Symbol) : tm.Cfg :=
+def initCfg (s : List Symbol) : tm.Cfg :=
   ⟨some tm.q₀, firstTape s⟩
 
 /-- Create an initial configuration given a tuple of tapes. -/
 @[simp]
-public def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
+def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
   ⟨some tm.q₀, tapes⟩
 
 /-- The final configuration corresponding to a list in the output alphabet.
 (We demand that the head halts at the leftmost position of the output.)
 -/
 @[simp]
-public def haltCfg (s : List Symbol) : tm.Cfg :=
+def haltCfg (s : List Symbol) : tm.Cfg :=
   ⟨none, firstTape s⟩
 
 /-- The final configuration of a Turing machine given a tuple of tapes. -/
 @[simp]
-public def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
+def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
   ⟨none, tapes⟩
 
 /-- The sequence of configurations of the Turing machine starting with initial state and
 given tapes at step `t`.
 If the Turing machine halts, it will eventually get and stay `none` after reaching the halting
 configuration. -/
-public def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg :=
+def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg :=
   (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes)
 
-
-
--- TODO shouldn't this be spaceUsed? (If yes, also change it in SingleTapeTM)
-
 /--
 The space used by a configuration is the sum of the space used by its tapes.
 -/
-public def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used
+def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used
 
 /--
 The space used by a configuration grows by at most `k` each step.
 -/
-public lemma Cfg.space_used_step (cfg cfg' : tm.Cfg)
+lemma Cfg.space_used_step (cfg cfg' : tm.Cfg)
     (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + k := by
   obtain ⟨_ | q, tapes⟩ := cfg
   · simp [step] at hstep
@@ -220,12 +218,12 @@ is defined by the `step` function,
 which maps a configuration to its next configuration, if it exists.
 -/
 @[scoped grind =]
-public def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop :=
+def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop :=
   tm.step c₁ = some c₂
 
 /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly
 `t` steps. -/
-public def TransformsTapesInExactTime
+def TransformsTapesInExactTime
     (tm : MultiTapeTM k Symbol)
     (tapes tapes' : Fin k → BiTape Symbol)
     (t : ℕ) : Prop :=
@@ -233,21 +231,19 @@ public def TransformsTapesInExactTime
 
 /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in up to
 `t` steps. -/
-public def TransformsTapesInTime
+def TransformsTapesInTime
     (tm : MultiTapeTM k Symbol)
     (tapes tapes' : Fin k → BiTape Symbol)
     (t : ℕ) : Prop :=
   RelatesWithinSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t
 
 /-- The Turing machine `tm` transforms tapes `tapes` to `tapes'`. -/
-public def TransformsTapes
-    (tm : MultiTapeTM k Symbol)
-    (tapes tapes' : Fin k → BiTape Symbol) : Prop :=
+def TransformsTapes (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) : Prop :=
   ∃ t, tm.TransformsTapesInExactTime tapes tapes' t
 
 /-- A proof that the Turing machine `tm` uses at most space `s` when run for up to `t` steps
 on initial tapes `tapes`. -/
-public def UsesSpaceUntilStep
+def UsesSpaceUntilStep
     (tm : MultiTapeTM k Symbol)
     (tapes : Fin k → BiTape Symbol)
     (s t : ℕ) : Prop :=
@@ -257,7 +253,7 @@ public def UsesSpaceUntilStep
 
 /-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps
 and uses at most `s` space. -/
-public def TransformsTapesInTimeAndSpace
+def TransformsTapesInTimeAndSpace
     (tm : MultiTapeTM k Symbol)
     (tapes tapes' : Fin k → BiTape Symbol)
     (t s : ℕ) : Prop :=
@@ -267,7 +263,7 @@ public def TransformsTapesInTimeAndSpace
 /-- This lemma translates between the relational notion and the iterated step notion. The latter
 can be more convenient especially for deterministic machines as we have here. -/
 @[scoped grind =]
-public lemma relatesInSteps_iff_step_iter_eq_some
+lemma relatesInSteps_iff_step_iter_eq_some
     (tm : MultiTapeTM k Symbol)
     (cfg₁ cfg₂ : tm.Cfg)
     (t : ℕ) :
@@ -287,14 +283,13 @@ public lemma relatesInSteps_iff_step_iter_eq_some
         grind
 
 /-- The Turing machine `tm` halts after exactly `t` steps on initial tapes `tapes`. -/
-public def haltsAtStep
-    (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool :=
+def haltsAtStep (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool :=
   match (tm.configs tapes t) with
   | some ⟨none, _⟩ => true
   | _ => false
 
 /-- If a Turing machine halts, the time step is uniquely determined. -/
-public lemma halting_step_unique
+lemma halting_step_unique
     {tm : MultiTapeTM k Symbol}
     {tapes : Fin k → BiTape Symbol}
     {t₁ t₂ : ℕ}
@@ -316,7 +311,7 @@ public lemma halting_step_unique
       simp at h_halts₂
 
 /-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/
-public lemma configs_isSome_of_haltsAtStep
+lemma configs_isSome_of_haltsAtStep
     {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t : ℕ}
     (h_halts : tm.haltsAtStep tapes t) :
     (tm.configs tapes t).isSome := by
@@ -324,7 +319,7 @@ public lemma configs_isSome_of_haltsAtStep
 
 /-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes
 if it eventually halts. -/
-public def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) :
+def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) :
     Part (Fin k → BiTape Symbol) :=
   ⟨∃ t, tm.haltsAtStep tapes t,
     fun h => ((tm.configs tapes (Nat.find h)).get
@@ -333,7 +328,7 @@ public def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) :
 /-- Evaluating a Turing machine on a tuple of tapes `tapes` has a value `tapes'` if and only if
 it transforms `tapes` into `tapes'`. -/
 @[scoped grind =]
-public lemma eval_eq_some_iff_transformsTapes
+lemma eval_eq_some_iff_transformsTapes
     {tm : MultiTapeTM k Symbol}
     {tapes tapes' : Fin k → BiTape Symbol} :
     tm.eval tapes = .some tapes' ↔ tm.TransformsTapes tapes tapes' := by

From abac0f11ddf6579691556eb705599353f16a5cca Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 18:26:49 +0100
Subject: [PATCH 005/106] Update Cslib.lean

---
 Cslib.lean | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Cslib.lean b/Cslib.lean
index 48a755f506..4e8f8d568b 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -29,9 +29,9 @@ public import Cslib.Computability.Languages.Language
 public import Cslib.Computability.Languages.OmegaLanguage
 public import Cslib.Computability.Languages.OmegaRegularLanguage
 public import Cslib.Computability.Languages.RegularLanguage
+public import Cslib.Computability.Machines.MultiTapeTuring.Basic
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Cslib.Computability.Machines.TuringCommon
-public import Cslib.Computability.Machines.MultiTapeTuring.Basic
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
 public import Cslib.Computability.URM.Defs

From ae6c498526fed9a2002d0396a60068782c8e3cd7 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 10 Mar 2026 23:52:23 +0100
Subject: [PATCH 006/106] Add missed file.

---
 .../Computability/Machines/TuringCommon.lean  | 28 +++++++++++++++++++
 1 file changed, 28 insertions(+)
 create mode 100644 Cslib/Computability/Machines/TuringCommon.lean

diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean
new file mode 100644
index 0000000000..e9e19184f0
--- /dev/null
+++ b/Cslib/Computability/Machines/TuringCommon.lean
@@ -0,0 +1,28 @@
+/-
+Copyright (c) 2026 Bolton Bailey. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Bolton Bailey, Pim Spelier, Daan van Gent
+-/
+
+module
+
+public import Mathlib.Computability.Tape
+
+@[expose] public section
+
+namespace Turing
+
+/--
+A Turing machine "statement" is just a `Option`al command to move left or right,
+and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape`
+-/
+structure Stmt (Symbol : Type) where
+  /-- The symbol to write at the current head position -/
+  symbol : Option Symbol
+  /-- The direction to move the tape head -/
+  movement : Option Dir
+deriving Inhabited
+
+instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
+
+end Turing

From 7401a21ab47ac4cf53cd964f1f7d7e9896867a64 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 19 Mar 2026 12:15:06 +0100
Subject: [PATCH 007/106] fix import.

---
 Cslib/Computability/Machines/TuringCommon.lean | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean
index e9e19184f0..60d0636639 100644
--- a/Cslib/Computability/Machines/TuringCommon.lean
+++ b/Cslib/Computability/Machines/TuringCommon.lean
@@ -6,7 +6,7 @@ Authors: Bolton Bailey, Pim Spelier, Daan van Gent
 
 module
 
-public import Mathlib.Computability.Tape
+public import Mathlib.Computability.TuringMachine.Tape
 
 @[expose] public section
 

From f57bb82a750c5d3dac3d4f7ed0c5e164a3f4f6c0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 18 Apr 2026 18:08:59 +0200
Subject: [PATCH 008/106] Function view for tapes.

---
 Cslib/Foundations/Data/BiTape.lean    | 95 +++++++++++++++++++++++++++
 Cslib/Foundations/Data/StackTape.lean | 36 ++++++++++
 2 files changed, 131 insertions(+)

diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index de7a9c8fa2..91730dccbb 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -78,6 +78,31 @@ def mk₁ (l : List Symbol) : BiTape Symbol :=
   | [] => ∅
   | h :: t => { head := some h, left := ∅, right := StackTape.map_some t }
 
+/-- Returns the tape symbol at positon `p` relative to the head, where
+positive numbers are right of the head and negative are left of the head. -/
+def get (t : BiTape Symbol) : ℤ → Option Symbol
+  | Int.ofNat 0 => t.head
+  | Int.ofNat (Nat.succ p') => t.right.toList[p']?.getD none
+  | Int.negSucc p' => t.left.toList[p']?.getD none
+
+/-- Two tapes are equal if and only if their `get` functions are equal. This allows to view
+tapes as functions `ℤ → Option Symbol`. -/
+lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) :
+  t₁ = t₂ := by
+  obtain ⟨head₁, left₁, right₁⟩ := t₁
+  obtain ⟨head₂, left₂, right₂⟩ := t₂
+  have h_head : head₁ = head₂ := by simpa [get] using h_get_eq 0
+  have h_right : right₁ = right₂ := by
+    apply StackTape.ext_get
+    intro p
+    simpa [get] using h_get_eq p.succ
+  have h_left : left₁ = left₂ := by
+    apply StackTape.ext_get
+    intro p
+    simpa [get] using h_get_eq (Int.negSucc p)
+  simp only [h_head, h_left, h_right]
+
+
 section Move
 
 /--
@@ -114,6 +139,66 @@ lemma move_left_move_right (t : BiTape Symbol) : t.move_left.move_right = t := b
 lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := by
   simp [move_left, move_right]
 
+/-- Translate an optional direction into a head movement offset, where the positive
+direction is to the right. -/
+def optionDirToInt (d : Option Dir) : ℤ :=
+  match d with
+  | none => 0
+  | some .left => -1
+  | some .right => 1
+
+@[simp]
+lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
+    (t.move_left).get p = t.get (p - 1) := by
+  unfold move_left get
+  match p with
+  | Int.ofNat 0 =>
+    rw [show Int.ofNat 0 - 1 = Int.negSucc 0 from rfl]
+    simp [StackTape.head_eq_getD]
+  | Int.ofNat 1 => simp
+  | Int.ofNat (n + 2) =>
+    rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) from by grind]
+    simp
+  | Int.negSucc n => simp
+
+@[simp]
+lemma get_move_right (t : BiTape Symbol) (p : ℤ) :
+    (t.move_right).get p = t.get (p + 1) := by
+  unfold move_right get
+  match p with
+  | Int.ofNat n =>
+    rw [show Int.ofNat n + 1 = Int.ofNat (n + 1) from by grind]
+    cases n <;> simp [StackTape.head_eq_getD]
+  | Int.negSucc 0 => simp
+  | Int.negSucc (n + 1) =>
+    rw [show Int.negSucc (n + 1) + 1 = Int.negSucc n from rfl]
+    simp
+
+@[simp]
+lemma get_optionMove (t : BiTape Symbol) (d : Option Dir) (p : ℤ) :
+    (t.optionMove d).get p = t.get (p + optionDirToInt d) := by
+  unfold optionMove optionDirToInt
+  cases d with
+  | none => simp
+  | some d =>
+    cases d <;> simp [move, show p + (-1 : ℤ) = p - 1 from by omega]
+
+@[simp]
+lemma get_move_right_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
+    (move_right^[n] t).get p = t.get (p + n):= by
+  induction n generalizing t p with
+  | zero => simp
+  | succ n ih => simp [Function.iterate_succ_apply, ih, Int.add_assoc]
+
+@[simp]
+lemma get_move_left_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
+    (move_left^[n] t).get p = t.get (p - n):= by
+  induction n generalizing t p with
+  | zero => simp
+  | succ n ih =>
+    have : p - n - 1 = p - (n + 1) := by grind
+    simp [Function.iterate_succ_apply, ih, this]
+
 end Move
 
 /--
@@ -121,6 +206,16 @@ Write a value under the head of the `BiTape`.
 -/
 def write (t : BiTape Symbol) (a : Option Symbol) : BiTape Symbol := { t with head := a }
 
+@[simp]
+lemma get_write (t : BiTape Symbol) (a : Option Symbol) :
+    (t.write a).get = Function.update t.get 0 a := by
+  unfold write get Function.update
+  funext p
+  match p with
+  | Int.ofNat 0 => simp
+  | Int.ofNat (n + 1) => simp; grind
+  | Int.negSucc n => simp
+
 /--
 The space used by a `BiTape` is the number of symbols
 between and including the head, and leftmost and rightmost non-blank symbols on the `BiTape`.
diff --git a/Cslib/Foundations/Data/StackTape.lean b/Cslib/Foundations/Data/StackTape.lean
index 049d52a195..e64758dba8 100644
--- a/Cslib/Foundations/Data/StackTape.lean
+++ b/Cslib/Foundations/Data/StackTape.lean
@@ -106,6 +106,25 @@ def head (l : StackTape Symbol) : Option Symbol :=
   | [] => none
   | h :: _ => h
 
+lemma head_eq_getD (s : StackTape Symbol) :
+    s.head = s.toList[0]?.getD none := by
+  unfold head; cases s.toList <;> simp
+
+@[simp]
+lemma tail_getD (s : StackTape Symbol) (n : ℕ) :
+    s.tail.toList[n]?.getD none = s.toList[n + 1]?.getD none := by
+  cases s with | mk l h => cases l <;> simp [tail, nil]
+
+@[simp]
+lemma cons_getD_zero (x : Option Symbol) (s : StackTape Symbol) :
+    (cons x s).toList[0]?.getD none = x := by
+  cases x <;> (cases s with | mk l h => cases l <;> simp [cons])
+
+@[simp]
+lemma cons_getD_succ (x : Option Symbol) (s : StackTape Symbol) (n : ℕ) :
+    (cons x s).toList[n + 1]?.getD none = s.toList[n]?.getD none := by
+  cases x <;> (cases s with | mk l h => cases l <;> simp [cons])
+
 lemma eq_iff (l1 l2 : StackTape Symbol) :
     l1 = l2 ↔ l1.head = l2.head ∧ l1.tail = l2.tail := by
   constructor
@@ -115,6 +134,23 @@ lemma eq_iff (l1 l2 : StackTape Symbol) :
     cases l2 with | mk as2 h2 =>
     cases as1 <;> cases as2 <;> grind
 
+lemma ext (t₁ t₂ : StackTape Symbol) (h_toList_eq : t₁.toList = t₂.toList) :
+  t₁ = t₂ := by
+  obtain ⟨t₁, h₁⟩ := t₁
+  obtain ⟨t₂, h₂⟩ := t₂
+  simpa using h_toList_eq
+
+lemma ext_get (t₁ t₂ : StackTape Symbol)
+    (h_get_eq : ∀ p, t₁.toList.getD p none = t₂.toList.getD p none) :
+  t₁ = t₂ := by
+  apply ext
+  obtain ⟨l₁, h₁⟩ := t₁
+  obtain ⟨l₂, h₂⟩ := t₂
+  simp only [List.getD_eq_getElem?_getD] at h_get_eq
+  have hlen : l₁.length = l₂.length := by grind
+  apply List.ext_getElem hlen
+  grind
+
 @[simp]
 lemma head_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).head = o := by
   cases o with

From 642162c56369302365a23c8e2507fe9d164355e8 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 20 Apr 2026 11:38:51 +0200
Subject: [PATCH 009/106] Apply suggestions from code review

Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 Cslib/Foundations/Data/BiTape.lean | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index 91730dccbb..c2621771de 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -78,12 +78,13 @@ def mk₁ (l : List Symbol) : BiTape Symbol :=
   | [] => ∅
   | h :: t => { head := some h, left := ∅, right := StackTape.map_some t }
 
+open scoped Int in
 /-- Returns the tape symbol at positon `p` relative to the head, where
 positive numbers are right of the head and negative are left of the head. -/
 def get (t : BiTape Symbol) : ℤ → Option Symbol
-  | Int.ofNat 0 => t.head
-  | Int.ofNat (Nat.succ p') => t.right.toList[p']?.getD none
-  | Int.negSucc p' => t.left.toList[p']?.getD none
+  | 0 => t.head
+  | (p' + 1 : Nat) => t.right.toList[p']?.getD none
+  | -[p'+1] => t.left.toList[p']?.getD none
 
 /-- Two tapes are equal if and only if their `get` functions are equal. This allows to view
 tapes as functions `ℤ → Option Symbol`. -/
@@ -95,7 +96,7 @@ lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.g
   have h_right : right₁ = right₂ := by
     apply StackTape.ext_get
     intro p
-    simpa [get] using h_get_eq p.succ
+    simpa [get] using h_get_eq (p + 1)
   have h_left : left₁ = left₂ := by
     apply StackTape.ext_get
     intro p
@@ -157,7 +158,7 @@ lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
     simp [StackTape.head_eq_getD]
   | Int.ofNat 1 => simp
   | Int.ofNat (n + 2) =>
-    rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) from by grind]
+    rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) by lia]
     simp
   | Int.negSucc n => simp
 
@@ -167,7 +168,7 @@ lemma get_move_right (t : BiTape Symbol) (p : ℤ) :
   unfold move_right get
   match p with
   | Int.ofNat n =>
-    rw [show Int.ofNat n + 1 = Int.ofNat (n + 1) from by grind]
+    rw [show Int.ofNat n + 1 = Int.ofNat (n + 1) by lia]
     cases n <;> simp [StackTape.head_eq_getD]
   | Int.negSucc 0 => simp
   | Int.negSucc (n + 1) =>
@@ -196,7 +197,7 @@ lemma get_move_left_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
   induction n generalizing t p with
   | zero => simp
   | succ n ih =>
-    have : p - n - 1 = p - (n + 1) := by grind
+    have : p - n - 1 = p - (n + 1) := by lia
     simp [Function.iterate_succ_apply, ih, this]
 
 end Move
@@ -213,7 +214,7 @@ lemma get_write (t : BiTape Symbol) (a : Option Symbol) :
   funext p
   match p with
   | Int.ofNat 0 => simp
-  | Int.ofNat (n + 1) => simp; grind
+  | Int.ofNat (n + 1) => grind
   | Int.negSucc n => simp
 
 /--

From be6855a82b58c4690c37837976eb4c44dc22469b Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 20 Apr 2026 13:07:33 +0200
Subject: [PATCH 010/106] Simplify some proofs and add annotations.

---
 Cslib/Foundations/Data/BiTape.lean    | 25 +++++++++----------
 Cslib/Foundations/Data/StackTape.lean | 35 +++++++++++----------------
 2 files changed, 26 insertions(+), 34 deletions(-)

diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index c2621771de..74c6a8190b 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -81,6 +81,7 @@ def mk₁ (l : List Symbol) : BiTape Symbol :=
 open scoped Int in
 /-- Returns the tape symbol at positon `p` relative to the head, where
 positive numbers are right of the head and negative are left of the head. -/
+@[scoped grind]
 def get (t : BiTape Symbol) : ℤ → Option Symbol
   | 0 => t.head
   | (p' + 1 : Nat) => t.right.toList[p']?.getD none
@@ -88,8 +89,8 @@ def get (t : BiTape Symbol) : ℤ → Option Symbol
 
 /-- Two tapes are equal if and only if their `get` functions are equal. This allows to view
 tapes as functions `ℤ → Option Symbol`. -/
-lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) :
-  t₁ = t₂ := by
+@[ext]
+lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) : t₁ = t₂ := by
   obtain ⟨head₁, left₁, right₁⟩ := t₁
   obtain ⟨head₂, left₂, right₂⟩ := t₂
   have h_head : head₁ = head₂ := by simpa [get] using h_get_eq 0
@@ -101,7 +102,7 @@ lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.g
     apply StackTape.ext_get
     intro p
     simpa [get] using h_get_eq (Int.negSucc p)
-  simp only [h_head, h_left, h_right]
+  grind
 
 
 section Move
@@ -142,13 +143,14 @@ lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := b
 
 /-- Translate an optional direction into a head movement offset, where the positive
 direction is to the right. -/
+@[scoped grind]
 def optionDirToInt (d : Option Dir) : ℤ :=
   match d with
   | none => 0
   | some .left => -1
   | some .right => 1
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
     (t.move_left).get p = t.get (p - 1) := by
   unfold move_left get
@@ -162,7 +164,7 @@ lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
     simp
   | Int.negSucc n => simp
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_move_right (t : BiTape Symbol) (p : ℤ) :
     (t.move_right).get p = t.get (p + 1) := by
   unfold move_right get
@@ -175,23 +177,20 @@ lemma get_move_right (t : BiTape Symbol) (p : ℤ) :
     rw [show Int.negSucc (n + 1) + 1 = Int.negSucc n from rfl]
     simp
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_optionMove (t : BiTape Symbol) (d : Option Dir) (p : ℤ) :
     (t.optionMove d).get p = t.get (p + optionDirToInt d) := by
   unfold optionMove optionDirToInt
-  cases d with
-  | none => simp
-  | some d =>
-    cases d <;> simp [move, show p + (-1 : ℤ) = p - 1 from by omega]
+  grind [move]
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_move_right_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
     (move_right^[n] t).get p = t.get (p + n):= by
   induction n generalizing t p with
   | zero => simp
   | succ n ih => simp [Function.iterate_succ_apply, ih, Int.add_assoc]
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_move_left_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
     (move_left^[n] t).get p = t.get (p - n):= by
   induction n generalizing t p with
@@ -207,7 +206,7 @@ Write a value under the head of the `BiTape`.
 -/
 def write (t : BiTape Symbol) (a : Option Symbol) : BiTape Symbol := { t with head := a }
 
-@[simp]
+@[simp, scoped grind =]
 lemma get_write (t : BiTape Symbol) (a : Option Symbol) :
     (t.write a).get = Function.update t.get 0 a := by
   unfold write get Function.update
diff --git a/Cslib/Foundations/Data/StackTape.lean b/Cslib/Foundations/Data/StackTape.lean
index e64758dba8..add0b18edf 100644
--- a/Cslib/Foundations/Data/StackTape.lean
+++ b/Cslib/Foundations/Data/StackTape.lean
@@ -106,21 +106,21 @@ def head (l : StackTape Symbol) : Option Symbol :=
   | [] => none
   | h :: _ => h
 
-lemma head_eq_getD (s : StackTape Symbol) :
-    s.head = s.toList[0]?.getD none := by
+@[scoped grind =]
+lemma head_eq_getD (s : StackTape Symbol) : s.head = s.toList[0]?.getD none := by
   unfold head; cases s.toList <;> simp
 
-@[simp]
-lemma tail_getD (s : StackTape Symbol) (n : ℕ) :
-    s.tail.toList[n]?.getD none = s.toList[n + 1]?.getD none := by
+@[simp, scoped grind =]
+lemma tail_getElem? (s : StackTape Symbol) (n : ℕ) :
+    s.tail.toList[n]? = s.toList[n + 1]? := by
   cases s with | mk l h => cases l <;> simp [tail, nil]
 
-@[simp]
+@[simp, scoped grind =]
 lemma cons_getD_zero (x : Option Symbol) (s : StackTape Symbol) :
     (cons x s).toList[0]?.getD none = x := by
   cases x <;> (cases s with | mk l h => cases l <;> simp [cons])
 
-@[simp]
+@[simp, scoped grind =]
 lemma cons_getD_succ (x : Option Symbol) (s : StackTape Symbol) (n : ℕ) :
     (cons x s).toList[n + 1]?.getD none = s.toList[n]?.getD none := by
   cases x <;> (cases s with | mk l h => cases l <;> simp [cons])
@@ -134,30 +134,23 @@ lemma eq_iff (l1 l2 : StackTape Symbol) :
     cases l2 with | mk as2 h2 =>
     cases as1 <;> cases as2 <;> grind
 
-lemma ext (t₁ t₂ : StackTape Symbol) (h_toList_eq : t₁.toList = t₂.toList) :
-  t₁ = t₂ := by
+@[ext]
+lemma ext (t₁ t₂ : StackTape Symbol) (h_toList_eq : t₁.toList = t₂.toList) : t₁ = t₂ := by
   obtain ⟨t₁, h₁⟩ := t₁
   obtain ⟨t₂, h₂⟩ := t₂
   simpa using h_toList_eq
 
+@[ext]
 lemma ext_get (t₁ t₂ : StackTape Symbol)
-    (h_get_eq : ∀ p, t₁.toList.getD p none = t₂.toList.getD p none) :
-  t₁ = t₂ := by
-  apply ext
+    (h_get_eq : ∀ p : ℕ, t₁.toList[p]?.getD none = t₂.toList[p]?.getD none) :
+    t₁ = t₂ := by
   obtain ⟨l₁, h₁⟩ := t₁
   obtain ⟨l₂, h₂⟩ := t₂
-  simp only [List.getD_eq_getElem?_getD] at h_get_eq
-  have hlen : l₁.length = l₂.length := by grind
-  apply List.ext_getElem hlen
-  grind
+  grind [List.ext_getElem]
 
 @[simp]
 lemma head_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).head = o := by
-  cases o with
-  | none =>
-    cases l with | mk toList hl =>
-    cases toList <;> grind
-  | some a => grind
+  grind
 
 @[simp]
 lemma tail_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).tail = l := by

From 3110f77821d3c3798e724c68a470e605cea22927 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 30 Apr 2026 10:25:46 +0200
Subject: [PATCH 011/106] Move "expose" command below module-level
 documentation.

---
 Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index e08ab23992..91ee0c781d 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -13,8 +13,6 @@ public import Cslib.Foundations.Data.RelatesInSteps
 public import Cslib.Computability.Machines.TuringCommon
 public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 
-@[expose] public section
-
 /-!
 # Multi-Tape Turing Machines
 
@@ -63,6 +61,8 @@ There are multiple ways to talk about the behaviour of a multi-tape Turing machi
 
 -/
 
+@[expose] public section
+
 open Cslib Relation
 
 namespace Turing

From aa623433a9b32b44631aba1d5f30e1533ba9dc21 Mon Sep 17 00:00:00 2001
From: Kim Morrison <477956+kim-em@users.noreply.github.com>
Date: Tue, 5 May 2026 15:23:52 +1000
Subject: [PATCH 012/106] chore: route Zulip notifications to
 nightly-testing-cslib (#548)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This PR retargets the nightly-testing failure-detection workflow and the
adaptation-PR helper script from the shared `nightly-testing` channel to
the new `#nightly-testing-cslib` channel, in line with the [proposal to
split
`#nightly-testing`](https://leanprover.zulipchat.com/#narrow/channel/428973-nightly-testing/topic/proposal.20to.20split.20the.20channel/near/592721807)
into per-project channels for Mathlib, Batteries, and Cslib.

Topic names are unchanged so existing bookmarks and topic links continue
to resolve to the same conversations (which were also moved over).

The `#nightly-testing-cslib` channel mirrors the original (web-public,
history visible to subscribers, anyone can post).

Companion PRs:
https://github.com/leanprover-community/mathlib4/pull/38946,
https://github.com/leanprover-community/mathlib-ci/pull/33,
https://github.com/leanprover-community/batteries/pull/1794.

🤖 Prepared with Claude Code
---
 .../workflows/report_failures_nightly-testing.yml    | 12 ++++++------
 scripts/create-adaptation-pr.sh                      |  4 ++--
 2 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/.github/workflows/report_failures_nightly-testing.yml b/.github/workflows/report_failures_nightly-testing.yml
index bdbd878814..edeeb91682 100644
--- a/.github/workflows/report_failures_nightly-testing.yml
+++ b/.github/workflows/report_failures_nightly-testing.yml
@@ -21,7 +21,7 @@ jobs:
         api-key: ${{ secrets.ZULIP_API_KEY }}
         email: 'github-mathlib4-bot@leanprover.zulipchat.com'
         organization-url: 'https://leanprover.zulipchat.com'
-        to: 'nightly-testing'
+        to: 'nightly-testing-cslib'
         type: 'stream'
         topic: 'Cslib status updates'
         content: |
@@ -101,7 +101,7 @@ jobs:
           'num_before': 1,
           'num_after': 0,
           'narrow': [
-            {'operator': 'stream', 'operand': 'nightly-testing'},
+            {'operator': 'stream', 'operand': 'nightly-testing-cslib'},
             {'operator': 'topic', 'operand': 'Cslib status updates'},
             {'operator': 'sender', 'operand': bot_email}
           ],
@@ -113,7 +113,7 @@ jobs:
             # Post the success message
             request = {
                 'type': 'stream',
-                'to': 'nightly-testing',
+                'to': 'nightly-testing-cslib',
                 'topic': 'Cslib status updates',
                 'content': f"✅ The latest CI for Cslib's [nightly-testing branch](https://github.com/leanprover/cslib/tree/nightly-testing) has succeeded! ([{os.getenv('SHA')}](https://github.com/${{ github.repository }}/commit/{os.getenv('SHA')}))"
             }
@@ -250,7 +250,7 @@ jobs:
         api-key: ${{ secrets.ZULIP_API_KEY }}
         email: 'github-mathlib4-bot@leanprover.zulipchat.com'
         organization-url: 'https://leanprover.zulipchat.com'
-        to: 'nightly-testing'
+        to: 'nightly-testing-cslib'
         type: 'stream'
         topic: 'Cslib status updates'
         content: |
@@ -350,7 +350,7 @@ jobs:
               'num_before': 1,
               'num_after': 0,
               'narrow': [
-                {'operator': 'stream', 'operand': 'nightly-testing'},
+                {'operator': 'stream', 'operand': 'nightly-testing-cslib'},
                 {'operator': 'topic', 'operand': 'Cslib bump branch reminders'},
                 {'operator': 'sender', 'operand': bot_email}
               ],
@@ -388,7 +388,7 @@ jobs:
                 # Post the reminder message
                 request = {
                     'type': 'stream',
-                    'to': 'nightly-testing',
+                    'to': 'nightly-testing-cslib',
                     'topic': 'Cslib bump branch reminders',
                     'content': payload
                 }
diff --git a/scripts/create-adaptation-pr.sh b/scripts/create-adaptation-pr.sh
index 01587009c9..47b1ee2a10 100755
--- a/scripts/create-adaptation-pr.sh
+++ b/scripts/create-adaptation-pr.sh
@@ -203,13 +203,13 @@ if git diff --name-only bump/"$BUMPVERSION" bump/nightly-"$NIGHTLYDATE" | grep -
   zulip_title="cslib#$pr_number adaptations for nightly-$NIGHTLYDATE"
   zulip_body=$(printf "> %s\n\nPlease review this PR. At the end of the month this diff will land in 'main'." "$pr_title cslib#$pr_number")
 
-  echo "Posting the link to the PR in a new thread on the #nightly-testing channel on Zulip"
+  echo "Posting the link to the PR in a new thread on the #nightly-testing-cslib channel on Zulip"
   echo "Here is the message:"
   echo "Title: $zulip_title"
   echo " Body: $zulip_body"
 
   if command -v zulip-send >/dev/null 2>&1; then
-    zulip_command="zulip-send --stream nightly-testing --subject \"$zulip_title\" --message \"$zulip_body\""
+    zulip_command="zulip-send --stream nightly-testing-cslib --subject \"$zulip_title\" --message \"$zulip_body\""
     echo "Running the following 'zulip-send' command to do this:"
     echo "> $zulip_command"
     eval "$zulip_command"

From 02052d4c7d64fe18ea3519b4cc481e159cca2516 Mon Sep 17 00:00:00 2001
From: "mathlib-nightly-testing[bot]"
 <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com>
Date: Tue, 5 May 2026 17:51:15 -0400
Subject: [PATCH 013/106] chore: bump mathlib to 6cf3ab1, fix breaking changes
 (#547)

Bump `mathlib` dependency to
[6cf3ab1](https://github.com/leanprover-community/mathlib4/commit/6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5):
chore: make argument in `zero_le`/`one_le` implicit (#38148)
(2026-04-29)
Previously at:
[6727686](https://github.com/leanprover-community/mathlib4/commit/672768680fb7e4eff7dac7ceca12bc3889fd60fd):
ci(olean_report): use `lake env` instead of `lake exec` to invoke cache
binary (#38712) (2026-04-29)

Tracking issue: https://github.com/leanprover/cslib/issues/546

---

This PR bumps `mathlib` to an identified incompatible (first-known-bad)
commit (`6cf3ab1`) so you can reproduce and fix the incompatibility
locally by checking out this branch.

_Opened automatically by
[downstream-reports/track-incompatibility](https://github.com/leanprover-community/downstream-reports)
via [this workflow
run](https://github.com/leanprover/cslib/actions/runs/25351406099)._

---------

Co-authored-by: mathlib-nightly-testing[bot] <mathlib-nightly-testing[bot]@users.noreply.github.com>
Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
---
 Cslib/Computability/Automata/NA/Concat.lean | 2 +-
 lake-manifest.json                          | 4 ++--
 lakefile.toml                               | 2 +-
 3 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/Cslib/Computability/Automata/NA/Concat.lean b/Cslib/Computability/Automata/NA/Concat.lean
index 0b2c10d3e7..7cc7c1c18f 100644
--- a/Cslib/Computability/Automata/NA/Concat.lean
+++ b/Cslib/Computability/Automata/NA/Concat.lean
@@ -177,7 +177,7 @@ theorem finConcat_language_eq [Inhabited Symbol] :
     obtain ⟨ss, ⟨_, h_ωtr⟩, _⟩ := concat_run_exists h_xl1 h_run2
     #adaptation_note
     /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/
-    have h_mtr := LTS.OmegaExecution.extract_mTr h_ωtr (zero_le (xl1.length + xl2.length))
+    have h_mtr := LTS.OmegaExecution.extract_mTr h_ωtr (zero_le (a := xl1.length + xl2.length))
     simp [← append_append_ωSequence, extract_eq_drop_take,
       take_append_of_le_length, ← List.length_append] at h_mtr
     have : ss (xl1.length + xl2.length) = (ss.drop xl1.length) xl2.length := by grind
diff --git a/lake-manifest.json b/lake-manifest.json
index b16de692da..ca8591cf36 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,10 +5,10 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "672768680fb7e4eff7dac7ceca12bc3889fd60fd",
+   "rev": "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5",
    "name": "mathlib",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "672768680fb7e4eff7dac7ceca12bc3889fd60fd",
+   "inputRev": "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5",
    "inherited": false,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/plausible",
diff --git a/lakefile.toml b/lakefile.toml
index 6f836bf81b..4169d4b8e6 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false
 [[require]]
 name = "mathlib"
 scope = "leanprover-community"
-rev = "672768680fb7e4eff7dac7ceca12bc3889fd60fd"
+rev = "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5"
 
 [[lean_lib]]
 name = "Cslib"

From cdfe65513343e5eebb6e43fd6329851d1aefa7e8 Mon Sep 17 00:00:00 2001
From: thomaskwaring <51426330+thomaskwaring@users.noreply.github.com>
Date: Wed, 6 May 2026 22:26:29 +0200
Subject: [PATCH 014/106] feat(Foundations/Data/Relation): strongly normalising
 elements of a type equipped with a relation (#549)

This PR defines a predicate `SN r x` (better naming suggestions welcome)
expressing that there is no infinite chain of `r`-related elements
starting with `x`. This extends the definition of `Terminating` using
`WellFounded` to individual elements, using `Acc`.

---

I'm very open to being told this is not a useful generalisation /
abstraction, but the existing API for `Acc` does seem to make certain
proofs easier. For instance, `sn_app_left` in
`LambdaCalculus/LocallyNameless/Untyped/StrongNorm` falls out as
reduction on `M` is a subrelation of reduction on `M.app N`.

---------

Co-authored-by: twwar <tom.waring@unimelb.edu.au>
Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 Cslib/Foundations/Data/Relation.lean          | 97 ++++++++++++++-----
 .../LocallyNameless/Stlc/StrongNorm.lean      | 10 +-
 .../LocallyNameless/Untyped/StrongNorm.lean   | 70 +++++++------
 3 files changed, 113 insertions(+), 64 deletions(-)

diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index 743e2f22df..b8060d3389 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -203,38 +203,91 @@ theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) :
   apply equivalence_join
   grind
 
+/-- An element `x` is `SN` (for strongly-normalising) for a relation `r` if it is accesible under
+the inverse of `r`. -/
+abbrev SN (r : α → α → Prop) := Acc (fun a b => r b a)
+
+lemma SN_iff_SN_of_rel (x : α) : SN r x ↔ ∀ y, r x y → SN r y := by grind [Acc]
+
+lemma SN.intro : (h : ∀ y, r x y → SN r y) → SN r x := (SN_iff_SN_of_rel x).mpr
+
+lemma SN.of_rel (hx : SN r x) (h : r x y) : SN r y := Acc.inv hx h
+
+@[grind →]
+lemma SN.of_rel_reflTransGen (hx : SN r x) (h : ReflTransGen r x y) : SN r y := by
+  induction h with
+  | refl => exact hx
+  | tail _ h ih => exact ih.of_rel h
+
+lemma SN.transGen (hx : SN r x) : SN (TransGen r) x := by
+  have eq : TransGen (Function.swap r) = (fun a b => TransGen r b a) := by
+    ext
+    exact transGen_swap
+  simpa [eq] using Acc.transGen hx
+
+lemma SN.of_le {r' : α → α → Prop} (hx : SN r x) (h : r' ≤ r) : SN r' x := by
+  refine Subrelation.accessible ?_ hx
+  exact subrelation_iff_le.mpr fun {x y} => h y x
+
+@[simp]
+lemma SN.iff_transGen (x : α) : SN (TransGen r) x ↔ SN r x :=
+  ⟨fun hx => hx.of_le <| fun _ _ => TransGen.single, transGen⟩
+
+/-- `SN r x` is equivalent to the more elementary definition, that there is no infinite sequence
+of reductions starting with `x`. -/
+theorem SN.iff_isEmpty_chain :
+    SN r x ↔ IsEmpty {f : ℕ → α | f 0 = x ∧ ∀ n, r (f n) (f (n + 1))} :=
+  acc_iff_isEmpty_descending_chain
+
+lemma SN.onFun_of_image {r : β → β → Prop} {f : α → β} (hx : SN r (f x)) :
+    SN (Function.onFun r f) x := InvImage.accessible f hx
+
+lemma SN.of_normal (hx : Normal r x) : SN r x := SN.intro fun y hy => (hx ⟨y, hy⟩).elim
+
 /-- A relation is terminating when the inverse of its transitive closure is well-founded.
   Note that this is also called Noetherian or strongly normalizing in the literature. -/
 abbrev Terminating (r : α → α → Prop) := WellFounded (fun a b => r b a)
 
+lemma Terminating.apply (hr : Terminating r) (x : α) : SN r x := WellFounded.apply hr x
+
+lemma Terminating.iff_forall_sn : Terminating r ↔ ∀ x, SN r x :=
+  ⟨WellFounded.apply, WellFounded.intro⟩
+
 theorem Terminating.toTransGen (ht : Terminating r) : Terminating (TransGen r) := by
-  suffices _ : (fun a b => TransGen r b a) = TransGen (Function.swap r) by grind
-  grind [transGen_swap]
+  simp_rw [iff_forall_sn, SN.iff_transGen] at ht ⊢
+  exact ht
 
 theorem Terminating.ofTransGen : Terminating (TransGen r) → Terminating r := by
-  suffices _ : (fun a b => TransGen r b a) = TransGen (Function.swap r) by grind
-  grind [transGen_swap]
+  simp_rw [iff_forall_sn, SN.iff_transGen]
+  exact id
+
+theorem Terminating.iff_transGen : Terminating (TransGen r) ↔ Terminating r := by
+  simp_rw [iff_forall_sn, SN.iff_transGen]
 
-theorem Terminating.iff_transGen : Terminating (TransGen r) ↔ Terminating r :=
-  ⟨ofTransGen, toTransGen⟩
+theorem Terminating.iff_isEmpty_chain :
+    Terminating r ↔ IsEmpty {f : ℕ → α // ∀ n, r (f n) (f (n + 1))} :=
+  wellFounded_iff_isEmpty_descending_chain
 
-theorem Terminating.subrelation {r' : α → α → Prop} (hr : Terminating r) (h : Subrelation r' r) :
+theorem Terminating.of_le {r' : α → α → Prop} (hr : Terminating r) (h : r' ≤ r) :
     Terminating r' := by
-  rw [Terminating, wellFounded_iff_isEmpty_descending_chain] at hr ⊢
-  rw [isEmpty_subtype]
-  intro f hf
-  exact hr.elim ⟨f, fun n ↦ by exact h (hf n)⟩
-
-theorem Terminating.isNormalizing (h : Terminating r) : Normalizing r := by
-  unfold Terminating at h
-  intro t
-  apply WellFounded.induction h t
-  intro a ih
-  by_cases ha : Reducible r a
-  · obtain ⟨b, hab⟩ := ha
-    obtain ⟨n, hbn, hn⟩ := ih b hab
-    exact ⟨n, ReflTransGen.head hab hbn, hn⟩
-  · use a
+  rw [iff_forall_sn] at hr ⊢
+  exact fun x => (hr x).of_le h
+
+lemma Terminating.subtype_sn (r : α → α → Prop) :
+    Terminating (α := {x // SN r x}) (fun a b => r a b) :=
+  iff_forall_sn.mpr fun x => x.property.onFun_of_image
+
+theorem SN.isNormalizable (hx : SN r x) : Normalizable r x := by
+  -- restrict to the subtype where all elements are `SN`, so `flip r` is well-founded
+  obtain ⟨⟨y, hsn⟩, hred : ReflTransGen r x y, hnorm⟩ :=
+    (Terminating.subtype_sn r).has_min
+    (s := Subtype.val ⁻¹' ({y | ReflTransGen r x y})) ⟨⟨x, hx⟩, ReflTransGen.refl⟩
+  use y, hred
+  intro ⟨z, hyz⟩
+  exact hnorm ⟨z, hsn.of_rel hyz⟩ (.tail hred hyz) hyz
+
+theorem Terminating.isNormalizing (hr : Terminating r) : Normalizing r :=
+  fun x => (hr.apply x).isNormalizable
 
 theorem Terminating.isConfluent_iff_all_unique_Normal (ht : Terminating r) :
     Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := by
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
index e9fd87fee6..9c98b17dac 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
@@ -26,7 +26,7 @@ universe u v
 
 namespace LambdaCalculus.LocallyNameless.Stlc
 
-open Untyped Typing LambdaCalculus.LocallyNameless.Untyped.Term
+open Untyped Typing LambdaCalculus.LocallyNameless.Untyped.Term Relation
 
 variable {Var : Type u} {Base : Type v} [DecidableEq Var] [HasFresh Var]
 
@@ -43,9 +43,9 @@ open scoped Term
 @[scoped grind]
 structure Saturated (S : Set (Term Var)) : Prop where
   lc : ∀ M ∈ S, LC M
-  sn : ∀ M ∈ S, SN M
+  sn : ∀ M ∈ S, SN FullBeta M
   neutal_lc : ∀ M, Neutral M → LC M → M ∈ S
-  multiApp : ∀ M N P, LC N → SN N → multiApp (M ^ N) P ∈ S → multiApp (M.abs.app N) P ∈ S
+  multiApp : ∀ M N P, LC N → SN FullBeta N → multiApp (M ^ N) P ∈ S → multiApp (M.abs.app N) P ∈ S
 
 /-- The semantic map maps each type to a corresponding saturated set of terms.
     For the strong normalization proof to work, we must ensure that
@@ -56,7 +56,7 @@ structure Saturated (S : Set (Term Var)) : Prop where
 -/
 @[simp, scoped grind =]
 def semanticMap : Ty Base → Set (Term Var)
-  | .base _ => { t | SN t ∧ LC t }
+  | .base _ => { t | SN FullBeta t ∧ LC t }
   | .arrow τ₁ τ₂ => { t | ∀ s, s ∈ semanticMap τ₁ → app t s ∈ semanticMap τ₂ }
 
 /-- The sets constructed by semanticMap are saturated -/
@@ -117,7 +117,7 @@ lemma soundness {Γ : Context Var (Ty Base)} (derivation_t : Γ ⊢ t ∶ τ) :
 /-- Using soundness and the fact that the empty context
     is entailed by any environment, we can conclude that
     a well-typed term is strongly normalizing. -/
-theorem strong_norm {t : Term Var} {τ : Ty Base} (der : Γ ⊢ t ∶ τ) : SN t := by
+theorem strong_norm {t : Term Var} {τ : Ty Base} (der : Γ ⊢ t ∶ τ) : SN FullBeta t := by
   apply (semanticMap_saturated τ).sn
   apply (soundness der [] (by grind) entails_context_empty)
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
index 2c5f2e7dc6..793061cfee 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
@@ -24,59 +24,52 @@ namespace LambdaCalculus.LocallyNameless.Untyped.Term
 
 variable {Var : Type u} {t t' : Term Var}
 
-open FullBeta
+open FullBeta Relation
 
 attribute [grind =] Finset.union_singleton
 
-/-- A term is strongly normalizing if every reduction sequence terminates at some point.
-    This is ensured by the following type as inductive data must always be finite. -/
-inductive SN {α} : Term α → Prop
-| sn t : (∀ t', t ⭢βᶠ t' → SN t') → SN t
-
-attribute [scoped grind .] SN.sn
-
 /-- A single β-reduction step preserves strong normalization. -/
-lemma sn_step (t_st_t' : t ⭢βᶠ t') (sn_t : SN t) : SN t' := by
-  grind [cases SN]
+lemma sn_step (t_st_t' : t ⭢βᶠ t') (sn_t : SN FullBeta t) : SN FullBeta t' :=
+  sn_t.of_rel t_st_t'
 
 /-- Multiple β-reduction steps also preserve strong normalization. -/
-lemma sn_steps (t_st_t' : t ↠βᶠ t') (sn_t : SN t) : SN t' := by
-  induction t_st_t' with grind [sn_step]
+lemma sn_steps (t_st_t' : t ↠βᶠ t') (sn_t : SN FullBeta t) : SN FullBeta t' :=
+  sn_t.of_rel_reflTransGen t_st_t'
 
 /-- Free variables are strongly normalizing. -/
-lemma sn_fvar {x : Var} : SN (fvar x) := by
-  grind only [cases Xi, cases Beta, SN]
+lemma sn_fvar {x : Var} : SN FullBeta (fvar x) := by
+  rw [SN_iff_SN_of_rel]
+  grind only [cases Xi, cases Beta]
 
 /-- An application is strongly normalizing if the left and right terms are strongly normalizing,
     as well as all possible future top level abstraction application beta reductions -/
-lemma sn_app (t s : Term Var) (sn_t : SN t) (sn_s : SN s)
-    (hβ : ∀ {t' s' : Term Var}, t ↠βᶠ t'.abs → s ↠βᶠ s' → SN (t' ^ s')) : SN (t.app s) := by
+lemma sn_app (t s : Term Var) (sn_t : SN FullBeta t) (sn_s : SN FullBeta s)
+    (hβ : ∀ {t' s' : Term Var}, t ↠βᶠ t'.abs → s ↠βᶠ s' → SN FullBeta (t' ^ s')) :
+    SN FullBeta (t.app s) := by
   induction sn_t generalizing s with
-  | sn t ht ih_t =>
+  | intro t ht ih_t =>
     induction sn_s with
-    | sn s hs ih_s =>
+    | intro s hs ih_s =>
       constructor
       intro u hstep
       cases hstep with
       | base h => cases h; grind
       | appL _ h_s_red => apply ih_s _ h_s_red
                           grind [Relation.ReflTransGen.head]
-      | appR _ h_t_red => apply ih_t _ h_t_red _ (SN.sn s hs)
+      | appR _ h_t_red => apply ih_t _ h_t_red _ (SN.intro hs)
                           grind [Relation.ReflTransGen.head]
 
 /-- The left side of a strongly normalizing application is strongly normalizing. -/
-lemma sn_app_left (M N : Term Var) (lc_N : Term.LC N) (sn_MN : SN (M.app N)) :
-    SN M := by
-  generalize Heq : M.app N = P
-  rw [Heq] at sn_MN
-  induction sn_MN generalizing M N with grind
+lemma sn_app_left (M N : Term Var) (lc_N : Term.LC N) (sn_MN : SN FullBeta (M.app N)) :
+    SN FullBeta M := by
+  refine sn_MN.onFun_of_image (f := (·.app N)) |>.of_le fun _ _ => ?_
+  exact Xi.appR lc_N
 
 /-- The right side of a strongly normalizing application is strongly normalizing. -/
-lemma sn_app_right (M N : Term Var) (lc_N : Term.LC M) (sn_MN : SN (M.app N)) :
-    SN N := by
-  generalize Heq : M.app N = P
-  rw [Heq] at sn_MN
-  induction sn_MN generalizing M N with grind
+lemma sn_app_right (M N : Term Var) (lc_M : Term.LC M) (sn_MN : SN FullBeta (M.app N)) :
+    SN FullBeta N := by
+  refine sn_MN.onFun_of_image (f := M.app) |>.of_le fun _ _ => ?_
+  exact Xi.appL lc_M
 
 /-- A neutral term is a term of the form v t₁ … t_n where
     v is a variable and t₁ … t_n are strongly normalizing terms. -/
@@ -87,7 +80,7 @@ inductive Neutral : Term Var → Prop
 /-- Just a free variable is neutral. -/
 | fvar : ∀ x, Neutral (fvar x)
 /-- Applying a strongly normalizing term to a neutral term yields a neutral term. -/
-| app : ∀ t1 t2, Neutral t1 → SN t2 → Neutral (app t1 t2)
+| app : ∀ t1 t2, Neutral t1 → SN FullBeta t2 → Neutral (app t1 t2)
 
 --attribute [scoped grind .] Neutral.bvar Neutral.fvar Neutral.app
 
@@ -100,17 +93,19 @@ lemma neutral_steps (Hneut : Neutral t) (Hsteps : t ↠βᶠ t') : Neutral t' :=
   induction Hsteps <;> grind [neutral_step]
 
 /-- Neutral terms are strongly normalizing. -/
-lemma sn_neutral (Hneut : Neutral t) : SN t := by
+lemma sn_neutral (Hneut : Neutral t) : SN FullBeta t := by
   induction Hneut with
   | app => grind [→ neutral_steps, sn_app]
-  | _ => grind only [SN, cases Xi]
+  | _ =>
+    rw [SN_iff_SN_of_rel]
+    grind only [cases Xi]
 
 /-- A lambda abstraction is strongly normalizing if its body is strongly normalizing. -/
-lemma sn_abs [DecidableEq Var] [HasFresh Var] {M N : Term Var} (sn_MN : SN (M ^ N)) (lc_N : LC N) :
-    SN (abs M) := by
+lemma sn_abs [DecidableEq Var] [HasFresh Var] {M N : Term Var} (sn_MN : SN FullBeta (M ^ N))
+    (lc_N : LC N) : SN FullBeta (abs M) := by
   generalize h : (M ^ N) = M_open at sn_MN
   induction sn_MN generalizing M N with
-  | sn =>
+  | intro =>
     constructor
     intro _ h_step
     cases h_step with
@@ -123,8 +118,9 @@ lemma sn_abs [DecidableEq Var] [HasFresh Var] {M N : Term Var} (sn_MN : SN (M ^
       1. N is locally closed,
       1. M ^ N P₁ … Pₙ is locally closed -/
 lemma sn_abs_app_multiApp [DecidableEq Var] [HasFresh Var] {Ps} {M N : Term Var}
-    (sn_N : SN N) (sn_MNPs : SN (multiApp (M ^ N) Ps))
-    (lc_N : LC N) (lc_MNPs : LC (multiApp (M ^ N) Ps)) : SN (multiApp (M.abs.app N) Ps) := by
+    (sn_N : SN FullBeta N) (sn_MNPs : SN FullBeta (multiApp (M ^ N) Ps))
+    (lc_N : LC N) (lc_MNPs : LC (multiApp (M ^ N) Ps)) :
+    SN FullBeta (multiApp (M.abs.app N) Ps) := by
   induction Ps with
   | nil =>
     apply sn_app

From ab16df6f9145bbee4e0c461402689c99be78c3bf Mon Sep 17 00:00:00 2001
From: Fabrizio Montesi <famontesi@gmail.com>
Date: Thu, 7 May 2026 17:29:59 +0200
Subject: [PATCH 015/106] feat: Modal Logic (#528)

Adds Modal Logic and the Modal Cube, including all the 15 well-known
modal logics (K, D, T, S5, etc.) and their relationships.

The notation that overlaps with propositional logic is consistent with
the existing module.

Note for future work (or here, if somebody can see an easy fix that
doesn't compromise readability for modal logicians): I'm not very
satisfied by the notation for judgements, which includes a ',' so it can
lead to some parsing trouble.

---------

Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
---
 Cslib.lean                           |   3 +
 Cslib/Foundations/Data/Relation.lean |  14 ++
 Cslib/Logics/Modal/Basic.lean        | 269 +++++++++++++++++++++++++++
 Cslib/Logics/Modal/Cube.lean         | 139 ++++++++++++++
 Cslib/Logics/Modal/Denotation.lean   |  51 +++++
 references.bib                       |  10 +
 6 files changed, 486 insertions(+)
 create mode 100644 Cslib/Logics/Modal/Basic.lean
 create mode 100644 Cslib/Logics/Modal/Cube.lean
 create mode 100644 Cslib/Logics/Modal/Denotation.lean

diff --git a/Cslib.lean b/Cslib.lean
index 37a038ee41..92a251cdfd 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -129,5 +129,8 @@ public import Cslib.Logics.LinearLogic.CLL.CutElimination
 public import Cslib.Logics.LinearLogic.CLL.EtaExpansion
 public import Cslib.Logics.LinearLogic.CLL.MLL
 public import Cslib.Logics.LinearLogic.CLL.PhaseSemantics.Basic
+public import Cslib.Logics.Modal.Basic
+public import Cslib.Logics.Modal.Cube
+public import Cslib.Logics.Modal.Denotation
 public import Cslib.Logics.Propositional.Defs
 public import Cslib.Logics.Propositional.NaturalDeduction.Basic
diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index b8060d3389..784e11b1e3 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -69,6 +69,10 @@ theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by
 /-- The relation `r` 'up to' the relation `s`. -/
 def UpTo (r s : α → α → Prop) : α → α → Prop := Comp s (Comp r s)
 
+/-- A relation `r` is (right) Euclidean if `r a b` and `r a c` guarantee `r b c`. -/
+class RightEuclidean (r : α → α → Prop) where
+  rightEuclidean : r a b → r a c → r b c
+
 /-- A relation has the diamond property when all reductions with a common origin are joinable -/
 abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c
 
@@ -148,6 +152,16 @@ theorem Confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) :
 /-- An element is reducible with respect to a relation if there is a value it is related to. -/
 abbrev Reducible (r : α → α → Prop) (x : α) : Prop := ∃ y, r x y
 
+/-- A relation `r` is serial if every element is `Reducible`. -/
+class Serial (r : α → α → Prop) where
+  serial a : Reducible r a
+
+@[scoped grind →]
+lemma refl_serial (r : α → α → Prop) (h : Std.Refl r) : Relation.Serial r where
+  serial a := ⟨a, h.refl a⟩
+
+instance [instRefl : Std.Refl r] : Relation.Serial r := refl_serial r instRefl
+
 /-- An element is normal if it is not reducible. -/
 abbrev Normal (r : α → α → Prop) (x : α) : Prop := ¬ Reducible r x
 
diff --git a/Cslib/Logics/Modal/Basic.lean b/Cslib/Logics/Modal/Basic.lean
new file mode 100644
index 0000000000..a627923676
--- /dev/null
+++ b/Cslib/Logics/Modal/Basic.lean
@@ -0,0 +1,269 @@
+/-
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Fabrizio Montesi, Marianna Girlando
+-/
+
+module
+
+public import Cslib.Init
+public import Cslib.Foundations.Logic.InferenceSystem
+public import Mathlib.Data.Set.Basic
+public import Mathlib.Order.Defs.Unbundled
+public import Cslib.Foundations.Data.Relation
+public import Mathlib.Logic.Nonempty
+
+/-! # Modal Logic
+
+Modal logic is a logic for reasoning about relational structures, studying statements about
+necessity (`□φ`) and possibility `◇φ`.
+
+## References
+
+* [P. Blackburn, M. de Rijke, Y. Venema, *Modal Logic*][Blackburn2001]
+* The definitions of theory equivalence and the denotational semantics of worlds are inspired by
+  the development of `Cslib.Logic.HML`.
+-/
+
+@[expose] public section
+
+namespace Cslib.Logic.Modal
+
+/-- A model consists of a relation between worlds `r` and a valuation `v`. -/
+structure Model (World : Type*) (Atom : Type*) where
+  /-- World accessibility relation. -/
+  r : World → World → Prop
+  /-- Valuation of atoms at a world. -/
+  v : World → Atom → Prop
+
+/-- Propositions. -/
+inductive Proposition (Atom : Type u) : Type u where
+  /-- Atomic proposition. -/
+  | atom (p : Atom)
+  /-- Negation. -/
+  | neg (φ : Proposition Atom)
+  /-- Conjunction. -/
+  | and (φ₁ φ₂ : Proposition Atom)
+  /-- Possibility. -/
+  | diamond (φ : Proposition Atom)
+
+@[inherit_doc] scoped prefix:40 "¬" => Proposition.neg
+@[inherit_doc] scoped infix:36 " ∧ " => Proposition.and
+@[inherit_doc] scoped prefix:40 "◇" => Proposition.diamond
+
+/-- Disjunction. -/
+def Proposition.or (φ₁ φ₂ : Proposition Atom) : Proposition Atom := ¬(¬φ₁ ∧ ¬φ₂)
+
+@[inherit_doc] scoped infix:35 " ∨ " => Proposition.or
+
+/-- Implication. -/
+def Proposition.impl (φ₁ φ₂ : Proposition Atom) : Proposition Atom := ¬φ₁ ∨ φ₂
+
+@[inherit_doc] scoped infix:30 " → " => Proposition.impl
+
+/-- Bi-implication. -/
+def Proposition.iff (φ₁ φ₂ : Proposition Atom) : Proposition Atom := (φ₁ → φ₂) ∧ (φ₂ → φ₁)
+
+@[inherit_doc] scoped infix:30 " ↔ " => Proposition.iff
+
+/-- Necessity. -/
+def Proposition.box (φ : Proposition Atom) : Proposition Atom := ¬◇¬φ
+
+@[inherit_doc] scoped prefix:40 "□" => Proposition.box
+
+/-- Satisfaction relation. `Satisfies m w φ` means that, in the model `m`, the world `w` satisfies
+the proposition `φ`. -/
+@[scoped grind]
+def Satisfies (m : Model World Atom) (w : World) : Proposition Atom → Prop
+  | .atom p => m.v w p
+  | .neg φ => ¬Satisfies m w φ
+  | .and φ₁ φ₂ => Satisfies m w φ₁ ∧ Satisfies m w φ₂
+  | .diamond φ => ∃ w', m.r w w' ∧ Satisfies m w' φ
+
+/-- Judgement, representing the conclusions one reaches in modal logic. -/
+structure Judgement World Atom where
+  /-- Constructs a judgement. -/
+  mk ::
+  /-- Model. -/
+  m : Model World Atom
+  /-- The world satisfying the proposition `φ`. -/
+  w : World
+  /-- The proposition satisfied by the world `w`. -/
+  φ : Proposition Atom
+
+@[inherit_doc] scoped notation "Modal[" m "," w " ⊨ " φ "]" => Judgement.mk m w φ
+
+/-- Satisfaction for judgements. This just refers to the unbundled `Satisfies`. -/
+@[simp, scoped grind =]
+def Satisfies.Bundled (j : Judgement World Atom) : Prop := Satisfies j.m j.w j.φ
+
+instance : HasInferenceSystem (Judgement World Atom) := ⟨Satisfies.Bundled⟩
+
+open scoped InferenceSystem Proposition
+
+@[scoped grind =]
+theorem derivation_def {m : Model World Atom} {w : World} {φ : Proposition Atom} :
+  ⇓Modal[m,w ⊨ φ] = Satisfies m w φ := rfl
+
+/-- A world satisfies a proposition iff it does not satisfy the negation of the proposition. -/
+@[scoped grind =]
+theorem neg_satisfies : ⇓Modal[m,w ⊨ ¬φ] ↔ ¬⇓Modal[m,w ⊨ φ] := by
+  induction φ generalizing w <;> grind
+
+/-- Characterisation of the `∨` connective.
+
+Disjunction is defined in terms of the more primitive connectives given in `Proposition`.
+This result proves that the definition is correct. -/
+@[scoped grind =]
+theorem Satisfies.or_iff_or {m : Model World Atom} :
+    ⇓Modal[m,w ⊨ φ₁ ∨ φ₂] ↔ ⇓Modal[m,w ⊨ φ₁] ∨ ⇓Modal[m,w ⊨ φ₂] := by grind [Proposition.or]
+
+/-- Characterisation of the `→` connective.
+
+Implication is defined in terms of the more primitive connectives given in `Proposition`.
+This result proves that the definition is correct.
+-/
+@[scoped grind =]
+theorem Satisfies.impl_iff_impl {m : Model World Atom} :
+    ⇓Modal[m,w ⊨ φ₁ → φ₂] ↔ (⇓Modal[m,w ⊨ φ₁] → ⇓Modal[m,w ⊨ φ₂]) := by grind [Proposition.impl]
+
+/-- Characterisation of the `□` modality.
+
+Necessity is defined in terms of the more primitive connectives given in `Proposition`.
+This result proves that the definition is correct. -/
+@[scoped grind =]
+theorem Satisfies.box_iff_forall {m : Model World Atom} :
+    ⇓Modal[m,w ⊨ □φ] ↔ ∀ w', m.r w w' → ⇓Modal[m,w' ⊨ φ] := by grind [Proposition.box]
+
+/-- The theory of a world in a model is the set of all propositions that it satifies. -/
+abbrev theory (m : Model World Atom) (w : World) : Set (Proposition Atom) :=
+  {φ | ⇓Modal[m,w ⊨ φ]}
+
+/-- Two worlds are theory-equivalent under a model if they have the same theory. -/
+abbrev TheoryEq (m : Model World Atom) (w₁ w₂ : World) :=
+  theory m w₁ = theory m w₂
+
+theorem TheoryEq.ext_iff : TheoryEq m w₁ w₂ ↔ (∀ φ, φ ∈ theory m w₁ ↔ φ ∈ theory m w₂) := by
+  grind
+
+/-- Any proposition satisfied by a world is in the theory of that world. -/
+@[scoped grind →]
+theorem satisfies_theory (h : Satisfies m w φ) : φ ∈ theory m w := by grind
+
+/-- If two worlds are not theory equivalent, there exists a distinguishing proposition. -/
+lemma not_theoryEq_satisfies (h : ¬TheoryEq m w₁ w₂) :
+    ∃ φ, (⇓Modal[m,w₁ ⊨ φ] ∧ ¬⇓Modal[m,w₂ ⊨ φ]) := by grind [=_ neg_satisfies]
+
+/-- If two worlds are theory equivalent and the former satisfies a proposition, the latter does as
+well. -/
+theorem theoryEq_satisfies {m : Model World Atom} (h : TheoryEq m w₁ w₂)
+    (hs : Satisfies m w₁ φ) : ⇓Modal[m,w₂ ⊨ φ] := by
+  apply TheoryEq.ext_iff.1 at h
+  exact (h φ).mp hs
+
+/-- The K axiom, valid for all models. -/
+theorem Satisfies.k : ⇓Modal[m,w ⊨ □(φ₁ → φ₂) → (□φ₁ → □φ₂)] := by grind
+
+set_option linter.tacticAnalysis.verifyGrindOnly false in
+/-- The dual axiom, valid for all models. -/
+theorem Satisfies.dual : ⇓Modal[m,w ⊨ ◇φ ↔ ¬□¬φ] := by
+  constructor
+  · grind
+  · grind only [→ satisfies_theory, usr Set.mem_setOf_eq, = impl_iff_impl, = derivation_def,
+    = neg_satisfies, Satisfies, = box_iff_forall, = Set.setOf_true]
+
+/-- The T axiom, valid for all reflexive models. -/
+theorem Satisfies.t {m : Model World Atom} [instRefl : Std.Refl m.r] {w : World}
+    (φ : Proposition Atom) : ⇓Modal[m,w ⊨ φ → ◇φ] := by grind [instRefl.refl w]
+
+/-- Any model that admits the axiom T is reflexive. -/
+theorem Satisfies.t_refl {r : World → World → Prop} [Nonempty Atom]
+    (h : ∀ {v} {w} {φ : Proposition Atom}, ⇓Modal[⟨r, v⟩,w ⊨ φ → ◇φ]) : Std.Refl r where
+  refl w := by
+    have a := Classical.arbitrary Atom
+    let v := fun (w' : World) (a : Atom) => w' = w
+    let h' := h (v := v) (w := w) (φ := .atom a)
+    grind
+
+/-- In any reflexive model, `□φ → φ` is equivalent to `φ → ◇φ`. -/
+theorem Satisfies.t_box_diamond [Std.Refl m.r] : ⇓Modal[m,w ⊨ □φ → φ] ↔ ⇓Modal[m,w ⊨ φ → ◇φ] := by
+  have := Std.Refl.refl (r := m.r) w
+  grind
+
+/-- The B axiom, valid for all symmetric models. -/
+theorem Satisfies.b {m : Model World Atom} [Std.Symm m.r] {w : World} (φ : Proposition Atom) :
+    ⇓Modal[m,w ⊨ φ → □◇φ] := by
+  have := Std.Symm.symm (r := m.r) w
+  grind
+
+/-- Any model that admits the axiom B is symmetric. -/
+theorem Satisfies.b_symm {World Atom} {r : World → World → Prop} [Nonempty Atom]
+    (h : ∀ {v} {w} {φ : Proposition Atom}, ⇓Modal[⟨r, v⟩,w ⊨ φ → □◇φ]) : Std.Symm r where
+  symm w₁ := by
+    have a := Classical.arbitrary Atom
+    let v₁ := fun (w' : World) (a : Atom) => w' = w₁
+    let h₁ := h (v := v₁) (w := w₁) (φ := .atom a)
+    simp [impl_iff_impl] at h₁
+    grind
+
+/-- The 4 axiom, valid for all transitive models. -/
+theorem Satisfies.four {m : Model World Atom} [IsTrans World m.r] {w : World}
+    (φ : Proposition Atom) : ⇓Modal[m,w ⊨ ◇◇φ → ◇φ] := by
+  simp only [impl_iff_impl]
+  intro h
+  rcases h with ⟨w', h₁, w'', h₂, hs⟩
+  exact ⟨w'', IsTrans.trans _ _ _ h₁ h₂, hs⟩
+
+/-- Any model that admits 4 is transitive. -/
+theorem Satisfies.four_trans {r : World → World → Prop} [Nonempty Atom]
+    (h : ∀ {v} {w} {φ : Proposition Atom}, ⇓Modal[⟨r, v⟩,w ⊨ ◇◇φ → ◇φ]) : IsTrans World r where
+  trans w₁ w₂ w₃ h₁ h₂ := by
+    have a := Classical.arbitrary Atom
+    let v := fun (w' : World) (a : Atom) => w' = w₃
+    let h' := h (v := v) (w := w₁) (φ := .atom a)
+    grind
+
+/-- The 5 axiom, valid for all Euclidean models. -/
+theorem Satisfies.five {m : Model World Atom} [Relation.RightEuclidean m.r]
+    {w : World}
+    (φ : Proposition Atom) : ⇓Modal[m,w ⊨ ◇φ → □◇φ] := by
+  have := @Relation.RightEuclidean.rightEuclidean (r := m.r)
+  grind
+
+/-- Any model that admits 5 is Euclidean. -/
+theorem Satisfies.five_rightEuclidean {r : World → World → Prop} [Nonempty Atom]
+    (h : ∀ {v} {w : World} {φ : Proposition Atom}, ⇓Modal[⟨r, v⟩,w ⊨ ◇φ → □◇φ]) :
+    Relation.RightEuclidean r where
+  rightEuclidean {w₁ w₂ w₃} h₁ h₂ := by
+    have a := Classical.arbitrary Atom
+    let v := fun (w' : World) (a : Atom) => w' = w₃
+    let h' := h (v := v) (w := w₁) (φ := .atom a)
+    grind
+
+/-- The D axiom, valid for all serial models. -/
+theorem Satisfies.d {m : Model World Atom} [Relation.Serial m.r] {w} (φ : Proposition Atom) :
+    ⇓Modal[m,w ⊨ □φ → ◇φ] := by
+  have : ∃ w', m.r w w' := Relation.Serial.serial w
+  grind
+
+/-- Any model that admits D is serial. -/
+theorem Satisfies.d_serial {r : World → World → Prop} [Nonempty Atom]
+    (h : ∀ {v} {w} {φ : Proposition Atom}, ⇓Modal[⟨r, v⟩,w ⊨ □φ → ◇φ]) : Relation.Serial r where
+  serial w₁ := by
+    have a := Classical.arbitrary Atom
+    let v := fun (w' : World) (a : Atom) => w' = w₁
+    let h' := h (v := v) (w := w₁) (φ := .atom a)
+    grind
+
+/-- A proposition is valid in a class of models `S` (modelled as a set) if it is satisfied under
+all models in `S` for all worlds. -/
+@[simp, scoped grind =]
+def Proposition.valid (S : Set (Model World Atom)) (φ : Proposition Atom) : Prop :=
+  ∀ (m : Model World Atom), ∀ (_ : m ∈ S), ∀ (w : World), ⇓Modal[m,w ⊨ φ]
+
+/-- The modal logic of a class of models `S` is the set of all propositions valid in `S`. -/
+@[simp, scoped grind =]
+def logic (S : Set (Model World Atom)) : Set (Proposition Atom) :=
+  {φ | φ.valid S}
+
+end Cslib.Logic.Modal
diff --git a/Cslib/Logics/Modal/Cube.lean b/Cslib/Logics/Modal/Cube.lean
new file mode 100644
index 0000000000..38b28295af
--- /dev/null
+++ b/Cslib/Logics/Modal/Cube.lean
@@ -0,0 +1,139 @@
+/-
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Fabrizio Montesi, Marianna Girlando
+-/
+
+module
+
+public import Cslib.Logics.Modal.Basic
+
+/-! # Modal Logic Cube
+
+This module formalises the Modal Cube, including all the 15 foundational modal logics and their
+relationships.
+
+## References
+
+* [P. Blackburn, M. de Rijke, Y. Venema, *Modal Logic*][Blackburn2001]
+
+-/
+
+@[expose] public section
+
+namespace Cslib.Logic.Modal
+
+/-- The modal logic K. -/
+@[simp, scoped grind =]
+def K World Atom := logic (Set.univ (α := Model World Atom))
+
+/-- The modal logic T. -/
+@[simp, scoped grind =]
+def T World Atom := logic {m : Model World Atom | Std.Refl m.r}
+
+/-- The modal logic B. -/
+@[simp, scoped grind =]
+def B World Atom := logic {m : Model World Atom | Std.Symm m.r}
+
+/-- The modal logic 4. -/
+@[simp, scoped grind =]
+def Four World Atom := logic {m : Model World Atom | IsTrans World m.r}
+
+/-- The modal logic 5. -/
+@[simp, scoped grind =]
+def Five World Atom := logic {m : Model World Atom | Relation.RightEuclidean m.r}
+
+/-- The modal logic K45. -/
+@[simp, scoped grind =]
+def K45 World Atom := (K World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
+
+/-- The modal logic D. -/
+@[simp, scoped grind =]
+def D World Atom := logic {m : Model World Atom | Relation.Serial m.r}
+
+/-- The modal logic D4. -/
+@[simp, scoped grind =]
+def D4 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom)
+
+/-- The modal logic D5. -/
+@[simp, scoped grind =]
+def D5 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Five World Atom)
+
+/-- The modal logic D45. -/
+@[simp, scoped grind =]
+def D45 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
+
+/-- The modal logic DB. -/
+@[simp, scoped grind =]
+def DB World Atom := (K World Atom) ∪ (D World Atom) ∪ (B World Atom)
+
+/-- The modal logic TB. -/
+@[simp, scoped grind =]
+def TB World Atom := (K World Atom) ∪ (T World Atom) ∪ (B World Atom)
+
+/-- The modal logic KB5. -/
+@[simp, scoped grind =]
+def KB5 World Atom := (K World Atom) ∪ (B World Atom) ∪ (Five World Atom)
+
+/-- The modal logic S4. -/
+@[simp, scoped grind =]
+def S4 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom)
+
+/-- The modal logic S5. -/
+@[simp, scoped grind =]
+def S5 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
+
+section Order
+
+/-! ## Ordering of Modal Logics
+
+This section proves the essential inclusions of modal logics.
+
+The other inclusions in the Modal Cube can be derived from the properties of `⊆` and `∪`, as shown
+in `k_subset_t`.
+-/
+
+open scoped Proposition
+
+theorem k_subset_d : (K World Atom ⊆ D World Atom) := by
+  intro φ; grind
+
+theorem k_subset_b : (K World Atom ⊆ B World Atom) := by
+  intro φ; grind
+
+theorem k_subset_four : (K World Atom ⊆ Four World Atom) := by
+  intro φ; grind
+
+theorem k_subset_five : (K World Atom ⊆ Five World Atom) := by
+  intro φ; grind
+
+open scoped Relation in
+theorem d_subset_t : (D World Atom ⊆ T World Atom) := by
+  intro φ; grind
+
+theorem k_subset_t : (K World Atom ⊆ T World Atom) := by
+  calc
+    K World Atom ⊆ D World Atom := k_subset_d
+    D World Atom ⊆ T World Atom := d_subset_t
+
+end Order
+
+section Validity
+
+/-! ## Validity
+
+This section showcases how to prove the expected validities in the different modal logics.
+-/
+
+/-- The axiom K is valid in the logic K. -/
+theorem K.k_valid : (□(φ₁ → φ₂) → (□φ₁ → □φ₂) : Proposition Atom) ∈ K World Atom := by
+  open scoped Proposition in grind [Satisfies.k]
+
+/-- The axiom T is valid in the logic T. -/
+theorem T.t_valid : (φ → ◇φ : Proposition Atom) ∈ T World Atom := by
+  intro _ h
+  grind [Satisfies.t (instRefl := (by assumption))]
+
+end Validity
+
+end Cslib.Logic.Modal
diff --git a/Cslib/Logics/Modal/Denotation.lean b/Cslib/Logics/Modal/Denotation.lean
new file mode 100644
index 0000000000..63e88000e0
--- /dev/null
+++ b/Cslib/Logics/Modal/Denotation.lean
@@ -0,0 +1,51 @@
+/-
+Copyright (c) 2026 Fabrizio Montesi. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Fabrizio Montesi
+-/
+
+module
+
+public import Cslib.Logics.Modal.Basic
+
+/-! # Denotational semantics for Modal Logic
+
+A denotational semantics for modal logic, inspired by the one for Hennessy-Milner Logic
+(`Cslib.Logic.HML`).
+-/
+
+@[expose] public section
+
+namespace Cslib.Logic.Modal
+
+open scoped Proposition InferenceSystem
+
+/-- Denotation of a proposition. -/
+@[simp, scoped grind =]
+def Proposition.denotation (m : Model World Atom) :
+    Proposition Atom → Set World
+  | .atom p => {w | m.v w p}
+  | .neg φ => (φ.denotation m)ᶜ
+  | .and φ₁ φ₂ => φ₁.denotation m ∩ φ₂.denotation m
+  | .diamond φ => {w | ∃ w', m.r w w' ∧ w' ∈ φ.denotation m}
+
+/-- Characterisation theorem for the denotational semantics. -/
+@[scoped grind =]
+theorem satisfies_mem_denotation {m : Model World Atom} {φ : Proposition Atom} :
+    w ∈ φ.denotation m ↔ ⇓Modal[m,w ⊨ φ] := by
+  induction φ generalizing w <;> grind
+
+/-- A world is in the denotation of a proposition iff it is not in the denotation of the negation
+of the proposition. -/
+@[scoped grind =]
+theorem neg_denotation {m : Model World Atom} (φ : Proposition Atom) :
+    w ∉ (¬φ).denotation m ↔ w ∈ φ.denotation m := by
+  grind [_=_ satisfies_mem_denotation]
+
+/-- Two worlds are theory-equivalent iff they are denotationally equivalent. -/
+theorem theoryEq_denotation_eq {m : Model World Atom} {w₁ w₂ : World} :
+    (TheoryEq m w₁ w₂) ↔
+    (∀ (φ : Proposition Atom), w₁ ∈ (φ.denotation m) ↔ w₂ ∈ (φ.denotation m)) := by
+  apply Iff.intro <;> grind [_=_ satisfies_mem_denotation]
+
+end Cslib.Logic.Modal
diff --git a/references.bib b/references.bib
index 1f8c0dc518..afa0213e93 100644
--- a/references.bib
+++ b/references.bib
@@ -28,6 +28,16 @@ @book{Baader1998
 address = {USA}
 }
 
+@book{Blackburn2001,
+  place={Cambridge},
+  series={Cambridge Tracts in Theoretical Computer Science},
+  title={Modal Logic},
+  publisher={Cambridge University Press},
+  author={Blackburn, Patrick and Rijke, Maarten de and Venema, Yde},
+  year={2001},
+  collection={Cambridge Tracts in Theoretical Computer Science}
+}
+
 @inproceedings{Danielsson2008,
 author = {Danielsson, Nils Anders},
 title = {Lightweight semiformal time complexity analysis for purely functional data structures},

From b37c36e4eff045ec347f83ad21328bd397e01eb0 Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Mon, 11 May 2026 02:40:22 -0400
Subject: [PATCH 016/106] feat: some lemmas about Euclidean relations (#557)

Some lemmas on Euclidean relations, including defining `LeftEuclidean`
to accompany the existing `RightEuclidean`. I erred on the side of
leaving most of these as theorems, as these are a bit problematic if all
made instances.

I will note again that these existed in FFL, but this adds a bit more
than is proven there.
---
 Cslib/Foundations/Data/Relation.lean | 99 ++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)

diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index 784e11b1e3..29635bee64 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -73,6 +73,105 @@ def UpTo (r s : α → α → Prop) : α → α → Prop := Comp s (Comp r s)
 class RightEuclidean (r : α → α → Prop) where
   rightEuclidean : r a b → r a c → r b c
 
+/-- A relation `r` is (left) Euclidean if `r a c` and `r b c` guarantee `r a b`. -/
+class LeftEuclidean (r : α → α → Prop) where
+  leftEuclidean {a b c} : r a c → r b c → r a b
+
+namespace RightEuclidean
+
+variable [RightEuclidean r]
+
+/-- A `RightEuclidean` relation is reflexive on its range -/
+theorem refl_range (ab : r a b) : r b b := rightEuclidean ab ab
+
+/-- The converse of a `RightEuclidean` relation is `LeftEuclidean` -/
+theorem leftEuclidean_swap : LeftEuclidean (fun a b => r b a) where
+  leftEuclidean ca cb := rightEuclidean cb ca
+
+instance [Std.Refl r] : Std.Symm r where
+  symm a _ ab := rightEuclidean ab (refl a)
+
+theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where
+  trans a b c ab bc := by
+    have := Std.Trichotomous.trichotomous (r := r) a c
+    have cc := refl_range bc
+    have (ca : r c a) := rightEuclidean ca cc
+    grind
+
+theorem antisymm_rightUnique [Std.Antisymm r] : Relator.RightUnique r := by
+  intros a b c ab ac
+  exact antisymm (rightEuclidean ab ac) (rightEuclidean ac ab)
+
+theorem rightUnique_antisymm (h : Relator.RightUnique r) : Std.Antisymm r where
+  antisymm _ _ ab ba := h ba (refl_range ab)
+
+end RightEuclidean
+
+namespace LeftEuclidean
+
+variable [LeftEuclidean r]
+
+/-- A `LeftEuclidean` relation is reflexive on its domain -/
+theorem refl_dom (ab : r a b) : r a a := leftEuclidean ab ab
+
+/-- The converse of a `LeftEuclidean` relation is `RightEuclidean` -/
+theorem rightEuclidean_swap : RightEuclidean (fun a b => r b a) where
+  rightEuclidean ab ac := leftEuclidean ac ab
+
+instance [Std.Refl r] : Std.Symm r where
+  symm _ b ab := leftEuclidean (refl b) ab
+
+theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where
+  trans a b c ab bc := by
+    have := Std.Trichotomous.trichotomous (r := r) a c
+    have aa := refl_dom ab
+    have (ca : r c a) := leftEuclidean aa ca
+    grind
+
+theorem antisymm_leftUnique [Std.Antisymm r] : Relator.LeftUnique r := by
+  intros a b c ac bc
+  exact antisymm (leftEuclidean ac bc) (leftEuclidean bc ac)
+
+theorem leftUnique_antisymm (h : Relator.LeftUnique r) : Std.Antisymm r where
+  antisymm _ _ ab ba := h ab (refl_dom ba)
+
+end LeftEuclidean
+
+section euclidean_symm
+
+variable [Std.Symm r]
+
+private theorem RightEuclidean.symm_leftEuclidean [RightEuclidean r] : LeftEuclidean r where
+  leftEuclidean ac bc := rightEuclidean (symm ac) (symm bc)
+
+private theorem LeftEuclidean.symm_trans [LeftEuclidean r] : IsTrans α r where
+  trans _ _ _ ab bc := leftEuclidean ab (symm bc)
+
+private theorem RightEuclidean.trans_symm [IsTrans α r] : RightEuclidean r where
+  rightEuclidean ab ac := _root_.trans (symm ab) ac
+
+private theorem symm_equivalents : [RightEuclidean r, LeftEuclidean r, IsTrans α r].TFAE := by
+  apply List.tfae_of_cycle
+  · simp only [List.isChain_cons_cons, List.IsChain.singleton, and_true]
+    split_ands
+    · exact @RightEuclidean.symm_leftEuclidean _ _ _
+    · exact @LeftEuclidean.symm_trans _ _ _
+  · exact @RightEuclidean.trans_symm _ _ _
+
+/-- For a symmetric relation, `LeftEuclidean` and `RightEuclidean` are equivalent. -/
+theorem symm_leftEuclidean_iff_rightEuclidean : LeftEuclidean r ↔ RightEuclidean r :=
+  List.TFAE.out symm_equivalents 1 0
+
+/-- For a symmetric relation, `LeftEuclidean` and transitivity are equivalent. -/
+theorem symm_leftEuclidean_iff_trans : LeftEuclidean r ↔  IsTrans α r :=
+  List.TFAE.out symm_equivalents 1 2
+
+/-- For a symmetric relation, `RightEuclidean` and transitivity are equivalent. -/
+theorem symm_rightEuclidean_iff_trans : RightEuclidean r ↔ IsTrans α r :=
+  List.TFAE.out symm_equivalents 0 2
+
+end euclidean_symm
+
 /-- A relation has the diamond property when all reductions with a common origin are joinable -/
 abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c
 

From ca0e27c11f3e34ef053c4e1df73563679c3dce60 Mon Sep 17 00:00:00 2001
From: Samuel Schlesinger <SamuelSchlesinger@users.noreply.github.com>
Date: Mon, 11 May 2026 04:02:38 -0400
Subject: [PATCH 017/106] feat(MachineLearning/PACLearning): definitions (#492)

Define the PAC learning model generalized to an arbitrary label type and
parameterized by a distribution family over labeled examples.

The unified definition `IsPACLearnerFor` captures the realizable,
agnostic, and noise-tolerant settings. Online PAC learning is not
treated here and left for future work. Given that the theorems we will
prove on this definition will require statements that look a whole lot
like `IsPACLearnerFor` anyways, this work will be compatible with future
online definitions.

---------

Co-authored-by: Fabrizio Montesi <famontesi@gmail.com>
---
 Cslib.lean                                  |   1 +
 Cslib/MachineLearning/PACLearning/Defs.lean | 528 ++++++++++++++++++++
 references.bib                              |  60 +++
 3 files changed, 589 insertions(+)
 create mode 100644 Cslib/MachineLearning/PACLearning/Defs.lean

diff --git a/Cslib.lean b/Cslib.lean
index 92a251cdfd..8bb4d86a50 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -134,3 +134,4 @@ public import Cslib.Logics.Modal.Cube
 public import Cslib.Logics.Modal.Denotation
 public import Cslib.Logics.Propositional.Defs
 public import Cslib.Logics.Propositional.NaturalDeduction.Basic
+public import Cslib.MachineLearning.PACLearning.Defs
diff --git a/Cslib/MachineLearning/PACLearning/Defs.lean b/Cslib/MachineLearning/PACLearning/Defs.lean
new file mode 100644
index 0000000000..e51ceff1fd
--- /dev/null
+++ b/Cslib/MachineLearning/PACLearning/Defs.lean
@@ -0,0 +1,528 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.MeasureTheory.Measure.MeasureSpace
+public import Mathlib.MeasureTheory.Constructions.Pi
+public import Mathlib.Order.SymmDiff
+
+/-! # PAC Learning
+
+This file defines the Probably Approximately Correct (PAC) learning model
+introduced by Valiant [Valiant1984], generalized to an arbitrary label type `β`
+and parameterized by a family of distributions `𝒟` on `α × β`.
+
+A concept class `C` over domain `α` with labels in `β` is a collection of
+functions `α → β`. A learning algorithm receives a labeled sample drawn i.i.d.
+from an unknown joint distribution `D` on `α × β` and must produce a hypothesis
+whose 0-1 error is within `ε` of the best concept in `C`, with probability at
+least `1 - δ`.
+
+The single definition `IsPACLearnerFor` captures the realizable, agnostic, and
+noise-tolerant settings by varying the distribution family `𝒟`:
+
+- **Agnostic** [Haussler1992]: `𝒟 = Set.univ` — the learner must work for all distributions.
+- **Realizable**: `𝒟` consists of pushforwards of arbitrary probability measures
+  `P` on `α` along the graph `x ↦ (x, c x)` of some concept `c ∈ C`, so that
+  `optimalError D C = 0`.
+- **Noise-tolerant** [AngluinLaird1988]: `𝒟` consists of noisy versions of realizable
+  distributions, where each label is corrupted independently with some probability `η`.
+
+The accuracy and confidence parameters `ε` and `δ` are elements of the subtype
+`Set.Ioo (0 : ℝ≥0) 1`, which bundles the value together with the proof that it
+lies in the open interval `(0, 1)`, ensuring the learning condition is non-vacuous.
+
+All declarations live under the `Cslib.MachineLearning.PACLearning` namespace so that
+generic names like `error` and `optimalError` do not pollute the parent namespace.
+
+## Main definitions
+
+- `ConceptClass`: a set of functions `α → β` (classifiers).
+- `LabeledSample`: a finite sequence of `(point, label)` pairs.
+- `Learner`: a function from labeled samples to hypotheses.
+- `error`: the 0-1 error of a hypothesis under a joint distribution.
+- `optimalError`: the infimum of `error` over a concept class.
+- `IsPACLearnerFor`: deterministic `(ε, δ)`-PAC learner over a distribution family.
+- `IsRPACLearnerFor`: randomized variant of `IsPACLearnerFor`. Universe-polymorphic in the
+  randomness space `Ω : Type*`.
+- `IsPACLearnable`: a concept class is PAC learnable if `IsPACLearnerFor` holds for
+  all `ε, δ : Set.Ioo (0 : ℝ≥0) 1` with some sample size `m`.
+- `IsRPACLearnable`: randomized variant of `IsPACLearnable`. Pins the randomness space to
+  `Type 0`; `IsRPACLearnerFor` itself remains universe-polymorphic for users who need it.
+- `LearnerModel`: the common predicate shape `ℕ → ε → δ → C → 𝒟 → Prop` abstracting both
+  the deterministic and randomized learners so sample-complexity lemmas can be shared.
+- `sampleComplexity`: sample complexity of a generic learner model.
+- `rsampleComplexity`: randomized sample complexity, i.e. `sampleComplexity IsRPACLearnerFor`.
+
+## Binary classification
+
+When `β = Bool`, concepts correspond to subsets of `α`. The section
+*Binary Classification* provides:
+
+- `hypothesisError`: the symmetric-difference error `P(h ∆ c)`.
+- `falsePositiveError`, `falseNegativeError`: its decomposition.
+- `hypothesisError_eq_add`: the decomposition theorem.
+- `error_map_eq_hypothesisError`: bridge between the general `error` and
+  the binary `hypothesisError` under a realizable distribution.
+
+## Main statements
+
+- `IsPACLearnerFor.toIsRPACLearnerFor`: every deterministic PAC learner is a
+  randomized one (via the trivial randomness space `PUnit`).
+- `IsPACLearnerFor.antitone_family`, `.antitone_C`: the deterministic PAC learner
+  predicate is antitone in the distribution family and concept class.
+- `IsPACLearnerFor.mono_δ`, `.mono_ε`: the predicate is monotone in the confidence and
+  accuracy parameters (a weaker bound still holds).
+- `IsRPACLearnerFor.antitone_family`, `.mono_δ`: analogues for the randomized predicate.
+  (`mono_ε` and `antitone_C` are not provided because they change the integrand and
+  would require an extra measurability assumption.)
+- `IsPACLearnable.toIsRPACLearnable`: deterministic learnability implies randomized.
+- `IsPACLearnable.antitone_family`, `.antitone_C`, `IsRPACLearnable.antitone_family`:
+  PAC learnability is antitone in the distribution family and concept class.
+- `sampleComplexity_antitone_δ`, `_antitone_ε`, `_mono_family`, `_mono_C`: variation of
+  deterministic sample complexity in confidence, accuracy, distribution family, and concept
+  class (antitone in the numeric parameters, monotone under `⊆` in the set parameters). The
+  randomized analogues `rsampleComplexity_antitone_δ` and `_mono_family` are provided.
+- `IsPACLearnable.sampleComplexity_*`, `IsRPACLearnable.rsampleComplexity_*`: the same
+  monotonicity facts phrased with a learnability hypothesis in place of the ad-hoc
+  `∃ m, IsPACLearnerFor m …` existence witness, so callers who already know the class is
+  learnable need not thread it through.
+- `hypothesisError_eq_add`: total error = false positive + false negative.
+
+## References
+
+* [L. G. Valiant, *A Theory of the Learnable*][Valiant1984]
+* [A. Ehrenfeucht, D. Haussler, M. Kearns, L. Valiant,
+  *A General Lower Bound on the Number of Examples Needed for Learning*][EHKV1989]
+* [M. J. Kearns, U. V. Vazirani,
+  *An Introduction to Computational Learning Theory*][KearnsVazirani1994]
+* [D. Haussler, *Decision Theoretic Generalizations of the PAC Model for Neural Net
+  and Other Learning Applications*][Haussler1992]
+* [D. Angluin, P. Laird, *Learning from Noisy Examples*][AngluinLaird1988]
+-/
+
+@[expose] public section
+
+open MeasureTheory Set
+open scoped ENNReal NNReal
+
+namespace Cslib.MachineLearning.PACLearning
+
+/-! ### Core Definitions -/
+
+/-- A *concept class* over domain `α` with label type `β` is a set of functions `α → β`.
+For binary classification (`β = Bool`), this is equivalent to a collection of subsets of `α`
+via the characteristic function. -/
+abbrev ConceptClass (α β : Type*) := Set (α → β)
+
+/-- A *labeled sample* of size `m` over domain `α` with label type `β` is a finite sequence
+of `(point, label)` pairs. -/
+abbrev LabeledSample (α β : Type*) (m : ℕ) := Fin m → (α × β)
+
+/-- A *learner* using `m` samples is a function that takes a labeled sample and produces
+a hypothesis (a function from the domain to the label type). -/
+abbrev Learner (α β : Type*) (m : ℕ) := LabeledSample α β m → (α → β)
+
+section
+variable {α : Type*} {β : Type*} [MeasurableSpace α] [MeasurableSpace β]
+
+/-- The *prediction error* (0-1 loss) of a hypothesis `h` under a joint distribution `D`
+on `α × β`, defined as the probability that the prediction disagrees with the label:
+`D({(x, y) | h(x) ≠ y})`. -/
+noncomputable def error (D : Measure (α × β)) (h : α → β) : ℝ≥0∞ :=
+  D {p : α × β | h p.1 ≠ p.2}
+
+/-- The *optimal error* of a concept class `C` under a joint distribution `D`, defined as the
+infimum of `error D c` over all concepts `c ∈ C`. When `C` is empty this is `⊤`, making the
+PAC learning condition vacuously true. -/
+noncomputable def optimalError (D : Measure (α × β)) (C : ConceptClass α β) : ℝ≥0∞ :=
+  ⨅ c ∈ C, error D c
+
+/-! ### PAC Learners -/
+
+/-- `IsPACLearnerFor m ε δ C 𝒟` asserts that there exists a learner using `m` samples
+that is `(ε, δ)`-correct for the concept class `C` over the distribution family `𝒟`: for every
+probability measure `D ∈ 𝒟` on `α × β`, the probability (over i.i.d. samples from `D`) that
+the learner's hypothesis has error exceeding `opt_C(D) + ε` is at most `δ`.
+
+The parameters `ε` and `δ` are elements of `Set.Ioo (0 : ℝ≥0) 1`, bundling the value with
+the proof that it lies in `(0, 1)`. This ensures the condition is non-vacuous:
+`ε < 1` prevents the error threshold from exceeding the maximum possible error under a
+probability measure, and `δ < 1` prevents the confidence bound from being trivially
+satisfied. -/
+def IsPACLearnerFor (m : ℕ) (ε δ : Set.Ioo (0 : ℝ≥0) 1)
+    (C : ConceptClass α β) (𝒟 : Set (Measure (α × β))) : Prop :=
+  ∃ A : Learner α β m,
+    ∀ (D : Measure (α × β)) [IsProbabilityMeasure D], D ∈ 𝒟 →
+      (Measure.pi (fun _ : Fin m => D))
+        {S : LabeledSample α β m |
+          error D (A S) > optimalError D C + ↑ε.val} ≤ ↑δ.val
+
+/-- `IsRPACLearnerFor m ε δ C 𝒟` asserts that there exists a *randomized* learner using
+`m` samples that is `(ε, δ)`-correct for the concept class `C` over the distribution family
+`𝒟`. A randomized learner draws internal randomness `ω` from a probability space `(Ω, Q)` and
+acts as the deterministic learner `A(ω)`.
+
+For every probability measure `D ∈ 𝒟`, the failure probability function
+`ω ↦ D^m{S | error(A(ω)(S)) > opt_C(D) + ε}` must be `Q`-a.e. measurable, and its
+expectation over `ω` must be at most `δ`.
+
+The randomness space `Ω : Type*` is universe-polymorphic; the universe is an implicit
+parameter of `IsRPACLearnerFor`, and downstream statements reference it via the pattern
+`IsRPACLearnerFor.{_, _, u}`. Fix `u := 0` for the usual case of a standard randomness space.
+
+A deterministic learner (`IsPACLearnerFor`) is the special case `Ω = PUnit`;
+see `IsPACLearnerFor.toIsRPACLearnerFor`. -/
+def IsRPACLearnerFor (m : ℕ) (ε δ : Set.Ioo (0 : ℝ≥0) 1)
+    (C : ConceptClass α β) (𝒟 : Set (Measure (α × β))) : Prop :=
+  ∃ (Ω : Type*) (_ : MeasurableSpace Ω) (Q : Measure Ω) (_ : IsProbabilityMeasure Q)
+    (A : Ω → Learner α β m),
+    ∀ (D : Measure (α × β)) [IsProbabilityMeasure D], D ∈ 𝒟 →
+      AEMeasurable (fun ω => (Measure.pi (fun _ : Fin m => D))
+        {S : LabeledSample α β m |
+          error D ((A ω) S) > optimalError D C + ↑ε.val}) Q ∧
+      ∫⁻ ω, (Measure.pi (fun _ : Fin m => D))
+        {S : LabeledSample α β m |
+          error D ((A ω) S) > optimalError D C + ↑ε.val} ∂Q ≤ ↑δ.val
+
+/-- Every deterministic PAC learner is in particular a randomized PAC learner
+(with the trivial one-point randomness space `PUnit`). -/
+theorem IsPACLearnerFor.toIsRPACLearnerFor {m : ℕ} {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : IsPACLearnerFor m ε δ C 𝒟) :
+    IsRPACLearnerFor m ε δ C 𝒟 := by
+  obtain ⟨A, hA⟩ := h
+  refine ⟨PUnit, inferInstance, Measure.dirac PUnit.unit, inferInstance, fun _ => A, ?_⟩
+  intro D _ hD
+  refine ⟨measurable_const.aemeasurable, ?_⟩
+  simp only [gt_iff_lt, lintegral_const, measure_univ, mul_one]
+  exact hA D hD
+
+/-- The deterministic PAC learner predicate is antitone in the distribution family: a
+learner for a larger family `𝒟'` is also a learner for any subfamily `𝒟 ⊆ 𝒟'`. -/
+theorem IsPACLearnerFor.antitone_family {m : ℕ} {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))}
+    (h𝒟 : 𝒟 ⊆ 𝒟') (h : IsPACLearnerFor m ε δ C 𝒟') :
+    IsPACLearnerFor m ε δ C 𝒟 := by
+  obtain ⟨A, hA⟩ := h
+  exact ⟨A, fun D inst hD => @hA D inst (h𝒟 hD)⟩
+
+/-- A PAC learner with confidence `δ₁` is also a PAC learner with any weaker confidence
+`δ₂ ≥ δ₁`: the failure-probability bound only gets looser. -/
+theorem IsPACLearnerFor.mono_δ {m : ℕ} {ε : Set.Ioo (0 : ℝ≥0) 1}
+    {δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1} (hδ : δ₁.val ≤ δ₂.val)
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : IsPACLearnerFor m ε δ₁ C 𝒟) :
+    IsPACLearnerFor m ε δ₂ C 𝒟 := by
+  obtain ⟨A, hA⟩ := h
+  refine ⟨A, fun D inst hD => le_trans (@hA D inst hD) ?_⟩
+  exact_mod_cast hδ
+
+/-- A PAC learner with accuracy `ε₁` is also a PAC learner with any weaker accuracy
+`ε₂ ≥ ε₁`: the bad event `{error > opt + ε}` only shrinks. -/
+theorem IsPACLearnerFor.mono_ε {m : ℕ} {δ : Set.Ioo (0 : ℝ≥0) 1}
+    {ε₁ ε₂ : Set.Ioo (0 : ℝ≥0) 1} (hε : ε₁.val ≤ ε₂.val)
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : IsPACLearnerFor m ε₁ δ C 𝒟) :
+    IsPACLearnerFor m ε₂ δ C 𝒟 := by
+  obtain ⟨A, hA⟩ := h
+  refine ⟨A, fun D inst hD => le_trans (measure_mono ?_) (@hA D inst hD)⟩
+  intro S hS
+  have hε' : (↑ε₁.val : ℝ≥0∞) ≤ ↑ε₂.val := by exact_mod_cast hε
+  calc optimalError D C + (↑ε₁.val : ℝ≥0∞)
+      ≤ optimalError D C + ↑ε₂.val := by gcongr
+    _ < error D (A S) := hS
+
+/-- The deterministic PAC learner predicate is antitone in the concept class: a learner
+for a larger class `C'` is also a learner for any subclass `C ⊆ C'`, since the agnostic
+benchmark `optimalError _ C ≥ optimalError _ C'` makes the error requirement easier. -/
+theorem IsPACLearnerFor.antitone_C {m : ℕ} {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C C' : ConceptClass α β} (hC : C ⊆ C')
+    {𝒟 : Set (Measure (α × β))} (h : IsPACLearnerFor m ε δ C' 𝒟) :
+    IsPACLearnerFor m ε δ C 𝒟 := by
+  obtain ⟨A, hA⟩ := h
+  refine ⟨A, fun D inst hD => le_trans (measure_mono ?_) (@hA D inst hD)⟩
+  intro S hS
+  have h_opt : optimalError D C' ≤ optimalError D C := iInf_le_iInf_of_subset hC
+  calc optimalError D C' + (↑ε.val : ℝ≥0∞)
+      ≤ optimalError D C + ↑ε.val := by gcongr
+    _ < error D (A S) := hS
+
+/-- The randomized PAC learner predicate is antitone in the distribution family. The
+universe of the randomness space `Ω` is pinned so the hypothesis and conclusion share it. -/
+theorem IsRPACLearnerFor.antitone_family.{u} {m : ℕ} {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))}
+    (h𝒟 : 𝒟 ⊆ 𝒟') (h : IsRPACLearnerFor.{_, _, u} m ε δ C 𝒟') :
+    IsRPACLearnerFor.{_, _, u} m ε δ C 𝒟 := by
+  obtain ⟨Ω, mΩ, Q, hQ, A, hA⟩ := h
+  exact ⟨Ω, mΩ, Q, hQ, A, fun D inst hD => @hA D inst (h𝒟 hD)⟩
+
+/-- A randomized PAC learner with confidence `δ₁` is also a randomized PAC learner with
+any weaker confidence `δ₂ ≥ δ₁`. Unlike `mono_ε` or `antitone_C`, this does not touch the
+integrand, so it carries the `AEMeasurable` part through unchanged. -/
+theorem IsRPACLearnerFor.mono_δ.{u} {m : ℕ} {ε : Set.Ioo (0 : ℝ≥0) 1}
+    {δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1} (hδ : δ₁.val ≤ δ₂.val)
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : IsRPACLearnerFor.{_, _, u} m ε δ₁ C 𝒟) :
+    IsRPACLearnerFor.{_, _, u} m ε δ₂ C 𝒟 := by
+  obtain ⟨Ω, mΩ, Q, hQ, A, hA⟩ := h
+  refine ⟨Ω, mΩ, Q, hQ, A, fun D inst hD => ?_⟩
+  obtain ⟨hmeas, hint⟩ := @hA D inst hD
+  refine ⟨hmeas, le_trans hint ?_⟩
+  exact_mod_cast hδ
+
+/-! ### PAC Learnability -/
+
+/-- A concept class `C` is *PAC learnable* over the distribution family `𝒟` if for every
+accuracy `ε ∈ (0, 1)` and confidence `δ ∈ (0, 1)`, there exists a sample size `m` admitting
+a deterministic `(ε, δ)`-PAC learner for `C`. Here `ε` and `δ` are elements of the subtype
+`Set.Ioo (0 : ℝ≥0) 1`. -/
+def IsPACLearnable (C : ConceptClass α β) (𝒟 : Set (Measure (α × β))) : Prop :=
+  ∀ (ε δ : Set.Ioo (0 : ℝ≥0) 1),
+    ∃ m, IsPACLearnerFor m ε δ C 𝒟
+
+/-- A concept class `C` is *randomized PAC learnable* over the distribution family `𝒟` if for
+every accuracy `ε ∈ (0, 1)` and confidence `δ ∈ (0, 1)`, there exists a sample size `m`
+admitting a randomized `(ε, δ)`-PAC learner for `C`. The randomness space is pinned to
+`Type 0` at the learnability level; `IsRPACLearnerFor` itself remains universe-polymorphic. -/
+def IsRPACLearnable (C : ConceptClass α β) (𝒟 : Set (Measure (α × β))) : Prop :=
+  ∀ (ε δ : Set.Ioo (0 : ℝ≥0) 1),
+    ∃ m, IsRPACLearnerFor.{_, _, 0} m ε δ C 𝒟
+
+/-- Deterministic PAC learnability implies randomized PAC learnability. -/
+theorem IsPACLearnable.toIsRPACLearnable {C : ConceptClass α β}
+    {𝒟 : Set (Measure (α × β))} (h : IsPACLearnable C 𝒟) :
+    IsRPACLearnable C 𝒟 := by
+  intro ε δ
+  obtain ⟨m, hm⟩ := h ε δ
+  exact ⟨m, hm.toIsRPACLearnerFor⟩
+
+/-- PAC learnability is antitone in the distribution family: a subfamily of a learnable
+family is learnable. -/
+theorem IsPACLearnable.antitone_family {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))}
+    (h𝒟 : 𝒟 ⊆ 𝒟') (h : IsPACLearnable C 𝒟') : IsPACLearnable C 𝒟 :=
+  fun ε δ => (h ε δ).imp fun _ hm => hm.antitone_family h𝒟
+
+/-- PAC learnability is antitone in the concept class: a subclass of a learnable class is
+learnable. -/
+theorem IsPACLearnable.antitone_C {C C' : ConceptClass α β} (hC : C ⊆ C')
+    {𝒟 : Set (Measure (α × β))} (h : IsPACLearnable C' 𝒟) : IsPACLearnable C 𝒟 :=
+  fun ε δ => (h ε δ).imp fun _ hm => hm.antitone_C hC
+
+/-- Randomized PAC learnability is antitone in the distribution family. -/
+theorem IsRPACLearnable.antitone_family {C : ConceptClass α β}
+    {𝒟 𝒟' : Set (Measure (α × β))} (h𝒟 : 𝒟 ⊆ 𝒟')
+    (h : IsRPACLearnable C 𝒟') : IsRPACLearnable C 𝒟 :=
+  fun ε δ => (h ε δ).imp fun _ hm => hm.antitone_family h𝒟
+
+/-! ### Sample Complexity -/
+
+/-- A *learner model* is a predicate on (sample size, accuracy, confidence, concept class,
+distribution family) that classifies which sample sizes admit a learner of the given kind.
+Instantiating with `IsPACLearnerFor` gives the deterministic model; with `IsRPACLearnerFor`
+gives the randomized one. -/
+abbrev LearnerModel (α β : Type*) [MeasurableSpace α] [MeasurableSpace β] :=
+  ℕ → Set.Ioo (0 : ℝ≥0) 1 → Set.Ioo (0 : ℝ≥0) 1 →
+    ConceptClass α β → Set (Measure (α × β)) → Prop
+
+/-- The *sample complexity* of a concept class `C` under a learner model `L`, at accuracy
+`ε ∈ (0, 1)` and confidence `δ ∈ (0, 1)` over distribution family `𝒟`, is the smallest sample
+size `m` with `L m ε δ C 𝒟`. Specialize with `L := IsPACLearnerFor` for the deterministic model
+and `L := IsRPACLearnerFor` for the randomized one.
+
+**Caveat**: because `sInf` on `ℕ` returns `0` for the empty set, this definition returns `0`
+when no learner exists (e.g., a concept class of infinite VC dimension). It is only meaningful
+when the defining set `{m | L m ε δ C 𝒟}` is nonempty. The `IsPACLearnable.sampleComplexity_*`
+variants below discharge this nonemptiness from a learnability hypothesis. -/
+noncomputable def sampleComplexity (L : LearnerModel α β) (C : ConceptClass α β)
+    (ε δ : Set.Ioo (0 : ℝ≥0) 1) (𝒟 : Set (Measure (α × β))) : ℕ :=
+  sInf {m : ℕ | L m ε δ C 𝒟}
+
+/-- The *randomized sample complexity* of `C`, i.e. `sampleComplexity` instantiated at the
+randomized learner model `IsRPACLearnerFor`. The randomness space is pinned to `Type 0`. -/
+noncomputable def rsampleComplexity (C : ConceptClass α β) (ε δ : Set.Ioo (0 : ℝ≥0) 1)
+    (𝒟 : Set (Measure (α × β))) : ℕ :=
+  sampleComplexity IsRPACLearnerFor.{_, _, 0} C ε δ 𝒟
+
+/-! ### Monotonicity of Sample Complexity
+
+These lemmas are all special cases of the following observation: if `{m | L₁ m ε₁ δ₁ C₁ 𝒟₁} ⊆
+{m | L₂ m ε₂ δ₂ C₂ 𝒟₂}` and the first set is nonempty, then the sample complexity under
+`(L₂, ε₂, δ₂, C₂, 𝒟₂)` is at most the sample complexity under `(L₁, ε₁, δ₁, C₁, 𝒟₁)`. The
+nonemptiness hypothesis is essential: `sInf` on `ℕ` returns `0` for an empty set, so without
+it the inequality can fail at the degenerate boundary. The `IsPACLearnable`-flavoured variants
+at the end of this section discharge that witness from a learnability hypothesis. -/
+
+/-- General pointwise monotonicity of `sampleComplexity`: if every witness sample size for
+`(L₁, ε₁, δ₁, C₁, 𝒟₁)` is also a witness for `(L₂, ε₂, δ₂, C₂, 𝒟₂)`, then the latter's
+sample complexity is at most the former's (provided the former is attained). -/
+theorem sampleComplexity_le_of_forall {L₁ L₂ : LearnerModel α β}
+    {ε₁ δ₁ ε₂ δ₂ : Set.Ioo (0 : ℝ≥0) 1} {C₁ C₂ : ConceptClass α β}
+    {𝒟₁ 𝒟₂ : Set (Measure (α × β))}
+    (hL : ∀ {m : ℕ}, L₁ m ε₁ δ₁ C₁ 𝒟₁ → L₂ m ε₂ δ₂ C₂ 𝒟₂)
+    (h : ∃ m, L₁ m ε₁ δ₁ C₁ 𝒟₁) :
+    sampleComplexity L₂ C₂ ε₂ δ₂ 𝒟₂ ≤ sampleComplexity L₁ C₁ ε₁ δ₁ 𝒟₁ :=
+  Nat.sInf_le (hL (Nat.sInf_mem h))
+
+/-- Deterministic sample complexity is antitone in the confidence parameter `δ`: weaker
+confidence requires no more samples. -/
+theorem sampleComplexity_antitone_δ {ε δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1} (hδ : δ₁.val ≤ δ₂.val)
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : ∃ m, IsPACLearnerFor m ε δ₁ C 𝒟) :
+    sampleComplexity IsPACLearnerFor C ε δ₂ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε δ₁ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_δ hδ) h
+
+/-- Deterministic sample complexity is antitone in the accuracy parameter `ε`: weaker
+accuracy requires no more samples. -/
+theorem sampleComplexity_antitone_ε {ε₁ ε₂ δ : Set.Ioo (0 : ℝ≥0) 1} (hε : ε₁.val ≤ ε₂.val)
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : ∃ m, IsPACLearnerFor m ε₁ δ C 𝒟) :
+    sampleComplexity IsPACLearnerFor C ε₂ δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε₁ δ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_ε hε) h
+
+/-- Deterministic sample complexity is monotone in the distribution family under `⊆`: a
+smaller family (fewer distributions to cover) requires no more samples. -/
+theorem sampleComplexity_mono_family {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))} (h𝒟 : 𝒟 ⊆ 𝒟')
+    (h : ∃ m, IsPACLearnerFor m ε δ C 𝒟') :
+    sampleComplexity IsPACLearnerFor C ε δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε δ 𝒟' :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_family h𝒟) h
+
+/-- Deterministic sample complexity is monotone in the concept class under `⊆`: a smaller
+class (weaker agnostic benchmark) requires no more samples. -/
+theorem sampleComplexity_mono_C {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C C' : ConceptClass α β} (hC : C ⊆ C') {𝒟 : Set (Measure (α × β))}
+    (h : ∃ m, IsPACLearnerFor m ε δ C' 𝒟) :
+    sampleComplexity IsPACLearnerFor C ε δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C' ε δ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_C hC) h
+
+/-- Randomized sample complexity is antitone in the confidence parameter `δ`. -/
+theorem rsampleComplexity_antitone_δ {ε δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1}
+    (hδ : δ₁.val ≤ δ₂.val) {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (h : ∃ m, IsRPACLearnerFor.{_, _, 0} m ε δ₁ C 𝒟) :
+    rsampleComplexity C ε δ₂ 𝒟 ≤ rsampleComplexity C ε δ₁ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_δ hδ) h
+
+/-- Randomized sample complexity is monotone in the distribution family under `⊆`. -/
+theorem rsampleComplexity_mono_family {ε δ : Set.Ioo (0 : ℝ≥0) 1}
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))} (h𝒟 : 𝒟 ⊆ 𝒟')
+    (h : ∃ m, IsRPACLearnerFor.{_, _, 0} m ε δ C 𝒟') :
+    rsampleComplexity C ε δ 𝒟 ≤ rsampleComplexity C ε δ 𝒟' :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_family h𝒟) h
+
+/-! Convenience variants conditional on learnability, which discharge the nonemptiness
+hypothesis `(∃ m, IsPACLearnerFor m …)` from an `IsPACLearnable` / `IsRPACLearnable` witness.
+Bodies go through `sampleComplexity_le_of_forall` directly rather than the top-level
+`sampleComplexity_*` lemmas, whose unqualified names would resolve as self-recursion inside
+these theorems' `IsPACLearnable.*` / `IsRPACLearnable.*` namespaces. -/
+
+/-- `sampleComplexity_antitone_δ` for a learnable class: the nonemptiness hypothesis comes
+for free from `IsPACLearnable`. -/
+theorem IsPACLearnable.sampleComplexity_antitone_δ
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))} (hL : IsPACLearnable C 𝒟)
+    {ε δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1} (hδ : δ₁.val ≤ δ₂.val) :
+    sampleComplexity IsPACLearnerFor C ε δ₂ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε δ₁ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_δ hδ) (hL ε δ₁)
+
+/-- `sampleComplexity_antitone_ε` for a learnable class. -/
+theorem IsPACLearnable.sampleComplexity_antitone_ε
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))} (hL : IsPACLearnable C 𝒟)
+    {ε₁ ε₂ δ : Set.Ioo (0 : ℝ≥0) 1} (hε : ε₁.val ≤ ε₂.val) :
+    sampleComplexity IsPACLearnerFor C ε₂ δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε₁ δ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_ε hε) (hL ε₁ δ)
+
+/-- `sampleComplexity_mono_family` for a learnable class (learnability at the *larger*
+family `𝒟'` is the hypothesis). -/
+theorem IsPACLearnable.sampleComplexity_mono_family
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))}
+    (hL : IsPACLearnable C 𝒟') (h𝒟 : 𝒟 ⊆ 𝒟') {ε δ : Set.Ioo (0 : ℝ≥0) 1} :
+    sampleComplexity IsPACLearnerFor C ε δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C ε δ 𝒟' :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_family h𝒟) (hL ε δ)
+
+/-- `sampleComplexity_mono_C` for a learnable class (learnability at the *larger* class
+`C'` is the hypothesis). -/
+theorem IsPACLearnable.sampleComplexity_mono_C
+    {C C' : ConceptClass α β} {𝒟 : Set (Measure (α × β))}
+    (hL : IsPACLearnable C' 𝒟) (hC : C ⊆ C') {ε δ : Set.Ioo (0 : ℝ≥0) 1} :
+    sampleComplexity IsPACLearnerFor C ε δ 𝒟 ≤ sampleComplexity IsPACLearnerFor C' ε δ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_C hC) (hL ε δ)
+
+/-- `rsampleComplexity_antitone_δ` for a randomized-learnable class. -/
+theorem IsRPACLearnable.rsampleComplexity_antitone_δ
+    {C : ConceptClass α β} {𝒟 : Set (Measure (α × β))} (hL : IsRPACLearnable C 𝒟)
+    {ε δ₁ δ₂ : Set.Ioo (0 : ℝ≥0) 1} (hδ : δ₁.val ≤ δ₂.val) :
+    rsampleComplexity C ε δ₂ 𝒟 ≤ rsampleComplexity C ε δ₁ 𝒟 :=
+  sampleComplexity_le_of_forall (fun h' => h'.mono_δ hδ) (hL ε δ₁)
+
+/-- `rsampleComplexity_mono_family` for a randomized-learnable class. -/
+theorem IsRPACLearnable.rsampleComplexity_mono_family
+    {C : ConceptClass α β} {𝒟 𝒟' : Set (Measure (α × β))}
+    (hL : IsRPACLearnable C 𝒟') (h𝒟 : 𝒟 ⊆ 𝒟') {ε δ : Set.Ioo (0 : ℝ≥0) 1} :
+    rsampleComplexity C ε δ 𝒟 ≤ rsampleComplexity C ε δ 𝒟' :=
+  sampleComplexity_le_of_forall (fun h' => h'.antitone_family h𝒟) (hL ε δ)
+
+end
+
+/-! ### Binary Classification
+
+When `β = Bool`, concepts correspond to subsets of `α` via the characteristic function.
+The symmetric-difference error `P(h ∆ c)` is the natural error metric, and it decomposes
+into false positive and false negative components.
+
+The bridge lemma `error_map_eq_hypothesisError` connects the general `error` on `α × Bool`
+to the binary `hypothesisError` on `α`, showing they coincide for realizable distributions. -/
+
+section Binary
+variable {α : Type*} [MeasurableSpace α]
+
+/-- The *symmetric-difference error* of a hypothesis `h` with respect to a target concept `c`
+(both viewed as subsets of `α`) under distribution `P`, defined as `P(h ∆ c)`. -/
+noncomputable def hypothesisError (P : Measure α) (h c : Set α) : ℝ≥0∞ :=
+  P (symmDiff h c)
+
+/-- The *false positive error* `P(h \ c)` — points classified positive but not in the
+concept. -/
+noncomputable def falsePositiveError (P : Measure α) (h c : Set α) : ℝ≥0∞ :=
+  P (h \ c)
+
+/-- The *false negative error* `P(c \ h)` — points in the concept but classified negative. -/
+noncomputable def falseNegativeError (P : Measure α) (h c : Set α) : ℝ≥0∞ :=
+  P (c \ h)
+
+/-- The total hypothesis error decomposes as the sum of false positive and false negative
+errors, since `h ∆ c = (h \ c) ∪ (c \ h)` is a disjoint union. -/
+theorem hypothesisError_eq_add {P : Measure α} {h c : Set α}
+    (hh : MeasurableSet h) (hc : MeasurableSet c) :
+    hypothesisError P h c = falsePositiveError P h c + falseNegativeError P h c := by
+  simp only [hypothesisError, falsePositiveError, falseNegativeError, symmDiff_def, sup_eq_union]
+  exact measure_union disjoint_sdiff_sdiff (hc.diff hh)
+
+open Classical in
+/-- Under a realizable distribution `P.map (x ↦ (x, c(x)))`, the general 0-1 `error`
+coincides with the binary `hypothesisError P h c`, where `h` and `c` are viewed as subsets
+of `α` via the characteristic function `decide (· ∈ ·)`. -/
+theorem error_map_eq_hypothesisError (P : Measure α) (h c : Set α)
+    (hh : MeasurableSet h) (hc : MeasurableSet c) :
+    error (P.map (fun x => (x, decide (x ∈ c)))) (fun x => decide (x ∈ h)) =
+    hypothesisError P h c := by
+  simp only [error, hypothesisError]
+  have hf : Measurable (fun x => (x, decide (x ∈ c))) :=
+    Measurable.prodMk measurable_id
+      (measurable_to_bool (by convert hc using 1; ext x; simp [decide_eq_true_eq]))
+  rw [Measure.map_apply_of_aemeasurable hf.aemeasurable]
+  · congr 1; ext x
+    simp only [Set.mem_preimage, Set.mem_setOf_eq, symmDiff_def, sup_eq_union,
+      Set.mem_union, Set.mem_diff]
+    by_cases hx : x ∈ h <;> by_cases hcx : x ∈ c <;> simp_all
+  · convert (hh.prod (measurableSet_singleton false)).union
+      (hh.compl.prod (measurableSet_singleton true)) using 1
+    ext ⟨x, b⟩; cases b <;> simp
+
+end Binary
+
+end Cslib.MachineLearning.PACLearning
diff --git a/references.bib b/references.bib
index afa0213e93..f0db1a781e 100644
--- a/references.bib
+++ b/references.bib
@@ -19,6 +19,17 @@ @inproceedings{Aceto1999
   bibsource    = {dblp computer science bibliography, https://dblp.org}
 }
 
+@article{AngluinLaird1988,
+  author       = {Angluin, Dana and Laird, Philip},
+  title        = {Learning from Noisy Examples},
+  journal      = {Machine Learning},
+  volume       = {2},
+  number       = {4},
+  pages        = {343--370},
+  year         = {1988},
+  doi          = {10.1007/BF00116829}
+}
+
 @book{Baader1998,
 author = {Baader, Franz and Nipkow, Tobias},
 title = {Term rewriting and all that},
@@ -117,6 +128,18 @@ @inbook{          Girard1995
   collection={London Mathematical Society Lecture Note Series}
 }
 
+@article{Haussler1992,
+  author       = {Haussler, David},
+  title        = {Decision Theoretic Generalizations of the {PAC} Model for Neural Net and Other Learning Applications},
+  journal      = {Information and Computation},
+  volume       = {100},
+  number       = {1},
+  pages        = {78--150},
+  year         = {1992},
+  issn         = {0890-5401},
+  doi          = {10.1016/0890-5401(92)90010-D}
+}
+
 @article{         Hennessy1985,
   author       = {Matthew Hennessy and
                   Robin Milner},
@@ -285,6 +308,43 @@ @article{         ShepherdsonSturgis1963
   address      = {New York, NY, USA}
 }
 
+@inproceedings{Valiant1984,
+  author       = {Valiant, L. G.},
+  title        = {A Theory of the Learnable},
+  year         = {1984},
+  isbn         = {0-89791-133-4},
+  publisher    = {Association for Computing Machinery},
+  address      = {New York, NY, USA},
+  url          = {https://doi.org/10.1145/800057.808710},
+  doi          = {10.1145/800057.808710},
+  booktitle    = {Proceedings of the Sixteenth Annual ACM Symposium on Theory of Computing},
+  pages        = {436--445},
+  series       = {STOC '84}
+}
+
+@article{EHKV1989,
+  author       = {Ehrenfeucht, Andrzej and Haussler, David and Kearns, Michael and Valiant, Leslie},
+  title        = {A General Lower Bound on the Number of Examples Needed for Learning},
+  journal      = {Information and Computation},
+  volume       = {82},
+  number       = {3},
+  pages        = {247--261},
+  year         = {1989},
+  issn         = {0890-5401},
+  url          = {https://doi.org/10.1016/0890-5401(89)90002-3},
+  doi          = {10.1016/0890-5401(89)90002-3},
+  publisher    = {Academic Press}
+}
+
+@book{KearnsVazirani1994,
+  author       = {Kearns, Michael J. and Vazirani, Umesh V.},
+  title        = {An Introduction to Computational Learning Theory},
+  year         = {1994},
+  isbn         = {978-0-262-11193-5},
+  publisher    = {MIT Press},
+  address      = {Cambridge, MA, USA}
+}
+
 @incollection{WinskelNielsen1995,
   author       = {Winskel, Glynn and Nielsen, Mogens},
   isbn         = {9780198537809},

From 57e5054134b4d049d85e7c4404115c69b6de043a Mon Sep 17 00:00:00 2001
From: Samuel Schlesinger <SamuelSchlesinger@users.noreply.github.com>
Date: Mon, 11 May 2026 06:11:06 -0400
Subject: [PATCH 018/106] feat(Cryptography/SecretSharing): Shamir's secret
 sharing (#495)

Added a general definition of a secret sharing protocol along with
privacy definitions: view indistinguishability and perfect privacy.
Implemented Shamir's secret sharing as an instance, then proved view
indistinguishability and perfect privacy of translation invariant tail
polynomial distributions. Specialized to the uniform tail polynomial
distribution as that is the typical setting.

A few more PMF utilities were needed, I am planning to upstream those to
Mathlib along with the existing ones from perfectly secret encryption
schemes.

---------

Co-authored-by: Fabrizio Montesi <famontesi@gmail.com>
---
 Cslib.lean                                    |   6 +-
 .../Crypto/Protocols/PerfectSecrecy/Defs.lean |   4 +-
 .../Internal/PerfectSecrecy.lean              |   4 +-
 .../Crypto/Protocols/SecretSharing/Defs.lean  | 104 ++++++
 .../Protocols/SecretSharing/Scheme.lean       | 107 ++++++
 .../Protocols/SecretSharing/Shamir.lean       | 327 ++++++++++++++++++
 .../SecretSharing/Shamir/Polynomial.lean      | 144 ++++++++
 .../PMF.lean}                                 |  59 +++-
 references.bib                                |  13 +
 9 files changed, 755 insertions(+), 13 deletions(-)
 create mode 100644 Cslib/Crypto/Protocols/SecretSharing/Defs.lean
 create mode 100644 Cslib/Crypto/Protocols/SecretSharing/Scheme.lean
 create mode 100644 Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
 create mode 100644 Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean
 rename Cslib/{Crypto/Protocols/PerfectSecrecy/PMFUtilities.lean => Probability/PMF.lean} (56%)

diff --git a/Cslib.lean b/Cslib.lean
index 8bb4d86a50..1b7b4c4b13 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -42,7 +42,10 @@ public import Cslib.Crypto.Protocols.PerfectSecrecy.Encryption
 public import Cslib.Crypto.Protocols.PerfectSecrecy.Internal.OneTimePad
 public import Cslib.Crypto.Protocols.PerfectSecrecy.Internal.PerfectSecrecy
 public import Cslib.Crypto.Protocols.PerfectSecrecy.OneTimePad
-public import Cslib.Crypto.Protocols.PerfectSecrecy.PMFUtilities
+public import Cslib.Crypto.Protocols.SecretSharing.Defs
+public import Cslib.Crypto.Protocols.SecretSharing.Scheme
+public import Cslib.Crypto.Protocols.SecretSharing.Shamir
+public import Cslib.Crypto.Protocols.SecretSharing.Shamir.Polynomial
 public import Cslib.Foundations.Combinatorics.InfiniteGraphRamsey
 public import Cslib.Foundations.Control.Monad.Free
 public import Cslib.Foundations.Control.Monad.Free.Effects
@@ -135,3 +138,4 @@ public import Cslib.Logics.Modal.Denotation
 public import Cslib.Logics.Propositional.Defs
 public import Cslib.Logics.Propositional.NaturalDeduction.Basic
 public import Cslib.MachineLearning.PACLearning.Defs
+public import Cslib.Probability.PMF
diff --git a/Cslib/Crypto/Protocols/PerfectSecrecy/Defs.lean b/Cslib/Crypto/Protocols/PerfectSecrecy/Defs.lean
index 03760e22dd..e7d824dd69 100644
--- a/Cslib/Crypto/Protocols/PerfectSecrecy/Defs.lean
+++ b/Cslib/Crypto/Protocols/PerfectSecrecy/Defs.lean
@@ -7,7 +7,7 @@ Authors: Samuel Schlesinger
 module
 
 public import Cslib.Crypto.Protocols.PerfectSecrecy.Encryption
-public import Cslib.Crypto.Protocols.PerfectSecrecy.PMFUtilities
+public import Cslib.Probability.PMF
 public import Mathlib.Probability.ProbabilityMassFunction.Constructions
 
 /-!
@@ -58,7 +58,7 @@ the marginal distribution. -/
 noncomputable def posteriorMsgDist (scheme : EncScheme M K C)
     (msgDist : PMF M) (c : C)
     (hc : c ∈ (scheme.marginalCiphertextDist msgDist).support) : PMF M :=
-  PMFUtilities.posteriorDist msgDist scheme.ciphertextDist c hc
+  Cslib.Probability.PMF.posteriorDist msgDist scheme.ciphertextDist c hc
 
 @[simp]
 theorem posteriorMsgDist_apply (scheme : EncScheme M K C)
diff --git a/Cslib/Crypto/Protocols/PerfectSecrecy/Internal/PerfectSecrecy.lean b/Cslib/Crypto/Protocols/PerfectSecrecy/Internal/PerfectSecrecy.lean
index 9f01fc4791..66656e8bad 100644
--- a/Cslib/Crypto/Protocols/PerfectSecrecy/Internal/PerfectSecrecy.lean
+++ b/Cslib/Crypto/Protocols/PerfectSecrecy/Internal/PerfectSecrecy.lean
@@ -32,12 +32,12 @@ variable {M K C : Type u}
 theorem jointDist_eq (scheme : EncScheme M K C) (msgDist : PMF M)
     (m : M) (c : C) :
     scheme.jointDist msgDist (m, c) = msgDist m * scheme.ciphertextDist m c :=
-  PMFUtilities.bind_pair_apply msgDist scheme.ciphertextDist m c
+  Cslib.Probability.PMF.bind_pair_apply msgDist scheme.ciphertextDist m c
 
 /-- Summing the joint distribution over messages gives the marginal ciphertext distribution. -/
 theorem jointDist_tsum_fst (scheme : EncScheme M K C) (msgDist : PMF M) (c : C) :
     ∑' m, scheme.jointDist msgDist (m, c) = scheme.marginalCiphertextDist msgDist c :=
-  PMFUtilities.bind_pair_tsum_fst msgDist scheme.ciphertextDist c
+  Cslib.Probability.PMF.bind_pair_tsum_fst msgDist scheme.ciphertextDist c
 
 /-- Perfect secrecy is equivalent to message-ciphertext independence.
 The two formulations are related by multiplying/dividing by `marginal(c)`. -/
diff --git a/Cslib/Crypto/Protocols/SecretSharing/Defs.lean b/Cslib/Crypto/Protocols/SecretSharing/Defs.lean
new file mode 100644
index 0000000000..e8788f08d0
--- /dev/null
+++ b/Cslib/Crypto/Protocols/SecretSharing/Defs.lean
@@ -0,0 +1,104 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.Probability.PMF
+public import Cslib.Crypto.Protocols.SecretSharing.Scheme
+
+/-!
+# Secret Sharing: Definitions
+
+Privacy for secret sharing is part of the `Scheme` interface. This file exposes
+the corresponding view and posterior distributions, plus theorem-friendly
+consequences of the built-in privacy field.
+
+## Main definitions
+
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.shareDist`:
+  the full share distribution for one secret
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.viewDist`:
+  the distribution of the restricted view for one coalition
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.posteriorSecretDist`:
+  the posterior distribution on secrets after observing one view
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.PerfectlyPrivate`:
+  posterior equals prior for unauthorized coalitions
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.perfectlyPrivate`:
+  every scheme has posterior privacy
+
+## References
+
+* [Adi Shamir, *How to Share a Secret*][Shamir1979]
+* [J. Katz, Y. Lindell, *Introduction to Modern Cryptography*][KatzLindell2020]
+-/
+
+@[expose] public section
+
+namespace Cslib.Crypto.Protocols.SecretSharing
+
+namespace Scheme
+
+variable {Secret Randomness Party Share : Type*}
+
+/-- The distribution of the full share assignment for one secret. -/
+noncomputable def shareDist (scheme : Scheme Secret Randomness Party Share)
+    (secret : Secret) : PMF (Party → Share) :=
+  scheme.gen.map (fun r => scheme.share r secret)
+
+/-- The view distribution induced on the coalition `s`. -/
+noncomputable def viewDist (scheme : Scheme Secret Randomness Party Share)
+    (s : Finset Party) (secret : Secret) : PMF (s → Share) :=
+  viewDistOf scheme.gen scheme.share s secret
+
+/-- Unauthorized coalitions receive secret-independent view distributions. -/
+theorem viewDist_eq_of_not_authorized
+    (scheme : Scheme Secret Randomness Party Share)
+    {s : Finset Party} (hs : ¬ scheme.authorized s)
+    (secret₀ secret₁ : Secret) :
+    scheme.viewDist s secret₀ = scheme.viewDist s secret₁ := by
+  unfold viewDist
+  exact scheme.view_indist s hs secret₀ secret₁
+
+/-- The posterior distribution on secrets after observing the coalition view
+`v`. -/
+noncomputable def posteriorSecretDist
+    (scheme : Scheme Secret Randomness Party Share)
+    (s : Finset Party) (secretDist : PMF Secret) (v : s → Share)
+    (hv : v ∈ (secretDist.bind (scheme.viewDist s)).support) : PMF Secret :=
+  Cslib.Probability.PMF.posteriorDist
+    (p := secretDist) (f := scheme.viewDist s) v hv
+
+@[simp]
+theorem posteriorSecretDist_apply
+    (scheme : Scheme Secret Randomness Party Share)
+    (s : Finset Party) (secretDist : PMF Secret) (v : s → Share)
+    (hv : v ∈ (secretDist.bind (scheme.viewDist s)).support) (secret : Secret) :
+    scheme.posteriorSecretDist s secretDist v hv secret =
+      (secretDist.bind fun secret' =>
+        (scheme.viewDist s secret').bind fun v' => PMF.pure (secret', v')) (secret, v) /
+        (secretDist.bind (scheme.viewDist s)) v :=
+  rfl
+
+/-- Perfect privacy for unauthorized coalitions: conditioning on a view does not
+change the prior on secrets. -/
+def PerfectlyPrivate (scheme : Scheme Secret Randomness Party Share) : Prop :=
+  ∀ (s : Finset Party) (_hs : ¬ scheme.authorized s)
+    (secretDist : PMF Secret) (v : s → Share)
+    (hv : v ∈ (secretDist.bind (scheme.viewDist s)).support),
+      scheme.posteriorSecretDist s secretDist v hv = secretDist
+
+/-- Every scheme has posterior privacy by definition of `Scheme`. -/
+theorem perfectlyPrivate
+    (scheme : Scheme Secret Randomness Party Share) :
+    scheme.PerfectlyPrivate := by
+  intro s hs secretDist v hv
+  exact Cslib.Probability.PMF.posteriorDist_eq_prior_of_outputIndist
+    (p := secretDist) (f := scheme.viewDist s)
+    (fun secret₀ secret₁ => scheme.viewDist_eq_of_not_authorized hs secret₀ secret₁) v hv
+
+end Scheme
+
+end Cslib.Crypto.Protocols.SecretSharing
diff --git a/Cslib/Crypto/Protocols/SecretSharing/Scheme.lean b/Cslib/Crypto/Protocols/SecretSharing/Scheme.lean
new file mode 100644
index 0000000000..09e07ae2a3
--- /dev/null
+++ b/Cslib/Crypto/Protocols/SecretSharing/Scheme.lean
@@ -0,0 +1,107 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.Data.Finset.Basic
+public import Mathlib.Probability.ProbabilityMassFunction.Constructions
+
+/-!
+# Secret Sharing Schemes
+
+A secret-sharing scheme bundles the deterministic sharing/reconstruction
+interface, the distribution on randomness, and privacy for unauthorized
+coalitions.
+
+## Main definitions
+
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme`:
+  a secret-sharing scheme with correctness and privacy
+- `Cslib.Crypto.Protocols.SecretSharing.Scheme.view`:
+  the restricted shares seen by one coalition
+
+## References
+
+* [Adi Shamir, *How to Share a Secret*][Shamir1979]
+* [J. Katz, Y. Lindell, *Introduction to Modern Cryptography*][KatzLindell2020]
+-/
+
+@[expose] public section
+
+namespace Cslib.Crypto.Protocols.SecretSharing
+
+/-- The view distribution induced by raw sharing data. -/
+noncomputable def viewDistOf {Secret Randomness Party Share : Type*}
+    (gen : PMF Randomness) (share : Randomness → Secret → Party → Share)
+    (s : Finset Party) (secret : Secret) : PMF (s → Share) :=
+  PMF.map (fun r : Randomness => (fun i : s => share r secret i : s → Share)) gen
+
+/--
+A secret-sharing scheme over secret space `Secret`, randomness space
+`Randomness`, party set `Party`, and share space `Share`.
+
+Correctness is deterministic: every authorized coalition reconstructs the
+secret from the shares generated using any randomness seed. Privacy is
+distributional: unauthorized coalitions have the same view distribution for all
+secrets.
+-/
+structure Scheme (Secret Randomness Party Share : Type*) where
+  /-- The distribution used to sample the protocol's randomness. -/
+  gen : PMF Randomness
+  /-- Sharing algorithm: one randomness seed determines one share per party. -/
+  share : Randomness → Secret → Party → Share
+  /-- Reconstruction from a coalition's observed shares. -/
+  reconstruct (s : Finset Party) : (s → Share) → Secret
+  /-- Authorized coalitions. -/
+  authorized : Finset Party → Prop
+  /-- Authorization is monotone in the coalition. -/
+  authorized_mono :
+    ∀ {s t : Finset Party}, s ⊆ t → authorized s → authorized t
+  /-- Authorized coalitions reconstruct the secret from the restricted view. -/
+  correct :
+    ∀ (r : Randomness) (secret : Secret) (s : Finset Party),
+      authorized s → reconstruct s (fun i => share r secret i) = secret
+  /-- Unauthorized coalitions receive secret-independent view distributions. -/
+  view_indist :
+    ∀ (s : Finset Party), ¬ authorized s → ∀ secret₀ secret₁ : Secret,
+      viewDistOf gen share s secret₀ = viewDistOf gen share s secret₁
+
+namespace Scheme
+
+variable {Secret Randomness Party Share : Type*}
+
+/-- The restricted shares observed by the coalition `s`. -/
+def view (scheme : Scheme Secret Randomness Party Share) (s : Finset Party)
+    (r : Randomness) (secret : Secret) : s → Share :=
+  fun i => scheme.share r secret i
+
+@[simp]
+theorem view_apply (scheme : Scheme Secret Randomness Party Share) (s : Finset Party)
+    (r : Randomness) (secret : Secret) (i : s) :
+    scheme.view s r secret i = scheme.share r secret i :=
+  rfl
+
+/-- Authorized coalitions reconstruct the secret from the restricted view. -/
+theorem reconstruct_view_eq_secret
+    (scheme : Scheme Secret Randomness Party Share)
+    (r : Randomness) (secret : Secret) {s : Finset Party}
+    (hs : scheme.authorized s) :
+    scheme.reconstruct s (scheme.view s r secret) = secret :=
+  scheme.correct r secret s hs
+
+/-- Any sub-coalition of an unauthorized coalition is unauthorized as well. -/
+theorem not_authorized_of_subset
+    (scheme : Scheme Secret Randomness Party Share)
+    {s t : Finset Party} (hst : s ⊆ t)
+    (ht : ¬ scheme.authorized t) :
+    ¬ scheme.authorized s := by
+  intro hs
+  exact ht (scheme.authorized_mono hst hs)
+
+end Scheme
+
+end Cslib.Crypto.Protocols.SecretSharing
diff --git a/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
new file mode 100644
index 0000000000..5e5d7f2930
--- /dev/null
+++ b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
@@ -0,0 +1,327 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.Crypto.Protocols.SecretSharing.Scheme
+public import Mathlib.Probability.Distributions.Uniform
+public import Cslib.Crypto.Protocols.SecretSharing.Shamir.Polynomial
+import Cslib.Probability.PMF
+
+/-!
+# Shamir Secret Sharing
+
+This module presents a secure-by-construction API for finite-party Shamir secret
+sharing through the abstract `SecretSharing.Scheme` interface.
+
+The public constructors require two pieces of data:
+
+- public parameters consisting of a threshold together with distinct, nonzero
+  evaluation points for a finite party set
+- a translation-invariant sampler on the tail coefficients
+
+Translation invariance is exactly the symmetry used in the privacy proof. The
+canonical finite-field instance is obtained by taking the sampler to be uniform.
+
+## Main definitions
+
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.Params`:
+  the threshold and public evaluation points
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.Randomness`:
+  the vector of tail coefficients
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.TailSampler`:
+  a translation-invariant distribution on tail coefficients
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.schemeWith`:
+  Shamir's scheme with a privacy-preserving tail sampler
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.scheme`:
+  the corresponding finite-field scheme with uniform randomness
+
+## Main results
+
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.reconstruct_view_eq_secret`:
+  any authorized coalition reconstructs the secret
+- `Cslib.Crypto.Protocols.SecretSharing.Shamir.authorized_univ`:
+  the full party set is always authorized
+
+## Notes
+
+The public share type is just the field `F`: the evaluation points are fixed in
+`Params`, so one share consists only of the corresponding field value.
+
+## References
+
+* [Adi Shamir, *How to Share a Secret*][Shamir1979]
+* [J. Katz, Y. Lindell, *Introduction to Modern Cryptography*][KatzLindell2020]
+-/
+
+@[expose] public section
+
+noncomputable section
+
+namespace Cslib.Crypto.Protocols.SecretSharing.Shamir
+
+variable {F Party : Type*} [Field F] [Fintype Party]
+
+/-- Public parameters for a finite Shamir secret-sharing instance. The threshold
+is bundled with the evaluation points so the API can enforce the standard
+non-vacuous `threshold < number of parties` side condition. -/
+structure Params (F : Type*) [Zero F] (Party : Type*) [Fintype Party] where
+  /-- A coalition of size `threshold + 1` is the first authorized size. -/
+  threshold : ℕ
+  /-- Standard Shamir sharing requires `threshold < number of parties`. -/
+  threshold_lt_card : threshold < Fintype.card Party
+  /-- The public evaluation point assigned to each party. -/
+  point : Party → F
+  /-- Distinct parties receive distinct evaluation points. -/
+  point_injective : Function.Injective point
+  /-- Standard Shamir sharing forbids the point `0`, which would reveal the
+  secret directly. -/
+  point_nonzero : ∀ i : Party, point i ≠ 0
+
+/-- The random coefficients of the degree-`threshold - 1` tail polynomial. -/
+abbrev Randomness (params : Params F Party) := Fin params.threshold → F
+
+/-- A coalition is authorized exactly when it contains at least
+`params.threshold + 1` parties. -/
+def authorized (params : Params F Party) (s : Finset Party) : Prop :=
+  params.threshold + 1 ≤ s.card
+
+/-- Because `params.threshold < |Party|`, the full party set can always
+reconstruct the secret. -/
+theorem authorized_univ {F Party : Type*} [Field F] [Fintype Party]
+    (params : Params F Party) :
+    authorized params (Finset.univ : Finset Party) := by
+  simpa [authorized] using Nat.succ_le_of_lt params.threshold_lt_card
+
+/-- The Shamir share value sent to one party. -/
+noncomputable def share (params : Params F Party)
+    (coeffs : Randomness params) (secretValue : F) (i : Party) : F :=
+  (Polynomial.sharingPolynomial secretValue
+    (Polynomial.tailPolynomial params.threshold coeffs)).eval (params.point i)
+
+/-- Reconstruct the secret from one coalition's Shamir shares. -/
+noncomputable def reconstruct (params : Params F Party)
+    (s : Finset Party) (σ : s → F) : F :=
+  Polynomial.reconstruct (fun i : s => params.point i) σ
+
+/-- A sampler on Shamir tail coefficients is privacy-compatible when its
+distribution is invariant under translation by any coefficient vector. This is
+the exact symmetry needed in the privacy proof. -/
+structure TailSampler (params : Params F Party) where
+  /-- The underlying coefficient distribution. -/
+  gen : PMF (Randomness params)
+  /-- Translating the coefficients does not change the distribution. -/
+  map_add_eq_self : ∀ δ : Randomness params, gen.map (fun coeffs => coeffs + δ) = gen
+
+private def coeffTranslate {params : Params F Party} (δ : Randomness params) :
+    Randomness params ≃ Randomness params where
+  toFun coeffs := coeffs + δ
+  invFun coeffs := coeffs - δ
+  left_inv coeffs := by simp
+  right_inv coeffs := by simp
+
+/-- Uniform tail coefficients form the canonical privacy-compatible sampler. -/
+noncomputable def uniformTailSampler (params : Params F Party)
+    [Fintype F] [Nonempty F] : TailSampler params where
+  gen := PMF.uniformOfFintype (Randomness params)
+  map_add_eq_self δ := by
+    simpa [coeffTranslate] using
+      (Cslib.Probability.PMF.uniformOfFintype_map_equiv
+        (coeffTranslate (params := params) δ))
+
+private noncomputable def privacyCorrectionPolynomial
+    (params : Params F Party) (s : Finset Party)
+    (secret₀ secret₁ : F) : _root_.Polynomial F :=
+  by
+    classical
+    exact _root_.Lagrange.interpolate s.attach (fun i : s => params.point i)
+      (fun i : s => (secret₀ - secret₁) / params.point i)
+
+private theorem points_injOn_subtype {F Party : Type*} [Field F] [Fintype Party]
+    (params : Params F Party) (s : Finset Party) :
+    Set.InjOn (fun i : s => params.point i) (s.attach : Finset s) := by
+  intro i _ j _ hij
+  apply Subtype.ext
+  exact params.point_injective hij
+
+private theorem privacyCorrectionPolynomial_eval
+    (params : Params F Party) (s : Finset Party)
+    (secret₀ secret₁ : F) (i : s) :
+    (privacyCorrectionPolynomial (F := F) params s secret₀ secret₁).eval (params.point i) =
+      (secret₀ - secret₁) / params.point i := by
+  classical
+  simpa using
+    (_root_.Lagrange.eval_interpolate_at_node
+      (s := s.attach)
+      (v := fun j : s => params.point j)
+      (r := fun j : s => (secret₀ - secret₁) / params.point j)
+      (points_injOn_subtype (F := F) params s)
+      (by simp))
+
+private theorem privacyCorrectionPolynomial_degree_lt
+    (params : Params F Party) (s : Finset Party)
+    (secret₀ secret₁ : F) (hcard : s.card ≤ params.threshold) :
+    (privacyCorrectionPolynomial (F := F) params s secret₀ secret₁).degree <
+      params.threshold := by
+  classical
+  refine lt_of_lt_of_le
+    (_root_.Lagrange.degree_interpolate_lt
+      (s := s.attach)
+      (v := fun i : s => params.point i)
+      (r := fun i : s => (secret₀ - secret₁) / params.point i)
+      (points_injOn_subtype (F := F) params s))
+    ?_
+  simpa using hcard
+
+private noncomputable def privacyCorrection
+    (params : Params F Party) (s : Finset Party)
+    (hcard : s.card ≤ params.threshold)
+    (secret₀ secret₁ : F) : Randomness params :=
+  _root_.Polynomial.degreeLTEquiv F params.threshold
+    ⟨privacyCorrectionPolynomial (F := F) params s secret₀ secret₁,
+      _root_.Polynomial.mem_degreeLT.2
+        (privacyCorrectionPolynomial_degree_lt (F := F) params s secret₀ secret₁ hcard)⟩
+
+private theorem tailPolynomial_privacyCorrection
+    (params : Params F Party) (s : Finset Party)
+    (hcard : s.card ≤ params.threshold)
+    (secret₀ secret₁ : F) :
+    Polynomial.tailPolynomial (F := F) params.threshold
+        (privacyCorrection (F := F) params s hcard secret₀ secret₁) =
+      privacyCorrectionPolynomial (F := F) params s secret₀ secret₁ := by
+  simp [privacyCorrection, Polynomial.tailPolynomial]
+
+private theorem view_eq_view_add_privacyCorrection
+    (params : Params F Party) (s : Finset Party)
+    (hcard : s.card ≤ params.threshold)
+    (secret₀ secret₁ : F) (coeffs : Randomness params) :
+    (fun i : s => share params coeffs secret₀ i) =
+      (fun i : s =>
+        share params
+          (coeffs + privacyCorrection (F := F) params s hcard secret₀ secret₁)
+          secret₁ i) := by
+  ext i
+  unfold share
+  rw [Polynomial.sharingPolynomial_eval, Polynomial.sharingPolynomial_eval]
+  rw [Polynomial.tailPolynomial_add, _root_.Polynomial.eval_add, tailPolynomial_privacyCorrection]
+  rw [privacyCorrectionPolynomial_eval (F := F) params s secret₀ secret₁ i]
+  field_simp [params.point_nonzero i]
+  ring
+
+/-- Translation-invariant Shamir tail samplers induce secret-independent views
+for unauthorized coalitions. -/
+theorem view_indist_of_tailSampler (params : Params F Party)
+    (sampler : TailSampler params) :
+    ∀ (s : Finset Party), ¬ authorized params s → ∀ secret₀ secret₁ : F,
+      viewDistOf sampler.gen (share params) s secret₀ =
+        viewDistOf sampler.gen (share params) s secret₁ := by
+  intro s hs secret₀ secret₁
+  have hcard : s.card ≤ params.threshold := by
+    have hs' : ¬ params.threshold + 1 ≤ s.card := by
+      simpa [authorized] using hs
+    exact Nat.lt_succ_iff.mp (Nat.not_le.mp hs')
+  unfold viewDistOf
+  calc
+    PMF.map (fun coeffs : Randomness params =>
+        (fun i : s => share params coeffs secret₀ i : s → F)) sampler.gen =
+      PMF.map
+        (fun coeffs : Randomness params => (fun i : s =>
+          share params
+            (coeffs + privacyCorrection (F := F) params s hcard secret₀ secret₁)
+            secret₁ i : s → F)) sampler.gen := by
+        congr 1
+        funext coeffs
+        exact view_eq_view_add_privacyCorrection
+          (F := F) params s hcard secret₀ secret₁ coeffs
+    _ = PMF.map (fun coeffs : Randomness params =>
+          (fun i : s => share params coeffs secret₁ i : s → F))
+        (PMF.map
+          (fun coeffs => coeffs + privacyCorrection (F := F) params s hcard secret₀ secret₁)
+          sampler.gen) := by
+          rw [PMF.map_comp]
+          rfl
+    _ = PMF.map (fun coeffs : Randomness params =>
+          (fun i : s => share params coeffs secret₁ i : s → F)) sampler.gen := by
+          rw [sampler.map_add_eq_self]
+
+/-- Shamir's scheme built from a privacy-compatible tail sampler. -/
+noncomputable def schemeWith (params : Params F Party) (sampler : TailSampler params)
+    :
+    SecretSharing.Scheme F (Randomness params) Party F :=
+  { gen := sampler.gen
+    share := share params
+    reconstruct := reconstruct params
+    authorized := authorized params
+    authorized_mono := by
+      intro s u hsu hs
+      exact le_trans hs (Finset.card_le_card hsu)
+    correct := by
+      intro coeffs secretValue s hs
+      have hdeg₀ :
+          (Polynomial.sharingPolynomial secretValue
+              (Polynomial.tailPolynomial params.threshold coeffs)).degree <
+            (params.threshold + 1 : WithBot ℕ) :=
+        Polynomial.degree_sharingPolynomial_tailPolynomial_lt_succ
+          secretValue params.threshold coeffs
+      have hdeg :
+          (Polynomial.sharingPolynomial secretValue
+              (Polynomial.tailPolynomial params.threshold coeffs)).degree <
+            Fintype.card s := by
+        simpa using
+          (lt_of_lt_of_le hdeg₀ (by exact_mod_cast hs) :
+            (Polynomial.sharingPolynomial secretValue
+                (Polynomial.tailPolynomial params.threshold coeffs)).degree <
+              s.card)
+      have hx : Function.Injective (fun i : s => params.point i) := by
+        intro i j hij
+        exact Subtype.ext (params.point_injective hij)
+      simpa [share, reconstruct] using
+        Polynomial.reconstruct_sharingPolynomial_eq_secret
+          (x := fun i : s => params.point i)
+          (secretValue := secretValue)
+          (tail := Polynomial.tailPolynomial params.threshold coeffs)
+          hx
+          hdeg
+    view_indist := view_indist_of_tailSampler params sampler }
+
+/-- The canonical finite-field Shamir scheme with uniformly sampled tail
+coefficients. -/
+noncomputable def scheme (params : Params F Party)
+    [Fintype F] [Nonempty F] :
+    SecretSharing.Scheme F (Randomness params) Party F :=
+  schemeWith params (uniformTailSampler params)
+
+@[simp]
+theorem schemeWith_authorized_iff (params : Params F Party)
+    (sampler : TailSampler params) (s : Finset Party) :
+    (schemeWith params sampler).authorized s ↔ params.threshold + 1 ≤ s.card :=
+  Iff.rfl
+
+@[simp]
+theorem scheme_authorized_iff (params : Params F Party)
+    [Fintype F] [Nonempty F] (s : Finset Party) :
+    (scheme params).authorized s ↔ params.threshold + 1 ≤ s.card :=
+  Iff.rfl
+
+@[simp]
+theorem schemeWith_share_eq (params : Params F Party)
+    (sampler : TailSampler params) (coeffs : Randomness params)
+    (secretValue : F) (i : Party) :
+    (schemeWith params sampler).share coeffs secretValue i =
+      share params coeffs secretValue i :=
+  rfl
+
+/-- Any authorized coalition reconstructs the secret from the shares it sees. -/
+theorem reconstruct_view_eq_secret
+    (params : Params F Party) (sampler : TailSampler params)
+    (coeffs : Randomness params) (secretValue : F) {s : Finset Party}
+    (hs : (schemeWith params sampler).authorized s) :
+    (schemeWith params sampler).reconstruct s
+      ((schemeWith params sampler).view s coeffs secretValue) = secretValue :=
+  SecretSharing.Scheme.reconstruct_view_eq_secret
+    (schemeWith params sampler) coeffs secretValue hs
+
+end Cslib.Crypto.Protocols.SecretSharing.Shamir
diff --git a/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean b/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean
new file mode 100644
index 0000000000..4cb4ced4f8
--- /dev/null
+++ b/Cslib/Crypto/Protocols/SecretSharing/Shamir/Polynomial.lean
@@ -0,0 +1,144 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.LinearAlgebra.Lagrange
+
+/-!
+# Shamir Secret Sharing: Polynomial Utilities
+
+This file contains the Shamir-specific polynomial and interpolation utilities
+used to prove correctness and privacy of the public scheme construction.
+-/
+
+@[expose] public section
+
+noncomputable section
+
+namespace Cslib.Crypto.Protocols.SecretSharing.Shamir.Polynomial
+
+variable {F : Type*} [Field F]
+
+/-- The tail polynomial determined by the first `n` coefficients. -/
+def tailPolynomial (n : ℕ) (coeffs : Fin n → F) : _root_.Polynomial F :=
+  ↑((_root_.Polynomial.degreeLTEquiv F n).symm coeffs)
+
+@[simp]
+theorem tailPolynomial_coeff (n : ℕ) (coeffs : Fin n → F) (i : Fin n) :
+    (tailPolynomial (F := F) n coeffs).coeff i = coeffs i := by
+  have h := congrFun
+    (LinearEquiv.apply_symm_apply (_root_.Polynomial.degreeLTEquiv F n) coeffs) i
+  simpa [tailPolynomial, _root_.Polynomial.degreeLTEquiv] using h
+
+/-- `tailPolynomial n coeffs` has degree `< n` by construction. -/
+theorem tailPolynomial_degree_lt (n : ℕ) (coeffs : Fin n → F) :
+    (tailPolynomial (F := F) n coeffs).degree < n :=
+  _root_.Polynomial.mem_degreeLT.1
+    (((_root_.Polynomial.degreeLTEquiv F n).symm coeffs :
+      _root_.Polynomial.degreeLT F n)).2
+
+/-- `tailPolynomial` is additive in its coefficient vector. -/
+theorem tailPolynomial_add (n : ℕ) (a b : Fin n → F) :
+    tailPolynomial (F := F) n (a + b) = tailPolynomial n a + tailPolynomial n b := by
+  simp [tailPolynomial]
+
+/-- The standard Shamir sharing polynomial `s + X * q(X)`. -/
+def sharingPolynomial (secretValue : F) (tail : _root_.Polynomial F) : _root_.Polynomial F :=
+  _root_.Polynomial.C secretValue + _root_.Polynomial.X * tail
+
+@[simp]
+theorem sharingPolynomial_eval (secretValue x : F) (tail : _root_.Polynomial F) :
+    (sharingPolynomial secretValue tail).eval x = secretValue + x * tail.eval x := by
+  simp [sharingPolynomial, mul_comm]
+
+theorem coeff_zero_sharingPolynomial (secretValue : F) (tail : _root_.Polynomial F) :
+    (sharingPolynomial secretValue tail).coeff 0 = secretValue := by
+  simp [sharingPolynomial]
+
+theorem constantCoeff_sharingPolynomial (secretValue : F) (tail : _root_.Polynomial F) :
+    (sharingPolynomial secretValue tail).constantCoeff = secretValue := by
+  simpa [_root_.Polynomial.constantCoeff_apply] using
+    coeff_zero_sharingPolynomial secretValue tail
+
+/-- If the tail polynomial has degree `< n`, then the sharing polynomial has
+natural degree at most `n`. -/
+theorem natDegree_sharingPolynomial_le (secretValue : F) (tail : _root_.Polynomial F) {n : ℕ}
+    (hdeg : tail.degree < n) :
+    (sharingPolynomial secretValue tail).natDegree ≤ n := by
+  rw [sharingPolynomial]
+  refine (_root_.Polynomial.natDegree_add_le _ _).trans ?_
+  rw [max_le_iff]
+  constructor
+  · rw [_root_.Polynomial.natDegree_C]
+    exact Nat.zero_le n
+  · by_cases htail : tail = 0
+    · simp [htail]
+    · rw [_root_.Polynomial.natDegree_X_mul htail]
+      have htailDegree : tail.natDegree < n := by
+        have := hdeg
+        rw [_root_.Polynomial.degree_eq_natDegree htail] at this
+        exact_mod_cast this
+      exact Nat.succ_le_of_lt htailDegree
+
+/-- If the tail polynomial has degree `< n`, then the sharing polynomial has
+degree `< n + 1`. -/
+theorem degree_sharingPolynomial_lt_succ (secretValue : F) (tail : _root_.Polynomial F) {n : ℕ}
+    (hdeg : tail.degree < n) :
+    (sharingPolynomial secretValue tail).degree < (n + 1 : WithBot ℕ) := by
+  by_cases hsharing : sharingPolynomial secretValue tail = 0
+  · simp [hsharing]
+  · rw [_root_.Polynomial.degree_eq_natDegree hsharing]
+    exact_mod_cast Nat.lt_succ_of_le (natDegree_sharingPolynomial_le secretValue tail hdeg)
+
+/-- The coefficient-vector version of `degree_sharingPolynomial_lt_succ`. -/
+theorem degree_sharingPolynomial_tailPolynomial_lt_succ
+    (secretValue : F) (n : ℕ) (coeffs : Fin n → F) :
+    (sharingPolynomial secretValue (tailPolynomial n coeffs)).degree <
+      (n + 1 : WithBot ℕ) :=
+  degree_sharingPolynomial_lt_succ secretValue (tailPolynomial n coeffs)
+    (tailPolynomial_degree_lt n coeffs)
+
+variable {ι : Type*} [Fintype ι]
+
+/-- Reconstruct the secret from finitely indexed share values by interpolating
+the unique low-degree polynomial that matches them. -/
+def reconstruct (x σ : ι → F) : F :=
+  by
+    classical
+    exact (_root_.Lagrange.interpolate Finset.univ x σ).constantCoeff
+
+/-- Reconstruction recovers the constant coefficient of any low-degree
+polynomial from its values at distinct points. -/
+theorem reconstruct_eq_constantCoeff_of_eval_eq
+    {x : ι → F} {p : _root_.Polynomial F}
+    (hx : Function.Injective x)
+    (hdeg : p.degree < Fintype.card ι) :
+    reconstruct x (fun i => p.eval (x i)) = p.constantCoeff := by
+  classical
+  have hp :
+      p = _root_.Lagrange.interpolate Finset.univ x (fun i => p.eval (x i)) :=
+    _root_.Lagrange.eq_interpolate
+      (s := Finset.univ)
+      (v := x)
+      hx.injOn
+      (by simpa using hdeg)
+  simpa [reconstruct] using congrArg _root_.Polynomial.constantCoeff hp.symm
+
+/-- Reconstruction succeeds on the values of a Shamir sharing polynomial once
+the finite index type is large enough. -/
+theorem reconstruct_sharingPolynomial_eq_secret
+    {x : ι → F} {secretValue : F} {tail : _root_.Polynomial F}
+    (hx : Function.Injective x)
+    (hdeg : (sharingPolynomial secretValue tail).degree < Fintype.card ι) :
+    reconstruct x
+      (fun i => (sharingPolynomial secretValue tail).eval (x i)) = secretValue := by
+  rw [reconstruct_eq_constantCoeff_of_eval_eq
+    (p := sharingPolynomial secretValue tail) hx hdeg]
+  exact constantCoeff_sharingPolynomial secretValue tail
+
+end Cslib.Crypto.Protocols.SecretSharing.Shamir.Polynomial
diff --git a/Cslib/Crypto/Protocols/PerfectSecrecy/PMFUtilities.lean b/Cslib/Probability/PMF.lean
similarity index 56%
rename from Cslib/Crypto/Protocols/PerfectSecrecy/PMFUtilities.lean
rename to Cslib/Probability/PMF.lean
index b1ab748de0..d20be22be2 100644
--- a/Cslib/Crypto/Protocols/PerfectSecrecy/PMFUtilities.lean
+++ b/Cslib/Probability/PMF.lean
@@ -8,6 +8,7 @@ module
 
 public import Cslib.Init
 public import Mathlib.Probability.ProbabilityMassFunction.Monad
+public import Mathlib.Probability.Distributions.Uniform
 
 /-!
 # PMF Utilities
@@ -23,20 +24,25 @@ the Mathlib module instead.
 
 ## Main results
 
-- `PMFUtilities.bind_pair_apply`: the "pairing" bind at `(a, b)` equals `p a * f a b`
-- `PMFUtilities.bind_pair_tsum_fst`: marginalizing over the first component
-- `PMFUtilities.posterior_hasSum`: posterior probabilities sum to 1
-- `PMFUtilities.posteriorDist`: the posterior as a `PMF`
+- `Cslib.Probability.PMF.bind_pair_apply`: the "pairing" bind at `(a, b)` equals `p a * f a b`
+- `Cslib.Probability.PMF.bind_pair_tsum_fst`: marginalizing over the first component
+- `Cslib.Probability.PMF.uniformOfFintype_map_equiv`:
+  a uniform distribution is invariant under equivalence
+- `Cslib.Probability.PMF.posterior_hasSum`: posterior probabilities sum to 1
+- `Cslib.Probability.PMF.posteriorDist`: the posterior as a `PMF`
+- `Cslib.Probability.PMF.posteriorDist_eq_prior_of_outputIndist`:
+  if the output distribution does not depend on the input, conditioning does
+  not change the prior
 -/
 
 @[expose] public section
 
-namespace Cslib.Crypto.Protocols.PerfectSecrecy.PMFUtilities
+namespace Cslib.Probability.PMF
 
 open PMF ENNReal
 
-universe u
-variable {α β : Type u}
+universe u v
+variable {α : Type u} {β : Type v}
 
 /-- Evaluating the "pairing" bind `(do let a ← p; return (a, ← f a))` at `(a, b)`
 gives the product `p a * f a b`. -/
@@ -54,6 +60,24 @@ theorem bind_pair_tsum_fst (p : PMF α) (f : α → PMF β) (b : β) :
       (p.bind f) b := by
   simp_rw [bind_pair_apply, PMF.bind_apply]
 
+/-- A uniform distribution on a finite type is invariant under any equivalence. -/
+theorem uniformOfFintype_map_equiv {γ : Type v} [Fintype α] [Fintype γ] [Nonempty α] [Nonempty γ]
+    (e : α ≃ γ) :
+    (PMF.uniformOfFintype α).map e = PMF.uniformOfFintype γ := by
+  classical
+  have hcard : Fintype.card α = Fintype.card γ := Fintype.card_congr e
+  ext c
+  rw [PMF.map_apply, PMF.uniformOfFintype_apply, tsum_eq_single (e.symm c)]
+  · simp_rw [PMF.uniformOfFintype_apply]
+    simp [hcard]
+  · intro a ha
+    simp_rw [PMF.uniformOfFintype_apply]
+    split_ifs with h
+    · exfalso
+      apply ha
+      simpa using congrArg e.symm h.symm
+    · simp
+
 /-- Posterior probabilities `joint(a, b) / marginal(b)` sum to 1
 when `b` is in the support of the marginal. -/
 theorem posterior_hasSum (p : PMF α) (f : α → PMF β) (b : β)
@@ -87,4 +111,23 @@ theorem posteriorDist_apply (p : PMF α) (f : α → PMF β) (b : β)
         (p.bind f) b :=
   rfl
 
-end Cslib.Crypto.Protocols.PerfectSecrecy.PMFUtilities
+/-- If the output distribution of a channel does not depend on the input, then
+conditioning on any output with positive probability leaves the prior unchanged. -/
+theorem posteriorDist_eq_prior_of_outputIndist (p : PMF α) (f : α → PMF β)
+    (h : ∀ a₀ a₁ : α, f a₀ = f a₁)
+    (b : β) (hb : b ∈ (p.bind f).support) :
+    posteriorDist p f b hb = p := by
+  ext a
+  rw [posteriorDist_apply, bind_pair_apply, PMF.bind_apply]
+  have hf : ∀ a', f a' b = f a b := fun a' => by rw [h a' a]
+  simp_rw [hf]
+  rw [ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul]
+  have hb' : (p.bind f) b ≠ 0 := (PMF.mem_support_iff _ _).mp hb
+  have hmarg : (p.bind f) b = f a b := by
+    rw [PMF.bind_apply]
+    simp_rw [hf]
+    rw [ENNReal.tsum_mul_right, PMF.tsum_coe, one_mul]
+  exact ENNReal.mul_div_cancel_right (hmarg ▸ hb')
+    (ne_top_of_le_ne_top ENNReal.one_ne_top (PMF.coe_le_one _ _))
+
+end Cslib.Probability.PMF
diff --git a/references.bib b/references.bib
index f0db1a781e..f0d122d179 100644
--- a/references.bib
+++ b/references.bib
@@ -166,6 +166,19 @@ @book{             KatzLindell2020
   isbn         = {9780815354369}
 }
 
+@article{         Shamir1979,
+  author       = {Adi Shamir},
+  title        = {How to Share a Secret},
+  journal      = {Communications of the ACM},
+  volume       = {22},
+  number       = {11},
+  pages        = {612--613},
+  year         = {1979},
+  month        = nov,
+  url          = {https://doi.org/10.1145/359168.359176},
+  doi          = {10.1145/359168.359176}
+}
+
 @inproceedings{   Kiselyov2015,
   author    = {Kiselyov, Oleg and Ishii, Hiromi},
   title     = {Freer Monads, More Extensible Effects},

From 2e5e64d28ae562ac3820750f0ad61e1430e55f89 Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Mon, 11 May 2026 08:08:51 -0400
Subject: [PATCH 019/106] ci: use `INFO=true` for weekly linting (#526)

This adds back `info` messages for the weekly linting report, see
https://github.com/leanprover-community/mathlib-ci/pull/23 for more
context.
---
 .github/workflows/weekly-lints.yml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.github/workflows/weekly-lints.yml b/.github/workflows/weekly-lints.yml
index 42462e34ef..949213f269 100644
--- a/.github/workflows/weekly-lints.yml
+++ b/.github/workflows/weekly-lints.yml
@@ -58,6 +58,7 @@ jobs:
         SHA=${{ github.sha }} \
         REPO=${{ github.repository }} \
         RUN_ID=${{ github.run_id }} \
+        INFO=true \
           "${CI_SCRIPTS_DIR}/reporting/zulip_build_report.sh" "${lean_outfile}" > "${GITHUB_OUTPUT}"
 
     - name: Post output to Zulip

From 75db8cbd9fea11b0717245416df1031bb2de153c Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 11 May 2026 21:30:01 +0200
Subject: [PATCH 020/106] Rose tree machine.

---
 .../Machines/RoseTreeMachine/Basic.lean       | 383 ++++++++++++++++++
 .../RoseTreeMachine/RoseTreeMachine.lean      | 211 ++++++++++
 2 files changed, 594 insertions(+)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/Basic.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean b/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean
new file mode 100644
index 0000000000..e53fee28a6
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean
@@ -0,0 +1,383 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+-- TODO create a "common file"?
+public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+
+public import Mathlib.Data.Part
+
+import Std
+import Mathlib.Algebra.Order.BigOperators.Group.Finset
+import Mathlib.Order.Interval.Finset.Defs
+
+
+
+inductive Data where
+  | l : List Data → Data
+deriving Repr, BEq
+
+abbrev Data.empty := Data.l []
+
+abbrev Data.asList
+  | Data.l items => items
+
+structure TapeIndex where
+  id : ℕ
+deriving Repr, BEq, Hashable
+
+-- Is a program a map from Nat to operations which reference smaller indices?
+
+inductive Operation
+  | empty
+  | copy (tape : TapeIndex)
+  | cons (head tail : TapeIndex)
+  -- | fold (list : TapeIndex) (step : List Operation)
+deriving Repr
+
+abbrev Program := List Operation
+
+def eval (p : Program) (stack : List Data) : Part (List Data) :=
+  match p with
+  | [] => .some stack
+  | .empty :: ops =>
+    eval ops (stack.concat Data.empty)
+  | .copy t :: ops =>
+    -- TODO can we enforce that inside the program?
+    if h : t.id < stack.length then
+      eval ops (stack.concat stack[t.id])
+    else
+      Part.none
+  | .cons head tail :: ops =>
+    if h : head.id < stack.length ∧ tail.id < stack.length then
+      eval ops (stack.concat (Data.l (stack[head.id] :: stack[tail.id].asList)))
+    else
+      Part.none
+  -- | .fold list init step :: ops =>
+  --   if h : list.id < initial.length then
+  --     let listData := initial[list.id]
+  --     match listData with
+  --     | Data.l items =>
+  --       let initData := initial.getLast'sorry
+  --       let stepOps := step.map (fun op => op.mapTapeIndex (fun t => initial[t.id]))
+  --   else
+  --     Part.none
+
+
+structure BuilderCtx where
+  nextTapeIndex : ℕ
+  program : Program
+deriving Repr
+
+abbrev Build (α : Type) := StateT BuilderCtx (Except String) α
+
+def newTape (p : Program) : Build TapeIdx := do
+  let env ← get
+  let sid := env.next
+  set { env with next := sid + 1, ops := env.ops ++ [op] }
+  return ⟨sid⟩
+
+-- ============================================================
+-- SLOT PRIMITIVES
+-- ============================================================
+
+-- Allocate a slot holding Data.l []
+def new : Build TapeIdx :=
+  newTape Program.new
+
+-- Prepend a as first child of b
+-- O(1) time, O(1) space — one new heap node with two pointers
+def cons (a b : Slot) : Build Slot :=
+  newTape s!"cons({a.id},{b.id})"
+
+-- Left fold over children of slot a
+-- O(n) time — space = max live accumulator = size of final result
+opaque fold
+    {α : Type}
+    (a    : Slot)
+    (init : α)
+    (step : Slot → α → Build α)
+    : Build α
+
+-- Right fold over children of slot a
+-- O(n) time — needed for single-pass append/snoc
+opaque foldr
+    {α : Type}
+    (a    : Slot)
+    (init : α)
+    (step : Slot → α → Build α)
+    : Build α
+
+-- Data.l [] if a = b, nonempty otherwise
+-- eq_ a a = Data.l [] is correct: slots are immutable so same slot = same value
+-- O(n) time structural equality, O(1) space
+opaque eq_ (a b : Slot) : Build Slot
+
+-- Branch on slot value: Data.l [] = false, anything else = true
+opaque if_
+    {α : Type}
+    (cond  : Slot)
+    (then_ : Build α)
+    (else_ : Build α)
+    : Build α
+
+-- Loop until condition slot returned by step is Data.l []
+-- Step: current state → (condition, next state)
+-- Only source of non-termination in the system
+opaque while_
+    {α : Type}
+    (step : α → Build (Slot × α))
+    (init : α)
+    : Build α
+
+-- ============================================================
+-- INPUT TAPE PRIMITIVES
+-- All navigation is O(1) space (just moves the read head)
+-- ============================================================
+
+-- Move into first child
+-- nonEmpty branch: cursor moves to first child's (
+-- empty branch:    current node is Data.l [], cursor stays
+-- O(1) time — peek right one cell
+opaque down
+    {α : Type}
+    (nonEmpty : Build α)
+    (empty    : Build α)
+    : Build α
+
+-- Move to parent
+-- hasParent branch: cursor moves to parent's (
+-- isRoot branch:    already at root, cursor stays
+-- O(n) time — scan left past siblings counting brackets
+opaque up
+    {α : Type}
+    (hasParent : Build α)
+    (isRoot    : Build α)
+    : Build α
+
+-- Move to next sibling
+-- hasNext branch: cursor moves to next sibling's (
+-- isLast branch:  no next sibling (cursor lands on parent's ))
+-- O(n) time — scan right past current subtree
+opaque next
+    {α : Type}
+    (hasNext : Build α)
+    (isLast  : Build α)
+    : Build α
+
+-- Move to previous sibling
+-- hasPrev branch: cursor moves to previous sibling's (
+-- isFirst branch: no previous sibling, cursor stays
+-- O(n) time — scan left past previous subtree
+opaque prev
+    {α : Type}
+    (hasPrev : Build α)
+    (isFirst : Build α)
+    : Build α
+
+-- Copy the subtree at the current cursor position into a new slot
+-- O(n) time, O(n) space
+opaque readCursor : Build Slot
+
+-- ============================================================
+-- DERIVED: BOOLEAN SLOTS
+-- ============================================================
+
+def false_ : Build Slot := new
+def true_  : Build Slot := do cons (← new) (← new)
+
+-- ============================================================
+-- DERIVED: BOUNDARY DETECTION
+-- (all derived from navigation combinators)
+-- ============================================================
+
+def cursorEmpty : Build Slot :=
+  down (do up (return ()) (return ()); false_) true_
+
+def isFirst_ : Build Slot :=
+  prev (do next (return ()) (return ()); false_) true_
+
+def isLast_ : Build Slot :=
+  next (do prev (return ()) (return ()); false_) true_
+
+def isRoot_ : Build Slot :=
+  up (do down (return ()) (return ()); false_) true_
+
+-- ============================================================
+-- DERIVED: SLOT CONSTRUCTORS
+-- ============================================================
+
+def wrap (a : Slot) : Build Slot :=
+  cons a (← new)
+
+def copy (a : Slot) : Build Slot :=
+  fold a (← new) (fun child acc => cons child acc)
+
+-- ============================================================
+-- DERIVED: BOOLEAN OPERATIONS ON SLOTS
+-- ============================================================
+
+def not_ (a : Slot) : Build Slot :=
+  if_ a false_ true_
+
+def and_ (a b : Slot) : Build Slot :=
+  if_ a (return b) false_
+
+def or_ (a b : Slot) : Build Slot :=
+  if_ a true_ (return b)
+
+def xor_ (a b : Slot) : Build Slot :=
+  not_ =<< eq_ a b
+
+-- ============================================================
+-- DERIVED: LIST OPERATIONS ON SLOTS
+-- ============================================================
+
+-- Append: children of a then children of b — O(|a|) time, O(|a|) space
+def append_ (a b : Slot) : Build Slot :=
+  foldr a b (fun child acc => cons child acc)
+
+-- Reverse — O(n) time, O(n) space
+def reverse_ (a : Slot) : Build Slot :=
+  fold a (← new) (fun child acc => cons child acc)
+
+-- Snoc: b as last child of a — O(n) time, O(n) space
+def snoc (a b : Slot) : Build Slot :=
+  foldr a (← wrap b) (fun child acc => cons child acc)
+
+-- Filter — O(n) time, O(m) space where m = kept elements
+def filter (a : Slot) (pred : Slot → Build Slot) : Build Slot :=
+  fold a (← new) (fun child acc => do
+    if_ (← pred child)
+      (cons child acc)
+      (return acc))
+
+-- ============================================================
+-- DERIVED: INPUT TAPE ITERATION
+-- ============================================================
+
+-- Fold over children of current cursor node
+-- O(n) time — visits each child once
+-- space = accumulator = O(output size)
+def foldCursor {α : Type} (init : α) (step : α → Build α) : Build α :=
+  down
+    (do
+      let result ← while_
+        (fun acc => do
+          let r    ← step acc
+          let cond ← next
+            (do false_)    -- has next sibling: condition = false = keep going
+            (do true_)     -- no next sibling: condition = true = stop
+          return (cond, r))
+        init
+      up (return ()) (return ())
+      return result)
+    (return init)          -- empty node: nothing to fold
+
+-- Read all children of current node into a slot
+-- O(n) time, O(n) space
+def readChildren : Build Slot := do
+  foldCursor (← new) (fun acc => do
+    let child ← readCursor
+    down (up (return ()) (return ())) (return ())  -- step into child and back
+    cons child acc)
+
+-- ============================================================
+-- DERIVED: BINARY NATURAL NUMBERS IN SLOTS
+--
+-- Encoding: Data.l [b0, b1, ..., bn] LSB first
+--   Data.l []  = bit 0
+--   nonempty   = bit 1
+-- ============================================================
+
+def bit0 : Build Slot := new
+def bit1 : Build Slot := true_
+
+def addBits (a b carry : Slot) : Build (Slot × Slot) := do
+  let sumBit   ← xor_ (← xor_ a b) carry
+  let carryOut ← if_ (← and_ a b)
+    true_
+    (and_ b carry)
+  return (sumBit, carryOut)
+
+-- Add two binary numbers — O(n²) time, O(n) space
+def add (a b : Slot) : Build Slot := do
+  let (acc, bRest, carry) ← fold a (← new, b, ← bit0)
+    (fun aBit (acc, bRest, carry) => do
+      let (bBit, bTail) ← if_ bRest
+        (fold bRest (← bit0, ← new)
+          (fun h _ => return (h, ← new)))  -- take head of bRest
+        (do return (← bit0, ← new))        -- b exhausted
+      let (s, c) ← addBits aBit bBit carry
+      return (← cons s acc, bTail, c))
+  let (acc2, carry2) ← fold bRest (acc, carry)
+    (fun bBit (acc, carry) => do
+      let (s, c) ← addBits (← bit0) bBit carry
+      return (← cons s acc, c))
+  if_ carry2
+    (cons (← bit1) acc2)
+    (return acc2)
+
+-- ============================================================
+-- SEAL
+-- ============================================================
+
+structure CompiledRoutine where
+  outputSlot : Nat
+  ops        : List String
+deriving Repr
+
+-- Seal a routine that reads the input tape and produces one output slot
+def seal (build : Build Slot) : Except String CompiledRoutine := do
+  let (out, env) ← build.run SlotEnv.initial
+  return ⟨out.id, env.ops⟩
+
+-- Seal a routine that also takes explicit slot arguments
+def seal1 (build : Slot → Build Slot) : Except String CompiledRoutine := do
+  let (out, env) ← (build ⟨0⟩).run { SlotEnv.initial with next := 1 }
+  return ⟨out.id, env.ops⟩
+
+def seal2 (build : Slot → Slot → Build Slot) : Except String CompiledRoutine := do
+  let (out, env) ← (build ⟨0⟩ ⟨1⟩).run { SlotEnv.initial with next := 2 }
+  return ⟨out.id, env.ops⟩
+
+-- ============================================================
+-- MAIN
+-- ============================================================
+
+def main : IO Unit := do
+  let run (name : String) (r : Except String CompiledRoutine) : IO Unit :=
+    IO.println s!"\n=== {name} ===" >>
+    match r with
+    | .error e => IO.println s!"Error: {e}"
+    | .ok r    => IO.println (repr r)
+
+  -- Slot operations
+  run "new"           (seal new)
+  run "true_"         (seal true_)
+  run "not(true)"     (seal do not_ (← true_))
+  run "not(false)"    (seal do not_ (← false_))
+  run "and(T,T)"      (seal do and_ (← true_) (← true_))
+  run "and(F,T)"      (seal do and_ (← false_) (← true_))
+  run "or(F,T)"       (seal do or_ (← false_) (← true_))
+  run "xor(T,T)"      (seal do xor_ (← true_) (← true_))
+  run "xor(F,T)"      (seal do xor_ (← false_) (← true_))
+  run "append"        (seal2 fun a b => append_ a b)
+  run "reverse"       (seal1 fun a => reverse_ a)
+  run "snoc"          (seal2 fun a b => snoc a b)
+  run "add"           (seal2 fun a b => add a b)
+
+  -- Input tape operations
+  run "readCursor"    (seal readCursor)
+  run "cursorEmpty"   (seal cursorEmpty)
+  run "isFirst"       (seal isFirst_)
+  run "isLast"        (seal isLast_)
+  run "isRoot"        (seal isRoot_)
+  run "foldCursor"    (seal do
+    foldCursor (← new) (fun acc => do
+      let child ← readCursor
+      cons child acc))
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
new file mode 100644
index 0000000000..f9253bd519
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -0,0 +1,211 @@
+import Mathlib.Data.Part
+import Mathlib.Control.Fix
+import Mathlib.Tactic
+import Std
+
+-- This is a proposal to define a machine model and related time and space measure
+-- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
+
+-- The goal would be that the machine model is flexible enough to implement algorithms easily,
+-- but still close enough to Turing machines to allow defining logspace and even loglogspace.
+
+-- The machine as defined below will allow stateless / pure functional programs.
+-- If we store the input tape position as a number, we should be able to define logspace.
+-- In order to go down to loglogspace, we need to use the input tape head as a "pointer"
+-- and cannot count its position. This could be doable as well, but requires a more stateful
+-- model at least for the input tape. The input tape is currently not modeled, but I have some
+-- plans to define actions on the input tape as further elementary operations.
+
+-- The main insight over my current work is that it does not hurt to
+-- (1) create a new tape for every elementary operation (the program size is constant, so the number
+--     of tapes is constant)
+-- (2) disallow modifications to existing tapes (work tape space has been spent, it is fine
+--     to copy it finitely often
+-- (3) if we have a built-in `fold` operation, we should be able to implement the required
+--     operations at linear space overhead, because the fold operation implicitly re-uses the
+--     space used by the accumulator.
+
+
+
+-- ================= Data structure
+
+
+
+-- Rose-tree data structure, it allows us to
+-- 1. map most of Lean's data structures in a "natural" manner
+-- 2. define a "fold" operation
+inductive Data where
+  | l : List Data → Data
+deriving Repr, BEq
+
+def Data.asList
+  | Data.l xs => xs
+
+abbrev TapeIndex := ℕ
+
+
+-- ================= Operations and programs
+
+-- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
+-- Each operation creates a new stack entry (a new tape) and can read from previous
+-- entries by index.
+
+-- TODO: For the combinators (ite, fold, while_) I am not yet sure if we can/should restrict the
+-- inner programs to return exactly one tape. Unrelated to that, the inner programs of `fold` and
+-- `while_` are able to create "temporary" slots.
+
+inductive Operation where
+  -- create a new tape initialized with `Data.l []`
+  | empty  : Operation
+  -- copy tape i to a new tape -- not sure if this is needed
+  | copy   : TapeIndex → Operation
+  -- cons tape h and tape t to a new tape (h :: t)
+  | cons   : TapeIndex → TapeIndex → Operation
+  -- compare two tapes, returning empty if equal, nonempty otherwise
+  | eq     : TapeIndex → TapeIndex → Operation
+  -- branch on tape i: if empty then then_ else else_
+  | ite    : TapeIndex → (List Operation) → (List Operation) → Operation
+  -- fold over the children of tape l with initial accumulator tape i and body program b
+  | fold   : TapeIndex → TapeIndex → (List Operation) → Operation
+  -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
+  | while_ : TapeIndex → (List Operation) → Operation
+
+abbrev Prog := List Operation
+
+
+-- TODO define a well-formedness Prop that ensures that tape indices are all in bounds.
+
+-- One could define a monadic builder-pattern that handles tape index allocation:
+-- def filter (a : TapeIndex) (predicate : TapeIndex → Build TapeIndex) : Build TapeIndex := do
+--   fold a (← empty) (fun child acc => do
+--     ite (← predicate child)
+--       (cons child acc)
+--       (return acc))
+
+
+-- TODO define space measure:
+-- elementary operations incur the size of their output as additional space
+-- fold incurs space of init plus the max of the space of the step function - this is the crucial point
+-- that allows us to build space-efficient algorithms: We implicitly overwrite the old
+-- accumulator value even though there is no explicit "overwrite" or "free" operation.
+
+-- Interpreter:
+-- It returns Part.none if the program does not terminate and Part.some Option.none if the
+-- program is not well-formed.
+mutual
+  def evalOp (stack : List Data) (op : Operation) : Part (Option (List Data)) := match op with
+    | .empty      => .some (some (stack ++ [Data.l []]))
+    | .copy  i    => .some (do stack ++ [← stack[i]?])
+    | .cons  h t  =>
+        .some (do
+          let hv ← stack[h]?
+          let tv ← stack[h]?
+          return stack ++ [Data.l (hv :: tv.asList)])
+    | .eq i j =>
+        .some (do
+          let a ← stack[i]?
+          let b ← stack[j]?
+          stack ++ [if a == b then Data.l [] else Data.l [Data.l []]])
+    | .ite i then_ else_ =>
+        match stack[i]? with
+        | none     => .some none
+        | some cond =>
+          if cond == Data.l [] then evalProg then_ stack else evalProg else_ stack
+    | .fold  l i body => match (stack[l]?, stack[i]?) with
+        | (some list, some initial) =>
+          (goFold list.asList initial stack body).map (fun result => result.map (stack ++ [·]))
+        | _ => .some none
+    | .while_ i body =>
+        match stack[i]? with
+        | none     => .some none
+        | some acc => sorry -- use Part.fix
+
+
+  def goFold (children : List Data) (acc : Data)
+      (stack : List Data) (body : Prog) : Part (Option Data) :=
+    match children with
+    | []      => .some (some acc)
+    | c :: cs =>
+      -- Put the item and the accumulator on two new tapes and run the program.
+      -- take the contents of the last tape as the result / new accumulator.
+      (evalProg body (stack ++ [c, acc])).bind fun result =>
+        match result >>= (·.getLast?) with
+        | none      => .some none
+        | some acc' => goFold cs acc' stack body
+
+  def evalProg (p : Prog) (stack : List Data) : Part (Option (List Data)) := match p with
+    | []           => .some (some stack)
+    | op :: rest   =>
+      (evalOp stack op).bind fun result =>
+        match result with
+        | none   => .some none
+        | some stack' => evalProg rest stack'
+end
+
+-- `Part` is annoying but unfortunately needed. Since we are dealing with complexity, all programs
+-- should compute total functions, so we define totality as a prop. Of course, any program that
+-- does not use while_ is total. This can be hopefully derived structurally using simp lemmas and thus
+-- should auto-solve in simp lemmas.
+
+mutual
+  def WhileFreeOp : Operation → Prop
+    | .while_ _ _ => False
+    | .fold _ _ b => WhileFreeProg b
+    | _           => True
+
+  def WhileFreeProg : Prog → Prop
+    | []         => True
+    | op :: rest => WhileFreeOp op ∧ WhileFreeProg rest
+end
+
+def ComputesTotalFunction (prog : Prog) : Prop :=
+  ∀ (stack : List Data), (evalProg prog stack).Dom
+
+theorem whileFree_total (prog : Prog) (hwf : WhileFreeProg prog) :
+    ComputesTotalFunction prog := by sorry
+
+def WellFormedTotal (prog : Prog) : Prop :=
+  ∃ (h_total : ComputesTotalFunction prog), ∀ stack : List Data,
+    ((evalProg prog stack).get (h_total stack)).isSome
+
+-- Now the most important part: If a program is total, and well-formed we can talk about the
+-- function computed by the program - this is something that was not really possible with my old
+-- design:
+
+def progFun (prog : Prog) (h_wft : WellFormedTotal prog) (stack : List Data) : Data :=
+    -- TODO prove that the stack size increases by at least 1 or similar
+  (((evalProg prog stack).get (h_wft.1 stack)).get (h_wft.2 stack)).getLast sorry
+
+-- With these at hand, we can define simp lemmas and thus auto-derive semantics
+-- and maybe even resource requirements of programs:
+
+@[simp]
+theorem evalFold_eq_foldl
+    (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
+    (body : Prog) (h : WellFormedTotal body)
+    (rest : Prog) :
+    evalProg ((.fold l i body) :: rest) stack =
+    .some (some (stack ++ [(stack[l].asList.foldl
+      (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
+      stack[i])])) := by
+  sorry
+
+
+abbrev Build (α : Type) := StateT Prog (Except String) α
+
+def appendOp (op : Operation) : Build TapeIndex := do
+  let prog ← get
+  let idx := prog.length
+  set (prog ++ [op])
+  return idx
+
+def empty : Build TapeIndex := appendOp .empty
+
+def copy (i : TapeIndex) : Build TapeIndex := appendOp (.copy i)
+
+def cons (h t : TapeIndex) : Build TapeIndex := appendOp (.cons h t)
+
+def eq (i j : TapeIndex) : Build TapeIndex := appendOp (.eq i j)
+
+def ite_ (cond : TapeIndex) (then_ else_ : Prog) : Build TapeIndex := do
+  appendOp (.ite cond (getThenProg) (getElseProg))

From 283bc0bb625030786f88f9005384cfd505d137c2 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 11 May 2026 21:31:59 +0200
Subject: [PATCH 021/106] Apply suggestions from code review

Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 Cslib/Foundations/Data/BiTape.lean | 25 ++++++++++---------------
 1 file changed, 10 insertions(+), 15 deletions(-)

diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index 74c6a8190b..dc760e2045 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -91,18 +91,15 @@ def get (t : BiTape Symbol) : ℤ → Option Symbol
 tapes as functions `ℤ → Option Symbol`. -/
 @[ext]
 lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) : t₁ = t₂ := by
-  obtain ⟨head₁, left₁, right₁⟩ := t₁
-  obtain ⟨head₂, left₂, right₂⟩ := t₂
-  have h_head : head₁ = head₂ := by simpa [get] using h_get_eq 0
-  have h_right : right₁ = right₂ := by
-    apply StackTape.ext_get
-    intro p
-    simpa [get] using h_get_eq (p + 1)
-  have h_left : left₁ = left₂ := by
-    apply StackTape.ext_get
+  cases t₁
+  congr
+  · simpa [get] using h_get_eq 0
+  · apply StackTape.ext_get
     intro p
     simpa [get] using h_get_eq (Int.negSucc p)
-  grind
+  · apply StackTape.ext_get
+    intro p
+    simpa [get] using h_get_eq (p + 1)
 
 
 section Move
@@ -151,13 +148,12 @@ def optionDirToInt (d : Option Dir) : ℤ :=
   | some .right => 1
 
 @[simp, scoped grind =]
-lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
-    (t.move_left).get p = t.get (p - 1) := by
+lemma get_move_left (t : BiTape Symbol) (p : ℤ) : t.move_left.get p = t.get (p - 1) := by
   unfold move_left get
   match p with
   | Int.ofNat 0 =>
-    rw [show Int.ofNat 0 - 1 = Int.negSucc 0 from rfl]
     simp [StackTape.head_eq_getD]
+    rfl
   | Int.ofNat 1 => simp
   | Int.ofNat (n + 2) =>
     rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) by lia]
@@ -165,8 +161,7 @@ lemma get_move_left (t : BiTape Symbol) (p : ℤ) :
   | Int.negSucc n => simp
 
 @[simp, scoped grind =]
-lemma get_move_right (t : BiTape Symbol) (p : ℤ) :
-    (t.move_right).get p = t.get (p + 1) := by
+lemma get_move_right (t : BiTape Symbol) (p : ℤ) : t.move_right.get p = t.get (p + 1) := by
   unfold move_right get
   match p with
   | Int.ofNat n =>

From 28a8f5e47008c4552b371ae027a804a060de7a6b Mon Sep 17 00:00:00 2001
From: Kim Morrison <477956+kim-em@users.noreply.github.com>
Date: Tue, 12 May 2026 11:46:17 +1000
Subject: [PATCH 022/106] chore(ci): pin lint-style-action to a SHA instead of
 @main (#561)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This PR pins `leanprover-community/lint-style-action` to commit
`91923b04` (2026-05-12) instead of tracking `@main`. SHA-pinning
third-party GitHub Actions is the standard hardening practice — it
prevents a compromised or accidentally-broken upstream commit from
silently affecting CI here, and makes the action version reproducible.

The chosen pin matches what mathlib4 uses (after the companion bump in
https://github.com/leanprover-community/mathlib4/pull/39228) and
includes
https://github.com/leanprover-community/lint-style-action/pull/5 -
feat(install-bibtool): use --no-install-recommends with apt-get, which
trims ~167 MB of unused texlive packages off every run of the Lint style
step.

Going forward, bumping the pin can be a periodic, reviewed step rather
than an implicit dependency on whatever HEAD happens to be.

🤖 Prepared with Claude Code

Co-authored-by: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
---
 .github/workflows/lean_action_ci.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml
index 1053d8a537..0554798c1b 100644
--- a/.github/workflows/lean_action_ci.yml
+++ b/.github/workflows/lean_action_ci.yml
@@ -34,6 +34,6 @@ jobs:
         run: |
           set -e
           lake exe checkInitImports
-      - uses: leanprover-community/lint-style-action@main
+      - uses: leanprover-community/lint-style-action@91923b046cc6a468e9ae340f32f8defe586bd08f # 2026-05-12
         with:
           mode: check

From b3c5575d118fdf36bd507fdce57c5267beee61a2 Mon Sep 17 00:00:00 2001
From: Kim Morrison <477956+kim-em@users.noreply.github.com>
Date: Tue, 12 May 2026 21:56:11 +1000
Subject: [PATCH 023/106] chore(ci): bump lint-style-action pin off reverted
 commit (#562)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Follow-up to https://github.com/leanprover/cslib/pull/561.

This PR moves `leanprover-community/lint-style-action` from `91923b04`
(the merge of the now-reverted
https://github.com/leanprover-community/lint-style-action/pull/5) to
`e6128ab2` (the merge of the revert PR
https://github.com/leanprover-community/lint-style-action/pull/6).

cslib does not set `lint-bib-file: true`, so the broken `Install
bibtool` step shipped in `91923b04` was gated off and never actually ran
here — the previous pin was functionally harmless. This is purely a
cosmetic move off a known-bad SHA onto the current clean tip, restoring
parity with mathlib4's pin (which is still `a7e7428`, functionally
identical to `e6128ab2` at the `action.yml` level after the revert).

🤖 Prepared with Claude Code

Co-authored-by: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
---
 .github/workflows/lean_action_ci.yml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml
index 0554798c1b..5b0ce8b541 100644
--- a/.github/workflows/lean_action_ci.yml
+++ b/.github/workflows/lean_action_ci.yml
@@ -34,6 +34,6 @@ jobs:
         run: |
           set -e
           lake exe checkInitImports
-      - uses: leanprover-community/lint-style-action@91923b046cc6a468e9ae340f32f8defe586bd08f # 2026-05-12
+      - uses: leanprover-community/lint-style-action@e6128ab22cb03b509075ae46c33727e3952ffab7 # 2026-05-12
         with:
           mode: check

From 608cbe1b629a276abd3f2081f9b42dc766d8fd78 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Wed, 13 May 2026 02:01:58 +0800
Subject: [PATCH 024/106] doc: fix missing '$' (#564)

doc: fix missing '$'
---
 Cslib/Languages/CombinatoryLogic/Defs.lean | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Cslib/Languages/CombinatoryLogic/Defs.lean b/Cslib/Languages/CombinatoryLogic/Defs.lean
index 9186ade5b7..a82459aadf 100644
--- a/Cslib/Languages/CombinatoryLogic/Defs.lean
+++ b/Cslib/Languages/CombinatoryLogic/Defs.lean
@@ -40,7 +40,7 @@ namespace Cslib
 
 /-- An SKI expression is built from the primitive combinators `S`, `K` and `I`, and application. -/
 inductive SKI where
-  /-- `S`-combinator, with semantics $λxyz.xz(yz) -/
+  /-- `S`-combinator, with semantics $λxyz.xz(yz)$ -/
   | S
   /-- `K`-combinator, with semantics $λxy.x$ -/
   | K

From 1cae37251db2a6b92f7c0aa31db9c290db172b44 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Wed, 13 May 2026 13:08:10 +0200
Subject: [PATCH 025/106] Update definitions.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 77 +++++++++++--------
 1 file changed, 43 insertions(+), 34 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index f9253bd519..549c3716b4 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -38,7 +38,9 @@ inductive Data where
   | l : List Data → Data
 deriving Repr, BEq
 
-def Data.asList
+abbrev Data.empty := Data.l []
+
+abbrev Data.asList
   | Data.l xs => xs
 
 abbrev TapeIndex := ℕ
@@ -61,6 +63,10 @@ inductive Operation where
   | copy   : TapeIndex → Operation
   -- cons tape h and tape t to a new tape (h :: t)
   | cons   : TapeIndex → TapeIndex → Operation
+  -- head of the data if it exists, or empty otherwise
+  | head   : TapeIndex → Operation
+  -- tail of the data
+  | tail   : TapeIndex → Operation
   -- compare two tapes, returning empty if equal, nonempty otherwise
   | eq     : TapeIndex → TapeIndex → Operation
   -- branch on tape i: if empty then then_ else else_
@@ -89,57 +95,60 @@ abbrev Prog := List Operation
 -- that allows us to build space-efficient algorithms: We implicitly overwrite the old
 -- accumulator value even though there is no explicit "overwrite" or "free" operation.
 
+abbrev dataTrue := Data.l [Data.l []]
+abbrev dataFalse := Data.l []
+
 -- Interpreter:
 -- It returns Part.none if the program does not terminate and Part.some Option.none if the
 -- program is not well-formed.
 mutual
-  def evalOp (stack : List Data) (op : Operation) : Part (Option (List Data)) := match op with
-    | .empty      => .some (some (stack ++ [Data.l []]))
-    | .copy  i    => .some (do stack ++ [← stack[i]?])
-    | .cons  h t  =>
-        .some (do
-          let hv ← stack[h]?
-          let tv ← stack[h]?
-          return stack ++ [Data.l (hv :: tv.asList)])
+  def evalOp (stack : List Data) (op : Operation) : Part (Option Data) := match op with
+    | .empty => .some (some Data.empty)
+    | .copy i => .some stack[i]?
+    | .cons h t =>
+        .some do Data.l ((← stack[h]?) :: (← stack[t]?).asList)
+    | .head i =>
+        .some (do (← stack[i]?).asList.headD Data.empty)
+    | .tail i =>
+        .some (do Data.l (← stack[i]?).asList.tail)
     | .eq i j =>
-        .some (do
-          let a ← stack[i]?
-          let b ← stack[j]?
-          stack ++ [if a == b then Data.l [] else Data.l [Data.l []]])
-    | .ite i then_ else_ =>
-        match stack[i]? with
-        | none     => .some none
-        | some cond =>
-          if cond == Data.l [] then evalProg then_ stack else evalProg else_ stack
-    | .fold  l i body => match (stack[l]?, stack[i]?) with
-        | (some list, some initial) =>
-          (goFold list.asList initial stack body).map (fun result => result.map (stack ++ [·]))
+        .some (do if (← stack[i]?) == (← stack[j]?) then dataTrue else dataFalse)
+    | .ite i then_ else_ => match stack[i]? with
+        | none => .some none
+        | some d => if d == dataTrue then evalProg then_ stack else evalProg else_ stack
+    | .fold l i body => match (stack[l]?, stack[i]?) with
+        | (some list, some initial) => goFold list.asList initial stack body
         | _ => .some none
     | .while_ i body =>
         match stack[i]? with
         | none     => .some none
-        | some acc => sorry -- use Part.fix
-
-
-  def goFold (children : List Data) (acc : Data)
-      (stack : List Data) (body : Prog) : Part (Option Data) :=
-    match children with
+        | some acc =>
+          -- recurse as long as the head of the returned value is true (the rest is used
+          -- to pass data across iterations).
+          let F := fun rec d => (evalProg body (d :: stack)).bind fun
+              | none => .some none
+              | some d => if d.asList.head? == dataTrue then rec d else Data.l d.asList.tail
+          Part.fix F acc
+
+
+  def goFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog) :
+      Part (Option Data) :=
+    match items with
     | []      => .some (some acc)
     | c :: cs =>
       -- Put the item and the accumulator on two new tapes and run the program.
       -- take the contents of the last tape as the result / new accumulator.
-      (evalProg body (stack ++ [c, acc])).bind fun result =>
-        match result >>= (·.getLast?) with
+      (evalProg body (c :: acc :: stack)).bind fun result =>
+        match result with
         | none      => .some none
         | some acc' => goFold cs acc' stack body
 
-  def evalProg (p : Prog) (stack : List Data) : Part (Option (List Data)) := match p with
-    | []           => .some (some stack)
+  def evalProg (p : Prog) (stack : List Data) : Part (Option Data) := match p with
+    | []           => .some stack.head?
     | op :: rest   =>
-      (evalOp stack op).bind fun result =>
-        match result with
+      (evalOp stack op).bind fun
         | none   => .some none
-        | some stack' => evalProg rest stack'
+        | some r => evalProg rest (r :: stack)
 end
 
 -- `Part` is annoying but unfortunately needed. Since we are dealing with complexity, all programs

From 1693880c06fdddcfef24f3f6f0dca4eed1113745 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 14 May 2026 09:49:30 +0200
Subject: [PATCH 026/106] cleanup

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 127 +++++++++++-------
 1 file changed, 77 insertions(+), 50 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 549c3716b4..d61aed547a 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -78,8 +78,28 @@ inductive Operation where
 
 abbrev Prog := List Operation
 
-
--- TODO define a well-formedness Prop that ensures that tape indices are all in bounds.
+mutual
+  /-- `WFOp n op` states that `op` is well-formed when the current stack has `n` entries.
+      All tape indices must be in bounds, and sub-programs must be well-formed at the
+      appropriate derived stack heights. -/
+  def WFOp (n : ℕ) : Operation → Prop
+    | .empty      => True
+    | .copy i     => i < n
+    | .cons h t   => h < n ∧ t < n
+    | .head i     => i < n
+    | .tail i     => i < n
+    | .eq i j     => i < n ∧ j < n
+    | .ite i t e  => i < n ∧ WFProg n t ∧ WFProg n e
+    | .fold l i b => l < n ∧ i < n ∧ WFProg (n + 2) b
+    | .while_ i b => i < n ∧ WFProg (n + 1) b
+
+  /-- `WFProg n p` states that `p` is well-formed given an initial stack of size `n`.
+      Since each operation pushes exactly one value, the k-th operation (0-indexed) sees
+      a stack of size `n + k`, so the tail of the program is checked at height `n + 1`. -/
+  def WFProg : ℕ → Prog → Prop
+    | n, []         => n ≠ 0 -- we require this because a program has to return a result.
+    | n, op :: rest => WFOp n op ∧ WFProg (n + 1) rest
+end
 
 -- One could define a monadic builder-pattern that handles tape index allocation:
 -- def filter (a : TapeIndex) (predicate : TapeIndex → Build TapeIndex) : Build TapeIndex := do
@@ -98,63 +118,72 @@ abbrev Prog := List Operation
 abbrev dataTrue := Data.l [Data.l []]
 abbrev dataFalse := Data.l []
 
+
 -- Interpreter:
 -- It returns Part.none if the program does not terminate and Part.some Option.none if the
 -- program is not well-formed.
 mutual
-  def evalOp (stack : List Data) (op : Operation) : Part (Option Data) := match op with
-    | .empty => .some (some Data.empty)
-    | .copy i => .some stack[i]?
+  def evalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op) : Part Data := match op with
+    | .empty => .some Data.empty
+    | .copy i => .some stack[i]
     | .cons h t =>
-        .some do Data.l ((← stack[h]?) :: (← stack[t]?).asList)
-    | .head i =>
-        .some (do (← stack[i]?).asList.headD Data.empty)
-    | .tail i =>
-        .some (do Data.l (← stack[i]?).asList.tail)
+      let ⟨h₁, h₂⟩ := h_wf
+      .some (Data.l (stack[h] :: stack[t].asList))
+    | .head i => .some (stack[i].asList.headD Data.empty)
+    | .tail i => .some (Data.l stack[i].asList.tail)
     | .eq i j =>
-        .some (do if (← stack[i]?) == (← stack[j]?) then dataTrue else dataFalse)
-    | .ite i then_ else_ => match stack[i]? with
-        | none => .some none
-        | some d => if d == dataTrue then evalProg then_ stack else evalProg else_ stack
-    | .fold l i body => match (stack[l]?, stack[i]?) with
-        | (some list, some initial) => goFold list.asList initial stack body
-        | _ => .some none
+      let ⟨h₁, h₂⟩ := h_wf
+      .some (if stack[i] == stack[j] then dataTrue else dataFalse)
+    | .ite i then_ else_ =>
+       let ⟨h₁, h₂, h₃⟩ := h_wf
+       if stack[i] == dataTrue then evalProg then_ stack h₂ else evalProg else_ stack h₃
+    | .fold list initial body =>
+       let ⟨h₁, h₂, h₃⟩ := h_wf
+       goFold stack[list].asList stack[initial] stack body h₃
     | .while_ i body =>
-        match stack[i]? with
-        | none     => .some none
-        | some acc =>
-          -- recurse as long as the head of the returned value is true (the rest is used
-          -- to pass data across iterations).
-          let F := fun rec d => (evalProg body (d :: stack)).bind fun
-              | none => .some none
-              | some d => if d.asList.head? == dataTrue then rec d else Data.l d.asList.tail
-          Part.fix F acc
-
-
-  def goFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog) :
-      Part (Option Data) :=
+       let ⟨h₁, h₂⟩ := h_wf
+        -- recurse as long as the head of the returned value is true (the rest is used
+        -- to pass data across iterations).
+        let F := fun rec d =>
+          (evalProg body (d :: stack) h₂).bind fun d =>
+            if d.asList.head? == dataTrue then rec d else Data.l d.asList.tail
+        Part.fix F stack[i]
+
+  def goFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog)
+      (h_wf : WFProg (stack.length + 2) body) : Part Data :=
     match items with
-    | []      => .some (some acc)
+    | []      => .some acc
     | c :: cs =>
       -- Put the item and the accumulator on two new tapes and run the program.
       -- take the contents of the last tape as the result / new accumulator.
-      (evalProg body (c :: acc :: stack)).bind fun result =>
-        match result with
-        | none      => .some none
-        | some acc' => goFold cs acc' stack body
-
-  def evalProg (p : Prog) (stack : List Data) : Part (Option Data) := match p with
-    | []           => .some stack.head?
-    | op :: rest   =>
-      (evalOp stack op).bind fun
-        | none   => .some none
-        | some r => evalProg rest (r :: stack)
+      (evalProg body (c :: acc :: stack) h_wf).bind fun acc' => goFold cs acc' stack body h_wf
+
+  def evalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) : Part Data :=
+    match prog with
+      | []           => .some (stack.head (by grind [WFProg]))
+      | op :: rest   =>
+        let ⟨h_wf_head, h_wf_tail⟩ := h_wf
+        (evalOp stack op h_wf_head).bind fun r => evalProg rest (r :: stack) h_wf_tail
 end
 
--- `Part` is annoying but unfortunately needed. Since we are dealing with complexity, all programs
--- should compute total functions, so we define totality as a prop. Of course, any program that
--- does not use while_ is total. This can be hopefully derived structurally using simp lemmas and thus
--- should auto-solve in simp lemmas.
+structure WellFormedProgram where
+  prog : Prog
+  inputs : ℕ
+  h_wf : WFProg inputs prog
+
+def FunType (wf : WellFormedProgram) : Type :=
+  let rec of_input_count := fun
+    | 0 => Data
+    | n + 1 => Data → of_input_count n
+  of_input_count wf.inputs
+
+def WellFormedProgram.eval (h_wf : WellFormedProgram)
+    (stack : List Data) (h_len : stack.length = h_wf.inputs) : Part Data :=
+  evalProg h_wf.prog stack (by simpa [h_len] using h_wf.h_wf)
+
+def WellFormedProgram.Total (wfp : WellFormedProgram) : Prop :=
+  ∀ (stack : List Data) (h_len : stack.length = wfp.inputs), (wfp.eval stack h_len).Dom
+
 
 mutual
   def WhileFreeOp : Operation → Prop
@@ -167,11 +196,9 @@ mutual
     | op :: rest => WhileFreeOp op ∧ WhileFreeProg rest
 end
 
-def ComputesTotalFunction (prog : Prog) : Prop :=
-  ∀ (stack : List Data), (evalProg prog stack).Dom
+theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p.Total := by
 
-theorem whileFree_total (prog : Prog) (hwf : WhileFreeProg prog) :
-    ComputesTotalFunction prog := by sorry
+  sorry
 
 def WellFormedTotal (prog : Prog) : Prop :=
   ∃ (h_total : ComputesTotalFunction prog), ∀ stack : List Data,

From be8ef85d58b1ae0ccae052e1dc7246e86a246fd0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 14 May 2026 10:41:36 +0200
Subject: [PATCH 027/106] Remove copy.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 112 +++++++++++++-----
 1 file changed, 85 insertions(+), 27 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index d61aed547a..5a30e9508d 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -59,8 +59,6 @@ abbrev TapeIndex := ℕ
 inductive Operation where
   -- create a new tape initialized with `Data.l []`
   | empty  : Operation
-  -- copy tape i to a new tape -- not sure if this is needed
-  | copy   : TapeIndex → Operation
   -- cons tape h and tape t to a new tape (h :: t)
   | cons   : TapeIndex → TapeIndex → Operation
   -- head of the data if it exists, or empty otherwise
@@ -84,7 +82,6 @@ mutual
       appropriate derived stack heights. -/
   def WFOp (n : ℕ) : Operation → Prop
     | .empty      => True
-    | .copy i     => i < n
     | .cons h t   => h < n ∧ t < n
     | .head i     => i < n
     | .tail i     => i < n
@@ -123,9 +120,9 @@ abbrev dataFalse := Data.l []
 -- It returns Part.none if the program does not terminate and Part.some Option.none if the
 -- program is not well-formed.
 mutual
-  def evalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op) : Part Data := match op with
+  def evalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op)
+      : Part Data := match op with
     | .empty => .some Data.empty
-    | .copy i => .some stack[i]
     | .cons h t =>
       let ⟨h₁, h₂⟩ := h_wf
       .some (Data.l (stack[h] :: stack[t].asList))
@@ -197,37 +194,100 @@ mutual
 end
 
 theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p.Total := by
+  intro data h_len
+  induction h : p.prog generalizing data with
+  | nil =>
+    simp [WellFormedProgram.eval, evalProg, h]
+  | cons op rest ih =>
+    simp [WellFormedProgram.eval, h]
+    cases op with
+    | empty =>
+      unfold evalProg evalOp
+      simp
+      sorry
+    | cons h t => sorry
+    | head i => sorry
+    | tail i => sorry
+    | eq i j => sorry
+    | ite i then_ else_ => sorry
+    | fold l i body => sorry
+    | while_ i body => sorry
 
-  sorry
-
-def WellFormedTotal (prog : Prog) : Prop :=
-  ∃ (h_total : ComputesTotalFunction prog), ∀ stack : List Data,
-    ((evalProg prog stack).get (h_total stack)).isSome
 
 -- Now the most important part: If a program is total, and well-formed we can talk about the
 -- function computed by the program - this is something that was not really possible with my old
 -- design:
 
-def progFun (prog : Prog) (h_wft : WellFormedTotal prog) (stack : List Data) : Data :=
-    -- TODO prove that the stack size increases by at least 1 or similar
-  (((evalProg prog stack).get (h_wft.1 stack)).get (h_wft.2 stack)).getLast sorry
-
 -- With these at hand, we can define simp lemmas and thus auto-derive semantics
 -- and maybe even resource requirements of programs:
 
-@[simp]
-theorem evalFold_eq_foldl
-    (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
-    (body : Prog) (h : WellFormedTotal body)
-    (rest : Prog) :
-    evalProg ((.fold l i body) :: rest) stack =
-    .some (some (stack ++ [(stack[l].asList.foldl
-      (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
-      stack[i])])) := by
-  sorry
+-- @[simp]
+-- theorem evalFold_eq_foldl
+--     (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
+--     (body : Prog) (h : WellFormedTotal body)
+--     (rest : Prog) :
+--     evalProg ((.fold l i body) :: rest) stack =
+--     .some (some (stack ++ [(stack[l].asList.foldl
+--       (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
+--       stack[i])])) := by
+--   sorry
+
+
+-- The problem with the current programs is that they reference stack slots relative to the stack
+-- head, so they are constantly shifting. The following Builder monad makes that easier:
 
+def AbsoluteIndex := ℕ
+
+structure IndexAllocator where
+  initialStackSize : ℕ
+  prog : Prog
+
+abbrev Build (α : Type) := StateT IndexAllocator (Except String) α
+
+-- Only way to allocate a slot
+def newSlot (op : String) : Build Slot := do
+  let env ← get
+  let sid := env.next
+  set { env with next := sid + 1, ops := env.ops ++ [op] }
+  return ⟨sid⟩
+
+-- ============================================================
+-- SLOT PRIMITIVES
+-- ============================================================
+
+-- Allocate a slot holding Data.l []
+def new : Build Slot :=
+  newSlot "new"
+
+
+def bit0 : Build Slot := new
+def bit1 : Build Slot := true_
+
+def addBits (a b carry : Slot) : Build (Slot × Slot) := do
+  let sumBit   ← xor_ (← xor_ a b) carry
+  let carryOut ← if_ (← and_ a b)
+    true_
+    (and_ b carry)
+  return (sumBit, carryOut)
+
+-- Add two binary numbers — O(n²) time, O(n) space
+def add (a b : Slot) : Build Slot := do
+  let (acc, bRest, carry) ← fold a (← new, b, ← bit0)
+    (fun aBit (acc, bRest, carry) => do
+      let (bBit, bTail) ← if_ bRest
+        (fold bRest (← bit0, ← new)
+          (fun h _ => return (h, ← new)))  -- take head of bRest
+        (do return (← bit0, ← new))        -- b exhausted
+      let (s, c) ← addBits aBit bBit carry
+      return (← cons s acc, bTail, c))
+  let (acc2, carry2) ← fold bRest (acc, carry)
+    (fun bBit (acc, carry) => do
+      let (s, c) ← addBits (← bit0) bBit carry
+      return (← cons s acc, c))
+  if_ carry2
+    (cons (← bit1) acc2)
+    (return acc2)
 
-abbrev Build (α : Type) := StateT Prog (Except String) α
 
 def appendOp (op : Operation) : Build TapeIndex := do
   let prog ← get
@@ -237,8 +297,6 @@ def appendOp (op : Operation) : Build TapeIndex := do
 
 def empty : Build TapeIndex := appendOp .empty
 
-def copy (i : TapeIndex) : Build TapeIndex := appendOp (.copy i)
-
 def cons (h t : TapeIndex) : Build TapeIndex := appendOp (.cons h t)
 
 def eq (i j : TapeIndex) : Build TapeIndex := appendOp (.eq i j)

From 3d07e8ab4227ce8292aa9d61b152db1e856c4e96 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 14 May 2026 10:54:37 +0200
Subject: [PATCH 028/106] builder

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 205 +++++++++++-------
 1 file changed, 132 insertions(+), 73 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 5a30e9508d..472e292dda 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -108,9 +108,10 @@ end
 
 -- TODO define space measure:
 -- elementary operations incur the size of their output as additional space
--- fold incurs space of init plus the max of the space of the step function - this is the crucial point
--- that allows us to build space-efficient algorithms: We implicitly overwrite the old
--- accumulator value even though there is no explicit "overwrite" or "free" operation.
+-- fold incurs space of init plus the max of the space of the step function
+-- this is the crucial point that allows us to build space-efficient algorithms:
+-- We implicitly overwrite the old accumulator value even though there is no
+-- explicit "overwrite" or "free" operation.
 
 abbrev dataTrue := Data.l [Data.l []]
 abbrev dataFalse := Data.l []
@@ -233,73 +234,131 @@ theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p
 --   sorry
 
 
--- The problem with the current programs is that they reference stack slots relative to the stack
--- head, so they are constantly shifting. The following Builder monad makes that easier:
-
-def AbsoluteIndex := ℕ
-
-structure IndexAllocator where
-  initialStackSize : ℕ
-  prog : Prog
-
-abbrev Build (α : Type) := StateT IndexAllocator (Except String) α
-
--- Only way to allocate a slot
-def newSlot (op : String) : Build Slot := do
-  let env ← get
-  let sid := env.next
-  set { env with next := sid + 1, ops := env.ops ++ [op] }
-  return ⟨sid⟩
-
--- ============================================================
--- SLOT PRIMITIVES
--- ============================================================
-
--- Allocate a slot holding Data.l []
-def new : Build Slot :=
-  newSlot "new"
-
-
-def bit0 : Build Slot := new
-def bit1 : Build Slot := true_
-
-def addBits (a b carry : Slot) : Build (Slot × Slot) := do
-  let sumBit   ← xor_ (← xor_ a b) carry
-  let carryOut ← if_ (← and_ a b)
-    true_
-    (and_ b carry)
-  return (sumBit, carryOut)
-
--- Add two binary numbers — O(n²) time, O(n) space
-def add (a b : Slot) : Build Slot := do
-  let (acc, bRest, carry) ← fold a (← new, b, ← bit0)
-    (fun aBit (acc, bRest, carry) => do
-      let (bBit, bTail) ← if_ bRest
-        (fold bRest (← bit0, ← new)
-          (fun h _ => return (h, ← new)))  -- take head of bRest
-        (do return (← bit0, ← new))        -- b exhausted
-      let (s, c) ← addBits aBit bBit carry
-      return (← cons s acc, bTail, c))
-  let (acc2, carry2) ← fold bRest (acc, carry)
-    (fun bBit (acc, carry) => do
-      let (s, c) ← addBits (← bit0) bBit carry
-      return (← cons s acc, c))
-  if_ carry2
-    (cons (← bit1) acc2)
-    (return acc2)
-
-
-def appendOp (op : Operation) : Build TapeIndex := do
-  let prog ← get
-  let idx := prog.length
-  set (prog ++ [op])
-  return idx
-
-def empty : Build TapeIndex := appendOp .empty
-
-def cons (h t : TapeIndex) : Build TapeIndex := appendOp (.cons h t)
-
-def eq (i j : TapeIndex) : Build TapeIndex := appendOp (.eq i j)
-
-def ite_ (cond : TapeIndex) (then_ else_ : Prog) : Build TapeIndex := do
-  appendOp (.ite cond (getThenProg) (getElseProg))
+-- ================= Builder monad
+--
+-- The problem with writing programs directly is that tape indices are top-relative
+-- (0 = newest item), so every push shifts all existing indices by 1.
+--
+-- The builder monad solves this by working with *bottom-indexed* references internally.
+-- A `Ref` stores the absolute position of a stack slot counting from the bottom (oldest = 0).
+-- Bottom-indices are stable: pushing a new item never changes any existing Ref.
+-- When an Operation is about to be emitted, `Ref.toIdx` converts the stored bottom-index
+-- to the top-relative index expected by the machine: `currentHeight - 1 - bottomIndex`.
+--
+-- Sub-program builders (for ite/fold/while_) are created with `n_initial` set to the
+-- outer stack height at the point of the combinator plus any extra items prepended by
+-- the combinator (2 for fold, 1 for while_). Outer Refs pass into sub-builders unchanged
+-- because their bottom-indices remain valid.
+
+/-- Monad state: the initial stack size for this (sub-)program and the ops collected so far. -/
+structure BuildCtx where
+  n_initial : ℕ
+  prog : Prog := []
+
+/-- The builder monad. -/
+abbrev Build (α : Type) := StateT BuildCtx (Except String) α
+
+/-- A stable reference to a stack slot.  The value is the slot's bottom-index:
+    position from the bottom of the conceptual stack (oldest item = 0).
+    Using `abbrev` so all `ℕ` instances (LE, Sub, ToString, …) are inherited. -/
+abbrev Ref := ℕ
+
+/-- Current stack height (= n_initial + number of ops emitted so far). -/
+def Build.currentHeight : Build ℕ := do
+  let ctx ← get
+  return ctx.n_initial + ctx.prog.length
+
+/-- Convert a stable `Ref` to its current top-relative index (for use in Operations).
+    Throws if the ref is out of range. -/
+def Ref.toIdx (r : Ref) : Build TapeIndex := do
+  let h ← Build.currentHeight
+  if r ≥ h then throw s!"Ref {r} is out of range (current height {h})"
+  return h - 1 - r
+
+/-- Emit one operation and return a `Ref` to the slot it creates. -/
+private def emit (op : Operation) : Build Ref := do
+  let ctx ← get
+  let b : Ref := ctx.n_initial + ctx.prog.length
+  set { ctx with prog := ctx.prog ++ [op] }
+  return b
+
+/-- Obtain a `Ref` to an item that already exists in the initial stack.
+    `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom. -/
+def Build.inputRef (j : TapeIndex) : Build Ref := do
+  let ctx ← get
+  if j ≥ ctx.n_initial then
+    throw s!"inputRef {j} is out of range (n_initial = {ctx.n_initial})"
+  return ctx.n_initial - 1 - j
+
+-- ── Primitive operations ──────────────────────────────────────────────────────
+
+def Build.empty : Build Ref := emit .empty
+
+def Build.cons (h t : Ref) : Build Ref := do emit (.cons (← h.toIdx) (← t.toIdx))
+
+def Build.head (r : Ref) : Build Ref := do emit (.head (← r.toIdx))
+
+def Build.tail (r : Ref) : Build Ref := do emit (.tail (← r.toIdx))
+
+def Build.eq (r s : Ref) : Build Ref := do emit (.eq (← r.toIdx) (← s.toIdx))
+
+-- ── Combinators ───────────────────────────────────────────────────────────────
+
+/-- Run a sub-program builder in a fresh context whose initial stack = the current
+    outer stack height plus `extra` items prepended on top.
+    Returns the compiled `Prog`.  The `Ref`s returned by `inner` are bottom-indices
+    valid in the sub-context; `extraRefs` are the `Ref`s for the `extra` prepended
+    items (index 0 = topmost prepended item). -/
+private def Build.subProg (extra : ℕ) (inner : Array Ref → Build Ref)
+    : Build Prog := do
+  let h ← Build.currentHeight
+  let n_initial_inner := h + extra
+  -- Bottom-indices for the `extra` prepended items (top item = h + extra - 1, …)
+  let extraRefs : Array Ref := (Array.range extra).map (fun k => h + extra - 1 - k)
+  let (_, innerCtx) ←
+    liftM (StateT.run (inner extraRefs) ({ n_initial := n_initial_inner } : BuildCtx))
+  return innerCtx.prog
+
+/-- Branch on `cond`: if `cond == dataTrue` run `then_`, else run `else_`.
+    Both branches receive no extra prepended items (same stack as the outer context
+    at the ite op).  Each branch builder must return the `Ref` it wants as the result. -/
+def Build.ite (cond : Ref) (then_ else_ : Build Ref) : Build Ref := do
+  let ci ← cond.toIdx
+  let thenProg ← Build.subProg 0 (fun _ => then_)
+  let elseProg ← Build.subProg 0 (fun _ => else_)
+  emit (.ite ci thenProg elseProg)
+
+/-- Fold over the children of `list_`, starting with accumulator `acc_`, using `body`.
+    `body` receives two `Ref`s: the current child (index 0) and the current accumulator
+    (index 1), plus all outer `Ref`s remain valid unchanged. -/
+def Build.fold (list_ acc_ : Ref) (body : Ref → Ref → Build Ref) : Build Ref := do
+  let li ← list_.toIdx
+  let ai ← acc_.toIdx
+  let bodyProg ← Build.subProg 2 (fun extra => body extra[0]! extra[1]!)
+  emit (.fold li ai bodyProg)
+
+/-- While `cond_` is nonempty, run `body`.
+    `body` receives one `Ref` for the current accumulator (= current value of `cond_`). -/
+def Build.while_ (cond_ : Ref) (body : Ref → Build Ref) : Build Ref := do
+  let ci ← cond_.toIdx
+  let bodyProg ← Build.subProg 1 (fun extra => body extra[0]!)
+  emit (.while_ ci bodyProg)
+
+-- ── Running the builder ───────────────────────────────────────────────────────
+
+/-- Run a builder that starts with `n_initial` pre-existing stack items.
+    The builder returns the `Ref` it considers the result.
+    `run` checks that the result `Ref` is the top of the final stack (top-index 0),
+    i.e., the result is the last emitted op, and returns the completed `Prog`. -/
+def Build.run (n_initial : ℕ) (b : Build Ref) : Except String Prog := do
+  let (resultRef, ctx) ← StateT.run b { n_initial }
+  let finalHeight := n_initial + ctx.prog.length
+  if finalHeight = 0 then throw "empty program with empty initial stack"
+  let resultIdx := finalHeight - 1 - resultRef
+  if resultIdx ≠ 0 then
+    throw s!"result Ref is not at the top of the stack (top-index {resultIdx}, expected 0)"
+  return ctx.prog
+
+/-- `Build.run` for programs that take no initial input (n_initial = 0 would violate
+    WFProg at the empty case, so callers must ensure at least one op is emitted). -/
+def Build.runFresh (b : Build Ref) : Except String Prog := Build.run 0 b

From d089e52d4dafdb26466aa1df2fa39354927722c5 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 15 May 2026 11:01:52 +0200
Subject: [PATCH 029/106] some simplifications.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 437 +++++++++++++-----
 1 file changed, 328 insertions(+), 109 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 472e292dda..7ce67705ae 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -65,7 +65,7 @@ inductive Operation where
   | head   : TapeIndex → Operation
   -- tail of the data
   | tail   : TapeIndex → Operation
-  -- compare two tapes, returning empty if equal, nonempty otherwise
+  -- compare two tapes, returning non-empty if equal, empty otherwise
   | eq     : TapeIndex → TapeIndex → Operation
   -- branch on tape i: if empty then then_ else else_
   | ite    : TapeIndex → (List Operation) → (List Operation) → Operation
@@ -73,6 +73,7 @@ inductive Operation where
   | fold   : TapeIndex → TapeIndex → (List Operation) → Operation
   -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
   | while_ : TapeIndex → (List Operation) → Operation
+deriving Repr
 
 abbrev Prog := List Operation
 
@@ -124,28 +125,24 @@ mutual
   def evalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op)
       : Part Data := match op with
     | .empty => .some Data.empty
-    | .cons h t =>
-      let ⟨h₁, h₂⟩ := h_wf
-      .some (Data.l (stack[h] :: stack[t].asList))
+    | .cons h t => .some (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList))
     | .head i => .some (stack[i].asList.headD Data.empty)
     | .tail i => .some (Data.l stack[i].asList.tail)
-    | .eq i j =>
-      let ⟨h₁, h₂⟩ := h_wf
-      .some (if stack[i] == stack[j] then dataTrue else dataFalse)
+    | .eq i j => .some (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse)
     | .ite i then_ else_ =>
-       let ⟨h₁, h₂, h₃⟩ := h_wf
-       if stack[i] == dataTrue then evalProg then_ stack h₂ else evalProg else_ stack h₃
+      if stack[i]'h_wf.1 == dataTrue then
+        evalProg then_ stack h_wf.2.1
+      else
+        evalProg else_ stack h_wf.2.2
     | .fold list initial body =>
-       let ⟨h₁, h₂, h₃⟩ := h_wf
-       goFold stack[list].asList stack[initial] stack body h₃
+      goFold (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) stack body h_wf.2.2
     | .while_ i body =>
-       let ⟨h₁, h₂⟩ := h_wf
         -- recurse as long as the head of the returned value is true (the rest is used
         -- to pass data across iterations).
         let F := fun rec d =>
-          (evalProg body (d :: stack) h₂).bind fun d =>
+          (evalProg body (d :: stack) h_wf.2).bind fun d =>
             if d.asList.head? == dataTrue then rec d else Data.l d.asList.tail
-        Part.fix F stack[i]
+        Part.fix F (stack[i]'h_wf.1)
 
   def goFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog)
       (h_wf : WFProg (stack.length + 2) body) : Part Data :=
@@ -164,6 +161,16 @@ mutual
         (evalOp stack op h_wf_head).bind fun r => evalProg rest (r :: stack) h_wf_tail
 end
 
+@[simp]
+lemma evalProg_cons
+    (op : Operation)
+    (rest : Prog)
+    (stack : List Data)
+    (h_wf : WFProg stack.length (op :: rest)) :
+    evalProg (op :: rest) stack h_wf =
+      (evalOp stack op h_wf.1).bind fun r => evalProg rest (r :: stack) h_wf.2 := by
+  sorry
+
 structure WellFormedProgram where
   prog : Prog
   inputs : ℕ
@@ -175,13 +182,32 @@ def FunType (wf : WellFormedProgram) : Type :=
     | n + 1 => Data → of_input_count n
   of_input_count wf.inputs
 
-def WellFormedProgram.eval (h_wf : WellFormedProgram)
-    (stack : List Data) (h_len : stack.length = h_wf.inputs) : Part Data :=
-  evalProg h_wf.prog stack (by simpa [h_len] using h_wf.h_wf)
-
-def WellFormedProgram.Total (wfp : WellFormedProgram) : Prop :=
-  ∀ (stack : List Data) (h_len : stack.length = wfp.inputs), (wfp.eval stack h_len).Dom
-
+@[simp]
+def WellFormedProgram.eval (p : WellFormedProgram)
+    (stack : List Data) (h_len : stack.length = p.inputs) : Part Data :=
+  evalProg p.prog stack (by simpa [h_len] using p.h_wf)
+
+def WellFormedProgram.Total (p : WellFormedProgram) : Prop :=
+  ∀ (stack : List Data) (h_len : stack.length = p.inputs), (p.eval stack h_len).Dom
+
+-- examples:
+def prog_true : WellFormedProgram := {
+  prog := [.empty, .cons 0 0],
+  inputs := 0,
+  h_wf := by simp [WFProg, WFOp]
+}
+def prog_false : WellFormedProgram := {
+  prog := [.empty],
+  inputs := 0,
+  h_wf := by simp [WFProg, WFOp]
+}
+def prog_negate : WellFormedProgram := {
+  prog := [.eq 0 0],
+  inputs := 1,
+  h_wf := by simp [WFProg, WFOp]
+}
+lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
+  simp [prog_true, evalOp]
 
 mutual
   def WhileFreeOp : Operation → Prop
@@ -242,123 +268,316 @@ theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p
 -- The builder monad solves this by working with *bottom-indexed* references internally.
 -- A `Ref` stores the absolute position of a stack slot counting from the bottom (oldest = 0).
 -- Bottom-indices are stable: pushing a new item never changes any existing Ref.
--- When an Operation is about to be emitted, `Ref.toIdx` converts the stored bottom-index
+-- When an Operation is about to be emitted, we convert the stored bottom-index
 -- to the top-relative index expected by the machine: `currentHeight - 1 - bottomIndex`.
 --
--- Sub-program builders (for ite/fold/while_) are created with `n_initial` set to the
--- outer stack height at the point of the combinator plus any extra items prepended by
--- the combinator (2 for fold, 1 for while_). Outer Refs pass into sub-builders unchanged
--- because their bottom-indices remain valid.
-
-/-- Monad state: the initial stack size for this (sub-)program and the ops collected so far. -/
+-- The builder additionally **carries a proof of well-formedness** in its state, so that
+-- `Build.run` returns a `WellFormedProgram` *by construction*, with no exceptions, no
+-- `Option`, and no post-hoc decidable check.
+
+/-- A weakening of `WFProg` that holds for the empty program at any `n` (including `0`).
+    Used as the in-flight invariant of the builder, since intermediate states may have
+    `prog = []` while `n_initial = 0`. -/
+def WFProgRaw : ℕ → Prog → Prop
+  | _, []         => True
+  | n, op :: rest => WFOp n op ∧ WFProgRaw (n + 1) rest
+
+/-- Snoc a single op (well-formed at the post-state height) onto a `WFProgRaw` program. -/
+theorem WFProgRaw.append_op :
+    ∀ {n : ℕ} {prog : Prog} {op : Operation},
+      WFProgRaw n prog → WFOp (n + prog.length) op → WFProgRaw n (prog ++ [op])
+  | n, [], op, _, h_op => by
+    refine ⟨?_, trivial⟩
+    show WFOp n op
+    simpa using h_op
+  | n, o :: rest, op, h_p, h_op => by
+    obtain ⟨h_o, h_rest⟩ := h_p
+    refine ⟨h_o, ?_⟩
+    have h_op' : WFOp (n + 1 + rest.length) op := by
+      have heq : n + (o :: rest).length = n + 1 + rest.length := by
+        simp [List.length_cons]; omega
+      rw [heq] at h_op
+      exact h_op
+    exact WFProgRaw.append_op h_rest h_op'
+
+/-- A `WFProgRaw` program with at least one element on the post-execution stack
+    (i.e. `n_initial + prog.length > 0`) lifts to a full `WFProg`. -/
+theorem WFProgRaw_to_WFProg :
+    ∀ {n : ℕ} {prog : Prog}, WFProgRaw n prog → n + prog.length ≠ 0 → WFProg n prog
+  | n, [], _, hpos => by simpa using hpos
+  | _, _ :: rest, h_p, _ => by
+    obtain ⟨h_op, h_rest⟩ := h_p
+    refine ⟨h_op, ?_⟩
+    apply WFProgRaw_to_WFProg h_rest
+    simp
+
+/-- Monad state: the initial stack size, the ops collected so far, and a proof that
+    the collected ops form a well-formed program at that initial stack size. -/
 structure BuildCtx where
   n_initial : ℕ
   prog : Prog := []
+  h_wf : WFProgRaw n_initial prog := by trivial
+
+/-- The current stack height of a build context. -/
+@[simp] def BuildCtx.height (c : BuildCtx) : ℕ := c.n_initial + c.prog.length
 
-/-- The builder monad. -/
-abbrev Build (α : Type) := StateT BuildCtx (Except String) α
+/-- The builder monad: a state monad over `BuildCtx`. -/
+abbrev Build := StateM BuildCtx
 
-/-- A stable reference to a stack slot.  The value is the slot's bottom-index:
-    position from the bottom of the conceptual stack (oldest item = 0).
-    Using `abbrev` so all `ℕ` instances (LE, Sub, ToString, …) are inherited. -/
-abbrev Ref := ℕ
+/-- A stable reference to a stack slot.  `val` is the slot's bottom-index (oldest = 0).
+    `bound` is a snapshot of `currentHeight` at the moment the ref was minted; the
+    invariant `val < bound` is what makes the ref usable.  All refs produced by the
+    builder API satisfy `bound ≤ currentHeight` from the moment of mint onwards
+    (since heights only grow). -/
+structure Ref where
+  val : ℕ
+  bound : ℕ
+  h_lt : val < bound
 
-/-- Current stack height (= n_initial + number of ops emitted so far). -/
+/-- Current stack height (= `n_initial + prog.length`). -/
 def Build.currentHeight : Build ℕ := do
   let ctx ← get
-  return ctx.n_initial + ctx.prog.length
+  return ctx.height
 
-/-- Convert a stable `Ref` to its current top-relative index (for use in Operations).
-    Throws if the ref is out of range. -/
-def Ref.toIdx (r : Ref) : Build TapeIndex := do
-  let h ← Build.currentHeight
-  if r ≥ h then throw s!"Ref {r} is out of range (current height {h})"
-  return h - 1 - r
+/-- Extend a `BuildCtx` by appending one well-formed operation. -/
+private def BuildCtx.extend (ctx : BuildCtx) (op : Operation) (h_op : WFOp ctx.height op) :
+    BuildCtx :=
+  { n_initial := ctx.n_initial
+    prog := ctx.prog ++ [op]
+    h_wf := WFProgRaw.append_op ctx.h_wf (by simpa [BuildCtx.height] using h_op) }
 
-/-- Emit one operation and return a `Ref` to the slot it creates. -/
-private def emit (op : Operation) : Build Ref := do
-  let ctx ← get
-  let b : Ref := ctx.n_initial + ctx.prog.length
-  set { ctx with prog := ctx.prog ++ [op] }
-  return b
+@[simp] theorem BuildCtx.extend_n_initial (ctx : BuildCtx) (op : Operation)
+    (h_op : WFOp ctx.height op) : (ctx.extend op h_op).n_initial = ctx.n_initial := rfl
+
+@[simp] theorem BuildCtx.extend_height (ctx : BuildCtx) (op : Operation)
+    (h_op : WFOp ctx.height op) : (ctx.extend op h_op).height = ctx.height + 1 := by
+  simp [BuildCtx.extend, BuildCtx.height, List.length_append, Nat.add_assoc]
 
 /-- Obtain a `Ref` to an item that already exists in the initial stack.
-    `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom. -/
+    `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom.
+    If `j ≥ n_initial` the resulting `Ref` will be invalid; calls using such a ref will
+    silently fall back to emitting `.empty`. -/
 def Build.inputRef (j : TapeIndex) : Build Ref := do
   let ctx ← get
-  if j ≥ ctx.n_initial then
-    throw s!"inputRef {j} is out of range (n_initial = {ctx.n_initial})"
-  return ctx.n_initial - 1 - j
+  let h := ctx.height
+  if hp : ctx.n_initial > 0 then
+    -- val = ctx.n_initial - 1 - j (clamped at 0 for j ≥ n_initial); bound = h ≥ n_initial > 0
+    let v := if j < ctx.n_initial then ctx.n_initial - 1 - j else 0
+    return ⟨v, h, by simp [v, BuildCtx.height]; split <;> sorry⟩
+  else
+    -- No initial inputs: return a sentinel; can't be used since bound > val always fails.
+    return ⟨0, 1, Nat.lt_succ_self _⟩
 
 -- ── Primitive operations ──────────────────────────────────────────────────────
 
-def Build.empty : Build Ref := emit .empty
-
-def Build.cons (h t : Ref) : Build Ref := do emit (.cons (← h.toIdx) (← t.toIdx))
-
-def Build.head (r : Ref) : Build Ref := do emit (.head (← r.toIdx))
-
-def Build.tail (r : Ref) : Build Ref := do emit (.tail (← r.toIdx))
-
-def Build.eq (r s : Ref) : Build Ref := do emit (.eq (← r.toIdx) (← s.toIdx))
+/-- Emit an `.empty` operation; returns a `Ref` to the new (empty) item on top. -/
+def Build.empty : Build Ref := do
+  let ctx ← get
+  let h := ctx.height
+  let h_op : WFOp h .empty := trivial
+  set (ctx.extend .empty h_op)
+  return ⟨h, h + 1, Nat.lt_succ_self _⟩
+
+/-- Emit `.cons h t`. If either ref's bound exceeds the current height (impossible by
+    API contract), silently emits `.empty` instead so that the WF invariant is preserved. -/
+def Build.cons (h t : Ref) : Build Ref := do
+  let ctx ← get
+  let height := ctx.height
+  if hh : h.bound ≤ height then
+    if ht : t.bound ≤ height then
+      have h_hv : h.val < height := Nat.lt_of_lt_of_le h.h_lt hh
+      have h_tv : t.val < height := Nat.lt_of_lt_of_le t.h_lt ht
+      let i := height - 1 - h.val
+      let j := height - 1 - t.val
+      let op : Operation := .cons i j
+      have hi : i < height := by simp [i]; omega
+      have hj : j < height := by simp [j]; omega
+      have h_op : WFOp height op := ⟨hi, hj⟩
+      set (ctx.extend op h_op)
+      return ⟨height, height + 1, Nat.lt_succ_self _⟩
+    else
+      Build.empty
+  else
+    Build.empty
+
+/-- Emit `.head r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+def Build.head (r : Ref) : Build Ref := do
+  let ctx ← get
+  let height := ctx.height
+  if hr : r.bound ≤ height then
+    have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+    let i := height - 1 - r.val
+    let op : Operation := .head i
+    have hi : i < height := by simp [i]; omega
+    have h_op : WFOp height op := hi
+    set (ctx.extend op h_op)
+    return ⟨height, height + 1, Nat.lt_succ_self _⟩
+  else
+    Build.empty
+
+/-- Emit `.tail r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+def Build.tail (r : Ref) : Build Ref := do
+  let ctx ← get
+  let height := ctx.height
+  if hr : r.bound ≤ height then
+    have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+    let i := height - 1 - r.val
+    let op : Operation := .tail i
+    have hi : i < height := by simp [i]; omega
+    have h_op : WFOp height op := hi
+    set (ctx.extend op h_op)
+    return ⟨height, height + 1, Nat.lt_succ_self _⟩
+  else
+    Build.empty
+
+/-- Emit `.eq r s`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+def Build.eq (r s : Ref) : Build Ref := do
+  let ctx ← get
+  let height := ctx.height
+  if hr : r.bound ≤ height then
+    if hs : s.bound ≤ height then
+      have h_rv : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+      have h_sv : s.val < height := Nat.lt_of_lt_of_le s.h_lt hs
+      let i := height - 1 - r.val
+      let j := height - 1 - s.val
+      let op : Operation := .eq i j
+      have hi : i < height := by simp [i]; omega
+      have hj : j < height := by simp [j]; omega
+      have h_op : WFOp height op := ⟨hi, hj⟩
+      set (ctx.extend op h_op)
+      return ⟨height, height + 1, Nat.lt_succ_self _⟩
+    else
+      Build.empty
+  else
+    Build.empty
 
 -- ── Combinators ───────────────────────────────────────────────────────────────
 
-/-- Run a sub-program builder in a fresh context whose initial stack = the current
-    outer stack height plus `extra` items prepended on top.
-    Returns the compiled `Prog`.  The `Ref`s returned by `inner` are bottom-indices
-    valid in the sub-context; `extraRefs` are the `Ref`s for the `extra` prepended
-    items (index 0 = topmost prepended item). -/
-private def Build.subProg (extra : ℕ) (inner : Array Ref → Build Ref)
-    : Build Prog := do
-  let h ← Build.currentHeight
-  let n_initial_inner := h + extra
-  -- Bottom-indices for the `extra` prepended items (top item = h + extra - 1, …)
-  let extraRefs : Array Ref := (Array.range extra).map (fun k => h + extra - 1 - k)
-  let (_, innerCtx) ←
-    liftM (StateT.run (inner extraRefs) ({ n_initial := n_initial_inner } : BuildCtx))
-  return innerCtx.prog
+/-- Run a sub-program builder in a fresh context whose initial stack height is `subN`,
+    returning the compiled `Prog` together with a `WFProg subN` proof.
+    The caller must supply `h_pos : subN > 0` so that the empty-`prog` case is handled.
+    `extraRefs` are the `Ref`s for the `subN - h` items prepended on top of the outer
+    stack (e.g. `[child, acc]` for `fold`). -/
+private def Build.subProg (subN : ℕ) (h_pos : subN > 0)
+    (extraRefs : Array Ref) (inner : Array Ref → Build Ref) :
+    Build { p : Prog // WFProg subN p } := do
+  let init : BuildCtx := { n_initial := subN, prog := [], h_wf := trivial }
+  let (_, subCtx) := StateT.run (inner extraRefs) init
+  -- Trust that the smart constructors do not change `n_initial`; if some user code
+  -- did, we fall back to a trivial WF program of length 1.
+  if h_eq : subCtx.n_initial = subN then
+    have h_wf_raw : WFProgRaw subN subCtx.prog := h_eq ▸ subCtx.h_wf
+    have h_pos' : subN + subCtx.prog.length ≠ 0 := by omega
+    return ⟨subCtx.prog, WFProgRaw_to_WFProg h_wf_raw h_pos'⟩
+  else
+    have h_wf : WFProg subN [Operation.empty] := by
+      refine ⟨trivial, ?_⟩
+      show subN + 1 ≠ 0
+      omega
+    return ⟨[Operation.empty], h_wf⟩
+
+/-- Build the bottom-index `Ref`s for the `extra` items prepended on top of the outer
+    stack `h` when entering a sub-builder.  Returns refs in order
+    `[topmost prepended, …, bottommost prepended]`. -/
+private def Build.extraRefs (h extra : ℕ) : Array Ref :=
+  (Array.range extra).map fun k =>
+    let v := h + extra - 1 - k
+    have h_lt : v < h + extra := by simp [v]; omega
+    ⟨v, h + extra, h_lt⟩
 
 /-- Branch on `cond`: if `cond == dataTrue` run `then_`, else run `else_`.
-    Both branches receive no extra prepended items (same stack as the outer context
-    at the ite op).  Each branch builder must return the `Ref` it wants as the result. -/
+    Both branches see the same outer stack.  Each branch must return the `Ref` it
+    wants as the result. -/
 def Build.ite (cond : Ref) (then_ else_ : Build Ref) : Build Ref := do
-  let ci ← cond.toIdx
-  let thenProg ← Build.subProg 0 (fun _ => then_)
-  let elseProg ← Build.subProg 0 (fun _ => else_)
-  emit (.ite ci thenProg elseProg)
+  let ctx ← get
+  let height := ctx.height
+  if hc : cond.bound ≤ height then
+    have h_v : cond.val < height := Nat.lt_of_lt_of_le cond.h_lt hc
+    let i := height - 1 - cond.val
+    have hi : i < height := by simp [i]; omega
+    have h_pos : height > 0 := by omega
+    let ⟨thenProg, h_then⟩ ← Build.subProg height h_pos (Build.extraRefs height 0) (fun _ => then_)
+    let ⟨elseProg, h_else⟩ ← Build.subProg height h_pos (Build.extraRefs height 0) (fun _ => else_)
+    let op : Operation := .ite i thenProg elseProg
+    have h_op : WFOp height op := ⟨hi, h_then, h_else⟩
+    set (ctx.extend op h_op)
+    return ⟨height, height + 1, Nat.lt_succ_self _⟩
+  else
+    Build.empty
 
 /-- Fold over the children of `list_`, starting with accumulator `acc_`, using `body`.
-    `body` receives two `Ref`s: the current child (index 0) and the current accumulator
-    (index 1), plus all outer `Ref`s remain valid unchanged. -/
+    `body` receives `(child, acc)` as `Ref`s; outer `Ref`s remain valid unchanged. -/
 def Build.fold (list_ acc_ : Ref) (body : Ref → Ref → Build Ref) : Build Ref := do
-  let li ← list_.toIdx
-  let ai ← acc_.toIdx
-  let bodyProg ← Build.subProg 2 (fun extra => body extra[0]! extra[1]!)
-  emit (.fold li ai bodyProg)
-
-/-- While `cond_` is nonempty, run `body`.
-    `body` receives one `Ref` for the current accumulator (= current value of `cond_`). -/
+  let ctx ← get
+  let height := ctx.height
+  if hl : list_.bound ≤ height then
+    if ha : acc_.bound ≤ height then
+      have h_lv : list_.val < height := Nat.lt_of_lt_of_le list_.h_lt hl
+      have h_av : acc_.val < height := Nat.lt_of_lt_of_le acc_.h_lt ha
+      let li := height - 1 - list_.val
+      let ai := height - 1 - acc_.val
+      have hli : li < height := by simp [li]; omega
+      have hai : ai < height := by simp [ai]; omega
+      have h_pos : height + 2 > 0 := by omega
+      let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 2) h_pos
+        (Build.extraRefs height 2) (fun extra => body extra[0]! extra[1]!)
+      let op : Operation := .fold li ai bodyProg
+      have h_op : WFOp height op := ⟨hli, hai, h_body⟩
+      set (ctx.extend op h_op)
+      return ⟨height, height + 1, Nat.lt_succ_self _⟩
+    else
+      Build.empty
+  else
+    Build.empty
+
+/-- While `cond_` is nonempty, run `body`.  `body` receives one `Ref` for the current
+    accumulator (= the current value of `cond_` on top of the outer stack). -/
 def Build.while_ (cond_ : Ref) (body : Ref → Build Ref) : Build Ref := do
-  let ci ← cond_.toIdx
-  let bodyProg ← Build.subProg 1 (fun extra => body extra[0]!)
-  emit (.while_ ci bodyProg)
+  let ctx ← get
+  let height := ctx.height
+  if hc : cond_.bound ≤ height then
+    have h_v : cond_.val < height := Nat.lt_of_lt_of_le cond_.h_lt hc
+    let i := height - 1 - cond_.val
+    have hi : i < height := by simp [i]; omega
+    have h_pos : height + 1 > 0 := by omega
+    let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 1) h_pos
+      (Build.extraRefs height 1) (fun extra => body extra[0]!)
+    let op : Operation := .while_ i bodyProg
+    have h_op : WFOp height op := ⟨hi, h_body⟩
+    set (ctx.extend op h_op)
+    return ⟨height, height + 1, Nat.lt_succ_self _⟩
+  else
+    Build.empty
 
 -- ── Running the builder ───────────────────────────────────────────────────────
 
-/-- Run a builder that starts with `n_initial` pre-existing stack items.
-    The builder returns the `Ref` it considers the result.
-    `run` checks that the result `Ref` is the top of the final stack (top-index 0),
-    i.e., the result is the last emitted op, and returns the completed `Prog`. -/
-def Build.run (n_initial : ℕ) (b : Build Ref) : Except String Prog := do
-  let (resultRef, ctx) ← StateT.run b { n_initial }
-  let finalHeight := n_initial + ctx.prog.length
-  if finalHeight = 0 then throw "empty program with empty initial stack"
-  let resultIdx := finalHeight - 1 - resultRef
-  if resultIdx ≠ 0 then
-    throw s!"result Ref is not at the top of the stack (top-index {resultIdx}, expected 0)"
-  return ctx.prog
-
-/-- `Build.run` for programs that take no initial input (n_initial = 0 would violate
-    WFProg at the empty case, so callers must ensure at least one op is emitted). -/
-def Build.runFresh (b : Build Ref) : Except String Prog := Build.run 0 b
+/-- Run a builder that starts with `n_initial` pre-existing stack items, producing a
+    `WellFormedProgram` *by construction*.  If the user's builder produces no ops and
+    `n_initial = 0`, an `.empty` op is appended so that the result is always a
+    syntactically valid `WFProg` (which requires the post-execution stack to be
+    non-empty). -/
+def Build.run (n_initial : ℕ) (b : Build Ref) : WellFormedProgram :=
+  let init : BuildCtx := { n_initial, prog := [], h_wf := trivial }
+  let (_, ctx) := StateT.run b init
+  if h_pos : ctx.height ≠ 0 then
+    ⟨ctx.prog, ctx.n_initial, WFProgRaw_to_WFProg ctx.h_wf (by simpa [BuildCtx.height] using h_pos)⟩
+  else
+    -- height = 0 ⇒ n_initial = 0 ∧ prog = []; emit a sentinel `.empty` to satisfy WFProg.
+    let extended := ctx.extend .empty trivial
+    have h_pos' : extended.n_initial + extended.prog.length ≠ 0 := by
+      simp [extended, BuildCtx.extend, List.length_append]
+    ⟨extended.prog, extended.n_initial, WFProgRaw_to_WFProg extended.h_wf h_pos'⟩
+
+/-- Convenience: `Build.run` for programs that take no initial input. -/
+def Build.runFresh (b : Build Ref) : WellFormedProgram := Build.run 0 b
+
+
+def funFalse : WellFormedProgram := Build.runFresh do
+  Build.empty
+
+def funTrue : WellFormedProgram := Build.runFresh do
+  let a ← Build.empty
+  Build.cons a a
+
+#eval funFalse.prog
+#eval funTrue.prog

From 34240349ef60f6afabda42eca88ba7d26350e064 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 15 May 2026 12:00:19 +0200
Subject: [PATCH 030/106] metered evaluation

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 109 ++++++++++++++++++
 1 file changed, 109 insertions(+)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 7ce67705ae..87ae5bb5ac 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -43,6 +43,10 @@ abbrev Data.empty := Data.l []
 abbrev Data.asList
   | Data.l xs => xs
 
+--- Encoding length of d.
+def Data.size : Data → ℕ
+  | Data.l xs => 2 + (xs.map Data.size |>.sum)
+
 abbrev TapeIndex := ℕ
 
 
@@ -117,6 +121,10 @@ end
 abbrev dataTrue := Data.l [Data.l []]
 abbrev dataFalse := Data.l []
 
+structure InterpreterState where
+  stack : List Data
+  time : ℕ
+  space : ℕ
 
 -- Interpreter:
 -- It returns Part.none if the program does not terminate and Part.some Option.none if the
@@ -153,6 +161,7 @@ mutual
       -- take the contents of the last tape as the result / new accumulator.
       (evalProg body (c :: acc :: stack) h_wf).bind fun acc' => goFold cs acc' stack body h_wf
 
+  @[simp]
   def evalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) : Part Data :=
     match prog with
       | []           => .some (stack.head (by grind [WFProg]))
@@ -161,6 +170,45 @@ mutual
         (evalOp stack op h_wf_head).bind fun r => evalProg rest (r :: stack) h_wf_tail
 end
 
+mutual
+  --- Evaluate a single operation and return the return value, additional time and additional space.
+  def meteredEvalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op) :
+      Part (Data × ℕ × ℕ) :=
+    match op with
+    | .empty => .some (Data.empty, 1, 1)
+    | .cons h t =>
+      let result := Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)
+      .some (result, 1 + result.size, 1 + result.size)
+    | .head i =>
+      let result := stack[i].asList.headD Data.empty
+      .some (result, 1 + result.size, 1 + result.size)
+    | .tail i =>
+      let result := Data.l stack[i].asList.tail
+      .some (result, 1 + result.size, 1 + result.size)
+    | .eq i j => .some
+      (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse,
+      1 + (min (stack[i]'h_wf.1).size (stack[j]'h_wf.2).size),
+      1)
+    | .ite i then_ else_ =>
+      (if stack[i]'h_wf.1 == dataTrue then
+        meteredEvalProg then_ stack h_wf.2.1
+      else
+        meteredEvalProg else_ stack h_wf.2.2).map (fun (r, t, s) => (r, 1 + t, s))
+    | .fold list initial body => sorry
+    | .while_ i body => sorry
+
+
+  def meteredEvalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) :
+      Part (Data × ℕ × ℕ) :=
+    match prog with
+    | [] => .some (stack.head (by grind [WFProg]), 0, 0)
+    | op :: rest => do
+      let (r, opTime, opSpace) ← meteredEvalOp stack op h_wf.1
+      let (r, time, space) ← meteredEvalProg rest (r :: stack) h_wf.2
+      (r, opTime + time, opSpace + space)
+
+end
+
 @[simp]
 lemma evalProg_cons
     (op : Operation)
@@ -176,6 +224,9 @@ structure WellFormedProgram where
   inputs : ℕ
   h_wf : WFProg inputs prog
 
+--- The output stack size of the program.
+abbrev WellFormedProgram.stackSize (p : WellFormedProgram) : ℕ := p.inputs + p.prog.length
+
 def FunType (wf : WellFormedProgram) : Type :=
   let rec of_input_count := fun
     | 0 => Data
@@ -209,6 +260,64 @@ def prog_negate : WellFormedProgram := {
 lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
   simp [prog_true, evalOp]
 
+def WellFormedProgram.append (p1 p2 : WellFormedProgram) (h_le : p2.inputs ≤ p1.stackSize) :
+    WellFormedProgram :=
+  { prog := p1.prog ++ p2.prog
+    inputs := p1.inputs
+    h_wf := by sorry }
+
+class DataEncode (α : Type) where
+  encode : α → Data
+  h_inj : encode.Injective
+
+instance : DataEncode Bool where
+  encode b := if b then dataTrue else dataFalse
+  h_inj := by intros a b h_eq; grind
+
+instance (α : Type) [DataEncode α] : DataEncode (List α) where
+  encode xs := Data.l (xs.map DataEncode.encode)
+  h_inj := by sorry
+
+instance (α : Type) [DataEncode α] : DataEncode (Option α) where
+  encode := fun
+    | none => Data.l []
+    | some x => Data.l [DataEncode.encode x]
+  h_inj := by sorry
+
+instance : DataEncode ℕ where
+  encode x := DataEncode.encode (Nat.bits x)
+  h_inj := by sorry
+
+-- Binary addition
+def prog_add : WellFormedProgram := {
+  prog := [
+    .fold 0 1 [
+      .cons 0 2, -- cons the bit to the accumulator
+      .ite 2 [ -- if the new accumulator is nonempty (the bit was 1)
+        .cons 1 2, -- add the carry from the previous bit
+        .empty -- else just put the carry (0 or 1) as the new accumulator
+      ] [
+         .cons 1 2 -- if the new bit is zero, we only get a carry if the previous carry was one
+      ]
+    ]
+    -- TODO
+  ],
+  inputs := 2,
+  h_wf := by sorry
+}
+
+def add (x y : List Bool) : List Bool :=
+
+  match prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl with
+  | .some d => d.asList.map (fun b => b == dataTrue)
+  | .none => [] -- this should never happen since the program is total
+
+theorem prog_add_semantics : ∀ (x y : ℕ),
+    prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl =
+      .some (DataEncode.encode (x + y)) := by
+  sorry
+
+
 mutual
   def WhileFreeOp : Operation → Prop
     | .while_ _ _ => False

From 302bcac1b764c546488de027fd8c8d5b8623c0dd Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 15 May 2026 13:01:20 +0200
Subject: [PATCH 031/106] try to prove reverse.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 157 ++++++++++--------
 1 file changed, 92 insertions(+), 65 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 87ae5bb5ac..114ba3c766 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -74,9 +74,12 @@ inductive Operation where
   -- branch on tape i: if empty then then_ else else_
   | ite    : TapeIndex → (List Operation) → (List Operation) → Operation
   -- fold over the children of tape l with initial accumulator tape i and body program b
-  | fold   : TapeIndex → TapeIndex → (List Operation) → Operation
+  | fold   : (List Operation) → TapeIndex → TapeIndex → Operation
   -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
   | while_ : TapeIndex → (List Operation) → Operation
+  -- call executes a sub-program and returns its stack top. This is not strictly needed, but
+  -- makes it easier to write programs.
+  | call : (List Operation) → Operation
 deriving Repr
 
 abbrev Prog := List Operation
@@ -92,8 +95,9 @@ mutual
     | .tail i     => i < n
     | .eq i j     => i < n ∧ j < n
     | .ite i t e  => i < n ∧ WFProg n t ∧ WFProg n e
-    | .fold l i b => l < n ∧ i < n ∧ WFProg (n + 2) b
+    | .fold b i l => l < n ∧ i < n ∧ WFProg (n + 2) b
     | .while_ i b => i < n ∧ WFProg (n + 1) b
+    | .call b => WFProg n b
 
   /-- `WFProg n p` states that `p` is well-formed given an initial stack of size `n`.
       Since each operation pushes exactly one value, the k-th operation (0-indexed) sees
@@ -121,55 +125,6 @@ end
 abbrev dataTrue := Data.l [Data.l []]
 abbrev dataFalse := Data.l []
 
-structure InterpreterState where
-  stack : List Data
-  time : ℕ
-  space : ℕ
-
--- Interpreter:
--- It returns Part.none if the program does not terminate and Part.some Option.none if the
--- program is not well-formed.
-mutual
-  def evalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op)
-      : Part Data := match op with
-    | .empty => .some Data.empty
-    | .cons h t => .some (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList))
-    | .head i => .some (stack[i].asList.headD Data.empty)
-    | .tail i => .some (Data.l stack[i].asList.tail)
-    | .eq i j => .some (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse)
-    | .ite i then_ else_ =>
-      if stack[i]'h_wf.1 == dataTrue then
-        evalProg then_ stack h_wf.2.1
-      else
-        evalProg else_ stack h_wf.2.2
-    | .fold list initial body =>
-      goFold (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) stack body h_wf.2.2
-    | .while_ i body =>
-        -- recurse as long as the head of the returned value is true (the rest is used
-        -- to pass data across iterations).
-        let F := fun rec d =>
-          (evalProg body (d :: stack) h_wf.2).bind fun d =>
-            if d.asList.head? == dataTrue then rec d else Data.l d.asList.tail
-        Part.fix F (stack[i]'h_wf.1)
-
-  def goFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog)
-      (h_wf : WFProg (stack.length + 2) body) : Part Data :=
-    match items with
-    | []      => .some acc
-    | c :: cs =>
-      -- Put the item and the accumulator on two new tapes and run the program.
-      -- take the contents of the last tape as the result / new accumulator.
-      (evalProg body (c :: acc :: stack) h_wf).bind fun acc' => goFold cs acc' stack body h_wf
-
-  @[simp]
-  def evalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) : Part Data :=
-    match prog with
-      | []           => .some (stack.head (by grind [WFProg]))
-      | op :: rest   =>
-        let ⟨h_wf_head, h_wf_tail⟩ := h_wf
-        (evalOp stack op h_wf_head).bind fun r => evalProg rest (r :: stack) h_wf_tail
-end
-
 mutual
   --- Evaluate a single operation and return the return value, additional time and additional space.
   def meteredEvalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op) :
@@ -194,10 +149,38 @@ mutual
         meteredEvalProg then_ stack h_wf.2.1
       else
         meteredEvalProg else_ stack h_wf.2.2).map (fun (r, t, s) => (r, 1 + t, s))
-    | .fold list initial body => sorry
-    | .while_ i body => sorry
-
+    | .fold body initial list =>
+      -- Time: 1 + Σ_iterations (1 + body_time).
+      -- Space: init.size + max_iterations(body_space).
+      (goMeteredFold (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) stack body h_wf.2.2)
+    | .while_ i body =>
+      -- Same accounting as fold: time sums per-iteration costs (each iteration adds 1 + body_time);
+      -- space is init.size plus the max body space across iterations.
+      let init := stack[i]'h_wf.1
+      let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
+              (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
+        fun rec d_ts =>
+          let (d, t, s) := d_ts
+          (meteredEvalProg body (d :: stack) h_wf.2).bind fun (d', tBody, sBody) =>
+            let t' := t + 1 + tBody
+            let s' := max s sBody
+            if d'.asList.head? == .some dataTrue then rec (d', t', s')
+            else .some (Data.l d'.asList.tail, t', s')
+      (Part.fix F (init, 0, 0)).map fun (r, t, s) => (r, 1 + t, init.size + s)
+    | .call body => meteredEvalProg body stack h_wf
+
+  /-- Metered analogue of `goFold`: walks the items, threading the accumulator and accumulating
+      `(sum of (1 + body_time), max of body_space)` across iterations. -/
+  def goMeteredFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog)
+      (h_wf : WFProg (stack.length + 2) body) : Part (Data × ℕ × ℕ) :=
+    match items with
+    | []      => .some (acc, acc.size, acc.size)
+    | c :: cs =>
+      (meteredEvalProg body (c :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
+        (goMeteredFold cs acc' stack body h_wf).map fun (r, t, s) =>
+          (r, 1 + tBody + t, max sBody s)
 
+  @[simp]
   def meteredEvalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) :
       Part (Data × ℕ × ℕ) :=
     match prog with
@@ -210,14 +193,18 @@ mutual
 end
 
 @[simp]
-lemma evalProg_cons
-    (op : Operation)
-    (rest : Prog)
-    (stack : List Data)
-    (h_wf : WFProg stack.length (op :: rest)) :
-    evalProg (op :: rest) stack h_wf =
-      (evalOp stack op h_wf.1).bind fun r => evalProg rest (r :: stack) h_wf.2 := by
-  sorry
+lemma goMeteredFold_nil (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body) :
+    goMeteredFold [] acc stack body h_wf = .some (acc, acc.size, acc.size) := by
+  simp [goMeteredFold]
+
+@[simp]
+lemma goMeteredFold_cons (head : Data) (tail : List Data) (acc : Data) (stack : List Data)
+    (h_wf : WFProg (stack.length + 2) body) :
+    goMeteredFold (head :: tail) acc stack body h_wf =
+      (meteredEvalProg body (head :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
+        (goMeteredFold tail acc' stack body h_wf).map fun (r, t, s) =>
+          (r, 1 + tBody + t, max sBody s) := by
+  simp [goMeteredFold]
 
 structure WellFormedProgram where
   prog : Prog
@@ -236,7 +223,17 @@ def FunType (wf : WellFormedProgram) : Type :=
 @[simp]
 def WellFormedProgram.eval (p : WellFormedProgram)
     (stack : List Data) (h_len : stack.length = p.inputs) : Part Data :=
-  evalProg p.prog stack (by simpa [h_len] using p.h_wf)
+  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (d, _, _) => d
+
+@[simp]
+def WellFormedProgram.time (p : WellFormedProgram)
+    (stack : List Data) (h_len : stack.length = p.inputs) : Part ℕ :=
+  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, t, _) => t
+
+@[simp]
+def WellFormedProgram.space (p : WellFormedProgram)
+    (stack : List Data) (h_len : stack.length = p.inputs) : Part ℕ :=
+  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
 
 def WellFormedProgram.Total (p : WellFormedProgram) : Prop :=
   ∀ (stack : List Data) (h_len : stack.length = p.inputs), (p.eval stack h_len).Dom
@@ -258,7 +255,13 @@ def prog_negate : WellFormedProgram := {
   h_wf := by simp [WFProg, WFOp]
 }
 lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
-  simp [prog_true, evalOp]
+  simp [prog_true, meteredEvalOp]
+
+lemma prog_true.space : prog_true.space [] rfl = .some 6 := by
+  simp [prog_true, meteredEvalOp, Data.size]
+
+lemma prog_true.time : prog_true.time [] rfl = .some 6 := by
+  simp [prog_true, meteredEvalOp, Data.size]
 
 def WellFormedProgram.append (p1 p2 : WellFormedProgram) (h_le : p2.inputs ≤ p1.stackSize) :
     WellFormedProgram :=
@@ -288,8 +291,32 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
+
+def prog_reverse : WellFormedProgram := {
+  prog := [
+    .empty,
+    .fold [
+      .cons 0 1
+    ] 0 1
+  ],
+  inputs := 1,
+  h_wf := by simp [WFProg, WFOp]
+}
+
+theorem prog_reverse.semantics (xs : List Data) :
+    prog_reverse.eval [Data.l xs] rfl = .some (Data.l xs.reverse) := by
+  unfold prog_reverse
+  induction xs with
+  | nil => simp [meteredEvalOp]
+  | cons x xs ih =>
+    simp
+    simp at ih
+    simp [meteredEvalOp] at ih ⊢
+    simp [ih, List.reverse_cons]
+    sorry
+
 -- Binary addition
-def prog_add : WellFormedProgram := {
+def prog_inc : WellFormedProgram := {
   prog := [
     .fold 0 1 [
       .cons 0 2, -- cons the bit to the accumulator

From 2397904f0ac9d2a60017a7ae3d2197737bc95909 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 15 May 2026 14:09:01 +0200
Subject: [PATCH 032/106] RunsInSpace

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 181 ++++++++++++++----
 1 file changed, 142 insertions(+), 39 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 114ba3c766..ad0f199b16 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -206,52 +206,50 @@ lemma goMeteredFold_cons (head : Data) (tail : List Data) (acc : Data) (stack :
           (r, 1 + tBody + t, max sBody s) := by
   simp [goMeteredFold]
 
-structure WellFormedProgram where
+structure WellFormedProgram (inputs : ℕ) where
   prog : Prog
-  inputs : ℕ
   h_wf : WFProg inputs prog
 
 --- The output stack size of the program.
-abbrev WellFormedProgram.stackSize (p : WellFormedProgram) : ℕ := p.inputs + p.prog.length
+abbrev WellFormedProgram.stackSize {inputs : ℕ} (p : WellFormedProgram inputs) : ℕ := inputs + p.prog.length
 
-def FunType (wf : WellFormedProgram) : Type :=
-  let rec of_input_count := fun
-    | 0 => Data
-    | n + 1 => Data → of_input_count n
-  of_input_count wf.inputs
+def FunType (inputs : ℕ) : Type := match inputs with
+  | 0 => Data
+  | n + 1 => Data → FunType n
 
 @[simp]
-def WellFormedProgram.eval (p : WellFormedProgram)
-    (stack : List Data) (h_len : stack.length = p.inputs) : Part Data :=
+def WellFormedProgram.eval {inputs : ℕ} (p : WellFormedProgram inputs)
+    (stack : List Data) (h_len : stack.length = inputs) : Part Data :=
   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (d, _, _) => d
 
 @[simp]
-def WellFormedProgram.time (p : WellFormedProgram)
-    (stack : List Data) (h_len : stack.length = p.inputs) : Part ℕ :=
+def WellFormedProgram.time {inputs : ℕ} (p : WellFormedProgram inputs)
+    (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, t, _) => t
 
 @[simp]
-def WellFormedProgram.space (p : WellFormedProgram)
-    (stack : List Data) (h_len : stack.length = p.inputs) : Part ℕ :=
+def WellFormedProgram.space {inputs : ℕ} (p : WellFormedProgram inputs)
+    (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
 
-def WellFormedProgram.Total (p : WellFormedProgram) : Prop :=
-  ∀ (stack : List Data) (h_len : stack.length = p.inputs), (p.eval stack h_len).Dom
+def WellFormedProgram.Total {inputs : ℕ} (p : WellFormedProgram inputs) : Prop :=
+  ∀ (stack : List Data) (h_len : stack.length = inputs), (p.eval stack h_len).Dom
+
+def WellFormedProgram.as_fun {inputs : ℕ} (p : WellFormedProgram inputs) (h_total : p.Total) :
+    FunType inputs :=
+  sorry
 
 -- examples:
-def prog_true : WellFormedProgram := {
+def prog_true : WellFormedProgram 0 := {
   prog := [.empty, .cons 0 0],
-  inputs := 0,
   h_wf := by simp [WFProg, WFOp]
 }
-def prog_false : WellFormedProgram := {
+def prog_false : WellFormedProgram 0 := {
   prog := [.empty],
-  inputs := 0,
   h_wf := by simp [WFProg, WFOp]
 }
-def prog_negate : WellFormedProgram := {
+def prog_negate : WellFormedProgram 1 := {
   prog := [.eq 0 0],
-  inputs := 1,
   h_wf := by simp [WFProg, WFOp]
 }
 lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
@@ -263,11 +261,10 @@ lemma prog_true.space : prog_true.space [] rfl = .some 6 := by
 lemma prog_true.time : prog_true.time [] rfl = .some 6 := by
   simp [prog_true, meteredEvalOp, Data.size]
 
-def WellFormedProgram.append (p1 p2 : WellFormedProgram) (h_le : p2.inputs ≤ p1.stackSize) :
-    WellFormedProgram :=
-  { prog := p1.prog ++ p2.prog
-    inputs := p1.inputs
-    h_wf := by sorry }
+def WellFormedProgram.append {in₁ in₁ : ℕ}
+    (p₁ : WellFormedProgram in₁) (p₂ : WellFormedProgram in₂) (h_le : in₂ ≤ p₁.stackSize) :
+    WellFormedProgram in₁ :=
+  { prog := p₁.prog ++ p₂.prog, h_wf := by sorry }
 
 class DataEncode (α : Type) where
   encode : α → Data
@@ -291,29 +288,135 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
-
-def prog_reverse : WellFormedProgram := {
+def RunsInSpace {inputs : ℕ} (p : WellFormedProgram inputs) (s : ℕ → ℕ) : Prop :=
+  ∃ s₁ s₂, ∀ x, (h_l : x.length = inputs) → ∃ s' ≤ s₁ * (s (Data.l x).size) + s₂,
+  p.space x h_l = .some s'
+
+def RunsInTime {inputs : ℕ} (p : WellFormedProgram inputs) (t : ℕ → ℕ) : Prop :=
+  ∃ t₁ t₂, ∀ x, (h_l : x.length = inputs) → ∃ t' ≤ t₁ * (t (Data.l x).size) + t₂,
+  p.time x h_l = .some t'
+
+def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β]
+  (p : WellFormedProgram 1) (f : α → β) (t s : ℕ → ℕ) : Prop :=
+  ∃ t₁ t₂ s₁ s₂,
+    (∀ x : α, p.eval [DataEncode.encode x] rfl = .some (DataEncode.encode (f x))) ∧
+    (∀ x : α, ∃ t' ≤ t₁ * (t (DataEncode.encode x).size) + t₂,
+        p.time [DataEncode.encode x] rfl = .some t') ∧
+    (∀ x : α, ∃ s' ≤ s₁ * (s (DataEncode.encode x).size) + s₂,
+        p.space [DataEncode.encode x] sorry = .some s')
+
+def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
+  (f : α → β) (t s : ℕ → ℕ) : Prop :=
+  ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
+
+
+lemma fold_space_linear {s : ℕ → ℕ} {step : Data → Data → Data}
+    (hbody : ∀ (c acc : Data),
+      meteredEvalOp stack .fold  body (c :: acc :: stack) h_wf =
+        .some (step c acc, stepTime c acc, stepSpace c acc)) :
+    ∀ (xs : List Data) (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body),
+      goMeteredFold xs acc stack body h_wf =
+        .some (xs.foldl (fun a x => step x a) acc,
+               foldTime stepTime step xs acc,
+               foldSpace stepSpace step xs acc) := by
+  exact goMeteredFold_of_step hbody
+
+def prog_reverse : WellFormedProgram 1 := {
   prog := [
     .empty,
     .fold [
       .cons 0 1
     ] 0 1
   ],
-  inputs := 1,
   h_wf := by simp [WFProg, WFOp]
 }
 
+theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
+  : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)
+    (fun n => 1 + 2 * n + n * n) (fun n => 1 + 2 * n + n * n) := by
+  refine ⟨_, _, _, _, ?_⟩
+  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]; use 1 + 2 * xs.size + xs.size * xs.size; omega
+  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]; use 1 + 2 * xs.size + xs.size * xs.size; omega
+
+/-- Generic time cost of a metered fold whose body acts as a pure step
+    `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
+def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
+    : List Data → Data → ℕ
+  | [],      acc => acc.size
+  | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
+
+/-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
+def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
+    : List Data → Data → ℕ
+  | [],      acc => acc.size
+  | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
+
+/-- Generic semantics + time + space for any well-formed fold body that acts as a pure
+    deterministic step.
+
+    The hypothesis `hbody` must hold for every iteration: running `body` on a stack of the
+    form `c :: acc :: stack` (for any `c, acc`) produces `step c acc` with cost
+    `(stepTime c acc, stepSpace c acc)`. -/
+lemma goMeteredFold_of_step {body : Prog} {stack : List Data}
+    (h_wf : WFProg (stack.length + 2) body)
+    (step : Data → Data → Data) (stepTime stepSpace : Data → Data → ℕ)
+    (hbody : ∀ (c acc : Data),
+      meteredEvalProg body (c :: acc :: stack) h_wf =
+        .some (step c acc, stepTime c acc, stepSpace c acc))
+    (xs : List Data) (acc : Data) :
+    goMeteredFold xs acc stack body h_wf =
+      .some (xs.foldl (fun a x => step x a) acc,
+             foldTime stepTime step xs acc,
+             foldSpace stepSpace step xs acc) := by
+  induction xs generalizing acc with
+  | nil => simp [foldTime, foldSpace]
+  | cons x xs ih => simp [hbody, ih, foldTime, foldSpace]
+
+/-- Time cost of running the body `[.cons 0 1]` repeatedly over `xs`, threading `acc`. -/
+def revFoldTime (xs : List Data) (acc : Data) : ℕ :=
+  foldTime (fun x a => 1 + (Data.l (x :: a.asList)).size)
+           (fun x a => Data.l (x :: a.asList)) xs acc
+
+/-- Space cost of the same fold: maximum live size across iterations. -/
+def revFoldSpace (xs : List Data) (acc : Data) : ℕ :=
+  foldSpace (fun x a => 1 + (Data.l (x :: a.asList)).size)
+            (fun x a => Data.l (x :: a.asList)) xs acc
+
+/-- Combined semantics + time + space for the inner fold of `prog_reverse`. -/
+lemma goMeteredFold_reverseBody (xs : List Data) (acc : Data) (stack : List Data)
+    (h_wf : WFProg (stack.length + 2) [Operation.cons 0 1]) :
+    goMeteredFold xs acc stack [Operation.cons 0 1] h_wf =
+      .some (xs.foldl (fun a x => Data.l (x :: a.asList)) acc,
+             revFoldTime xs acc, revFoldSpace xs acc) := by
+  exact goMeteredFold_of_step h_wf
+    (fun x a => Data.l (x :: a.asList))
+    (fun x a => 1 + (Data.l (x :: a.asList)).size)
+    (fun x a => 1 + (Data.l (x :: a.asList)).size)
+    (by intro c acc'; simp [meteredEvalOp]) xs acc
+
+/-- The reverse-body fold reverses the input list, prepended onto the accumulator. -/
+lemma foldl_reverseBody (xs : List Data) (acc : Data) :
+    xs.foldl (fun a x => Data.l (x :: a.asList)) acc =
+      Data.l (xs.reverse ++ acc.asList) := by
+  induction xs generalizing acc with
+  | nil => cases acc with | l _ => simp [Data.asList]
+  | cons x xs ih => cases acc with | l _ => simp [ih, Data.asList, List.reverse_cons]
+
+/-- `prog_reverse` reverses its input list, with concrete time and space cost. -/
 theorem prog_reverse.semantics (xs : List Data) :
+    meteredEvalProg prog_reverse.prog [Data.l xs] prog_reverse.h_wf
+      = .some (Data.l xs.reverse,
+               1 + revFoldTime xs Data.empty,
+               1 + revFoldSpace xs Data.empty) := by
+  have h := goMeteredFold_reverseBody xs Data.empty [Data.empty, Data.l xs]
+    (by simp [WFProg, WFOp])
+  simp [prog_reverse, meteredEvalOp, h, foldl_reverseBody, Data.asList]
+
+/-- Convenient corollary: `prog_reverse.eval` returns the reversed list. -/
+theorem prog_reverse.eval_eq (xs : List Data) :
     prog_reverse.eval [Data.l xs] rfl = .some (Data.l xs.reverse) := by
-  unfold prog_reverse
-  induction xs with
-  | nil => simp [meteredEvalOp]
-  | cons x xs ih =>
-    simp
-    simp at ih
-    simp [meteredEvalOp] at ih ⊢
-    simp [ih, List.reverse_cons]
-    sorry
+  simp [WellFormedProgram.eval, prog_reverse.semantics]
 
 -- Binary addition
 def prog_inc : WellFormedProgram := {

From dc316b2cfd8eadb53f1d4adff26705b1537d0ee1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 15 May 2026 15:05:12 +0200
Subject: [PATCH 033/106] foldspace

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 70 ++++++++++++++++---
 1 file changed, 59 insertions(+), 11 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index ad0f199b16..32a6cbb7be 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -310,17 +310,6 @@ def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
   ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
 
 
-lemma fold_space_linear {s : ℕ → ℕ} {step : Data → Data → Data}
-    (hbody : ∀ (c acc : Data),
-      meteredEvalOp stack .fold  body (c :: acc :: stack) h_wf =
-        .some (step c acc, stepTime c acc, stepSpace c acc)) :
-    ∀ (xs : List Data) (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body),
-      goMeteredFold xs acc stack body h_wf =
-        .some (xs.foldl (fun a x => step x a) acc,
-               foldTime stepTime step xs acc,
-               foldSpace stepSpace step xs acc) := by
-  exact goMeteredFold_of_step hbody
-
 def prog_reverse : WellFormedProgram 1 := {
   prog := [
     .empty,
@@ -352,6 +341,65 @@ def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data
   | [],      acc => acc.size
   | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
 
+/-- Generic space bound for `foldSpace` via a single budget `B`:
+    if `init.size ≤ B`, and for every reachable accumulator each iteration's per-step
+    space and the resulting accumulator both stay within `B`, then the entire fold's
+    space is at most `B`. -/
+lemma foldSpace_le {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
+    (B : ℕ) (xs : List Data) (init : Data) (hInit : init.size ≤ B)
+    (hStep : ∀ acc c, acc.size ≤ B → c ∈ xs →
+                stepSpace c acc ≤ B ∧ (step c acc).size ≤ B) :
+    foldSpace stepSpace step xs init ≤ B := by
+  induction xs generalizing init with
+  | nil => simpa [foldSpace] using hInit
+  | cons x xs ih =>
+    have ⟨hSp, hAcc⟩ := hStep init x hInit (List.mem_cons_self ..)
+    refine max_le hSp
+      (ih _ hAcc fun acc c hAcc' hc => hStep acc c hAcc' (List.mem_cons_of_mem _ hc))
+
+/-- Linear-space body + constant-size init ⟹ linear-space fold.
+
+    If every step costs space at most `s₁ * (c.size + acc.size) + s₂`, the accumulator
+    grows by at most `c.size + k` per item, and `init.size ≤ c₀`, then `foldSpace` is
+    linear in `(xs.map Data.size).sum + xs.length * k + c₀`. -/
+lemma fold_space_linear {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
+    {s₁ s₂ k c₀ : ℕ}
+    (hStepSpace : ∀ c acc, stepSpace c acc ≤ s₁ * (c.size + acc.size) + s₂)
+    (hGrowth : ∀ c acc, (step c acc).size ≤ acc.size + c.size + k)
+    (xs : List Data) (init : Data) (hInit : init.size ≤ c₀) :
+    foldSpace stepSpace step xs init ≤
+      max (c₀ + (xs.map Data.size).sum + xs.length * k)
+          (s₁ * ((xs.map Data.size).sum + c₀ + xs.length * k) + s₂) := by
+  -- Strengthen by allowing any starting bound `c₀'` on `init.size`.
+  suffices h : ∀ (xs : List Data) (init : Data) (c₀' : ℕ), init.size ≤ c₀' →
+      foldSpace stepSpace step xs init ≤
+        max (c₀' + (xs.map Data.size).sum + xs.length * k)
+            (s₁ * ((xs.map Data.size).sum + c₀' + xs.length * k) + s₂) from h xs init c₀ hInit
+  clear hInit init xs
+  intro xs
+  induction xs with
+  | nil => intro init c₀' hInit; simpa [foldSpace] using Or.inl (by omega)
+  | cons x xs ih =>
+    intro init c₀' hInit
+    have hStepSize : (step x init).size ≤ c₀' + x.size + k := by
+      have := hGrowth x init; omega
+    have ih' := ih (step x init) (c₀' + x.size + k) hStepSize
+    have hSp : stepSpace x init ≤
+        s₁ * (x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k) + s₂ := by
+      have := Nat.mul_le_mul_left s₁
+        (show x.size + init.size ≤ x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k by
+          omega)
+      have h1 := hStepSpace x init
+      omega
+    simp only [foldSpace, List.length_cons, List.map_cons, List.sum_cons]
+    refine max_le (le_trans hSp (le_max_right _ _)) (le_trans ih' (max_le_max ?_ ?_))
+    · have : (xs.length + 1) * k = xs.length * k + k := by ring
+      omega
+    · apply Nat.add_le_add_right
+      apply Nat.mul_le_mul_left
+      have : (xs.length + 1) * k = xs.length * k + k := by ring
+      omega
+
 /-- Generic semantics + time + space for any well-formed fold body that acts as a pure
     deterministic step.
 

From f6b54c6360f873c51f026bf39593e340f6b5bd4e Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 14:29:53 +0200
Subject: [PATCH 034/106] total eval functions

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 194 ++++++++++++++++--
 1 file changed, 177 insertions(+), 17 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 32a6cbb7be..734dc9bbcb 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -107,6 +107,10 @@ mutual
     | n, op :: rest => WFOp n op ∧ WFProg (n + 1) rest
 end
 
+lemma WFProg_mono {n₁ n₂ : ℕ} {prog : Prog} (h_wf : WFProg n₁ prog) (h_le : n₁ ≤ n₂) : WFProg n₂ prog := by
+  sorry
+
+
 -- One could define a monadic builder-pattern that handles tape index allocation:
 -- def filter (a : TapeIndex) (predicate : TapeIndex → Build TapeIndex) : Build TapeIndex := do
 --   fold a (← empty) (fun child acc => do
@@ -192,19 +196,94 @@ mutual
 
 end
 
+-- @[simp]
+-- lemma goMeteredFold_nil (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body) :
+--     goMeteredFold [] acc stack body h_wf = .some (acc, acc.size, acc.size) := by
+--   simp [goMeteredFold]
+
+-- @[simp]
+-- lemma goMeteredFold_cons (head : Data) (tail : List Data) (acc : Data) (stack : List Data)
+--     (h_wf : WFProg (stack.length + 2) body) :
+--     goMeteredFold (head :: tail) acc stack body h_wf =
+--       (meteredEvalProg body (head :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
+--         (goMeteredFold tail acc' stack body h_wf).map fun (r, t, s) =>
+--           (r, 1 + tBody + t, max sBody s) := by
+--   simp [goMeteredFold]
+
+def Op.Total (op : Operation) (h_wf : WFOp n op) : Prop :=
+  ∀ (stack : List Data) (h_len : stack.length = n),
+  (meteredEvalOp stack op (h_len ▸ h_wf)).Dom
+
+/-- A well-formed body is *total* at input length `n` if it terminates on every stack
+    of that length. This mirrors `WellFormedProgram.Total` but works on a raw `Prog`
+    paired with its well-formedness proof. -/
+def Prog.Total {n : ℕ} (body : Prog) (h_wf : WFProg n body) : Prop :=
+  ∀ (stack : List Data) (h_len : stack.length = n),
+    (meteredEvalProg body stack (h_len ▸ h_wf)).Dom
+
+mutual
+  @[simp]
+  def Operation.WhileFree (op : Operation) : Prop :=
+    match op with
+    | .while_ _ _ => False
+    | .fold b _ _ => Prog.WhileFree b
+    | _ => True
+  @[simp]
+  def Prog.WhileFree (body : Prog) : Prop :=
+    ∀ op ∈ body, Operation.WhileFree op
+end
+
 @[simp]
-lemma goMeteredFold_nil (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body) :
-    goMeteredFold [] acc stack body h_wf = .some (acc, acc.size, acc.size) := by
-  simp [goMeteredFold]
+theorem Total_of_WhileFree {n : ℕ} {body : Prog}
+    (h_wf : WFProg n body) (h_whileFree : Prog.WhileFree body) :
+    Prog.Total body h_wf := by
+  sorry
+
+def Operation.meteredEvalT (op : Operation) (stack : List Data) (h_wf : WFOp stack.length op)
+    (h_total : Op.Total op h_wf) : Data × ℕ × ℕ :=
+  (meteredEvalOp stack op h_wf).get (by simpa [Prog.Total] using h_total stack rfl)
+
+def Prog.meteredEvalT (body : Prog) (stack : List Data)
+    (h_wf : WFProg stack.length body)
+    (h_total : body.Total h_wf) : Data × ℕ × ℕ :=
+  (meteredEvalProg body stack h_wf).get (by simpa [Prog.Total] using h_total stack rfl)
+
 
 @[simp]
-lemma goMeteredFold_cons (head : Data) (tail : List Data) (acc : Data) (stack : List Data)
-    (h_wf : WFProg (stack.length + 2) body) :
-    goMeteredFold (head :: tail) acc stack body h_wf =
-      (meteredEvalProg body (head :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
-        (goMeteredFold tail acc' stack body h_wf).map fun (r, t, s) =>
-          (r, 1 + tBody + t, max sBody s) := by
-  simp [goMeteredFold]
+lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length .empty} {h_total : Op.Total .empty h_wf} :
+    Operation.meteredEvalT .empty stack h_wf h_total = (Data.empty, 1, 1) := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
+@[simp]
+lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
+    {h_wf : WFOp stack.length (.fold body initial list)} {h_total : Op.Total (.fold body initial list) h_wf} :
+    Operation.meteredEvalT (.fold body initial list) stack h_wf h_total =
+      (
+        List.foldl (fun a x => Prog.meteredEvalT body (a :: x :: stack) sorry sorry) (stack[initial]'h_wf.2.1) (stack[list]'h_wf.1).asList,
+        sorry,
+        sorry
+      )
+      := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
+@[simp]
+lemma Prog.meteredEvalT_nil
+    {stack : List Data}
+    {h_wf : WFProg stack.length []}
+    {h_total : Prog.Total [] h_wf} :
+    Prog.meteredEvalT [] stack h_wf h_total = (stack.head (by grind [WFProg]), 0, 0) := by
+  sorry
+
+@[simp]
+lemma Prog.meteredEvalT_cons
+    {op : Operation} {rest : Prog} {stack : List Data}
+    {h_wf : WFProg stack.length (op :: rest)}
+    {h_total : Prog.Total (op :: rest) h_wf} :
+    Prog.meteredEvalT (op :: rest) stack h_wf h_total =
+      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 sorry
+      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 sorry
+      (stack, opT + t, opS + s) := by
+  sorry
 
 structure WellFormedProgram (inputs : ℕ) where
   prog : Prog
@@ -219,8 +298,8 @@ def FunType (inputs : ℕ) : Type := match inputs with
 
 @[simp]
 def WellFormedProgram.eval {inputs : ℕ} (p : WellFormedProgram inputs)
-    (stack : List Data) (h_len : stack.length = inputs) : Part Data :=
-  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (d, _, _) => d
+    (stack : List Data) (h_len : stack.length ≥ inputs) : Part Data :=
+  (meteredEvalProg p.prog stack (by sorry)).map fun (d, _, _) => d
 
 @[simp]
 def WellFormedProgram.time {inputs : ℕ} (p : WellFormedProgram inputs)
@@ -232,10 +311,26 @@ def WellFormedProgram.space {inputs : ℕ} (p : WellFormedProgram inputs)
     (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
 
-def WellFormedProgram.Total {inputs : ℕ} (p : WellFormedProgram inputs) : Prop :=
-  ∀ (stack : List Data) (h_len : stack.length = inputs), (p.eval stack h_len).Dom
+structure TotalProgram (inputs : ℕ) extends WellFormedProgram inputs where
+  h_total : toWellFormedProgram.prog.Total toWellFormedProgram.h_wf
+
+def TotalProgram.eval {inputs : ℕ} (p : TotalProgram inputs)
+    (stack : List Data) (h_len : stack.length ≥ inputs) : Data :=
+  (p.toWellFormedProgram.eval stack h_len).get (p.h_total stack sorry)
 
-def WellFormedProgram.as_fun {inputs : ℕ} (p : WellFormedProgram inputs) (h_total : p.Total) :
+/-- Unfolding lemma that lets `simp` "execute" a `TotalProgram` step-by-step: it
+    rewrites `p.eval stack h_len` into a form mentioning `meteredEvalProg` directly,
+    so the `@[simp]` equations for `meteredEvalProg`/`meteredEvalOp` together with
+    `Part.some_bind`, `Part.map_some`, `Part.get_some` can reduce the program. -/
+@[simp]
+theorem TotalProgram.eval_eq {inputs : ℕ} (p : TotalProgram inputs)
+    (stack : List Data) (h_len : stack.length ≥ inputs) :
+    p.eval stack h_len =
+      ((meteredEvalProg p.prog stack (by sorry)).get
+         (by simpa [WellFormedProgram.eval] using p.h_total stack sorry)).1 := by
+  simp [TotalProgram.eval, WellFormedProgram.eval]
+
+def TotalProgram.as_fun {inputs : ℕ} (p : TotalProgram inputs) :
     FunType inputs :=
   sorry
 
@@ -299,7 +394,7 @@ def RunsInTime {inputs : ℕ} (p : WellFormedProgram inputs) (t : ℕ → ℕ) :
 def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β]
   (p : WellFormedProgram 1) (f : α → β) (t s : ℕ → ℕ) : Prop :=
   ∃ t₁ t₂ s₁ s₂,
-    (∀ x : α, p.eval [DataEncode.encode x] rfl = .some (DataEncode.encode (f x))) ∧
+    (∀ x : α, p.eval [DataEncode.encode x] sorry = .some (DataEncode.encode (f x))) ∧
     (∀ x : α, ∃ t' ≤ t₁ * (t (DataEncode.encode x).size) + t₂,
         p.time [DataEncode.encode x] rfl = .some t') ∧
     (∀ x : α, ∃ s' ≤ s₁ * (s (DataEncode.encode x).size) + s₂,
@@ -310,7 +405,7 @@ def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
   ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
 
 
-def prog_reverse : WellFormedProgram 1 := {
+def prog_reverse : TotalProgram 1 := {
   prog := [
     .empty,
     .fold [
@@ -318,8 +413,73 @@ def prog_reverse : WellFormedProgram 1 := {
     ] 0 1
   ],
   h_wf := by simp [WFProg, WFOp]
+  h_total := by simp
 }
 
+-- TODO continue here: Now we need a good lemma for goMeteredFold.
+
+/-- The `(result, time, space)` triple produced by a single execution of a total fold
+    body on `c :: acc :: stack`. Derived from `meteredEvalProg`, so no extra data is
+    needed beyond the body, its well-formedness, and a totality witness. -/
+def Prog.foldStep {body : Prog} {stack : List Data}
+    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+    (c acc : Data) : Data × ℕ × ℕ :=
+  (meteredEvalProg body (c :: acc :: stack) h_wf).get
+    (h_total (c :: acc :: stack) (by simp))
+
+/-- Generic time cost of a metered fold whose body acts as a pure step
+    `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
+def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
+    : List Data → Data → ℕ
+  | [],      acc => acc.size
+  | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
+
+/-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
+def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
+    : List Data → Data → ℕ
+  | [],      acc => acc.size
+  | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
+
+lemma Prog.meteredEvalProg_eq_foldStep {body : Prog} {stack : List Data}
+    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+    (c acc : Data) :
+    meteredEvalProg body (c :: acc :: stack) h_wf =
+      .some (Prog.foldStep h_wf h_total c acc) :=
+  (Part.some_get _).symm
+
+/-- Simp form of `goMeteredFold_of_step`: a *total* body uniquely determines the fold
+    semantics, with no free `step`/`stepTime`/`stepSpace` variables for `simp` to
+    invent. The data result is exactly `List.foldl` over `Prog.foldStep`. -/
+@[simp]
+lemma goMeteredFold_of_total {body : Prog} {stack : List Data}
+    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+    (xs : List Data) (acc : Data) :
+    goMeteredFold xs acc stack body h_wf = .some
+      (xs.foldl (fun a x => (Prog.foldStep h_wf h_total x a).1) acc,
+       foldTime (fun c a => (Prog.foldStep h_wf h_total c a).2.1)
+                (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc,
+       foldSpace (fun c a => (Prog.foldStep h_wf h_total c a).2.2)
+                 (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc) := by
+  induction xs generalizing acc with
+  | nil => simp [foldTime, foldSpace, goMeteredFold]
+  | cons x xs ih =>
+    simp [ih, foldTime, foldSpace, goMeteredFold]
+    rw [Prog.meteredEvalProg_eq_foldStep h_wf h_total]
+    simp_all
+
+-- TODO: summary of current problems: We canont re-write the stuff inside a
+-- `Part.bind` because that would change the type (although it is equal)
+-- Solution: Get rid of Part
+
+lemma prog_reverse.semantics (x : Data) (xs : List Data) :
+    (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp; sorry)).1 = Data.l (x.asList).reverse := by
+  unfold prog_reverse
+  simp
+  rw [goMeteredFold_of_total _ _ x.asList Data.empty]
+
+
+  simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+
 theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
   : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)
     (fun n => 1 + 2 * n + n * n) (fun n => 1 + 2 * n + n * n) := by

From fa7b411489aaca2855f5ab05caaced1680e39a53 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 16:17:47 +0200
Subject: [PATCH 035/106] more simp

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 28 ++++++++++++++-----
 1 file changed, 21 insertions(+), 7 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 734dc9bbcb..c2d1b470c5 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -254,17 +254,32 @@ lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length
     Operation.meteredEvalT .empty stack h_wf h_total = (Data.empty, 1, 1) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
+@[simp]
+lemma Operation.meteredEvalT_cons
+    {stack : List Data}
+    {h_wf : WFOp stack.length (.cons h t)}
+    {h_total : Op.Total (.cons h t) h_wf} :
+    Operation.meteredEvalT (.cons h t) stack h_wf h_total =
+      (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList),
+      1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size,
+      1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
 @[simp]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
-    {h_wf : WFOp stack.length (.fold body initial list)} {h_total : Op.Total (.fold body initial list) h_wf} :
+    {h_wf : WFOp stack.length (.fold body initial list)}
+    {h_total : Op.Total (.fold body initial list) h_wf}
+    (h_body_total : body.Total h_wf.2.2) :
     Operation.meteredEvalT (.fold body initial list) stack h_wf h_total =
       (
-        List.foldl (fun a x => Prog.meteredEvalT body (a :: x :: stack) sorry sorry) (stack[initial]'h_wf.2.1) (stack[list]'h_wf.1).asList,
+        List.foldl
+          (fun a x => (Prog.meteredEvalT body (x :: a :: stack) h_wf.2.2 h_body_total).1)
+          (stack[initial]'h_wf.2.1) (stack[list]'h_wf.1).asList,
         sorry,
         sorry
       )
       := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
+  sorry
 
 @[simp]
 lemma Prog.meteredEvalT_nil
@@ -475,10 +490,9 @@ lemma prog_reverse.semantics (x : Data) (xs : List Data) :
     (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp; sorry)).1 = Data.l (x.asList).reverse := by
   unfold prog_reverse
   simp
-  rw [goMeteredFold_of_total _ _ x.asList Data.empty]
-
-
-  simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+  rw [Operation.meteredEvalT_fold (by simp)]
+  simp
+  sorry
 
 theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
   : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)

From f58b8fa89946ace821e0eecc76009a6613bcb489 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 17:15:34 +0200
Subject: [PATCH 036/106] prove prog_reverse.semantics.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 86 ++++++++++++-------
 1 file changed, 56 insertions(+), 30 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index c2d1b470c5..de8b87e3c1 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -43,6 +43,12 @@ abbrev Data.empty := Data.l []
 abbrev Data.asList
   | Data.l xs => xs
 
+@[simp]
+lemma Data.asList_empty : Data.empty.asList = [] := by simp [Data.empty]
+
+@[simp]
+lemma Data.asList_l : Data.l xs.asList = xs := by grind
+
 --- Encoding length of d.
 def Data.size : Data → ℕ
   | Data.l xs => 2 + (xs.map Data.size |>.sum)
@@ -210,7 +216,7 @@ end
 --           (r, 1 + tBody + t, max sBody s) := by
 --   simp [goMeteredFold]
 
-def Op.Total (op : Operation) (h_wf : WFOp n op) : Prop :=
+def Operation.Total (op : Operation) (h_wf : WFOp n op) : Prop :=
   ∀ (stack : List Data) (h_len : stack.length = n),
   (meteredEvalOp stack op (h_len ▸ h_wf)).Dom
 
@@ -225,41 +231,60 @@ mutual
   @[simp]
   def Operation.WhileFree (op : Operation) : Prop :=
     match op with
+    | .ite _ a b => Prog.WhileFree a ∧ Prog.WhileFree b
     | .while_ _ _ => False
     | .fold b _ _ => Prog.WhileFree b
+    | .call p => Prog.WhileFree p
     | _ => True
   @[simp]
   def Prog.WhileFree (body : Prog) : Prop :=
-    ∀ op ∈ body, Operation.WhileFree op
+    match body with
+    | [] => True
+    | op :: rest => Operation.WhileFree op ∧ Prog.WhileFree rest
 end
 
 @[simp]
-theorem Total_of_WhileFree {n : ℕ} {body : Prog}
+theorem Prog_total_of_WhileFree {n : ℕ} {body : Prog}
     (h_wf : WFProg n body) (h_whileFree : Prog.WhileFree body) :
     Prog.Total body h_wf := by
   sorry
 
+@[simp]
+theorem Op_total_of_WhileFree {n : ℕ} {op : Operation}
+    (h_wf : WFOp n op) (h_whileFree : Operation.WhileFree op) :
+    Operation.Total op h_wf := by
+  sorry
+
+@[simp]
+theorem Dom_meteredEvalOp_of_WhileFree {op : Operation} {stack : List Data}
+    (h_wf : WFOp stack.length op) (h_whf : Operation.WhileFree op) :
+    (meteredEvalOp stack op h_wf).Dom :=
+  Op_total_of_WhileFree h_wf h_whf stack rfl
+
+-- We now introduce some simplification lemmas. Because of the dependent types involed
+-- in Part and for other reasons, we only do this for while-free programs.
+-- It is not sufficient for a program to be total, because this does not imply that all
+-- sub-programs are total, which is what we would need for simp lemmas to be clearly statable.
+
 def Operation.meteredEvalT (op : Operation) (stack : List Data) (h_wf : WFOp stack.length op)
-    (h_total : Op.Total op h_wf) : Data × ℕ × ℕ :=
-  (meteredEvalOp stack op h_wf).get (by simpa [Prog.Total] using h_total stack rfl)
+    (h_whf : Operation.WhileFree op) : Data × ℕ × ℕ :=
+  (meteredEvalOp stack op h_wf).get (by simp [h_whf])
 
 def Prog.meteredEvalT (body : Prog) (stack : List Data)
     (h_wf : WFProg stack.length body)
-    (h_total : body.Total h_wf) : Data × ℕ × ℕ :=
-  (meteredEvalProg body stack h_wf).get (by simpa [Prog.Total] using h_total stack rfl)
-
+    (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
+  (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree h_wf h_whf stack rfl)
 
 @[simp]
-lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length .empty} {h_total : Op.Total .empty h_wf} :
-    Operation.meteredEvalT .empty stack h_wf h_total = (Data.empty, 1, 1) := by
+lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length .empty} :
+    Operation.meteredEvalT .empty stack h_wf (by simp) = (Data.empty, 1, 1) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
 @[simp]
 lemma Operation.meteredEvalT_cons
     {stack : List Data}
-    {h_wf : WFOp stack.length (.cons h t)}
-    {h_total : Op.Total (.cons h t) h_wf} :
-    Operation.meteredEvalT (.cons h t) stack h_wf h_total =
+    {h_wf : WFOp stack.length (.cons h t)} :
+    Operation.meteredEvalT (.cons h t) stack h_wf (by simp) =
       (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList),
       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size,
       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
@@ -268,12 +293,12 @@ lemma Operation.meteredEvalT_cons
 @[simp]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
     {h_wf : WFOp stack.length (.fold body initial list)}
-    {h_total : Op.Total (.fold body initial list) h_wf}
+    {h_whf : Operation.WhileFree (.fold body initial list)}
     (h_body_total : body.Total h_wf.2.2) :
-    Operation.meteredEvalT (.fold body initial list) stack h_wf h_total =
+    Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
       (
         List.foldl
-          (fun a x => (Prog.meteredEvalT body (x :: a :: stack) h_wf.2.2 h_body_total).1)
+          (fun a x => (Prog.meteredEvalT body (x :: a :: stack) h_wf.2.2 (by simpa using h_whf)).1)
           (stack[initial]'h_wf.2.1) (stack[list]'h_wf.1).asList,
         sorry,
         sorry
@@ -284,19 +309,18 @@ lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stac
 @[simp]
 lemma Prog.meteredEvalT_nil
     {stack : List Data}
-    {h_wf : WFProg stack.length []}
-    {h_total : Prog.Total [] h_wf} :
-    Prog.meteredEvalT [] stack h_wf h_total = (stack.head (by grind [WFProg]), 0, 0) := by
-  sorry
+    {h_wf : WFProg stack.length []} :
+    Prog.meteredEvalT [] stack h_wf (by simp) = (stack.head (by grind [WFProg]), 0, 0) := by
+  simp [Prog.meteredEvalT]
 
 @[simp]
 lemma Prog.meteredEvalT_cons
     {op : Operation} {rest : Prog} {stack : List Data}
     {h_wf : WFProg stack.length (op :: rest)}
-    {h_total : Prog.Total (op :: rest) h_wf} :
-    Prog.meteredEvalT (op :: rest) stack h_wf h_total =
-      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 sorry
-      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 sorry
+    {h_whf : Prog.WhileFree (op :: rest)} :
+    Prog.meteredEvalT (op :: rest) stack h_wf h_whf =
+      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 h_whf.1
+      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 h_whf.2
       (stack, opT + t, opS + s) := by
   sorry
 
@@ -487,12 +511,14 @@ lemma goMeteredFold_of_total {body : Prog} {stack : List Data}
 -- Solution: Get rid of Part
 
 lemma prog_reverse.semantics (x : Data) (xs : List Data) :
-    (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp; sorry)).1 = Data.l (x.asList).reverse := by
-  unfold prog_reverse
-  simp
-  rw [Operation.meteredEvalT_fold (by simp)]
-  simp
-  sorry
+    (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp [prog_reverse])).1 =
+      Data.l (x.asList).reverse := by
+  have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
+      Data.l (xs.reverse ++ init.asList) := by
+    induction xs generalizing init with
+    | nil => simp
+    | cons x xs ih => simp [List.foldl, ih]
+  simp [prog_reverse, h]
 
 theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
   : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)

From 508268d45438e54bbdc6fb9d4cb46ffdf29063e1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 17:21:01 +0200
Subject: [PATCH 037/106] cleanup

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 64 ++++++++-----------
 1 file changed, 28 insertions(+), 36 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index de8b87e3c1..3f3bc24655 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -113,25 +113,6 @@ mutual
     | n, op :: rest => WFOp n op ∧ WFProg (n + 1) rest
 end
 
-lemma WFProg_mono {n₁ n₂ : ℕ} {prog : Prog} (h_wf : WFProg n₁ prog) (h_le : n₁ ≤ n₂) : WFProg n₂ prog := by
-  sorry
-
-
--- One could define a monadic builder-pattern that handles tape index allocation:
--- def filter (a : TapeIndex) (predicate : TapeIndex → Build TapeIndex) : Build TapeIndex := do
---   fold a (← empty) (fun child acc => do
---     ite (← predicate child)
---       (cons child acc)
---       (return acc))
-
-
--- TODO define space measure:
--- elementary operations incur the size of their output as additional space
--- fold incurs space of init plus the max of the space of the step function
--- this is the crucial point that allows us to build space-efficient algorithms:
--- We implicitly overwrite the old accumulator value even though there is no
--- explicit "overwrite" or "free" operation.
-
 abbrev dataTrue := Data.l [Data.l []]
 abbrev dataFalse := Data.l []
 
@@ -202,27 +183,10 @@ mutual
 
 end
 
--- @[simp]
--- lemma goMeteredFold_nil (acc : Data) (stack : List Data) (h_wf : WFProg (stack.length + 2) body) :
---     goMeteredFold [] acc stack body h_wf = .some (acc, acc.size, acc.size) := by
---   simp [goMeteredFold]
-
--- @[simp]
--- lemma goMeteredFold_cons (head : Data) (tail : List Data) (acc : Data) (stack : List Data)
---     (h_wf : WFProg (stack.length + 2) body) :
---     goMeteredFold (head :: tail) acc stack body h_wf =
---       (meteredEvalProg body (head :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
---         (goMeteredFold tail acc' stack body h_wf).map fun (r, t, s) =>
---           (r, 1 + tBody + t, max sBody s) := by
---   simp [goMeteredFold]
-
 def Operation.Total (op : Operation) (h_wf : WFOp n op) : Prop :=
   ∀ (stack : List Data) (h_len : stack.length = n),
   (meteredEvalOp stack op (h_len ▸ h_wf)).Dom
 
-/-- A well-formed body is *total* at input length `n` if it terminates on every stack
-    of that length. This mirrors `WellFormedProgram.Total` but works on a raw `Prog`
-    paired with its well-formedness proof. -/
 def Prog.Total {n : ℕ} (body : Prog) (h_wf : WFProg n body) : Prop :=
   ∀ (stack : List Data) (h_len : stack.length = n),
     (meteredEvalProg body stack (h_len ▸ h_wf)).Dom
@@ -324,6 +288,34 @@ lemma Prog.meteredEvalT_cons
       (stack, opT + t, opS + s) := by
   sorry
 
+
+------------------------------------------------------------------------------
+-- Example program
+---------------------------------------------------------------------------
+
+def prog_reverse : Prog := [
+    .empty,
+    .fold [ .cons 0 1 ] 0 1
+  ]
+
+lemma prog_reverse.semantics (x : Data) (xs : List Data) :
+    (prog_reverse.meteredEvalT
+      (x :: xs)
+      (by simp [prog_reverse, WFProg, WFOp])
+      (by simp [prog_reverse])).1 =
+      Data.l (x.asList).reverse := by
+  have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
+      Data.l (xs.reverse ++ init.asList) := by
+    induction xs generalizing init with
+    | nil => simp
+    | cons x xs ih => simp [List.foldl, ih]
+  simp [prog_reverse, h]
+
+
+-----------------------------------------------------------------------------------------
+--- The stuff below here still needs some work
+-----------------------------------------------------------------------------
+
 structure WellFormedProgram (inputs : ℕ) where
   prog : Prog
   h_wf : WFProg inputs prog

From 35ca0daed3ddd3f79406757063f9699ff0a98838 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 17:36:55 +0200
Subject: [PATCH 038/106] full fold semantics.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 58 +++++++++++++------
 1 file changed, 39 insertions(+), 19 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 3f3bc24655..95814fce24 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -260,12 +260,27 @@ lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stac
     {h_whf : Operation.WhileFree (.fold body initial list)}
     (h_body_total : body.Total h_wf.2.2) :
     Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
-      (
-        List.foldl
-          (fun a x => (Prog.meteredEvalT body (x :: a :: stack) h_wf.2.2 (by simpa using h_whf)).1)
-          (stack[initial]'h_wf.2.1) (stack[list]'h_wf.1).asList,
-        sorry,
-        sorry
+      ( -- data: fold over accumulator
+        (stack[list]'h_wf.1).asList.foldl
+          (fun acc x => (Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+            (by simpa using h_whf)).1)
+          (stack[initial]'h_wf.2.1),
+        -- time: thread (acc, time), then add final acc size
+        (let (a', t) := (stack[list]'h_wf.1).asList.foldl
+            (fun (acc, t) x =>
+              let (r, t', _) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+                (by simpa using h_whf)
+              (r, t + 1 + t'))
+            (stack[initial]'h_wf.2.1, 0);
+          t + a'.size),
+        -- space: thread (acc, max-space), then max with final acc size
+        (let (a', s) := (stack[list]'h_wf.1).asList.foldl
+            (fun (acc, s) x =>
+              let (r, _, s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+                (by simpa using h_whf)
+              (r, max s s'))
+            (stack[initial]'h_wf.2.1, 0);
+          max s a'.size)
       )
       := by
   sorry
@@ -311,6 +326,24 @@ lemma prog_reverse.semantics (x : Data) (xs : List Data) :
     | cons x xs ih => simp [List.foldl, ih]
   simp [prog_reverse, h]
 
+lemma prog_reverse.time (x : Data) (xs : List Data) :
+    (prog_reverse.meteredEvalT
+      (x :: xs)
+      (by simp [prog_reverse, WFProg, WFOp])
+      (by simp [prog_reverse])).2 =
+      sorry := by
+  simp [prog_reverse]
+  sorry
+
+lemma prog_reverse.space (x : Data) (xs : List Data) :
+    (prog_reverse.meteredEvalT
+      (x :: xs)
+      (by simp [prog_reverse, WFProg, WFOp])
+      (by simp [prog_reverse])).2.1 =
+      sorry := by
+  simp [prog_reverse]
+  sorry
+
 
 -----------------------------------------------------------------------------------------
 --- The stuff below here still needs some work
@@ -458,19 +491,6 @@ def Prog.foldStep {body : Prog} {stack : List Data}
   (meteredEvalProg body (c :: acc :: stack) h_wf).get
     (h_total (c :: acc :: stack) (by simp))
 
-/-- Generic time cost of a metered fold whose body acts as a pure step
-    `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
-def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
-    : List Data → Data → ℕ
-  | [],      acc => acc.size
-  | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
-
-/-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
-def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
-    : List Data → Data → ℕ
-  | [],      acc => acc.size
-  | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
-
 lemma Prog.meteredEvalProg_eq_foldStep {body : Prog} {stack : List Data}
     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
     (c acc : Data) :

From 2ac3df5f618c969303e1c4d7238e175fd9ab73b0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 16 May 2026 22:28:28 +0200
Subject: [PATCH 039/106] examples

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 115 +++++++++++++++++-
 1 file changed, 110 insertions(+), 5 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 95814fce24..1f34543052 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -53,6 +53,14 @@ lemma Data.asList_l : Data.l xs.asList = xs := by grind
 def Data.size : Data → ℕ
   | Data.l xs => 2 + (xs.map Data.size |>.sum)
 
+@[simp]
+lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
+
+@[simp]
+lemma Data.cons_size {h : Data} {t : List Data} :
+    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
+  simp [Data.size, Nat.add_assoc, Nat.add_comm]
+
 abbrev TapeIndex := ℕ
 
 
@@ -285,6 +293,69 @@ lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stac
       := by
   sorry
 
+/-- Recursive form of the per-iteration accumulator threading used by `meteredEvalT_fold`.
+    Mirrors `goMeteredFold` directly, but on the `meteredEvalT` side: every body run
+    is a total `Data × ℕ × ℕ` (no `Part`). -/
+def Operation.foldRec (body : Prog) (stack : List Data)
+    (h_wf : WFProg (stack.length + 2) body)
+    (h_whf : Prog.WhileFree body) :
+    List Data → Data → Data × ℕ × ℕ
+  | [], acc => (acc, acc.size, acc.size)
+  | x :: rest, acc =>
+    let (acc', t, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf h_whf
+    let (r, t', s') := Operation.foldRec body stack h_wf h_whf rest acc'
+    (r, 1 + t + t', max s s')
+
+/-- Recursive analog of `Operation.meteredEvalT_fold`: instead of three `List.foldl`s,
+    express the fold operation's result by structural recursion on the list. -/
+lemma Operation.meteredEvalT_fold_rec
+    {body : Prog} {initial list : TapeIndex} {stack : List Data}
+    {h_wf : WFOp stack.length (.fold body initial list)}
+    {h_whf : Operation.WhileFree (.fold body initial list)} :
+    Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
+      Operation.foldRec body stack h_wf.2.2 (by simpa using h_whf)
+        (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) := by
+  sorry
+
+
+/-- Space bound for a fold operation. If the initial accumulator fits within `B`,
+    and for every accumulator with `acc.size ≤ B` the body uses space `≤ B` and
+    produces a new accumulator with size `≤ B`, then the entire fold uses space
+    `≤ B`. -/
+lemma fold_bounded_space {body : Prog} {initial list : TapeIndex} {stack : List Data}
+    {h_wf : WFOp stack.length (.fold body initial list)}
+    {h_whf : Operation.WhileFree (.fold body initial list)}
+    (B : ℕ)
+    (h_init : (stack[initial]'h_wf.2.1).size ≤ B)
+    (h_step : ∀ acc x, acc.size ≤ B → x ∈ (stack[list]'h_wf.1).asList →
+      let (acc', _, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
+      s ≤ B ∧ acc'.size ≤ B) :
+    (Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf).2.2 ≤ B := by
+  sorry
+
+/-- Induction principle for `Operation.meteredEvalT` on a `.fold` operation.
+    To prove `motive` of the final `(acc, time, space)` triple, the caller supplies:
+    * `h_init`: the motive holds on `(initial, 0, 0)`;
+    * `h_step`: for every iteration item `x ∈ list`, the motive is preserved by one
+      body invocation — old triple `(acc, t, s)` is taken to
+      `(r.1, t + 1 + r.2.1, max s r.2.2)` where `r` is the body's result;
+    * `h_finish`: from the motive on the post-loop triple `(acc, t, s)`, derive
+      the motive on the final adjusted triple `(acc, t + acc.size, max s acc.size)`,
+      which accounts for the `[]` base case of `goMeteredFold`. -/
+lemma Operation.meteredEvalT_fold_induction
+    {body : Prog} {initial list : TapeIndex} {stack : List Data}
+    {h_wf : WFOp stack.length (.fold body initial list)}
+    {h_whf : Operation.WhileFree (.fold body initial list)}
+    (motive : Data → ℕ → ℕ → Prop)
+    (h_init : motive (stack[initial]'h_wf.2.1) 0 0)
+    (h_step : ∀ acc t s x, x ∈ (stack[list]'h_wf.1).asList → motive acc t s →
+      let (r, t', s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
+      motive r (t + 1 + t') (max s s'))
+    (h_finish : ∀ acc t s, motive acc t s → motive acc (t + acc.size) (max s acc.size)) :
+    let (r, t, s) := Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf
+    motive r t s := by
+  sorry
+
 @[simp]
 lemma Prog.meteredEvalT_nil
     {stack : List Data}
@@ -335,15 +406,49 @@ lemma prog_reverse.time (x : Data) (xs : List Data) :
   simp [prog_reverse]
   sorry
 
-lemma prog_reverse.space (x : Data) (xs : List Data) :
+lemma prog_reverse.space (list : Data) (xs : List Data) :
     (prog_reverse.meteredEvalT
-      (x :: xs)
+      (list :: xs)
       (by simp [prog_reverse, WFProg, WFOp])
-      (by simp [prog_reverse])).2.1 =
-      sorry := by
-  simp [prog_reverse]
+      (by simp [prog_reverse])).2.2 ≤ 8 * list.size + 8 := by
   sorry
+  -- have h (stack list : List Data) (acc : Data) :
+  --     (Operation.foldRec [.cons 0 1] stack sorry sorry list acc).2.2 ≤ 8 * (Data.l list).size := by
+  --   induction list with
+  --   | nil => simp [Operation.foldRec]
+  --   | cons x xs ih => sorry
+  -- simp only [prog_reverse, Prog.meteredEvalT_cons, Operation.meteredEvalT_empty,
+  --   Prog.meteredEvalT_nil, List.head_cons, add_zero, Prod.mk.eta, ge_iff_le]
+  -- rw [Operation.meteredEvalT_fold_rec]
+  -- simp
+  -- specialize h (Data.empty :: list :: xs) list.asList Data.empty
+  -- simp at h
+  -- grind
+
+-- TODO the successor function is not too easy, because
+-- we also need to concatenate at the end.
+-- so maybe it is easier to have some kind of fold-map-routine (i.e. a map that also has shared
+-- state in an accumulator)?
+-- where the "cons" is handeled by the fold-map routine?
+
+def prog_true : Prog := [
+    .empty,
+    .cons 0 0
+  ]
 
+def prog_bit_add : Prog := [
+    .empty,
+    .cons 0 1,
+    .cons 0 1,
+    .ite 0
+      [ .cons 0 1 ] -- if first bit is 1, add second bit to result
+      [ .head 1 ]     -- if first bit is 0, result is just second bit
+  ]
+
+def prog_succ : Prog := [
+    .call prog_true,
+    .fold [ .cons 0 1 ] 0 1
+  ]
 
 -----------------------------------------------------------------------------------------
 --- The stuff below here still needs some work

From bcc2615302669731767208dc88607f723f39968c Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 10:51:52 +0200
Subject: [PATCH 040/106] stacktape cons semantics.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 323 +++++++++++++++---
 1 file changed, 283 insertions(+), 40 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 1f34543052..28ab42501d 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -3,6 +3,8 @@ import Mathlib.Control.Fix
 import Mathlib.Tactic
 import Std
 
+import Cslib.Computability.Machines.SingleTapeTuring.Basic
+
 -- This is a proposal to define a machine model and related time and space measure
 -- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
 
@@ -40,6 +42,11 @@ deriving Repr, BEq
 
 abbrev Data.empty := Data.l []
 
+-- TODO not sure why this is needed
+@[simp]
+lemma Data_beq (x : Data) : (x == x) := by sorry
+
+
 abbrev Data.asList
   | Data.l xs => xs
 
@@ -86,7 +93,7 @@ inductive Operation where
   -- compare two tapes, returning non-empty if equal, empty otherwise
   | eq     : TapeIndex → TapeIndex → Operation
   -- branch on tape i: if empty then then_ else else_
-  | ite    : TapeIndex → (List Operation) → (List Operation) → Operation
+  | ifEmpty : TapeIndex → (List Operation) → (List Operation) → Operation
   -- fold over the children of tape l with initial accumulator tape i and body program b
   | fold   : (List Operation) → TapeIndex → TapeIndex → Operation
   -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
@@ -108,7 +115,7 @@ mutual
     | .head i     => i < n
     | .tail i     => i < n
     | .eq i j     => i < n ∧ j < n
-    | .ite i t e  => i < n ∧ WFProg n t ∧ WFProg n e
+    | .ifEmpty i t e  => i < n ∧ WFProg n t ∧ WFProg n e
     | .fold b i l => l < n ∧ i < n ∧ WFProg (n + 2) b
     | .while_ i b => i < n ∧ WFProg (n + 1) b
     | .call b => WFProg n b
@@ -143,8 +150,8 @@ mutual
       (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse,
       1 + (min (stack[i]'h_wf.1).size (stack[j]'h_wf.2).size),
       1)
-    | .ite i then_ else_ =>
-      (if stack[i]'h_wf.1 == dataTrue then
+    | .ifEmpty i then_ else_ =>
+      (if stack[i]'h_wf.1 == Data.empty then
         meteredEvalProg then_ stack h_wf.2.1
       else
         meteredEvalProg else_ stack h_wf.2.2).map (fun (r, t, s) => (r, 1 + t, s))
@@ -203,7 +210,7 @@ mutual
   @[simp]
   def Operation.WhileFree (op : Operation) : Prop :=
     match op with
-    | .ite _ a b => Prog.WhileFree a ∧ Prog.WhileFree b
+    | .ifEmpty _ a b => Prog.WhileFree a ∧ Prog.WhileFree b
     | .while_ _ _ => False
     | .fold b _ _ => Prog.WhileFree b
     | .call p => Prog.WhileFree p
@@ -238,6 +245,10 @@ theorem Dom_meteredEvalOp_of_WhileFree {op : Operation} {stack : List Data}
 -- It is not sufficient for a program to be total, because this does not imply that all
 -- sub-programs are total, which is what we would need for simp lemmas to be clearly statable.
 
+-- Note that you do not want to unfold or simplify Operation.meteredEvalT, because it introduces
+-- the proof of termination, which blocks simp and rw rules. Because of that, we have
+-- simp lemmas for each operation below.
+
 def Operation.meteredEvalT (op : Operation) (stack : List Data) (h_wf : WFOp stack.length op)
     (h_whf : Operation.WhileFree op) : Data × ℕ × ℕ :=
   (meteredEvalOp stack op h_wf).get (by simp [h_whf])
@@ -254,6 +265,7 @@ lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length
 
 @[simp]
 lemma Operation.meteredEvalT_cons
+    {h t : ℕ}
     {stack : List Data}
     {h_wf : WFOp stack.length (.cons h t)} :
     Operation.meteredEvalT (.cons h t) stack h_wf (by simp) =
@@ -262,6 +274,45 @@ lemma Operation.meteredEvalT_cons
       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
+@[simp]
+lemma Operation.meteredEvalT_head
+    {i : ℕ}
+    {stack : List Data}
+    {h_wf : WFOp stack.length (.head i)} :
+    Operation.meteredEvalT (.head i) stack h_wf (by simp) =
+      (stack[i].asList.headD Data.empty,
+      1 + (stack[i].asList.headD Data.empty).size,
+      1 + (stack[i].asList.headD Data.empty).size) := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
+@[simp]
+lemma Operation.meteredEvalT_tail
+    {i : ℕ}
+    {stack : List Data}
+    {h_wf : WFOp stack.length (.tail i)} :
+    Operation.meteredEvalT (.tail i) stack h_wf (by simp) =
+      (Data.l stack[i].asList.tail,
+      1 + (Data.l stack[i].asList.tail).size,
+      1 + (Data.l stack[i].asList.tail).size) := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
+@[simp]
+lemma Operation.meteredEvalT_ifEmpty
+    {i : ℕ}
+    {stack : List Data}
+    {then_ else_ : List Operation}
+    {h_wf : WFOp stack.length (.ifEmpty i then_ else_)}
+    {h_whf : WhileFree (.ifEmpty i then_ else_)} :
+    Operation.meteredEvalT (.ifEmpty i then_ else_) stack h_wf h_whf =
+      let (r, t, s) := if stack[i]'h_wf.1 == Data.empty then
+        Prog.meteredEvalT then_ stack h_wf.2.1 h_whf.1
+      else
+        Prog.meteredEvalT else_ stack h_wf.2.2 h_whf.2
+      (r, 1 + t, s) := by
+  by_cases h_empty : stack[i]'h_wf.1 == Data.empty
+  · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
+  · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
+
 @[simp]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
     {h_wf : WFOp stack.length (.fold body initial list)}
@@ -374,8 +425,55 @@ lemma Prog.meteredEvalT_cons
       (stack, opT + t, opS + s) := by
   sorry
 
+class DataEncode (α : Type) where
+  encode : α → Data
+  h_inj : encode.Injective
+
+instance : DataEncode Bool where
+  encode b := if b then dataTrue else dataFalse
+  h_inj := by intros a b h_eq; grind
+
+instance (α : Type) [DataEncode α] : DataEncode (List α) where
+  encode xs := Data.l (xs.map DataEncode.encode)
+  h_inj := by sorry
+
+@[simp, grind =]
+lemma DataEncode_list_nil {α : Type} [DataEncode α] :
+  DataEncode.encode ([] : List α) = Data.l [] := by
+  simp [DataEncode.encode]
+
+@[simp, grind =]
+lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
+  DataEncode.encode xs = Data.empty ↔ xs = [] := by
+  simp [DataEncode.encode]
 
-------------------------------------------------------------------------------
+instance (α : Type) [DataEncode α] : DataEncode (Option α) where
+  encode := fun
+    | none => Data.l []
+    | some x => Data.l [DataEncode.encode x]
+  h_inj := by sorry
+
+@[simp]
+lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α):
+  (DataEncode.encode x == Data.empty) = x.isNone := by sorry
+
+instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
+  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
+  h_inj := by sorry
+
+instance : DataEncode ℕ where
+  encode x := DataEncode.encode (Nat.bits x)
+  h_inj := by sorry
+
+----------------------------------------------------------------
+---- Function view
+--------------------------------------------------------
+
+def FunType (inputs : ℕ) : Type := match inputs with
+  | 0 => Data
+  | n + 1 => Data → FunType n
+
+--------------------------------------------------------------------
 -- Example program
 ---------------------------------------------------------------------------
 
@@ -431,25 +529,191 @@ lemma prog_reverse.space (list : Data) (xs : List Data) :
 -- state in an accumulator)?
 -- where the "cons" is handeled by the fold-map routine?
 
-def prog_true : Prog := [
-    .empty,
-    .cons 0 0
-  ]
+--------------------------------------------------------------------
+---------------- Universal Turing Machine (simulation of a SingleTapeTM)
+---------------------------------------------------------------------------
 
-def prog_bit_add : Prog := [
+variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
+
+public instance : DataEncode (Turing.StackTape Symbol) where
+  encode t := DataEncode.encode t.toList
+  h_inj := by sorry
+
+public instance : DataEncode (Turing.BiTape Symbol) where
+  encode t := DataEncode.encode (t.head, t.left, t.right)
+  h_inj := by sorry
+
+def tape_write : Prog := [
+  .tail 1,
+  .cons 1 0
+]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+@[simp]
+lemma tape_write.semantics (t : Turing.BiTape Symbol) (a : Option Symbol) {stack : List Data} :
+    (tape_write.meteredEvalT (DataEncode.encode a :: DataEncode.encode t :: stack)
+      (by simp [tape_write, WFProg, WFOp]) (by simp [tape_write])).1 =
+      DataEncode.encode (t.write a) := by
+  simp [tape_write, Turing.BiTape.write]
+  rfl
+
+-- /-- Prepend an `Option` to the `StackTape` -/
+-- @[scoped grind]
+-- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
+--   match x, xs with
+--   | none, ⟨[], _⟩ => ⟨[], by grind⟩
+--   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
+--   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
+
+def stackTape_cons : Prog := [
+  .ifEmpty 0 [ .ifEmpty 1 [ .empty ] [ .cons 0 1 ] ] [ .cons 0 1 ]
+]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+@[simp]
+lemma stackTape_cons.semantics
+    (x : Option Symbol) (xs : Turing.StackTape Symbol) {stack : List Data} :
+    (stackTape_cons.meteredEvalT (DataEncode.encode x :: DataEncode.encode xs :: stack)
+      (by simp [stackTape_cons, WFProg, WFOp]) (by simp [stackTape_cons])).1 =
+      DataEncode.encode (xs.cons x) := by
+  have h_encode_stackTape (xs : Turing.StackTape Symbol) :
+    DataEncode.encode xs = DataEncode.encode (xs.toList) := by simp [DataEncode.encode]
+  match x with
+  | none =>
+    by_cases h_tail : xs.toList = []
+    · have : xs = Turing.StackTape.nil := Turing.StackTape.ext _ _ (by simp [h_tail])
+      simp [stackTape_cons, h_encode_stackTape, this]
+    · have h_empty : ¬ (DataEncode.encode xs == Data.empty) := by
+        sorry
+      simp [stackTape_cons, h_empty]
+      simp [h_encode_stackTape]
+      -- TODO just some StackTape encoding stuff left to solve here.
+      sorry
+  | some x =>
+    simp [stackTape_cons, h_encode_stackTape]
+    simp [DataEncode.encode]
+
+-- def move_left (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
+
+def tape_move_left : Prog := [
+  .head 0, -- head
+  .tail 1, -- (left, right)
+  .head 0, -- left
+  .tail 1, -- right
+
+
+def tape_optionMove
+
+def put : Data → Prog
+  | Data.l [] => [ .empty ]
+  | Data.l (head :: tail) => [
+      .call (put (Data.l tail)),
+      .call (put head),
+      .cons 0 1
+    ]
+
+--------------------- IDEAS ---------------------------------
+-- Complexity:
+-- If a program is loop-free (no .while, no .fold), then both its space and time complexity
+-- is linear in the sum of the sizes of its inputs (determined by the smallest well-formedness
+-- parameter)
+------------------------------------
+
+
+@[simp]
+lemma put_wf {i : ℕ} {d : Data} : WFProg i (put d) := by sorry
+
+@[simp]
+lemma put_whf {d : Data} : Prog.WhileFree (put d) := by sorry
+
+@[simp]
+lemma put_semantics {stack : List Data} {d : Data} :
+    ((put d).meteredEvalT stack (by simp) (by simp)).1 = d := by sorry
+
+def copy (slot : ℕ) : Prog := [ .tail slot, .head (slot + 1), .cons 0 1 ]
+
+@[simp]
+lemma copy_wf {i slot : ℕ} (h_lt : slot < i) : WFProg i (copy slot) := by
+  simp [copy, WFProg, WFOp, h_lt]
+
+@[simp]
+lemma copy_whf {slot : ℕ} : Prog.WhileFree (copy slot) := by simp [copy]
+
+@[simp]
+lemma copy_semantics {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
+    ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
+  simp [copy, Operation.meteredEvalT, meteredEvalOp]
+  sorry
+
+--- Runs `condition` on every element in the list and returns the first return value that
+--- is non-empty.
+def find? (condition : Prog) : Prog := [
     .empty,
-    .cons 0 1,
-    .cons 0 1,
-    .ite 0
-      [ .cons 0 1 ] -- if first bit is 1, add second bit to result
-      [ .head 1 ]     -- if first bit is 0, result is just second bit
+    .fold [
+      -- element: 0, acc: 1
+      .ite 1 (copy 1) [.call condition],
+    ] 1 0
   ]
 
-def prog_succ : Prog := [
-    .call prog_true,
-    .fold [ .cons 0 1 ] 0 1
+@[simp]
+lemma find?_semantics (condition : Prog) {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
+    ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
+  simp [copy, Operation.meteredEvalT, meteredEvalOp]
+  sorry
+
+def get_symbol : Prog := [
+    .head 0
   ]
 
+public instance (α : Type) [StrEnc α] (k : ℕ) : StrEnc (Vector α k) where
+  toData v := StrEnc.toData v.toList
+
+public instance : StrEnc (MultiCell (k : ℕ)) where
+  toData mc := StrEnc.toData (mc.cells, mc.isLeftEnd, mc.isRightEnd)
+
+/-
+Outline of UTM:
+while the current state is not None:
+- for each tape, find the head position on the multi-tape
+  and copy the current symbol to an aux tape.
+- now the aux tape contains the symbols in the correct order.
+- copy the current state to the aux tape.
+- the contents of the aux tape is exactly the input to the
+  transition function
+- "evaluate the transition function" by iterating through its
+  table and storing the result on another tape
+- execute the actions for each of the tapes:
+  - find the head. update the symbol, update the head marking
+    according to the move action
+    (potentially extend the tape to the left or right)
+- update the current state
+-/
+
+/- sub-routines we need:
+- move to the first element of a list that satisfies a condition:
+  tm₁ tm₂ tm₃: For each item in the list: if tm₁ outputs true on an aux tape, run tm₂.
+  if it never outputs true, run tm₃
+- evaluate a function given by a list of input-output pairs
+- update an element in a list, whose encoding size must be the same
+- extend a list to the right
+-/
+
+/-- The encoding of the given tapes as a list of `MultiCell`s. -/
+def encodeTapes (k : ℕ) (tapes : Fin k → BiTape Char) (shifts : Fin k → ℤ) : List (MultiCell k) :=
+  sorry
+
+def getHeadSymbol (k : ℕ) (tapeIdx : ℕ) (mt out aux : Fin k) : MultiTapeTM k Char :=
+  -- Find the cell where the tapeIdx-th tape has the head
+  find_list mt aux (atPath [0, tapeIdx, 1] mt (copyEnc mt aux))
+    -- copy the symbol to out
+    (atPath [0, tapeIdx, 0] mt (copy_to_list mt out))
+    -- otherwise do nothing (because we know there is a head marker)
+    (noop)
+
+
+
+
 -----------------------------------------------------------------------------------------
 --- The stuff below here still needs some work
 -----------------------------------------------------------------------------
@@ -530,27 +794,6 @@ def WellFormedProgram.append {in₁ in₁ : ℕ}
     WellFormedProgram in₁ :=
   { prog := p₁.prog ++ p₂.prog, h_wf := by sorry }
 
-class DataEncode (α : Type) where
-  encode : α → Data
-  h_inj : encode.Injective
-
-instance : DataEncode Bool where
-  encode b := if b then dataTrue else dataFalse
-  h_inj := by intros a b h_eq; grind
-
-instance (α : Type) [DataEncode α] : DataEncode (List α) where
-  encode xs := Data.l (xs.map DataEncode.encode)
-  h_inj := by sorry
-
-instance (α : Type) [DataEncode α] : DataEncode (Option α) where
-  encode := fun
-    | none => Data.l []
-    | some x => Data.l [DataEncode.encode x]
-  h_inj := by sorry
-
-instance : DataEncode ℕ where
-  encode x := DataEncode.encode (Nat.bits x)
-  h_inj := by sorry
 
 def RunsInSpace {inputs : ℕ} (p : WellFormedProgram inputs) (s : ℕ → ℕ) : Prop :=
   ∃ s₁ s₂, ∀ x, (h_l : x.length = inputs) → ∃ s' ≤ s₁ * (s (Data.l x).size) + s₂,

From 0d053b5fa8b4e9735718a64ad8da707621c41260 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 11:29:12 +0200
Subject: [PATCH 041/106] cleanup

---
 .../Machines/RoseTreeMachine/Basic.lean       |  383 ----
 .../RoseTreeMachine/RoseTreeMachine.lean      | 1643 +++++++++--------
 2 files changed, 838 insertions(+), 1188 deletions(-)
 delete mode 100644 Cslib/Computability/Machines/RoseTreeMachine/Basic.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean b/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean
deleted file mode 100644
index e53fee28a6..0000000000
--- a/Cslib/Computability/Machines/RoseTreeMachine/Basic.lean
+++ /dev/null
@@ -1,383 +0,0 @@
-/-
-Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner
--/
-
-module
-
--- TODO create a "common file"?
-public import Cslib.Computability.Machines.SingleTapeTuring.Basic
-
-public import Mathlib.Data.Part
-
-import Std
-import Mathlib.Algebra.Order.BigOperators.Group.Finset
-import Mathlib.Order.Interval.Finset.Defs
-
-
-
-inductive Data where
-  | l : List Data → Data
-deriving Repr, BEq
-
-abbrev Data.empty := Data.l []
-
-abbrev Data.asList
-  | Data.l items => items
-
-structure TapeIndex where
-  id : ℕ
-deriving Repr, BEq, Hashable
-
--- Is a program a map from Nat to operations which reference smaller indices?
-
-inductive Operation
-  | empty
-  | copy (tape : TapeIndex)
-  | cons (head tail : TapeIndex)
-  -- | fold (list : TapeIndex) (step : List Operation)
-deriving Repr
-
-abbrev Program := List Operation
-
-def eval (p : Program) (stack : List Data) : Part (List Data) :=
-  match p with
-  | [] => .some stack
-  | .empty :: ops =>
-    eval ops (stack.concat Data.empty)
-  | .copy t :: ops =>
-    -- TODO can we enforce that inside the program?
-    if h : t.id < stack.length then
-      eval ops (stack.concat stack[t.id])
-    else
-      Part.none
-  | .cons head tail :: ops =>
-    if h : head.id < stack.length ∧ tail.id < stack.length then
-      eval ops (stack.concat (Data.l (stack[head.id] :: stack[tail.id].asList)))
-    else
-      Part.none
-  -- | .fold list init step :: ops =>
-  --   if h : list.id < initial.length then
-  --     let listData := initial[list.id]
-  --     match listData with
-  --     | Data.l items =>
-  --       let initData := initial.getLast'sorry
-  --       let stepOps := step.map (fun op => op.mapTapeIndex (fun t => initial[t.id]))
-  --   else
-  --     Part.none
-
-
-structure BuilderCtx where
-  nextTapeIndex : ℕ
-  program : Program
-deriving Repr
-
-abbrev Build (α : Type) := StateT BuilderCtx (Except String) α
-
-def newTape (p : Program) : Build TapeIdx := do
-  let env ← get
-  let sid := env.next
-  set { env with next := sid + 1, ops := env.ops ++ [op] }
-  return ⟨sid⟩
-
--- ============================================================
--- SLOT PRIMITIVES
--- ============================================================
-
--- Allocate a slot holding Data.l []
-def new : Build TapeIdx :=
-  newTape Program.new
-
--- Prepend a as first child of b
--- O(1) time, O(1) space — one new heap node with two pointers
-def cons (a b : Slot) : Build Slot :=
-  newTape s!"cons({a.id},{b.id})"
-
--- Left fold over children of slot a
--- O(n) time — space = max live accumulator = size of final result
-opaque fold
-    {α : Type}
-    (a    : Slot)
-    (init : α)
-    (step : Slot → α → Build α)
-    : Build α
-
--- Right fold over children of slot a
--- O(n) time — needed for single-pass append/snoc
-opaque foldr
-    {α : Type}
-    (a    : Slot)
-    (init : α)
-    (step : Slot → α → Build α)
-    : Build α
-
--- Data.l [] if a = b, nonempty otherwise
--- eq_ a a = Data.l [] is correct: slots are immutable so same slot = same value
--- O(n) time structural equality, O(1) space
-opaque eq_ (a b : Slot) : Build Slot
-
--- Branch on slot value: Data.l [] = false, anything else = true
-opaque if_
-    {α : Type}
-    (cond  : Slot)
-    (then_ : Build α)
-    (else_ : Build α)
-    : Build α
-
--- Loop until condition slot returned by step is Data.l []
--- Step: current state → (condition, next state)
--- Only source of non-termination in the system
-opaque while_
-    {α : Type}
-    (step : α → Build (Slot × α))
-    (init : α)
-    : Build α
-
--- ============================================================
--- INPUT TAPE PRIMITIVES
--- All navigation is O(1) space (just moves the read head)
--- ============================================================
-
--- Move into first child
--- nonEmpty branch: cursor moves to first child's (
--- empty branch:    current node is Data.l [], cursor stays
--- O(1) time — peek right one cell
-opaque down
-    {α : Type}
-    (nonEmpty : Build α)
-    (empty    : Build α)
-    : Build α
-
--- Move to parent
--- hasParent branch: cursor moves to parent's (
--- isRoot branch:    already at root, cursor stays
--- O(n) time — scan left past siblings counting brackets
-opaque up
-    {α : Type}
-    (hasParent : Build α)
-    (isRoot    : Build α)
-    : Build α
-
--- Move to next sibling
--- hasNext branch: cursor moves to next sibling's (
--- isLast branch:  no next sibling (cursor lands on parent's ))
--- O(n) time — scan right past current subtree
-opaque next
-    {α : Type}
-    (hasNext : Build α)
-    (isLast  : Build α)
-    : Build α
-
--- Move to previous sibling
--- hasPrev branch: cursor moves to previous sibling's (
--- isFirst branch: no previous sibling, cursor stays
--- O(n) time — scan left past previous subtree
-opaque prev
-    {α : Type}
-    (hasPrev : Build α)
-    (isFirst : Build α)
-    : Build α
-
--- Copy the subtree at the current cursor position into a new slot
--- O(n) time, O(n) space
-opaque readCursor : Build Slot
-
--- ============================================================
--- DERIVED: BOOLEAN SLOTS
--- ============================================================
-
-def false_ : Build Slot := new
-def true_  : Build Slot := do cons (← new) (← new)
-
--- ============================================================
--- DERIVED: BOUNDARY DETECTION
--- (all derived from navigation combinators)
--- ============================================================
-
-def cursorEmpty : Build Slot :=
-  down (do up (return ()) (return ()); false_) true_
-
-def isFirst_ : Build Slot :=
-  prev (do next (return ()) (return ()); false_) true_
-
-def isLast_ : Build Slot :=
-  next (do prev (return ()) (return ()); false_) true_
-
-def isRoot_ : Build Slot :=
-  up (do down (return ()) (return ()); false_) true_
-
--- ============================================================
--- DERIVED: SLOT CONSTRUCTORS
--- ============================================================
-
-def wrap (a : Slot) : Build Slot :=
-  cons a (← new)
-
-def copy (a : Slot) : Build Slot :=
-  fold a (← new) (fun child acc => cons child acc)
-
--- ============================================================
--- DERIVED: BOOLEAN OPERATIONS ON SLOTS
--- ============================================================
-
-def not_ (a : Slot) : Build Slot :=
-  if_ a false_ true_
-
-def and_ (a b : Slot) : Build Slot :=
-  if_ a (return b) false_
-
-def or_ (a b : Slot) : Build Slot :=
-  if_ a true_ (return b)
-
-def xor_ (a b : Slot) : Build Slot :=
-  not_ =<< eq_ a b
-
--- ============================================================
--- DERIVED: LIST OPERATIONS ON SLOTS
--- ============================================================
-
--- Append: children of a then children of b — O(|a|) time, O(|a|) space
-def append_ (a b : Slot) : Build Slot :=
-  foldr a b (fun child acc => cons child acc)
-
--- Reverse — O(n) time, O(n) space
-def reverse_ (a : Slot) : Build Slot :=
-  fold a (← new) (fun child acc => cons child acc)
-
--- Snoc: b as last child of a — O(n) time, O(n) space
-def snoc (a b : Slot) : Build Slot :=
-  foldr a (← wrap b) (fun child acc => cons child acc)
-
--- Filter — O(n) time, O(m) space where m = kept elements
-def filter (a : Slot) (pred : Slot → Build Slot) : Build Slot :=
-  fold a (← new) (fun child acc => do
-    if_ (← pred child)
-      (cons child acc)
-      (return acc))
-
--- ============================================================
--- DERIVED: INPUT TAPE ITERATION
--- ============================================================
-
--- Fold over children of current cursor node
--- O(n) time — visits each child once
--- space = accumulator = O(output size)
-def foldCursor {α : Type} (init : α) (step : α → Build α) : Build α :=
-  down
-    (do
-      let result ← while_
-        (fun acc => do
-          let r    ← step acc
-          let cond ← next
-            (do false_)    -- has next sibling: condition = false = keep going
-            (do true_)     -- no next sibling: condition = true = stop
-          return (cond, r))
-        init
-      up (return ()) (return ())
-      return result)
-    (return init)          -- empty node: nothing to fold
-
--- Read all children of current node into a slot
--- O(n) time, O(n) space
-def readChildren : Build Slot := do
-  foldCursor (← new) (fun acc => do
-    let child ← readCursor
-    down (up (return ()) (return ())) (return ())  -- step into child and back
-    cons child acc)
-
--- ============================================================
--- DERIVED: BINARY NATURAL NUMBERS IN SLOTS
---
--- Encoding: Data.l [b0, b1, ..., bn] LSB first
---   Data.l []  = bit 0
---   nonempty   = bit 1
--- ============================================================
-
-def bit0 : Build Slot := new
-def bit1 : Build Slot := true_
-
-def addBits (a b carry : Slot) : Build (Slot × Slot) := do
-  let sumBit   ← xor_ (← xor_ a b) carry
-  let carryOut ← if_ (← and_ a b)
-    true_
-    (and_ b carry)
-  return (sumBit, carryOut)
-
--- Add two binary numbers — O(n²) time, O(n) space
-def add (a b : Slot) : Build Slot := do
-  let (acc, bRest, carry) ← fold a (← new, b, ← bit0)
-    (fun aBit (acc, bRest, carry) => do
-      let (bBit, bTail) ← if_ bRest
-        (fold bRest (← bit0, ← new)
-          (fun h _ => return (h, ← new)))  -- take head of bRest
-        (do return (← bit0, ← new))        -- b exhausted
-      let (s, c) ← addBits aBit bBit carry
-      return (← cons s acc, bTail, c))
-  let (acc2, carry2) ← fold bRest (acc, carry)
-    (fun bBit (acc, carry) => do
-      let (s, c) ← addBits (← bit0) bBit carry
-      return (← cons s acc, c))
-  if_ carry2
-    (cons (← bit1) acc2)
-    (return acc2)
-
--- ============================================================
--- SEAL
--- ============================================================
-
-structure CompiledRoutine where
-  outputSlot : Nat
-  ops        : List String
-deriving Repr
-
--- Seal a routine that reads the input tape and produces one output slot
-def seal (build : Build Slot) : Except String CompiledRoutine := do
-  let (out, env) ← build.run SlotEnv.initial
-  return ⟨out.id, env.ops⟩
-
--- Seal a routine that also takes explicit slot arguments
-def seal1 (build : Slot → Build Slot) : Except String CompiledRoutine := do
-  let (out, env) ← (build ⟨0⟩).run { SlotEnv.initial with next := 1 }
-  return ⟨out.id, env.ops⟩
-
-def seal2 (build : Slot → Slot → Build Slot) : Except String CompiledRoutine := do
-  let (out, env) ← (build ⟨0⟩ ⟨1⟩).run { SlotEnv.initial with next := 2 }
-  return ⟨out.id, env.ops⟩
-
--- ============================================================
--- MAIN
--- ============================================================
-
-def main : IO Unit := do
-  let run (name : String) (r : Except String CompiledRoutine) : IO Unit :=
-    IO.println s!"\n=== {name} ===" >>
-    match r with
-    | .error e => IO.println s!"Error: {e}"
-    | .ok r    => IO.println (repr r)
-
-  -- Slot operations
-  run "new"           (seal new)
-  run "true_"         (seal true_)
-  run "not(true)"     (seal do not_ (← true_))
-  run "not(false)"    (seal do not_ (← false_))
-  run "and(T,T)"      (seal do and_ (← true_) (← true_))
-  run "and(F,T)"      (seal do and_ (← false_) (← true_))
-  run "or(F,T)"       (seal do or_ (← false_) (← true_))
-  run "xor(T,T)"      (seal do xor_ (← true_) (← true_))
-  run "xor(F,T)"      (seal do xor_ (← false_) (← true_))
-  run "append"        (seal2 fun a b => append_ a b)
-  run "reverse"       (seal1 fun a => reverse_ a)
-  run "snoc"          (seal2 fun a b => snoc a b)
-  run "add"           (seal2 fun a b => add a b)
-
-  -- Input tape operations
-  run "readCursor"    (seal readCursor)
-  run "cursorEmpty"   (seal cursorEmpty)
-  run "isFirst"       (seal isFirst_)
-  run "isLast"        (seal isLast_)
-  run "isRoot"        (seal isRoot_)
-  run "foldCursor"    (seal do
-    foldCursor (← new) (fun acc => do
-      let child ← readCursor
-      cons child acc))
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 28ab42501d..b570f4fe30 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -42,9 +42,9 @@ deriving Repr, BEq
 
 abbrev Data.empty := Data.l []
 
--- TODO not sure why this is needed
-@[simp]
-lemma Data_beq (x : Data) : (x == x) := by sorry
+-- -- TODO not sure why this is needed
+-- @[simp]
+-- lemma Data_beq (x : Data) : (x == x) := by sorry
 
 
 abbrev Data.asList
@@ -313,6 +313,16 @@ lemma Operation.meteredEvalT_ifEmpty
   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
 
+
+@[simp]
+lemma Operation.meteredEvalT_call
+    {stack : List Data}
+    {p : List Operation}
+    {h_wf : WFOp stack.length (.call p)}
+    {h_whf : WhileFree (.call p)} :
+    Operation.meteredEvalT (.call p) stack h_wf h_whf = Prog.meteredEvalT p stack h_wf h_whf := by
+  simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp]
+
 @[simp]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
     {h_wf : WFOp stack.length (.fold body initial list)}
@@ -454,7 +464,7 @@ instance (α : Type) [DataEncode α] : DataEncode (Option α) where
   h_inj := by sorry
 
 @[simp]
-lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α):
+lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
   (DataEncode.encode x == Data.empty) = x.isNone := by sorry
 
 instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
@@ -511,7 +521,8 @@ lemma prog_reverse.space (list : Data) (xs : List Data) :
       (by simp [prog_reverse])).2.2 ≤ 8 * list.size + 8 := by
   sorry
   -- have h (stack list : List Data) (acc : Data) :
-  --     (Operation.foldRec [.cons 0 1] stack sorry sorry list acc).2.2 ≤ 8 * (Data.l list).size := by
+  --     (Operation.foldRec [.cons 0 1] stack sorry sorry list acc).2.2 ≤
+  --     8 * (Data.l list).size := by
   --   induction list with
   --   | nil => simp [Operation.foldRec]
   --   | cons x xs ih => sorry
@@ -557,14 +568,6 @@ lemma tape_write.semantics (t : Turing.BiTape Symbol) (a : Option Symbol) {stack
   simp [tape_write, Turing.BiTape.write]
   rfl
 
--- /-- Prepend an `Option` to the `StackTape` -/
--- @[scoped grind]
--- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
---   match x, xs with
---   | none, ⟨[], _⟩ => ⟨[], by grind⟩
---   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
---   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
-
 def stackTape_cons : Prog := [
   .ifEmpty 0 [ .ifEmpty 1 [ .empty ] [ .cons 0 1 ] ] [ .cons 0 1 ]
 ]
@@ -583,6 +586,7 @@ lemma stackTape_cons.semantics
     by_cases h_tail : xs.toList = []
     · have : xs = Turing.StackTape.nil := Turing.StackTape.ext _ _ (by simp [h_tail])
       simp [stackTape_cons, h_encode_stackTape, this]
+      sorry
     · have h_empty : ¬ (DataEncode.encode xs == Data.empty) := by
         sorry
       simp [stackTape_cons, h_empty]
@@ -597,834 +601,863 @@ lemma stackTape_cons.semantics
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
 def tape_move_left : Prog := [
-  .head 0, -- head
-  .tail 1, -- (left, right)
-  .head 0, -- left
-  .tail 1, -- right
-
-
-def tape_optionMove
-
-def put : Data → Prog
-  | Data.l [] => [ .empty ]
-  | Data.l (head :: tail) => [
-      .call (put (Data.l tail)),
-      .call (put head),
-      .cons 0 1
-    ]
-
---------------------- IDEAS ---------------------------------
--- Complexity:
--- If a program is loop-free (no .while, no .fold), then both its space and time complexity
--- is linear in the sum of the sizes of its inputs (determined by the smallest well-formedness
--- parameter)
-------------------------------------
-
-
-@[simp]
-lemma put_wf {i : ℕ} {d : Data} : WFProg i (put d) := by sorry
-
-@[simp]
-lemma put_whf {d : Data} : Prog.WhileFree (put d) := by sorry
+  .head 0, -- t.head
+  .call [ .tail 1, .tail 0 ], -- t.right
+  .call stackTape_cons, -- StackTape.cons t.head t.right
+  .call [ .tail 3, .head 0, .tail 0 ], -- t.left.tail
+  .call [ .tail 3, .head 0, .head 0 ], -- t.left.head
+  .cons 1 2,
+  .cons 1 0
+]
 
 @[simp]
-lemma put_semantics {stack : List Data} {d : Data} :
-    ((put d).meteredEvalT stack (by simp) (by simp)).1 = d := by sorry
-
-def copy (slot : ℕ) : Prog := [ .tail slot, .head (slot + 1), .cons 0 1 ]
+lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
+  simp [tape_move_left, stackTape_cons]
 
 @[simp]
-lemma copy_wf {i slot : ℕ} (h_lt : slot < i) : WFProg i (copy slot) := by
-  simp [copy, WFProg, WFOp, h_lt]
+lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
+  simp [tape_move_left, WFProg, WFOp, stackTape_cons, h_le]
 
-@[simp]
-lemma copy_whf {slot : ℕ} : Prog.WhileFree (copy slot) := by simp [copy]
+-- @[simp]
+-- lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
+--     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp) (by simp)).1 =
+--       DataEncode.encode (Turing.BiTape.move_left t) := by
+--   unfold tape_move_left
+--   simp
 
-@[simp]
-lemma copy_semantics {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
-    ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
-  simp [copy, Operation.meteredEvalT, meteredEvalOp]
-  sorry
+--   sorry
 
---- Runs `condition` on every element in the list and returns the first return value that
---- is non-empty.
-def find? (condition : Prog) : Prog := [
-    .empty,
-    .fold [
-      -- element: 0, acc: 1
-      .ite 1 (copy 1) [.call condition],
-    ] 1 0
-  ]
 
-@[simp]
-lemma find?_semantics (condition : Prog) {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
-    ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
-  simp [copy, Operation.meteredEvalT, meteredEvalOp]
-  sorry
+-- def put : Data → Prog
+--   | Data.l [] => [ .empty ]
+--   | Data.l (head :: tail) => [
+--       .call (put (Data.l tail)),
+--       .call (put head),
+--       .cons 0 1
+--     ]
 
-def get_symbol : Prog := [
-    .head 0
-  ]
+-- --------------------- IDEAS ---------------------------------
+-- -- Complexity:
+-- -- If a program is loop-free (no .while, no .fold), then both its space and time complexity
+-- -- is linear in the sum of the sizes of its inputs (determined by the smallest well-formedness
+-- -- parameter)
+-- ------------------------------------
 
-public instance (α : Type) [StrEnc α] (k : ℕ) : StrEnc (Vector α k) where
-  toData v := StrEnc.toData v.toList
-
-public instance : StrEnc (MultiCell (k : ℕ)) where
-  toData mc := StrEnc.toData (mc.cells, mc.isLeftEnd, mc.isRightEnd)
-
-/-
-Outline of UTM:
-while the current state is not None:
-- for each tape, find the head position on the multi-tape
-  and copy the current symbol to an aux tape.
-- now the aux tape contains the symbols in the correct order.
-- copy the current state to the aux tape.
-- the contents of the aux tape is exactly the input to the
-  transition function
-- "evaluate the transition function" by iterating through its
-  table and storing the result on another tape
-- execute the actions for each of the tapes:
-  - find the head. update the symbol, update the head marking
-    according to the move action
-    (potentially extend the tape to the left or right)
-- update the current state
--/
-
-/- sub-routines we need:
-- move to the first element of a list that satisfies a condition:
-  tm₁ tm₂ tm₃: For each item in the list: if tm₁ outputs true on an aux tape, run tm₂.
-  if it never outputs true, run tm₃
-- evaluate a function given by a list of input-output pairs
-- update an element in a list, whose encoding size must be the same
-- extend a list to the right
--/
-
-/-- The encoding of the given tapes as a list of `MultiCell`s. -/
-def encodeTapes (k : ℕ) (tapes : Fin k → BiTape Char) (shifts : Fin k → ℤ) : List (MultiCell k) :=
-  sorry
 
-def getHeadSymbol (k : ℕ) (tapeIdx : ℕ) (mt out aux : Fin k) : MultiTapeTM k Char :=
-  -- Find the cell where the tapeIdx-th tape has the head
-  find_list mt aux (atPath [0, tapeIdx, 1] mt (copyEnc mt aux))
-    -- copy the symbol to out
-    (atPath [0, tapeIdx, 0] mt (copy_to_list mt out))
-    -- otherwise do nothing (because we know there is a head marker)
-    (noop)
+-- @[simp]
+-- lemma put_wf {i : ℕ} {d : Data} : WFProg i (put d) := by sorry
 
+-- @[simp]
+-- lemma put_whf {d : Data} : Prog.WhileFree (put d) := by sorry
 
+-- @[simp]
+-- lemma put_semantics {stack : List Data} {d : Data} :
+--     ((put d).meteredEvalT stack (by simp) (by simp)).1 = d := by sorry
 
+-- def copy (slot : ℕ) : Prog := [ .tail slot, .head (slot + 1), .cons 0 1 ]
 
------------------------------------------------------------------------------------------
---- The stuff below here still needs some work
------------------------------------------------------------------------------
+-- @[simp]
+-- lemma copy_wf {i slot : ℕ} (h_lt : slot < i) : WFProg i (copy slot) := by
+--   simp [copy, WFProg, WFOp, h_lt]
 
-structure WellFormedProgram (inputs : ℕ) where
-  prog : Prog
-  h_wf : WFProg inputs prog
+-- @[simp]
+-- lemma copy_whf {slot : ℕ} : Prog.WhileFree (copy slot) := by simp [copy]
 
---- The output stack size of the program.
-abbrev WellFormedProgram.stackSize {inputs : ℕ} (p : WellFormedProgram inputs) : ℕ := inputs + p.prog.length
+-- @[simp]
+-- lemma copy_semantics {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
+--     ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
+--   simp [copy, Operation.meteredEvalT, meteredEvalOp]
+--   sorry
 
-def FunType (inputs : ℕ) : Type := match inputs with
-  | 0 => Data
-  | n + 1 => Data → FunType n
+-- --- Runs `condition` on every element in the list and returns the first return value that
+-- --- is non-empty.
+-- def find? (condition : Prog) : Prog := [
+--     .empty,
+--     .fold [
+--       -- element: 0, acc: 1
+--       .ite 1 (copy 1) [.call condition],
+--     ] 1 0
+--   ]
 
-@[simp]
-def WellFormedProgram.eval {inputs : ℕ} (p : WellFormedProgram inputs)
-    (stack : List Data) (h_len : stack.length ≥ inputs) : Part Data :=
-  (meteredEvalProg p.prog stack (by sorry)).map fun (d, _, _) => d
+-- @[simp]
+-- lemma find?_semantics (condition : Prog) {stack : List Data} {slot : ℕ}
+--     (h_lt : slot < stack.length) :
+--     ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
+--   simp [copy, Operation.meteredEvalT, meteredEvalOp]
+--   sorry
 
-@[simp]
-def WellFormedProgram.time {inputs : ℕ} (p : WellFormedProgram inputs)
-    (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
-  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, t, _) => t
+-- def get_symbol : Prog := [
+--     .head 0
+--   ]
+
+-- public instance (α : Type) [StrEnc α] (k : ℕ) : StrEnc (Vector α k) where
+--   toData v := StrEnc.toData v.toList
+
+-- public instance : StrEnc (MultiCell (k : ℕ)) where
+--   toData mc := StrEnc.toData (mc.cells, mc.isLeftEnd, mc.isRightEnd)
+
+-- /-
+-- Outline of UTM:
+-- while the current state is not None:
+-- - for each tape, find the head position on the multi-tape
+--   and copy the current symbol to an aux tape.
+-- - now the aux tape contains the symbols in the correct order.
+-- - copy the current state to the aux tape.
+-- - the contents of the aux tape is exactly the input to the
+--   transition function
+-- - "evaluate the transition function" by iterating through its
+--   table and storing the result on another tape
+-- - execute the actions for each of the tapes:
+--   - find the head. update the symbol, update the head marking
+--     according to the move action
+--     (potentially extend the tape to the left or right)
+-- - update the current state
+-- -/
+
+-- /- sub-routines we need:
+-- - move to the first element of a list that satisfies a condition:
+--   tm₁ tm₂ tm₃: For each item in the list: if tm₁ outputs true on an aux tape, run tm₂.
+--   if it never outputs true, run tm₃
+-- - evaluate a function given by a list of input-output pairs
+-- - update an element in a list, whose encoding size must be the same
+-- - extend a list to the right
+-- -/
+
+-- /-- The encoding of the given tapes as a list of `MultiCell`s. -/
+-- def encodeTapes (k : ℕ) (tapes : Fin k → BiTape Char) (shifts : Fin k → ℤ) :
+--   List (MultiCell k) :=
+--   sorry
 
-@[simp]
-def WellFormedProgram.space {inputs : ℕ} (p : WellFormedProgram inputs)
-    (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
-  (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
+-- def getHeadSymbol (k : ℕ) (tapeIdx : ℕ) (mt out aux : Fin k) : MultiTapeTM k Char :=
+--   -- Find the cell where the tapeIdx-th tape has the head
+--   find_list mt aux (atPath [0, tapeIdx, 1] mt (copyEnc mt aux))
+--     -- copy the symbol to out
+--     (atPath [0, tapeIdx, 0] mt (copy_to_list mt out))
+--     -- otherwise do nothing (because we know there is a head marker)
+--     (noop)
 
-structure TotalProgram (inputs : ℕ) extends WellFormedProgram inputs where
-  h_total : toWellFormedProgram.prog.Total toWellFormedProgram.h_wf
 
-def TotalProgram.eval {inputs : ℕ} (p : TotalProgram inputs)
-    (stack : List Data) (h_len : stack.length ≥ inputs) : Data :=
-  (p.toWellFormedProgram.eval stack h_len).get (p.h_total stack sorry)
 
-/-- Unfolding lemma that lets `simp` "execute" a `TotalProgram` step-by-step: it
-    rewrites `p.eval stack h_len` into a form mentioning `meteredEvalProg` directly,
-    so the `@[simp]` equations for `meteredEvalProg`/`meteredEvalOp` together with
-    `Part.some_bind`, `Part.map_some`, `Part.get_some` can reduce the program. -/
-@[simp]
-theorem TotalProgram.eval_eq {inputs : ℕ} (p : TotalProgram inputs)
-    (stack : List Data) (h_len : stack.length ≥ inputs) :
-    p.eval stack h_len =
-      ((meteredEvalProg p.prog stack (by sorry)).get
-         (by simpa [WellFormedProgram.eval] using p.h_total stack sorry)).1 := by
-  simp [TotalProgram.eval, WellFormedProgram.eval]
-
-def TotalProgram.as_fun {inputs : ℕ} (p : TotalProgram inputs) :
-    FunType inputs :=
-  sorry
 
--- examples:
-def prog_true : WellFormedProgram 0 := {
-  prog := [.empty, .cons 0 0],
-  h_wf := by simp [WFProg, WFOp]
-}
-def prog_false : WellFormedProgram 0 := {
-  prog := [.empty],
-  h_wf := by simp [WFProg, WFOp]
-}
-def prog_negate : WellFormedProgram 1 := {
-  prog := [.eq 0 0],
-  h_wf := by simp [WFProg, WFOp]
-}
-lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
-  simp [prog_true, meteredEvalOp]
-
-lemma prog_true.space : prog_true.space [] rfl = .some 6 := by
-  simp [prog_true, meteredEvalOp, Data.size]
-
-lemma prog_true.time : prog_true.time [] rfl = .some 6 := by
-  simp [prog_true, meteredEvalOp, Data.size]
-
-def WellFormedProgram.append {in₁ in₁ : ℕ}
-    (p₁ : WellFormedProgram in₁) (p₂ : WellFormedProgram in₂) (h_le : in₂ ≤ p₁.stackSize) :
-    WellFormedProgram in₁ :=
-  { prog := p₁.prog ++ p₂.prog, h_wf := by sorry }
-
-
-def RunsInSpace {inputs : ℕ} (p : WellFormedProgram inputs) (s : ℕ → ℕ) : Prop :=
-  ∃ s₁ s₂, ∀ x, (h_l : x.length = inputs) → ∃ s' ≤ s₁ * (s (Data.l x).size) + s₂,
-  p.space x h_l = .some s'
-
-def RunsInTime {inputs : ℕ} (p : WellFormedProgram inputs) (t : ℕ → ℕ) : Prop :=
-  ∃ t₁ t₂, ∀ x, (h_l : x.length = inputs) → ∃ t' ≤ t₁ * (t (Data.l x).size) + t₂,
-  p.time x h_l = .some t'
-
-def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β]
-  (p : WellFormedProgram 1) (f : α → β) (t s : ℕ → ℕ) : Prop :=
-  ∃ t₁ t₂ s₁ s₂,
-    (∀ x : α, p.eval [DataEncode.encode x] sorry = .some (DataEncode.encode (f x))) ∧
-    (∀ x : α, ∃ t' ≤ t₁ * (t (DataEncode.encode x).size) + t₂,
-        p.time [DataEncode.encode x] rfl = .some t') ∧
-    (∀ x : α, ∃ s' ≤ s₁ * (s (DataEncode.encode x).size) + s₂,
-        p.space [DataEncode.encode x] sorry = .some s')
-
-def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
-  (f : α → β) (t s : ℕ → ℕ) : Prop :=
-  ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
-
-
-def prog_reverse : TotalProgram 1 := {
-  prog := [
-    .empty,
-    .fold [
-      .cons 0 1
-    ] 0 1
-  ],
-  h_wf := by simp [WFProg, WFOp]
-  h_total := by simp
-}
-
--- TODO continue here: Now we need a good lemma for goMeteredFold.
-
-/-- The `(result, time, space)` triple produced by a single execution of a total fold
-    body on `c :: acc :: stack`. Derived from `meteredEvalProg`, so no extra data is
-    needed beyond the body, its well-formedness, and a totality witness. -/
-def Prog.foldStep {body : Prog} {stack : List Data}
-    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
-    (c acc : Data) : Data × ℕ × ℕ :=
-  (meteredEvalProg body (c :: acc :: stack) h_wf).get
-    (h_total (c :: acc :: stack) (by simp))
-
-lemma Prog.meteredEvalProg_eq_foldStep {body : Prog} {stack : List Data}
-    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
-    (c acc : Data) :
-    meteredEvalProg body (c :: acc :: stack) h_wf =
-      .some (Prog.foldStep h_wf h_total c acc) :=
-  (Part.some_get _).symm
-
-/-- Simp form of `goMeteredFold_of_step`: a *total* body uniquely determines the fold
-    semantics, with no free `step`/`stepTime`/`stepSpace` variables for `simp` to
-    invent. The data result is exactly `List.foldl` over `Prog.foldStep`. -/
-@[simp]
-lemma goMeteredFold_of_total {body : Prog} {stack : List Data}
-    (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
-    (xs : List Data) (acc : Data) :
-    goMeteredFold xs acc stack body h_wf = .some
-      (xs.foldl (fun a x => (Prog.foldStep h_wf h_total x a).1) acc,
-       foldTime (fun c a => (Prog.foldStep h_wf h_total c a).2.1)
-                (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc,
-       foldSpace (fun c a => (Prog.foldStep h_wf h_total c a).2.2)
-                 (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc) := by
-  induction xs generalizing acc with
-  | nil => simp [foldTime, foldSpace, goMeteredFold]
-  | cons x xs ih =>
-    simp [ih, foldTime, foldSpace, goMeteredFold]
-    rw [Prog.meteredEvalProg_eq_foldStep h_wf h_total]
-    simp_all
-
--- TODO: summary of current problems: We canont re-write the stuff inside a
--- `Part.bind` because that would change the type (although it is equal)
--- Solution: Get rid of Part
+-- -----------------------------------------------------------------------------------------
+-- --- The stuff below here still needs some work
+-- -----------------------------------------------------------------------------
 
-lemma prog_reverse.semantics (x : Data) (xs : List Data) :
-    (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp [prog_reverse])).1 =
-      Data.l (x.asList).reverse := by
-  have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
-      Data.l (xs.reverse ++ init.asList) := by
-    induction xs generalizing init with
-    | nil => simp
-    | cons x xs ih => simp [List.foldl, ih]
-  simp [prog_reverse, h]
+-- structure WellFormedProgram (inputs : ℕ) where
+--   prog : Prog
+--   h_wf : WFProg inputs prog
 
-theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
-  : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)
-    (fun n => 1 + 2 * n + n * n) (fun n => 1 + 2 * n + n * n) := by
-  refine ⟨_, _, _, _, ?_⟩
-  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
-  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]; use 1 + 2 * xs.size + xs.size * xs.size; omega
-  · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]; use 1 + 2 * xs.size + xs.size * xs.size; omega
-
-/-- Generic time cost of a metered fold whose body acts as a pure step
-    `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
-def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
-    : List Data → Data → ℕ
-  | [],      acc => acc.size
-  | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
-
-/-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
-def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
-    : List Data → Data → ℕ
-  | [],      acc => acc.size
-  | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
-
-/-- Generic space bound for `foldSpace` via a single budget `B`:
-    if `init.size ≤ B`, and for every reachable accumulator each iteration's per-step
-    space and the resulting accumulator both stay within `B`, then the entire fold's
-    space is at most `B`. -/
-lemma foldSpace_le {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
-    (B : ℕ) (xs : List Data) (init : Data) (hInit : init.size ≤ B)
-    (hStep : ∀ acc c, acc.size ≤ B → c ∈ xs →
-                stepSpace c acc ≤ B ∧ (step c acc).size ≤ B) :
-    foldSpace stepSpace step xs init ≤ B := by
-  induction xs generalizing init with
-  | nil => simpa [foldSpace] using hInit
-  | cons x xs ih =>
-    have ⟨hSp, hAcc⟩ := hStep init x hInit (List.mem_cons_self ..)
-    refine max_le hSp
-      (ih _ hAcc fun acc c hAcc' hc => hStep acc c hAcc' (List.mem_cons_of_mem _ hc))
-
-/-- Linear-space body + constant-size init ⟹ linear-space fold.
-
-    If every step costs space at most `s₁ * (c.size + acc.size) + s₂`, the accumulator
-    grows by at most `c.size + k` per item, and `init.size ≤ c₀`, then `foldSpace` is
-    linear in `(xs.map Data.size).sum + xs.length * k + c₀`. -/
-lemma fold_space_linear {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
-    {s₁ s₂ k c₀ : ℕ}
-    (hStepSpace : ∀ c acc, stepSpace c acc ≤ s₁ * (c.size + acc.size) + s₂)
-    (hGrowth : ∀ c acc, (step c acc).size ≤ acc.size + c.size + k)
-    (xs : List Data) (init : Data) (hInit : init.size ≤ c₀) :
-    foldSpace stepSpace step xs init ≤
-      max (c₀ + (xs.map Data.size).sum + xs.length * k)
-          (s₁ * ((xs.map Data.size).sum + c₀ + xs.length * k) + s₂) := by
-  -- Strengthen by allowing any starting bound `c₀'` on `init.size`.
-  suffices h : ∀ (xs : List Data) (init : Data) (c₀' : ℕ), init.size ≤ c₀' →
-      foldSpace stepSpace step xs init ≤
-        max (c₀' + (xs.map Data.size).sum + xs.length * k)
-            (s₁ * ((xs.map Data.size).sum + c₀' + xs.length * k) + s₂) from h xs init c₀ hInit
-  clear hInit init xs
-  intro xs
-  induction xs with
-  | nil => intro init c₀' hInit; simpa [foldSpace] using Or.inl (by omega)
-  | cons x xs ih =>
-    intro init c₀' hInit
-    have hStepSize : (step x init).size ≤ c₀' + x.size + k := by
-      have := hGrowth x init; omega
-    have ih' := ih (step x init) (c₀' + x.size + k) hStepSize
-    have hSp : stepSpace x init ≤
-        s₁ * (x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k) + s₂ := by
-      have := Nat.mul_le_mul_left s₁
-        (show x.size + init.size ≤ x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k by
-          omega)
-      have h1 := hStepSpace x init
-      omega
-    simp only [foldSpace, List.length_cons, List.map_cons, List.sum_cons]
-    refine max_le (le_trans hSp (le_max_right _ _)) (le_trans ih' (max_le_max ?_ ?_))
-    · have : (xs.length + 1) * k = xs.length * k + k := by ring
-      omega
-    · apply Nat.add_le_add_right
-      apply Nat.mul_le_mul_left
-      have : (xs.length + 1) * k = xs.length * k + k := by ring
-      omega
-
-/-- Generic semantics + time + space for any well-formed fold body that acts as a pure
-    deterministic step.
-
-    The hypothesis `hbody` must hold for every iteration: running `body` on a stack of the
-    form `c :: acc :: stack` (for any `c, acc`) produces `step c acc` with cost
-    `(stepTime c acc, stepSpace c acc)`. -/
-lemma goMeteredFold_of_step {body : Prog} {stack : List Data}
-    (h_wf : WFProg (stack.length + 2) body)
-    (step : Data → Data → Data) (stepTime stepSpace : Data → Data → ℕ)
-    (hbody : ∀ (c acc : Data),
-      meteredEvalProg body (c :: acc :: stack) h_wf =
-        .some (step c acc, stepTime c acc, stepSpace c acc))
-    (xs : List Data) (acc : Data) :
-    goMeteredFold xs acc stack body h_wf =
-      .some (xs.foldl (fun a x => step x a) acc,
-             foldTime stepTime step xs acc,
-             foldSpace stepSpace step xs acc) := by
-  induction xs generalizing acc with
-  | nil => simp [foldTime, foldSpace]
-  | cons x xs ih => simp [hbody, ih, foldTime, foldSpace]
-
-/-- Time cost of running the body `[.cons 0 1]` repeatedly over `xs`, threading `acc`. -/
-def revFoldTime (xs : List Data) (acc : Data) : ℕ :=
-  foldTime (fun x a => 1 + (Data.l (x :: a.asList)).size)
-           (fun x a => Data.l (x :: a.asList)) xs acc
-
-/-- Space cost of the same fold: maximum live size across iterations. -/
-def revFoldSpace (xs : List Data) (acc : Data) : ℕ :=
-  foldSpace (fun x a => 1 + (Data.l (x :: a.asList)).size)
-            (fun x a => Data.l (x :: a.asList)) xs acc
-
-/-- Combined semantics + time + space for the inner fold of `prog_reverse`. -/
-lemma goMeteredFold_reverseBody (xs : List Data) (acc : Data) (stack : List Data)
-    (h_wf : WFProg (stack.length + 2) [Operation.cons 0 1]) :
-    goMeteredFold xs acc stack [Operation.cons 0 1] h_wf =
-      .some (xs.foldl (fun a x => Data.l (x :: a.asList)) acc,
-             revFoldTime xs acc, revFoldSpace xs acc) := by
-  exact goMeteredFold_of_step h_wf
-    (fun x a => Data.l (x :: a.asList))
-    (fun x a => 1 + (Data.l (x :: a.asList)).size)
-    (fun x a => 1 + (Data.l (x :: a.asList)).size)
-    (by intro c acc'; simp [meteredEvalOp]) xs acc
-
-/-- The reverse-body fold reverses the input list, prepended onto the accumulator. -/
-lemma foldl_reverseBody (xs : List Data) (acc : Data) :
-    xs.foldl (fun a x => Data.l (x :: a.asList)) acc =
-      Data.l (xs.reverse ++ acc.asList) := by
-  induction xs generalizing acc with
-  | nil => cases acc with | l _ => simp [Data.asList]
-  | cons x xs ih => cases acc with | l _ => simp [ih, Data.asList, List.reverse_cons]
-
-/-- `prog_reverse` reverses its input list, with concrete time and space cost. -/
-theorem prog_reverse.semantics (xs : List Data) :
-    meteredEvalProg prog_reverse.prog [Data.l xs] prog_reverse.h_wf
-      = .some (Data.l xs.reverse,
-               1 + revFoldTime xs Data.empty,
-               1 + revFoldSpace xs Data.empty) := by
-  have h := goMeteredFold_reverseBody xs Data.empty [Data.empty, Data.l xs]
-    (by simp [WFProg, WFOp])
-  simp [prog_reverse, meteredEvalOp, h, foldl_reverseBody, Data.asList]
-
-/-- Convenient corollary: `prog_reverse.eval` returns the reversed list. -/
-theorem prog_reverse.eval_eq (xs : List Data) :
-    prog_reverse.eval [Data.l xs] rfl = .some (Data.l xs.reverse) := by
-  simp [WellFormedProgram.eval, prog_reverse.semantics]
-
--- Binary addition
-def prog_inc : WellFormedProgram := {
-  prog := [
-    .fold 0 1 [
-      .cons 0 2, -- cons the bit to the accumulator
-      .ite 2 [ -- if the new accumulator is nonempty (the bit was 1)
-        .cons 1 2, -- add the carry from the previous bit
-        .empty -- else just put the carry (0 or 1) as the new accumulator
-      ] [
-         .cons 1 2 -- if the new bit is zero, we only get a carry if the previous carry was one
-      ]
-    ]
-    -- TODO
-  ],
-  inputs := 2,
-  h_wf := by sorry
-}
-
-def add (x y : List Bool) : List Bool :=
-
-  match prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl with
-  | .some d => d.asList.map (fun b => b == dataTrue)
-  | .none => [] -- this should never happen since the program is total
-
-theorem prog_add_semantics : ∀ (x y : ℕ),
-    prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl =
-      .some (DataEncode.encode (x + y)) := by
-  sorry
+-- --- The output stack size of the program.
+-- abbrev WellFormedProgram.stackSize {inputs : ℕ} (p : WellFormedProgram inputs) : ℕ :=
+--    inputs + p.prog.length
 
+-- def FunType (inputs : ℕ) : Type := match inputs with
+--   | 0 => Data
+--   | n + 1 => Data → FunType n
 
-mutual
-  def WhileFreeOp : Operation → Prop
-    | .while_ _ _ => False
-    | .fold _ _ b => WhileFreeProg b
-    | _           => True
+-- @[simp]
+-- def WellFormedProgram.eval {inputs : ℕ} (p : WellFormedProgram inputs)
+--     (stack : List Data) (h_len : stack.length ≥ inputs) : Part Data :=
+--   (meteredEvalProg p.prog stack (by sorry)).map fun (d, _, _) => d
 
-  def WhileFreeProg : Prog → Prop
-    | []         => True
-    | op :: rest => WhileFreeOp op ∧ WhileFreeProg rest
-end
+-- @[simp]
+-- def WellFormedProgram.time {inputs : ℕ} (p : WellFormedProgram inputs)
+--     (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
+--   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, t, _) => t
 
-theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p.Total := by
-  intro data h_len
-  induction h : p.prog generalizing data with
-  | nil =>
-    simp [WellFormedProgram.eval, evalProg, h]
-  | cons op rest ih =>
-    simp [WellFormedProgram.eval, h]
-    cases op with
-    | empty =>
-      unfold evalProg evalOp
-      simp
-      sorry
-    | cons h t => sorry
-    | head i => sorry
-    | tail i => sorry
-    | eq i j => sorry
-    | ite i then_ else_ => sorry
-    | fold l i body => sorry
-    | while_ i body => sorry
+-- @[simp]
+-- def WellFormedProgram.space {inputs : ℕ} (p : WellFormedProgram inputs)
+--     (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
+--   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
 
+-- structure TotalProgram (inputs : ℕ) extends WellFormedProgram inputs where
+--   h_total : toWellFormedProgram.prog.Total toWellFormedProgram.h_wf
 
--- Now the most important part: If a program is total, and well-formed we can talk about the
--- function computed by the program - this is something that was not really possible with my old
--- design:
+-- def TotalProgram.eval {inputs : ℕ} (p : TotalProgram inputs)
+--     (stack : List Data) (h_len : stack.length ≥ inputs) : Data :=
+--   (p.toWellFormedProgram.eval stack h_len).get (p.h_total stack sorry)
 
--- With these at hand, we can define simp lemmas and thus auto-derive semantics
--- and maybe even resource requirements of programs:
+-- /-- Unfolding lemma that lets `simp` "execute" a `TotalProgram` step-by-step: it
+--     rewrites `p.eval stack h_len` into a form mentioning `meteredEvalProg` directly,
+--     so the `@[simp]` equations for `meteredEvalProg`/`meteredEvalOp` together with
+--     `Part.some_bind`, `Part.map_some`, `Part.get_some` can reduce the program. -/
+-- @[simp]
+-- theorem TotalProgram.eval_eq {inputs : ℕ} (p : TotalProgram inputs)
+--     (stack : List Data) (h_len : stack.length ≥ inputs) :
+--     p.eval stack h_len =
+--       ((meteredEvalProg p.prog stack (by sorry)).get
+--          (by simpa [WellFormedProgram.eval] using p.h_total stack sorry)).1 := by
+--   simp [TotalProgram.eval, WellFormedProgram.eval]
+
+-- def TotalProgram.as_fun {inputs : ℕ} (p : TotalProgram inputs) :
+--     FunType inputs :=
+--   sorry
 
+-- -- examples:
+-- def prog_true : WellFormedProgram 0 := {
+--   prog := [.empty, .cons 0 0],
+--   h_wf := by simp [WFProg, WFOp]
+-- }
+-- def prog_false : WellFormedProgram 0 := {
+--   prog := [.empty],
+--   h_wf := by simp [WFProg, WFOp]
+-- }
+-- def prog_negate : WellFormedProgram 1 := {
+--   prog := [.eq 0 0],
+--   h_wf := by simp [WFProg, WFOp]
+-- }
+-- lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
+--   simp [prog_true, meteredEvalOp]
+
+-- lemma prog_true.space : prog_true.space [] rfl = .some 6 := by
+--   simp [prog_true, meteredEvalOp, Data.size]
+
+-- lemma prog_true.time : prog_true.time [] rfl = .some 6 := by
+--   simp [prog_true, meteredEvalOp, Data.size]
+
+-- def WellFormedProgram.append {in₁ in₁ : ℕ}
+--     (p₁ : WellFormedProgram in₁) (p₂ : WellFormedProgram in₂) (h_le : in₂ ≤ p₁.stackSize) :
+--     WellFormedProgram in₁ :=
+--   { prog := p₁.prog ++ p₂.prog, h_wf := by sorry }
+
+
+-- def RunsInSpace {inputs : ℕ} (p : WellFormedProgram inputs) (s : ℕ → ℕ) : Prop :=
+--   ∃ s₁ s₂, ∀ x, (h_l : x.length = inputs) → ∃ s' ≤ s₁ * (s (Data.l x).size) + s₂,
+--   p.space x h_l = .some s'
+
+-- def RunsInTime {inputs : ℕ} (p : WellFormedProgram inputs) (t : ℕ → ℕ) : Prop :=
+--   ∃ t₁ t₂, ∀ x, (h_l : x.length = inputs) → ∃ t' ≤ t₁ * (t (Data.l x).size) + t₂,
+--   p.time x h_l = .some t'
+
+-- def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β]
+--   (p : WellFormedProgram 1) (f : α → β) (t s : ℕ → ℕ) : Prop :=
+--   ∃ t₁ t₂ s₁ s₂,
+--     (∀ x : α, p.eval [DataEncode.encode x] sorry = .some (DataEncode.encode (f x))) ∧
+--     (∀ x : α, ∃ t' ≤ t₁ * (t (DataEncode.encode x).size) + t₂,
+--         p.time [DataEncode.encode x] rfl = .some t') ∧
+--     (∀ x : α, ∃ s' ≤ s₁ * (s (DataEncode.encode x).size) + s₂,
+--         p.space [DataEncode.encode x] sorry = .some s')
+
+-- def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
+--   (f : α → β) (t s : ℕ → ℕ) : Prop :=
+--   ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
+
+
+-- def prog_reverse : TotalProgram 1 := {
+--   prog := [
+--     .empty,
+--     .fold [
+--       .cons 0 1
+--     ] 0 1
+--   ],
+--   h_wf := by simp [WFProg, WFOp]
+--   h_total := by simp
+-- }
+
+-- -- TODO continue here: Now we need a good lemma for goMeteredFold.
+
+-- /-- The `(result, time, space)` triple produced by a single execution of a total fold
+--     body on `c :: acc :: stack`. Derived from `meteredEvalProg`, so no extra data is
+--     needed beyond the body, its well-formedness, and a totality witness. -/
+-- def Prog.foldStep {body : Prog} {stack : List Data}
+--     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+--     (c acc : Data) : Data × ℕ × ℕ :=
+--   (meteredEvalProg body (c :: acc :: stack) h_wf).get
+--     (h_total (c :: acc :: stack) (by simp))
+
+-- lemma Prog.meteredEvalProg_eq_foldStep {body : Prog} {stack : List Data}
+--     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+--     (c acc : Data) :
+--     meteredEvalProg body (c :: acc :: stack) h_wf =
+--       .some (Prog.foldStep h_wf h_total c acc) :=
+--   (Part.some_get _).symm
+
+-- /-- Simp form of `goMeteredFold_of_step`: a *total* body uniquely determines the fold
+--     semantics, with no free `step`/`stepTime`/`stepSpace` variables for `simp` to
+--     invent. The data result is exactly `List.foldl` over `Prog.foldStep`. -/
 -- @[simp]
--- theorem evalFold_eq_foldl
---     (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
---     (body : Prog) (h : WellFormedTotal body)
---     (rest : Prog) :
---     evalProg ((.fold l i body) :: rest) stack =
---     .some (some (stack ++ [(stack[l].asList.foldl
---       (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
---       stack[i])])) := by
+-- lemma goMeteredFold_of_total {body : Prog} {stack : List Data}
+--     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
+--     (xs : List Data) (acc : Data) :
+--     goMeteredFold xs acc stack body h_wf = .some
+--       (xs.foldl (fun a x => (Prog.foldStep h_wf h_total x a).1) acc,
+--        foldTime (fun c a => (Prog.foldStep h_wf h_total c a).2.1)
+--                 (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc,
+--        foldSpace (fun c a => (Prog.foldStep h_wf h_total c a).2.2)
+--                  (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc) := by
+--   induction xs generalizing acc with
+--   | nil => simp [foldTime, foldSpace, goMeteredFold]
+--   | cons x xs ih =>
+--     simp [ih, foldTime, foldSpace, goMeteredFold]
+--     rw [Prog.meteredEvalProg_eq_foldStep h_wf h_total]
+--     simp_all
+
+-- -- TODO: summary of current problems: We canont re-write the stuff inside a
+-- -- `Part.bind` because that would change the type (although it is equal)
+-- -- Solution: Get rid of Part
+
+-- lemma prog_reverse.semantics (x : Data) (xs : List Data) :
+--     (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp [prog_reverse])).1 =
+--       Data.l (x.asList).reverse := by
+--   have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
+--       Data.l (xs.reverse ++ init.asList) := by
+--     induction xs generalizing init with
+--     | nil => simp
+--     | cons x xs ih => simp [List.foldl, ih]
+--   simp [prog_reverse, h]
+
+-- theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
+--   : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)
+--     (fun n => 1 + 2 * n + n * n) (fun n => 1 + 2 * n + n * n) := by
+--   refine ⟨_, _, _, _, ?_⟩
+--   · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+--   · intro xs
+--     simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+--     use 1 + 2 * xs.size + xs.size * xs.size
+--     omega
+--   · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
+--     use 1 + 2 * xs.size + xs.size * xs.size; omega
+
+-- /-- Generic time cost of a metered fold whose body acts as a pure step
+--     `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
+-- def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
+--     : List Data → Data → ℕ
+--   | [],      acc => acc.size
+--   | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
+
+-- /-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
+-- def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
+--     : List Data → Data → ℕ
+--   | [],      acc => acc.size
+--   | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
+
+-- /-- Generic space bound for `foldSpace` via a single budget `B`:
+--     if `init.size ≤ B`, and for every reachable accumulator each iteration's per-step
+--     space and the resulting accumulator both stay within `B`, then the entire fold's
+--     space is at most `B`. -/
+-- lemma foldSpace_le {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
+--     (B : ℕ) (xs : List Data) (init : Data) (hInit : init.size ≤ B)
+--     (hStep : ∀ acc c, acc.size ≤ B → c ∈ xs →
+--                 stepSpace c acc ≤ B ∧ (step c acc).size ≤ B) :
+--     foldSpace stepSpace step xs init ≤ B := by
+--   induction xs generalizing init with
+--   | nil => simpa [foldSpace] using hInit
+--   | cons x xs ih =>
+--     have ⟨hSp, hAcc⟩ := hStep init x hInit (List.mem_cons_self ..)
+--     refine max_le hSp
+--       (ih _ hAcc fun acc c hAcc' hc => hStep acc c hAcc' (List.mem_cons_of_mem _ hc))
+
+-- /-- Linear-space body + constant-size init ⟹ linear-space fold.
+
+--     If every step costs space at most `s₁ * (c.size + acc.size) + s₂`, the accumulator
+--     grows by at most `c.size + k` per item, and `init.size ≤ c₀`, then `foldSpace` is
+--     linear in `(xs.map Data.size).sum + xs.length * k + c₀`. -/
+-- lemma fold_space_linear {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
+--     {s₁ s₂ k c₀ : ℕ}
+--     (hStepSpace : ∀ c acc, stepSpace c acc ≤ s₁ * (c.size + acc.size) + s₂)
+--     (hGrowth : ∀ c acc, (step c acc).size ≤ acc.size + c.size + k)
+--     (xs : List Data) (init : Data) (hInit : init.size ≤ c₀) :
+--     foldSpace stepSpace step xs init ≤
+--       max (c₀ + (xs.map Data.size).sum + xs.length * k)
+--           (s₁ * ((xs.map Data.size).sum + c₀ + xs.length * k) + s₂) := by
+--   -- Strengthen by allowing any starting bound `c₀'` on `init.size`.
+--   suffices h : ∀ (xs : List Data) (init : Data) (c₀' : ℕ), init.size ≤ c₀' →
+--       foldSpace stepSpace step xs init ≤
+--         max (c₀' + (xs.map Data.size).sum + xs.length * k)
+--             (s₁ * ((xs.map Data.size).sum + c₀' + xs.length * k) + s₂) from h xs init c₀ hInit
+--   clear hInit init xs
+--   intro xs
+--   induction xs with
+--   | nil => intro init c₀' hInit; simpa [foldSpace] using Or.inl (by omega)
+--   | cons x xs ih =>
+--     intro init c₀' hInit
+--     have hStepSize : (step x init).size ≤ c₀' + x.size + k := by
+--       have := hGrowth x init; omega
+--     have ih' := ih (step x init) (c₀' + x.size + k) hStepSize
+--     have hSp : stepSpace x init ≤
+--         s₁ * (x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k) + s₂ := by
+--       have := Nat.mul_le_mul_left s₁
+--         (show x.size + init.size ≤ x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k by
+--           omega)
+--       have h1 := hStepSpace x init
+--       omega
+--     simp only [foldSpace, List.length_cons, List.map_cons, List.sum_cons]
+--     refine max_le (le_trans hSp (le_max_right _ _)) (le_trans ih' (max_le_max ?_ ?_))
+--     · have : (xs.length + 1) * k = xs.length * k + k := by ring
+--       omega
+--     · apply Nat.add_le_add_right
+--       apply Nat.mul_le_mul_left
+--       have : (xs.length + 1) * k = xs.length * k + k := by ring
+--       omega
+
+-- /-- Generic semantics + time + space for any well-formed fold body that acts as a pure
+--     deterministic step.
+
+--     The hypothesis `hbody` must hold for every iteration: running `body` on a stack of the
+--     form `c :: acc :: stack` (for any `c, acc`) produces `step c acc` with cost
+--     `(stepTime c acc, stepSpace c acc)`. -/
+-- lemma goMeteredFold_of_step {body : Prog} {stack : List Data}
+--     (h_wf : WFProg (stack.length + 2) body)
+--     (step : Data → Data → Data) (stepTime stepSpace : Data → Data → ℕ)
+--     (hbody : ∀ (c acc : Data),
+--       meteredEvalProg body (c :: acc :: stack) h_wf =
+--         .some (step c acc, stepTime c acc, stepSpace c acc))
+--     (xs : List Data) (acc : Data) :
+--     goMeteredFold xs acc stack body h_wf =
+--       .some (xs.foldl (fun a x => step x a) acc,
+--              foldTime stepTime step xs acc,
+--              foldSpace stepSpace step xs acc) := by
+--   induction xs generalizing acc with
+--   | nil => simp [foldTime, foldSpace]
+--   | cons x xs ih => simp [hbody, ih, foldTime, foldSpace]
+
+-- /-- Time cost of running the body `[.cons 0 1]` repeatedly over `xs`, threading `acc`. -/
+-- def revFoldTime (xs : List Data) (acc : Data) : ℕ :=
+--   foldTime (fun x a => 1 + (Data.l (x :: a.asList)).size)
+--            (fun x a => Data.l (x :: a.asList)) xs acc
+
+-- /-- Space cost of the same fold: maximum live size across iterations. -/
+-- def revFoldSpace (xs : List Data) (acc : Data) : ℕ :=
+--   foldSpace (fun x a => 1 + (Data.l (x :: a.asList)).size)
+--             (fun x a => Data.l (x :: a.asList)) xs acc
+
+-- /-- Combined semantics + time + space for the inner fold of `prog_reverse`. -/
+-- lemma goMeteredFold_reverseBody (xs : List Data) (acc : Data) (stack : List Data)
+--     (h_wf : WFProg (stack.length + 2) [Operation.cons 0 1]) :
+--     goMeteredFold xs acc stack [Operation.cons 0 1] h_wf =
+--       .some (xs.foldl (fun a x => Data.l (x :: a.asList)) acc,
+--              revFoldTime xs acc, revFoldSpace xs acc) := by
+--   exact goMeteredFold_of_step h_wf
+--     (fun x a => Data.l (x :: a.asList))
+--     (fun x a => 1 + (Data.l (x :: a.asList)).size)
+--     (fun x a => 1 + (Data.l (x :: a.asList)).size)
+--     (by intro c acc'; simp [meteredEvalOp]) xs acc
+
+-- /-- The reverse-body fold reverses the input list, prepended onto the accumulator. -/
+-- lemma foldl_reverseBody (xs : List Data) (acc : Data) :
+--     xs.foldl (fun a x => Data.l (x :: a.asList)) acc =
+--       Data.l (xs.reverse ++ acc.asList) := by
+--   induction xs generalizing acc with
+--   | nil => cases acc with | l _ => simp [Data.asList]
+--   | cons x xs ih => cases acc with | l _ => simp [ih, Data.asList, List.reverse_cons]
+
+-- /-- `prog_reverse` reverses its input list, with concrete time and space cost. -/
+-- theorem prog_reverse.semantics (xs : List Data) :
+--     meteredEvalProg prog_reverse.prog [Data.l xs] prog_reverse.h_wf
+--       = .some (Data.l xs.reverse,
+--                1 + revFoldTime xs Data.empty,
+--                1 + revFoldSpace xs Data.empty) := by
+--   have h := goMeteredFold_reverseBody xs Data.empty [Data.empty, Data.l xs]
+--     (by simp [WFProg, WFOp])
+--   simp [prog_reverse, meteredEvalOp, h, foldl_reverseBody, Data.asList]
+
+-- /-- Convenient corollary: `prog_reverse.eval` returns the reversed list. -/
+-- theorem prog_reverse.eval_eq (xs : List Data) :
+--     prog_reverse.eval [Data.l xs] rfl = .some (Data.l xs.reverse) := by
+--   simp [WellFormedProgram.eval, prog_reverse.semantics]
+
+-- -- Binary addition
+-- def prog_inc : WellFormedProgram := {
+--   prog := [
+--     .fold 0 1 [
+--       .cons 0 2, -- cons the bit to the accumulator
+--       .ite 2 [ -- if the new accumulator is nonempty (the bit was 1)
+--         .cons 1 2, -- add the carry from the previous bit
+--         .empty -- else just put the carry (0 or 1) as the new accumulator
+--       ] [
+--          .cons 1 2 -- if the new bit is zero, we only get a carry if the previous carry was one
+--       ]
+--     ]
+--     -- TODO
+--   ],
+--   inputs := 2,
+--   h_wf := by sorry
+-- }
+
+-- def add (x y : List Bool) : List Bool :=
+
+--   match prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl with
+--   | .some d => d.asList.map (fun b => b == dataTrue)
+--   | .none => [] -- this should never happen since the program is total
+
+-- theorem prog_add_semantics : ∀ (x y : ℕ),
+--     prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl =
+--       .some (DataEncode.encode (x + y)) := by
 --   sorry
 
 
--- ================= Builder monad
---
--- The problem with writing programs directly is that tape indices are top-relative
--- (0 = newest item), so every push shifts all existing indices by 1.
---
--- The builder monad solves this by working with *bottom-indexed* references internally.
--- A `Ref` stores the absolute position of a stack slot counting from the bottom (oldest = 0).
--- Bottom-indices are stable: pushing a new item never changes any existing Ref.
--- When an Operation is about to be emitted, we convert the stored bottom-index
--- to the top-relative index expected by the machine: `currentHeight - 1 - bottomIndex`.
---
--- The builder additionally **carries a proof of well-formedness** in its state, so that
--- `Build.run` returns a `WellFormedProgram` *by construction*, with no exceptions, no
--- `Option`, and no post-hoc decidable check.
-
-/-- A weakening of `WFProg` that holds for the empty program at any `n` (including `0`).
-    Used as the in-flight invariant of the builder, since intermediate states may have
-    `prog = []` while `n_initial = 0`. -/
-def WFProgRaw : ℕ → Prog → Prop
-  | _, []         => True
-  | n, op :: rest => WFOp n op ∧ WFProgRaw (n + 1) rest
-
-/-- Snoc a single op (well-formed at the post-state height) onto a `WFProgRaw` program. -/
-theorem WFProgRaw.append_op :
-    ∀ {n : ℕ} {prog : Prog} {op : Operation},
-      WFProgRaw n prog → WFOp (n + prog.length) op → WFProgRaw n (prog ++ [op])
-  | n, [], op, _, h_op => by
-    refine ⟨?_, trivial⟩
-    show WFOp n op
-    simpa using h_op
-  | n, o :: rest, op, h_p, h_op => by
-    obtain ⟨h_o, h_rest⟩ := h_p
-    refine ⟨h_o, ?_⟩
-    have h_op' : WFOp (n + 1 + rest.length) op := by
-      have heq : n + (o :: rest).length = n + 1 + rest.length := by
-        simp [List.length_cons]; omega
-      rw [heq] at h_op
-      exact h_op
-    exact WFProgRaw.append_op h_rest h_op'
-
-/-- A `WFProgRaw` program with at least one element on the post-execution stack
-    (i.e. `n_initial + prog.length > 0`) lifts to a full `WFProg`. -/
-theorem WFProgRaw_to_WFProg :
-    ∀ {n : ℕ} {prog : Prog}, WFProgRaw n prog → n + prog.length ≠ 0 → WFProg n prog
-  | n, [], _, hpos => by simpa using hpos
-  | _, _ :: rest, h_p, _ => by
-    obtain ⟨h_op, h_rest⟩ := h_p
-    refine ⟨h_op, ?_⟩
-    apply WFProgRaw_to_WFProg h_rest
-    simp
-
-/-- Monad state: the initial stack size, the ops collected so far, and a proof that
-    the collected ops form a well-formed program at that initial stack size. -/
-structure BuildCtx where
-  n_initial : ℕ
-  prog : Prog := []
-  h_wf : WFProgRaw n_initial prog := by trivial
-
-/-- The current stack height of a build context. -/
-@[simp] def BuildCtx.height (c : BuildCtx) : ℕ := c.n_initial + c.prog.length
-
-/-- The builder monad: a state monad over `BuildCtx`. -/
-abbrev Build := StateM BuildCtx
-
-/-- A stable reference to a stack slot.  `val` is the slot's bottom-index (oldest = 0).
-    `bound` is a snapshot of `currentHeight` at the moment the ref was minted; the
-    invariant `val < bound` is what makes the ref usable.  All refs produced by the
-    builder API satisfy `bound ≤ currentHeight` from the moment of mint onwards
-    (since heights only grow). -/
-structure Ref where
-  val : ℕ
-  bound : ℕ
-  h_lt : val < bound
-
-/-- Current stack height (= `n_initial + prog.length`). -/
-def Build.currentHeight : Build ℕ := do
-  let ctx ← get
-  return ctx.height
-
-/-- Extend a `BuildCtx` by appending one well-formed operation. -/
-private def BuildCtx.extend (ctx : BuildCtx) (op : Operation) (h_op : WFOp ctx.height op) :
-    BuildCtx :=
-  { n_initial := ctx.n_initial
-    prog := ctx.prog ++ [op]
-    h_wf := WFProgRaw.append_op ctx.h_wf (by simpa [BuildCtx.height] using h_op) }
-
-@[simp] theorem BuildCtx.extend_n_initial (ctx : BuildCtx) (op : Operation)
-    (h_op : WFOp ctx.height op) : (ctx.extend op h_op).n_initial = ctx.n_initial := rfl
-
-@[simp] theorem BuildCtx.extend_height (ctx : BuildCtx) (op : Operation)
-    (h_op : WFOp ctx.height op) : (ctx.extend op h_op).height = ctx.height + 1 := by
-  simp [BuildCtx.extend, BuildCtx.height, List.length_append, Nat.add_assoc]
-
-/-- Obtain a `Ref` to an item that already exists in the initial stack.
-    `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom.
-    If `j ≥ n_initial` the resulting `Ref` will be invalid; calls using such a ref will
-    silently fall back to emitting `.empty`. -/
-def Build.inputRef (j : TapeIndex) : Build Ref := do
-  let ctx ← get
-  let h := ctx.height
-  if hp : ctx.n_initial > 0 then
-    -- val = ctx.n_initial - 1 - j (clamped at 0 for j ≥ n_initial); bound = h ≥ n_initial > 0
-    let v := if j < ctx.n_initial then ctx.n_initial - 1 - j else 0
-    return ⟨v, h, by simp [v, BuildCtx.height]; split <;> sorry⟩
-  else
-    -- No initial inputs: return a sentinel; can't be used since bound > val always fails.
-    return ⟨0, 1, Nat.lt_succ_self _⟩
-
--- ── Primitive operations ──────────────────────────────────────────────────────
-
-/-- Emit an `.empty` operation; returns a `Ref` to the new (empty) item on top. -/
-def Build.empty : Build Ref := do
-  let ctx ← get
-  let h := ctx.height
-  let h_op : WFOp h .empty := trivial
-  set (ctx.extend .empty h_op)
-  return ⟨h, h + 1, Nat.lt_succ_self _⟩
-
-/-- Emit `.cons h t`. If either ref's bound exceeds the current height (impossible by
-    API contract), silently emits `.empty` instead so that the WF invariant is preserved. -/
-def Build.cons (h t : Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hh : h.bound ≤ height then
-    if ht : t.bound ≤ height then
-      have h_hv : h.val < height := Nat.lt_of_lt_of_le h.h_lt hh
-      have h_tv : t.val < height := Nat.lt_of_lt_of_le t.h_lt ht
-      let i := height - 1 - h.val
-      let j := height - 1 - t.val
-      let op : Operation := .cons i j
-      have hi : i < height := by simp [i]; omega
-      have hj : j < height := by simp [j]; omega
-      have h_op : WFOp height op := ⟨hi, hj⟩
-      set (ctx.extend op h_op)
-      return ⟨height, height + 1, Nat.lt_succ_self _⟩
-    else
-      Build.empty
-  else
-    Build.empty
-
-/-- Emit `.head r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
-def Build.head (r : Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hr : r.bound ≤ height then
-    have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
-    let i := height - 1 - r.val
-    let op : Operation := .head i
-    have hi : i < height := by simp [i]; omega
-    have h_op : WFOp height op := hi
-    set (ctx.extend op h_op)
-    return ⟨height, height + 1, Nat.lt_succ_self _⟩
-  else
-    Build.empty
-
-/-- Emit `.tail r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
-def Build.tail (r : Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hr : r.bound ≤ height then
-    have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
-    let i := height - 1 - r.val
-    let op : Operation := .tail i
-    have hi : i < height := by simp [i]; omega
-    have h_op : WFOp height op := hi
-    set (ctx.extend op h_op)
-    return ⟨height, height + 1, Nat.lt_succ_self _⟩
-  else
-    Build.empty
-
-/-- Emit `.eq r s`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
-def Build.eq (r s : Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hr : r.bound ≤ height then
-    if hs : s.bound ≤ height then
-      have h_rv : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
-      have h_sv : s.val < height := Nat.lt_of_lt_of_le s.h_lt hs
-      let i := height - 1 - r.val
-      let j := height - 1 - s.val
-      let op : Operation := .eq i j
-      have hi : i < height := by simp [i]; omega
-      have hj : j < height := by simp [j]; omega
-      have h_op : WFOp height op := ⟨hi, hj⟩
-      set (ctx.extend op h_op)
-      return ⟨height, height + 1, Nat.lt_succ_self _⟩
-    else
-      Build.empty
-  else
-    Build.empty
-
--- ── Combinators ───────────────────────────────────────────────────────────────
-
-/-- Run a sub-program builder in a fresh context whose initial stack height is `subN`,
-    returning the compiled `Prog` together with a `WFProg subN` proof.
-    The caller must supply `h_pos : subN > 0` so that the empty-`prog` case is handled.
-    `extraRefs` are the `Ref`s for the `subN - h` items prepended on top of the outer
-    stack (e.g. `[child, acc]` for `fold`). -/
-private def Build.subProg (subN : ℕ) (h_pos : subN > 0)
-    (extraRefs : Array Ref) (inner : Array Ref → Build Ref) :
-    Build { p : Prog // WFProg subN p } := do
-  let init : BuildCtx := { n_initial := subN, prog := [], h_wf := trivial }
-  let (_, subCtx) := StateT.run (inner extraRefs) init
-  -- Trust that the smart constructors do not change `n_initial`; if some user code
-  -- did, we fall back to a trivial WF program of length 1.
-  if h_eq : subCtx.n_initial = subN then
-    have h_wf_raw : WFProgRaw subN subCtx.prog := h_eq ▸ subCtx.h_wf
-    have h_pos' : subN + subCtx.prog.length ≠ 0 := by omega
-    return ⟨subCtx.prog, WFProgRaw_to_WFProg h_wf_raw h_pos'⟩
-  else
-    have h_wf : WFProg subN [Operation.empty] := by
-      refine ⟨trivial, ?_⟩
-      show subN + 1 ≠ 0
-      omega
-    return ⟨[Operation.empty], h_wf⟩
-
-/-- Build the bottom-index `Ref`s for the `extra` items prepended on top of the outer
-    stack `h` when entering a sub-builder.  Returns refs in order
-    `[topmost prepended, …, bottommost prepended]`. -/
-private def Build.extraRefs (h extra : ℕ) : Array Ref :=
-  (Array.range extra).map fun k =>
-    let v := h + extra - 1 - k
-    have h_lt : v < h + extra := by simp [v]; omega
-    ⟨v, h + extra, h_lt⟩
-
-/-- Branch on `cond`: if `cond == dataTrue` run `then_`, else run `else_`.
-    Both branches see the same outer stack.  Each branch must return the `Ref` it
-    wants as the result. -/
-def Build.ite (cond : Ref) (then_ else_ : Build Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hc : cond.bound ≤ height then
-    have h_v : cond.val < height := Nat.lt_of_lt_of_le cond.h_lt hc
-    let i := height - 1 - cond.val
-    have hi : i < height := by simp [i]; omega
-    have h_pos : height > 0 := by omega
-    let ⟨thenProg, h_then⟩ ← Build.subProg height h_pos (Build.extraRefs height 0) (fun _ => then_)
-    let ⟨elseProg, h_else⟩ ← Build.subProg height h_pos (Build.extraRefs height 0) (fun _ => else_)
-    let op : Operation := .ite i thenProg elseProg
-    have h_op : WFOp height op := ⟨hi, h_then, h_else⟩
-    set (ctx.extend op h_op)
-    return ⟨height, height + 1, Nat.lt_succ_self _⟩
-  else
-    Build.empty
-
-/-- Fold over the children of `list_`, starting with accumulator `acc_`, using `body`.
-    `body` receives `(child, acc)` as `Ref`s; outer `Ref`s remain valid unchanged. -/
-def Build.fold (list_ acc_ : Ref) (body : Ref → Ref → Build Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hl : list_.bound ≤ height then
-    if ha : acc_.bound ≤ height then
-      have h_lv : list_.val < height := Nat.lt_of_lt_of_le list_.h_lt hl
-      have h_av : acc_.val < height := Nat.lt_of_lt_of_le acc_.h_lt ha
-      let li := height - 1 - list_.val
-      let ai := height - 1 - acc_.val
-      have hli : li < height := by simp [li]; omega
-      have hai : ai < height := by simp [ai]; omega
-      have h_pos : height + 2 > 0 := by omega
-      let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 2) h_pos
-        (Build.extraRefs height 2) (fun extra => body extra[0]! extra[1]!)
-      let op : Operation := .fold li ai bodyProg
-      have h_op : WFOp height op := ⟨hli, hai, h_body⟩
-      set (ctx.extend op h_op)
-      return ⟨height, height + 1, Nat.lt_succ_self _⟩
-    else
-      Build.empty
-  else
-    Build.empty
-
-/-- While `cond_` is nonempty, run `body`.  `body` receives one `Ref` for the current
-    accumulator (= the current value of `cond_` on top of the outer stack). -/
-def Build.while_ (cond_ : Ref) (body : Ref → Build Ref) : Build Ref := do
-  let ctx ← get
-  let height := ctx.height
-  if hc : cond_.bound ≤ height then
-    have h_v : cond_.val < height := Nat.lt_of_lt_of_le cond_.h_lt hc
-    let i := height - 1 - cond_.val
-    have hi : i < height := by simp [i]; omega
-    have h_pos : height + 1 > 0 := by omega
-    let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 1) h_pos
-      (Build.extraRefs height 1) (fun extra => body extra[0]!)
-    let op : Operation := .while_ i bodyProg
-    have h_op : WFOp height op := ⟨hi, h_body⟩
-    set (ctx.extend op h_op)
-    return ⟨height, height + 1, Nat.lt_succ_self _⟩
-  else
-    Build.empty
-
--- ── Running the builder ───────────────────────────────────────────────────────
-
-/-- Run a builder that starts with `n_initial` pre-existing stack items, producing a
-    `WellFormedProgram` *by construction*.  If the user's builder produces no ops and
-    `n_initial = 0`, an `.empty` op is appended so that the result is always a
-    syntactically valid `WFProg` (which requires the post-execution stack to be
-    non-empty). -/
-def Build.run (n_initial : ℕ) (b : Build Ref) : WellFormedProgram :=
-  let init : BuildCtx := { n_initial, prog := [], h_wf := trivial }
-  let (_, ctx) := StateT.run b init
-  if h_pos : ctx.height ≠ 0 then
-    ⟨ctx.prog, ctx.n_initial, WFProgRaw_to_WFProg ctx.h_wf (by simpa [BuildCtx.height] using h_pos)⟩
-  else
-    -- height = 0 ⇒ n_initial = 0 ∧ prog = []; emit a sentinel `.empty` to satisfy WFProg.
-    let extended := ctx.extend .empty trivial
-    have h_pos' : extended.n_initial + extended.prog.length ≠ 0 := by
-      simp [extended, BuildCtx.extend, List.length_append]
-    ⟨extended.prog, extended.n_initial, WFProgRaw_to_WFProg extended.h_wf h_pos'⟩
-
-/-- Convenience: `Build.run` for programs that take no initial input. -/
-def Build.runFresh (b : Build Ref) : WellFormedProgram := Build.run 0 b
-
-
-def funFalse : WellFormedProgram := Build.runFresh do
-  Build.empty
-
-def funTrue : WellFormedProgram := Build.runFresh do
-  let a ← Build.empty
-  Build.cons a a
-
-#eval funFalse.prog
-#eval funTrue.prog
+-- mutual
+--   def WhileFreeOp : Operation → Prop
+--     | .while_ _ _ => False
+--     | .fold _ _ b => WhileFreeProg b
+--     | _           => True
+
+--   def WhileFreeProg : Prog → Prop
+--     | []         => True
+--     | op :: rest => WhileFreeOp op ∧ WhileFreeProg rest
+-- end
+
+-- theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p.Total := by
+--   intro data h_len
+--   induction h : p.prog generalizing data with
+--   | nil =>
+--     simp [WellFormedProgram.eval, evalProg, h]
+--   | cons op rest ih =>
+--     simp [WellFormedProgram.eval, h]
+--     cases op with
+--     | empty =>
+--       unfold evalProg evalOp
+--       simp
+--       sorry
+--     | cons h t => sorry
+--     | head i => sorry
+--     | tail i => sorry
+--     | eq i j => sorry
+--     | ite i then_ else_ => sorry
+--     | fold l i body => sorry
+--     | while_ i body => sorry
+
+
+-- -- Now the most important part: If a program is total, and well-formed we can talk about the
+-- -- function computed by the program - this is something that was not really possible with my old
+-- -- design:
+
+-- -- With these at hand, we can define simp lemmas and thus auto-derive semantics
+-- -- and maybe even resource requirements of programs:
+
+-- -- @[simp]
+-- -- theorem evalFold_eq_foldl
+-- --     (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
+-- --     (body : Prog) (h : WellFormedTotal body)
+-- --     (rest : Prog) :
+-- --     evalProg ((.fold l i body) :: rest) stack =
+-- --     .some (some (stack ++ [(stack[l].asList.foldl
+-- --       (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
+-- --       stack[i])])) := by
+-- --   sorry
+
+
+-- -- ================= Builder monad
+-- --
+-- -- The problem with writing programs directly is that tape indices are top-relative
+-- -- (0 = newest item), so every push shifts all existing indices by 1.
+-- --
+-- -- The builder monad solves this by working with *bottom-indexed* references internally.
+-- -- A `Ref` stores the absolute position of a stack slot counting from the bottom (oldest = 0).
+-- -- Bottom-indices are stable: pushing a new item never changes any existing Ref.
+-- -- When an Operation is about to be emitted, we convert the stored bottom-index
+-- -- to the top-relative index expected by the machine: `currentHeight - 1 - bottomIndex`.
+-- --
+-- -- The builder additionally **carries a proof of well-formedness** in its state, so that
+-- -- `Build.run` returns a `WellFormedProgram` *by construction*, with no exceptions, no
+-- -- `Option`, and no post-hoc decidable check.
+
+-- /-- A weakening of `WFProg` that holds for the empty program at any `n` (including `0`).
+--     Used as the in-flight invariant of the builder, since intermediate states may have
+--     `prog = []` while `n_initial = 0`. -/
+-- def WFProgRaw : ℕ → Prog → Prop
+--   | _, []         => True
+--   | n, op :: rest => WFOp n op ∧ WFProgRaw (n + 1) rest
+
+-- /-- Snoc a single op (well-formed at the post-state height) onto a `WFProgRaw` program. -/
+-- theorem WFProgRaw.append_op :
+--     ∀ {n : ℕ} {prog : Prog} {op : Operation},
+--       WFProgRaw n prog → WFOp (n + prog.length) op → WFProgRaw n (prog ++ [op])
+--   | n, [], op, _, h_op => by
+--     refine ⟨?_, trivial⟩
+--     show WFOp n op
+--     simpa using h_op
+--   | n, o :: rest, op, h_p, h_op => by
+--     obtain ⟨h_o, h_rest⟩ := h_p
+--     refine ⟨h_o, ?_⟩
+--     have h_op' : WFOp (n + 1 + rest.length) op := by
+--       have heq : n + (o :: rest).length = n + 1 + rest.length := by
+--         simp [List.length_cons]; omega
+--       rw [heq] at h_op
+--       exact h_op
+--     exact WFProgRaw.append_op h_rest h_op'
+
+-- /-- A `WFProgRaw` program with at least one element on the post-execution stack
+--     (i.e. `n_initial + prog.length > 0`) lifts to a full `WFProg`. -/
+-- theorem WFProgRaw_to_WFProg :
+--     ∀ {n : ℕ} {prog : Prog}, WFProgRaw n prog → n + prog.length ≠ 0 → WFProg n prog
+--   | n, [], _, hpos => by simpa using hpos
+--   | _, _ :: rest, h_p, _ => by
+--     obtain ⟨h_op, h_rest⟩ := h_p
+--     refine ⟨h_op, ?_⟩
+--     apply WFProgRaw_to_WFProg h_rest
+--     simp
+
+-- /-- Monad state: the initial stack size, the ops collected so far, and a proof that
+--     the collected ops form a well-formed program at that initial stack size. -/
+-- structure BuildCtx where
+--   n_initial : ℕ
+--   prog : Prog := []
+--   h_wf : WFProgRaw n_initial prog := by trivial
+
+-- /-- The current stack height of a build context. -/
+-- @[simp] def BuildCtx.height (c : BuildCtx) : ℕ := c.n_initial + c.prog.length
+
+-- /-- The builder monad: a state monad over `BuildCtx`. -/
+-- abbrev Build := StateM BuildCtx
+
+-- /-- A stable reference to a stack slot.  `val` is the slot's bottom-index (oldest = 0).
+--     `bound` is a snapshot of `currentHeight` at the moment the ref was minted; the
+--     invariant `val < bound` is what makes the ref usable.  All refs produced by the
+--     builder API satisfy `bound ≤ currentHeight` from the moment of mint onwards
+--     (since heights only grow). -/
+-- structure Ref where
+--   val : ℕ
+--   bound : ℕ
+--   h_lt : val < bound
+
+-- /-- Current stack height (= `n_initial + prog.length`). -/
+-- def Build.currentHeight : Build ℕ := do
+--   let ctx ← get
+--   return ctx.height
+
+-- /-- Extend a `BuildCtx` by appending one well-formed operation. -/
+-- private def BuildCtx.extend (ctx : BuildCtx) (op : Operation) (h_op : WFOp ctx.height op) :
+--     BuildCtx :=
+--   { n_initial := ctx.n_initial
+--     prog := ctx.prog ++ [op]
+--     h_wf := WFProgRaw.append_op ctx.h_wf (by simpa [BuildCtx.height] using h_op) }
+
+-- @[simp] theorem BuildCtx.extend_n_initial (ctx : BuildCtx) (op : Operation)
+--     (h_op : WFOp ctx.height op) : (ctx.extend op h_op).n_initial = ctx.n_initial := rfl
+
+-- @[simp] theorem BuildCtx.extend_height (ctx : BuildCtx) (op : Operation)
+--     (h_op : WFOp ctx.height op) : (ctx.extend op h_op).height = ctx.height + 1 := by
+--   simp [BuildCtx.extend, BuildCtx.height, List.length_append, Nat.add_assoc]
+
+-- /-- Obtain a `Ref` to an item that already exists in the initial stack.
+--     `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom.
+--     If `j ≥ n_initial` the resulting `Ref` will be invalid; calls using such a ref will
+--     silently fall back to emitting `.empty`. -/
+-- def Build.inputRef (j : TapeIndex) : Build Ref := do
+--   let ctx ← get
+--   let h := ctx.height
+--   if hp : ctx.n_initial > 0 then
+--     -- val = ctx.n_initial - 1 - j (clamped at 0 for j ≥ n_initial); bound = h ≥ n_initial > 0
+--     let v := if j < ctx.n_initial then ctx.n_initial - 1 - j else 0
+--     return ⟨v, h, by simp [v, BuildCtx.height]; split <;> sorry⟩
+--   else
+--     -- No initial inputs: return a sentinel; can't be used since bound > val always fails.
+--     return ⟨0, 1, Nat.lt_succ_self _⟩
+
+-- -- ── Primitive operations ──────────────────────────────────────────────────────
+
+-- /-- Emit an `.empty` operation; returns a `Ref` to the new (empty) item on top. -/
+-- def Build.empty : Build Ref := do
+--   let ctx ← get
+--   let h := ctx.height
+--   let h_op : WFOp h .empty := trivial
+--   set (ctx.extend .empty h_op)
+--   return ⟨h, h + 1, Nat.lt_succ_self _⟩
+
+-- /-- Emit `.cons h t`. If either ref's bound exceeds the current height (impossible by
+--     API contract), silently emits `.empty` instead so that the WF invariant is preserved. -/
+-- def Build.cons (h t : Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hh : h.bound ≤ height then
+--     if ht : t.bound ≤ height then
+--       have h_hv : h.val < height := Nat.lt_of_lt_of_le h.h_lt hh
+--       have h_tv : t.val < height := Nat.lt_of_lt_of_le t.h_lt ht
+--       let i := height - 1 - h.val
+--       let j := height - 1 - t.val
+--       let op : Operation := .cons i j
+--       have hi : i < height := by simp [i]; omega
+--       have hj : j < height := by simp [j]; omega
+--       have h_op : WFOp height op := ⟨hi, hj⟩
+--       set (ctx.extend op h_op)
+--       return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--     else
+--       Build.empty
+--   else
+--     Build.empty
+
+-- /-- Emit `.head r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+-- def Build.head (r : Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hr : r.bound ≤ height then
+--     have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+--     let i := height - 1 - r.val
+--     let op : Operation := .head i
+--     have hi : i < height := by simp [i]; omega
+--     have h_op : WFOp height op := hi
+--     set (ctx.extend op h_op)
+--     return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--   else
+--     Build.empty
+
+-- /-- Emit `.tail r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+-- def Build.tail (r : Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hr : r.bound ≤ height then
+--     have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+--     let i := height - 1 - r.val
+--     let op : Operation := .tail i
+--     have hi : i < height := by simp [i]; omega
+--     have h_op : WFOp height op := hi
+--     set (ctx.extend op h_op)
+--     return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--   else
+--     Build.empty
+
+-- /-- Emit `.eq r s`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
+-- def Build.eq (r s : Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hr : r.bound ≤ height then
+--     if hs : s.bound ≤ height then
+--       have h_rv : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
+--       have h_sv : s.val < height := Nat.lt_of_lt_of_le s.h_lt hs
+--       let i := height - 1 - r.val
+--       let j := height - 1 - s.val
+--       let op : Operation := .eq i j
+--       have hi : i < height := by simp [i]; omega
+--       have hj : j < height := by simp [j]; omega
+--       have h_op : WFOp height op := ⟨hi, hj⟩
+--       set (ctx.extend op h_op)
+--       return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--     else
+--       Build.empty
+--   else
+--     Build.empty
+
+-- -- ── Combinators ───────────────────────────────────────────────────────────────
+
+-- /-- Run a sub-program builder in a fresh context whose initial stack height is `subN`,
+--     returning the compiled `Prog` together with a `WFProg subN` proof.
+--     The caller must supply `h_pos : subN > 0` so that the empty-`prog` case is handled.
+--     `extraRefs` are the `Ref`s for the `subN - h` items prepended on top of the outer
+--     stack (e.g. `[child, acc]` for `fold`). -/
+-- private def Build.subProg (subN : ℕ) (h_pos : subN > 0)
+--     (extraRefs : Array Ref) (inner : Array Ref → Build Ref) :
+--     Build { p : Prog // WFProg subN p } := do
+--   let init : BuildCtx := { n_initial := subN, prog := [], h_wf := trivial }
+--   let (_, subCtx) := StateT.run (inner extraRefs) init
+--   -- Trust that the smart constructors do not change `n_initial`; if some user code
+--   -- did, we fall back to a trivial WF program of length 1.
+--   if h_eq : subCtx.n_initial = subN then
+--     have h_wf_raw : WFProgRaw subN subCtx.prog := h_eq ▸ subCtx.h_wf
+--     have h_pos' : subN + subCtx.prog.length ≠ 0 := by omega
+--     return ⟨subCtx.prog, WFProgRaw_to_WFProg h_wf_raw h_pos'⟩
+--   else
+--     have h_wf : WFProg subN [Operation.empty] := by
+--       refine ⟨trivial, ?_⟩
+--       show subN + 1 ≠ 0
+--       omega
+--     return ⟨[Operation.empty], h_wf⟩
+
+-- /-- Build the bottom-index `Ref`s for the `extra` items prepended on top of the outer
+--     stack `h` when entering a sub-builder.  Returns refs in order
+--     `[topmost prepended, …, bottommost prepended]`. -/
+-- private def Build.extraRefs (h extra : ℕ) : Array Ref :=
+--   (Array.range extra).map fun k =>
+--     let v := h + extra - 1 - k
+--     have h_lt : v < h + extra := by simp [v]; omega
+--     ⟨v, h + extra, h_lt⟩
+
+-- /-- Branch on `cond`: if `cond == dataTrue` run `then_`, else run `else_`.
+--     Both branches see the same outer stack.  Each branch must return the `Ref` it
+--     wants as the result. -/
+-- def Build.ite (cond : Ref) (then_ else_ : Build Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hc : cond.bound ≤ height then
+--     have h_v : cond.val < height := Nat.lt_of_lt_of_le cond.h_lt hc
+--     let i := height - 1 - cond.val
+--     have hi : i < height := by simp [i]; omega
+--     have h_pos : height > 0 := by omega
+--     let ⟨thenProg, h_then⟩ ← Build.subProg height h_pos (Build.extraRefs height 0)
+--          (fun _ => then_)
+--     let ⟨elseProg, h_else⟩ ← Build.subProg height h_pos (Build.extraRefs height 0)
+--          (fun _ => else_)
+--     let op : Operation := .ite i thenProg elseProg
+--     have h_op : WFOp height op := ⟨hi, h_then, h_else⟩
+--     set (ctx.extend op h_op)
+--     return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--   else
+--     Build.empty
+
+-- /-- Fold over the children of `list_`, starting with accumulator `acc_`, using `body`.
+--     `body` receives `(child, acc)` as `Ref`s; outer `Ref`s remain valid unchanged. -/
+-- def Build.fold (list_ acc_ : Ref) (body : Ref → Ref → Build Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hl : list_.bound ≤ height then
+--     if ha : acc_.bound ≤ height then
+--       have h_lv : list_.val < height := Nat.lt_of_lt_of_le list_.h_lt hl
+--       have h_av : acc_.val < height := Nat.lt_of_lt_of_le acc_.h_lt ha
+--       let li := height - 1 - list_.val
+--       let ai := height - 1 - acc_.val
+--       have hli : li < height := by simp [li]; omega
+--       have hai : ai < height := by simp [ai]; omega
+--       have h_pos : height + 2 > 0 := by omega
+--       let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 2) h_pos
+--         (Build.extraRefs height 2) (fun extra => body extra[0]! extra[1]!)
+--       let op : Operation := .fold li ai bodyProg
+--       have h_op : WFOp height op := ⟨hli, hai, h_body⟩
+--       set (ctx.extend op h_op)
+--       return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--     else
+--       Build.empty
+--   else
+--     Build.empty
+
+-- /-- While `cond_` is nonempty, run `body`.  `body` receives one `Ref` for the current
+--     accumulator (= the current value of `cond_` on top of the outer stack). -/
+-- def Build.while_ (cond_ : Ref) (body : Ref → Build Ref) : Build Ref := do
+--   let ctx ← get
+--   let height := ctx.height
+--   if hc : cond_.bound ≤ height then
+--     have h_v : cond_.val < height := Nat.lt_of_lt_of_le cond_.h_lt hc
+--     let i := height - 1 - cond_.val
+--     have hi : i < height := by simp [i]; omega
+--     have h_pos : height + 1 > 0 := by omega
+--     let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 1) h_pos
+--       (Build.extraRefs height 1) (fun extra => body extra[0]!)
+--     let op : Operation := .while_ i bodyProg
+--     have h_op : WFOp height op := ⟨hi, h_body⟩
+--     set (ctx.extend op h_op)
+--     return ⟨height, height + 1, Nat.lt_succ_self _⟩
+--   else
+--     Build.empty
+
+-- -- ── Running the builder ───────────────────────────────────────────────────────
+
+-- /-- Run a builder that starts with `n_initial` pre-existing stack items, producing a
+--     `WellFormedProgram` *by construction*.  If the user's builder produces no ops and
+--     `n_initial = 0`, an `.empty` op is appended so that the result is always a
+--     syntactically valid `WFProg` (which requires the post-execution stack to be
+--     non-empty). -/
+-- def Build.run (n_initial : ℕ) (b : Build Ref) : WellFormedProgram :=
+--   let init : BuildCtx := { n_initial, prog := [], h_wf := trivial }
+--   let (_, ctx) := StateT.run b init
+--   if h_pos : ctx.height ≠ 0 then
+--     ⟨ctx.prog, ctx.n_initial, WFProgRaw_to_WFProg ctx.h_wf (by simpa [BuildCtx.height]
+--      using h_pos)⟩
+--   else
+--     -- height = 0 ⇒ n_initial = 0 ∧ prog = []; emit a sentinel `.empty` to satisfy WFProg.
+--     let extended := ctx.extend .empty trivial
+--     have h_pos' : extended.n_initial + extended.prog.length ≠ 0 := by
+--       simp [extended, BuildCtx.extend, List.length_append]
+--     ⟨extended.prog, extended.n_initial, WFProgRaw_to_WFProg extended.h_wf h_pos'⟩
+
+-- /-- Convenience: `Build.run` for programs that take no initial input. -/
+-- def Build.runFresh (b : Build Ref) : WellFormedProgram := Build.run 0 b
+
+
+-- def funFalse : WellFormedProgram := Build.runFresh do
+--   Build.empty
+
+-- def funTrue : WellFormedProgram := Build.runFresh do
+--   let a ← Build.empty
+--   Build.cons a a
+
+-- #eval funFalse.prog
+-- #eval funTrue.prog

From 31ef87ec3ca98f96366d15bd178cc38962d293c4 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 11:36:43 +0200
Subject: [PATCH 042/106] more cleanup

---
 Cslib.lean                                    |  1 +
 .../RoseTreeMachine/RoseTreeMachine.lean      | 31 +++++++++++++++----
 2 files changed, 26 insertions(+), 6 deletions(-)

diff --git a/Cslib.lean b/Cslib.lean
index 5b3cef9dd5..368d22f45d 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -69,6 +69,7 @@ public import Cslib.Computability.Machines.MultiTapeTuring.TapeView
 public import Cslib.Computability.Machines.MultiTapeTuring.UniversalTM
 public import Cslib.Computability.Machines.MultiTapeTuring.WhileCombinator
 public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes
+public import Cslib.Computability.Machines.RoseTreeMachine.RoseTreeMachine
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index b570f4fe30..a403c028d0 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -1,10 +1,19 @@
-import Mathlib.Data.Part
-import Mathlib.Control.Fix
-import Mathlib.Tactic
-import Std
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
 
-import Cslib.Computability.Machines.SingleTapeTuring.Basic
+module
 
+public import Mathlib.Data.Part
+public import Mathlib.Control.Fix
+public import Std
+
+public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+public import Mathlib.Data.Nat.Bits
+
+/-!
 -- This is a proposal to define a machine model and related time and space measure
 -- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
 
@@ -26,8 +35,14 @@ import Cslib.Computability.Machines.SingleTapeTuring.Basic
 -- (3) if we have a built-in `fold` operation, we should be able to implement the required
 --     operations at linear space overhead, because the fold operation implicitly re-uses the
 --     space used by the accumulator.
+-/
+
+@[expose] public section
+
 
+namespace Turing
 
+namespace RoseTreeMachine
 
 -- ================= Data structure
 
@@ -50,7 +65,6 @@ abbrev Data.empty := Data.l []
 abbrev Data.asList
   | Data.l xs => xs
 
-@[simp]
 lemma Data.asList_empty : Data.empty.asList = [] := by simp [Data.empty]
 
 @[simp]
@@ -67,6 +81,7 @@ lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
 lemma Data.cons_size {h : Data} {t : List Data} :
     (Data.l (h :: t)).size = h.size + (Data.l t).size := by
   simp [Data.size, Nat.add_assoc, Nat.add_comm]
+  sorry
 
 abbrev TapeIndex := ℕ
 
@@ -1461,3 +1476,7 @@ lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
 
 -- #eval funFalse.prog
 -- #eval funTrue.prog
+
+end RoseTreeMachine
+
+end Turing

From f55465b4dbf0316154888e33e3e452e2675a7779 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 13:05:27 +0200
Subject: [PATCH 043/106] more complex call

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 112 +++++++++++++-----
 1 file changed, 82 insertions(+), 30 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index a403c028d0..4f228ca2d8 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -113,9 +113,10 @@ inductive Operation where
   | fold   : (List Operation) → TapeIndex → TapeIndex → Operation
   -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
   | while_ : TapeIndex → (List Operation) → Operation
-  -- call executes a sub-program and returns its stack top. This is not strictly needed, but
-  -- makes it easier to write programs.
-  | call : (List Operation) → Operation
+  -- call executes a sub-program on a swapped / copied stack and returns its stack top.
+  -- This is not strictly needed, but makes it easier to write programs.
+  -- Note that the subprogram only has access to the provided stack indices.
+  | call : (List Operation) → (List TapeIndex) → Operation
 deriving Repr
 
 abbrev Prog := List Operation
@@ -133,7 +134,7 @@ mutual
     | .ifEmpty i t e  => i < n ∧ WFProg n t ∧ WFProg n e
     | .fold b i l => l < n ∧ i < n ∧ WFProg (n + 2) b
     | .while_ i b => i < n ∧ WFProg (n + 1) b
-    | .call b => WFProg n b
+    | .call b stack => (∀ i ∈ stack, i < n) ∧ WFProg stack.length b
 
   /-- `WFProg n p` states that `p` is well-formed given an initial stack of size `n`.
       Since each operation pushes exactly one value, the k-th operation (0-indexed) sees
@@ -188,7 +189,7 @@ mutual
             if d'.asList.head? == .some dataTrue then rec (d', t', s')
             else .some (Data.l d'.asList.tail, t', s')
       (Part.fix F (init, 0, 0)).map fun (r, t, s) => (r, 1 + t, init.size + s)
-    | .call body => meteredEvalProg body stack h_wf
+    | .call body idxs => goCall body idxs stack [] h_wf.1 h_wf.2
 
   /-- Metered analogue of `goFold`: walks the items, threading the accumulator and accumulating
       `(sum of (1 + body_time), max of body_space)` across iterations. -/
@@ -201,6 +202,17 @@ mutual
         (goMeteredFold cs acc' stack body h_wf).map fun (r, t, s) =>
           (r, 1 + tBody + t, max sBody s)
 
+  @[simp]
+  def goCall (body : Prog) (idxs : List TapeIndex) (stack copiedStack : List Data)
+      (h_idxs : ∀ i ∈ idxs, i < stack.length)
+      (h_wf : WFProg (idxs.length + copiedStack.length) body) :
+      Part (Data × ℕ × ℕ) :=
+    match idxs with
+    | [] => meteredEvalProg body copiedStack (by simpa using h_wf)
+    | i :: idxs' =>
+      have : i < stack.length := h_idxs i (by simp)
+      goCall body idxs' stack (copiedStack ++ [stack[i]]) (by grind) (by grind)
+
   @[simp]
   def meteredEvalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) :
       Part (Data × ℕ × ℕ) :=
@@ -228,7 +240,7 @@ mutual
     | .ifEmpty _ a b => Prog.WhileFree a ∧ Prog.WhileFree b
     | .while_ _ _ => False
     | .fold b _ _ => Prog.WhileFree b
-    | .call p => Prog.WhileFree p
+    | .call p _ => Prog.WhileFree p
     | _ => True
   @[simp]
   def Prog.WhileFree (body : Prog) : Prop :=
@@ -273,12 +285,21 @@ def Prog.meteredEvalT (body : Prog) (stack : List Data)
     (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
   (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree h_wf h_whf stack rfl)
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length .empty} :
     Operation.meteredEvalT .empty stack h_wf (by simp) = (Data.empty, 1, 1) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp]
+@[simp, scoped grind =]
+lemma Operation.meteredEvalT_cons_one
+    {h t : ℕ}
+    {stack : List Data}
+    {h_wf : WFOp stack.length (.cons h t)} :
+    (Operation.meteredEvalT (.cons h t) stack h_wf (by simp)).1 =
+      Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList) := by
+  simp [Operation.meteredEvalT, meteredEvalOp]
+
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_cons
     {h t : ℕ}
     {stack : List Data}
@@ -289,7 +310,7 @@ lemma Operation.meteredEvalT_cons
       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_head
     {i : ℕ}
     {stack : List Data}
@@ -300,7 +321,7 @@ lemma Operation.meteredEvalT_head
       1 + (stack[i].asList.headD Data.empty).size) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_tail
     {i : ℕ}
     {stack : List Data}
@@ -311,7 +332,7 @@ lemma Operation.meteredEvalT_tail
       1 + (Data.l stack[i].asList.tail).size) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_ifEmpty
     {i : ℕ}
     {stack : List Data}
@@ -329,7 +350,7 @@ lemma Operation.meteredEvalT_ifEmpty
   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
 
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_call
     {stack : List Data}
     {p : List Operation}
@@ -338,7 +359,7 @@ lemma Operation.meteredEvalT_call
     Operation.meteredEvalT (.call p) stack h_wf h_whf = Prog.meteredEvalT p stack h_wf h_whf := by
   simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp]
 
-@[simp]
+@[simp, scoped grind =]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
     {h_wf : WFOp stack.length (.fold body initial list)}
     {h_whf : Operation.WhileFree (.fold body initial list)}
@@ -432,14 +453,25 @@ lemma Operation.meteredEvalT_fold_induction
     motive r t s := by
   sorry
 
-@[simp]
+@[simp, scoped grind =]
 lemma Prog.meteredEvalT_nil
     {stack : List Data}
     {h_wf : WFProg stack.length []} :
     Prog.meteredEvalT [] stack h_wf (by simp) = (stack.head (by grind [WFProg]), 0, 0) := by
   simp [Prog.meteredEvalT]
 
-@[simp]
+@[simp, scoped grind =]
+lemma Prog.meteredEvalT_cons_one
+    {op : Operation} {rest : Prog} {stack : List Data}
+    {h_wf : WFProg stack.length (op :: rest)}
+    {h_whf : Prog.WhileFree (op :: rest)} :
+    (Prog.meteredEvalT (op :: rest) stack h_wf h_whf).1 =
+      let s := stack
+      let r := (op.meteredEvalT s h_wf.1 h_whf.1).1
+      (meteredEvalT rest (r :: s) h_wf.2 h_whf.2).1 := by
+  sorry
+
+@[simp, scoped grind =]
 lemma Prog.meteredEvalT_cons
     {op : Operation} {rest : Prog} {stack : List Data}
     {h_wf : WFProg stack.length (op :: rest)}
@@ -478,7 +510,7 @@ instance (α : Type) [DataEncode α] : DataEncode (Option α) where
     | some x => Data.l [DataEncode.encode x]
   h_inj := by sorry
 
-@[simp]
+@[simp, scoped grind =]
 lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
   (DataEncode.encode x == Data.empty) = x.isNone := by sorry
 
@@ -615,32 +647,52 @@ lemma stackTape_cons.semantics
 -- def move_left (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
+def snd : Prog := [ .tail 0, .head 0 ]
+
+@[simp]
+lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
+    {stack : List Data} {x : α} {y : β} :
+    (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
+      (by simp [snd, WFProg, WFOp]) (by simp [snd])).1 =
+      DataEncode.encode y := by
+  simp [snd]
+
 def tape_move_left : Prog := [
   .head 0, -- t.head
   .call [ .tail 1, .tail 0 ], -- t.right
-  .call stackTape_cons, -- StackTape.cons t.head t.right
-  .call [ .tail 3, .head 0, .tail 0 ], -- t.left.tail
-  .call [ .tail 3, .head 0, .head 0 ], -- t.left.head
-  .cons 1 2,
-  .cons 1 0
+  -- .call stackTape_cons, -- StackTape.cons t.head t.right
+  -- .call [ .tail 3, .head 0, .tail 0 ], -- t.left.tail
+  -- .call [ .tail 3, .head 0, .head 0 ], -- t.left.head
+  -- .cons 1 2,
+  -- .cons 1 0
 ]
 
 @[simp]
 lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
-  simp [tape_move_left, stackTape_cons]
+  simp [tape_move_left]
 
 @[simp]
 lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
-  simp [tape_move_left, WFProg, WFOp, stackTape_cons, h_le]
+  simp [tape_move_left, WFProg, WFOp, h_le]
 
--- @[simp]
--- lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
---     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp) (by simp)).1 =
---       DataEncode.encode (Turing.BiTape.move_left t) := by
---   unfold tape_move_left
---   simp
+@[simp]
+lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
+    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp) (by simp)).1 =
+      DataEncode.encode (Turing.BiTape.move_left t) := by
+  unfold tape_move_left
+  set input := DataEncode.encode t
+  simp only [Prog.meteredEvalT_cons, Prog.meteredEvalT_nil]
+  simp [Operation.meteredEvalT_head]
+  simp only [input]
+  rw [List.tail_cons]
+  simp [DataEncode.encode]
+  rw [List.tail_cons]
+  simp only [List.tail_cons, input]
 
---   sorry
+  -- it gets exponential because of the ".1" and because "stack" is repeated multiple times!
+  -- simp only [List.getElem_cons_zero]
+
+  sorry
 
 
 -- def put : Data → Prog

From b1c2f4f0660710e141f0c90e768decd5fbbdcd86 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 15:27:36 +0200
Subject: [PATCH 044/106] more semantics.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 113 ++++++++++++------
 1 file changed, 77 insertions(+), 36 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 4f228ca2d8..6a67dd7993 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -67,17 +67,18 @@ abbrev Data.asList
 
 lemma Data.asList_empty : Data.empty.asList = [] := by simp [Data.empty]
 
-@[simp]
+@[simp, grind =]
 lemma Data.asList_l : Data.l xs.asList = xs := by grind
 
+
 --- Encoding length of d.
 def Data.size : Data → ℕ
   | Data.l xs => 2 + (xs.map Data.size |>.sum)
 
-@[simp]
+@[simp, grind =]
 lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
 
-@[simp]
+@[simp, grind =]
 lemma Data.cons_size {h : Data} {t : List Data} :
     (Data.l (h :: t)).size = h.size + (Data.l t).size := by
   simp [Data.size, Nat.add_assoc, Nat.add_comm]
@@ -134,7 +135,7 @@ mutual
     | .ifEmpty i t e  => i < n ∧ WFProg n t ∧ WFProg n e
     | .fold b i l => l < n ∧ i < n ∧ WFProg (n + 2) b
     | .while_ i b => i < n ∧ WFProg (n + 1) b
-    | .call b stack => (∀ i ∈ stack, i < n) ∧ WFProg stack.length b
+    | .call b idxs => (∀ i ∈ idxs, i < n) ∧ WFProg idxs.length b
 
   /-- `WFProg n p` states that `p` is well-formed given an initial stack of size `n`.
       Since each operation pushes exactly one value, the k-th operation (0-indexed) sees
@@ -161,7 +162,7 @@ mutual
       .some (result, 1 + result.size, 1 + result.size)
     | .tail i =>
       let result := Data.l stack[i].asList.tail
-      .some (result, 1 + result.size, 1 + result.size)
+      .some (result, 1 + stack[i].size, 1 + result.size)
     | .eq i j => .some
       (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse,
       1 + (min (stack[i]'h_wf.1).size (stack[j]'h_wf.2).size),
@@ -189,7 +190,9 @@ mutual
             if d'.asList.head? == .some dataTrue then rec (d', t', s')
             else .some (Data.l d'.asList.tail, t', s')
       (Part.fix F (init, 0, 0)).map fun (r, t, s) => (r, 1 + t, init.size + s)
-    | .call body idxs => goCall body idxs stack [] h_wf.1 h_wf.2
+    | .call body idxs => goCall body idxs stack [] h_wf.1 (by simpa using h_wf.2)
+    -- cost of copying?
+  termination_by (sizeOf op, 0, 0)
 
   /-- Metered analogue of `goFold`: walks the items, threading the accumulator and accumulating
       `(sum of (1 + body_time), max of body_space)` across iterations. -/
@@ -201,8 +204,12 @@ mutual
       (meteredEvalProg body (c :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
         (goMeteredFold cs acc' stack body h_wf).map fun (r, t, s) =>
           (r, 1 + tBody + t, max sBody s)
+  -- Primary key `sizeOf body` decreases when entering goMeteredFold from meteredEvalOp .fold
+  -- (body is a strict subterm of the .fold op), enabling the secondary key `sizeOf items`
+  -- to be runtime data without breaking the well-founded ordering.
+  termination_by (sizeOf body, sizeOf items, 0)
 
-  @[simp]
+  @[simp, grind =]
   def goCall (body : Prog) (idxs : List TapeIndex) (stack copiedStack : List Data)
       (h_idxs : ∀ i ∈ idxs, i < stack.length)
       (h_wf : WFProg (idxs.length + copiedStack.length) body) :
@@ -212,8 +219,11 @@ mutual
     | i :: idxs' =>
       have : i < stack.length := h_idxs i (by simp)
       goCall body idxs' stack (copiedStack ++ [stack[i]]) (by grind) (by grind)
+  -- Same lexicographic strategy as goMeteredFold: primary key `sizeOf body` lets us cross
+  -- function boundaries; secondary key `sizeOf idxs` handles goCall's own recursion.
+  termination_by (sizeOf body, 0, sizeOf idxs)
 
-  @[simp]
+  @[simp, grind =]
   def meteredEvalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) :
       Part (Data × ℕ × ℕ) :=
     match prog with
@@ -222,6 +232,7 @@ mutual
       let (r, opTime, opSpace) ← meteredEvalOp stack op h_wf.1
       let (r, time, space) ← meteredEvalProg rest (r :: stack) h_wf.2
       (r, opTime + time, opSpace + space)
+  termination_by (sizeOf prog, 0, 0)
 
 end
 
@@ -328,7 +339,7 @@ lemma Operation.meteredEvalT_tail
     {h_wf : WFOp stack.length (.tail i)} :
     Operation.meteredEvalT (.tail i) stack h_wf (by simp) =
       (Data.l stack[i].asList.tail,
-      1 + (Data.l stack[i].asList.tail).size,
+      1 + stack[i].size,
       1 + (Data.l stack[i].asList.tail).size) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
@@ -353,11 +364,16 @@ lemma Operation.meteredEvalT_ifEmpty
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_call
     {stack : List Data}
-    {p : List Operation}
-    {h_wf : WFOp stack.length (.call p)}
-    {h_whf : WhileFree (.call p)} :
-    Operation.meteredEvalT (.call p) stack h_wf h_whf = Prog.meteredEvalT p stack h_wf h_whf := by
-  simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp]
+    {body : Prog}
+    {idxs : List TapeIndex}
+    {h_wf : WFOp stack.length (.call body idxs)}
+    {h_whf : WhileFree (.call body idxs)} :
+    Operation.meteredEvalT (.call body idxs) stack h_wf h_whf =
+      Prog.meteredEvalT body
+        (idxs.attach.map (fun ⟨i, hi⟩ => stack[i]'(h_wf.1 i hi)))
+        (by simpa using h_wf.2)
+        h_whf := by
+  sorry
 
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
@@ -504,6 +520,11 @@ lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α)
   DataEncode.encode xs = Data.empty ↔ xs = [] := by
   simp [DataEncode.encode]
 
+@[simp, scoped grind =]
+lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+  simp [DataEncode.encode]
+
 instance (α : Type) [DataEncode α] : DataEncode (Option α) where
   encode := fun
     | none => Data.l []
@@ -653,45 +674,65 @@ def snd : Prog := [ .tail 0, .head 0 ]
 lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
     {stack : List Data} {x : α} {y : β} :
     (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
-      (by simp [snd, WFProg, WFOp]) (by simp [snd])).1 =
-      DataEncode.encode y := by
+      (by simp [snd, WFProg, WFOp]) (by simp [snd])) =
+      (DataEncode.encode y,
+        2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
+        4 + 2 * (DataEncode.encode y).size)
+      := by
   simp [snd]
+  grind
+
+def tape_left : Prog := [ .call snd [0], .head 0 ]
+
+@[simp]
+lemma tape_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
+    (tape_left.meteredEvalT (DataEncode.encode t :: stack)
+      (by simp [tape_left, snd, WFProg, WFOp]) (by simp [tape_left, snd])).1 =
+      DataEncode.encode t.left := by
+  simp [tape_left]
+  sorry
+
+
 
 def tape_move_left : Prog := [
   .head 0, -- t.head
-  .call [ .tail 1, .tail 0 ], -- t.right
-  -- .call stackTape_cons, -- StackTape.cons t.head t.right
-  -- .call [ .tail 3, .head 0, .tail 0 ], -- t.left.tail
-  -- .call [ .tail 3, .head 0, .head 0 ], -- t.left.head
+  .call [ .call snd [0], .call snd [0] ] [1], -- t.right
+  .call stackTape_cons [1, 0], -- StackTape.cons t.head t.right
+  .call [ .call tape_left [0], .tail 0 ] [3], -- t.left.tail
+  .call [ .call tape_left [0], .head 0 ] [4], -- t.left.head
+  -- .call [ .tail 0 ] [0], -- t.left.tail
+  -- .call [ .call snd [3], .head 0, .head 0 ] [4], -- t.left.head
   -- .cons 1 2,
   -- .cons 1 0
 ]
 
 @[simp]
 lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
-  simp [tape_move_left]
+  simp [tape_move_left, snd, stackTape_cons]
 
 @[simp]
 lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
-  simp [tape_move_left, WFProg, WFOp, h_le]
+  simp [tape_move_left, snd, stackTape_cons, WFProg, WFOp, h_le]
 
 @[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp) (by simp)).1 =
-      DataEncode.encode (Turing.BiTape.move_left t) := by
-  unfold tape_move_left
-  set input := DataEncode.encode t
-  simp only [Prog.meteredEvalT_cons, Prog.meteredEvalT_nil]
-  simp [Operation.meteredEvalT_head]
-  simp only [input]
-  rw [List.tail_cons]
-  simp [DataEncode.encode]
-  rw [List.tail_cons]
-  simp only [List.tail_cons, input]
-
-  -- it gets exponential because of the ".1" and because "stack" is repeated multiple times!
-  -- simp only [List.getElem_cons_zero]
-
+      DataEncode.encode (Turing.BiTape.move_left t)
+        := by
+  have encode_bitape : DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+  have encode_stacktape_tail (st : Turing.StackTape Symbol) :
+      Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
+    rw [show DataEncode.encode st = DataEncode.encode (st.toList) by simp [DataEncode.encode]]
+    rw [DataEncode_list_tail, Data.asList_l]
+    sorry -- StackList stuff
+  have encode_stacktape_head (st : Turing.StackTape Symbol) :
+      Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
+    rw [show DataEncode.encode st = DataEncode.encode (st.toList) by simp [DataEncode.encode]]
+    rw [DataEncode_list_tail, Data.asList_l]
+    sorry -- StackList stuff
+  simp [tape_move_left, encode_bitape, encode_stacktape_tail, -Operation.meteredEvalT_call]
+  -- TODO how can we prevent the expression size to explode during simp?
   sorry
 
 

From cab828510ace49f35fb57f1c668a28c7331df9f0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 18:22:49 +0200
Subject: [PATCH 045/106] class-based semantics resolution.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 429 ++++++++++++++++--
 1 file changed, 396 insertions(+), 33 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 6a67dd7993..611b38c2a7 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -360,7 +360,23 @@ lemma Operation.meteredEvalT_ifEmpty
   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
 
+-- @[scoped grind =]
+-- lemma Operation.meteredEvalT_call_single
+--     {stack : List Data}
+--     {body : Prog}
+--     {i : TapeIndex}
+--     {h_wf : WFOp stack.length (.call body [i])}
+--     {h_whf : WhileFree (.call body [i])} :
+--     Operation.meteredEvalT (.call body [i]) stack h_wf h_whf =
+--       Prog.meteredEvalT body
+--         [stack[i]'(by simpa using h_wf.1 i)]
+--         h_wf.2
+--         h_whf := by
+--   sorry
+
 
+-- this is not @simp because we do not want to unfold calls, they should have
+-- their own specific simp lemmas
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_call
     {stack : List Data}
@@ -493,11 +509,317 @@ lemma Prog.meteredEvalT_cons
     {h_wf : WFProg stack.length (op :: rest)}
     {h_whf : Prog.WhileFree (op :: rest)} :
     Prog.meteredEvalT (op :: rest) stack h_wf h_whf =
-      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 h_whf.1
-      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 h_whf.2
+      let st := stack
+      let (r, opT, opS) := op.meteredEvalT st h_wf.1 h_whf.1
+      let (stack, t, s) := meteredEvalT rest (r :: st) h_wf.2 h_whf.2
       (stack, opT + t, opS + s) := by
   sorry
 
+-- ========================= Data-only evaluation =========================
+
+/-- Data-only evaluation of a single operation (discards time/space). -/
+def Operation.evalData (op : Operation) (stack : List Data)
+    (h_wf : WFOp stack.length op) (h_whf : Operation.WhileFree op) : Data :=
+  (Operation.meteredEvalT op stack h_wf h_whf).1
+
+/-- Data-only evaluation of a program (discards time/space). -/
+def Prog.evalData (prog : Prog) (stack : List Data)
+    (h_wf : WFProg stack.length prog) (h_whf : Prog.WhileFree prog) : Data :=
+  (Prog.meteredEvalT prog stack h_wf h_whf).1
+
+lemma Prog.evalData_nil {stack : List Data} {h_wf : WFProg stack.length []} :
+    Prog.evalData [] stack h_wf (by simp) = stack.head (by grind [WFProg]) := by
+  simp [Prog.evalData, Prog.meteredEvalT_nil]
+
+/-- Step lemma for `evalData`. The intermediate result `r` is `let`-bound so that
+    repeated chaining keeps the goal linear in size. -/
+lemma Prog.evalData_cons {op : Operation} {rest : Prog} {stack : List Data}
+    {h_wf : WFProg stack.length (op :: rest)} {h_whf : Prog.WhileFree (op :: rest)} :
+    Prog.evalData (op :: rest) stack h_wf h_whf =
+      let r := Operation.evalData op stack h_wf.1 h_whf.1
+      Prog.evalData rest (r :: stack) h_wf.2 h_whf.2 := by
+  simp [Prog.evalData, Operation.evalData]
+
+-- ========================= Hoare-style specs (Option A) =========================
+
+/-! ## Compositional specifications
+
+`Operation.Computes op f` (resp. `Prog.Computes p f`) says: whenever `op` (resp. `p`)
+runs on a well-formed, while-free stack `s`, the resulting data equals `f s h_wf`.
+The function `f` is allowed to depend on the well-formedness proof so that it can
+write `s[i]'_` directly.
+
+Why this exists: a naive `simp` chain that unfolds every step of an `n`-operation
+program produces a goal where intermediate stacks are duplicated `O(n²)` times.
+With `Computes`, each step is summarised once by its own `f`, and composition
+(`computes_cons`) chains them via `let`-bindings in the spec function — the
+proof of the composite program never instantiates a giant inlined stack term. -/
+
+/-- A specification for a single operation. -/
+def Operation.Computes (op : Operation)
+    (f : (s : List Data) → WFOp s.length op → Data) : Prop :=
+  ∀ (s : List Data) (h_wf : WFOp s.length op) (h_whf : Operation.WhileFree op),
+    Operation.evalData op s h_wf h_whf = f s h_wf
+
+/-- A specification for a program. -/
+def Prog.Computes (p : Prog)
+    (f : (s : List Data) → WFProg s.length p → Data) : Prop :=
+  ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
+    Prog.evalData p s h_wf h_whf = f s h_wf
+
+/-- The empty program returns the top of the stack. -/
+@[simp, grind .]
+theorem Prog.computes_nil :
+    Prog.Computes ([] : Prog)
+      (fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)) := by
+  intro s h_wf h_whf
+  simp [Prog.evalData, Prog.meteredEvalT_nil]
+
+/-- Sequencing rule. The composite program `op :: rest` runs `fop` on the input
+    stack, pushes the result, and then runs `frest` on the extended stack.
+    The intermediate value appears once via a `let` binding — no duplication. -/
+@[simp, grind .]
+theorem Prog.computes_cons {op : Operation} {rest : Prog}
+    {fop : (s : List Data) → WFOp s.length op → Data}
+    {frest : (s : List Data) → WFProg s.length rest → Data}
+    (h_op : Operation.Computes op fop)
+    (h_rest : Prog.Computes rest frest) :
+    Prog.Computes (op :: rest)
+      (fun s h_wf =>
+        let r := fop s h_wf.1
+        frest (r :: s) h_wf.2) := by
+  intro s h_wf h_whf
+  rw [Prog.evalData_cons]
+  rw [h_op s h_wf.1 h_whf.1]
+  rw [h_rest (fop s h_wf.1 :: s) h_wf.2 h_whf.2]
+
+-- --------- Per-operation specs for `.cons`, `.head`, `.tail` ---------
+
+@[simp, grind .]
+theorem Operation.computes_cons_op (h t : ℕ) :
+    Operation.Computes (.cons h t)
+      (fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)) := by
+  intro s h_wf h_whf
+  simp [Operation.evalData, Operation.meteredEvalT_cons]
+
+@[simp, grind .]
+theorem Operation.computes_head (i : ℕ) :
+    Operation.Computes (.head i)
+      (fun s h_wf => (s[i]'h_wf).asList.headD Data.empty) := by
+  intro s h_wf h_whf
+  simp [Operation.evalData, Operation.meteredEvalT_head]
+
+@[simp, grind .]
+theorem Operation.computes_tail (i : ℕ) :
+    Operation.Computes (.tail i)
+      (fun s h_wf => Data.l (s[i]'h_wf).asList.tail) := by
+  intro s h_wf h_whf
+  simp [Operation.evalData, Operation.meteredEvalT_tail]
+
+@[simp, grind .]
+theorem Operation.computes_empty :
+    Operation.Computes .empty (fun _ _ => Data.empty) := by
+  intro s h_wf h_whf
+  simp [Operation.evalData, Operation.meteredEvalT_empty]
+
+@[simp, grind .]
+theorem Operation.computes_eq (i j : ℕ) :
+    Operation.Computes (.eq i j)
+      (fun s h_wf =>
+        if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse) := by
+  intro s h_wf h_whf
+  simp [Operation.evalData, Operation.meteredEvalT, meteredEvalOp]
+
+@[simp, grind .]
+theorem Operation.computes_ifEmpty {i : ℕ} {then_ else_ : List Operation}
+    {f_then : (s : List Data) → WFProg s.length then_ → Data}
+    {f_else : (s : List Data) → WFProg s.length else_ → Data}
+    (h_then : Prog.Computes then_ f_then)
+    (h_else : Prog.Computes else_ f_else) :
+    Operation.Computes (.ifEmpty i then_ else_)
+      (fun s h_wf =>
+        if (s[i]'h_wf.1) == Data.empty then f_then s h_wf.2.1 else f_else s h_wf.2.2) := by
+  intro s h_wf h_whf
+  unfold Operation.evalData
+  rw [Operation.meteredEvalT_ifEmpty]
+  by_cases h : (s[i]'h_wf.1) == Data.empty
+  · simp only [h, if_true]
+    have := h_then s h_wf.2.1 h_whf.1
+    simp [Prog.evalData] at this
+    simp [this]
+  · simp only [h]
+    have := h_else s h_wf.2.2 h_whf.2
+    simp [Prog.evalData] at this
+    simp [this]
+
+@[simp, grind .]
+theorem Operation.computes_call {body : Prog} {idxs : List TapeIndex}
+    {f_body : (s : List Data) → WFProg s.length body → Data}
+    (h_body : Prog.Computes body f_body) :
+    Operation.Computes (.call body idxs)
+      (fun s h_wf =>
+        f_body
+          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+          (by simpa using h_wf.2)) := by
+  intro s h_wf h_whf
+  unfold Operation.evalData
+  rw [Operation.meteredEvalT_call]
+  exact h_body _ _ _
+
+-- --------- Worked example: a small two-step program ---------
+
+/-- Example: `[.head 0, .tail 0]` first takes the head of `s[0]`, pushes it, then
+    takes the tail of the new top (which is the freshly-pushed head). The
+    intermediate result appears once, as the `let`-bound `r`. -/
+example : Prog.Computes [Operation.head 0, Operation.tail 0]
+    (fun s h_wf =>
+      let r := (s[0]'(by
+        rcases h_wf with ⟨h1, _⟩; exact h1)).asList.headD Data.empty
+      Data.l r.asList.tail) := by
+  intro s h_wf h_whf
+  -- grind -- [Prog.computes_cons, Operation.computes_head, Operation.computes_tail, Prog.computes_nil]
+  have h := Prog.computes_cons (Operation.computes_head 0)
+    (Prog.computes_cons (Operation.computes_tail 0) Prog.computes_nil)
+  exact h s h_wf h_whf
+
+-- ========================= Automation via type-class resolution =========================
+
+/-! ## Automatic spec synthesis
+
+The composition pattern `Prog.computes_cons (op_spec) (Prog.computes_cons ... Prog.computes_nil)`
+is mechanical and entirely determined by the program structure. We expose it via
+type classes so that, for any program built from registered operations, the spec
+function and proof can be obtained by `inferInstance`. -/
+
+class Operation.HasComputes (op : Operation) where
+  spec : (s : List Data) → WFOp s.length op → Data
+  proof : Operation.Computes op spec
+
+class Prog.HasComputes (p : Prog) where
+  spec : (s : List Data) → WFProg s.length p → Data
+  proof : Prog.Computes p spec
+
+instance : Prog.HasComputes ([] : Prog) where
+  spec := fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)
+  proof := Prog.computes_nil
+
+instance {op : Operation} {rest : Prog}
+    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
+    Prog.HasComputes (op :: rest) where
+  spec := fun s h_wf =>
+    let r := hop.spec s h_wf.1
+    hrest.spec (r :: s) h_wf.2
+  proof := Prog.computes_cons hop.proof hrest.proof
+
+instance (h t : ℕ) : Operation.HasComputes (.cons h t) where
+  spec := fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)
+  proof := Operation.computes_cons_op h t
+
+instance (i : ℕ) : Operation.HasComputes (.head i) where
+  spec := fun s h_wf => (s[i]'h_wf).asList.headD Data.empty
+  proof := Operation.computes_head i
+
+instance (i : ℕ) : Operation.HasComputes (.tail i) where
+  spec := fun s h_wf => Data.l (s[i]'h_wf).asList.tail
+  proof := Operation.computes_tail i
+
+instance : Operation.HasComputes .empty where
+  spec := fun _ _ => Data.empty
+  proof := Operation.computes_empty
+
+instance (i j : ℕ) : Operation.HasComputes (.eq i j) where
+  spec := fun s h_wf =>
+    if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse
+  proof := Operation.computes_eq i j
+
+instance {i : ℕ} {then_ else_ : List Operation}
+    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
+    Operation.HasComputes (.ifEmpty i then_ else_) where
+  spec := fun s h_wf =>
+    if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1 else he.spec s h_wf.2.2
+  proof := Operation.computes_ifEmpty ht.proof he.proof
+
+instance {body : Prog} {idxs : List TapeIndex}
+    [hb : Prog.HasComputes body] :
+    Operation.HasComputes (.call body idxs) where
+  spec := fun s h_wf =>
+    hb.spec
+      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+      (by simpa using h_wf.2)
+  proof := Operation.computes_call hb.proof
+
+/-- One-liner: extract the data result of any auto-resolvable program. -/
+abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
+    (s : List Data) (h_wf : WFProg s.length p) : Data :=
+  h.spec s h_wf
+
+-- --------- Simp lemmas exposing each instance's spec ---------
+-- These are all `rfl`: each instance's `spec` field is *definitionally* its RHS.
+-- We expose them as `simp` lemmas so that `simp [...]` can unfold the chain
+-- compositionally without needing the instances themselves to be reducible.
+
+@[simp] lemma Prog.HasComputes.spec_nil :
+    (Prog.HasComputes.spec (p := ([] : Prog))) =
+      fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf) := rfl
+
+@[simp] lemma Prog.HasComputes.spec_cons {op : Operation} {rest : Prog}
+    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
+    (Prog.HasComputes.spec (p := op :: rest)) =
+      fun s h_wf =>
+        let r := hop.spec s h_wf.1
+        hrest.spec (r :: s) h_wf.2 := rfl
+
+@[simp] lemma Operation.HasComputes.spec_cons (h t : ℕ) :
+    (Operation.HasComputes.spec (op := .cons h t)) =
+      fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList) := rfl
+
+@[simp] lemma Operation.HasComputes.spec_head (i : ℕ) :
+    (Operation.HasComputes.spec (op := .head i)) =
+      fun s h_wf => (s[i]'h_wf).asList.headD Data.empty := rfl
+
+@[simp] lemma Operation.HasComputes.spec_tail (i : ℕ) :
+    (Operation.HasComputes.spec (op := .tail i)) =
+      fun s h_wf => Data.l (s[i]'h_wf).asList.tail := rfl
+
+@[simp] lemma Operation.HasComputes.spec_empty :
+    (Operation.HasComputes.spec (op := .empty)) = fun _ _ => Data.empty := rfl
+
+@[simp] lemma Operation.HasComputes.spec_eq (i j : ℕ) :
+    (Operation.HasComputes.spec (op := .eq i j)) =
+      fun s h_wf =>
+        if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse := rfl
+
+@[simp] lemma Operation.HasComputes.spec_ifEmpty {i : ℕ} {then_ else_ : List Operation}
+    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
+    (Operation.HasComputes.spec (op := .ifEmpty i then_ else_)) =
+      fun s h_wf =>
+        if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1
+        else he.spec s h_wf.2.2 := rfl
+
+@[simp] lemma Operation.HasComputes.spec_call {body : Prog} {idxs : List TapeIndex}
+    [hb : Prog.HasComputes body] :
+    (Operation.HasComputes.spec (op := .call body idxs)) =
+      fun s h_wf =>
+        hb.spec
+          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+          (by simpa using h_wf.2) := rfl
+
+-- --------- Worked example using automation ---------
+
+/-- Same as the previous example, but now the spec function and its proof are
+    synthesised by type-class resolution; only the goal statement is written by hand. -/
+example : Prog.Computes [Operation.head 0, Operation.tail 0]
+    (Prog.HasComputes.spec (p := [Operation.head 0, Operation.tail 0])) :=
+  Prog.HasComputes.proof
+
+/-- A slightly larger program: take head of s[0], take tail of the new top, then
+    cons those two. Spec is derived automatically. -/
+example : Prog.Computes
+    [Operation.head 0, Operation.tail 0, Operation.cons 0 1]
+    (Prog.HasComputes.spec
+      (p := [Operation.head 0, Operation.tail 0, Operation.cons 0 1])) :=
+  Prog.HasComputes.proof
+
 class DataEncode (α : Type) where
   encode : α → Data
   h_inj : encode.Injective
@@ -636,7 +958,7 @@ lemma tape_write.semantics (t : Turing.BiTape Symbol) (a : Option Symbol) {stack
   simp [tape_write, Turing.BiTape.write]
   rfl
 
-def stackTape_cons : Prog := [
+abbrev stackTape_cons : Prog := [
   .ifEmpty 0 [ .ifEmpty 1 [ .empty ] [ .cons 0 1 ] ] [ .cons 0 1 ]
 ]
 
@@ -682,30 +1004,60 @@ lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
   simp [snd]
   grind
 
-def tape_left : Prog := [ .call snd [0], .head 0 ]
+/-- Data-only semantics of `snd`, proved via the `HasComputes` automation: instance
+    search assembles the spec function from per-operation specs for `.tail` and `.head`,
+    and `HasComputes.proof` discharges the equality. No simp chain through the
+    full `(Data × ℕ × ℕ)` triple, hence no `O(n²)` blowup. -/
+lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
+    {stack : List Data} {x : α} {y : β} :
+    Prog.evalData snd (DataEncode.encode (x, y) :: stack)
+      (by simp [snd, WFProg, WFOp]) (by simp [snd]) =
+      DataEncode.encode y := by
+  show Prog.evalData [Operation.tail 0, Operation.head 0] _ _ _ = _
+  rw [Prog.HasComputes.proof
+    (p := [Operation.tail 0, Operation.head 0])]
+  simp [Prog.HasComputes.spec, Operation.HasComputes.spec,
+    DataEncode.encode, Data.asList]
+
+/-- Bridge: the data component of `meteredEvalT` is exactly `evalData`. Used to
+    transport spec-based reasoning back to the original semantics statements. -/
+lemma Prog.meteredEvalT_fst_eq_evalData {p : Prog} {s : List Data}
+    {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
+    (Prog.meteredEvalT p s h_wf h_whf).1 = Prog.evalData p s h_wf h_whf := rfl
+
+/-- Instance for the named program `snd`: routed via `inferInstanceAs` since
+    `snd` is a `def`, not an `abbrev`. -/
+instance instHasComputesSnd : Prog.HasComputes snd :=
+  inferInstanceAs (Prog.HasComputes [Operation.tail 0, Operation.head 0])
+
+@[simp] lemma snd.spec_eq :
+    (Prog.HasComputes.spec (p := snd)) =
+      (Prog.HasComputes.spec (p := [Operation.tail 0, Operation.head 0])) := rfl
 
 @[simp]
-lemma tape_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
-    (tape_left.meteredEvalT (DataEncode.encode t :: stack)
-      (by simp [tape_left, snd, WFProg, WFOp]) (by simp [tape_left, snd])).1 =
-      DataEncode.encode t.left := by
-  simp [tape_left]
+lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Symbol)
+      (h_wf : WFProg [DataEncode.encode head, DataEncode.encode tail].length stackTape_cons) :
+    (Prog.HasComputes.spec (p := stackTape_cons))
+      [DataEncode.encode head, DataEncode.encode tail] h_wf =
+      DataEncode.encode (tail.cons head)
+      := by
+  simp
+  -- only encoding and stackTape business left.
   sorry
 
-
-
-def tape_move_left : Prog := [
+abbrev tape_move_left : Prog := [
   .head 0, -- t.head
   .call [ .call snd [0], .call snd [0] ] [1], -- t.right
   .call stackTape_cons [1, 0], -- StackTape.cons t.head t.right
-  .call [ .call tape_left [0], .tail 0 ] [3], -- t.left.tail
-  .call [ .call tape_left [0], .head 0 ] [4], -- t.left.head
-  -- .call [ .tail 0 ] [0], -- t.left.tail
-  -- .call [ .call snd [3], .head 0, .head 0 ] [4], -- t.left.head
-  -- .cons 1 2,
-  -- .cons 1 0
+  .call [ .call snd [0], .head 0, .tail 0 ] [3], -- t.left.tail
+  .call [ .call snd [0], .head 0, .head 0 ] [4], -- t.left.head
+  .cons 1 2,
+  .cons 1 0
 ]
 
+instance instHasComputesTapeMoveLeft : Prog.HasComputes tape_move_left :=
+  inferInstanceAs (Prog.HasComputes tape_move_left)
+
 @[simp]
 lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
   simp [tape_move_left, snd, stackTape_cons]
@@ -714,28 +1066,39 @@ lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
 lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
   simp [tape_move_left, snd, stackTape_cons, WFProg, WFOp, h_le]
 
+/-- Data-only semantics of `tape_move_left`, derived by `HasComputes` automation.
+    Each step's contribution appears once (as a `let`-bound name in the spec
+    function), so the proof term does not duplicate the stack `O(n²)` times. -/
+lemma tape_move_left.evalData_eq {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
+    [DataEncode Symbol]
+    (t : Turing.BiTape Symbol) {stack : List Data} :
+    Prog.evalData tape_move_left (DataEncode.encode t :: stack)
+      (by simp) (by simp [tape_move_left, snd, stackTape_cons]) =
+    Prog.HasComputes.spec (p := tape_move_left)
+      (DataEncode.encode t :: stack) (by simp) := by
+  show Prog.evalData _ _ _ _ = _
+  rw [Prog.HasComputes.proof (p := tape_move_left)]
+
 @[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
-    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp) (by simp)).1 =
+    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp)
+      (by simp [tape_move_left, snd, stackTape_cons])).1 =
       DataEncode.encode (Turing.BiTape.move_left t)
         := by
-  have encode_bitape : DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
-    simp [DataEncode.encode]
-  have encode_stacktape_tail (st : Turing.StackTape Symbol) :
-      Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
-    rw [show DataEncode.encode st = DataEncode.encode (st.toList) by simp [DataEncode.encode]]
-    rw [DataEncode_list_tail, Data.asList_l]
-    sorry -- StackList stuff
-  have encode_stacktape_head (st : Turing.StackTape Symbol) :
-      Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
-    rw [show DataEncode.encode st = DataEncode.encode (st.toList) by simp [DataEncode.encode]]
-    rw [DataEncode_list_tail, Data.asList_l]
-    sorry -- StackList stuff
-  simp [tape_move_left, encode_bitape, encode_stacktape_tail, -Operation.meteredEvalT_call]
-  -- TODO how can we prevent the expression size to explode during simp?
+  -- Step 1: switch from `meteredEvalT.1` to `evalData`, then apply the
+  -- `HasComputes`-derived spec equality. After this, the LHS is
+  -- `HasComputes.spec (p := tape_move_left) ...`.
+  rw [Prog.meteredEvalT_fst_eq_evalData, tape_move_left.evalData_eq]
+  -- Step 2: unfold the spec chain WITHOUT eliminating let-bindings (`zeta := false`).
+  -- Each intermediate result of the program becomes a `have r := ...` binder
+  -- in the goal, so the goal size is linear in the program length rather
+  -- than `O(n²)`. The per-program `.spec_eq` lemmas bridge the named-def
+  -- instances to their underlying list-literal instances.
+  simp
   sorry
 
 
+
 -- def put : Data → Prog
 --   | Data.l [] => [ .empty ]
 --   | Data.l (head :: tail) => [

From 7716a51b99a79f87d71b32d52bae6a4bd1c3b9a5 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 18:43:25 +0200
Subject: [PATCH 046/106] space and time.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 295 ++++++++++++------
 1 file changed, 200 insertions(+), 95 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 611b38c2a7..dfcdf648e7 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -301,25 +301,16 @@ lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length
     Operation.meteredEvalT .empty stack h_wf (by simp) = (Data.empty, 1, 1) := by
   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_cons_one
-    {h t : ℕ}
-    {stack : List Data}
-    {h_wf : WFOp stack.length (.cons h t)} :
-    (Operation.meteredEvalT (.cons h t) stack h_wf (by simp)).1 =
-      Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList) := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
-
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_cons
-    {h t : ℕ}
-    {stack : List Data}
-    {h_wf : WFOp stack.length (.cons h t)} :
-    Operation.meteredEvalT (.cons h t) stack h_wf (by simp) =
-      (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList),
-      1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size,
-      1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
+-- @[simp, scoped grind =]
+-- lemma Operation.meteredEvalT_cons
+--     {h t : ℕ}
+--     {stack : List Data}
+--     {h_wf : WFOp stack.length (.cons h t)} :
+--     Operation.meteredEvalT (.cons h t) stack h_wf (by simp) =
+--       (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList),
+--       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size,
+--       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
+--   simp [Operation.meteredEvalT, meteredEvalOp]
 
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_head
@@ -509,9 +500,8 @@ lemma Prog.meteredEvalT_cons
     {h_wf : WFProg stack.length (op :: rest)}
     {h_whf : Prog.WhileFree (op :: rest)} :
     Prog.meteredEvalT (op :: rest) stack h_wf h_whf =
-      let st := stack
-      let (r, opT, opS) := op.meteredEvalT st h_wf.1 h_whf.1
-      let (stack, t, s) := meteredEvalT rest (r :: st) h_wf.2 h_whf.2
+      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 h_whf.1
+      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 h_whf.2
       (stack, opT + t, opS + s) := by
   sorry
 
@@ -527,6 +517,12 @@ def Prog.evalData (prog : Prog) (stack : List Data)
     (h_wf : WFProg stack.length prog) (h_whf : Prog.WhileFree prog) : Data :=
   (Prog.meteredEvalT prog stack h_wf h_whf).1
 
+/-- Bridge: the data component of `meteredEvalT` is exactly `evalData`. Used to
+    transport spec-based reasoning back to the original semantics statements. -/
+lemma Prog.meteredEvalT_fst_eq_evalData {p : Prog} {s : List Data}
+    {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
+    (Prog.meteredEvalT p s h_wf h_whf).1 = Prog.evalData p s h_wf h_whf := rfl
+
 lemma Prog.evalData_nil {stack : List Data} {h_wf : WFProg stack.length []} :
     Prog.evalData [] stack h_wf (by simp) = stack.head (by grind [WFProg]) := by
   simp [Prog.evalData, Prog.meteredEvalT_nil]
@@ -595,13 +591,6 @@ theorem Prog.computes_cons {op : Operation} {rest : Prog}
 
 -- --------- Per-operation specs for `.cons`, `.head`, `.tail` ---------
 
-@[simp, grind .]
-theorem Operation.computes_cons_op (h t : ℕ) :
-    Operation.Computes (.cons h t)
-      (fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)) := by
-  intro s h_wf h_whf
-  simp [Operation.evalData, Operation.meteredEvalT_cons]
-
 @[simp, grind .]
 theorem Operation.computes_head (i : ℕ) :
     Operation.Computes (.head i)
@@ -692,16 +681,24 @@ type classes so that, for any program built from registered operations, the spec
 function and proof can be obtained by `inferInstance`. -/
 
 class Operation.HasComputes (op : Operation) where
-  spec : (s : List Data) → WFOp s.length op → Data
-  proof : Operation.Computes op spec
+  spec  : (s : List Data) → WFOp s.length op → Data
+  time  : (s : List Data) → WFOp s.length op → ℕ
+  space : (s : List Data) → WFOp s.length op → ℕ
+  proof : ∀ (s : List Data) (h_wf : WFOp s.length op) (h_whf : Operation.WhileFree op),
+    Operation.meteredEvalT op s h_wf h_whf = (spec s h_wf, time s h_wf, space s h_wf)
 
 class Prog.HasComputes (p : Prog) where
-  spec : (s : List Data) → WFProg s.length p → Data
-  proof : Prog.Computes p spec
+  spec  : (s : List Data) → WFProg s.length p → Data
+  time  : (s : List Data) → WFProg s.length p → ℕ
+  space : (s : List Data) → WFProg s.length p → ℕ
+  proof : ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
+    Prog.meteredEvalT p s h_wf h_whf = (spec s h_wf, time s h_wf, space s h_wf)
 
 instance : Prog.HasComputes ([] : Prog) where
-  spec := fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)
-  proof := Prog.computes_nil
+  spec  := fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)
+  time  := fun _ _ => 0
+  space := fun _ _ => 0
+  proof := by intros s h_wf h_whf; simp [Prog.meteredEvalT_nil]
 
 instance {op : Operation} {rest : Prog}
     [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
@@ -709,35 +706,65 @@ instance {op : Operation} {rest : Prog}
   spec := fun s h_wf =>
     let r := hop.spec s h_wf.1
     hrest.spec (r :: s) h_wf.2
-  proof := Prog.computes_cons hop.proof hrest.proof
+  time := fun s h_wf =>
+    let r := hop.spec s h_wf.1
+    hop.time s h_wf.1 + hrest.time (r :: s) h_wf.2
+  space := fun s h_wf =>
+    let r := hop.spec s h_wf.1
+    hop.space s h_wf.1 + hrest.space (r :: s) h_wf.2
+  proof := by
+    intros s h_wf h_whf
+    simp only [Prog.meteredEvalT_cons, hop.proof, hrest.proof]
 
 instance (h t : ℕ) : Operation.HasComputes (.cons h t) where
-  spec := fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)
-  proof := Operation.computes_cons_op h t
+  spec  := fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)
+  time  := fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size
+  space := fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size
+  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
 
 instance (i : ℕ) : Operation.HasComputes (.head i) where
-  spec := fun s h_wf => (s[i]'h_wf).asList.headD Data.empty
-  proof := Operation.computes_head i
+  spec  := fun s h_wf => (s[i]'h_wf).asList.headD Data.empty
+  time  := fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size
+  space := fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size
+  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
 
 instance (i : ℕ) : Operation.HasComputes (.tail i) where
-  spec := fun s h_wf => Data.l (s[i]'h_wf).asList.tail
-  proof := Operation.computes_tail i
+  spec  := fun s h_wf => Data.l (s[i]'h_wf).asList.tail
+  time  := fun s h_wf => 1 + (s[i]'h_wf).size
+  space := fun s h_wf => 1 + (Data.l (s[i]'h_wf).asList.tail).size
+  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
 
 instance : Operation.HasComputes .empty where
-  spec := fun _ _ => Data.empty
-  proof := Operation.computes_empty
+  spec  := fun _ _ => Data.empty
+  time  := fun _ _ => 1
+  space := fun _ _ => 1
+  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
 
 instance (i j : ℕ) : Operation.HasComputes (.eq i j) where
   spec := fun s h_wf =>
     if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse
-  proof := Operation.computes_eq i j
+  time  := fun s h_wf =>
+    1 + min (s[i]'h_wf.1).size (s[j]'h_wf.2).size
+  space := fun _ _ => 1
+  proof := by
+    intros s h_wf h_whf
+    simp [Operation.meteredEvalT, meteredEvalOp]
 
 instance {i : ℕ} {then_ else_ : List Operation}
     [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
     Operation.HasComputes (.ifEmpty i then_ else_) where
   spec := fun s h_wf =>
     if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1 else he.spec s h_wf.2.2
-  proof := Operation.computes_ifEmpty ht.proof he.proof
+  time := fun s h_wf =>
+    1 + (if (s[i]'h_wf.1) == Data.empty then ht.time s h_wf.2.1 else he.time s h_wf.2.2)
+  space := fun s h_wf =>
+    if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1 else he.space s h_wf.2.2
+  proof := by
+    intros s h_wf h_whf
+    rw [Operation.meteredEvalT_ifEmpty]
+    by_cases h : (s[i]'h_wf.1) == Data.empty
+    · simp [h, ht.proof s h_wf.2.1 h_whf.1]
+    · simp [h, he.proof s h_wf.2.2 h_whf.2]
 
 instance {body : Prog} {idxs : List TapeIndex}
     [hb : Prog.HasComputes body] :
@@ -746,21 +773,51 @@ instance {body : Prog} {idxs : List TapeIndex}
     hb.spec
       (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
       (by simpa using h_wf.2)
-  proof := Operation.computes_call hb.proof
+  time := fun s h_wf =>
+    hb.time
+      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+      (by simpa using h_wf.2)
+  space := fun s h_wf =>
+    hb.space
+      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+      (by simpa using h_wf.2)
+  proof := by
+    intros s h_wf h_whf
+    rw [Operation.meteredEvalT_call, hb.proof]
 
 /-- One-liner: extract the data result of any auto-resolvable program. -/
 abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
     (s : List Data) (h_wf : WFProg s.length p) : Data :=
   h.spec s h_wf
 
--- --------- Simp lemmas exposing each instance's spec ---------
--- These are all `rfl`: each instance's `spec` field is *definitionally* its RHS.
+-- --------- Bridge: `meteredEvalT` reduces to the triple of HasComputes fields ---------
+
+/-- The bridge: any `meteredEvalT` of a program with a `HasComputes` instance
+    rewrites to `(spec, time, space)`. Each projection (`.1`, `.2.1`, `.2.2`)
+    then reduces independently along its own simp chain. -/
+@[simp] lemma Prog.HasComputes.meteredEvalT_eq {p : Prog} [h : Prog.HasComputes p]
+    {s : List Data} {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
+    Prog.meteredEvalT p s h_wf h_whf = (h.spec s h_wf, h.time s h_wf, h.space s h_wf) :=
+  h.proof s h_wf h_whf
+
+@[simp] lemma Operation.HasComputes.meteredEvalT_eq {op : Operation}
+    [h : Operation.HasComputes op]
+    {s : List Data} {h_wf : WFOp s.length op} {h_whf : Operation.WhileFree op} :
+    Operation.meteredEvalT op s h_wf h_whf = (h.spec s h_wf, h.time s h_wf, h.space s h_wf) :=
+  h.proof s h_wf h_whf
+
+-- --------- Simp lemmas exposing each instance's spec/time/space ---------
+-- These are all `rfl`: each instance's field is *definitionally* its RHS.
 -- We expose them as `simp` lemmas so that `simp [...]` can unfold the chain
 -- compositionally without needing the instances themselves to be reducible.
 
 @[simp] lemma Prog.HasComputes.spec_nil :
     (Prog.HasComputes.spec (p := ([] : Prog))) =
       fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf) := rfl
+@[simp] lemma Prog.HasComputes.time_nil :
+    (Prog.HasComputes.time (p := ([] : Prog))) = fun _ _ => 0 := rfl
+@[simp] lemma Prog.HasComputes.space_nil :
+    (Prog.HasComputes.space (p := ([] : Prog))) = fun _ _ => 0 := rfl
 
 @[simp] lemma Prog.HasComputes.spec_cons {op : Operation} {rest : Prog}
     [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
@@ -768,26 +825,67 @@ abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
       fun s h_wf =>
         let r := hop.spec s h_wf.1
         hrest.spec (r :: s) h_wf.2 := rfl
+@[simp] lemma Prog.HasComputes.time_cons {op : Operation} {rest : Prog}
+    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
+    (Prog.HasComputes.time (p := op :: rest)) =
+      fun s h_wf =>
+        let r := hop.spec s h_wf.1
+        hop.time s h_wf.1 + hrest.time (r :: s) h_wf.2 := rfl
+@[simp] lemma Prog.HasComputes.space_cons {op : Operation} {rest : Prog}
+    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
+    (Prog.HasComputes.space (p := op :: rest)) =
+      fun s h_wf =>
+        let r := hop.spec s h_wf.1
+        hop.space s h_wf.1 + hrest.space (r :: s) h_wf.2 := rfl
 
 @[simp] lemma Operation.HasComputes.spec_cons (h t : ℕ) :
     (Operation.HasComputes.spec (op := .cons h t)) =
       fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList) := rfl
+@[simp] lemma Operation.HasComputes.time_cons (h t : ℕ) :
+    (Operation.HasComputes.time (op := .cons h t)) =
+      fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size := rfl
+@[simp] lemma Operation.HasComputes.space_cons (h t : ℕ) :
+    (Operation.HasComputes.space (op := .cons h t)) =
+      fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size := rfl
 
 @[simp] lemma Operation.HasComputes.spec_head (i : ℕ) :
     (Operation.HasComputes.spec (op := .head i)) =
       fun s h_wf => (s[i]'h_wf).asList.headD Data.empty := rfl
+@[simp] lemma Operation.HasComputes.time_head (i : ℕ) :
+    (Operation.HasComputes.time (op := .head i)) =
+      fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size := rfl
+@[simp] lemma Operation.HasComputes.space_head (i : ℕ) :
+    (Operation.HasComputes.space (op := .head i)) =
+      fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size := rfl
 
 @[simp] lemma Operation.HasComputes.spec_tail (i : ℕ) :
     (Operation.HasComputes.spec (op := .tail i)) =
       fun s h_wf => Data.l (s[i]'h_wf).asList.tail := rfl
+@[simp] lemma Operation.HasComputes.time_tail (i : ℕ) :
+    (Operation.HasComputes.time (op := .tail i)) =
+      fun s h_wf => 1 + (s[i]'h_wf).size := rfl
+@[simp] lemma Operation.HasComputes.space_tail (i : ℕ) :
+    (Operation.HasComputes.space (op := .tail i)) =
+      fun s h_wf => 1 + (Data.l (s[i]'h_wf).asList.tail).size := rfl
 
 @[simp] lemma Operation.HasComputes.spec_empty :
     (Operation.HasComputes.spec (op := .empty)) = fun _ _ => Data.empty := rfl
+@[simp] lemma Operation.HasComputes.time_empty :
+    (Operation.HasComputes.time (op := .empty)) = fun _ _ => 1 := rfl
+@[simp] lemma Operation.HasComputes.space_empty :
+    (Operation.HasComputes.space (op := .empty)) = fun _ _ => 1 := rfl
 
 @[simp] lemma Operation.HasComputes.spec_eq (i j : ℕ) :
     (Operation.HasComputes.spec (op := .eq i j)) =
       fun s h_wf =>
         if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse := rfl
+@[simp] lemma Operation.HasComputes.time_eq (i j : ℕ) :
+    (Operation.HasComputes.time (op := .eq i j)) =
+      fun s h_wf =>
+        1 + min (s[i]'h_wf.1).size (s[j]'h_wf.2).size := rfl
+@[simp] lemma Operation.HasComputes.space_eq (i j : ℕ) :
+    (Operation.HasComputes.space (op := .eq i j)) =
+      fun _ _ => 1 := rfl
 
 @[simp] lemma Operation.HasComputes.spec_ifEmpty {i : ℕ} {then_ else_ : List Operation}
     [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
@@ -795,6 +893,18 @@ abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
       fun s h_wf =>
         if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1
         else he.spec s h_wf.2.2 := rfl
+@[simp] lemma Operation.HasComputes.time_ifEmpty {i : ℕ} {then_ else_ : List Operation}
+    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
+    (Operation.HasComputes.time (op := .ifEmpty i then_ else_)) =
+      fun s h_wf =>
+        1 + (if (s[i]'h_wf.1) == Data.empty then ht.time s h_wf.2.1
+             else he.time s h_wf.2.2) := rfl
+@[simp] lemma Operation.HasComputes.space_ifEmpty {i : ℕ} {then_ else_ : List Operation}
+    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
+    (Operation.HasComputes.space (op := .ifEmpty i then_ else_)) =
+      fun s h_wf =>
+        if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1
+        else he.space s h_wf.2.2 := rfl
 
 @[simp] lemma Operation.HasComputes.spec_call {body : Prog} {idxs : List TapeIndex}
     [hb : Prog.HasComputes body] :
@@ -803,22 +913,44 @@ abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
         hb.spec
           (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
           (by simpa using h_wf.2) := rfl
+@[simp] lemma Operation.HasComputes.time_call {body : Prog} {idxs : List TapeIndex}
+    [hb : Prog.HasComputes body] :
+    (Operation.HasComputes.time (op := .call body idxs)) =
+      fun s h_wf =>
+        hb.time
+          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+          (by simpa using h_wf.2) := rfl
+@[simp] lemma Operation.HasComputes.space_call {body : Prog} {idxs : List TapeIndex}
+    [hb : Prog.HasComputes body] :
+    (Operation.HasComputes.space (op := .call body idxs)) =
+      fun s h_wf =>
+        hb.space
+          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
+          (by simpa using h_wf.2) := rfl
 
 -- --------- Worked example using automation ---------
 
-/-- Same as the previous example, but now the spec function and its proof are
-    synthesised by type-class resolution; only the goal statement is written by hand. -/
-example : Prog.Computes [Operation.head 0, Operation.tail 0]
-    (Prog.HasComputes.spec (p := [Operation.head 0, Operation.tail 0])) :=
-  Prog.HasComputes.proof
+/-- Same as the previous example, but now the spec function, time, space functions and the
+    bridging proof are all synthesised by type-class resolution; only the goal statement
+    is written by hand. -/
+example (s : List Data) (h_wf : WFProg s.length [Operation.head 0, Operation.tail 0])
+    (h_whf : Prog.WhileFree [Operation.head 0, Operation.tail 0]) :
+    Prog.meteredEvalT [Operation.head 0, Operation.tail 0] s h_wf h_whf
+      = (Prog.HasComputes.spec s h_wf,
+         Prog.HasComputes.time s h_wf,
+         Prog.HasComputes.space s h_wf) :=
+  Prog.HasComputes.proof _ _ _
 
 /-- A slightly larger program: take head of s[0], take tail of the new top, then
-    cons those two. Spec is derived automatically. -/
-example : Prog.Computes
-    [Operation.head 0, Operation.tail 0, Operation.cons 0 1]
-    (Prog.HasComputes.spec
-      (p := [Operation.head 0, Operation.tail 0, Operation.cons 0 1])) :=
-  Prog.HasComputes.proof
+    cons those two. Spec, cost and proof are derived automatically. -/
+example (s : List Data)
+    (h_wf : WFProg s.length [Operation.head 0, Operation.tail 0, Operation.cons 0 1])
+    (h_whf : Prog.WhileFree [Operation.head 0, Operation.tail 0, Operation.cons 0 1]) :
+    Prog.meteredEvalT [Operation.head 0, Operation.tail 0, Operation.cons 0 1] s h_wf h_whf
+      = (Prog.HasComputes.spec s h_wf,
+         Prog.HasComputes.time s h_wf,
+         Prog.HasComputes.space s h_wf) :=
+  Prog.HasComputes.proof _ _ _
 
 class DataEncode (α : Type) where
   encode : α → Data
@@ -962,31 +1094,6 @@ abbrev stackTape_cons : Prog := [
   .ifEmpty 0 [ .ifEmpty 1 [ .empty ] [ .cons 0 1 ] ] [ .cons 0 1 ]
 ]
 
-omit [Inhabited Symbol] [Fintype Symbol] in
-@[simp]
-lemma stackTape_cons.semantics
-    (x : Option Symbol) (xs : Turing.StackTape Symbol) {stack : List Data} :
-    (stackTape_cons.meteredEvalT (DataEncode.encode x :: DataEncode.encode xs :: stack)
-      (by simp [stackTape_cons, WFProg, WFOp]) (by simp [stackTape_cons])).1 =
-      DataEncode.encode (xs.cons x) := by
-  have h_encode_stackTape (xs : Turing.StackTape Symbol) :
-    DataEncode.encode xs = DataEncode.encode (xs.toList) := by simp [DataEncode.encode]
-  match x with
-  | none =>
-    by_cases h_tail : xs.toList = []
-    · have : xs = Turing.StackTape.nil := Turing.StackTape.ext _ _ (by simp [h_tail])
-      simp [stackTape_cons, h_encode_stackTape, this]
-      sorry
-    · have h_empty : ¬ (DataEncode.encode xs == Data.empty) := by
-        sorry
-      simp [stackTape_cons, h_empty]
-      simp [h_encode_stackTape]
-      -- TODO just some StackTape encoding stuff left to solve here.
-      sorry
-  | some x =>
-    simp [stackTape_cons, h_encode_stackTape]
-    simp [DataEncode.encode]
-
 -- def move_left (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
@@ -1014,17 +1121,11 @@ lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
       (by simp [snd, WFProg, WFOp]) (by simp [snd]) =
       DataEncode.encode y := by
   show Prog.evalData [Operation.tail 0, Operation.head 0] _ _ _ = _
-  rw [Prog.HasComputes.proof
-    (p := [Operation.tail 0, Operation.head 0])]
+  rw [← Prog.meteredEvalT_fst_eq_evalData,
+      Prog.HasComputes.proof (p := [Operation.tail 0, Operation.head 0])]
   simp [Prog.HasComputes.spec, Operation.HasComputes.spec,
     DataEncode.encode, Data.asList]
 
-/-- Bridge: the data component of `meteredEvalT` is exactly `evalData`. Used to
-    transport spec-based reasoning back to the original semantics statements. -/
-lemma Prog.meteredEvalT_fst_eq_evalData {p : Prog} {s : List Data}
-    {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
-    (Prog.meteredEvalT p s h_wf h_whf).1 = Prog.evalData p s h_wf h_whf := rfl
-
 /-- Instance for the named program `snd`: routed via `inferInstanceAs` since
     `snd` is a `def`, not an `abbrev`. -/
 instance instHasComputesSnd : Prog.HasComputes snd :=
@@ -1041,7 +1142,10 @@ lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Sym
       [DataEncode.encode head, DataEncode.encode tail] h_wf =
       DataEncode.encode (tail.cons head)
       := by
-  simp
+  simp only [Prog.HasComputes.spec_cons, Operation.HasComputes.spec_ifEmpty, List.getElem_cons_zero,
+    DataEncode_Option_empty, Option.isNone_iff_eq_none, List.getElem_cons_succ,
+    Operation.HasComputes.spec_empty, Prog.HasComputes.spec_nil, List.head_cons,
+    Operation.HasComputes.spec_cons]
   -- only encoding and stackTape business left.
   sorry
 
@@ -1077,7 +1181,8 @@ lemma tape_move_left.evalData_eq {Symbol : Type} [Inhabited Symbol] [Fintype Sym
     Prog.HasComputes.spec (p := tape_move_left)
       (DataEncode.encode t :: stack) (by simp) := by
   show Prog.evalData _ _ _ _ = _
-  rw [Prog.HasComputes.proof (p := tape_move_left)]
+  rw [← Prog.meteredEvalT_fst_eq_evalData,
+      Prog.HasComputes.proof (p := tape_move_left)]
 
 @[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :

From e042ba724ccbc35312722794ed79f23ad95c11c5 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 19:08:50 +0200
Subject: [PATCH 047/106] cleanup

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 340 +++++-------------
 1 file changed, 81 insertions(+), 259 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index dfcdf648e7..37fb22421e 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -57,11 +57,6 @@ deriving Repr, BEq
 
 abbrev Data.empty := Data.l []
 
--- -- TODO not sure why this is needed
--- @[simp]
--- lemma Data_beq (x : Data) : (x == x) := by sorry
-
-
 abbrev Data.asList
   | Data.l xs => xs
 
@@ -81,8 +76,8 @@ lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
 @[simp, grind =]
 lemma Data.cons_size {h : Data} {t : List Data} :
     (Data.l (h :: t)).size = h.size + (Data.l t).size := by
-  simp [Data.size, Nat.add_assoc, Nat.add_comm]
-  sorry
+  simp [Data.size]
+  grind
 
 abbrev TapeIndex := ℕ
 
@@ -91,11 +86,9 @@ abbrev TapeIndex := ℕ
 
 -- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
 -- Each operation creates a new stack entry (a new tape) and can read from previous
--- entries by index.
-
--- TODO: For the combinators (ite, fold, while_) I am not yet sure if we can/should restrict the
--- inner programs to return exactly one tape. Unrelated to that, the inner programs of `fold` and
--- `while_` are able to create "temporary" slots.
+-- entries by index. Stack entries created in "inner" programs are temporary and deleted
+-- once the inner program terminates. This is especially relevant for space complexity of
+-- loops since it allows us to re-use the space of one iteration for the next iteration.
 
 inductive Operation where
   -- create a new tape initialized with `Data.l []`
@@ -312,63 +305,47 @@ lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length
 --       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
 --   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_head
-    {i : ℕ}
-    {stack : List Data}
-    {h_wf : WFOp stack.length (.head i)} :
-    Operation.meteredEvalT (.head i) stack h_wf (by simp) =
-      (stack[i].asList.headD Data.empty,
-      1 + (stack[i].asList.headD Data.empty).size,
-      1 + (stack[i].asList.headD Data.empty).size) := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
-
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_tail
-    {i : ℕ}
-    {stack : List Data}
-    {h_wf : WFOp stack.length (.tail i)} :
-    Operation.meteredEvalT (.tail i) stack h_wf (by simp) =
-      (Data.l stack[i].asList.tail,
-      1 + stack[i].size,
-      1 + (Data.l stack[i].asList.tail).size) := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
+-- @[simp, scoped grind =]
+-- lemma Operation.meteredEvalT_head
+--     {i : ℕ}
+--     {stack : List Data}
+--     {h_wf : WFOp stack.length (.head i)} :
+--     Operation.meteredEvalT (.head i) stack h_wf (by simp) =
+--       (stack[i].asList.headD Data.empty,
+--       1 + (stack[i].asList.headD Data.empty).size,
+--       1 + (stack[i].asList.headD Data.empty).size) := by
+--   simp [Operation.meteredEvalT, meteredEvalOp]
 
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_ifEmpty
-    {i : ℕ}
-    {stack : List Data}
-    {then_ else_ : List Operation}
-    {h_wf : WFOp stack.length (.ifEmpty i then_ else_)}
-    {h_whf : WhileFree (.ifEmpty i then_ else_)} :
-    Operation.meteredEvalT (.ifEmpty i then_ else_) stack h_wf h_whf =
-      let (r, t, s) := if stack[i]'h_wf.1 == Data.empty then
-        Prog.meteredEvalT then_ stack h_wf.2.1 h_whf.1
-      else
-        Prog.meteredEvalT else_ stack h_wf.2.2 h_whf.2
-      (r, 1 + t, s) := by
-  by_cases h_empty : stack[i]'h_wf.1 == Data.empty
-  · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
-  · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
-
--- @[scoped grind =]
--- lemma Operation.meteredEvalT_call_single
+-- @[simp, scoped grind =]
+-- lemma Operation.meteredEvalT_tail
+--     {i : ℕ}
 --     {stack : List Data}
---     {body : Prog}
---     {i : TapeIndex}
---     {h_wf : WFOp stack.length (.call body [i])}
---     {h_whf : WhileFree (.call body [i])} :
---     Operation.meteredEvalT (.call body [i]) stack h_wf h_whf =
---       Prog.meteredEvalT body
---         [stack[i]'(by simpa using h_wf.1 i)]
---         h_wf.2
---         h_whf := by
---   sorry
+--     {h_wf : WFOp stack.length (.tail i)} :
+--     Operation.meteredEvalT (.tail i) stack h_wf (by simp) =
+--       (Data.l stack[i].asList.tail,
+--       1 + stack[i].size,
+--       1 + (Data.l stack[i].asList.tail).size) := by
+--   simp [Operation.meteredEvalT, meteredEvalOp]
 
+-- @[simp, scoped grind =]
+-- lemma Operation.meteredEvalT_ifEmpty
+--     {i : ℕ}
+--     {stack : List Data}
+--     {then_ else_ : List Operation}
+--     {h_wf : WFOp stack.length (.ifEmpty i then_ else_)}
+--     {h_whf : WhileFree (.ifEmpty i then_ else_)} :
+--     Operation.meteredEvalT (.ifEmpty i then_ else_) stack h_wf h_whf =
+--       let (r, t, s) := if stack[i]'h_wf.1 == Data.empty then
+--         Prog.meteredEvalT then_ stack h_wf.2.1 h_whf.1
+--       else
+--         Prog.meteredEvalT else_ stack h_wf.2.2 h_whf.2
+--       (r, 1 + t, s) := by
+--   by_cases h_empty : stack[i]'h_wf.1 == Data.empty
+--   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
+--   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
 
 -- this is not @simp because we do not want to unfold calls, they should have
 -- their own specific simp lemmas
-@[simp, scoped grind =]
 lemma Operation.meteredEvalT_call
     {stack : List Data}
     {body : Prog}
@@ -476,24 +453,6 @@ lemma Operation.meteredEvalT_fold_induction
     motive r t s := by
   sorry
 
-@[simp, scoped grind =]
-lemma Prog.meteredEvalT_nil
-    {stack : List Data}
-    {h_wf : WFProg stack.length []} :
-    Prog.meteredEvalT [] stack h_wf (by simp) = (stack.head (by grind [WFProg]), 0, 0) := by
-  simp [Prog.meteredEvalT]
-
-@[simp, scoped grind =]
-lemma Prog.meteredEvalT_cons_one
-    {op : Operation} {rest : Prog} {stack : List Data}
-    {h_wf : WFProg stack.length (op :: rest)}
-    {h_whf : Prog.WhileFree (op :: rest)} :
-    (Prog.meteredEvalT (op :: rest) stack h_wf h_whf).1 =
-      let s := stack
-      let r := (op.meteredEvalT s h_wf.1 h_whf.1).1
-      (meteredEvalT rest (r :: s) h_wf.2 h_whf.2).1 := by
-  sorry
-
 @[simp, scoped grind =]
 lemma Prog.meteredEvalT_cons
     {op : Operation} {rest : Prog} {stack : List Data}
@@ -525,7 +484,7 @@ lemma Prog.meteredEvalT_fst_eq_evalData {p : Prog} {s : List Data}
 
 lemma Prog.evalData_nil {stack : List Data} {h_wf : WFProg stack.length []} :
     Prog.evalData [] stack h_wf (by simp) = stack.head (by grind [WFProg]) := by
-  simp [Prog.evalData, Prog.meteredEvalT_nil]
+  simp [Prog.evalData, Prog.meteredEvalT]
 
 /-- Step lemma for `evalData`. The intermediate result `r` is `let`-bound so that
     repeated chaining keeps the goal linear in size. -/
@@ -563,113 +522,31 @@ def Prog.Computes (p : Prog)
   ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
     Prog.evalData p s h_wf h_whf = f s h_wf
 
-/-- The empty program returns the top of the stack. -/
-@[simp, grind .]
-theorem Prog.computes_nil :
-    Prog.Computes ([] : Prog)
-      (fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)) := by
-  intro s h_wf h_whf
-  simp [Prog.evalData, Prog.meteredEvalT_nil]
-
-/-- Sequencing rule. The composite program `op :: rest` runs `fop` on the input
-    stack, pushes the result, and then runs `frest` on the extended stack.
-    The intermediate value appears once via a `let` binding — no duplication. -/
-@[simp, grind .]
-theorem Prog.computes_cons {op : Operation} {rest : Prog}
-    {fop : (s : List Data) → WFOp s.length op → Data}
-    {frest : (s : List Data) → WFProg s.length rest → Data}
-    (h_op : Operation.Computes op fop)
-    (h_rest : Prog.Computes rest frest) :
-    Prog.Computes (op :: rest)
-      (fun s h_wf =>
-        let r := fop s h_wf.1
-        frest (r :: s) h_wf.2) := by
-  intro s h_wf h_whf
-  rw [Prog.evalData_cons]
-  rw [h_op s h_wf.1 h_whf.1]
-  rw [h_rest (fop s h_wf.1 :: s) h_wf.2 h_whf.2]
-
--- --------- Per-operation specs for `.cons`, `.head`, `.tail` ---------
-
-@[simp, grind .]
-theorem Operation.computes_head (i : ℕ) :
-    Operation.Computes (.head i)
-      (fun s h_wf => (s[i]'h_wf).asList.headD Data.empty) := by
-  intro s h_wf h_whf
-  simp [Operation.evalData, Operation.meteredEvalT_head]
-
-@[simp, grind .]
-theorem Operation.computes_tail (i : ℕ) :
-    Operation.Computes (.tail i)
-      (fun s h_wf => Data.l (s[i]'h_wf).asList.tail) := by
-  intro s h_wf h_whf
-  simp [Operation.evalData, Operation.meteredEvalT_tail]
-
-@[simp, grind .]
-theorem Operation.computes_empty :
-    Operation.Computes .empty (fun _ _ => Data.empty) := by
-  intro s h_wf h_whf
-  simp [Operation.evalData, Operation.meteredEvalT_empty]
-
-@[simp, grind .]
-theorem Operation.computes_eq (i j : ℕ) :
-    Operation.Computes (.eq i j)
-      (fun s h_wf =>
-        if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse) := by
-  intro s h_wf h_whf
-  simp [Operation.evalData, Operation.meteredEvalT, meteredEvalOp]
-
-@[simp, grind .]
-theorem Operation.computes_ifEmpty {i : ℕ} {then_ else_ : List Operation}
-    {f_then : (s : List Data) → WFProg s.length then_ → Data}
-    {f_else : (s : List Data) → WFProg s.length else_ → Data}
-    (h_then : Prog.Computes then_ f_then)
-    (h_else : Prog.Computes else_ f_else) :
-    Operation.Computes (.ifEmpty i then_ else_)
-      (fun s h_wf =>
-        if (s[i]'h_wf.1) == Data.empty then f_then s h_wf.2.1 else f_else s h_wf.2.2) := by
-  intro s h_wf h_whf
-  unfold Operation.evalData
-  rw [Operation.meteredEvalT_ifEmpty]
-  by_cases h : (s[i]'h_wf.1) == Data.empty
-  · simp only [h, if_true]
-    have := h_then s h_wf.2.1 h_whf.1
-    simp [Prog.evalData] at this
-    simp [this]
-  · simp only [h]
-    have := h_else s h_wf.2.2 h_whf.2
-    simp [Prog.evalData] at this
-    simp [this]
-
-@[simp, grind .]
-theorem Operation.computes_call {body : Prog} {idxs : List TapeIndex}
-    {f_body : (s : List Data) → WFProg s.length body → Data}
-    (h_body : Prog.Computes body f_body) :
-    Operation.Computes (.call body idxs)
-      (fun s h_wf =>
-        f_body
-          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-          (by simpa using h_wf.2)) := by
-  intro s h_wf h_whf
-  unfold Operation.evalData
-  rw [Operation.meteredEvalT_call]
-  exact h_body _ _ _
-
--- --------- Worked example: a small two-step program ---------
-
-/-- Example: `[.head 0, .tail 0]` first takes the head of `s[0]`, pushes it, then
-    takes the tail of the new top (which is the freshly-pushed head). The
-    intermediate result appears once, as the `let`-bound `r`. -/
-example : Prog.Computes [Operation.head 0, Operation.tail 0]
-    (fun s h_wf =>
-      let r := (s[0]'(by
-        rcases h_wf with ⟨h1, _⟩; exact h1)).asList.headD Data.empty
-      Data.l r.asList.tail) := by
-  intro s h_wf h_whf
-  -- grind -- [Prog.computes_cons, Operation.computes_head, Operation.computes_tail, Prog.computes_nil]
-  have h := Prog.computes_cons (Operation.computes_head 0)
-    (Prog.computes_cons (Operation.computes_tail 0) Prog.computes_nil)
-  exact h s h_wf h_whf
+-- /-- The empty program returns the top of the stack. -/
+-- @[simp, grind .]
+-- theorem Prog.computes_nil :
+--     Prog.Computes ([] : Prog)
+--       (fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)) := by
+--   intro s h_wf h_whf
+--   simp [Prog.evalData, Prog.meteredEvalT]
+
+-- /-- Sequencing rule. The composite program `op :: rest` runs `fop` on the input
+--     stack, pushes the result, and then runs `frest` on the extended stack.
+--     The intermediate value appears once via a `let` binding — no duplication. -/
+-- @[simp, grind .]
+-- theorem Prog.computes_cons {op : Operation} {rest : Prog}
+--     {fop : (s : List Data) → WFOp s.length op → Data}
+--     {frest : (s : List Data) → WFProg s.length rest → Data}
+--     (h_op : Operation.Computes op fop)
+--     (h_rest : Prog.Computes rest frest) :
+--     Prog.Computes (op :: rest)
+--       (fun s h_wf =>
+--         let r := fop s h_wf.1
+--         frest (r :: s) h_wf.2) := by
+--   intro s h_wf h_whf
+--   rw [Prog.evalData_cons]
+--   rw [h_op s h_wf.1 h_whf.1]
+--   rw [h_rest (fop s h_wf.1 :: s) h_wf.2 h_whf.2]
 
 -- ========================= Automation via type-class resolution =========================
 
@@ -695,17 +572,15 @@ class Prog.HasComputes (p : Prog) where
     Prog.meteredEvalT p s h_wf h_whf = (spec s h_wf, time s h_wf, space s h_wf)
 
 instance : Prog.HasComputes ([] : Prog) where
-  spec  := fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)
+  spec  := fun s h_wf => s.head (by simpa [WFProg] using h_wf)
   time  := fun _ _ => 0
   space := fun _ _ => 0
-  proof := by intros s h_wf h_whf; simp [Prog.meteredEvalT_nil]
+  proof := by simp [Prog.meteredEvalT]
 
 instance {op : Operation} {rest : Prog}
     [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
     Prog.HasComputes (op :: rest) where
-  spec := fun s h_wf =>
-    let r := hop.spec s h_wf.1
-    hrest.spec (r :: s) h_wf.2
+  spec := fun s h_wf => hrest.spec ((hop.spec s h_wf.1) :: s) h_wf.2
   time := fun s h_wf =>
     let r := hop.spec s h_wf.1
     hop.time s h_wf.1 + hrest.time (r :: s) h_wf.2
@@ -761,10 +636,12 @@ instance {i : ℕ} {then_ else_ : List Operation}
     if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1 else he.space s h_wf.2.2
   proof := by
     intros s h_wf h_whf
-    rw [Operation.meteredEvalT_ifEmpty]
+    simp [Operation.meteredEvalT, meteredEvalOp]
     by_cases h : (s[i]'h_wf.1) == Data.empty
-    · simp [h, ht.proof s h_wf.2.1 h_whf.1]
+    · simp [h, Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp]
+      sorry
     · simp [h, he.proof s h_wf.2.2 h_whf.2]
+      sorry
 
 instance {body : Prog} {idxs : List TapeIndex}
     [hb : Prog.HasComputes body] :
@@ -928,29 +805,9 @@ abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
           (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
           (by simpa using h_wf.2) := rfl
 
--- --------- Worked example using automation ---------
-
-/-- Same as the previous example, but now the spec function, time, space functions and the
-    bridging proof are all synthesised by type-class resolution; only the goal statement
-    is written by hand. -/
-example (s : List Data) (h_wf : WFProg s.length [Operation.head 0, Operation.tail 0])
-    (h_whf : Prog.WhileFree [Operation.head 0, Operation.tail 0]) :
-    Prog.meteredEvalT [Operation.head 0, Operation.tail 0] s h_wf h_whf
-      = (Prog.HasComputes.spec s h_wf,
-         Prog.HasComputes.time s h_wf,
-         Prog.HasComputes.space s h_wf) :=
-  Prog.HasComputes.proof _ _ _
-
-/-- A slightly larger program: take head of s[0], take tail of the new top, then
-    cons those two. Spec, cost and proof are derived automatically. -/
-example (s : List Data)
-    (h_wf : WFProg s.length [Operation.head 0, Operation.tail 0, Operation.cons 0 1])
-    (h_whf : Prog.WhileFree [Operation.head 0, Operation.tail 0, Operation.cons 0 1]) :
-    Prog.meteredEvalT [Operation.head 0, Operation.tail 0, Operation.cons 0 1] s h_wf h_whf
-      = (Prog.HasComputes.spec s h_wf,
-         Prog.HasComputes.time s h_wf,
-         Prog.HasComputes.space s h_wf) :=
-  Prog.HasComputes.proof _ _ _
+-------------------------------------
+--- Encoding of generic types into Data
+--------------------------------------
 
 class DataEncode (α : Type) where
   encode : α → Data
@@ -997,14 +854,6 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
-----------------------------------------------------------------
----- Function view
---------------------------------------------------------
-
-def FunType (inputs : ℕ) : Type := match inputs with
-  | 0 => Data
-  | n + 1 => Data → FunType n
-
 --------------------------------------------------------------------
 -- Example program
 ---------------------------------------------------------------------------
@@ -1142,10 +991,7 @@ lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Sym
       [DataEncode.encode head, DataEncode.encode tail] h_wf =
       DataEncode.encode (tail.cons head)
       := by
-  simp only [Prog.HasComputes.spec_cons, Operation.HasComputes.spec_ifEmpty, List.getElem_cons_zero,
-    DataEncode_Option_empty, Option.isNone_iff_eq_none, List.getElem_cons_succ,
-    Operation.HasComputes.spec_empty, Prog.HasComputes.spec_nil, List.head_cons,
-    Operation.HasComputes.spec_cons]
+  simp
   -- only encoding and stackTape business left.
   sorry
 
@@ -1159,46 +1005,22 @@ abbrev tape_move_left : Prog := [
   .cons 1 0
 ]
 
-instance instHasComputesTapeMoveLeft : Prog.HasComputes tape_move_left :=
-  inferInstanceAs (Prog.HasComputes tape_move_left)
 
 @[simp]
 lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
-  simp [tape_move_left, snd, stackTape_cons]
+  simp [snd]
 
 @[simp]
 lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
-  simp [tape_move_left, snd, stackTape_cons, WFProg, WFOp, h_le]
-
-/-- Data-only semantics of `tape_move_left`, derived by `HasComputes` automation.
-    Each step's contribution appears once (as a `let`-bound name in the spec
-    function), so the proof term does not duplicate the stack `O(n²)` times. -/
-lemma tape_move_left.evalData_eq {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
-    [DataEncode Symbol]
-    (t : Turing.BiTape Symbol) {stack : List Data} :
-    Prog.evalData tape_move_left (DataEncode.encode t :: stack)
-      (by simp) (by simp [tape_move_left, snd, stackTape_cons]) =
-    Prog.HasComputes.spec (p := tape_move_left)
-      (DataEncode.encode t :: stack) (by simp) := by
-  show Prog.evalData _ _ _ _ = _
-  rw [← Prog.meteredEvalT_fst_eq_evalData,
-      Prog.HasComputes.proof (p := tape_move_left)]
+  simp [snd, WFProg, WFOp, h_le]
 
 @[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp)
-      (by simp [tape_move_left, snd, stackTape_cons])).1 =
+      (by simp [snd])).1 =
       DataEncode.encode (Turing.BiTape.move_left t)
         := by
-  -- Step 1: switch from `meteredEvalT.1` to `evalData`, then apply the
-  -- `HasComputes`-derived spec equality. After this, the LHS is
-  -- `HasComputes.spec (p := tape_move_left) ...`.
-  rw [Prog.meteredEvalT_fst_eq_evalData, tape_move_left.evalData_eq]
-  -- Step 2: unfold the spec chain WITHOUT eliminating let-bindings (`zeta := false`).
-  -- Each intermediate result of the program becomes a `have r := ...` binder
-  -- in the goal, so the goal size is linear in the program length rather
-  -- than `O(n²)`. The per-program `.spec_eq` lemmas bridge the named-def
-  -- instances to their underlying list-literal instances.
+  rw [Prog.HasComputes.proof (p := tape_move_left)]
   simp
   sorry
 

From 76ae2699c0cc36cbd25c1459b88188a7669a1bc2 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 18 May 2026 19:20:01 +0200
Subject: [PATCH 048/106] cleanup

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 158 ++----------------
 1 file changed, 12 insertions(+), 146 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 37fb22421e..b25a3c30fd 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -289,76 +289,6 @@ def Prog.meteredEvalT (body : Prog) (stack : List Data)
     (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
   (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree h_wf h_whf stack rfl)
 
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_empty {stack : List Data} {h_wf : WFOp stack.length .empty} :
-    Operation.meteredEvalT .empty stack h_wf (by simp) = (Data.empty, 1, 1) := by
-  simp [Operation.meteredEvalT, meteredEvalOp]
-
--- @[simp, scoped grind =]
--- lemma Operation.meteredEvalT_cons
---     {h t : ℕ}
---     {stack : List Data}
---     {h_wf : WFOp stack.length (.cons h t)} :
---     Operation.meteredEvalT (.cons h t) stack h_wf (by simp) =
---       (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList),
---       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size,
---       1 + (Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)).size) := by
---   simp [Operation.meteredEvalT, meteredEvalOp]
-
--- @[simp, scoped grind =]
--- lemma Operation.meteredEvalT_head
---     {i : ℕ}
---     {stack : List Data}
---     {h_wf : WFOp stack.length (.head i)} :
---     Operation.meteredEvalT (.head i) stack h_wf (by simp) =
---       (stack[i].asList.headD Data.empty,
---       1 + (stack[i].asList.headD Data.empty).size,
---       1 + (stack[i].asList.headD Data.empty).size) := by
---   simp [Operation.meteredEvalT, meteredEvalOp]
-
--- @[simp, scoped grind =]
--- lemma Operation.meteredEvalT_tail
---     {i : ℕ}
---     {stack : List Data}
---     {h_wf : WFOp stack.length (.tail i)} :
---     Operation.meteredEvalT (.tail i) stack h_wf (by simp) =
---       (Data.l stack[i].asList.tail,
---       1 + stack[i].size,
---       1 + (Data.l stack[i].asList.tail).size) := by
---   simp [Operation.meteredEvalT, meteredEvalOp]
-
--- @[simp, scoped grind =]
--- lemma Operation.meteredEvalT_ifEmpty
---     {i : ℕ}
---     {stack : List Data}
---     {then_ else_ : List Operation}
---     {h_wf : WFOp stack.length (.ifEmpty i then_ else_)}
---     {h_whf : WhileFree (.ifEmpty i then_ else_)} :
---     Operation.meteredEvalT (.ifEmpty i then_ else_) stack h_wf h_whf =
---       let (r, t, s) := if stack[i]'h_wf.1 == Data.empty then
---         Prog.meteredEvalT then_ stack h_wf.2.1 h_whf.1
---       else
---         Prog.meteredEvalT else_ stack h_wf.2.2 h_whf.2
---       (r, 1 + t, s) := by
---   by_cases h_empty : stack[i]'h_wf.1 == Data.empty
---   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
---   · simp [Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp, h_empty]
-
--- this is not @simp because we do not want to unfold calls, they should have
--- their own specific simp lemmas
-lemma Operation.meteredEvalT_call
-    {stack : List Data}
-    {body : Prog}
-    {idxs : List TapeIndex}
-    {h_wf : WFOp stack.length (.call body idxs)}
-    {h_whf : WhileFree (.call body idxs)} :
-    Operation.meteredEvalT (.call body idxs) stack h_wf h_whf =
-      Prog.meteredEvalT body
-        (idxs.attach.map (fun ⟨i, hi⟩ => stack[i]'(h_wf.1 i hi)))
-        (by simpa using h_wf.2)
-        h_whf := by
-  sorry
-
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
     {h_wf : WFOp stack.length (.fold body initial list)}
@@ -464,43 +394,12 @@ lemma Prog.meteredEvalT_cons
       (stack, opT + t, opS + s) := by
   sorry
 
--- ========================= Data-only evaluation =========================
-
-/-- Data-only evaluation of a single operation (discards time/space). -/
-def Operation.evalData (op : Operation) (stack : List Data)
-    (h_wf : WFOp stack.length op) (h_whf : Operation.WhileFree op) : Data :=
-  (Operation.meteredEvalT op stack h_wf h_whf).1
-
-/-- Data-only evaluation of a program (discards time/space). -/
-def Prog.evalData (prog : Prog) (stack : List Data)
-    (h_wf : WFProg stack.length prog) (h_whf : Prog.WhileFree prog) : Data :=
-  (Prog.meteredEvalT prog stack h_wf h_whf).1
-
-/-- Bridge: the data component of `meteredEvalT` is exactly `evalData`. Used to
-    transport spec-based reasoning back to the original semantics statements. -/
-lemma Prog.meteredEvalT_fst_eq_evalData {p : Prog} {s : List Data}
-    {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
-    (Prog.meteredEvalT p s h_wf h_whf).1 = Prog.evalData p s h_wf h_whf := rfl
-
-lemma Prog.evalData_nil {stack : List Data} {h_wf : WFProg stack.length []} :
-    Prog.evalData [] stack h_wf (by simp) = stack.head (by grind [WFProg]) := by
-  simp [Prog.evalData, Prog.meteredEvalT]
-
-/-- Step lemma for `evalData`. The intermediate result `r` is `let`-bound so that
-    repeated chaining keeps the goal linear in size. -/
-lemma Prog.evalData_cons {op : Operation} {rest : Prog} {stack : List Data}
-    {h_wf : WFProg stack.length (op :: rest)} {h_whf : Prog.WhileFree (op :: rest)} :
-    Prog.evalData (op :: rest) stack h_wf h_whf =
-      let r := Operation.evalData op stack h_wf.1 h_whf.1
-      Prog.evalData rest (r :: stack) h_wf.2 h_whf.2 := by
-  simp [Prog.evalData, Operation.evalData]
-
--- ========================= Hoare-style specs (Option A) =========================
+-- ========================= Compositional specifications =========================
 
 /-! ## Compositional specifications
 
 `Operation.Computes op f` (resp. `Prog.Computes p f`) says: whenever `op` (resp. `p`)
-runs on a well-formed, while-free stack `s`, the resulting data equals `f s h_wf`.
+is while-free and runs on a suitable stack `s`, the resulting data equals `f s h_wf`.
 The function `f` is allowed to depend on the well-formedness proof so that it can
 write `s[i]'_` directly.
 
@@ -514,39 +413,13 @@ proof of the composite program never instantiates a giant inlined stack term. -/
 def Operation.Computes (op : Operation)
     (f : (s : List Data) → WFOp s.length op → Data) : Prop :=
   ∀ (s : List Data) (h_wf : WFOp s.length op) (h_whf : Operation.WhileFree op),
-    Operation.evalData op s h_wf h_whf = f s h_wf
+    (Operation.meteredEvalT op s h_wf h_whf).1 = f s h_wf
 
 /-- A specification for a program. -/
 def Prog.Computes (p : Prog)
     (f : (s : List Data) → WFProg s.length p → Data) : Prop :=
   ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
-    Prog.evalData p s h_wf h_whf = f s h_wf
-
--- /-- The empty program returns the top of the stack. -/
--- @[simp, grind .]
--- theorem Prog.computes_nil :
---     Prog.Computes ([] : Prog)
---       (fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf)) := by
---   intro s h_wf h_whf
---   simp [Prog.evalData, Prog.meteredEvalT]
-
--- /-- Sequencing rule. The composite program `op :: rest` runs `fop` on the input
---     stack, pushes the result, and then runs `frest` on the extended stack.
---     The intermediate value appears once via a `let` binding — no duplication. -/
--- @[simp, grind .]
--- theorem Prog.computes_cons {op : Operation} {rest : Prog}
---     {fop : (s : List Data) → WFOp s.length op → Data}
---     {frest : (s : List Data) → WFProg s.length rest → Data}
---     (h_op : Operation.Computes op fop)
---     (h_rest : Prog.Computes rest frest) :
---     Prog.Computes (op :: rest)
---       (fun s h_wf =>
---         let r := fop s h_wf.1
---         frest (r :: s) h_wf.2) := by
---   intro s h_wf h_whf
---   rw [Prog.evalData_cons]
---   rw [h_op s h_wf.1 h_whf.1]
---   rw [h_rest (fop s h_wf.1 :: s) h_wf.2 h_whf.2]
+    (Prog.meteredEvalT p s h_wf h_whf).1 = f s h_wf
 
 -- ========================= Automation via type-class resolution =========================
 
@@ -660,7 +533,9 @@ instance {body : Prog} {idxs : List TapeIndex}
       (by simpa using h_wf.2)
   proof := by
     intros s h_wf h_whf
-    rw [Operation.meteredEvalT_call, hb.proof]
+    simp [Operation.meteredEvalT, meteredEvalOp]
+    sorry
+
 
 /-- One-liner: extract the data result of any auto-resolvable program. -/
 abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
@@ -946,13 +821,13 @@ abbrev stackTape_cons : Prog := [
 -- def move_left (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
-def snd : Prog := [ .tail 0, .head 0 ]
+abbrev snd : Prog := [ .tail 0, .head 0 ]
 
 @[simp]
 lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
     {stack : List Data} {x : α} {y : β} :
     (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
-      (by simp [snd, WFProg, WFOp]) (by simp [snd])) =
+      (by simp [WFProg, WFOp]) (by simp)) =
       (DataEncode.encode y,
         2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
         4 + 2 * (DataEncode.encode y).size)
@@ -966,19 +841,10 @@ lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
     full `(Data × ℕ × ℕ)` triple, hence no `O(n²)` blowup. -/
 lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
     {stack : List Data} {x : α} {y : β} :
-    Prog.evalData snd (DataEncode.encode (x, y) :: stack)
-      (by simp [snd, WFProg, WFOp]) (by simp [snd]) =
+    (Prog.meteredEvalT snd (DataEncode.encode (x, y) :: stack)
+      (by simp [WFProg, WFOp]) (by simp)).1 =
       DataEncode.encode y := by
-  show Prog.evalData [Operation.tail 0, Operation.head 0] _ _ _ = _
-  rw [← Prog.meteredEvalT_fst_eq_evalData,
-      Prog.HasComputes.proof (p := [Operation.tail 0, Operation.head 0])]
-  simp [Prog.HasComputes.spec, Operation.HasComputes.spec,
-    DataEncode.encode, Data.asList]
-
-/-- Instance for the named program `snd`: routed via `inferInstanceAs` since
-    `snd` is a `def`, not an `abbrev`. -/
-instance instHasComputesSnd : Prog.HasComputes snd :=
-  inferInstanceAs (Prog.HasComputes [Operation.tail 0, Operation.head 0])
+  simp
 
 @[simp] lemma snd.spec_eq :
     (Prog.HasComputes.spec (p := snd)) =

From 65a1e47bf771ba26b575b3083e05a8c682acbe7c Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 19 May 2026 15:28:17 +0200
Subject: [PATCH 049/106] eq for data

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 144 +++++++++++++++---
 1 file changed, 122 insertions(+), 22 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index b25a3c30fd..5ce12764dd 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -53,10 +53,32 @@ namespace RoseTreeMachine
 -- 2. define a "fold" operation
 inductive Data where
   | l : List Data → Data
-deriving Repr, BEq
+deriving Repr
+
+mutual
+  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
+    | .l xs, .l ys =>
+      match Data.listDecEq xs ys with
+      | isTrue h => isTrue (congrArg Data.l h)
+      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
+  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
+    | [], [] => isTrue rfl
+    | [], _ :: _ => isFalse (by simp)
+    | _ :: _, [] => isFalse (by simp)
+    | x :: xs, y :: ys =>
+      match Data.decEq x y, Data.listDecEq xs ys with
+      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
+      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
+      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
+end
+
+instance : DecidableEq Data := Data.decEq
+instance : BEq Data := inferInstance
+instance : LawfulBEq Data := inferInstance
 
 abbrev Data.empty := Data.l []
 
+
 abbrev Data.asList
   | Data.l xs => xs
 
@@ -510,10 +532,10 @@ instance {i : ℕ} {then_ else_ : List Operation}
   proof := by
     intros s h_wf h_whf
     simp [Operation.meteredEvalT, meteredEvalOp]
-    by_cases h : (s[i]'h_wf.1) == Data.empty
-    · simp [h, Operation.meteredEvalT, Prog.meteredEvalT, meteredEvalOp]
+    by_cases h : (s[i]'h_wf.1 = Data.empty)
+    · simp [h]
       sorry
-    · simp [h, he.proof s h_wf.2.2 h_whf.2]
+    · simp [h]
       sorry
 
 instance {body : Prog} {idxs : List TapeIndex}
@@ -717,9 +739,10 @@ instance (α : Type) [DataEncode α] : DataEncode (Option α) where
     | some x => Data.l [DataEncode.encode x]
   h_inj := by sorry
 
-@[simp, scoped grind =]
+@[simp]
 lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
-  (DataEncode.encode x == Data.empty) = x.isNone := by sorry
+  (DataEncode.encode x == Data.empty) = x.isNone := by
+  cases x <;> simp [DataEncode.encode, Data.empty]
 
 instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
   encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
@@ -850,6 +873,7 @@ lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
     (Prog.HasComputes.spec (p := snd)) =
       (Prog.HasComputes.spec (p := [Operation.tail 0, Operation.head 0])) := rfl
 
+omit [Inhabited Symbol] [Fintype Symbol] in
 @[simp]
 lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Symbol)
       (h_wf : WFProg [DataEncode.encode head, DataEncode.encode tail].length stackTape_cons) :
@@ -857,9 +881,23 @@ lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Sym
       [DataEncode.encode head, DataEncode.encode tail] h_wf =
       DataEncode.encode (tail.cons head)
       := by
-  simp
-  -- only encoding and stackTape business left.
-  sorry
+  cases head with
+  | none =>
+    obtain ⟨l, hl⟩ := tail
+    cases l with
+    | nil => simp [DataEncode.encode, Turing.StackTape.cons]
+    | cons hd tl => simp [DataEncode.encode, Turing.StackTape.cons]
+  | some a => simp [DataEncode.encode, Turing.StackTape.cons]
+
+abbrev to_pair : Prog := [ .empty, .cons 2 0, .cons 2 0 ]
+
+@[simp]
+lemma to_pair.semantics {α β : Type} [DataEncode α] [DataEncode β]
+    {stack : List Data} {x : α} {y : β} :
+    (to_pair.meteredEvalT (DataEncode.encode x :: DataEncode.encode y :: stack)
+      (by simp [WFProg, WFOp]) (by simp)).1 =
+      DataEncode.encode (x, y) := by
+  simp [to_pair, DataEncode.encode]
 
 abbrev tape_move_left : Prog := [
   .head 0, -- t.head
@@ -867,31 +905,93 @@ abbrev tape_move_left : Prog := [
   .call stackTape_cons [1, 0], -- StackTape.cons t.head t.right
   .call [ .call snd [0], .head 0, .tail 0 ] [3], -- t.left.tail
   .call [ .call snd [0], .head 0, .head 0 ] [4], -- t.left.head
-  .cons 1 2,
-  .cons 1 0
+  .call to_pair [1, 2],
+  .call to_pair [1, 0],
 ]
 
 
-@[simp]
-lemma tape_move_left_whf : Prog.WhileFree tape_move_left := by
-  simp [snd]
-
-@[simp]
-lemma tape_move_left_wf (n : ℕ) (h_le : 0 < n) : WFProg n tape_move_left := by
-  simp [snd, WFProg, WFOp, h_le]
-
 @[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
-    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp)
-      (by simp [snd])).1 =
+    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
+      (by simp)).1 =
       DataEncode.encode (Turing.BiTape.move_left t)
         := by
+  have encode_st (st : Turing.StackTape Symbol) :
+    DataEncode.encode st = DataEncode.encode st.toList := by
+    simp [DataEncode.encode]
+  have encode_bt (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+  have encode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+    (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+    simp [DataEncode.encode]
+  have h_head (st : Turing.StackTape Symbol) :
+      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
+      DataEncode.encode st.head := by
+    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
+  have h_tail (st : Turing.StackTape Symbol) :
+      DataEncode.encode st.toList.tail = DataEncode.encode st.tail := by
+    have : st.tail.toList = st.toList.tail :=
+      by rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
+          simp [Turing.StackTape.tail, Turing.StackTape.nil]
+    simp [DataEncode.encode, this]
   rw [Prog.HasComputes.proof (p := tape_move_left)]
-  simp
+  unfold Turing.BiTape.move_left
+  simp --
+  simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
+  -- simp [DataEncode.encode]
+  sorry
+
+-- def move_right (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
+
+abbrev tape_move_right : Prog := [
+  .head 0,                                    -- t.head
+  .call [ .call snd [0], .call snd [0] ] [1], -- t.right
+  .call [ .call snd [0], .head 0 ] [2],       -- t.left
+  .call stackTape_cons [2, 0],                -- cons(t.head, t.left)
+  .head 2,                                    -- t.right.head
+  .tail 3,                                    -- t.right.tail
+  .call to_pair [2, 0],                       -- pair(cons(t.head,t.left), t.right.tail)
+  .call to_pair [2, 0],                       -- pair(t.right.head, ...)
+]
+
+
+@[simp]
+lemma tape_move_right.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
+    (tape_move_right.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
+      (by simp)).1 =
+      DataEncode.encode (Turing.BiTape.move_right t)
+        := by
+  have encode_st (st : Turing.StackTape Symbol) :
+    DataEncode.encode st = DataEncode.encode st.toList := by
+    simp [DataEncode.encode]
+  have encode_bt (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+  have encode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+    (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+    simp [DataEncode.encode]
+  have h_head (st : Turing.StackTape Symbol) :
+      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
+      DataEncode.encode st.head := by
+    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
+  have h_tail (st : Turing.StackTape Symbol) :
+      DataEncode.encode st.toList.tail = DataEncode.encode st.tail := by
+    have : st.tail.toList = st.toList.tail :=
+      by rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
+          simp [Turing.StackTape.tail, Turing.StackTape.nil]
+    simp [DataEncode.encode, this]
+  rw [Prog.HasComputes.proof (p := tape_move_right)]
+  unfold Turing.BiTape.move_right
+  -- simp --
+  -- simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
+  -- simp [DataEncode.encode]
   sorry
 
 
 
+
 -- def put : Data → Prog
 --   | Data.l [] => [ .empty ]
 --   | Data.l (head :: tail) => [

From 5220c7bee67ce72a4ba58521ce73dfd18c9fbe6f Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Wed, 20 May 2026 09:31:14 +0800
Subject: [PATCH 050/106] feat: remove open_fresh_preserve_not_fvar (#573)

This PR remove `open_fresh_preserve_not_fvar`: because
`open_preserve_not_fvar` is the stronger version of
`open_fresh_preserve_not_fvar`
---
 .../LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean   | 2 +-
 .../LambdaCalculus/LocallyNameless/Untyped/FullEta.lean    | 2 +-
 .../LambdaCalculus/LocallyNameless/Untyped/Properties.lean | 7 +------
 3 files changed, 3 insertions(+), 8 deletions(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
index 1b90ff1e6d..f9a5f00c86 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
@@ -104,7 +104,7 @@ lemma step_not_fv (step : M ⭢βᶠ N) (hw : w ∉ M.fv) : w ∉ N.fv := by
   | abs =>
     have ⟨x, _⟩ := fresh_exists <| free_union [fv] Var
     have := open_close x
-    grind [close_preserve_not_fvar, open_fresh_preserve_not_fvar]
+    grind [close_preserve_not_fvar, open_preserve_not_fvar]
   | _ => grind
 
 /-- Abstracting then closing preserves a single reduction. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
index 9907b11a2f..10d29d35e5 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
@@ -69,7 +69,7 @@ lemma step_not_fv (step : M ⭢ηᶠ M') (hw : w ∉ M.fv) : w ∉ M'.fv := by
   | abs =>
     have ⟨x, _⟩ := fresh_exists <| free_union [fv] Var
     have := open_close x
-    grind [close_preserve_not_fvar, open_fresh_preserve_not_fvar]
+    grind [close_preserve_not_fvar, open_preserve_not_fvar]
   | _ => grind
 
 /-- Substitution of a fresh variable preserves an η-reduction step. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index aedd0be0b3..5bb9979a94 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -55,11 +55,6 @@ lemma swap_open_fvar_close (k n : ℕ) (x y : Var) (m : Term Var) (neq₁ : k 
 lemma close_preserve_not_fvar {k x y} (m : Term Var) (nmem : x ∉ m.fv) : x ∉ (m⟦k ↜ y⟧).fv := by
   induction m generalizing k <;> grind
 
-/-- Opening to a fresh free variable preserves free variables. -/
-lemma open_fresh_preserve_not_fvar {k x y} (m : Term Var) (nmem : x ∉ m.fv) (neq : x ≠ y) :
-    x ∉ (m⟦k ↝ fvar y⟧).fv := by
-  induction m generalizing k <;> grind
-
 /-- Opening preserves free variables. -/
 lemma open_preserve_not_fvar {k x} (m n : Term Var) (nmem_m : x ∉ m.fv) (nmem_n : x ∉ n.fv) :
     x ∉ (m⟦k ↝ n⟧).fv := by
@@ -144,7 +139,7 @@ lemma open_close_to_subst (m : Term Var) (x y : Var) (k : ℕ) (m_lc : LC m) :
     grind [
       swap_open, =_ swap_open_fvar_close,
       open_close x' (t⟦k+1 ↜ x⟧⟦k+1 ↝ fvar y⟧) 0, open_close x' (t[x := fvar y]) 0,
-      open_fresh_preserve_not_fvar, close_preserve_not_fvar, subst_preserve_not_fvar]
+       open_preserve_not_fvar, close_preserve_not_fvar, subst_preserve_not_fvar]
   | _ => grind
 
 /-- Closing and opening are inverses. -/

From a188b7623d58522b4c1e7408c6c132de4300e046 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Wed, 20 May 2026 10:10:42 +0800
Subject: [PATCH 051/106] feat: decidable `LcAt` and `LC` (#572)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This PR makes `LcAt` and `LC` decidable.

Before:

```lean
def Term_LA0L1 : Term String := .abs (.app (.bvar 0) (.abs (.bvar 1)))

theorem LA0L1_lc : Term_LA0L1.LC := by
unfold Term_LA0L1
apply LC.abs
intros
simp [open', openRec]
apply LC.app
grind
apply LC.abs
intros
simp [open', openRec]
grind
exact ∅
exact ∅
```

After:

```lean
theorem LA0L1_lc : LcAt 0 Term_LA0L1 := by decide
```
---
 .../LambdaCalculus/LocallyNameless/Untyped/LcAt.lean   | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
index 5a6529c1e7..7222d84bb6 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
@@ -27,10 +27,10 @@ variable {Var : Type u}
 
 /-- `LcAt k M` is satisfied when all bound indices of M are smaller than `k`. -/
 @[simp, scoped grind =]
-def LcAt (k : ℕ) : Term Var → Prop
+def LcAt (k : ℕ) : Term Var → Bool
 | bvar i => i < k
-| fvar _ => True
-| app t₁ t₂ => LcAt k t₁ ∧ LcAt k t₂
+| fvar _ => true
+| app t₁ t₂ => LcAt k t₁ && LcAt k t₂
 | abs t => LcAt (k + 1) t
 
 /-- `depth` counts the maximum number of the lambdas that are enclosing variables. -/
@@ -83,6 +83,10 @@ theorem lcAt_iff_LC (M : Term Var) [HasFresh Var] : LcAt 0 M ↔ M.LC := by
         grind [fresh_exists L]
     | _ => grind [cases LC]
 
+instance [HasFresh Var] (t : Term Var) : Decidable t.LC := by
+  rw [← lcAt_iff_LC]
+  infer_instance
+
 /- Opening for some term at i-th bound variable increments `LcAt` by one -/
 lemma lcAt_openRec_lcAt (M N : Term Var) (i : ℕ) :
     LcAt i (M⟦i ↝ N⟧) → LcAt (i + 1) M := by

From cb6469f7387581969a6310a68689a0db570c6c16 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Wed, 20 May 2026 14:35:56 +0800
Subject: [PATCH 052/106] feat(FullBetaEta): redex_app_l_cong, redex_app_r_cong
 (#571)

This PR introduces `FullBetaEta.redex_app_l_cong` and
`FullBetaEta.redex_app_r_cong`

Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 Cslib.lean                                    |  1 +
 .../LocallyNameless/Untyped/FullBetaEta.lean  | 62 +++++++++++++++++++
 .../Untyped/FullBetaEtaConfluence.lean        |  5 +-
 3 files changed, 64 insertions(+), 4 deletions(-)
 create mode 100644 Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEta.lean

diff --git a/Cslib.lean b/Cslib.lean
index 1b7b4c4b13..b504973c3e 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -116,6 +116,7 @@ public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Basic
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Congruence
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBeta
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaConfluence
+public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaEta
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaEtaConfluence
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullEta
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullEtaConfluence
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEta.lean
new file mode 100644
index 0000000000..a78ade35f9
--- /dev/null
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEta.lean
@@ -0,0 +1,62 @@
+/-
+Copyright (c) 2026 Maximiliano Onofre Martínez. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Maximiliano Onofre Martínez, Yijun Leng
+-/
+
+module
+
+public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaConfluence
+public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullEtaConfluence
+
+/-! # βη-Confluence for the λ-calculus
+
+## Reference
+
+* [T. Nipkow, *More Church-Rosser Proofs (in Isabelle/HOL)*][Nipkow2001]
+
+-/
+
+@[expose] public section
+
+set_option linter.unusedDecidableInType false
+
+namespace Cslib
+
+universe u
+
+variable {Var : Type u}
+
+namespace LambdaCalculus.LocallyNameless.Untyped.Term
+
+open Relation
+
+/-- Full βη-reduction. -/
+@[reduction_sys "βηᶠ"]
+abbrev FullBetaEta : Term Var → Term Var → Prop := FullBeta ⊔ FullEta
+
+namespace FullBetaEta
+
+theorem redex_app_l_cong (redex : M ↠βηᶠ M') (lc_N : LC N) : app M N ↠βηᶠ app M' N := by
+  induction redex with
+  | refl => grind
+  | tail _ h ih =>
+    refine .trans ih (.single ?_)
+    rcases h with h | h
+    · exact join_inl (h.appR lc_N)
+    · exact join_inr (h.appR lc_N)
+
+theorem redex_app_r_cong (redex : M ↠βηᶠ M') (lc_N : LC N) : app N M ↠βηᶠ app N M' := by
+  induction redex with
+  | refl => grind
+  | tail _ h ih =>
+    refine .trans ih (.single ?_)
+    rcases h with h | h
+    · exact join_inl (h.appL lc_N)
+    · exact join_inr (h.appL lc_N)
+
+end FullBetaEta
+
+end LambdaCalculus.LocallyNameless.Untyped.Term
+
+end Cslib
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
index 24ae1c9438..d56359e8ad 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
@@ -8,6 +8,7 @@ module
 
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaConfluence
 public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullEtaConfluence
+public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.FullBetaEta
 
 /-! # βη-Confluence for the λ-calculus
 
@@ -32,10 +33,6 @@ namespace LambdaCalculus.LocallyNameless.Untyped.Term
 
 open Relation
 
-/-- Full βη-reduction. -/
-@[reduction_sys "βηᶠ"]
-abbrev FullBetaEta : Term Var → Term Var → Prop := FullBeta ⊔ FullEta
-
 open FullEta FullBeta in
 /-- η-reduction and β-reduction strongly commute. -/
 lemma stronglyCommute_eta_beta : StronglyCommute (@FullEta Var) FullBeta := by

From caa9a9c1fad8d6ae627941ae921557731da055d7 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Wed, 20 May 2026 19:33:03 +0800
Subject: [PATCH 053/106] feat: precise `close_preserve_not_fvar` (#580)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

`(m⟦k ↜ y⟧).fv` can be precisely represented: `(m⟦k ↜ y⟧).fv =
m.fv.erase y`
---
 .../LambdaCalculus/LocallyNameless/Untyped/Properties.lean      | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index 5bb9979a94..e79c4bb960 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -52,7 +52,7 @@ lemma swap_open_fvar_close (k n : ℕ) (x y : Var) (m : Term Var) (neq₁ : k 
   induction m generalizing k n <;> grind
 
 /-- Closing preserves free variables. -/
-lemma close_preserve_not_fvar {k x y} (m : Term Var) (nmem : x ∉ m.fv) : x ∉ (m⟦k ↜ y⟧).fv := by
+lemma close_preserve_not_fvar {k y} (m : Term Var) : (m⟦k ↜ y⟧).fv = m.fv.erase y := by
   induction m generalizing k <;> grind
 
 /-- Opening preserves free variables. -/

From 9bc06f7a469a611db09f88ba1bb5c0708a96f465 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Wed, 20 May 2026 20:00:15 +0200
Subject: [PATCH 054/106] proofs that while-free programs are total.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 89 ++++++++++++++++---
 1 file changed, 79 insertions(+), 10 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 5ce12764dd..f63705d961 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -275,17 +275,83 @@ mutual
     | op :: rest => Operation.WhileFree op ∧ Prog.WhileFree rest
 end
 
+/-- Helper: assemble totality of `op :: rest` from totality of `op` (the operation) and
+    totality of `rest` (the remaining program). -/
 @[simp]
-theorem Prog_total_of_WhileFree {n : ℕ} {body : Prog}
+lemma progConsCase {n : ℕ} {op : Operation} {rest : Prog}
+    (h_wf : WFProg n (op :: rest))
+    (h_op_total : Operation.Total op h_wf.1)
+    (h_rest_total : Prog.Total rest h_wf.2) :
+    Prog.Total (op :: rest) h_wf := by
+  intro stack h_len
+  subst h_len
+  simp only [meteredEvalProg]
+  exact Part.bind_dom.mpr ⟨h_op_total stack rfl,
+    Part.bind_dom.mpr ⟨h_rest_total _ (by simp), trivial⟩⟩
+
+@[simp]
+theorem Prog_total_of_WhileFree {n : ℕ} (body : Prog)
     (h_wf : WFProg n body) (h_whileFree : Prog.WhileFree body) :
     Prog.Total body h_wf := by
-  sorry
+  match body with
+  | [] => intro stack h_len; simp [meteredEvalProg]
+  | op :: rest =>
+    apply progConsCase _ _ (Prog_total_of_WhileFree rest h_wf.2 h_whileFree.2)
+    intro stack h_len
+    match op with
+    | .empty | .cons _ _ | .head _ | .tail _ | .eq _ _ =>
+      simp [meteredEvalOp]
+    | .ifEmpty i t e =>
+      have ht := Prog_total_of_WhileFree t h_wf.1.2.1 h_whileFree.1.1 stack h_len
+      have he := Prog_total_of_WhileFree e h_wf.1.2.2 h_whileFree.1.2 stack h_len
+      by_cases h : (stack[i]'(h_len ▸ h_wf.1.1)) = Data.empty <;> simp [meteredEvalOp, h, ht, he]
+    | .fold b init lst =>
+      simp only [meteredEvalOp]
+      subst h_len
+      suffices h : ∀ items acc, (goMeteredFold items acc stack b h_wf.1.2.2).Dom from h _ _
+      intro items
+      induction items with
+      | nil => simp [goMeteredFold]
+      | cons _ _ ih =>
+        intro acc
+        simp only [goMeteredFold]
+        have hb := Prog_total_of_WhileFree b h_wf.1.2.2 h_whileFree.1
+        exact Part.bind_dom.mpr ⟨hb _ (by simp), ih _⟩
+    | .while_ _ _ => exact absurd h_whileFree.1 (by simp)
+    | .call b idxs =>
+      simp only [meteredEvalOp]
+      have hb := Prog_total_of_WhileFree b (by simpa using h_wf.1.2) h_whileFree.1
+      have hrest := Prog_total_of_WhileFree rest h_wf.2 h_whileFree.2
+      subst h_len
+      suffices h : ∀ (idxs' : List TapeIndex) (copiedStack : List Data)
+          (h_idxs' : ∀ i ∈ idxs', i < stack.length)
+          (h_wf' : WFProg (idxs'.length + copiedStack.length) b)
+          (_ : ∀ (s : List Data) (hs : s.length = idxs'.length + copiedStack.length),
+            (meteredEvalProg b s (hs ▸ h_wf')).Dom),
+          (goCall b idxs' stack copiedStack h_idxs' h_wf').Dom by
+        have h_full := h idxs [] h_wf.1.1 (by simpa using h_wf.1.2)
+          (by intro s hs; simpa using hb s (by simpa using hs))
+        simpa using h_full
+      intro idxs' copiedStack h_idxs' h_wf' h_bdom
+      induction idxs' generalizing copiedStack with
+      | nil =>
+        simpa [goCall] using h_bdom copiedStack (by simp)
+      | cons i is ih =>
+        simp only [goCall]
+        apply ih
+        intro s hs
+        exact h_bdom s (by simp [hs]; omega)
 
 @[simp]
 theorem Op_total_of_WhileFree {n : ℕ} {op : Operation}
     (h_wf : WFOp n op) (h_whileFree : Operation.WhileFree op) :
     Operation.Total op h_wf := by
-  sorry
+  intro stack h_len
+  have h_wf_prog : WFProg n [op] := ⟨h_wf, by simp [WFProg]⟩
+  have h_whf_prog : Prog.WhileFree [op] := ⟨h_whileFree, by simp⟩
+  have h := Prog_total_of_WhileFree [op] h_wf_prog h_whf_prog stack h_len
+  simp only [meteredEvalProg] at h
+  exact (Part.bind_dom.mp h).1
 
 @[simp]
 theorem Dom_meteredEvalOp_of_WhileFree {op : Operation} {stack : List Data}
@@ -309,7 +375,7 @@ def Operation.meteredEvalT (op : Operation) (stack : List Data) (h_wf : WFOp sta
 def Prog.meteredEvalT (body : Prog) (stack : List Data)
     (h_wf : WFProg stack.length body)
     (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
-  (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree h_wf h_whf stack rfl)
+  (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree body h_wf h_whf stack rfl)
 
 @[simp, scoped grind =]
 lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
@@ -531,12 +597,15 @@ instance {i : ℕ} {then_ else_ : List Operation}
     if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1 else he.space s h_wf.2.2
   proof := by
     intros s h_wf h_whf
-    simp [Operation.meteredEvalT, meteredEvalOp]
-    by_cases h : (s[i]'h_wf.1 = Data.empty)
-    · simp [h]
-      sorry
-    · simp [h]
-      sorry
+    simp only [Operation.meteredEvalT, meteredEvalOp]
+    split_ifs
+    · have := ht.proof s h_wf.2.1 h_whf.1
+      simp [Prog.meteredEvalT] at this
+      simp [this]
+    · have := he.proof s h_wf.2.2 h_whf.2
+      simp [Prog.meteredEvalT] at this
+      simp [this]
+
 
 instance {body : Prog} {idxs : List TapeIndex}
     [hb : Prog.HasComputes body] :

From 1d062e4d498589eb80b8ea3745fd017bd35c86af Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Wed, 20 May 2026 20:19:21 +0200
Subject: [PATCH 055/106] cleanup

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 23 ++++++++++++-------
 1 file changed, 15 insertions(+), 8 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index f63705d961..afd60ce864 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -85,7 +85,7 @@ abbrev Data.asList
 lemma Data.asList_empty : Data.empty.asList = [] := by simp [Data.empty]
 
 @[simp, grind =]
-lemma Data.asList_l : Data.l xs.asList = xs := by grind
+lemma Data.asList_l (xs : Data) : Data.l xs.asList = xs := by grind
 
 
 --- Encoding length of d.
@@ -817,6 +817,10 @@ instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β)
   encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
   h_inj := by sorry
 
+lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
+  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
+  simp [DataEncode.encode]
+
 instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
@@ -915,7 +919,7 @@ abbrev stackTape_cons : Prog := [
 
 abbrev snd : Prog := [ .tail 0, .head 0 ]
 
-@[simp]
+
 lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
     {stack : List Data} {x : α} {y : β} :
     (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
@@ -960,7 +964,6 @@ lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Sym
 
 abbrev to_pair : Prog := [ .empty, .cons 2 0, .cons 2 0 ]
 
-@[simp]
 lemma to_pair.semantics {α β : Type} [DataEncode α] [DataEncode β]
     {stack : List Data} {x : α} {y : β} :
     (to_pair.meteredEvalT (DataEncode.encode x :: DataEncode.encode y :: stack)
@@ -979,7 +982,6 @@ abbrev tape_move_left : Prog := [
 ]
 
 
-@[simp]
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
       (by simp)).1 =
@@ -1004,11 +1006,17 @@ lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
       by rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
           simp [Turing.StackTape.tail, Turing.StackTape.nil]
     simp [DataEncode.encode, this]
+  have h_encodeTuple (st : Turing.StackTape Symbol) :
+      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
+      DataEncode.encode st.head := by
+    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
   rw [Prog.HasComputes.proof (p := tape_move_left)]
   unfold Turing.BiTape.move_left
-  simp --
-  simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
-  -- simp [DataEncode.encode]
+  -- simp --
+  -- simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
+  -- simp [DataEncode_pair]
+  -- rw [Data.asList_l]
+  -- simp
   sorry
 
 -- def move_right (t : BiTape Symbol) : BiTape Symbol :=
@@ -1026,7 +1034,6 @@ abbrev tape_move_right : Prog := [
 ]
 
 
-@[simp]
 lemma tape_move_right.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_right.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
       (by simp)).1 =

From f6b958dcaf2f643944ded7c325ce4e727273c62f Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 13:42:39 +0200
Subject: [PATCH 056/106] semantics of move left.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 268 +++++++-----------
 1 file changed, 99 insertions(+), 169 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index afd60ce864..34b1753e43 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -79,14 +79,18 @@ instance : LawfulBEq Data := inferInstance
 abbrev Data.empty := Data.l []
 
 
-abbrev Data.asList
+@[grind =]
+def Data.asList
   | Data.l xs => xs
 
-lemma Data.asList_empty : Data.empty.asList = [] := by simp [Data.empty]
+@[simp]
+lemma Data.asList_empty : Data.empty.asList = [] := by rfl
 
 @[simp, grind =]
-lemma Data.asList_l (xs : Data) : Data.l xs.asList = xs := by grind
+lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
 
+@[simp, grind =]
+lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
 
 --- Encoding length of d.
 def Data.size : Data → ℕ
@@ -377,36 +381,36 @@ def Prog.meteredEvalT (body : Prog) (stack : List Data)
     (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
   (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree body h_wf h_whf stack rfl)
 
-@[simp, scoped grind =]
-lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
-    {h_wf : WFOp stack.length (.fold body initial list)}
-    {h_whf : Operation.WhileFree (.fold body initial list)}
-    (h_body_total : body.Total h_wf.2.2) :
-    Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
-      ( -- data: fold over accumulator
-        (stack[list]'h_wf.1).asList.foldl
-          (fun acc x => (Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
-            (by simpa using h_whf)).1)
-          (stack[initial]'h_wf.2.1),
-        -- time: thread (acc, time), then add final acc size
-        (let (a', t) := (stack[list]'h_wf.1).asList.foldl
-            (fun (acc, t) x =>
-              let (r, t', _) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
-                (by simpa using h_whf)
-              (r, t + 1 + t'))
-            (stack[initial]'h_wf.2.1, 0);
-          t + a'.size),
-        -- space: thread (acc, max-space), then max with final acc size
-        (let (a', s) := (stack[list]'h_wf.1).asList.foldl
-            (fun (acc, s) x =>
-              let (r, _, s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
-                (by simpa using h_whf)
-              (r, max s s'))
-            (stack[initial]'h_wf.2.1, 0);
-          max s a'.size)
-      )
-      := by
-  sorry
+-- @[simp, scoped grind =]
+-- lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
+--     {h_wf : WFOp stack.length (.fold body initial list)}
+--     {h_whf : Operation.WhileFree (.fold body initial list)}
+--     (h_body_total : body.Total h_wf.2.2) :
+--     Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
+--       ( -- data: fold over accumulator
+--         (stack[list]'h_wf.1).asList.foldl
+--           (fun acc x => (Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+--             (by simpa using h_whf)).1)
+--           (stack[initial]'h_wf.2.1),
+--         -- time: thread (acc, time), then add final acc size
+--         (let (a', t) := (stack[list]'h_wf.1).asList.foldl
+--             (fun (acc, t) x =>
+--               let (r, t', _) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+--                 (by simpa using h_whf)
+--               (r, t + 1 + t'))
+--             (stack[initial]'h_wf.2.1, 0);
+--           t + a'.size),
+--         -- space: thread (acc, max-space), then max with final acc size
+--         (let (a', s) := (stack[list]'h_wf.1).asList.foldl
+--             (fun (acc, s) x =>
+--               let (r, _, s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
+--                 (by simpa using h_whf)
+--               (r, max s s'))
+--             (stack[initial]'h_wf.2.1, 0);
+--           max s a'.size)
+--       )
+--       := by
+--   sorry
 
 /-- Recursive form of the per-iteration accumulator threading used by `meteredEvalT_fold`.
     Mirrors `goMeteredFold` directly, but on the `meteredEvalT` side: every body run
@@ -421,55 +425,55 @@ def Operation.foldRec (body : Prog) (stack : List Data)
     let (r, t', s') := Operation.foldRec body stack h_wf h_whf rest acc'
     (r, 1 + t + t', max s s')
 
-/-- Recursive analog of `Operation.meteredEvalT_fold`: instead of three `List.foldl`s,
-    express the fold operation's result by structural recursion on the list. -/
-lemma Operation.meteredEvalT_fold_rec
-    {body : Prog} {initial list : TapeIndex} {stack : List Data}
-    {h_wf : WFOp stack.length (.fold body initial list)}
-    {h_whf : Operation.WhileFree (.fold body initial list)} :
-    Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
-      Operation.foldRec body stack h_wf.2.2 (by simpa using h_whf)
-        (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) := by
-  sorry
+-- /-- Recursive analog of `Operation.meteredEvalT_fold`: instead of three `List.foldl`s,
+--     express the fold operation's result by structural recursion on the list. -/
+-- lemma Operation.meteredEvalT_fold_rec
+--     {body : Prog} {initial list : TapeIndex} {stack : List Data}
+--     {h_wf : WFOp stack.length (.fold body initial list)}
+--     {h_whf : Operation.WhileFree (.fold body initial list)} :
+--     Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
+--       Operation.foldRec body stack h_wf.2.2 (by simpa using h_whf)
+--         (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) := by
+--   sorry
 
 
-/-- Space bound for a fold operation. If the initial accumulator fits within `B`,
-    and for every accumulator with `acc.size ≤ B` the body uses space `≤ B` and
-    produces a new accumulator with size `≤ B`, then the entire fold uses space
-    `≤ B`. -/
-lemma fold_bounded_space {body : Prog} {initial list : TapeIndex} {stack : List Data}
-    {h_wf : WFOp stack.length (.fold body initial list)}
-    {h_whf : Operation.WhileFree (.fold body initial list)}
-    (B : ℕ)
-    (h_init : (stack[initial]'h_wf.2.1).size ≤ B)
-    (h_step : ∀ acc x, acc.size ≤ B → x ∈ (stack[list]'h_wf.1).asList →
-      let (acc', _, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
-      s ≤ B ∧ acc'.size ≤ B) :
-    (Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf).2.2 ≤ B := by
-  sorry
+-- /-- Space bound for a fold operation. If the initial accumulator fits within `B`,
+--     and for every accumulator with `acc.size ≤ B` the body uses space `≤ B` and
+--     produces a new accumulator with size `≤ B`, then the entire fold uses space
+--     `≤ B`. -/
+-- lemma fold_bounded_space {body : Prog} {initial list : TapeIndex} {stack : List Data}
+--     {h_wf : WFOp stack.length (.fold body initial list)}
+--     {h_whf : Operation.WhileFree (.fold body initial list)}
+--     (B : ℕ)
+--     (h_init : (stack[initial]'h_wf.2.1).size ≤ B)
+--     (h_step : ∀ acc x, acc.size ≤ B → x ∈ (stack[list]'h_wf.1).asList →
+--       let (acc', _, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
+--       s ≤ B ∧ acc'.size ≤ B) :
+--     (Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf).2.2 ≤ B := by
+--   sorry
 
-/-- Induction principle for `Operation.meteredEvalT` on a `.fold` operation.
-    To prove `motive` of the final `(acc, time, space)` triple, the caller supplies:
-    * `h_init`: the motive holds on `(initial, 0, 0)`;
-    * `h_step`: for every iteration item `x ∈ list`, the motive is preserved by one
-      body invocation — old triple `(acc, t, s)` is taken to
-      `(r.1, t + 1 + r.2.1, max s r.2.2)` where `r` is the body's result;
-    * `h_finish`: from the motive on the post-loop triple `(acc, t, s)`, derive
-      the motive on the final adjusted triple `(acc, t + acc.size, max s acc.size)`,
-      which accounts for the `[]` base case of `goMeteredFold`. -/
-lemma Operation.meteredEvalT_fold_induction
-    {body : Prog} {initial list : TapeIndex} {stack : List Data}
-    {h_wf : WFOp stack.length (.fold body initial list)}
-    {h_whf : Operation.WhileFree (.fold body initial list)}
-    (motive : Data → ℕ → ℕ → Prop)
-    (h_init : motive (stack[initial]'h_wf.2.1) 0 0)
-    (h_step : ∀ acc t s x, x ∈ (stack[list]'h_wf.1).asList → motive acc t s →
-      let (r, t', s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
-      motive r (t + 1 + t') (max s s'))
-    (h_finish : ∀ acc t s, motive acc t s → motive acc (t + acc.size) (max s acc.size)) :
-    let (r, t, s) := Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf
-    motive r t s := by
-  sorry
+-- /-- Induction principle for `Operation.meteredEvalT` on a `.fold` operation.
+--     To prove `motive` of the final `(acc, time, space)` triple, the caller supplies:
+--     * `h_init`: the motive holds on `(initial, 0, 0)`;
+--     * `h_step`: for every iteration item `x ∈ list`, the motive is preserved by one
+--       body invocation — old triple `(acc, t, s)` is taken to
+--       `(r.1, t + 1 + r.2.1, max s r.2.2)` where `r` is the body's result;
+--     * `h_finish`: from the motive on the post-loop triple `(acc, t, s)`, derive
+--       the motive on the final adjusted triple `(acc, t + acc.size, max s acc.size)`,
+--       which accounts for the `[]` base case of `goMeteredFold`. -/
+-- lemma Operation.meteredEvalT_fold_induction
+--     {body : Prog} {initial list : TapeIndex} {stack : List Data}
+--     {h_wf : WFOp stack.length (.fold body initial list)}
+--     {h_whf : Operation.WhileFree (.fold body initial list)}
+--     (motive : Data → ℕ → ℕ → Prop)
+--     (h_init : motive (stack[initial]'h_wf.2.1) 0 0)
+--     (h_step : ∀ acc t s x, x ∈ (stack[list]'h_wf.1).asList → motive acc t s →
+--       let (r, t', s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
+--       motive r (t + 1 + t') (max s s'))
+--     (h_finish : ∀ acc t s, motive acc t s → motive acc (t + acc.size) (max s acc.size)) :
+--     let (r, t, s) := Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf
+--     motive r t s := by
+--   sorry
 
 @[simp, scoped grind =]
 lemma Prog.meteredEvalT_cons
@@ -825,64 +829,7 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
---------------------------------------------------------------------
--- Example program
----------------------------------------------------------------------------
-
-def prog_reverse : Prog := [
-    .empty,
-    .fold [ .cons 0 1 ] 0 1
-  ]
-
-lemma prog_reverse.semantics (x : Data) (xs : List Data) :
-    (prog_reverse.meteredEvalT
-      (x :: xs)
-      (by simp [prog_reverse, WFProg, WFOp])
-      (by simp [prog_reverse])).1 =
-      Data.l (x.asList).reverse := by
-  have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
-      Data.l (xs.reverse ++ init.asList) := by
-    induction xs generalizing init with
-    | nil => simp
-    | cons x xs ih => simp [List.foldl, ih]
-  simp [prog_reverse, h]
-
-lemma prog_reverse.time (x : Data) (xs : List Data) :
-    (prog_reverse.meteredEvalT
-      (x :: xs)
-      (by simp [prog_reverse, WFProg, WFOp])
-      (by simp [prog_reverse])).2 =
-      sorry := by
-  simp [prog_reverse]
-  sorry
-
-lemma prog_reverse.space (list : Data) (xs : List Data) :
-    (prog_reverse.meteredEvalT
-      (list :: xs)
-      (by simp [prog_reverse, WFProg, WFOp])
-      (by simp [prog_reverse])).2.2 ≤ 8 * list.size + 8 := by
-  sorry
-  -- have h (stack list : List Data) (acc : Data) :
-  --     (Operation.foldRec [.cons 0 1] stack sorry sorry list acc).2.2 ≤
-  --     8 * (Data.l list).size := by
-  --   induction list with
-  --   | nil => simp [Operation.foldRec]
-  --   | cons x xs ih => sorry
-  -- simp only [prog_reverse, Prog.meteredEvalT_cons, Operation.meteredEvalT_empty,
-  --   Prog.meteredEvalT_nil, List.head_cons, add_zero, Prod.mk.eta, ge_iff_le]
-  -- rw [Operation.meteredEvalT_fold_rec]
-  -- simp
-  -- specialize h (Data.empty :: list :: xs) list.asList Data.empty
-  -- simp at h
-  -- grind
-
--- TODO the successor function is not too easy, because
--- we also need to concatenate at the end.
--- so maybe it is easier to have some kind of fold-map-routine (i.e. a map that also has shared
--- state in an accumulator)?
--- where the "cons" is handeled by the fold-map routine?
-
---------------------------------------------------------------------
+--------------------------------
 ---------------- Universal Turing Machine (simulation of a SingleTapeTM)
 ---------------------------------------------------------------------------
 
@@ -896,6 +843,11 @@ public instance : DataEncode (Turing.BiTape Symbol) where
   encode t := DataEncode.encode (t.head, t.left, t.right)
   h_inj := by sorry
 
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_biTape (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+
 def tape_write : Prog := [
   .tail 1,
   .cons 1 0
@@ -928,7 +880,7 @@ lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
         2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
         4 + 2 * (DataEncode.encode y).size)
       := by
-  simp [snd]
+  simp [snd, DataEncode.encode]
   grind
 
 /-- Data-only semantics of `snd`, proved via the `HasComputes` automation: instance
@@ -940,7 +892,7 @@ lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
     (Prog.meteredEvalT snd (DataEncode.encode (x, y) :: stack)
       (by simp [WFProg, WFOp]) (by simp)).1 =
       DataEncode.encode y := by
-  simp
+  simp [DataEncode.encode]
 
 @[simp] lemma snd.spec_eq :
     (Prog.HasComputes.spec (p := snd)) =
@@ -981,43 +933,21 @@ abbrev tape_move_left : Prog := [
   .call to_pair [1, 0],
 ]
 
-
+omit [Inhabited Symbol] [Fintype Symbol] in
 lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
       (by simp)).1 =
       DataEncode.encode (Turing.BiTape.move_left t)
         := by
-  have encode_st (st : Turing.StackTape Symbol) :
-    DataEncode.encode st = DataEncode.encode st.toList := by
-    simp [DataEncode.encode]
-  have encode_bt (t : Turing.BiTape Symbol) :
-    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
-    simp [DataEncode.encode]
-  have encode_list_tail {α : Type} [DataEncode α] (xs : List α) :
-    (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
-    simp [DataEncode.encode]
-  have h_head (st : Turing.StackTape Symbol) :
-      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
-      DataEncode.encode st.head := by
-    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
-  have h_tail (st : Turing.StackTape Symbol) :
-      DataEncode.encode st.toList.tail = DataEncode.encode st.tail := by
-    have : st.tail.toList = st.toList.tail :=
-      by rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
-          simp [Turing.StackTape.tail, Turing.StackTape.nil]
-    simp [DataEncode.encode, this]
-  have h_encodeTuple (st : Turing.StackTape Symbol) :
-      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
-      DataEncode.encode st.head := by
-    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
   rw [Prog.HasComputes.proof (p := tape_move_left)]
   unfold Turing.BiTape.move_left
-  -- simp --
-  -- simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
-  -- simp [DataEncode_pair]
-  -- rw [Data.asList_l]
-  -- simp
-  sorry
+  simp [DataEncode_pair, encode_biTape]
+  refine ⟨?_, ?_⟩
+  · rcases t.left with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
+  · have : (t.left.tail).toList = (t.left.toList).tail :=
+      by rcases t.left with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
+        simp [Turing.StackTape.tail, Turing.StackTape.nil]
+    simp [DataEncode.encode, this]
 
 -- def move_right (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩

From f3c2894ea49e092c29d48175e0e0ff7ebecf3792 Mon Sep 17 00:00:00 2001
From: Ching-Tsun Chou <chingtsun.chou@gmail.com>
Date: Thu, 21 May 2026 07:04:29 -0700
Subject: [PATCH 057/106] refactor: use `Option State` rather than `Sum State
 Unit` in `LTS.totalize` construction (#584)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

The `LTS.totalize` construction adds a "sink state" and transitions to
the sink state in order to make the LTS total. Originally the sink state
is represented by the `()` in the RHS of a direct sum `State ⊕ Unit`.
This PR changes the state space of `LTS.totalize` to `Option State`
instead, where the sink state is represented by `none`. This equivalent
representation is easier to read and, more importantly, avoids the
confusing "sum of sums" types in NA/Concat.lean and NA.Loop.lean, where
another level of constructions also use the direct sum types.
---
 Cslib/Computability/Automata/NA/Concat.lean   | 12 +++----
 Cslib/Computability/Automata/NA/Loop.lean     |  8 ++---
 Cslib/Computability/Automata/NA/Total.lean    | 18 +++++------
 .../Languages/RegularLanguage.lean            |  6 ++--
 Cslib/Foundations/Semantics/LTS/Total.lean    | 32 ++++++++++---------
 5 files changed, 39 insertions(+), 37 deletions(-)

diff --git a/Cslib/Computability/Automata/NA/Concat.lean b/Cslib/Computability/Automata/NA/Concat.lean
index 7cc7c1c18f..298e607fd1 100644
--- a/Cslib/Computability/Automata/NA/Concat.lean
+++ b/Cslib/Computability/Automata/NA/Concat.lean
@@ -138,20 +138,20 @@ namespace FinAcc
 
 /-- `finConcat na1 na2` is the concatenation of the "totalized" versions of `na1` and `na2`. -/
 def finConcat (na1 : FinAcc State1 Symbol) (na2 : FinAcc State2 Symbol)
-  : NA ((State1 ⊕ Unit) ⊕ (State2 ⊕ Unit)) Symbol :=
-  concat ⟨na1.totalize, inl '' na1.accept⟩ na2.totalize
+  : NA (Option State1 ⊕ Option State2) Symbol :=
+  concat ⟨na1.totalize, some '' na1.accept⟩ na2.totalize
 
 variable {na1 : FinAcc State1 Symbol} {na2 : FinAcc State2 Symbol}
 
 /-- `finConcat na1 na2` is total. -/
 instance : (finConcat na1 na2).Total where
   total s x := match s with
-    | inl _ => ⟨inl (inr ()), by grind [finConcat, concat, NA.totalize, LTS.totalize]⟩
-    | inr _ => ⟨inr (inr ()), by grind [finConcat, concat, NA.totalize, LTS.totalize]⟩
+    | inl _ => ⟨inl none, by grind [finConcat, concat, NA.totalize, LTS.totalize]⟩
+    | inr _ => ⟨inr none, by grind [finConcat, concat, NA.totalize, LTS.totalize]⟩
 
 /-- `finConcat na1 na2` accepts the concatenation of the languages of `na1` and `na2`. -/
 theorem finConcat_language_eq [Inhabited Symbol] :
-    language (FinAcc.mk (finConcat na1 na2) (inr '' (inl '' na2.accept))) =
+    language (FinAcc.mk (finConcat na1 na2) (inr '' (some '' na2.accept))) =
     language na1 * language na2 := by
   ext xl
   constructor
@@ -166,7 +166,7 @@ theorem finConcat_language_eq [Inhabited Symbol] :
       #adaptation_note
       /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/
       have : ss xl.length = inr (ss2 (xl.length - n)) := by grind
-      have hl : (ss2 (xl.length - n)).isLeft := by grind
+      have hl : (ss2 (xl.length - n)).isSome := by grind
       obtain ⟨s2, t2, h_mtr2, _, _, _⟩ := totalize_run_mtr h_run2 hl
       refine ⟨s2, ?_, t2, ?_, ?_⟩ <;> grind [drop_append_of_le_length, take_append_of_le_length]
     · exact xl.take_append_drop n
diff --git a/Cslib/Computability/Automata/NA/Loop.lean b/Cslib/Computability/Automata/NA/Loop.lean
index 9aa7432c4c..a114cb384b 100644
--- a/Cslib/Computability/Automata/NA/Loop.lean
+++ b/Cslib/Computability/Automata/NA/Loop.lean
@@ -167,14 +167,14 @@ namespace FinAcc
 open scoped Computability
 
 /-- `finLoop na` is the loop construction applied to the "totalized" version of `na`. -/
-def finLoop (na : FinAcc State Symbol) : NA (Unit ⊕ (State ⊕ Unit)) Symbol :=
-  FinAcc.loop ⟨na.totalize, inl '' na.accept⟩
+def finLoop (na : FinAcc State Symbol) : NA (Unit ⊕ Option State) Symbol :=
+  FinAcc.loop ⟨na.totalize, some '' na.accept⟩
 
 /-- `finLoop na` is total, assuming that `na` has at least one start state. -/
 instance [h : Nonempty na.start] : na.finLoop.Total where
   total s x := match s with
-    | inl _ => ⟨inr (inr ()), by simpa [finLoop, loop, NA.totalize, LTS.totalize] using h⟩
-    | inr _ => ⟨inr (inr ()), by grind [finLoop, loop, NA.totalize, LTS.totalize]⟩
+    | inl _ => ⟨inr none, by simpa [finLoop, loop, NA.totalize, LTS.totalize] using h⟩
+    | inr _ => ⟨inr none, by grind [finLoop, loop, NA.totalize, LTS.totalize]⟩
 
 /-- `finLoop na` accepts the Kleene star of the language of `na`, assuming that
 the latter is nonempty. -/
diff --git a/Cslib/Computability/Automata/NA/Total.lean b/Cslib/Computability/Automata/NA/Total.lean
index 28e4df850d..9ba731b1c7 100644
--- a/Cslib/Computability/Automata/NA/Total.lean
+++ b/Cslib/Computability/Automata/NA/Total.lean
@@ -16,25 +16,25 @@ public import Cslib.Foundations.Semantics.LTS.Total
 
 namespace Cslib.Automata.NA
 
-open Sum ωSequence Acceptor
+open Option ωSequence Acceptor
 
 variable {Symbol State : Type*}
 
 /-- `NA.totalize` makes the original NA total by replacing its LTS with `LTS.totalize`
 and its starting states with their lifted non-sink versions. -/
-def totalize (na : NA State Symbol) : NA (State ⊕ Unit) Symbol where
+def totalize (na : NA State Symbol) : NA (Option State) Symbol where
   toLTS := na.toLTS.totalize
-  start := inl '' na.start
+  start := some '' na.start
 
 variable {na : NA State Symbol}
 
 /-- In an infinite execution of `NA.totalize`, as long as the NA stays in a non-sink state,
 the execution so far corresponds to a finite execution of the original NA. -/
-theorem totalize_run_mtr {xs : ωSequence Symbol} {ss : ωSequence (State ⊕ Unit)} {n : ℕ}
-    (h : na.totalize.Run xs ss) (hl : (ss n).isLeft) :
-    ∃ s t, na.MTr s (xs.take n) t ∧ s ∈ na.start ∧ ss 0 = inl s ∧ ss n = inl t := by
+theorem totalize_run_mtr {xs : ωSequence Symbol} {ss : ωSequence (Option State)} {n : ℕ}
+    (h : na.totalize.Run xs ss) (hl : (ss n).isSome) :
+    ∃ s t, na.MTr s (xs.take n) t ∧ s ∈ na.start ∧ ss 0 = some s ∧ ss n = some t := by
   obtain ⟨s, _, eq₁⟩ := h.start
-  obtain ⟨t, eq₂⟩ := isLeft_iff.mp hl
+  obtain ⟨t, eq₂⟩ := isSome_iff_exists.mp hl
   use s, t
   refine ⟨?_, by grind⟩
   -- TODO: `grind` does not use congruence relations with `na.totalize.MTr`
@@ -45,7 +45,7 @@ theorem totalize_run_mtr {xs : ωSequence Symbol} {ss : ωSequence (State ⊕ Un
 `NA.totalize`, provided that the alphabet is inbabited. -/
 theorem totalize_mtr_run [Inhabited Symbol] {xl : List Symbol} {s t : State}
     (hs : s ∈ na.start) (hm : na.MTr s xl t) :
-    ∃ xs ss, na.totalize.Run (xl ++ω xs) ss ∧ ss 0 = inl s ∧ ss xl.length = inl t := by
+    ∃ xs ss, na.totalize.Run (xl ++ω xs) ss ∧ ss 0 = some s ∧ ss xl.length = some t := by
   grind [totalize, Run, LTS.Total.extend_omegaExecution <| LTS.totalize.nonsink_mtr_iff.mpr hm]
 
 namespace FinAcc
@@ -53,7 +53,7 @@ namespace FinAcc
 /-- `NA.totalize` and the original NA accept the same language of finite words,
 as long as the accepting states are also lifted in the obvious way. -/
 theorem totalize_language_eq {na : FinAcc State Symbol} :
-    language (FinAcc.mk na.totalize (inl '' na.accept)) = language na := by
+    language (FinAcc.mk na.totalize (some '' na.accept)) = language na := by
   ext xl
   simp +instances [totalize]
 
diff --git a/Cslib/Computability/Languages/RegularLanguage.lean b/Cslib/Computability/Languages/RegularLanguage.lean
index 562d555b31..6e1bbcc8e0 100644
--- a/Cslib/Computability/Languages/RegularLanguage.lean
+++ b/Cslib/Computability/Languages/RegularLanguage.lean
@@ -158,8 +158,8 @@ theorem IsRegular.mul [Inhabited Symbol] {l1 l2 : Language Symbol}
   rw [IsRegular.iff_nfa] at h1 h2 ⊢
   obtain ⟨State1, h_fin1, nfa1, rfl⟩ := h1
   obtain ⟨State2, h_fin1, nfa2, rfl⟩ := h2
-  use (State1 ⊕ Unit) ⊕ (State2 ⊕ Unit), inferInstance,
-    ⟨finConcat nfa1 nfa2, inr '' (inl '' nfa2.accept)⟩
+  use Option State1 ⊕ Option State2, inferInstance,
+    ⟨finConcat nfa1 nfa2, inr '' (some '' nfa2.accept)⟩
   exact finConcat_language_eq
 
 -- TODO: fix proof to work with backward.isDefEq.respectTransparency
@@ -173,7 +173,7 @@ theorem IsRegular.kstar [Inhabited Symbol] {l : Language Symbol}
   · simp [h_l]
   · rw [IsRegular.iff_nfa] at h ⊢
     obtain ⟨State, h_fin, nfa, rfl⟩ := h
-    use Unit ⊕ (State ⊕ Unit), inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l
+    use Unit ⊕ Option State, inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l
 
 /-- If a right congruence is of finite index, then each of its equivalence classes is regular. -/
 @[simp]
diff --git a/Cslib/Foundations/Semantics/LTS/Total.lean b/Cslib/Foundations/Semantics/LTS/Total.lean
index 5907d35b9f..37073920f3 100644
--- a/Cslib/Foundations/Semantics/LTS/Total.lean
+++ b/Cslib/Foundations/Semantics/LTS/Total.lean
@@ -20,7 +20,7 @@ and a "totalize" construction that converts any LTS into a total LTS.
 
 namespace Cslib.LTS
 
-open ωSequence Sum
+open ωSequence
 
 variable {State Label : Type*} {lts : LTS State Label}
 
@@ -62,22 +62,24 @@ theorem Total.extend_omegaExecution [Inhabited Label] [ht : lts.Total]
   grind [OmegaExecution.append hm ho h0]
 
 /-- `totalize` constructs a total LTS from any given LTS by adding a sink state. -/
-def totalize (lts : LTS State Label) : LTS (State ⊕ Unit) Label where
+def totalize (lts : LTS State Label) : LTS (Option State) Label where
   Tr s' μ t' := match s', t' with
-    | Sum.inl s, Sum.inl t => lts.Tr s μ t
-    | _, Sum.inr () => True
-    | Sum.inr (), Sum.inl _ => False
+    | some s, some t => lts.Tr s μ t
+    | _, none => True
+    | none, some _ => False
 
 /-- The LTS constructed by `totalize` is indeed total. -/
 instance (lts : LTS State Label) : lts.totalize.Total where
-  total _ _ := by simp [totalize]
+  total _ _ := by
+    use none
+    simp [totalize]
 
 /-- In `totalize`, there is no finite execution from the sink state to any non-sink state. -/
 theorem totalize.no_sink_to_nonsink {μs : List Label} {t : State} :
-    ¬ lts.totalize.MTr (Sum.inr ()) μs (Sum.inl t) := by
+    ¬ lts.totalize.MTr (none) μs (some t) := by
   intro h
-  generalize h_s : (Sum.inr () : State ⊕ Unit) = s'
-  generalize h_t : (Sum.inl t : State ⊕ Unit) = t'
+  generalize h_s : (none : Option State) = s'
+  generalize h_t : (some t : Option State) = t'
   rw [h_s, h_t] at h
   induction h <;> grind [totalize]
 
@@ -85,25 +87,25 @@ theorem totalize.no_sink_to_nonsink {μs : List Label} {t : State} :
 the transitions in the original LTS. -/
 @[simp]
 theorem totalize.nonsink_tr_iff {μ : Label} {s t : State} :
-    lts.totalize.Tr (Sum.inl s) μ (Sum.inl t) ↔ lts.Tr s μ t := by
+    lts.totalize.Tr (some s) μ (some t) ↔ lts.Tr s μ t := by
   simp [totalize]
 
 /-- In `totalize`, the multistep transitions between non-sink states correspond exactly to
 the multistep transitions in the original LTS. -/
 @[simp]
 theorem totalize.nonsink_mtr_iff {μs : List Label} {s t : State} :
-    lts.totalize.MTr (Sum.inl s) μs (Sum.inl t) ↔ lts.MTr s μs t := by
+    lts.totalize.MTr (some s) μs (some t) ↔ lts.MTr s μs t := by
   constructor <;> intro h
-  · generalize h_s : (Sum.inl s : State ⊕ Unit) = s'
-    generalize h_t : (Sum.inl t : State ⊕ Unit) = t'
+  · generalize h_s : (some s : Option State) = s'
+    generalize h_t : (some t : Option State) = t'
     rw [h_s, h_t] at h
     induction h generalizing s
     case refl _ => grind [MTr]
     case stepL t1' μ t2' μs t3' h_tr h_mtr h_ind =>
       obtain ⟨rfl⟩ := h_s
       cases t2'
-      case inl t2 => grind [MTr, totalize.nonsink_tr_iff.mp h_tr]
-      case inr t2 => grind [totalize.no_sink_to_nonsink]
+      case some t2 => grind [MTr, totalize.nonsink_tr_iff.mp h_tr]
+      case none => grind [totalize.no_sink_to_nonsink]
   · induction h
     case refl _ => grind [MTr]
     case stepL t1 μ t2 μs t3 h_tr h_mtr h_ind =>

From 71a08c447ddfb76583922339ffec7e53dc6f7a7f Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 16:15:00 +0200
Subject: [PATCH 058/106] recursion principle and some tools

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 184 +++++++++++++-----
 1 file changed, 131 insertions(+), 53 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index 34b1753e43..e2c68b0af9 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -105,6 +105,32 @@ lemma Data.cons_size {h : Data} {t : List Data} :
   simp [Data.size]
   grind
 
+/-- Recursion principle for `Data` that exposes the list-of-children structure:
+    a `motive` is built from the empty case and a cons case that combines the
+    motive on the head child and on the tail list (viewed as a `Data`).
+    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
+    through `List.rec`, leaving the recursive call on children to the user;
+    `Data.recL` performs both recursions and is the natural elimination principle
+    for definitions/proofs that need both IHs. -/
+@[elab_as_elim]
+def Data.recL {motive : Data → Sort*}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
+    ∀ d, motive d
+  | .l [] => nil
+  | .l (x :: xs) =>
+      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
+
+/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
+@[elab_as_elim]
+theorem Data.inductionL {motive : Data → Prop}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
+    (d : Data) : motive d :=
+  Data.recL nil cons d
+
 abbrev TapeIndex := ℕ
 
 
@@ -484,7 +510,12 @@ lemma Prog.meteredEvalT_cons
       let (r, opT, opS) := op.meteredEvalT stack h_wf.1 h_whf.1
       let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 h_whf.2
       (stack, opT + t, opS + s) := by
-  sorry
+  rw [Prog.meteredEvalT, Part.get_eq_iff_mem]
+  unfold meteredEvalProg
+  simp only [Part.bind_eq_bind, Part.mem_bind_iff]
+  refine ⟨_, Part.get_mem (Dom_meteredEvalOp_of_WhileFree h_wf.1 h_whf.1),
+    _, Part.get_mem (Prog_total_of_WhileFree rest h_wf.2 h_whf.2 _ (by simp)), ?_⟩
+  simp [Operation.meteredEvalT, Prog.meteredEvalT]
 
 -- ========================= Compositional specifications =========================
 
@@ -829,6 +860,68 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
+
+------------------------------------------------------
+----------- Tools
+-----------------------------------------------------------
+
+
+abbrev snd : Prog := [ .tail 0, .head 0 ]
+
+
+lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
+    {stack : List Data} {x : α} {y : β} :
+    (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
+      (by simp [WFProg, WFOp]) (by simp)) =
+      (DataEncode.encode y,
+        2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
+        4 + 2 * (DataEncode.encode y).size)
+      := by
+  simp [snd, DataEncode.encode]
+  grind
+
+/-- Data-only semantics of `snd`, proved via the `HasComputes` automation: instance
+    search assembles the spec function from per-operation specs for `.tail` and `.head`,
+    and `HasComputes.proof` discharges the equality. No simp chain through the
+    full `(Data × ℕ × ℕ)` triple, hence no `O(n²)` blowup. -/
+lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
+    {stack : List Data} {x : α} {y : β} :
+    (Prog.meteredEvalT snd (DataEncode.encode (x, y) :: stack)
+      (by simp [WFProg, WFOp]) (by simp)).1 =
+      DataEncode.encode y := by
+  simp [DataEncode.encode]
+
+@[simp] lemma snd.spec_eq :
+    (Prog.HasComputes.spec (p := snd)) =
+      (Prog.HasComputes.spec (p := [Operation.tail 0, Operation.head 0])) := rfl
+
+def constant (a : Data) : Prog := match a with
+  | Data.l a => match a with
+    | [] => [ .empty ]
+    | x :: xs => [
+      .call (constant (Data.l xs)) [],
+      .call (constant x) [],
+      .cons 0 1 ]
+
+lemma constant_wf (a : Data) (n : ℕ) : WFProg n (constant a) := by
+  induction a using Data.inductionL generalizing n with
+  | nil => simp [constant, WFProg, WFOp]
+  | cons x xs ihx ihxs =>
+    simp [constant, WFProg, WFOp, ihx, ihxs]
+
+lemma constant_whf (a : Data) : Prog.WhileFree (constant a) := by
+  induction a using Data.inductionL with
+  | nil => simp [constant]
+  | cons x xs ihx ihxs =>
+    simp [constant, Prog.WhileFree, ihx, ihxs]
+
+lemma constant.semantics (a : Data) {stack : List Data} :
+    ((constant a).meteredEvalT stack (constant_wf _ _) (constant_whf _)).1 = a := by
+  induction a using Data.inductionL with
+  | nil => simp [constant]
+  | cons x xs ihx ihxs =>
+    simp [constant, ihx, ihxs, meteredEvalOp, meteredEvalProg]
+    sorry
 --------------------------------
 ---------------- Universal Turing Machine (simulation of a SingleTapeTM)
 ---------------------------------------------------------------------------
@@ -853,6 +946,9 @@ def tape_write : Prog := [
   .cons 1 0
 ]
 
+def tape_write' : Operation' :=
+  .cons [.load 0] [.tail [.load 1]]
+
 omit [Inhabited Symbol] [Fintype Symbol] in
 @[simp]
 lemma tape_write.semantics (t : Turing.BiTape Symbol) (a : Option Symbol) {stack : List Data} :
@@ -869,35 +965,6 @@ abbrev stackTape_cons : Prog := [
 -- def move_left (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
-abbrev snd : Prog := [ .tail 0, .head 0 ]
-
-
-lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
-    {stack : List Data} {x : α} {y : β} :
-    (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
-      (by simp [WFProg, WFOp]) (by simp)) =
-      (DataEncode.encode y,
-        2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
-        4 + 2 * (DataEncode.encode y).size)
-      := by
-  simp [snd, DataEncode.encode]
-  grind
-
-/-- Data-only semantics of `snd`, proved via the `HasComputes` automation: instance
-    search assembles the spec function from per-operation specs for `.tail` and `.head`,
-    and `HasComputes.proof` discharges the equality. No simp chain through the
-    full `(Data × ℕ × ℕ)` triple, hence no `O(n²)` blowup. -/
-lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
-    {stack : List Data} {x : α} {y : β} :
-    (Prog.meteredEvalT snd (DataEncode.encode (x, y) :: stack)
-      (by simp [WFProg, WFOp]) (by simp)).1 =
-      DataEncode.encode y := by
-  simp [DataEncode.encode]
-
-@[simp] lemma snd.spec_eq :
-    (Prog.HasComputes.spec (p := snd)) =
-      (Prog.HasComputes.spec (p := [Operation.tail 0, Operation.head 0])) := rfl
-
 omit [Inhabited Symbol] [Fintype Symbol] in
 @[simp]
 lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Symbol)
@@ -964,38 +1031,49 @@ abbrev tape_move_right : Prog := [
 ]
 
 
+omit [Inhabited Symbol] [Fintype Symbol] in
 lemma tape_move_right.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
     (tape_move_right.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
       (by simp)).1 =
       DataEncode.encode (Turing.BiTape.move_right t)
         := by
-  have encode_st (st : Turing.StackTape Symbol) :
-    DataEncode.encode st = DataEncode.encode st.toList := by
-    simp [DataEncode.encode]
-  have encode_bt (t : Turing.BiTape Symbol) :
-    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
-    simp [DataEncode.encode]
-  have encode_list_tail {α : Type} [DataEncode α] (xs : List α) :
-    (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
-    simp [DataEncode.encode]
-  have h_head (st : Turing.StackTape Symbol) :
-      (Option.map DataEncode.encode st.toList.head?).getD Data.empty =
-      DataEncode.encode st.head := by
-    rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
-  have h_tail (st : Turing.StackTape Symbol) :
-      DataEncode.encode st.toList.tail = DataEncode.encode st.tail := by
-    have : st.tail.toList = st.toList.tail :=
-      by rcases st with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
-          simp [Turing.StackTape.tail, Turing.StackTape.nil]
-    simp [DataEncode.encode, this]
   rw [Prog.HasComputes.proof (p := tape_move_right)]
   unfold Turing.BiTape.move_right
-  -- simp --
-  -- simp [encode_bt, encode_list_tail, -List.map_tail, h_head, h_tail]
-  -- simp [DataEncode.encode]
-  sorry
+  simp [DataEncode_pair, encode_biTape]
+  refine ⟨?_, ?_⟩
+  · rcases t.right with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
+  · have : (t.right.tail).toList = (t.right.toList).tail :=
+      by rcases t.right with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
+        simp [Turing.StackTape.tail, Turing.StackTape.nil]
+    simp [DataEncode.encode, this]
 
+-- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
+--   | t, none => t
+--   | t, some d => t.move d
 
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => Data.l [Data.empty]
+    | Dir.right => Data.l [Data.l []]
+  h_inj := by sorry
+
+abbrev tapeOptionMove : Prog := [
+  .ifEmpty 1
+    [ .call [] [0] ] -- none case: return t
+    [ .tail 1,
+      .call (constant (DataEncode.encode Dir.left)) [],
+      .eq 0 1, -- direction == left?
+      .ifEmpty 0
+       [ .call [] [0] ] -- right
+       [ .call (constant (DataEncode.encode Dir.left)) [], .eq 1 2, -- direction == left?
+         .ite 3 tape_move_left tape_move_right
+       ]
+
+    -- some case: move t according to direction
+      .call [ .call snd [2], .head 0 ] [3], -- direction
+      .ite 3 tape_move_left tape_move_right
+    ]
+]
 
 
 -- def put : Data → Prog

From 77f3a15fd0532e6a88e5502849dda5cc9d93245d Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 19:51:55 +0200
Subject: [PATCH 059/106] v2

---
 .../RoseTreeMachine/RoseTreeMachine.lean      |  27 +++
 .../Machines/RoseTreeMachine/V2.lean          | 202 ++++++++++++++++++
 2 files changed, 229 insertions(+)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
index e2c68b0af9..247d7b448d 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
@@ -13,6 +13,8 @@ public import Std
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Mathlib.Data.Nat.Bits
 
+set_option profiler true
+set_option profiler.threshold 100
 /-!
 -- This is a proposal to define a machine model and related time and space measure
 -- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
@@ -165,6 +167,31 @@ inductive Operation where
   | call : (List Operation) → (List TapeIndex) → Operation
 deriving Repr
 
+-- TODO maybe it is easier to "return" tapes by default, and make "store a tape" an explicit operation
+inductive Operation' where
+  -- read from the stack.
+  | load   : TapeIndex → Operation'
+  -- create a new tape initialized with `Data.l []`
+  | empty  : Operation'
+  -- cons tape h and tape t to a new tape (h :: t)
+  | cons   : (List Operation') → (List Operation') → Operation'
+  -- head of the data if it exists, or empty otherwise
+  | head   : (List Operation') → Operation'
+  -- tail of the data
+  | tail   : (List Operation') → Operation'
+  -- compare two tapes, returning non-empty if equal, empty otherwise
+  | eq     : (List Operation') → (List Operation') → Operation'
+  -- branch on tape i: if non-empty then then_ else else_
+  | ifNonEmpty : (List Operation') → (List Operation') → (List Operation') → Operation'
+  -- fold over the children of tape l with initial accumulator tape i and body program b
+  | fold   : (List Operation') → (List Operation') → (List Operation') → Operation'
+  -- TODO document
+  | while_ : (List Operation') → (List Operation') → Operation'
+  --- store the result of a program at the top of the stack.
+  | store : (List Operation) → Operation'
+deriving Repr
+
+
 abbrev Prog := List Operation
 
 mutual
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
new file mode 100644
index 0000000000..6c2a6700ef
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -0,0 +1,202 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Mathlib.Data.Part
+public import Mathlib.Control.Fix
+public import Std
+
+public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+public import Mathlib.Data.Nat.Bits
+
+/-!
+-- This is a proposal to define a machine model and related time and space measure
+-- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
+
+-- The goal would be that the machine model is flexible enough to implement algorithms easily,
+-- but still close enough to Turing machines to allow defining logspace and even loglogspace.
+
+-- The machine as defined below will allow stateless / pure functional programs.
+-- If we store the input tape position as a number, we should be able to define logspace.
+-- In order to go down to loglogspace, we need to use the input tape head as a "pointer"
+-- and cannot count its position. This could be doable as well, but requires a more stateful
+-- model at least for the input tape. The input tape is currently not modeled, but I have some
+-- plans to define actions on the input tape as further elementary operations.
+
+-- The main insight over my current work is that it does not hurt to
+-- (1) create a new tape for every elementary operation (the program size is constant, so the number
+--     of tapes is constant)
+-- (2) disallow modifications to existing tapes (work tape space has been spent, it is fine
+--     to copy it finitely often
+-- (3) if we have a built-in `fold` operation, we should be able to implement the required
+--     operations at linear space overhead, because the fold operation implicitly re-uses the
+--     space used by the accumulator.
+-/
+
+@[expose] public section
+
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-- ================= Data structure
+
+
+
+-- Rose-tree data structure, it allows us to
+-- 1. map most of Lean's data structures in a "natural" manner
+-- 2. define a "fold" operation
+inductive Data where
+  | l : List Data → Data
+deriving Repr
+
+mutual
+  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
+    | .l xs, .l ys =>
+      match Data.listDecEq xs ys with
+      | isTrue h => isTrue (congrArg Data.l h)
+      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
+  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
+    | [], [] => isTrue rfl
+    | [], _ :: _ => isFalse (by simp)
+    | _ :: _, [] => isFalse (by simp)
+    | x :: xs, y :: ys =>
+      match Data.decEq x y, Data.listDecEq xs ys with
+      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
+      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
+      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
+end
+
+instance : DecidableEq Data := Data.decEq
+instance : BEq Data := inferInstance
+instance : LawfulBEq Data := inferInstance
+
+abbrev Data.empty := Data.l []
+
+
+@[grind =]
+def Data.asList
+  | Data.l xs => xs
+
+@[simp]
+lemma Data.asList_empty : Data.empty.asList = [] := by rfl
+
+@[simp, grind =]
+lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
+
+@[simp, grind =]
+lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
+
+--- Encoding length of d.
+def Data.size : Data → ℕ
+  | Data.l xs => 2 + (xs.map Data.size |>.sum)
+
+@[simp, grind =]
+lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
+
+@[simp, grind =]
+lemma Data.cons_size {h : Data} {t : List Data} :
+    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
+  simp [Data.size]
+  grind
+
+/-- Recursion principle for `Data` that exposes the list-of-children structure:
+    a `motive` is built from the empty case and a cons case that combines the
+    motive on the head child and on the tail list (viewed as a `Data`).
+    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
+    through `List.rec`, leaving the recursive call on children to the user;
+    `Data.recL` performs both recursions and is the natural elimination principle
+    for definitions/proofs that need both IHs. -/
+@[elab_as_elim]
+def Data.recL {motive : Data → Sort*}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
+    ∀ d, motive d
+  | .l [] => nil
+  | .l (x :: xs) =>
+      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
+
+/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
+@[elab_as_elim]
+theorem Data.inductionL {motive : Data → Prop}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
+    (d : Data) : motive d :=
+  Data.recL nil cons d
+
+abbrev TapeIndex := ℕ
+
+
+-- ================= Operations and programs
+
+-- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
+-- Each operation creates a new stack entry (a new tape) and can read from previous
+-- entries by index. Stack entries created in "inner" programs are temporary and deleted
+-- once the inner program terminates. This is especially relevant for space complexity of
+-- loops since it allows us to re-use the space of one iteration for the next iteration.
+
+abbrev Var := ℕ
+
+-- TODO the `Var → Prog` parts are probably not a good idea like this, because when translating
+-- to a TM, they can depend "too much" on the variable - all they should be able to do is pass
+-- the var on to `.var`. So maybe we need some kind of monadic structure.
+
+inductive Prog where
+  | var (id : Var)
+  | letin (val : Prog) (rest : Var → Prog)
+  | empty
+  | cons (h t : Prog)
+  | elim (v : Prog) (empty : Prog) (cons : Var → Var → Prog)
+  -- TODO not sure if we need eq, could do recursively via fold, but would need
+  -- arbitrary descent.
+  | eq (a b : Prog)
+  | fold (body : Var → Var → Prog) (init list : Prog)
+  | while_ (body : Prog)
+
+/-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
+def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
+  match p with
+  | .var id => .some (env[id]?.getD (Data.l []), 1, 1) -- TODO do we need to charge for copying?
+  | .letin val rest => do
+    let (v, t, s) ← val.meteredEval env
+    let id := env.length
+    let (r, t', s') ← (rest id).meteredEval (env ++ [v])
+    return (r, 1 + t + t', max s s')
+  | .empty => .some (Data.empty, 1, 1)
+  | .cons h t => do
+    let (head, h_t, h_s) ← h.meteredEval env
+    let (tail, t_t, t_s) ← t.meteredEval env
+    return (Data.l (head :: tail.asList), 1 + h_t + t_t, max h_s t_s)
+  | .elim v em cons_ => do
+    let (v', t, s) ← v.meteredEval env
+    match v' with
+    | Data.l [] =>
+      let (r, t', s') ← em.meteredEval env
+      return (r, 1 + t + t', max s s')
+    | Data.l (head :: tail) =>
+      let id := env.length
+      -- TODO charge for copying head and tail?
+      let (r, t', s') ← (cons_ id (id + 1)).meteredEval (env ++ [head, Data.l tail])
+      return (r, 1 + t + t', max s s')
+  | .eq a b => do
+    let (a, a_t, a_s) ← a.meteredEval env
+    let (b, b_t, b_s) ← b.meteredEval env
+    (if a == b then Data.l [ Data.l [] ] else Data.l [], 1 + a_t + b_t, 1 + max a_s b_s)
+  | .fold body init list => do
+    -- Time: 1 + Σ_iterations (1 + body_time).
+    -- Space: init.size + max_iterations(body_space).
+    let (init, init_t, init_s) ← init.meteredEval env
+    sorry
+  | .while_ body => sorry
+  termination_by env.length + sizeOf p
+
+end RoseTreeMachine
+
+end Turing

From 560d1e058ec0fbfefa86a324c0df61c3d0ed4634 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 20:13:32 +0200
Subject: [PATCH 060/106] builder

---
 .../Machines/RoseTreeMachine/V2.lean          | 99 ++++++++++++++-----
 1 file changed, 75 insertions(+), 24 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 6c2a6700ef..1fec529400 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -142,60 +142,111 @@ abbrev TapeIndex := ℕ
 -- once the inner program terminates. This is especially relevant for space complexity of
 -- loops since it allows us to re-use the space of one iteration for the next iteration.
 
-abbrev Var := ℕ
-
--- TODO the `Var → Prog` parts are probably not a good idea like this, because when translating
--- to a TM, they can depend "too much" on the variable - all they should be able to do is pass
--- the var on to `.var`. So maybe we need some kind of monadic structure.
+def Var := ℕ
+deriving Repr
 
+/-- Abstract syntax tree. Binders (`letin`, `elim`'s cons branch, `fold`'s body, `while_`'s body)
+are *implicit*: each binder extends `env` with one or more fresh values, and the bound
+variable(s) are referred to as `var k` where `k = env.length` at the binding site.
+For ergonomic construction with named binders use `PB` below. -/
 inductive Prog where
   | var (id : Var)
-  | letin (val : Prog) (rest : Var → Prog)
+  /-- `letin val rest`: evaluate `val`, append the result to `env`, then evaluate `rest`. -/
+  | letin (val : Prog) (rest : Prog)
   | empty
   | cons (h t : Prog)
-  | elim (v : Prog) (empty : Prog) (cons : Var → Var → Prog)
-  -- TODO not sure if we need eq, could do recursively via fold, but would need
-  -- arbitrary descent.
+  /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
+      `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
+  | elim (v : Prog) (em : Prog) (cs : Prog)
   | eq (a b : Prog)
-  | fold (body : Var → Var → Prog) (init list : Prog)
+  /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
+      list; `body` runs once per element with `env` extended by `[acc, x]`. -/
+  | fold (body : Prog) (init list : Prog)
+  /-- `while_ body`: body runs with `env` extended by the current accumulator. -/
   | while_ (body : Prog)
+deriving Repr
+
 
 /-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
 def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
   match p with
-  | .var id => .some (env[id]?.getD (Data.l []), 1, 1) -- TODO do we need to charge for copying?
+  | .var id => .some (env[(show ℕ from id)]?.getD (Data.l []), 1, 1)
   | .letin val rest => do
     let (v, t, s) ← val.meteredEval env
-    let id := env.length
-    let (r, t', s') ← (rest id).meteredEval (env ++ [v])
+    let (r, t', s') ← rest.meteredEval (env ++ [v])
     return (r, 1 + t + t', max s s')
   | .empty => .some (Data.empty, 1, 1)
   | .cons h t => do
     let (head, h_t, h_s) ← h.meteredEval env
     let (tail, t_t, t_s) ← t.meteredEval env
     return (Data.l (head :: tail.asList), 1 + h_t + t_t, max h_s t_s)
-  | .elim v em cons_ => do
+  | .elim v em cs => do
     let (v', t, s) ← v.meteredEval env
     match v' with
     | Data.l [] =>
       let (r, t', s') ← em.meteredEval env
       return (r, 1 + t + t', max s s')
     | Data.l (head :: tail) =>
-      let id := env.length
-      -- TODO charge for copying head and tail?
-      let (r, t', s') ← (cons_ id (id + 1)).meteredEval (env ++ [head, Data.l tail])
+      let (r, t', s') ← cs.meteredEval (env ++ [head, Data.l tail])
       return (r, 1 + t + t', max s s')
   | .eq a b => do
     let (a, a_t, a_s) ← a.meteredEval env
     let (b, b_t, b_s) ← b.meteredEval env
     (if a == b then Data.l [ Data.l [] ] else Data.l [], 1 + a_t + b_t, 1 + max a_s b_s)
-  | .fold body init list => do
-    -- Time: 1 + Σ_iterations (1 + body_time).
-    -- Space: init.size + max_iterations(body_space).
-    let (init, init_t, init_s) ← init.meteredEval env
-    sorry
-  | .while_ body => sorry
-  termination_by env.length + sizeOf p
+  | .fold _body _init _list => sorry
+  | .while_ _body => sorry
+  termination_by sizeOf p
+
+/-! ## Surface syntax with named binders
+
+The AST above is binder-implicit; to construct programs by hand we lift to
+`PB := Var → Prog`, a function from the current binder depth to a `Prog`. The
+smart constructors below thread the depth automatically so the user can write
+`letIn val (fun x => …)` with a real Lean binder for `x`.
+
+To turn a `PB` term into a concrete `Prog`, apply it at depth `0` via `PB.build`. -/
+
+/-- A program builder: given the current binder depth (i.e. the size of `env`
+at the point of insertion), produce a `Prog`. -/
+abbrev PB := ℕ → Prog
+
+namespace PB
+
+abbrev empty : PB := fun _ => .empty
+abbrev cons (h t : PB) : PB := fun n => .cons (h n) (t n)
+abbrev eq (a b : PB) : PB := fun n => .eq (a n) (b n)
+
+/-- `letIn val (fun x => body)`: bind the value of `val` as a fresh variable `x`
+visible in `body`. -/
+abbrev letIn (val : PB) (body : PB → PB) : PB := fun n =>
+  .letin (val n) (body (fun _ => .var n) (n + 1))
+
+/-- `elim v em (fun head tail => body)`: case-analyse the result of `v`. -/
+abbrev elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
+  .elim (v n) (em n) (cs (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2))
+
+/-- `fold (fun acc x => body) init list`: run `body` for each element `x`
+threading accumulator `acc`. -/
+abbrev fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
+  .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
+
+/-- `while_ (fun acc => body)`. -/
+abbrev while_ (body : PB → PB) : PB := fun n =>
+  .while_ (body (fun _ => .var n) (n + 1))
+
+/-- Close a builder into a concrete `Prog`. -/
+abbrev build (p : PB) : Prog := p 0
+
+end PB
+
+
+/-- Example: `tail x` returns the tail of the list bound at variable `x`, or `empty`
+    if `x` denotes the empty list. Built with `elim`: the empty branch yields `empty`,
+    the cons branch ignores the head and projects the bound tail. -/
+def Prog.tail (x : PB) : Prog := PB.build <|
+  PB.elim x PB.empty (fun _head tl => tl)
+
+#eval Prog.tail (fun _ => .var (0: ℕ))
 
 end RoseTreeMachine
 

From b2c9bbb039461df514bd72505e9f386bde80aa03 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 21:51:29 +0200
Subject: [PATCH 061/106] utm

---
 Cslib.lean                                    |   2 +
 .../Machines/RoseTreeMachine/V2.lean          | 304 ++++++++++++++++--
 2 files changed, 286 insertions(+), 20 deletions(-)

diff --git a/Cslib.lean b/Cslib.lean
index 368d22f45d..6423f95ac5 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -70,6 +70,8 @@ public import Cslib.Computability.Machines.MultiTapeTuring.UniversalTM
 public import Cslib.Computability.Machines.MultiTapeTuring.WhileCombinator
 public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes
 public import Cslib.Computability.Machines.RoseTreeMachine.RoseTreeMachine
+public import Cslib.Computability.Machines.RoseTreeMachine.V2
+public import Cslib.Computability.Machines.RoseTreeMachine.V3
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 1fec529400..bc447935d2 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -166,14 +166,15 @@ inductive Prog where
   | while_ (body : Prog)
 deriving Repr
 
-
 /-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
 def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
   match p with
+    -- TODO charge for copy?
   | .var id => .some (env[(show ℕ from id)]?.getD (Data.l []), 1, 1)
   | .letin val rest => do
     let (v, t, s) ← val.meteredEval env
     let (r, t', s') ← rest.meteredEval (env ++ [v])
+    -- TODO charge for copy?
     return (r, 1 + t + t', max s s')
   | .empty => .some (Data.empty, 1, 1)
   | .cons h t => do
@@ -193,18 +194,60 @@ def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
     let (a, a_t, a_s) ← a.meteredEval env
     let (b, b_t, b_s) ← b.meteredEval env
     (if a == b then Data.l [ Data.l [] ] else Data.l [], 1 + a_t + b_t, 1 + max a_s b_s)
-  | .fold _body _init _list => sorry
-  | .while_ _body => sorry
-  termination_by sizeOf p
+  | .fold body init list => do
+    let (i, i_t, i_s) ← init.meteredEval env
+    let (l, l_t, l_s) ← list.meteredEval env
+    l.asList.foldlM
+      (fun (acc, t, s) el => do
+        let (acc', b_t, b_s) ← body.meteredEval (env ++ [acc, el])
+        return (acc', 1 + t + b_t, max s b_s))
+      (i, 1 + i_t + l_t, max i_s l_s)
+  | .while_ body =>
+    -- `body` is evaluated repeatedly with `env` extended by the current accumulator.
+    -- The result of `body` is expected to be a cons whose head is the "continue?" flag
+    -- (truthy = nonempty) and whose tail is the next accumulator.
+    -- The initial accumulator is `Data.empty`.
+    let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
+            (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
+      fun rec d_ts =>
+        let (acc, t, s) := d_ts
+        (body.meteredEval (env ++ [acc])).bind fun (r, b_t, b_s) =>
+          let t' := t + 1 + b_t
+          let s' := max s b_s
+          if r.asList.headD (Data.l []) != Data.l [] then
+            rec (Data.l r.asList.tail, t', s')
+          else
+            .some (Data.l r.asList.tail, t', s')
+    Part.fix F (Data.empty, 1, 1)
+  termination_by (sizeOf p, 0)
+
+
+def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
+
+@[simp]
+def Prog.WhileFree (p : Prog) : Prop :=
+  match p with
+  | .var _ => True
+  | .letin val rest => Prog.WhileFree val ∧ Prog.WhileFree rest
+  | .empty => True
+  | .cons h t => Prog.WhileFree h ∧ Prog.WhileFree t
+  | .elim v em cs => Prog.WhileFree v ∧ Prog.WhileFree em ∧ Prog.WhileFree cs
+  | .eq a b => Prog.WhileFree a ∧ Prog.WhileFree b
+  | .fold body init list => Prog.WhileFree body ∧ Prog.WhileFree init ∧ Prog.WhileFree list
+  | .while_ _ => False
+
+theorem total_of_whileFree (p : Prog) (h_wf : p.WhileFree) : p.Total := by sorry
+
+/-- Evaluation of while-free programs. Do not expand this, because `Part` is cumbersome to
+deal with. -/
+def Prog.meteredEvalT (p : Prog) (h_wf : p.WhileFree) (env : List Data) : Data × ℕ × ℕ :=
+  (p.meteredEval env).get (total_of_whileFree p h_wf env)
 
 /-! ## Surface syntax with named binders
 
-The AST above is binder-implicit; to construct programs by hand we lift to
-`PB := Var → Prog`, a function from the current binder depth to a `Prog`. The
-smart constructors below thread the depth automatically so the user can write
-`letIn val (fun x => …)` with a real Lean binder for `x`.
+Define convenience builder functions to allow binding the variables to names.
 
-To turn a `PB` term into a concrete `Prog`, apply it at depth `0` via `PB.build`. -/
+ -/
 
 /-- A program builder: given the current binder depth (i.e. the size of `env`
 at the point of insertion), produce a `Prog`. -/
@@ -212,41 +255,262 @@ abbrev PB := ℕ → Prog
 
 namespace PB
 
-abbrev empty : PB := fun _ => .empty
-abbrev cons (h t : PB) : PB := fun n => .cons (h n) (t n)
-abbrev eq (a b : PB) : PB := fun n => .eq (a n) (b n)
+@[simp]
+def empty : PB := fun _ => .empty
+@[simp]
+def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
+@[simp]
+def eq (a b : PB) : PB := fun n => .eq (a n) (b n)
 
 /-- `letIn val (fun x => body)`: bind the value of `val` as a fresh variable `x`
 visible in `body`. -/
-abbrev letIn (val : PB) (body : PB → PB) : PB := fun n =>
+@[simp]
+def letIn (val : PB) (body : PB → PB) : PB := fun n =>
   .letin (val n) (body (fun _ => .var n) (n + 1))
 
 /-- `elim v em (fun head tail => body)`: case-analyse the result of `v`. -/
-abbrev elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
+@[simp]
+def elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
   .elim (v n) (em n) (cs (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2))
 
 /-- `fold (fun acc x => body) init list`: run `body` for each element `x`
 threading accumulator `acc`. -/
-abbrev fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
+@[simp]
+def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
   .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
 
 /-- `while_ (fun acc => body)`. -/
-abbrev while_ (body : PB → PB) : PB := fun n =>
+@[simp]
+def while_ (body : PB → PB) : PB := fun n =>
   .while_ (body (fun _ => .var n) (n + 1))
 
 /-- Close a builder into a concrete `Prog`. -/
-abbrev build (p : PB) : Prog := p 0
+@[simp]
+def build (p : PB) : Prog := p 0
 
 end PB
 
+-------------------------------------
+--- Encoding of generic types into Data
+--------------------------------------
+
+class DataEncode (α : Type) where
+  encode : α → Data
+  h_inj : encode.Injective
+
+instance : DataEncode Bool where
+  encode b := if b then Data.l [ Data.l [] ] else Data.l []
+  h_inj := by intros a b h_eq; grind
+
+instance (α : Type) [DataEncode α] : DataEncode (List α) where
+  encode xs := Data.l (xs.map DataEncode.encode)
+  h_inj := by sorry
+
+@[simp, grind =]
+lemma DataEncode_list_nil {α : Type} [DataEncode α] :
+  DataEncode.encode ([] : List α) = Data.l [] := by
+  simp [DataEncode.encode]
+
+@[simp, grind =]
+lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
+  DataEncode.encode xs = Data.empty ↔ xs = [] := by
+  simp [DataEncode.encode]
+
+@[simp, scoped grind =]
+lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+  simp [DataEncode.encode]
+
+instance (α : Type) [DataEncode α] : DataEncode (Option α) where
+  encode := fun
+    | none => Data.l []
+    | some x => Data.l [DataEncode.encode x]
+  h_inj := by sorry
+
+@[simp]
+lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
+  (DataEncode.encode x == Data.empty) = x.isNone := by
+  cases x <;> simp [DataEncode.encode, Data.empty]
+
+instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
+  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
+  h_inj := by sorry
+
+lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
+  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
+  simp [DataEncode.encode]
+
+instance : DataEncode ℕ where
+  encode x := DataEncode.encode (Nat.bits x)
+  h_inj := by sorry
+
+-------------------------------------------------------
+--- combinator semantics
+----------------------------------------------------
+
+@[simp]
+lemma meteredEvalT_var_val {env : List Data} {i : ℕ} :
+  ((Prog.var i).meteredEvalT (by simp) env).1 = env[i]?.getD (Data.l []) := by
+  simp [Prog.meteredEvalT, Prog.meteredEval]
+
+@[simp]
+lemma meteredEvalT_empty_val {env : List Data} :
+  ((Prog.empty).meteredEvalT (by simp) env).1 = Data.l [] := by
+  simp [Prog.meteredEvalT, Prog.meteredEval]
+
+lemma meteredEvalT_elim_val {env : List Data} {v em cs : Prog}
+    {h_wf : (Prog.elim v em cs).WhileFree} :
+  ((Prog.elim v em cs).meteredEvalT h_wf env).1 =
+    match ((v.meteredEvalT h_wf.1 env).1) with
+    | Data.l [] => ((em.meteredEvalT h_wf.2.1 env).1)
+    | Data.l (head :: tail) => ((cs.meteredEvalT h_wf.2.2 (env ++ [head, Data.l tail])).1) := by
+  sorry
+-------------------------------------------------------------------
+--- tools
+-------------------------------------------
+
+lemma list_getElem_length_add {α : Type} (xs ys : List α) (i : ℕ) (h_lt : i < ys.length) :
+  (xs ++ ys)[xs.length + i]'(by grind) = ys[i] := by
+  sorry
 
 /-- Example: `tail x` returns the tail of the list bound at variable `x`, or `empty`
     if `x` denotes the empty list. Built with `elim`: the empty branch yields `empty`,
     the cons branch ignores the head and projects the bound tail. -/
-def Prog.tail (x : PB) : Prog := PB.build <|
-  PB.elim x PB.empty (fun _head tl => tl)
+def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
+def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
+
+lemma tail_semantics (x : PB) {env : List Data} {h_wf : (x env.length).WhileFree} :
+  ((PB.tail x (env.length)).meteredEvalT (by simp [PB.tail, h_wf]) env).1 =
+  Data.l ((x env.length).meteredEvalT h_wf env).1.asList.tail := by
+  simp [PB.tail, meteredEvalT_elim_val]
+  grind
+
+/-- Program that evaluates to the constant `a`. -/
+def constant (a : Data) : PB := match a with
+  | Data.l [] => PB.empty
+  | Data.l (x :: xs) => PB.cons (constant x) (constant (Data.l xs))
+
+@[simp]
+lemma constant_whileFree (a : Data) (n : ℕ) : (constant a n).WhileFree := by
+  induction a using Data.inductionL with
+  | nil => simp [constant]
+  | cons x xs ihx ihxs => simp [constant, ihx, ihxs]
+
+lemma constant.semantics (a : Data) {n : ℕ} :
+    ((constant a n).meteredEvalT (by simp) []).1 = a := by
+  sorry
+
+def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
+  .elim (PB.eq a b)
+    else_
+    (fun _ _ => then_)
+
+------------------------------------------------------
+----------- Tools
+-----------------------------------------------------------
+
+
+def PB.fst (x : PB) : PB := head x
+
+-- Compute fun x => x.snd
+def PB.snd (x : PB) : PB := head (tail x)
+
+-- TODO for the semantics, the PBs could actually be typed...
+
+-------------------------------------------------------------------
+---------------- Universal Turing Machine (simulation of a SingleTapeTM)
+---------------------------------------------------------------------------
+
+variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
+
+public instance : DataEncode (Turing.StackTape Symbol) where
+  encode t := DataEncode.encode t.toList
+  h_inj := by sorry
+
+public instance : DataEncode (Turing.BiTape Symbol) where
+  encode t := DataEncode.encode (t.head, t.left, t.right)
+  h_inj := by sorry
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_biTape (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+
+def tape_write (t v : PB) : PB := PB.cons v t.tail
+
+-- /-- Prepend an `Option` to the `StackTape` -/
+-- @[scoped grind]
+-- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
+--   match x, xs with
+--   | none, ⟨[], _⟩ => ⟨[], by grind⟩
+--   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
+--   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
+
+def stackTape_cons (x st : PB) : PB :=
+  PB.elim x
+    (PB.elim st
+      PB.empty
+      (fun _ _ => PB.cons x st))
+    (fun _ _ => PB.cons x st)
+
+
+def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
+
+--- The head component of the bitape
+def bitape_head (t : PB) : PB := t.fst
+--- The left component of the bitape
+def bitape_left (t : PB) : PB := t.snd.fst
+--- The right component of the bitape
+def bitape_right (t : PB) : PB := t.snd.snd
+
+-- def move_left (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
+
+def bitape_move_left (t : PB) : PB :=
+  to_pair (bitape_left t).head
+    (to_pair
+      (bitape_left t).tail
+      (stackTape_cons (bitape_head t) (bitape_right t)))
+
+-- def move_right (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
+
+def bitape_move_right (t : PB) : PB :=
+  to_pair (bitape_right t).head
+    (to_pair
+      (stackTape_cons (bitape_head t) (bitape_left t))
+      (bitape_right t).tail)
+
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => DataEncode.encode true
+    | Dir.right => DataEncode.encode false
+  h_inj := by sorry
+
+-- /--
+-- Move the head to the left or right, shifting the tape underneath it.
+-- -/
+-- def move (t : BiTape Symbol) : Dir → BiTape Symbol
+--   | .left => t.move_left
+--   | .right => t.move_right
+
+def bitape_move (tape dir : PB) : PB :=
+  PB.ifEq dir (constant (DataEncode.encode Dir.left))
+    (bitape_move_left tape)
+    (bitape_move_right tape)
+
+-- /--
+-- Optionally perform a `move`, or do nothing if `none`.
+-- -/
+-- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
+--   | t, none => t
+--   | t, some d => t.move d
+
+def bitape_optionMove (t dir : PB) : PB :=
+  .elim dir
+    t
+    (fun d _ => bitape_move t d)
 
-#eval Prog.tail (fun _ => .var (0: ℕ))
 
 end RoseTreeMachine
 

From de840801830adba1856195d791d8618311aebe32 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 21 May 2026 23:13:02 +0200
Subject: [PATCH 062/106] implementation of utm.

---
 .../Machines/RoseTreeMachine/V2.lean          | 85 ++++++++++++++++++-
 1 file changed, 82 insertions(+), 3 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index bc447935d2..1a3fe4d22a 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -215,9 +215,9 @@ def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
           let t' := t + 1 + b_t
           let s' := max s b_s
           if r.asList.headD (Data.l []) != Data.l [] then
-            rec (Data.l r.asList.tail, t', s')
+            rec (r, t', s')
           else
-            .some (Data.l r.asList.tail, t', s')
+            .some (r, t', s')
     Part.fix F (Data.empty, 1, 1)
   termination_by (sizeOf p, 0)
 
@@ -400,6 +400,8 @@ lemma constant.semantics (a : Data) {n : ℕ} :
     ((constant a n).meteredEvalT (by simp) []).1 = a := by
   sorry
 
+def encConst {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a)
+
 def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
   .elim (PB.eq a b)
     else_
@@ -415,6 +417,9 @@ def PB.fst (x : PB) : PB := head x
 -- Compute fun x => x.snd
 def PB.snd (x : PB) : PB := head (tail x)
 
+-- Compute x => Option.some x
+def PB.some (x : PB) : PB := cons x empty
+
 -- TODO for the semantics, the PBs could actually be typed...
 
 -------------------------------------------------------------------
@@ -436,7 +441,7 @@ lemma encode_biTape (t : Turing.BiTape Symbol) :
     DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
     simp [DataEncode.encode]
 
-def tape_write (t v : PB) : PB := PB.cons v t.tail
+def bitape_write (t v : PB) : PB := PB.cons v t.tail
 
 -- /-- Prepend an `Option` to the `StackTape` -/
 -- @[scoped grind]
@@ -511,6 +516,80 @@ def bitape_optionMove (t dir : PB) : PB :=
     t
     (fun d _ => bitape_move t d)
 
+instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
+    DataEncode (Turing.SingleTapeTM.Cfg tm) where
+  encode cfg := DataEncode.encode (cfg.state, cfg.BiTape)
+  h_inj := by sorry
+
+-- Evaluate a function `f` at `arg` where the function is given as a graph.
+-- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise.
+def eval_fun_graph (graph : PB) (arg : PB) : PB :=
+  PB.fold
+    (fun acc x =>
+      PB.ifEq acc .empty
+        (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
+        acc)
+    PB.empty graph
+
+
+def cfg_state (cfg : PB) : PB := cfg.fst
+def cfg_bitape (cfg : PB) : PB := cfg.snd
+
+/-- Evaluate the transition function. Returns `((wr, dir), q')`.
+ -- The return value is not wrapped inside an `Option` because the transition
+ -- function is assumed to be total. -/
+def eval_tr (tr : PB) (q c : PB) : PB :=
+  (eval_fun_graph (eval_fun_graph tr q).head c).head
+
+-- /-- The step function corresponding to a `SingleTapeTM`. -/
+-- @[simp]
+-- def step : tm.Cfg → Option tm.Cfg
+--   | ⟨none, _⟩ =>
+--     -- If in the halting state, there is no next configuration
+--     none
+--   | ⟨some q', t⟩ =>
+--     -- If in state q', perform look up in the transition function
+--     match tm.tr q' t.head with
+--     -- and enter a new configuration with state q'' (or none for halting)
+--     -- and tape updated according to the Stmt
+--     | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩
+
+-- Compute the step function given a transition function (as its graph) and a configuration.
+-- Returns `Option Cfg`
+def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
+  PB.elim (cfg_state cfg)
+    PB.empty
+    (fun q' _ => PB.letIn (cfg_bitape cfg) (fun tape =>
+      PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
+        .some (to_pair
+          tr_val.snd
+          (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
+
+def tm_main_loop (tr : PB) (cfg : PB) : PB :=
+  -- Note that `Cfg` is a pair of `Option State` and `BiTape`,
+  -- and the termination condition is that the first element of this pair is none.
+  -- This exactly matches our while loop termination condition.
+  PB.while_ (fun acc => PB.elim acc
+    -- accumulator is empty, initialize
+    cfg
+    -- accumulator is non-empty, run a single step. Ignore that the result is an option
+    (fun _ _ => (singleTapeTM_step tr acc).head))
+
+def string_to_tape (input : PB) : PB :=
+  to_pair input.head (to_pair .empty input.tail)
+
+def initial_config (q₀ : PB) (input : PB) : PB :=
+  to_pair (PB.some q₀) (string_to_tape input)
+
+/-- Turn the final config to an output, by taking the head and the right part of the tape. -/
+def final_config_to_output (cfg : PB) : PB := PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd)
+
+/-- Implements a universal Single-Tape TM, assuming that the input contains the following:
+((initialState, transitionFunction), input).
+If it terminates, the output is the tape contents under the head and to its right. -/
+def universal_tm (input : PB) :=
+  final_config_to_output
+    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.fst.snd))
 
 end RoseTreeMachine
 

From 006fc9f4f44e1d8e71bb11c8aef8fe4b59cd474e Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 14:07:54 +0200
Subject: [PATCH 063/106] some semantics proofs

---
 .../Machines/RoseTreeMachine/V2.lean          | 485 +++++++++++++++++-
 1 file changed, 464 insertions(+), 21 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 1a3fe4d22a..ca445c6644 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -221,6 +221,48 @@ def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
     Part.fix F (Data.empty, 1, 1)
   termination_by (sizeOf p, 0)
 
+------------------------------------
+--- We are just handling the semantics for now.
+--- Later on, it would probably make sense to define a variation of meteredEval
+--- that uses O-classes for the space and time, so we can use equality-transformations
+--- instead of inequalities in the semantics proofs.
+-------------------------------------------
+
+def Prog.eval (p : Prog) (env : List Data) : Part Data := (p.meteredEval env).map Prod.fst
+
+def Prog.computes (impl : Prog) (f : List Data → Data) : Prop :=
+  ∀ env, impl.eval env = .some (f env)
+
+@[simp]
+lemma Prog.var_computes {i : ℕ} :
+  (Prog.var i).computes (fun env => env[i]?.getD (Data.l [])) := by
+  simp [Prog.computes, Prog.eval, Prog.meteredEval]
+
+@[simp]
+lemma Prog.empty_computes :
+  Prog.empty.computes (fun _ => Data.l []) := by
+  simp [Prog.computes, Prog.eval, Prog.meteredEval]
+
+@[simp]
+lemma Prog.cons_computes {h t : Prog} {fh ft : List Data → Data}
+    (hh : h.computes fh) (ht : t.computes ft) :
+    (Prog.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
+  sorry
+
+/-- Pointwise (single-env) version of `Prog.cons_computes`. -/
+lemma Prog.cons_eval {h t : Prog} {env : List Data} {dh dt : Data}
+    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
+    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
+  sorry
+
+/-- Pointwise (single-env) version for `elim`. -/
+lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
+    (hv : v.eval env = .some dv) :
+    (Prog.elim v em cs).eval env =
+      match dv.asList with
+      | [] => em.eval env
+      | head :: tail => cs.eval (env ++ [head, Data.l tail]) := by
+  sorry
 
 def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
 
@@ -255,39 +297,32 @@ abbrev PB := ℕ → Prog
 
 namespace PB
 
-@[simp]
 def empty : PB := fun _ => .empty
-@[simp]
 def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
-@[simp]
 def eq (a b : PB) : PB := fun n => .eq (a n) (b n)
 
 /-- `letIn val (fun x => body)`: bind the value of `val` as a fresh variable `x`
 visible in `body`. -/
-@[simp]
 def letIn (val : PB) (body : PB → PB) : PB := fun n =>
   .letin (val n) (body (fun _ => .var n) (n + 1))
 
 /-- `elim v em (fun head tail => body)`: case-analyse the result of `v`. -/
-@[simp]
 def elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
   .elim (v n) (em n) (cs (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2))
 
 /-- `fold (fun acc x => body) init list`: run `body` for each element `x`
 threading accumulator `acc`. -/
-@[simp]
 def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
   .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
 
 /-- `while_ (fun acc => body)`. -/
-@[simp]
 def while_ (body : PB → PB) : PB := fun n =>
   .while_ (body (fun _ => .var n) (n + 1))
 
 /-- Close a builder into a concrete `Prog`. -/
-@[simp]
 def build (p : PB) : Prog := p 0
 
+
 end PB
 
 -------------------------------------
@@ -344,6 +379,11 @@ instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
   h_inj := by sorry
 
+----------------------------------------------------
+
+def PB.computes (impl : PB) (f : List Data → Data) : Prop :=
+  ∀ env, (impl env.length).eval env = .some (f env)
+
 -------------------------------------------------------
 --- combinator semantics
 ----------------------------------------------------
@@ -379,33 +419,361 @@ lemma list_getElem_length_add {α : Type} (xs ys : List α) (i : ℕ) (h_lt : i
 def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
 def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
 
-lemma tail_semantics (x : PB) {env : List Data} {h_wf : (x env.length).WhileFree} :
-  ((PB.tail x (env.length)).meteredEvalT (by simp [PB.tail, h_wf]) env).1 =
-  Data.l ((x env.length).meteredEvalT h_wf env).1.asList.tail := by
-  simp [PB.tail, meteredEvalT_elim_val]
+/-! ### Compositional `computes` rules for `PB` combinators
+
+The pattern: each combinator takes its `PB` arguments **paired with their `computes`
+specs**, and yields a `computes` for the composite. -/
+
+@[simp] lemma PB.empty_computes : PB.empty.computes (fun _ => Data.l []) := by
+  intro env
+  simp [PB.empty, Prog.eval, Prog.meteredEval]
+
+/-- The "bound-variable look-up" PB: at binder depth `n` it produces `var (n + offset)`. -/
+def PB.bound (offset : ℕ) : PB := fun n => Prog.var (n + offset)
+
+lemma PB.bound_computes (offset : ℕ) :
+    (PB.bound offset).computes (fun env => env[env.length + offset]?.getD (Data.l [])) := by
+  simp [PB.bound, PB.computes, Prog.eval, Prog.meteredEval]
+
+lemma PB.cons_computes {h t : PB} {fh ft : List Data → Data}
+    (hh : h.computes fh) (ht : t.computes ft) :
+    (PB.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
+  intro env
+  simp only [PB.cons]
+  exact Prog.cons_eval (hh env) (ht env)
+
+/-- Inside an `elim cs` branch, the two PBs passed to `cs` are constant closures
+returning `.var n` and `.var (n+1)`, where `n = env.length` at the outer call site.
+The body is then evaluated under env extended with `[head, Data.l tail]`.
+
+The spec for `cs` must therefore be parametric in the slot `n`: assume that for
+every `slot`, the body built with the two constant lookups computes a function
+expressed in terms of those two slot positions. -/
+lemma PB.elim_computes {v em : PB} {cs : PB → PB → PB}
+    {fv fem : List Data → Data}
+    {fcs : List Data → Data → Data → Data}
+    (hv : v.computes fv) (hem : em.computes fem)
+    (hcs : ∀ slot : ℕ,
+      (cs (fun _ => .var slot) (fun _ => .var (slot + 1))).computes
+        (fun env' => fcs (env'.take slot)
+                         (env'[slot]?.getD (Data.l []))
+                         (env'[slot + 1]?.getD (Data.l [])))) :
+    (PB.elim v em cs).computes (fun env =>
+      match (fv env).asList with
+      | [] => fem env
+      | head :: tail => fcs env head (Data.l tail)) := by
+  intro env
+  simp only [PB.elim]
+  -- Apply pointwise elim eval with hv env.
+  rw [Prog.elim_eval (hv env)]
+  -- Case split on (fv env).asList.
+  match h_fv : (fv env).asList with
+  | [] =>
+    simp only
+    exact hem env
+  | head :: tail =>
+    simp only
+    -- The cs body, instantiated at slot = env.length, computes the right function;
+    -- specialise its `computes` hypothesis to env' = env ++ [head, Data.l tail].
+    have hcs_inst := hcs env.length (env ++ [head, Data.l tail])
+    -- Beta-reduce the spec function on the extended env.
+    simp only at hcs_inst
+    -- The depth at the body's call site is (env ++ [head, Data.l tail]).length = env.length + 2.
+    have hlen : (env ++ [head, Data.l tail]).length = env.length + 2 := by simp
+    rw [hlen] at hcs_inst
+    have h_take : (env ++ [head, Data.l tail]).take env.length = env := by
+      simp
+    have h_get0 : (env ++ [head, Data.l tail])[env.length]? = some head := by
+      simp [List.getElem?_append_right]
+    have h_get1 : (env ++ [head, Data.l tail])[env.length + 1]? = some (Data.l tail) := by
+      simp [List.getElem?_append_right]
+    rw [h_take, h_get0, h_get1] at hcs_inst
+    simp only [Option.getD_some] at hcs_inst
+    exact hcs_inst
+
+lemma PB.elim_computes' {v em : PB} {cs : PB → PB → PB}
+    {fv fem : List Data → Data}
+    {fcs : Data → Data → List Data → Data}
+    (hv : v.computes fv) (hem : em.computes fem)
+    (hcs : ∀ slot : ℕ,
+      (cs (fun _ => .var slot) (fun _ => .var (slot + 1))).computes
+        (fun env' => fcs (env'[slot]?.getD (Data.l []))
+                         (env'[slot + 1]?.getD (Data.l []))
+                         (env'.take slot))) :
+    (PB.elim v em cs).computes (fun env =>
+      match (fv env).asList with
+      | [] => fem env
+      | head :: tail => fcs head (Data.l tail) env) := by
+  sorry
+
+/-- `PB.tail` computes the tail-of-list function applied to the spec of its argument.
+This is the direct combinator-level spec, obtainable from `PB.elim_computes` with
+`em := PB.empty` and `cs head tl := tl`. -/
+lemma PB.tail_computes {x : PB} {fx : List Data → Data} (hx : x.computes fx) :
+    (PB.tail x).computes (fun env => Data.l (fx env).asList.tail) := by
+  unfold PB.tail
+  have h := PB.elim_computes (cs := fun _head tl => tl)
+    (fv := fx) (fem := fun _ => Data.l [])
+    (fcs := fun _env _head tl => tl)
+    hx PB.empty_computes
+    (by
+      intro slot env'
+      simp [Prog.eval, Prog.meteredEval]
+      rfl)
+  intro env
+  have he := h env
+  simp only at he
+  show _ = Part.some (Data.l (fx env).asList.tail)
+  suffices h_eq :
+      (match (fx env).asList with
+       | [] => Data.l []
+       | _head :: tail => Data.l tail) = Data.l (fx env).asList.tail by
+    rw [← h_eq]; exact he
+  rcases (fx env).asList with _ | ⟨head, tail⟩
+  · rfl
+  · rfl
+
+/-- Same for `PB.head`. -/
+lemma PB.head_computes {x : PB} {fx : List Data → Data} (hx : x.computes fx) :
+    (PB.head x).computes (fun env => (fx env).asList.headD (Data.l [])) := by
+  sorry
+
+lemma PB.letIn_computes {val : PB} {body : PB → PB}
+    {fv : List Data → Data} {fb : List Data → Data → Data}
+    (hv : val.computes fv)
+    (hb : (body (PB.bound 0)).computes
+            (fun env => fb env.dropLast ((env.getLast?).getD (Data.l [])))) :
+    (PB.letIn val body).computes (fun env => fb env (fv env)) := by
+  sorry
+
+/-! ## Alternative reasoning layers
+
+The `PB.computes` framework above is awkward because the universal quantification
+over `env` is coupled to the depth `env.length` at which the PB is unfolded.
+Below are two lighter-weight alternatives. -/
+
+/-! ### Option A: pointwise `Prog`-level `simp` set
+
+Lifting eval rules to `@[simp]` lemmas lets you discharge most goals of the form
+`p.eval env = .some d` by `simp` plus at most one `rcases` on a list. -/
+
+@[simp] lemma Prog.var_eval {env : List Data} {i : ℕ} :
+    (Prog.var i).eval env = .some (env[i]?.getD (Data.l [])) := by
+  sorry
+
+@[simp] lemma Prog.empty_eval {env : List Data} :
+    Prog.empty.eval env = .some (Data.l []) := by
+  sorry
+
+@[simp] lemma Prog.cons_eval_simp {env : List Data} {h t : Prog} {dh dt : Data}
+    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
+    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
+  sorry
+
+@[simp] lemma Prog.elim_eval_nil {env : List Data} {v em cs : Prog}
+    (hv : v.eval env = .some (Data.l [])) :
+    (Prog.elim v em cs).eval env = em.eval env := by
+  sorry
+
+@[simp] lemma Prog.elim_eval_cons {env : List Data} {v em cs : Prog}
+    {head : Data} {tail : List Data}
+    (hv : v.eval env = .some (Data.l (head :: tail))) :
+    (Prog.elim v em cs).eval env = cs.eval (env ++ [head, Data.l tail]) := by
+  sorry
+
+@[simp] lemma Prog.letin_eval {env : List Data} {val rest : Prog} {dv : Data}
+    (hv : val.eval env = .some dv) :
+    (Prog.letin val rest).eval env = rest.eval (env ++ [dv]) := by
+  sorry
+
+@[simp] lemma Prog.eq_eval {env : List Data} {a b : Prog} {da db : Data}
+    (ha : a.eval env = .some da) (hb : b.eval env = .some db) :
+    (Prog.eq a b).eval env =
+      .some (if da = db then Data.l [Data.l []] else Data.l []) := by
+  sorry
+
+/-- Example: with the `simp` set above, the `tail` spec on a concrete env is short. -/
+example {env : List Data} {x : Prog} {dx : Data} (hx : x.eval env = .some dx) :
+    (Prog.elim x Prog.empty (Prog.var (env.length + 1))).eval env =
+      .some (Data.l dx.asList.tail) := by
+  rcases h : dx.asList with _ | ⟨head, tail⟩
+  · have hx' : x.eval env = .some (Data.l []) := by
+      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
+    simp [Prog.elim_eval_nil hx']
+  · have hx' : x.eval env = .some (Data.l (head :: tail)) := by
+      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
+    rw [Prog.elim_eval_cons hx', Prog.var_eval]
+    have hidx : (env ++ [head, Data.l tail])[env.length + 1]? = some (Data.l tail) := by
+      simp [List.getElem?_append_right]
+    simp only [hidx, Option.getD_some]
+    rfl
+
+/-! ### Option C: per-env `PB.computes_at`
+
+A pointwise version of `PB.computes` that talks about a specific env. -/
+
+/-- `PB.computes_at env impl d`: for every extension `ext` of `env`, when the
+program is unfolded at depth `(env ++ ext).length` and evaluated on `env ++ ext`,
+it yields `d`. The `∀ ext` quantifier captures the fact that well-formed PBs
+preserve their value under env-extension, which is essential for composing them
+inside binders. -/
+def PB.computes_at (env : List Data) (impl : PB) (d : Data) : Prop :=
+  ∀ ext : List Data,
+    (impl (env.length + ext.length)).eval (env ++ ext) = .some d
+
+/-- The basic per-env consequence, instantiating `ext := []`. -/
+lemma PB.computes_at.here {env : List Data} {impl : PB} {d : Data}
+    (h : PB.computes_at env impl d) :
+    (impl env.length).eval env = .some d := by
+  simpa using h []
+
+/-- Weakening: extending the env preserves `computes_at`. -/
+lemma PB.computes_at.extend {env ext : List Data} {impl : PB} {d : Data}
+    (h : PB.computes_at env impl d) :
+    PB.computes_at (env ++ ext) impl d := by
+  intro ext'
+  have := h (ext ++ ext')
+  simpa [List.append_assoc, Nat.add_assoc] using this
+
+@[simp, grind .]
+lemma PB.var_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes_at env (fun _ => .var i) env[i] := by
+  intro ext
+  simp [Prog.eval, Prog.meteredEval, List.getElem?_append_left h]
   grind
 
+@[simp, grind .]
+lemma PB.empty_computes_at {env : List Data} :
+    PB.computes_at env PB.empty (Data.l []) := by
+  intro ext
+  simp [PB.empty, Prog.eval, Prog.meteredEval]
+
+@[simp, grind .]
+lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
+    (hh : PB.computes_at env h dh) (ht : PB.computes_at env t dt) :
+    PB.computes_at env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
+  intro ext
+  simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
+
+/-- `elim` at a fixed env, nil branch. -/
+@[grind .]
+lemma PB.elim_nil_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {dr : Data}
+    (hv : PB.computes_at env v (Data.l []))
+    (hem : PB.computes_at env em dr) :
+    PB.computes_at env (PB.elim v em cs) dr := by
+  intro ext
+  simp only [PB.elim]
+  rw [Prog.elim_eval_nil (hv ext)]
+  exact hem ext
+
+/-- `elim` at a fixed env, cons branch. The body hypothesis is a `PB.computes_at`
+on the env extended with `[head, Data.l tail]` (and any outer extension `ext`),
+applied to `cs` with the two slot-lookup PBs for `head` and `Data.l tail`. -/
+@[grind .]
+lemma PB.elim_cons_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {head : Data} {tail : List Data} {dr : Data}
+    (hv : PB.computes_at env v (Data.l (head :: tail)))
+    (hcs : ∀ ext, PB.computes_at (env ++ ext ++ [head, Data.l tail])
+                    (cs (fun _ => .var (env.length + ext.length))
+                        (fun _ => .var (env.length + ext.length + 1))) dr) :
+    PB.computes_at env (PB.elim v em cs) dr := by
+  intro ext
+  simp only [PB.elim]
+  rw [Prog.elim_eval_cons (hv ext)]
+  have h := (hcs ext).here
+  simpa [List.append_assoc] using h
+
+/-- The two slot-lookup PBs appearing as arguments to `cs` in
+`PB.elim_cons_computes_at` compute `head` and `Data.l tail` respectively, viewed
+as `PB.computes_at` over the env extended with `[head, Data.l tail]`. -/
+lemma PB.elim_cons_head_var_computes_at {env ext : List Data}
+    {head : Data} {tail : Data} :
+    PB.computes_at (env ++ ext ++ [head, tail])
+      (fun _ => .var (env.length + ext.length)) head := by
+  have hlen : env.length + ext.length
+      < (env ++ ext ++ [head, tail]).length := by simp
+  grind [PB.var_computes_at hlen]
+
+lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
+    {head : Data} {tail : Data} :
+    PB.computes_at (env ++ ext ++ [head, tail])
+      (fun _ => .var (env.length + ext.length + 1)) tail := by
+  have hlen : env.length + ext.length + 1
+      < (env ++ ext ++ [head, tail]).length := by grind
+  grind [PB.var_computes_at hlen]
+
+/-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
+lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
+    (hx : PB.computes_at env x dx) :
+    PB.computes_at env (PB.tail x) (Data.l dx.asList.tail) := by
+  cases h : dx.asList with
+  | nil =>
+    refine PB.elim_nil_computes_at ?_ ?_
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+    · simp
+  | cons head tail =>
+    unfold PB.tail
+    apply PB.elim_cons_computes_at (em := PB.empty) (cs := fun _h tl => tl)
+    · intro ext; rw [hx ext]; congr 1
+      rw [← Data.asList_l dx, h]
+    · intro ext
+      simpa using PB.elim_cons_tail_var_computes_at
+
+/-- `PB.head` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
+lemma PB.head_computes_at {env : List Data} {x : PB} {dx : Data}
+    (hx : PB.computes_at env x dx) :
+    PB.computes_at env (PB.head x) (dx.asList.headD (Data.l [])) := by
+  cases h : dx.asList with
+  | nil =>
+    refine PB.elim_nil_computes_at ?_ (by simp)
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+  | cons head tail =>
+    apply PB.elim_cons_computes_at
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+    · intro ext
+      simpa using PB.elim_cons_head_var_computes_at
+
+/-! ### Option B (mentioned for completeness): recover the ∀-quantified version
+
+`PB.computes` is implied by the per-env strengthened version pointwise: if `impl`
+computes-at every env, it computes the constant value function. -/
+lemma PB.computes_of_computes_at {impl : PB} {d : Data}
+    (h : ∀ env, PB.computes_at env impl d) :
+    impl.computes (fun _ => d) := by
+  intro env; exact (h env).here
+
 /-- Program that evaluates to the constant `a`. -/
 def constant (a : Data) : PB := match a with
   | Data.l [] => PB.empty
   | Data.l (x :: xs) => PB.cons (constant x) (constant (Data.l xs))
 
-@[simp]
-lemma constant_whileFree (a : Data) (n : ℕ) : (constant a n).WhileFree := by
+-- @[simp]
+-- lemma constant_whileFree (a : Data) (n : ℕ) : (constant a n).WhileFree := by
+--   induction a using Data.inductionL with
+--   | nil => simp [constant]
+--   | cons x xs ihx ihxs => simp [constant, ihx, ihxs]
+
+-- lemma constant.semantics (a : Data) {n : ℕ} :
+--     ((constant a n).meteredEvalT (by simp) []).1 = a := by
+--   sorry
+
+lemma constant_computes {env : List Data} {a : Data} :
+    (constant a).computes_at env a := by
   induction a using Data.inductionL with
   | nil => simp [constant]
-  | cons x xs ihx ihxs => simp [constant, ihx, ihxs]
-
-lemma constant.semantics (a : Data) {n : ℕ} :
-    ((constant a n).meteredEvalT (by simp) []).1 = a := by
-  sorry
+  | cons x xs ihx ihxs =>
+    simpa [constant] using PB.cons_computes_at ihx ihxs
 
 def encConst {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a)
 
 def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
   .elim (PB.eq a b)
     else_
-    (fun _ _ => then_)
+    fun _ _ => then_
 
 ------------------------------------------------------
 ----------- Tools
@@ -420,7 +788,30 @@ def PB.snd (x : PB) : PB := head (tail x)
 -- Compute x => Option.some x
 def PB.some (x : PB) : PB := cons x empty
 
--- TODO for the semantics, the PBs could actually be typed...
+----------------- Typed computation
+
+def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
+    PB.computes_at env x (DataEncode.encode a)
+
+lemma PB.fst_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.fst x) a.fst := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes_at hx
+
+lemma PB.snd_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.snd x) a.snd := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes_at (PB.tail_computes_at hx)
+
+lemma PB.some_computes_at_encoded {α : Type} [DataEncode α]
+    {env : List Data} {x : PB} {a : α}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.some x) (Option.some a) := by
+  apply PB.cons_computes_at hx PB.empty_computes_at
 
 -------------------------------------------------------------------
 ---------------- Universal Turing Machine (simulation of a SingleTapeTM)
@@ -443,6 +834,14 @@ lemma encode_biTape (t : Turing.BiTape Symbol) :
 
 def bitape_write (t v : PB) : PB := PB.cons v t.tail
 
+lemma bitape_write_computes
+    {env : List Data} {p_t p_v : PB} {t : BiTape Symbol} {v : Option Symbol}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_v : PB.computes_at_encoded env p_v v) :
+    PB.computes_at_encoded env (bitape_write p_t p_v) (t.write v) := by
+  simp only [PB.computes_at_encoded, encode_biTape, DataEncode_pair] at h_t h_v ⊢
+  apply PB.cons_computes_at h_v (PB.tail_computes_at h_t)
+
 -- /-- Prepend an `Option` to the `StackTape` -/
 -- @[scoped grind]
 -- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
@@ -458,6 +857,50 @@ def stackTape_cons (x st : PB) : PB :=
       (fun _ _ => PB.cons x st))
     (fun _ _ => PB.cons x st)
 
+lemma stackTape_cons_computes
+    {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
+    (h_x : PB.computes_at_encoded env p_x x)
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (stackTape_cons p_x p_st).computes_at_encoded env (st.cons x) := by
+  simp only [PB.computes_at_encoded] at h_x h_st ⊢
+  -- Outer elim splits on `x`.
+  cases x with
+  | none =>
+    -- encode none = Data.l []
+    have hx0 : PB.computes_at env p_x (Data.l []) := by
+      simpa [DataEncode.encode] using h_x
+    refine PB.elim_nil_computes_at hx0 ?_
+    -- Inner elim splits on `st.toList`.
+    obtain ⟨l, hl⟩ := st
+    cases l with
+    | nil =>
+      -- encode st = Data.l [], encode (st.cons none) = Data.l []
+      have hst0 : PB.computes_at env p_st (Data.l []) := by
+        simpa [DataEncode.encode, StackTape.toList] using h_st
+      simpa [DataEncode.encode, StackTape.cons, StackTape.toList] using
+        PB.elim_nil_computes_at hst0 (PB.empty_computes_at)
+    | cons hd tl =>
+      -- encode st = Data.l (encode hd :: tl.map encode)
+      have hstc : PB.computes_at env p_st
+          (Data.l (DataEncode.encode hd :: (tl.map DataEncode.encode))) := by
+        simpa [DataEncode.encode, StackTape.toList, List.map] using h_st
+      apply PB.elim_cons_computes_at hstc
+        (head := DataEncode.encode hd) (tail := tl.map DataEncode.encode)
+      intro ext
+      -- cs body is `fun _ _ => PB.cons p_x p_st`; evaluate it.
+      have hcons := PB.cons_computes_at h_x h_st
+        (ext := ext ++ [DataEncode.encode hd, Data.l (tl.map DataEncode.encode)])
+      simpa [PB.cons, List.append_assoc] using hcons
+  | some a =>
+    -- encode (some a) = Data.l [encode a]
+    have hxc : PB.computes_at env p_x (Data.l [DataEncode.encode a]) := by
+      simpa [DataEncode.encode] using h_x
+    apply PB.elim_cons_computes_at hxc
+      (head := DataEncode.encode a) (tail := [])
+    intro ext
+    have hcons := PB.cons_computes_at h_x h_st
+      (ext := ext ++ [DataEncode.encode a, Data.l []])
+    simpa [PB.cons, List.append_assoc] using hcons
 
 def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
 

From 1389a83857d58b61b1b6f3e104caf143afc754e1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 16:46:31 +0200
Subject: [PATCH 064/106] more semantics

---
 .../Machines/RoseTreeMachine/V2.lean          | 242 ++++++++++++++----
 1 file changed, 195 insertions(+), 47 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index ca445c6644..dc9231d997 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -628,6 +628,7 @@ lemma PB.computes_at.here {env : List Data} {impl : PB} {d : Data}
   simpa using h []
 
 /-- Weakening: extending the env preserves `computes_at`. -/
+@[simp]
 lemma PB.computes_at.extend {env ext : List Data} {impl : PB} {d : Data}
     (h : PB.computes_at env impl d) :
     PB.computes_at (env ++ ext) impl d := by
@@ -655,6 +656,49 @@ lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
   intro ext
   simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
 
+lemma PB.eq_computes_at {env : List Data} {a b : PB} {da db : Data}
+    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db) :
+    PB.computes_at env (PB.eq a b)
+      (if da = db then Data.l [Data.l []] else Data.l []) := by
+  intro ext
+  simpa [PB.eq] using Prog.eq_eval (ha ext) (hb ext)
+
+/-! ### Body-of-binder abstraction
+
+The hypothesis shape arising for the body of a binder (`elim`, `letin`, `fold`,
+…) is that the body PB, built from var-lookup PBs for each new binding,
+computes the result on the env extended with those bindings, for any outer
+extension `ext`. We package this as `PB.computes_at_body` with arity-typed
+convenience wrappers. -/
+
+/-- Depth-agnostic var-lookup PB: `PB.atSlot i = fun _ => .var i`. -/
+def PB.atSlot (i : ℕ) : PB := fun _ => .var i
+
+@[simp]
+lemma PB.atSlot_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes_at env (PB.atSlot i) env[i] :=
+  PB.var_computes_at h
+
+/-- Body-of-binder hypothesis. `mkBody` is an arity-`bindings.length` body
+builder that receives the var-lookup PBs for each binding and produces a PB.
+The result must compute `dr` on `env` extended with `bindings` (under any
+outer extension `ext`). -/
+def PB.computes_at_body (env : List Data) (bindings : List Data)
+    (mkBody : (Fin bindings.length → PB) → PB) (dr : Data) : Prop :=
+  ∀ ext : List Data,
+    PB.computes_at (env ++ ext ++ bindings)
+      (mkBody (fun i => PB.atSlot (env.length + ext.length + i))) dr
+
+/-- Arity-1 convenience: one new binding `b`, body `body : PB → PB`. -/
+abbrev PB.computes_at_body₁ (env : List Data) (b : Data)
+    (body : PB → PB) (dr : Data) : Prop :=
+  PB.computes_at_body env [b] (fun a => body (a 0)) dr
+
+/-- Arity-2 convenience: two new bindings `b₁, b₂`, body `body : PB → PB → PB`. -/
+abbrev PB.computes_at_body₂ (env : List Data) (b₁ b₂ : Data)
+    (body : PB → PB → PB) (dr : Data) : Prop :=
+  PB.computes_at_body env [b₁, b₂] (fun a => body (a 0) (a 1)) dr
+
 /-- `elim` at a fixed env, nil branch. -/
 @[grind .]
 lemma PB.elim_nil_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
@@ -667,40 +711,40 @@ lemma PB.elim_nil_computes_at {env : List Data} {v em : PB} {cs : PB → PB →
   rw [Prog.elim_eval_nil (hv ext)]
   exact hem ext
 
-/-- `elim` at a fixed env, cons branch. The body hypothesis is a `PB.computes_at`
-on the env extended with `[head, Data.l tail]` (and any outer extension `ext`),
-applied to `cs` with the two slot-lookup PBs for `head` and `Data.l tail`. -/
+/-- `elim` at a fixed env, cons branch. The body hypothesis is packaged as
+`PB.computes_at_body₂`: `cs`, applied to the var-lookup PBs for `head` and
+`Data.l tail`, computes `dr` on the env extended with `[head, Data.l tail]`. -/
 @[grind .]
 lemma PB.elim_cons_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
     {head : Data} {tail : List Data} {dr : Data}
     (hv : PB.computes_at env v (Data.l (head :: tail)))
-    (hcs : ∀ ext, PB.computes_at (env ++ ext ++ [head, Data.l tail])
-                    (cs (fun _ => .var (env.length + ext.length))
-                        (fun _ => .var (env.length + ext.length + 1))) dr) :
+    (hcs : PB.computes_at_body₂ env head (Data.l tail) cs dr) :
     PB.computes_at env (PB.elim v em cs) dr := by
   intro ext
   simp only [PB.elim]
   rw [Prog.elim_eval_cons (hv ext)]
   have h := (hcs ext).here
-  simpa [List.append_assoc] using h
+  simpa [PB.atSlot, List.append_assoc] using h
 
-/-- The two slot-lookup PBs appearing as arguments to `cs` in
-`PB.elim_cons_computes_at` compute `head` and `Data.l tail` respectively, viewed
-as `PB.computes_at` over the env extended with `[head, Data.l tail]`. -/
+/-- The slot-lookup PB for `head` in the body of an `elim` (or any 2-binding
+body). -/
 lemma PB.elim_cons_head_var_computes_at {env ext : List Data}
     {head : Data} {tail : Data} :
     PB.computes_at (env ++ ext ++ [head, tail])
-      (fun _ => .var (env.length + ext.length)) head := by
+      (PB.atSlot (env.length + ext.length)) head := by
+  show PB.computes_at _ (fun _ => .var (env.length + ext.length)) _
   have hlen : env.length + ext.length
       < (env ++ ext ++ [head, tail]).length := by simp
   grind [PB.var_computes_at hlen]
 
+/-- The slot-lookup PB for the second binding in the body of an `elim`. -/
 lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
     {head : Data} {tail : Data} :
     PB.computes_at (env ++ ext ++ [head, tail])
-      (fun _ => .var (env.length + ext.length + 1)) tail := by
+      (PB.atSlot (env.length + ext.length + 1)) tail := by
+  show PB.computes_at _ (fun _ => .var (env.length + ext.length + 1)) _
   have hlen : env.length + ext.length + 1
-      < (env ++ ext ++ [head, tail]).length := by grind
+      < (env ++ ext ++ [head, tail]).length := by simp; omega
   grind [PB.var_computes_at hlen]
 
 /-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
@@ -719,7 +763,7 @@ lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
     · intro ext; rw [hx ext]; congr 1
       rw [← Data.asList_l dx, h]
     · intro ext
-      simpa using PB.elim_cons_tail_var_computes_at
+      exact PB.elim_cons_tail_var_computes_at
 
 /-- `PB.head` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
 lemma PB.head_computes_at {env : List Data} {x : PB} {dx : Data}
@@ -735,7 +779,7 @@ lemma PB.head_computes_at {env : List Data} {x : PB} {dx : Data}
     · intro ext; have := hx ext; rw [this]; congr 1
       rw [← Data.asList_l dx, h]
     · intro ext
-      simpa using PB.elim_cons_head_var_computes_at
+      exact PB.elim_cons_head_var_computes_at
 
 /-! ### Option B (mentioned for completeness): recover the ∀-quantified version
 
@@ -788,11 +832,29 @@ def PB.snd (x : PB) : PB := head (tail x)
 -- Compute x => Option.some x
 def PB.some (x : PB) : PB := cons x empty
 
+def PB.optionElim (x : PB) (noneCase : PB) (someCase : PB → PB) : PB :=
+  elim x noneCase (fun hd _ => someCase hd)
+
 ----------------- Typed computation
 
 def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
     PB.computes_at env x (DataEncode.encode a)
 
+/-- Encoded body-of-binder hypothesis: the body computes a typed value `a`
+under any outer env extension. -/
+abbrev PB.computes_at_body_encoded {α : Type} [DataEncode α]
+    (env : List Data) (bindings : List Data)
+    (mkBody : (Fin bindings.length → PB) → PB) (a : α) : Prop :=
+  PB.computes_at_body env bindings mkBody (DataEncode.encode a)
+
+abbrev PB.computes_at_body₁_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    (env : List Data) (a : α) (body : PB → PB) (b : β) : Prop :=
+  PB.computes_at_body₁ env (DataEncode.encode a) body (DataEncode.encode b)
+
+abbrev PB.computes_at_body₂_encoded {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ]
+    (env : List Data) (a : α) (b : β) (body : PB → PB → PB) (c : γ) : Prop :=
+  PB.computes_at_body₂ env (DataEncode.encode a) (DataEncode.encode b) body (DataEncode.encode c)
+
 lemma PB.fst_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
     {env : List Data} {x : PB} {a : α × β}
     (hx : PB.computes_at_encoded env x a) :
@@ -813,6 +875,24 @@ lemma PB.some_computes_at_encoded {α : Type} [DataEncode α]
     PB.computes_at_encoded env (PB.some x) (Option.some a) := by
   apply PB.cons_computes_at hx PB.empty_computes_at
 
+lemma PB.optionElim_computes_none {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
+    (hx : x.computes_at_encoded env (none : Option α))
+    {a : β}
+    (h_none : noneCase.computes_at_encoded env a) :
+    (PB.optionElim x noneCase someCase).computes_at_encoded env a := by
+  apply PB.elim_nil_computes_at hx h_none
+
+lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
+    {a : α}
+    (hx : x.computes_at_encoded env (Option.some a))
+    {b : β}
+    (h_some : PB.computes_at_body₁_encoded env a someCase b) :
+    (PB.optionElim x noneCase someCase).computes_at_encoded env b := by
+  apply PB.elim_cons_computes_at hx
+  intro ext
+  simpa [List.append_assoc] using (h_some ext).extend
 -------------------------------------------------------------------
 ---------------- Universal Turing Machine (simulation of a SingleTapeTM)
 ---------------------------------------------------------------------------
@@ -851,59 +931,46 @@ lemma bitape_write_computes
 --   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
 
 def stackTape_cons (x st : PB) : PB :=
-  PB.elim x
+  PB.optionElim x
     (PB.elim st
       PB.empty
       (fun _ _ => PB.cons x st))
-    (fun _ _ => PB.cons x st)
+    (fun _ => PB.cons x st)
 
+omit [Inhabited Symbol] [Fintype Symbol] in
 lemma stackTape_cons_computes
     {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
     (h_x : PB.computes_at_encoded env p_x x)
     (h_st : PB.computes_at_encoded env p_st st) :
     (stackTape_cons p_x p_st).computes_at_encoded env (st.cons x) := by
-  simp only [PB.computes_at_encoded] at h_x h_st ⊢
-  -- Outer elim splits on `x`.
   cases x with
   | none =>
-    -- encode none = Data.l []
-    have hx0 : PB.computes_at env p_x (Data.l []) := by
-      simpa [DataEncode.encode] using h_x
-    refine PB.elim_nil_computes_at hx0 ?_
-    -- Inner elim splits on `st.toList`.
+    apply PB.optionElim_computes_none h_x
     obtain ⟨l, hl⟩ := st
     cases l with
     | nil =>
-      -- encode st = Data.l [], encode (st.cons none) = Data.l []
-      have hst0 : PB.computes_at env p_st (Data.l []) := by
-        simpa [DataEncode.encode, StackTape.toList] using h_st
-      simpa [DataEncode.encode, StackTape.cons, StackTape.toList] using
-        PB.elim_nil_computes_at hst0 (PB.empty_computes_at)
+      simpa [DataEncode.encode] using
+        PB.elim_nil_computes_at (by simpa using h_st) (PB.empty_computes_at)
     | cons hd tl =>
-      -- encode st = Data.l (encode hd :: tl.map encode)
-      have hstc : PB.computes_at env p_st
-          (Data.l (DataEncode.encode hd :: (tl.map DataEncode.encode))) := by
-        simpa [DataEncode.encode, StackTape.toList, List.map] using h_st
-      apply PB.elim_cons_computes_at hstc
-        (head := DataEncode.encode hd) (tail := tl.map DataEncode.encode)
+      apply PB.elim_cons_computes_at (by simpa [DataEncode.encode] using h_st)
       intro ext
-      -- cs body is `fun _ _ => PB.cons p_x p_st`; evaluate it.
-      have hcons := PB.cons_computes_at h_x h_st
-        (ext := ext ++ [DataEncode.encode hd, Data.l (tl.map DataEncode.encode)])
-      simpa [PB.cons, List.append_assoc] using hcons
+      simpa using (PB.cons_computes_at h_x h_st).extend
   | some a =>
-    -- encode (some a) = Data.l [encode a]
-    have hxc : PB.computes_at env p_x (Data.l [DataEncode.encode a]) := by
-      simpa [DataEncode.encode] using h_x
-    apply PB.elim_cons_computes_at hxc
-      (head := DataEncode.encode a) (tail := [])
+    apply PB.optionElim_computes_some h_x
     intro ext
-    have hcons := PB.cons_computes_at h_x h_st
-      (ext := ext ++ [DataEncode.encode a, Data.l []])
-    simpa [PB.cons, List.append_assoc] using hcons
+    simpa using (PB.cons_computes_at (by simpa [DataEncode.encode] using h_x) h_st).extend
 
 def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
 
+lemma to_pair_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p_a p_b : PB}
+    {a : α} {b : β}
+    (h_a : p_a.computes_at_encoded env a)
+    (h_b : p_b.computes_at_encoded env b) :
+    (to_pair p_a p_b).computes_at_encoded env (a, b) := by
+  simpa [DataEncode.encode, to_pair] using
+    PB.cons_computes_at h_a (PB.cons_computes_at h_b PB.empty_computes_at)
+
 --- The head component of the bitape
 def bitape_head (t : PB) : PB := t.fst
 --- The left component of the bitape
@@ -911,6 +978,49 @@ def bitape_left (t : PB) : PB := t.snd.fst
 --- The right component of the bitape
 def bitape_right (t : PB) : PB := t.snd.snd
 
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_head_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_head p_t).computes_at_encoded env t.head := PB.head_computes_at h_t
+
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_left_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_left p_t).computes_at_encoded env t.left :=
+  PB.head_computes_at (PB.head_computes_at (PB.tail_computes_at h_t))
+
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_right_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_right p_t).computes_at_encoded env t.right :=
+  PB.head_computes_at (PB.tail_computes_at (PB.head_computes_at (PB.tail_computes_at h_t)))
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_stackTape_head (st : StackTape Symbol) :
+    (DataEncode.encode st).asList.headD (Data.l []) = DataEncode.encode st.head := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.head, Data.asList]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_stackTape_tail (st : StackTape Symbol) :
+    Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma stackTape_head_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (p_st.head).computes_at_encoded env st.head := by
+  unfold PB.computes_at_encoded
+  simpa [← encode_stackTape_head] using PB.head_computes_at h_st
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma stackTape_tail_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (p_st.tail).computes_at_encoded env st.tail := by
+  unfold PB.computes_at_encoded
+  simpa [← encode_stackTape_tail] using PB.tail_computes_at h_st
+
 -- def move_left (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
@@ -920,6 +1030,18 @@ def bitape_move_left (t : PB) : PB :=
       (bitape_left t).tail
       (stackTape_cons (bitape_head t) (bitape_right t)))
 
+lemma bitape_move_left_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    PB.computes_at_encoded env (bitape_move_left p_t) t.move_left := by
+  unfold PB.computes_at_encoded
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_at_encoded (bitape_left_computes h_t))
+    (to_pair_computes
+      (stackTape_tail_computes_at_encoded (bitape_left_computes h_t))
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
+
 -- def move_right (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
 
@@ -929,6 +1051,18 @@ def bitape_move_right (t : PB) : PB :=
       (stackTape_cons (bitape_head t) (bitape_left t))
       (bitape_right t).tail)
 
+lemma bitape_move_right_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    PB.computes_at_encoded env (bitape_move_right p_t) t.move_right := by
+  unfold PB.computes_at_encoded
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_at_encoded (bitape_right_computes h_t))
+    (to_pair_computes
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_left_computes h_t))
+      (stackTape_tail_computes_at_encoded (bitape_right_computes h_t)))
+
 instance : DataEncode Dir where
   encode := fun
     | Dir.left => DataEncode.encode true
@@ -947,6 +1081,20 @@ def bitape_move (tape dir : PB) : PB :=
     (bitape_move_left tape)
     (bitape_move_right tape)
 
+lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_dir : PB.computes_at_encoded env p_dir d) :
+    (bitape_move p_t p_dir).computes_at_encoded env (t.move d) := by
+  unfold PB.computes_at_encoded bitape_move PB.ifEq
+  simp only [PB.ifEq, constant, DataEncode_pair] at h_dir ⊢
+  cases d with
+  | left =>
+    rw [if_pos rfl]
+    exact bitape_move_left_computes h_t
+  | right =>
+    rw [if_neg (by simp)]
+    exact bitape_move_right_computes h_t
+
 -- /--
 -- Optionally perform a `move`, or do nothing if `none`.
 -- -/

From 6f7663065d92a0d8797ec5ae2002e0d0ca8ee304 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 17:10:18 +0200
Subject: [PATCH 065/106] finish move semantics.

---
 .../Machines/RoseTreeMachine/V2.lean          | 91 ++++++++++++++++---
 1 file changed, 80 insertions(+), 11 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index dc9231d997..a27183347a 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -643,6 +643,15 @@ lemma PB.var_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
   simp [Prog.eval, Prog.meteredEval, List.getElem?_append_left h]
   grind
 
+@[simp]
+lemma PB.var_last_computes_at {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ ext ++ [d])
+      (fun _ => Prog.var (env.length + ext.length)) d := by
+  have hlen : env.length + ext.length < (env ++ ext ++ [d]).length := by simp
+  have h := PB.var_computes_at (env := env ++ ext ++ [d]) hlen
+  convert h using 2
+  simp [List.getElem_append]
+
 @[simp, grind .]
 lemma PB.empty_computes_at {env : List Data} :
     PB.computes_at env PB.empty (Data.l []) := by
@@ -679,6 +688,18 @@ lemma PB.atSlot_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
     PB.computes_at env (PB.atSlot i) env[i] :=
   PB.var_computes_at h
 
+@[simp]
+lemma PB.atSlot_last_computes_at {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ ext ++ [d])
+      (PB.atSlot (env.length + ext.length)) d :=
+  PB.var_last_computes_at
+
+@[simp]
+lemma PB.atSlot_last_computes_at_right {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ (ext ++ [d]))
+      (PB.atSlot (env.length + ext.length)) d := by
+  rw [← List.append_assoc]; exact PB.atSlot_last_computes_at
+
 /-- Body-of-binder hypothesis. `mkBody` is an arity-`bindings.length` body
 builder that receives the var-lookup PBs for each binding and produces a PB.
 The result must compute `dr` on `env` extended with `bindings` (under any
@@ -819,6 +840,23 @@ def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
     else_
     fun _ _ => then_
 
+lemma PB.ifEq_computes_at {env : List Data} {a b then_ else_ : PB} {da db dr : Data}
+    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db)
+    (hthen : da = db → PB.computes_at env then_ dr)
+    (helse : da ≠ db → PB.computes_at env else_ dr) :
+    (PB.ifEq a b then_ else_).computes_at env dr := by
+  unfold PB.ifEq
+  by_cases h : da = db
+  · have heq : PB.computes_at env (PB.eq a b) (Data.l [Data.l []]) := by
+      simpa [h] using PB.eq_computes_at ha hb
+    refine PB.elim_cons_computes_at heq ?_
+    intro ext
+    have h' := (hthen h).extend (ext := ext ++ [Data.l [], Data.l []])
+    simpa [List.append_assoc] using h'
+  · have heq : PB.computes_at env (PB.eq a b) (Data.l []) := by
+      simpa [h] using PB.eq_computes_at ha hb
+    exact PB.elim_nil_computes_at heq (helse h)
+
 ------------------------------------------------------
 ----------- Tools
 -----------------------------------------------------------
@@ -840,6 +878,20 @@ def PB.optionElim (x : PB) (noneCase : PB) (someCase : PB → PB) : PB :=
 def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
     PB.computes_at env x (DataEncode.encode a)
 
+@[simp]
+lemma PB.atSlot_last_computes_at_encoded {α : Type} [DataEncode α]
+    {env ext : List Data} {a : α} :
+    PB.computes_at_encoded (env ++ ext ++ [DataEncode.encode a])
+      (PB.atSlot (env.length + ext.length)) a :=
+  PB.atSlot_last_computes_at
+
+@[simp]
+lemma PB.atSlot_last_computes_at_encoded_right {α : Type} [DataEncode α]
+    {env ext : List Data} {a : α} :
+    PB.computes_at_encoded (env ++ (ext ++ [DataEncode.encode a]))
+      (PB.atSlot (env.length + ext.length)) a :=
+  PB.atSlot_last_computes_at_right
+
 /-- Encoded body-of-binder hypothesis: the body computes a typed value `a`
 under any outer env extension. -/
 abbrev PB.computes_at_body_encoded {α : Type} [DataEncode α]
@@ -1085,15 +1137,19 @@ lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol
     (h_t : PB.computes_at_encoded env p_t t)
     (h_dir : PB.computes_at_encoded env p_dir d) :
     (bitape_move p_t p_dir).computes_at_encoded env (t.move d) := by
-  unfold PB.computes_at_encoded bitape_move PB.ifEq
-  simp only [PB.ifEq, constant, DataEncode_pair] at h_dir ⊢
-  cases d with
-  | left =>
-    rw [if_pos rfl]
-    exact bitape_move_left_computes h_t
-  | right =>
-    rw [if_neg (by simp)]
-    exact bitape_move_right_computes h_t
+  unfold PB.computes_at_encoded bitape_move
+  refine PB.ifEq_computes_at h_dir constant_computes ?_ ?_
+  · intro hd_eq
+    -- TODO could use injectivity here once we have it.
+    cases d with
+    | left => exact bitape_move_left_computes h_t
+    | right =>
+      exfalso
+      exact absurd hd_eq (by decide)
+  · intro hne
+    cases d with
+    | left => exact absurd rfl hne
+    | right => exact bitape_move_right_computes h_t
 
 -- /--
 -- Optionally perform a `move`, or do nothing if `none`.
@@ -1103,9 +1159,22 @@ lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol
 --   | t, some d => t.move d
 
 def bitape_optionMove (t dir : PB) : PB :=
-  .elim dir
+  PB.optionElim dir
     t
-    (fun d _ => bitape_move t d)
+    (fun d => bitape_move t d)
+
+lemma bitape_optionMove_computes {env : List Data} {p_t p_dir : PB}
+    {t : BiTape Symbol} {d : Option Dir}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_dir : PB.computes_at_encoded env p_dir d) :
+    (bitape_optionMove p_t p_dir).computes_at_encoded env (t.optionMove d) := by
+  unfold PB.computes_at_encoded bitape_optionMove BiTape.optionMove
+  match d with
+  | none => simpa using PB.optionElim_computes_none h_dir h_t
+  | some d =>
+    apply PB.optionElim_computes_some h_dir
+    intro ext
+    exact bitape_move_computes (by simpa using h_t.extend) (by simp)
 
 instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
     DataEncode (Turing.SingleTapeTM.Cfg tm) where

From 9c2f3445a2b07be7b61e82308227fa509816ade0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 17:24:15 +0200
Subject: [PATCH 066/106] fold semantics

---
 .../Machines/RoseTreeMachine/V2.lean          | 75 ++++++++++++++++++-
 1 file changed, 72 insertions(+), 3 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index a27183347a..9153b20360 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -523,7 +523,7 @@ lemma PB.tail_computes {x : PB} {fx : List Data → Data} (hx : x.computes fx) :
   intro env
   have he := h env
   simp only at he
-  show _ = Part.some (Data.l (fx env).asList.tail)
+  change _ = Part.some (Data.l (fx env).asList.tail)
   suffices h_eq :
       (match (fx env).asList with
        | [] => Data.l []
@@ -592,6 +592,22 @@ Lifting eval rules to `@[simp]` lemmas lets you discharge most goals of the form
       .some (if da = db then Data.l [Data.l []] else Data.l []) := by
   sorry
 
+/-- Semantic spec for `Prog.fold`. Rather than quantifying the body universally
+over arbitrary `Data` accumulators/elements, we parameterise by the actually
+visited accumulator sequence `acc : ℕ → Data`. This makes the lemma usable both
+for untyped and typed/encoded fold reasoning. -/
+lemma Prog.fold_eval {env : List Data} {body init list : Prog}
+    {da : Data} {dl : List Data} {result : Data}
+    (hi : init.eval env = .some da)
+    (hl : list.eval env = .some (Data.l dl))
+    (acc : ℕ → Data)
+    (hacc0 : acc 0 = da)
+    (haccN : acc dl.length = result)
+    (hstep : ∀ k (h : k < dl.length),
+      body.eval (env ++ [acc k, dl[k]]) = .some (acc (k+1))) :
+    (Prog.fold body init list).eval env = .some result := by
+  sorry
+
 /-- Example: with the `simp` set above, the `tail` spec on a concrete env is short. -/
 example {env : List Data} {x : Prog} {dx : Data} (hx : x.eval env = .some dx) :
     (Prog.elim x Prog.empty (Prog.var (env.length + 1))).eval env =
@@ -768,6 +784,29 @@ lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
       < (env ++ ext ++ [head, tail]).length := by simp; omega
   grind [PB.var_computes_at hlen]
 
+/-- `fold` at a fixed env: lifts `Prog.fold_eval` pointwise. The body hypothesis
+is packaged as `PB.computes_at_body₂` parameterised over the current
+accumulator `acc` and element `el`. -/
+lemma PB.fold_computes_at {env : List Data} {init list : PB}
+    {body : PB → PB → PB}
+    {da : Data} {dl : List Data} {f : Data → Data → Data}
+    (hi : PB.computes_at env init da)
+    (hl : PB.computes_at env list (Data.l dl))
+    (hbody : ∀ acc el, PB.computes_at_body₂ env acc el body (f acc el)) :
+    PB.computes_at env (PB.fold body init list) (dl.foldl f da) := by
+  intro ext
+  simp only [PB.fold]
+  refine Prog.fold_eval (hi ext) (hl ext)
+    (fun k => (dl.take k).foldl f da) rfl (by simp) ?_
+  intro k hk
+  have h := (hbody ((dl.take k).foldl f da) dl[k] ext).here
+  have hfoldl_succ :
+      (dl.take (k+1)).foldl f da = f ((dl.take k).foldl f da) dl[k] := by
+    rw [List.take_succ, List.foldl_append]
+    simp [List.getElem?_eq_getElem hk]
+  simp only [hfoldl_succ]
+  simpa [PB.atSlot, List.append_assoc] using h
+
 /-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
 lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
     (hx : PB.computes_at env x dx) :
@@ -945,6 +984,36 @@ lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
   apply PB.elim_cons_computes_at hx
   intro ext
   simpa [List.append_assoc] using (h_some ext).extend
+
+/-- Encoded variant of `PB.fold_computes_at`: typed accumulator `a : α`, typed
+list elements of type `β`, and a typed step function `f : α → β → α`. The body
+hypothesis is `PB.computes_at_body₂_encoded` parameterised over `acc : α` and
+`el : β`. -/
+lemma PB.fold_computes_at_encoded
+    {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {init list : PB} {body : PB → PB → PB}
+    {a : α} {l : List β} {f : α → β → α}
+    (hi : init.computes_at_encoded env a)
+    (hl : list.computes_at_encoded env l)
+    (hbody : ∀ acc el, PB.computes_at_body₂_encoded env acc el body (f acc el)) :
+    PB.computes_at_encoded env (PB.fold body init list) (l.foldl f a) := by
+  intro ext
+  simp only [PB.fold]
+  have hl' :
+      (list (env.length + ext.length)).eval (env ++ ext)
+        = .some (Data.l (l.map DataEncode.encode)) := hl ext
+  refine Prog.fold_eval (hi ext) hl'
+    (fun k => DataEncode.encode ((l.take k).foldl f a)) rfl (by simp) ?_
+  intro k hk
+  have hk' : k < l.length := by simpa using hk
+  have h := (hbody ((l.take k).foldl f a) l[k] ext).here
+  have hfoldl_succ :
+      (l.take (k+1)).foldl f a = f ((l.take k).foldl f a) l[k] := by
+    rw [List.take_succ, List.foldl_append]
+    simp [List.getElem?_eq_getElem hk']
+  have hget : (l.map DataEncode.encode)[k] = DataEncode.encode l[k] := by simp
+  simp only [hget, hfoldl_succ]
+  simpa [PB.atSlot, List.append_assoc] using h
 -------------------------------------------------------------------
 ---------------- Universal Turing Machine (simulation of a SingleTapeTM)
 ---------------------------------------------------------------------------
@@ -1186,9 +1255,9 @@ instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
 def eval_fun_graph (graph : PB) (arg : PB) : PB :=
   PB.fold
     (fun acc x =>
-      PB.ifEq acc .empty
+      PB.optionElim acc
         (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
-        acc)
+        fun _ => acc)
     PB.empty graph
 
 

From 3bede55bf92d7888b9351cba8db68e1fac2c10da Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 17:38:02 +0200
Subject: [PATCH 067/106] eval graph

---
 .../Machines/RoseTreeMachine/V2.lean          | 61 +++++++++++++++++++
 1 file changed, 61 insertions(+)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 9153b20360..6fad7ec143 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -1260,6 +1260,67 @@ def eval_fun_graph (graph : PB) (arg : PB) : PB :=
         fun _ => acc)
     PB.empty graph
 
+/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of
+`(α × β)`-pairs) and an encoded argument `a : α`, returns
+`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)`
+in the graph, else `none`. -/
+lemma eval_fun_graph_computes
+    {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α]
+    {env : List Data} {p_graph p_arg : PB}
+    {graph : List (α × β)} {a : α}
+    (h_graph : p_graph.computes_at_encoded env graph)
+    (h_arg : p_arg.computes_at_encoded env a) :
+    (eval_fun_graph p_graph p_arg).computes_at_encoded env
+      ((graph.find? (fun p => p.1 = a)).map (·.2)) := by
+  -- The Lean-level step function for the fold.
+  let step : Option β → α × β → Option β :=
+    fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc)
+  -- Once the accumulator is `some _`, it stays `some _`.
+  have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by
+    intro l b
+    induction l with
+    | nil => simp
+    | cons hd tl ih => simp [step, ih]
+  -- `foldl step none` matches `find?`-then-`map snd`.
+  have key : ∀ l : List (α × β),
+      l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by
+    intro l
+    induction l with
+    | nil => simp
+    | cons hd tl ih =>
+      simp only [List.foldl_cons, List.find?_cons]
+      by_cases h : hd.1 = a
+      · simp [step, h, stays]
+      · simp [step, h, ih]
+  rw [show (graph.find? (fun p => p.1 = a)).map (·.2)
+        = graph.foldl step none from (key graph).symm]
+  unfold eval_fun_graph
+  refine PB.fold_computes_at_encoded (a := (none : Option β)) (f := step)
+    (by simp [PB.computes_at_encoded, DataEncode.encode]) h_graph ?_
+  intro acc x ext
+  rcases acc with _ | v
+  · -- acc = none: step none x = if x.1 = a then some x.2 else none
+    refine PB.optionElim_computes_none (α := β)
+      PB.elim_cons_head_var_computes_at ?_
+    refine PB.ifEq_computes_at
+      (PB.fst_computes_at_encoded PB.elim_cons_tail_var_computes_at)
+      (by simpa using h_arg.extend) ?_ ?_
+    · intro h_enc
+      have h_eq : x.1 = a := DataEncode.h_inj h_enc
+      change PB.computes_at_encoded _ _ (step none x)
+      simp only [step, Option.elim_none, if_pos h_eq]
+      exact PB.some_computes_at_encoded
+        (PB.snd_computes_at_encoded PB.elim_cons_tail_var_computes_at)
+    · intro h_enc
+      have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h])
+      simp [DataEncode.encode, step, h_ne]
+  · -- acc = some v: step (some v) x = some v
+    refine PB.optionElim_computes_some (α := β)
+      (PB.elim_cons_head_var_computes_at
+        (head := DataEncode.encode (some v : Option β))) ?_
+    intro ext'
+    simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes_at.extend
+
 
 def cfg_state (cfg : PB) : PB := cfg.fst
 def cfg_bitape (cfg : PB) : PB := cfg.snd

From c6af97179aa5572fb11c11f6249aa51ce4dfd5b2 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 22:48:43 +0200
Subject: [PATCH 068/106] while

---
 .../Machines/RoseTreeMachine/V2.lean          | 448 ++++++++++++++++--
 1 file changed, 418 insertions(+), 30 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 6fad7ec143..45473b6485 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -162,8 +162,9 @@ inductive Prog where
   /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
       list; `body` runs once per element with `env` extended by `[acc, x]`. -/
   | fold (body : Prog) (init list : Prog)
-  /-- `while_ body`: body runs with `env` extended by the current accumulator. -/
-  | while_ (body : Prog)
+  /-- `while_ init body`: `init` produces the starting accumulator; `body` runs with
+      `env` extended by the current accumulator. -/
+  | while_ (init body : Prog)
 deriving Repr
 
 /-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
@@ -202,23 +203,21 @@ def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
         let (acc', b_t, b_s) ← body.meteredEval (env ++ [acc, el])
         return (acc', 1 + t + b_t, max s b_s))
       (i, 1 + i_t + l_t, max i_s l_s)
-  | .while_ body =>
-    -- `body` is evaluated repeatedly with `env` extended by the current accumulator.
-    -- The result of `body` is expected to be a cons whose head is the "continue?" flag
-    -- (truthy = nonempty) and whose tail is the next accumulator.
-    -- The initial accumulator is `Data.empty`.
+  | .while_ init body => do
+    let (i, i_t, i_s) ← init.meteredEval env
+    -- Real while loop: check the halt condition on the current accumulator first.
+    -- If `acc.asList.headD = []` (empty head), halt and return `acc`.
+    -- Otherwise run `body` on the accumulator and loop with its result.
     let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
             (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
       fun rec d_ts =>
         let (acc, t, s) := d_ts
-        (body.meteredEval (env ++ [acc])).bind fun (r, b_t, b_s) =>
-          let t' := t + 1 + b_t
-          let s' := max s b_s
-          if r.asList.headD (Data.l []) != Data.l [] then
-            rec (r, t', s')
-          else
-            .some (r, t', s')
-    Part.fix F (Data.empty, 1, 1)
+        if acc.asList.headD (Data.l []) = Data.l [] then
+          .some (acc, t, s)
+        else
+          (body.meteredEval (env ++ [acc])).bind fun (r, b_t, b_s) =>
+            rec (r, t + 1 + b_t, max s b_s)
+    Part.fix F (i, 1 + i_t, max 1 i_s)
   termination_by (sizeOf p, 0)
 
 ------------------------------------
@@ -264,6 +263,36 @@ lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
       | head :: tail => cs.eval (env ++ [head, Data.l tail]) := by
   sorry
 
+/-- The loop core of `while_`: starting from accumulator `acc` (a `Data`),
+halt and return `acc` if its `asList.headD` is empty; otherwise run `body` on
+`env ++ [acc]` and recurse on the result. -/
+noncomputable def Prog.whileFrom_eval (body : Prog) (env : List Data) : Data → Part Data :=
+  Part.fix fun rec acc =>
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      Part.some acc
+    else
+      (body.eval (env ++ [acc])).bind rec
+
+/-- Halt-step unrolling for `whileFrom_eval`. -/
+lemma Prog.whileFrom_eval_halt {body : Prog} {env : List Data} {acc : Data}
+    (h_halt : acc.asList.headD (Data.l []) = Data.l []) :
+    Prog.whileFrom_eval body env acc = .some acc := by
+  sorry
+
+/-- Body-step unrolling for `whileFrom_eval`. -/
+lemma Prog.whileFrom_eval_step {body : Prog} {env : List Data} {acc : Data}
+    (h_step : acc.asList.headD (Data.l []) ≠ Data.l []) :
+    Prog.whileFrom_eval body env acc =
+      (body.eval (env ++ [acc])).bind (Prog.whileFrom_eval body env) := by
+  sorry
+
+/-- Pointwise (single-env) version for `while_`: the program evaluates `init`,
+then runs the loop body starting from that value. -/
+lemma Prog.while_eval {init body : Prog} {env : List Data} :
+    (Prog.while_ init body).eval env =
+      (init.eval env).bind (Prog.whileFrom_eval body env) := by
+  sorry
+
 def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
 
 @[simp]
@@ -276,7 +305,7 @@ def Prog.WhileFree (p : Prog) : Prop :=
   | .elim v em cs => Prog.WhileFree v ∧ Prog.WhileFree em ∧ Prog.WhileFree cs
   | .eq a b => Prog.WhileFree a ∧ Prog.WhileFree b
   | .fold body init list => Prog.WhileFree body ∧ Prog.WhileFree init ∧ Prog.WhileFree list
-  | .while_ _ => False
+  | .while_ _ _ => False
 
 theorem total_of_whileFree (p : Prog) (h_wf : p.WhileFree) : p.Total := by sorry
 
@@ -315,9 +344,9 @@ threading accumulator `acc`. -/
 def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
   .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
 
-/-- `while_ (fun acc => body)`. -/
-def while_ (body : PB → PB) : PB := fun n =>
-  .while_ (body (fun _ => .var n) (n + 1))
+/-- `while_ init (fun acc => body)`. -/
+def while_ (init : PB) (body : PB → PB) : PB := fun n =>
+  .while_ (init n) (body (fun _ => .var n) (n + 1))
 
 /-- Close a builder into a concrete `Prog`. -/
 def build (p : PB) : Prog := p 0
@@ -807,6 +836,72 @@ lemma PB.fold_computes_at {env : List Data} {init list : PB}
   simp only [hfoldl_succ]
   simpa [PB.atSlot, List.append_assoc] using h
 
+/-! ### Spec for `PB.while_`
+
+`PB.while_ init body` is a real while loop: it starts from `init`, checks the
+halt condition (`asList.headD = []`) on the current accumulator, and either
+returns it (halt) or runs `body` and loops with the body's result. -/
+
+/-- Generic iteration spec for `PB.while_`. The result is `f^[N] init` where
+`N` is the smallest iteration index whose encoding's `headD` is empty. -/
+lemma PB.while_computes_iter {α : Type} [DataEncode α]
+    {env : List Data} {p_init : PB} {body : PB → PB}
+    (f : α → α) (init : α)
+    (h_init : PB.computes_at env p_init (DataEncode.encode init))
+    (h_body : ∀ c, PB.computes_at_body₁ env (DataEncode.encode c) body
+        (DataEncode.encode (f c)))
+    (h_halts : ∃ n, (DataEncode.encode (f^[n] init)).asList.headD (Data.l []) = Data.l []) :
+    PB.computes_at env (PB.while_ p_init body) (DataEncode.encode (f^[Nat.find h_halts] init)) := by
+  intro ext
+  set n := env.length + ext.length with hn
+  set bd : Prog := body (fun _ => .var n) (n + 1) with bd_def
+  -- Unfold one level of `while_` at depth `n`.
+  change (Prog.while_ (p_init n) bd).eval (env ++ ext) = _
+  rw [Prog.while_eval]
+  rw [show (p_init n).eval (env ++ ext) = .some (DataEncode.encode init) by
+        simpa [hn] using h_init ext, Part.bind_some]
+  -- Reduce to a statement about `whileFrom_eval`.
+  set N := Nat.find h_halts with N_def
+  suffices ∀ k, k ≤ N →
+      Prog.whileFrom_eval bd (env ++ ext) (DataEncode.encode (f^[k] init))
+        = .some (DataEncode.encode (f^[N] init)) from this 0 (Nat.zero_le _)
+  intro k hk
+  -- Induct on the distance to `N`.
+  induction hd : N - k generalizing k with
+  | zero =>
+    have hkN : k = N := by omega
+    subst hkN
+    exact Prog.whileFrom_eval_halt (Nat.find_spec h_halts)
+  | succ m ih =>
+    have hkN : k < N := by omega
+    have h_not_halt :
+        (DataEncode.encode (f^[k] init)).asList.headD (Data.l []) ≠ Data.l [] :=
+      Nat.find_min h_halts hkN
+    rw [Prog.whileFrom_eval_step h_not_halt]
+    -- The body computes `f` at `f^[k] init`.
+    have h_body_eval : bd.eval ((env ++ ext) ++ [DataEncode.encode (f^[k] init)]) =
+        .some (DataEncode.encode (f (f^[k] init))) := by
+      have h := (h_body (f^[k] init) ext).here
+      simpa [bd_def, hn, PB.atSlot] using h
+    rw [h_body_eval, Part.bind_some]
+    rw [show f (f^[k] init) = f^[k+1] init from (Function.iterate_succ_apply' f k init).symm]
+    exact ih (k + 1) (by omega) (by omega)
+
+
+/-- `letIn` at a fixed env: the body hypothesis is packaged as `PB.computes_at_body₁`. -/
+lemma PB.letIn_computes_at {env : List Data} {val : PB} {body : PB → PB}
+    {dv dr : Data}
+    (hv : PB.computes_at env val dv)
+    (hbody : PB.computes_at_body₁ env dv body dr) :
+    PB.computes_at env (PB.letIn val body) dr := by
+  intro ext
+  show (Prog.letin (val (env.length + ext.length))
+      (body (fun _ => Prog.var (env.length + ext.length))
+        (env.length + ext.length + 1))).eval (env ++ ext) = .some dr
+  rw [Prog.letin_eval (hv ext)]
+  have h := (hbody ext).here
+  simpa [PB.atSlot] using h
+
 /-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
 lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
     (hx : PB.computes_at env x dx) :
@@ -985,6 +1080,13 @@ lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
   intro ext
   simpa [List.append_assoc] using (h_some ext).extend
 
+lemma PB.letIn_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {val : PB} {body : PB → PB} {v : α} {b : β}
+    (hv : val.computes_at_encoded env v)
+    (hbody : PB.computes_at_body₁_encoded env v body b) :
+    (PB.letIn val body).computes_at_encoded env b :=
+  PB.letIn_computes_at hv hbody
+
 /-- Encoded variant of `PB.fold_computes_at`: typed accumulator `a : α`, typed
 list elements of type `β`, and a typed step function `f : α → β → α`. The body
 hypothesis is `PB.computes_at_body₂_encoded` parameterised over `acc : α` and
@@ -1321,16 +1423,75 @@ lemma eval_fun_graph_computes
     intro ext'
     simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes_at.extend
 
+-- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) :=
+--   Fintype.elems.toList.map (fun a => (a, f a))
+
+lemma eval_fun_graph_computes_of_fun
+    {α β : Type} [DataEncode α] [DataEncode β] [Fintype α]
+    {env : List Data} {p_graph p_arg : PB}
+    {a : α}
+    {f : α → β}
+    (h_graph : p_graph.computes_at_encoded env (Fintype.elems.toList.map (fun a => (a, f a))))
+    (h_arg : p_arg.computes_at_encoded env a) :
+    (eval_fun_graph p_graph p_arg).head.computes_at_encoded env (f a) := by
+  classical
+  have heq : ∀ (L : List α), a ∈ L →
+      ((L.map (fun a' => (a', f a'))).find?
+        (fun p => p.1 = a)).map (·.2) = some (f a) := by
+    intro L hmem
+    induction L with
+    | nil => exact absurd hmem (by simp)
+    | cons hd tl ih => grind
+  have h := eval_fun_graph_computes h_graph h_arg
+  rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h
+  simpa [DataEncode.encode, Data.asList] using PB.head_computes_at h
 
 def cfg_state (cfg : PB) : PB := cfg.fst
 def cfg_bitape (cfg : PB) : PB := cfg.snd
 
+lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_at_encoded env cfg) :
+    (cfg_state p).computes_at_encoded env cfg.state :=
+  PB.fst_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
+
+lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_at_encoded env cfg) :
+    (cfg_bitape p).computes_at_encoded env cfg.BiTape :=
+  PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
+
 /-- Evaluate the transition function. Returns `((wr, dir), q')`.
  -- The return value is not wrapped inside an `Option` because the transition
  -- function is assumed to be total. -/
 def eval_tr (tr : PB) (q c : PB) : PB :=
   (eval_fun_graph (eval_fun_graph tr q).head c).head
 
+instance : DataEncode (SingleTapeTM.Stmt Symbol) where
+  encode stmt := DataEncode.encode (stmt.symbol, stmt.movement)
+  h_inj := by sorry
+
+lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State]
+    [DecidableEq State] [Fintype Symbol]
+    {env : List Data} {p_tr p_q p_c : PB}
+    {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State}
+    {q : State}
+    {c : Option Symbol}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset State).toList.map (fun q' : State =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' : Option Symbol => (c', tr q' c'))))))
+    (h_q : p_q.computes_at_encoded env q)
+    (h_c : p_c.computes_at_encoded env c) :
+    (eval_tr p_tr p_q p_c).computes_at_encoded env (tr q c) := by
+  unfold eval_tr
+  exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q)
+    (eval_fun_graph_computes_of_fun (α := State) (f := fun q' =>
+      (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c')))
+      h_tr h_q) h_c
+
 -- /-- The step function corresponding to a `SingleTapeTM`. -/
 -- @[simp]
 -- def step : tm.Cfg → Option tm.Cfg
@@ -1347,26 +1508,253 @@ def eval_tr (tr : PB) (q c : PB) : PB :=
 -- Compute the step function given a transition function (as its graph) and a configuration.
 -- Returns `Option Cfg`
 def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
-  PB.elim (cfg_state cfg)
+  PB.optionElim (cfg_state cfg)
     PB.empty
-    (fun q' _ => PB.letIn (cfg_bitape cfg) (fun tape =>
+    (fun q' => PB.letIn (cfg_bitape cfg) (fun tape =>
       PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
         .some (to_pair
           tr_val.snd
           (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
 
+lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_at_encoded env cfg) :
+    (singleTapeTM_step p_tr p_cfg).computes_at_encoded env (tm.step cfg) := by
+  unfold singleTapeTM_step
+  obtain ⟨state, t⟩ := cfg
+  match hst : state with
+  | none =>
+    refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_
+    change PB.empty.computes_at_encoded env (none : Option tm.Cfg)
+    simp [PB.computes_at_encoded, DataEncode.encode]
+  | some q' =>
+    refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_
+    intro ext1
+    -- TODO letin makes this proof complicated.
+    -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`.
+    apply PB.letIn_computes_at_encoded (v := t)
+      (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend)
+    intro ext2
+    set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def
+    -- The slot for `q'` at depth `env.length + ext1.length`.
+    have h_q'_slot : PB.computes_at_encoded
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env.length + ext1.length)) q' := by
+      simpa [env2_def] using PB.atSlot_last_computes_at_encoded.extend
+    -- The slot for `tape` at depth `env2.length + ext2.length`.
+    have h_tape_slot : PB.computes_at_encoded
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env2.length + ext2.length)) t :=
+      PB.atSlot_last_computes_at_encoded
+    apply PB.letIn_computes_at_encoded
+      (eval_tr_computes
+        (by simpa [env2_def, List.append_assoc] using h_tr.extend)
+        h_q'_slot (bitape_head_computes h_tape_slot))
+    intro ext3
+    set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def
+    set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def
+    -- Re-derive tape slot at envS.
+    have h_tape_slot' : PB.computes_at_encoded envS
+        (PB.atSlot (env2.length + ext2.length)) t := by
+      simpa [envS_def, env3_def, List.append_assoc] using
+        h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)])
+    -- Destructure the transition result.
+    rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩
+    have h_trval : PB.computes_at_encoded envS
+        (PB.atSlot (env3.length + ext3.length))
+        (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by
+      simp [envS_def, htr_eq]
+    unfold SingleTapeTM.step
+    simp only [htr_eq]
+    exact PB.some_computes_at_encoded
+      (to_pair_computes
+        (PB.snd_computes_at_encoded h_trval)
+        (bitape_optionMove_computes
+          (bitape_write_computes h_tape_slot'
+            (PB.fst_computes_at_encoded (a := (wr, dir))
+              (PB.fst_computes_at_encoded h_trval)))
+          (PB.snd_computes_at_encoded (a := (wr, dir))
+            (PB.fst_computes_at_encoded h_trval))))
+
 def tm_main_loop (tr : PB) (cfg : PB) : PB :=
-  -- Note that `Cfg` is a pair of `Option State` and `BiTape`,
-  -- and the termination condition is that the first element of this pair is none.
-  -- This exactly matches our while loop termination condition.
-  PB.while_ (fun acc => PB.elim acc
-    -- accumulator is empty, initialize
-    cfg
-    -- accumulator is non-empty, run a single step. Ignore that the result is an option
-    (fun _ _ => (singleTapeTM_step tr acc).head))
+  -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step`
+  -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep
+  -- the current `acc` (which has `state = none`, signalling halt to `while_`).
+  PB.while_ cfg
+    (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
+
+/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
+`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
+state), the loop computes the configuration obtained after the *minimal* such
+number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
+halt result `none` as a fixed point via `Option.getD`. -/
+lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_at_encoded env cfg)
+    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
+    (tm_main_loop p_tr p_cfg).computes_at_encoded env
+      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
+  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
+  have headD_iff : ∀ c : tm.Cfg,
+      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+  -- Translate the halting hypothesis through the iff.
+  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
+    h_halts.imp fun _ h => (headD_iff _).mpr h
+  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
+    le_antisymm
+      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
+      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
+  -- Reduce to a `while_` spec call.
+  change PB.computes_at env (tm_main_loop p_tr p_cfg)
+    (DataEncode.encode (step^[Nat.find h_halts] cfg))
+  rw [← find_eq]
+  unfold tm_main_loop
+  refine PB.while_computes_iter (env := env) (p_init := p_cfg)
+    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+    step cfg h_cfg ?_ h_halts'
+  -- Body computes `step` at every typed accumulator (∀ ext).
+  intro c ext
+  set E := env ++ ext with E_def
+  have hE_len : E.length = env.length + ext.length := by simp [E_def]
+  have h_acc : PB.computes_at_encoded (E ++ [DataEncode.encode c])
+      (PB.atSlot E.length) c := by
+    simpa using PB.atSlot_last_computes_at_encoded (env := E) (ext := []) (a := c)
+  have h_step_eval :
+      (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_at_encoded
+        (E ++ [DataEncode.encode c]) (tm.step c) := by
+    have h_tr_ext : PB.computes_at_encoded (E ++ [DataEncode.encode c]) p_tr
+        ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))) := by
+      have := h_tr.extend (ext := ext ++ [DataEncode.encode c])
+      simpa [E_def, List.append_assoc] using this
+    exact singleTapeTM_step_computes h_tr_ext h_acc
+  -- Show the body computes `step c` at slot `E.length = env.length + ext.length`.
+  change PB.computes_at (E ++ [DataEncode.encode c])
+    (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length)))
+      (PB.atSlot (env.length + ext.length))
+      (fun next => next)) (DataEncode.encode (step c))
+  rw [← hE_len]
+  cases hstep_c : tm.step c with
+  | none =>
+    rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl]
+    exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc
+  | some next =>
+    rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl]
+    refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_
+    intro ext'
+    simpa using PB.atSlot_last_computes_at_encoded
+      (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next)
+
+def reverse (x : PB) : PB :=
+  PB.fold (fun acc el => PB.cons el acc) PB.empty x
+
+lemma reverse_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_at_encoded env l) :
+    (reverse p).computes_at_encoded env l.reverse := by
+  unfold reverse
+  have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp
+  rw [h_fold]
+  apply PB.fold_computes_at_encoded (by simp [PB.computes_at_encoded]) h
+  -- TODO at this point, we should actually be able to just apply a combinator on the semantics
+  -- of PB.cons
+  intro acc el ext
+  have h_el : PB.computes_at
+      (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+      (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by
+    simpa using (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
+  simpa [DataEncode.encode, Data.asList] using
+    PB.cons_computes_at h_el (by simpa using PB.atSlot_last_computes_at.extend)
+
+def list_map (x : PB) (f : PB → PB) : PB :=
+  reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x)
+
+lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p : PB} {l : List α}
+    {f : PB → PB} {g : α → β}
+    (h : p.computes_at_encoded env l)
+    (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) :
+    (list_map p f).computes_at_encoded env (l.map g) := by
+  unfold list_map
+  -- TODO simplify proof
+  have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_at_encoded
+      env (l.foldl (fun acc el => g el :: acc) []) := by
+    apply PB.fold_computes_at_encoded (a := ([] : List β)) (f := fun acc el => g el :: acc)
+      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
+    intro acc el ext
+    have h_acc : PB.computes_at
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+        (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+      simpa using (PB.atSlot_last_computes_at (env := env) (ext := ext)
+        (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by
+      simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc])
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_fel h_acc
+  have h_rev := reverse_computes h_fold
+  have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by
+    rw [show l.foldl (fun acc el => g el :: acc) []
+          = (l.map g).foldl (fun acc el => el :: acc) [] from
+        (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm]
+    simp
+  rwa [h_eq] at h_rev
+
+def list_head_option (input : PB) : PB :=
+  PB.elim input PB.empty (fun hd _tl => PB.some hd)
+
+lemma list_head_option_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_at_encoded env l) :
+    (list_head_option p).computes_at_encoded env l.head? := by
+  cases l with
+  | nil =>
+    apply PB.elim_nil_computes_at (em := PB.empty)
+    · simpa [DataEncode.encode] using h
+    · simp [DataEncode.encode]
+  | cons hd tl =>
+    apply PB.elim_cons_computes_at (head := DataEncode.encode hd)
+      (tail := tl.map DataEncode.encode)
+    · simpa [DataEncode.encode] using h
+    · intro ext
+      simpa [DataEncode.encode] using
+        PB.cons_computes_at PB.elim_cons_head_var_computes_at PB.empty_computes_at
 
 def string_to_tape (input : PB) : PB :=
-  to_pair input.head (to_pair .empty input.tail)
+  to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some))
+
+lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_at_encoded env input) :
+    (string_to_tape p_input).computes_at_encoded env (BiTape.mk₁ input) := by
+  have h_tail : (PB.tail p_input).computes_at_encoded env input.tail := by
+    simpa [PB.computes_at_encoded, DataEncode.encode] using PB.tail_computes_at h_input
+  have h_map : (list_map (PB.tail p_input) PB.some).computes_at_encoded env
+      (StackTape.map_some input.tail : Turing.StackTape Symbol) := by
+    simpa [PB.computes_at_encoded, DataEncode.encode]
+      using list_map_computes h_tail (fun _ _ => by
+        simpa [DataEncode.encode] using
+          PB.cons_computes_at PB.atSlot_last_computes_at PB.empty_computes_at)
+  have h_empty : (PB.empty : PB).computes_at_encoded env (∅ : Turing.StackTape Symbol) := by
+    simp [PB.computes_at_encoded, DataEncode.encode]
+  simpa [PB.computes_at_encoded, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape]
+    using to_pair_computes (list_head_option_computes h_input)
+      (to_pair_computes h_empty h_map)
+
 
 def initial_config (q₀ : PB) (input : PB) : PB :=
   to_pair (PB.some q₀) (string_to_tape input)

From a69341315d159faaa0e72e02ec1e4987105436e1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 22 May 2026 23:13:39 +0200
Subject: [PATCH 069/106] simulation

---
 .../Machines/RoseTreeMachine/V2.lean          | 201 +++++++++++++++++-
 1 file changed, 198 insertions(+), 3 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 45473b6485..2225d5e1a7 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -12,6 +12,7 @@ public import Std
 
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Mathlib.Data.Nat.Bits
+public import Mathlib.Data.List.ReduceOption
 
 /-!
 -- This is a proposal to define a machine model and related time and space measure
@@ -1715,6 +1716,87 @@ lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β]
     simp
   rwa [h_eq] at h_rev
 
+/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/
+def list_reduceOption (x : PB) : PB :=
+  reverse (PB.fold
+    (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc))
+    PB.empty x)
+
+lemma list_reduceOption_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List (Option α)}
+    (h : p.computes_at_encoded env l) :
+    (list_reduceOption p).computes_at_encoded env l.reduceOption := by
+  unfold list_reduceOption
+  set step : List α → Option α → List α :=
+    fun acc el => match el with | none => acc | some y => y :: acc with step_def
+  -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need
+  -- this generalized over the initial accumulator so the induction goes through.
+  have h_eq : ∀ (xs : List (Option α)) (init : List α),
+      (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by
+    intro xs
+    induction xs with
+    | nil => intro init; simp [List.reduceOption]
+    | cons hd tl ih =>
+      intro init
+      cases hd with
+      | none => simpa [step_def] using ih init
+      | some y =>
+        have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by
+          simp [step_def]
+        rw [h1, ih (y :: init)]
+        simp [List.reduceOption]
+  have h_fold : (PB.fold
+        (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p
+      ).computes_at_encoded env (l.foldl step []) := by
+    apply PB.fold_computes_at_encoded
+      (a := ([] : List α)) (f := step)
+      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
+    intro acc el ext
+    have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by
+      simpa [PB.computes_at_encoded] using
+        (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
+    have h_acc : (PB.atSlot (env.length + ext.length)).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by
+      simpa [PB.computes_at_encoded] using
+        (PB.atSlot_last_computes_at (env := env) (ext := ext)
+          (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    cases el with
+    | none =>
+      simpa [step_def] using
+        PB.optionElim_computes_none (α := α) h_el h_acc
+    | some y =>
+      refine PB.optionElim_computes_some (α := α) h_el ?_
+      intro ext'
+      -- Inside someCase, the bound `y` lives at slot
+      -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`.
+      set ext_inner :=
+        ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def
+      have hlen : ext_inner.length = ext.length + 2 + ext'.length := by
+        simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm]
+      have h_y :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length + 2 + ext'.length))
+            (DataEncode.encode y) := by
+        have h := PB.atSlot_last_computes_at
+          (env := env) (ext := ext_inner) (d := DataEncode.encode y)
+        rw [hlen] at h
+        convert h using 2
+        omega
+      have h_acc' :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+        have h := (h_acc :
+          PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)])
+            _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y])
+        simpa [ext_inner_def, List.append_assoc] using h
+      have h_cons := PB.cons_computes_at h_y h_acc'
+      simp only [ext_inner_def] at h_cons
+      simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons
+  have h_rev := reverse_computes h_fold
+  have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l []
+  rwa [h_eq₀] at h_rev
+
 def list_head_option (input : PB) : PB :=
   PB.elim input PB.empty (fun hd _tl => PB.some hd)
 
@@ -1759,15 +1841,128 @@ lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Sym
 def initial_config (q₀ : PB) (input : PB) : PB :=
   to_pair (PB.some q₀) (string_to_tape input)
 
-/-- Turn the final config to an output, by taking the head and the right part of the tape. -/
-def final_config_to_output (cfg : PB) : PB := PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd)
+/-- Turn the final config to an output, by taking the head and the right part of the tape
+    and discarding the blank (`none`) cells. -/
+def final_config_to_output (cfg : PB) : PB :=
+  list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))
 
 /-- Implements a universal Single-Tape TM, assuming that the input contains the following:
 ((initialState, transitionFunction), input).
 If it terminates, the output is the tape contents under the head and to its right. -/
 def universal_tm (input : PB) :=
   final_config_to_output
-    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.fst.snd))
+    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd))
+
+lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_q₀ p_input : PB} {input : List Symbol}
+    (h_q₀ : p_q₀.computes_at_encoded env tm.q₀)
+    (h_input : p_input.computes_at_encoded env input) :
+    (initial_config p_q₀ p_input).computes_at_encoded env (tm.initCfg input) := by
+  -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes
+  -- through the `(state, BiTape)` pair, so this matches `to_pair`.
+  exact to_pair_computes (PB.some_computes_at_encoded h_q₀) (string_to_tape_computes h_input)
+
+lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_cfg : PB} {cfg : tm.Cfg}
+    (h_cfg : p_cfg.computes_at_encoded env cfg) :
+    (final_config_to_output p_cfg).computes_at_encoded env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by
+  unfold final_config_to_output
+  have h_BiTape : (p_cfg.snd).computes_at_encoded env cfg.BiTape :=
+    PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h_cfg
+  have h_head := bitape_head_computes h_BiTape
+  have h_right := bitape_right_computes h_BiTape
+  -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`),
+  -- then `list_reduceOption` discards the blanks.
+  have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_at_encoded env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList) := by
+    change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList))
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_head h_right
+  exact list_reduceOption_computes h_list
+
+lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       input))
+    (h_halts : ∃ n,
+        ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) :
+    (universal_tm p_input).computes_at_encoded env
+      (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input)
+       (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by
+  unfold universal_tm
+  have h_fst := PB.fst_computes_at_encoded h_input
+  have h_q₀ := PB.fst_computes_at_encoded h_fst
+  have h_tr := PB.snd_computes_at_encoded h_fst
+  have h_inp := PB.snd_computes_at_encoded h_input
+  exact final_config_to_output_computes
+    (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts)
+
+/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding
+blanks) recovers `l`. -/
+private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) :
+    ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by
+  have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by
+    induction xs with
+    | nil => rfl
+    | cons _ _ ih => simp [ih]
+  cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h]
+
+/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`,
+then the universal Turing machine `universal_tm`, when given an encoding of `tm`
+together with `w`, computes `w'`.
+
+The encoded input has the shape `((tm.q₀, transitionTable), w)`, where
+`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/
+theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : tm.Outputs w w') :
+    (universal_tm p_input).computes_at_encoded env w' := by
+  -- Lift `tm.step` to a total step function; halting states are fixed points.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  -- Convert `ReflTransGen` into an explicit step count via tail-induction.
+  obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by
+    induction h_out with
+    | refl => exact ⟨0, rfl⟩
+    | tail _ h' ih =>
+      obtain ⟨n, hn⟩ := ih
+      refine ⟨n + 1, ?_⟩
+      rw [Function.iterate_succ_apply', hn]
+      show (tm.step _).getD _ = _
+      rw [show tm.step _ = some _ from h']; rfl
+  -- The halting hypothesis required by `universal_tm_computes`.
+  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]⟩
+  -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`.
+  have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn])
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.add_sub_cancel' h_le, hn] at h_iter
+    exact h_iter.symm
+  -- Conclude via `universal_tm_computes`.
+  have h := universal_tm_computes (tm := tm) h_input h_halts
+  rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+    tm.haltCfg w' from h_find] at h
+  simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h
 
 end RoseTreeMachine
 

From 3afe06114964c9a4759ae881deaf667a65de0923 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 23 May 2026 00:00:48 +0200
Subject: [PATCH 070/106] equivalence

---
 .../Machines/RoseTreeMachine/V2.lean          | 330 +++++++++++++++---
 1 file changed, 290 insertions(+), 40 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index 2225d5e1a7..bc005f530d 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -294,6 +294,21 @@ lemma Prog.while_eval {init body : Prog} {env : List Data} :
       (init.eval env).bind (Prog.whileFrom_eval body env) := by
   sorry
 
+/-- Termination-extraction for `whileFrom_eval`: if the loop returns `.some r`,
+then there exists an iteration index `n` such that running the body `n` times
+from `acc` along the (deterministic) trajectory yields `r`, the halt condition
+holds at `r`, and the halt condition does not hold at any intermediate value. -/
+lemma Prog.whileFrom_eval_some {body : Prog} {env : List Data} {acc r : Data}
+    (h : Prog.whileFrom_eval body env acc = .some r) :
+    ∃ (n : ℕ) (traj : ℕ → Data),
+      traj 0 = acc ∧
+      traj n = r ∧
+      (r.asList.headD (Data.l []) = Data.l []) ∧
+      (∀ k < n,
+          (traj k).asList.headD (Data.l []) ≠ Data.l [] ∧
+          body.eval (env ++ [traj k]) = .some (traj (k+1))) := by
+  sorry
+
 def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
 
 @[simp]
@@ -1590,46 +1605,21 @@ def tm_main_loop (tr : PB) (cfg : PB) : PB :=
   PB.while_ cfg
     (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
 
-/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
-`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
-state), the loop computes the configuration obtained after the *minimal* such
-number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
-halt result `none` as a fixed point via `Option.getD`. -/
-lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
+/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/
+private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol]
     [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
     [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    {env : List Data} {p_tr : PB}
     (h_tr : p_tr.computes_at_encoded env
       ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
         (q', (Fintype.elems : Finset (Option Symbol)).toList.map
           (fun c' => (c', tm.tr q' c'))))))
-    (h_cfg : p_cfg.computes_at_encoded env cfg)
-    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
-    (tm_main_loop p_tr p_cfg).computes_at_encoded env
-      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
-  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
+    (c : tm.Cfg) :
+    PB.computes_at_body₁ env (DataEncode.encode c)
+      (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+      (DataEncode.encode ((tm.step c).getD c)) := by
   set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
-  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
-  have headD_iff : ∀ c : tm.Cfg,
-      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
-    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
-  -- Translate the halting hypothesis through the iff.
-  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
-    h_halts.imp fun _ h => (headD_iff _).mpr h
-  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
-    le_antisymm
-      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
-      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
-  -- Reduce to a `while_` spec call.
-  change PB.computes_at env (tm_main_loop p_tr p_cfg)
-    (DataEncode.encode (step^[Nat.find h_halts] cfg))
-  rw [← find_eq]
-  unfold tm_main_loop
-  refine PB.while_computes_iter (env := env) (p_init := p_cfg)
-    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
-    step cfg h_cfg ?_ h_halts'
-  -- Body computes `step` at every typed accumulator (∀ ext).
-  intro c ext
+  intro ext
   set E := env ++ ext with E_def
   have hE_len : E.length = env.length + ext.length := by simp [E_def]
   have h_acc : PB.computes_at_encoded (E ++ [DataEncode.encode c])
@@ -1645,7 +1635,6 @@ lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
       have := h_tr.extend (ext := ext ++ [DataEncode.encode c])
       simpa [E_def, List.append_assoc] using this
     exact singleTapeTM_step_computes h_tr_ext h_acc
-  -- Show the body computes `step c` at slot `E.length = env.length + ext.length`.
   change PB.computes_at (E ++ [DataEncode.encode c])
     (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length)))
       (PB.atSlot (env.length + ext.length))
@@ -1662,6 +1651,45 @@ lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
     simpa using PB.atSlot_last_computes_at_encoded
       (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next)
 
+/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
+`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
+state), the loop computes the configuration obtained after the *minimal* such
+number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
+halt result `none` as a fixed point via `Option.getD`. -/
+lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_at_encoded env cfg)
+    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
+    (tm_main_loop p_tr p_cfg).computes_at_encoded env
+      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
+  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
+  have headD_iff : ∀ c : tm.Cfg,
+      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+  -- Translate the halting hypothesis through the iff.
+  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
+    h_halts.imp fun _ h => (headD_iff _).mpr h
+  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
+    le_antisymm
+      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
+      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
+  -- Reduce to a `while_` spec call.
+  change PB.computes_at env (tm_main_loop p_tr p_cfg)
+    (DataEncode.encode (step^[Nat.find h_halts] cfg))
+  rw [← find_eq]
+  unfold tm_main_loop
+  exact PB.while_computes_iter (env := env) (p_init := p_cfg)
+    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+    step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts'
+
 def reverse (x : PB) : PB :=
   PB.fold (fun acc el => PB.cons el acc) PB.empty x
 
@@ -1942,21 +1970,25 @@ theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq
     | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
   -- Convert `ReflTransGen` into an explicit step count via tail-induction.
   obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by
-    induction h_out with
+    suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' →
+        ∃ n, step^[n] c = c' from h h_out
+    intro c c' hrel
+    induction hrel with
     | refl => exact ⟨0, rfl⟩
     | tail _ h' ih =>
       obtain ⟨n, hn⟩ := ih
       refine ⟨n + 1, ?_⟩
       rw [Function.iterate_succ_apply', hn]
-      show (tm.step _).getD _ = _
-      rw [show tm.step _ = some _ from h']; rfl
+      change (tm.step _).getD _ = _
+      rw [h']
+      rfl
   -- The halting hypothesis required by `universal_tm_computes`.
-  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]⟩
+  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩
   -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`.
   have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by
-    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn])
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl)
     have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
-    rw [← Function.iterate_add_apply, Nat.add_sub_cancel' h_le, hn] at h_iter
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter
     exact h_iter.symm
   -- Conclude via `universal_tm_computes`.
   have h := universal_tm_computes (tm := tm) h_input h_halts
@@ -1964,6 +1996,224 @@ theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq
     tm.haltCfg w' from h_find] at h
   simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h
 
+/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded
+output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/
+private lemma universal_tm_eval_some_imp_loop_eval_some
+    {p_input : PB} {env : List Data} {d : Data}
+    (h : (universal_tm p_input env.length).eval env = .some d) :
+    ∃ d', (tm_main_loop p_input.fst.snd
+      (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by
+  -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is
+  -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is
+  -- `.some`, the bound subexpression must be `.some` too.
+  set n := env.length with hn
+  set mloop : Prog := tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd) n with mloop_def
+  -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do.
+  have bd_cons : ∀ {a b : Prog} {env d},
+      (Prog.cons a b).eval env = .some d →
+      (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by
+    intro a b env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does.
+  have bd_elim : ∀ {v em cs : Prog} {env d},
+      (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by
+    intro v em cs env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm
+    refine ⟨ah, ?_⟩
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+  -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init`
+  -- and `list` do.
+  have bd_fold : ∀ {body init list : Prog} {env d},
+      (Prog.fold body init list).eval env = .some d →
+      (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by
+    intro body init list env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Now unfold `universal_tm = final_config_to_output (...)`,
+  -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`,
+  -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`.
+  -- At each step we bubble down through the relevant `Prog` constructor.
+  -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost
+  -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through
+  -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s)
+  -- to extract a `some` evaluation for `mloop`.
+  change (final_config_to_output (tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h
+  unfold final_config_to_output list_reduceOption reverse at h
+  -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain)
+  obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h
+  obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1
+  -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2
+  -- where mloop' = tm_main_loop ...
+  change (Prog.cons _ _).eval env = .some d2 at h2
+  obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2
+  -- h3 : bitape_head (...).snd evaluates to some
+  -- bitape_head t = t.fst = head t = elim t empty (fun ...)
+  -- bitape_head (mloop').snd = head (head (tail mloop'))
+  change (Prog.elim _ _ _).eval env = .some d3 at h3
+  obtain ⟨d4, h4⟩ := bd_elim h3
+  -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _).
+  change (Prog.elim _ _ _).eval env = .some d4 at h4
+  obtain ⟨d5, h5⟩ := bd_elim h4
+  -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl).
+  change (Prog.elim _ _ _).eval env = .some d5 at h5
+  obtain ⟨d6, h6⟩ := bd_elim h5
+  -- h6 : mloop' n .eval env = some d6. Done.
+  exact ⟨d6, h6⟩
+
+/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to
+a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`,
+then there exists an iteration index `n` such that the TM is in a halt state and
+the tape contents under the head (with blanks discarded) equal `w'`. -/
+theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : (universal_tm p_input).computes_at_encoded env w') :
+    ∃ n : ℕ,
+      let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+      cfg.state = none ∧
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none
+  · -- Halts: use forward direction to identify the output.
+    refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩
+    have h_fwd := universal_tm_computes (tm := tm) h_input h_halts
+    -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`;
+    -- since `Part.eval` is functional, the encoded values must agree, then apply
+    -- injectivity of `DataEncode.encode`.
+    have h1 := h_fwd []
+    have h2 := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2
+    rw [h1] at h2
+    have h_eq := Part.some_inj.mp (by exact_mod_cast h2)
+    exact DataEncode.h_inj h_eq
+  · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`.
+    exfalso
+    have h_eval := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval
+    obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval
+    -- Project `h_input` to get individual components.
+    have h_q₀ := PB.fst_computes_at_encoded (PB.fst_computes_at_encoded h_input)
+    have h_tr := PB.snd_computes_at_encoded (PB.fst_computes_at_encoded h_input)
+    have h_inp := PB.snd_computes_at_encoded h_input
+    -- Initial config evaluates to `encode (tm.initCfg w)`.
+    have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env
+        = .some (DataEncode.encode (tm.initCfg w)) := by
+      have := (initial_config_computes h_q₀ h_inp) []
+      simpa using this
+    -- Unfold tm_main_loop = PB.while_ init body.
+    set body_pb : PB → PB :=
+      fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc
+        (fun next => next) with body_pb_def
+    change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env
+      = .some d at h_loop
+    set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def
+    change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env
+      = .some d at h_loop
+    rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop
+    -- Extract the trajectory.
+    obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ :=
+      Prog.whileFrom_eval_some h_loop
+    -- The body computes `step` at every config.
+    have h_body_eval : ∀ c : tm.Cfg,
+        bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by
+      intro c
+      have h := (tm_main_loop_body_computes h_tr c (ext := [])).here
+      simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h
+    -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`.
+    have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by
+      intro k hk
+      induction k with
+      | zero => simpa using h_traj0
+      | succ k ih =>
+        have hkm : k < m := hk
+        have ih' := ih (Nat.le_of_lt hkm)
+        have h_step_k := (h_steps k hkm).2
+        rw [ih', h_body_eval] at h_step_k
+        have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) :=
+          (Part.some_inj.mp h_step_k).symm
+        rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from
+          (Function.iterate_succ_apply' step k _).symm]
+    -- Halt condition at `m` gives `state = none`.
+    have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl
+    rw [← h_trajm, h_at_m] at h_halt_at_m
+    have headD_iff : ∀ c : tm.Cfg,
+        (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+      rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+    exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩
+
+/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches
+a halted configuration whose tape content (head followed by the right stack, with
+blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization
+of `universal_tm`. -/
+private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
+    (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop :=
+  ∃ n : ℕ,
+    let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+    cfg.state = none ∧
+    (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w'
+
+private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w)) :
+    Outputs' tm w w' ↔ (universal_tm p_input).computes_at_encoded env w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  refine ⟨?_, ?_⟩
+  · -- Forward: `Outputs' tm w w' → universal_tm computes w'`.
+    rintro ⟨n, h_halt_n, h_eq⟩
+    have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩
+    have h := universal_tm_computes (tm := tm) h_input h_halts
+    -- Stationarity: any later iterate of a halted config equals it.
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter
+    rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+      (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h
+    exact h
+  · -- Converse: directly from `universal_tm_simulates_converse`.
+    intro h_out
+    exact universal_tm_simulates_converse h_input h_out
+
 end RoseTreeMachine
 
 end Turing

From 206b6304b9f3d418fe493c3c4bf5c2ad64d04767 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 23 May 2026 00:52:45 +0200
Subject: [PATCH 071/106] completion?

---
 .../Machines/RoseTreeMachine/V2.lean          | 450 ++++++++++++++++--
 1 file changed, 421 insertions(+), 29 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index bc005f530d..ac36ff0bef 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -8,6 +8,7 @@ module
 
 public import Mathlib.Data.Part
 public import Mathlib.Control.Fix
+public import Mathlib.Control.LawfulFix
 public import Std
 
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
@@ -243,17 +244,35 @@ lemma Prog.empty_computes :
   Prog.empty.computes (fun _ => Data.l []) := by
   simp [Prog.computes, Prog.eval, Prog.meteredEval]
 
-@[simp]
-lemma Prog.cons_computes {h t : Prog} {fh ft : List Data → Data}
-    (hh : h.computes fh) (ht : t.computes ft) :
-    (Prog.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
-  sorry
+/-- `Prog.eval` returns `.some d` iff the underlying metered evaluation returns some triple
+with first component `d`. -/
+lemma Prog.eval_some_iff_meteredEval {p : Prog} {env : List Data} {d : Data} :
+    p.eval env = .some d ↔ ∃ t s, p.meteredEval env = .some (d, t, s) := by
+  rw [Prog.eval]
+  constructor
+  · intro h
+    rw [Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', t, s⟩, hm, heq⟩ := h
+    cases heq
+    exact ⟨t, s, Part.eq_some_iff.mpr hm⟩
+  · rintro ⟨t, s, h⟩; rw [h]; rfl
 
 /-- Pointwise (single-env) version of `Prog.cons_computes`. -/
 lemma Prog.cons_eval {h t : Prog} {env : List Data} {dh dt : Data}
     (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
     (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
-  sorry
+  obtain ⟨th, sh, hmh⟩ := Prog.eval_some_iff_meteredEval.mp hh
+  obtain ⟨tt, st, hmt⟩ := Prog.eval_some_iff_meteredEval.mp ht
+  show (Prog.meteredEval env (Prog.cons h t)).map Prod.fst = _
+  rw [Prog.meteredEval, hmh]
+  simp only [bind, Part.bind_some, hmt, pure, Part.map_some]
+
+@[simp]
+lemma Prog.cons_computes {h t : Prog} {fh ft : List Data → Data}
+    (hh : h.computes fh) (ht : t.computes ft) :
+    (Prog.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
+  intro env
+  exact Prog.cons_eval (hh env) (ht env)
 
 /-- Pointwise (single-env) version for `elim`. -/
 lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
@@ -262,7 +281,17 @@ lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
       match dv.asList with
       | [] => em.eval env
       | head :: tail => cs.eval (env ++ [head, Data.l tail]) := by
-  sorry
+  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
+  show (Prog.meteredEval env (Prog.elim v em cs)).map Prod.fst = _
+  rw [Prog.meteredEval, hmv]
+  simp only [bind, Part.bind_some]
+  rcases h : dv.asList with _ | ⟨head, tail⟩
+  · have hdv : dv = Data.l [] := by rw [← Data.asList_l dv, h]
+    rw [hdv]; simp only; rw [Prog.eval]; ext d
+    simp [Part.mem_map_iff, Part.mem_bind_iff]
+  · have hdv : dv = Data.l (head :: tail) := by rw [← Data.asList_l dv, h]
+    rw [hdv]; simp only; rw [Prog.eval]; ext d
+    simp [Part.mem_map_iff, Part.mem_bind_iff]
 
 /-- The loop core of `while_`: starting from accumulator `acc` (a `Data`),
 halt and return `acc` if its `asList.headD` is empty; otherwise run `body` on
@@ -274,25 +303,228 @@ noncomputable def Prog.whileFrom_eval (body : Prog) (env : List Data) : Data →
     else
       (body.eval (env ++ [acc])).bind rec
 
+/-- The loop body for `whileFrom_eval` is `ωScottContinuous`, which gives us access
+to `Part.fix_eq` for unrolling. -/
+lemma Prog.whileFrom_eval_continuous (body : Prog) (env : List Data) :
+    OmegaCompletePartialOrder.ωScottContinuous
+      (fun (rec : Data → Part Data) (acc : Data) =>
+        if acc.asList.headD (Data.l []) = Data.l [] then
+          Part.some acc
+        else
+          (body.eval (env ++ [acc])).bind rec) := by
+  apply OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+  intro a
+  by_cases h : a.asList.headD (Data.l []) = Data.l []
+  · simp only [h, if_true]
+    exact OmegaCompletePartialOrder.ωScottContinuous.const
+  · simp only [h, if_false]
+    exact OmegaCompletePartialOrder.ContinuousHom.ωScottContinuous.bind
+      OmegaCompletePartialOrder.ωScottContinuous.const
+      (OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+        (fun _ => OmegaCompletePartialOrder.ωScottContinuous.id.apply₂ _))
+
 /-- Halt-step unrolling for `whileFrom_eval`. -/
 lemma Prog.whileFrom_eval_halt {body : Prog} {env : List Data} {acc : Data}
     (h_halt : acc.asList.headD (Data.l []) = Data.l []) :
     Prog.whileFrom_eval body env acc = .some acc := by
-  sorry
+  unfold Prog.whileFrom_eval
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
+  simp only [h_halt, if_true]
 
 /-- Body-step unrolling for `whileFrom_eval`. -/
 lemma Prog.whileFrom_eval_step {body : Prog} {env : List Data} {acc : Data}
     (h_step : acc.asList.headD (Data.l []) ≠ Data.l []) :
     Prog.whileFrom_eval body env acc =
       (body.eval (env ++ [acc])).bind (Prog.whileFrom_eval body env) := by
-  sorry
+  conv_lhs => unfold Prog.whileFrom_eval
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
+  simp only [h_step, if_false]
+  rfl
+
+/-! ### Auxiliary metered/non-metered correspondence for `Prog.while_eval`.
+
+These private helpers factor out the metered and non-metered loop bodies and
+establish that the metered fix, projected to its data component, equals the
+non-metered `whileFrom_eval`. This is the key ingredient for `Prog.while_eval`.
+-/
+
+private noncomputable def Prog.metered_F (body : Prog) (env : List Data) :
+    ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) → (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
+  fun rec d_ts =>
+    let (acc, t, s) := d_ts
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      .some (acc, t, s)
+    else
+      (body.meteredEval (env ++ [acc])).bind fun y =>
+        rec (y.1, t + 1 + y.2.1, max s y.2.2)
+
+private noncomputable def Prog.nonmet_G (body : Prog) (env : List Data) :
+    (Data → Part Data) → Data → Part Data :=
+  fun rec acc =>
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      Part.some acc
+    else
+      (body.eval (env ++ [acc])).bind rec
+
+private lemma Prog.metered_F_monotone (body : Prog) (env : List Data) :
+    Monotone (Prog.metered_F body env) := by
+  intro f g hfg ⟨acc, t, s⟩ x hx
+  unfold Prog.metered_F at hx ⊢
+  simp only at hx ⊢
+  by_cases h : acc.asList.headD (Data.l []) = Data.l []
+  · rw [if_pos h] at hx ⊢; exact hx
+  · rw [if_neg h] at hx ⊢
+    rw [Part.mem_bind_iff] at hx ⊢
+    obtain ⟨y, hy1, hy2⟩ := hx
+    exact ⟨y, hy1, hfg _ _ hy2⟩
+
+private lemma Prog.nonmet_G_monotone (body : Prog) (env : List Data) :
+    Monotone (Prog.nonmet_G body env) := by
+  intro f g hfg acc x hx
+  unfold Prog.nonmet_G at hx ⊢
+  by_cases h : acc.asList.headD (Data.l []) = Data.l []
+  · rw [if_pos h] at hx ⊢; exact hx
+  · rw [if_neg h] at hx ⊢
+    rw [Part.mem_bind_iff] at hx ⊢
+    obtain ⟨y, hy1, hy2⟩ := hx
+    exact ⟨y, hy1, hfg _ _ hy2⟩
+
+private lemma Prog.approx_metered_to_nonmet (body : Prog) (env : List Data) :
+    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data) (t' s' : ℕ),
+      (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) →
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i := by
+  intro n
+  induction n with
+  | zero => intro i t s r t' s' h; exact absurd h (Part.notMem_none _)
+  | succ n ih =>
+    intro i t s r t' s' h
+    show r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i
+    have hF : (r, t', s') ∈
+        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s) := h
+    unfold Prog.metered_F at hF
+    unfold Prog.nonmet_G
+    simp only at hF
+    by_cases hh : i.asList.headD (Data.l []) = Data.l []
+    · rw [if_pos hh] at hF; rw [if_pos hh]
+      rw [Part.mem_some_iff] at hF
+      have : r = i := (Prod.mk.injEq ..).mp hF |>.1
+      subst this
+      exact Part.mem_some _
+    · rw [if_neg hh] at hF; rw [if_neg hh]
+      rw [Part.mem_bind_iff] at hF
+      obtain ⟨⟨r0, bt, bs⟩, hb, hrec⟩ := hF
+      rw [Part.mem_bind_iff]
+      refine ⟨r0, ?_, ih r0 _ _ r t' s' hrec⟩
+      show r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst
+      rw [Part.mem_map_iff]
+      exact ⟨(r0, bt, bs), hb, rfl⟩
+
+private lemma Prog.approx_nonmet_to_metered (body : Prog) (env : List Data) :
+    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data),
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i →
+      ∃ t' s', (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) := by
+  intro n
+  induction n with
+  | zero => intro i t s r h; exact absurd h (Part.notMem_none _)
+  | succ n ih =>
+    intro i t s r h
+    show ∃ t' s', (r, t', s') ∈
+        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s)
+    have hG : r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i := h
+    unfold Prog.nonmet_G at hG
+    unfold Prog.metered_F
+    simp only
+    by_cases hh : i.asList.headD (Data.l []) = Data.l []
+    · rw [if_pos hh] at hG; rw [if_pos hh]
+      rw [Part.mem_some_iff] at hG; subst hG
+      exact ⟨t, s, Part.mem_some _⟩
+    · rw [if_neg hh] at hG; rw [if_neg hh]
+      rw [Part.mem_bind_iff] at hG
+      obtain ⟨r0, hbody, hrec⟩ := hG
+      have hbody' : r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst := hbody
+      rw [Part.mem_map_iff] at hbody'
+      obtain ⟨⟨r0', bt, bs⟩, hmev, heq⟩ := hbody'
+      simp only at heq
+      have : r0' = r0 := heq
+      subst this
+      obtain ⟨t', s', hF⟩ := ih r0' (t + 1 + bt) (max s bs) r hrec
+      refine ⟨t', s', ?_⟩
+      rw [Part.mem_bind_iff]
+      exact ⟨(r0', bt, bs), hmev, hF⟩
+
+private lemma Prog.proj_fix_eq (body : Prog) (env : List Data) (i : Data) (t s : ℕ) :
+    (Part.fix (Prog.metered_F body env) (i, t, s)).map Prod.fst =
+      Prog.whileFrom_eval body env i := by
+  apply Part.ext
+  intro r
+  rw [Part.mem_map_iff]
+  let F_oh : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →o
+      ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) :=
+    ⟨Prog.metered_F body env, Prog.metered_F_monotone body env⟩
+  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
+    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
+  have hF_eq : ∀ {a b}, b ∈ Part.fix (Prog.metered_F body env) a ↔ b ∈ Part.fix (⇑F_oh) a := by
+    intros; rfl
+  have hG_eq : ∀ {a b}, b ∈ Part.fix (Prog.nonmet_G body env) a ↔ b ∈ Part.fix (⇑G_oh) a := by
+    intros; rfl
+  constructor
+  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
+    rw [hF_eq, Part.Fix.mem_iff F_oh] at hmem
+    obtain ⟨n, hn⟩ := hmem
+    show r' ∈ Prog.whileFrom_eval body env i
+    unfold Prog.whileFrom_eval
+    show r' ∈ Part.fix (Prog.nonmet_G body env) i
+    rw [hG_eq, Part.Fix.mem_iff G_oh]
+    exact ⟨n, Prog.approx_metered_to_nonmet body env n i t s r' _ _ hn⟩
+  · intro hr
+    have hr' : r ∈ Part.fix (Prog.nonmet_G body env) i := hr
+    rw [hG_eq, Part.Fix.mem_iff G_oh] at hr'
+    obtain ⟨n, hn⟩ := hr'
+    obtain ⟨t', s', hF⟩ := Prog.approx_nonmet_to_metered body env n i t s r hn
+    refine ⟨(r, t', s'), ?_, rfl⟩
+    rw [hF_eq, Part.Fix.mem_iff F_oh]
+    exact ⟨n, hF⟩
 
 /-- Pointwise (single-env) version for `while_`: the program evaluates `init`,
 then runs the loop body starting from that value. -/
 lemma Prog.while_eval {init body : Prog} {env : List Data} :
     (Prog.while_ init body).eval env =
       (init.eval env).bind (Prog.whileFrom_eval body env) := by
-  sorry
+  show (Prog.meteredEval env (Prog.while_ init body)).map Prod.fst = _
+  have hmEq : Prog.meteredEval env (Prog.while_ init body) =
+      (init.meteredEval env).bind (fun x =>
+        Part.fix (Prog.metered_F body env) (x.1, 1 + x.2.1, max 1 x.2.2)) := by
+    rw [Prog.meteredEval]; rfl
+  rw [hmEq]
+  apply Part.ext
+  intro r
+  rw [Part.mem_map_iff]
+  constructor
+  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
+    rw [Part.mem_bind_iff] at hmem
+    obtain ⟨⟨i, it, is⟩, hmi, hf⟩ := hmem
+    rw [Part.mem_bind_iff]
+    refine ⟨i, ?_, ?_⟩
+    · show i ∈ (init.meteredEval env).map Prod.fst
+      rw [Part.mem_map_iff]; exact ⟨_, hmi, rfl⟩
+    · rw [← Prog.proj_fix_eq body env i (1 + it) (max 1 is), Part.mem_map_iff]
+      exact ⟨_, hf, rfl⟩
+  · intro hr
+    rw [Part.mem_bind_iff] at hr
+    obtain ⟨i, hi, hr2⟩ := hr
+    have hi' : i ∈ (init.meteredEval env).map Prod.fst := hi
+    rw [Part.mem_map_iff] at hi'
+    obtain ⟨⟨i', it, is⟩, hmi, heq⟩ := hi'
+    simp only at heq
+    have hii : i' = i := heq
+    subst hii
+    rw [← Prog.proj_fix_eq body env i' (1 + it) (max 1 is), Part.mem_map_iff] at hr2
+    obtain ⟨⟨r', t', s'⟩, hF, rfl⟩ := hr2
+    refine ⟨(r', t', s'), ?_, rfl⟩
+    rw [Part.mem_bind_iff]
+    exact ⟨(i', it, is), hmi, hF⟩
 
 /-- Termination-extraction for `whileFrom_eval`: if the loop returns `.some r`,
 then there exists an iteration index `n` such that running the body `n` times
@@ -307,7 +539,70 @@ lemma Prog.whileFrom_eval_some {body : Prog} {env : List Data} {acc r : Data}
       (∀ k < n,
           (traj k).asList.headD (Data.l []) ≠ Data.l [] ∧
           body.eval (env ++ [traj k]) = .some (traj (k+1))) := by
-  sorry
+  -- Helper: induct on approx index to extract a trajectory.
+  have approx_some_traj : ∀ (n : ℕ) (acc r : Data),
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n acc →
+      ∃ (k : ℕ) (traj : ℕ → Data),
+        traj 0 = acc ∧ traj k = r ∧
+        (r.asList.headD (Data.l []) = Data.l []) ∧
+        (∀ j < k, (traj j).asList.headD (Data.l []) ≠ Data.l [] ∧
+                  body.eval (env ++ [traj j]) = .some (traj (j+1))) := by
+    intro n
+    induction n with
+    | zero => intro acc r h; exact absurd h (Part.notMem_none _)
+    | succ n ih =>
+      intro acc r h
+      have hG : r ∈ (Prog.nonmet_G body env)
+          (Part.Fix.approx (Prog.nonmet_G body env) n) acc := h
+      unfold Prog.nonmet_G at hG
+      by_cases hh : acc.asList.headD (Data.l []) = Data.l []
+      · rw [if_pos hh] at hG
+        rw [Part.mem_some_iff] at hG
+        cases hG
+        refine ⟨0, fun _ => acc, rfl, rfl, hh, ?_⟩
+        intro j hj; omega
+      · rw [if_neg hh] at hG
+        rw [Part.mem_bind_iff] at hG
+        obtain ⟨r0, hbody, hrec⟩ := hG
+        obtain ⟨k, traj', htraj0, htrajk, hr_halt, hsteps⟩ := ih r0 r hrec
+        refine ⟨k + 1, fun j => if j = 0 then acc else traj' (j - 1),
+                by simp, ?_, hr_halt, ?_⟩
+        · show (if k + 1 = 0 then acc else traj' (k + 1 - 1)) = r
+          rw [if_neg (by omega)]
+          have : k + 1 - 1 = k := by omega
+          rw [this]; exact htrajk
+        · intro j hj
+          cases j with
+          | zero =>
+            show (if (0 : ℕ) = 0 then acc else traj' (0 - 1)).asList.headD (Data.l []) ≠ Data.l [] ∧
+                 body.eval (env ++ [if (0 : ℕ) = 0 then acc else traj' (0 - 1)]) =
+                  .some (if (0 + 1 : ℕ) = 0 then acc else traj' (0 + 1 - 1))
+            simp only [if_true, if_neg (Nat.succ_ne_zero 0)]
+            refine ⟨hh, ?_⟩
+            have heval : body.eval (env ++ [acc]) = .some r0 :=
+              (Part.eq_some_iff.mpr hbody)
+            rw [heval]; congr 1
+            show r0 = traj' 0
+            exact htraj0.symm
+          | succ j =>
+            show (if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)).asList.headD
+                  (Data.l []) ≠ Data.l [] ∧
+                 body.eval (env ++ [if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)]) =
+                  .some (if (j + 1 + 1 : ℕ) = 0 then acc else traj' (j + 1 + 1 - 1))
+            rw [if_neg (Nat.succ_ne_zero _), if_neg (Nat.succ_ne_zero _)]
+            have hjk : j < k := by omega
+            have h_idx1 : (j + 1 - 1 : ℕ) = j := by omega
+            have h_idx2 : (j + 1 + 1 - 1 : ℕ) = j + 1 := by omega
+            rw [h_idx1, h_idx2]
+            exact hsteps j hjk
+  have hmem : r ∈ Prog.whileFrom_eval body env acc := by rw [h]; exact Part.mem_some _
+  have hmem' : r ∈ Part.fix (Prog.nonmet_G body env) acc := hmem
+  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
+    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
+  have hmem'' : r ∈ Part.fix (⇑G_oh) acc := hmem'
+  rw [Part.Fix.mem_iff G_oh] at hmem''
+  obtain ⟨n, hn⟩ := hmem''
+  exact approx_some_traj n acc r hn
 
 def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
 
@@ -384,7 +679,11 @@ instance : DataEncode Bool where
 
 instance (α : Type) [DataEncode α] : DataEncode (List α) where
   encode xs := Data.l (xs.map DataEncode.encode)
-  h_inj := by sorry
+  h_inj := by
+    intro a b h
+    have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode :=
+      Data.l.inj h
+    exact List.map_injective_iff.mpr DataEncode.h_inj h'
 
 @[simp, grind =]
 lemma DataEncode_list_nil {α : Type} [DataEncode α] :
@@ -405,7 +704,10 @@ instance (α : Type) [DataEncode α] : DataEncode (Option α) where
   encode := fun
     | none => Data.l []
     | some x => Data.l [DataEncode.encode x]
-  h_inj := by sorry
+  h_inj := by
+    intro a b h
+    cases a <;> cases b <;> simp_all
+    exact DataEncode.h_inj h
 
 @[simp]
 lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
@@ -414,7 +716,10 @@ lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
 
 instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
   encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
-  h_inj := by sorry
+  h_inj := by
+    intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h
+    simp at h
+    exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩
 
 lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
   DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
@@ -422,7 +727,17 @@ lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b
 
 instance : DataEncode ℕ where
   encode x := DataEncode.encode (Nat.bits x)
-  h_inj := by sorry
+  h_inj := by
+    intro a b h
+    have hb : a.bits = b.bits := DataEncode.h_inj h
+    -- Reconstruct a from a.bits via binaryRec.
+    have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by
+      intro n
+      induction n using Nat.binaryRec' with
+      | zero => simp
+      | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih]
+    have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb
+    simpa [hrec] using this
 
 ----------------------------------------------------
 
@@ -604,38 +919,86 @@ Lifting eval rules to `@[simp]` lemmas lets you discharge most goals of the form
 
 @[simp] lemma Prog.var_eval {env : List Data} {i : ℕ} :
     (Prog.var i).eval env = .some (env[i]?.getD (Data.l [])) := by
-  sorry
+  simp [Prog.eval, Prog.meteredEval]
 
 @[simp] lemma Prog.empty_eval {env : List Data} :
     Prog.empty.eval env = .some (Data.l []) := by
-  sorry
+  simp [Prog.eval, Prog.meteredEval, Data.empty]
 
 @[simp] lemma Prog.cons_eval_simp {env : List Data} {h t : Prog} {dh dt : Data}
     (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
-    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
-  sorry
+    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) :=
+  Prog.cons_eval hh ht
 
 @[simp] lemma Prog.elim_eval_nil {env : List Data} {v em cs : Prog}
     (hv : v.eval env = .some (Data.l [])) :
     (Prog.elim v em cs).eval env = em.eval env := by
-  sorry
+  have := Prog.elim_eval (em := em) (cs := cs) hv
+  simpa using this
 
 @[simp] lemma Prog.elim_eval_cons {env : List Data} {v em cs : Prog}
     {head : Data} {tail : List Data}
     (hv : v.eval env = .some (Data.l (head :: tail))) :
     (Prog.elim v em cs).eval env = cs.eval (env ++ [head, Data.l tail]) := by
-  sorry
+  have := Prog.elim_eval (em := em) (cs := cs) hv
+  simpa using this
 
 @[simp] lemma Prog.letin_eval {env : List Data} {val rest : Prog} {dv : Data}
     (hv : val.eval env = .some dv) :
     (Prog.letin val rest).eval env = rest.eval (env ++ [dv]) := by
-  sorry
+  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
+  show (Prog.meteredEval env (Prog.letin val rest)).map Prod.fst = _
+  rw [Prog.meteredEval, hmv]
+  simp only [bind, Part.bind_some]
+  rw [Prog.eval]; ext d
+  simp [Part.mem_map_iff, Part.mem_bind_iff]
 
 @[simp] lemma Prog.eq_eval {env : List Data} {a b : Prog} {da db : Data}
     (ha : a.eval env = .some da) (hb : b.eval env = .some db) :
     (Prog.eq a b).eval env =
       .some (if da = db then Data.l [Data.l []] else Data.l []) := by
-  sorry
+  obtain ⟨ta, sa, hma⟩ := Prog.eval_some_iff_meteredEval.mp ha
+  obtain ⟨tb, sb, hmb⟩ := Prog.eval_some_iff_meteredEval.mp hb
+  show (Prog.meteredEval env (Prog.eq a b)).map Prod.fst = _
+  rw [Prog.meteredEval, hma]
+  simp only [bind, Part.bind_some, hmb, beq_iff_eq]
+  by_cases h : da = db <;> simp [h, Part.map_some]
+
+/-- Helper for `Prog.fold_eval`: chained `foldlM` over `meteredEval`. -/
+private lemma Prog.foldlM_chain (body : Prog) (env : List Data)
+    (acc : ℕ → Data) :
+    ∀ (dl : List Data) (start : ℕ) (t s : ℕ),
+      (∀ k (h : k < dl.length),
+        body.eval (env ++ [acc (start + k), dl[k]]) = .some (acc (start + k + 1))) →
+      ∃ t' s', List.foldlM
+        (fun x el => (body.meteredEval (env ++ [x.1, el])).bind fun y =>
+          pure (y.1, 1 + x.2.1 + y.2.1, max x.2.2 y.2.2))
+        (acc start, t, s) dl = .some (acc (start + dl.length), t', s') := by
+  intro dl
+  induction dl with
+  | nil => intro start t s _hstep
+           refine ⟨t, s, ?_⟩
+           simp [List.foldlM]
+  | cons hd tl ih =>
+    intro start t s hstep
+    have h0 : body.eval (env ++ [acc start, hd]) = .some (acc (start + 1)) := by
+      have := hstep 0 (by simp)
+      simpa using this
+    obtain ⟨bt, bs, hmb⟩ := Prog.eval_some_iff_meteredEval.mp h0
+    simp only [List.foldlM_cons, List.length_cons, hmb, Part.bind_some, pure, bind]
+    have hstep' : ∀ k (h : k < tl.length),
+        body.eval (env ++ [acc ((start + 1) + k), tl[k]]) = .some (acc ((start + 1) + k + 1)) := by
+      intro k hk
+      have hh : k + 1 < (hd :: tl).length := by rw [List.length_cons]; omega
+      have := hstep (k + 1) hh
+      have h_eq : (hd :: tl)[k + 1] = tl[k] := by simp
+      rw [h_eq] at this
+      have h1 : start + 1 + k = start + (k + 1) := by omega
+      rw [h1]; exact this
+    obtain ⟨t', s', ih_res⟩ := ih (start + 1) (1 + t + bt) (max s bs) hstep'
+    refine ⟨t', s', ?_⟩
+    have h_len : start + (tl.length + 1) = (start + 1) + tl.length := by omega
+    rw [h_len]; exact ih_res
 
 /-- Semantic spec for `Prog.fold`. Rather than quantifying the body universally
 over arbitrary `Data` accumulators/elements, we parameterise by the actually
@@ -651,7 +1014,18 @@ lemma Prog.fold_eval {env : List Data} {body init list : Prog}
     (hstep : ∀ k (h : k < dl.length),
       body.eval (env ++ [acc k, dl[k]]) = .some (acc (k+1))) :
     (Prog.fold body init list).eval env = .some result := by
-  sorry
+  obtain ⟨it, is, hmi⟩ := Prog.eval_some_iff_meteredEval.mp hi
+  obtain ⟨lt, ls, hml⟩ := Prog.eval_some_iff_meteredEval.mp hl
+  rw [← hacc0] at hmi
+  have hstep' : ∀ k (h : k < dl.length),
+      body.eval (env ++ [acc (0 + k), dl[k]]) = .some (acc (0 + k + 1)) := by
+    intro k hk; simpa using hstep k hk
+  obtain ⟨t', s', hfold⟩ := Prog.foldlM_chain body env acc dl 0 (1 + it + lt) (max is ls) hstep'
+  show (Prog.meteredEval env (Prog.fold body init list)).map Prod.fst = _
+  rw [Prog.meteredEval, hmi]
+  simp only [bind, Part.bind_some, hml, Data.l_asList]
+  rw [hfold]
+  simp [haccN]
 
 /-- Example: with the `simp` set above, the `tail` spec on a concrete env is short. -/
 example {env : List Data} {x : Prog} {dx : Data} (hx : x.eval env = .some dx) :
@@ -1140,11 +1514,19 @@ variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
 
 public instance : DataEncode (Turing.StackTape Symbol) where
   encode t := DataEncode.encode t.toList
-  h_inj := by sorry
+  h_inj := by
+    intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h
+    have : l₁ = l₂ := DataEncode.h_inj h
+    cases this; rfl
 
 public instance : DataEncode (Turing.BiTape Symbol) where
   encode t := DataEncode.encode (t.head, t.left, t.right)
-  h_inj := by sorry
+  h_inj := by
+    intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hh, hl, hr⟩ := heq
+    cases hh; cases hl; cases hr; rfl
 
 omit [Inhabited Symbol] [Fintype Symbol] in
 lemma encode_biTape (t : Turing.BiTape Symbol) :
@@ -1306,7 +1688,7 @@ instance : DataEncode Dir where
   encode := fun
     | Dir.left => DataEncode.encode true
     | Dir.right => DataEncode.encode false
-  h_inj := by sorry
+  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
 
 -- /--
 -- Move the head to the left or right, shifting the tape underneath it.
@@ -1366,7 +1748,12 @@ lemma bitape_optionMove_computes {env : List Data} {p_t p_dir : PB}
 instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
     DataEncode (Turing.SingleTapeTM.Cfg tm) where
   encode cfg := DataEncode.encode (cfg.state, cfg.BiTape)
-  h_inj := by sorry
+  h_inj := by
+    intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, ht⟩ := heq
+    cases hs; cases ht; rfl
 
 -- Evaluate a function `f` at `arg` where the function is given as a graph.
 -- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise.
@@ -1487,7 +1874,12 @@ def eval_tr (tr : PB) (q c : PB) : PB :=
 
 instance : DataEncode (SingleTapeTM.Stmt Symbol) where
   encode stmt := DataEncode.encode (stmt.symbol, stmt.movement)
-  h_inj := by sorry
+  h_inj := by
+    intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, hm⟩ := heq
+    cases hs; cases hm; rfl
 
 lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State]
     [DecidableEq State] [Fintype Symbol]

From c3f5b8d860d0b48aa2855bc320f30aee61e23947 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 23 May 2026 01:13:12 +0200
Subject: [PATCH 072/106] split

---
 Cslib.lean                                    |    8 +
 .../Machines/RoseTreeMachine/V2.lean          | 2610 +----------------
 .../Machines/RoseTreeMachine/V2/Data.lean     |  115 +
 .../RoseTreeMachine/V2/DataEncode.lean        |  101 +
 .../Machines/RoseTreeMachine/V2/PB.lean       |  368 +++
 .../Machines/RoseTreeMachine/V2/Prog.lean     |  616 ++++
 .../Machines/RoseTreeMachine/V2/Tools.lean    |  191 ++
 .../RoseTreeMachine/V2/UniversalTM.lean       | 1124 +++++++
 8 files changed, 2536 insertions(+), 2597 deletions(-)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/Data.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/DataEncode.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean

diff --git a/Cslib.lean b/Cslib.lean
index 6423f95ac5..490c509e02 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -69,9 +69,17 @@ public import Cslib.Computability.Machines.MultiTapeTuring.TapeView
 public import Cslib.Computability.Machines.MultiTapeTuring.UniversalTM
 public import Cslib.Computability.Machines.MultiTapeTuring.WhileCombinator
 public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes
+public import Cslib.Computability.Machines.RoseTreeMachine.RTM_to_TM
 public import Cslib.Computability.Machines.RoseTreeMachine.RoseTreeMachine
 public import Cslib.Computability.Machines.RoseTreeMachine.V2
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Data
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.DataEncode
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.PB
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Tools
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.UniversalTM
 public import Cslib.Computability.Machines.RoseTreeMachine.V3
+public import Cslib.Computability.Machines.RoseTreeMachine.log
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
index ac36ff0bef..a327ad0a9b 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -6,2606 +6,22 @@ Authors: Christian Reitwiessner
 
 module
 
-public import Mathlib.Data.Part
-public import Mathlib.Control.Fix
-public import Mathlib.Control.LawfulFix
-public import Std
-
-public import Cslib.Computability.Machines.SingleTapeTuring.Basic
-public import Mathlib.Data.Nat.Bits
-public import Mathlib.Data.List.ReduceOption
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Data
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.DataEncode
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.PB
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Tools
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.UniversalTM
 
 /-!
--- This is a proposal to define a machine model and related time and space measure
--- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
+# RoseTreeMachine V2
 
--- The goal would be that the machine model is flexible enough to implement algorithms easily,
--- but still close enough to Turing machines to allow defining logspace and even loglogspace.
+A stack-machine model with `Data` rose-tree values, `Prog` programs (with `meteredEval` /
+`eval` / `while_` / `fold`), a `PB` (program-builder) layer with named binders and
+`computes_at` reasoning, and a `DataEncode` typeclass for encoding generic types.
 
--- The machine as defined below will allow stateless / pure functional programs.
--- If we store the input tape position as a number, we should be able to define logspace.
--- In order to go down to loglogspace, we need to use the input tape head as a "pointer"
--- and cannot count its position. This could be doable as well, but requires a more stateful
--- model at least for the input tape. The input tape is currently not modeled, but I have some
--- plans to define actions on the input tape as further elementary operations.
+The development culminates in `universal_tm`, a `PB` simulating an arbitrary
+`SingleTapeTM`, and the theorem `universal_tm_simulates_iff`.
 
--- The main insight over my current work is that it does not hurt to
--- (1) create a new tape for every elementary operation (the program size is constant, so the number
---     of tapes is constant)
--- (2) disallow modifications to existing tapes (work tape space has been spent, it is fine
---     to copy it finitely often
--- (3) if we have a built-in `fold` operation, we should be able to implement the required
---     operations at linear space overhead, because the fold operation implicitly re-uses the
---     space used by the accumulator.
+This file is just a re-export of the modules in `V2/`.
 -/
-
-@[expose] public section
-
-
-namespace Turing
-
-namespace RoseTreeMachine
-
--- ================= Data structure
-
-
-
--- Rose-tree data structure, it allows us to
--- 1. map most of Lean's data structures in a "natural" manner
--- 2. define a "fold" operation
-inductive Data where
-  | l : List Data → Data
-deriving Repr
-
-mutual
-  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
-    | .l xs, .l ys =>
-      match Data.listDecEq xs ys with
-      | isTrue h => isTrue (congrArg Data.l h)
-      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
-  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
-    | [], [] => isTrue rfl
-    | [], _ :: _ => isFalse (by simp)
-    | _ :: _, [] => isFalse (by simp)
-    | x :: xs, y :: ys =>
-      match Data.decEq x y, Data.listDecEq xs ys with
-      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
-      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
-      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
-end
-
-instance : DecidableEq Data := Data.decEq
-instance : BEq Data := inferInstance
-instance : LawfulBEq Data := inferInstance
-
-abbrev Data.empty := Data.l []
-
-
-@[grind =]
-def Data.asList
-  | Data.l xs => xs
-
-@[simp]
-lemma Data.asList_empty : Data.empty.asList = [] := by rfl
-
-@[simp, grind =]
-lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
-
-@[simp, grind =]
-lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
-
---- Encoding length of d.
-def Data.size : Data → ℕ
-  | Data.l xs => 2 + (xs.map Data.size |>.sum)
-
-@[simp, grind =]
-lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
-
-@[simp, grind =]
-lemma Data.cons_size {h : Data} {t : List Data} :
-    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
-  simp [Data.size]
-  grind
-
-/-- Recursion principle for `Data` that exposes the list-of-children structure:
-    a `motive` is built from the empty case and a cons case that combines the
-    motive on the head child and on the tail list (viewed as a `Data`).
-    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
-    through `List.rec`, leaving the recursive call on children to the user;
-    `Data.recL` performs both recursions and is the natural elimination principle
-    for definitions/proofs that need both IHs. -/
-@[elab_as_elim]
-def Data.recL {motive : Data → Sort*}
-    (nil : motive (Data.l []))
-    (cons : ∀ (x : Data) (xs : List Data),
-      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
-    ∀ d, motive d
-  | .l [] => nil
-  | .l (x :: xs) =>
-      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
-
-/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
-@[elab_as_elim]
-theorem Data.inductionL {motive : Data → Prop}
-    (nil : motive (Data.l []))
-    (cons : ∀ (x : Data) (xs : List Data),
-      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
-    (d : Data) : motive d :=
-  Data.recL nil cons d
-
-abbrev TapeIndex := ℕ
-
-
--- ================= Operations and programs
-
--- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
--- Each operation creates a new stack entry (a new tape) and can read from previous
--- entries by index. Stack entries created in "inner" programs are temporary and deleted
--- once the inner program terminates. This is especially relevant for space complexity of
--- loops since it allows us to re-use the space of one iteration for the next iteration.
-
-def Var := ℕ
-deriving Repr
-
-/-- Abstract syntax tree. Binders (`letin`, `elim`'s cons branch, `fold`'s body, `while_`'s body)
-are *implicit*: each binder extends `env` with one or more fresh values, and the bound
-variable(s) are referred to as `var k` where `k = env.length` at the binding site.
-For ergonomic construction with named binders use `PB` below. -/
-inductive Prog where
-  | var (id : Var)
-  /-- `letin val rest`: evaluate `val`, append the result to `env`, then evaluate `rest`. -/
-  | letin (val : Prog) (rest : Prog)
-  | empty
-  | cons (h t : Prog)
-  /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
-      `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
-  | elim (v : Prog) (em : Prog) (cs : Prog)
-  | eq (a b : Prog)
-  /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
-      list; `body` runs once per element with `env` extended by `[acc, x]`. -/
-  | fold (body : Prog) (init list : Prog)
-  /-- `while_ init body`: `init` produces the starting accumulator; `body` runs with
-      `env` extended by the current accumulator. -/
-  | while_ (init body : Prog)
-deriving Repr
-
-/-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
-def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
-  match p with
-    -- TODO charge for copy?
-  | .var id => .some (env[(show ℕ from id)]?.getD (Data.l []), 1, 1)
-  | .letin val rest => do
-    let (v, t, s) ← val.meteredEval env
-    let (r, t', s') ← rest.meteredEval (env ++ [v])
-    -- TODO charge for copy?
-    return (r, 1 + t + t', max s s')
-  | .empty => .some (Data.empty, 1, 1)
-  | .cons h t => do
-    let (head, h_t, h_s) ← h.meteredEval env
-    let (tail, t_t, t_s) ← t.meteredEval env
-    return (Data.l (head :: tail.asList), 1 + h_t + t_t, max h_s t_s)
-  | .elim v em cs => do
-    let (v', t, s) ← v.meteredEval env
-    match v' with
-    | Data.l [] =>
-      let (r, t', s') ← em.meteredEval env
-      return (r, 1 + t + t', max s s')
-    | Data.l (head :: tail) =>
-      let (r, t', s') ← cs.meteredEval (env ++ [head, Data.l tail])
-      return (r, 1 + t + t', max s s')
-  | .eq a b => do
-    let (a, a_t, a_s) ← a.meteredEval env
-    let (b, b_t, b_s) ← b.meteredEval env
-    (if a == b then Data.l [ Data.l [] ] else Data.l [], 1 + a_t + b_t, 1 + max a_s b_s)
-  | .fold body init list => do
-    let (i, i_t, i_s) ← init.meteredEval env
-    let (l, l_t, l_s) ← list.meteredEval env
-    l.asList.foldlM
-      (fun (acc, t, s) el => do
-        let (acc', b_t, b_s) ← body.meteredEval (env ++ [acc, el])
-        return (acc', 1 + t + b_t, max s b_s))
-      (i, 1 + i_t + l_t, max i_s l_s)
-  | .while_ init body => do
-    let (i, i_t, i_s) ← init.meteredEval env
-    -- Real while loop: check the halt condition on the current accumulator first.
-    -- If `acc.asList.headD = []` (empty head), halt and return `acc`.
-    -- Otherwise run `body` on the accumulator and loop with its result.
-    let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
-            (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
-      fun rec d_ts =>
-        let (acc, t, s) := d_ts
-        if acc.asList.headD (Data.l []) = Data.l [] then
-          .some (acc, t, s)
-        else
-          (body.meteredEval (env ++ [acc])).bind fun (r, b_t, b_s) =>
-            rec (r, t + 1 + b_t, max s b_s)
-    Part.fix F (i, 1 + i_t, max 1 i_s)
-  termination_by (sizeOf p, 0)
-
-------------------------------------
---- We are just handling the semantics for now.
---- Later on, it would probably make sense to define a variation of meteredEval
---- that uses O-classes for the space and time, so we can use equality-transformations
---- instead of inequalities in the semantics proofs.
--------------------------------------------
-
-def Prog.eval (p : Prog) (env : List Data) : Part Data := (p.meteredEval env).map Prod.fst
-
-def Prog.computes (impl : Prog) (f : List Data → Data) : Prop :=
-  ∀ env, impl.eval env = .some (f env)
-
-@[simp]
-lemma Prog.var_computes {i : ℕ} :
-  (Prog.var i).computes (fun env => env[i]?.getD (Data.l [])) := by
-  simp [Prog.computes, Prog.eval, Prog.meteredEval]
-
-@[simp]
-lemma Prog.empty_computes :
-  Prog.empty.computes (fun _ => Data.l []) := by
-  simp [Prog.computes, Prog.eval, Prog.meteredEval]
-
-/-- `Prog.eval` returns `.some d` iff the underlying metered evaluation returns some triple
-with first component `d`. -/
-lemma Prog.eval_some_iff_meteredEval {p : Prog} {env : List Data} {d : Data} :
-    p.eval env = .some d ↔ ∃ t s, p.meteredEval env = .some (d, t, s) := by
-  rw [Prog.eval]
-  constructor
-  · intro h
-    rw [Part.eq_some_iff, Part.mem_map_iff] at h
-    obtain ⟨⟨d', t, s⟩, hm, heq⟩ := h
-    cases heq
-    exact ⟨t, s, Part.eq_some_iff.mpr hm⟩
-  · rintro ⟨t, s, h⟩; rw [h]; rfl
-
-/-- Pointwise (single-env) version of `Prog.cons_computes`. -/
-lemma Prog.cons_eval {h t : Prog} {env : List Data} {dh dt : Data}
-    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
-    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
-  obtain ⟨th, sh, hmh⟩ := Prog.eval_some_iff_meteredEval.mp hh
-  obtain ⟨tt, st, hmt⟩ := Prog.eval_some_iff_meteredEval.mp ht
-  show (Prog.meteredEval env (Prog.cons h t)).map Prod.fst = _
-  rw [Prog.meteredEval, hmh]
-  simp only [bind, Part.bind_some, hmt, pure, Part.map_some]
-
-@[simp]
-lemma Prog.cons_computes {h t : Prog} {fh ft : List Data → Data}
-    (hh : h.computes fh) (ht : t.computes ft) :
-    (Prog.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
-  intro env
-  exact Prog.cons_eval (hh env) (ht env)
-
-/-- Pointwise (single-env) version for `elim`. -/
-lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
-    (hv : v.eval env = .some dv) :
-    (Prog.elim v em cs).eval env =
-      match dv.asList with
-      | [] => em.eval env
-      | head :: tail => cs.eval (env ++ [head, Data.l tail]) := by
-  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
-  show (Prog.meteredEval env (Prog.elim v em cs)).map Prod.fst = _
-  rw [Prog.meteredEval, hmv]
-  simp only [bind, Part.bind_some]
-  rcases h : dv.asList with _ | ⟨head, tail⟩
-  · have hdv : dv = Data.l [] := by rw [← Data.asList_l dv, h]
-    rw [hdv]; simp only; rw [Prog.eval]; ext d
-    simp [Part.mem_map_iff, Part.mem_bind_iff]
-  · have hdv : dv = Data.l (head :: tail) := by rw [← Data.asList_l dv, h]
-    rw [hdv]; simp only; rw [Prog.eval]; ext d
-    simp [Part.mem_map_iff, Part.mem_bind_iff]
-
-/-- The loop core of `while_`: starting from accumulator `acc` (a `Data`),
-halt and return `acc` if its `asList.headD` is empty; otherwise run `body` on
-`env ++ [acc]` and recurse on the result. -/
-noncomputable def Prog.whileFrom_eval (body : Prog) (env : List Data) : Data → Part Data :=
-  Part.fix fun rec acc =>
-    if acc.asList.headD (Data.l []) = Data.l [] then
-      Part.some acc
-    else
-      (body.eval (env ++ [acc])).bind rec
-
-/-- The loop body for `whileFrom_eval` is `ωScottContinuous`, which gives us access
-to `Part.fix_eq` for unrolling. -/
-lemma Prog.whileFrom_eval_continuous (body : Prog) (env : List Data) :
-    OmegaCompletePartialOrder.ωScottContinuous
-      (fun (rec : Data → Part Data) (acc : Data) =>
-        if acc.asList.headD (Data.l []) = Data.l [] then
-          Part.some acc
-        else
-          (body.eval (env ++ [acc])).bind rec) := by
-  apply OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
-  intro a
-  by_cases h : a.asList.headD (Data.l []) = Data.l []
-  · simp only [h, if_true]
-    exact OmegaCompletePartialOrder.ωScottContinuous.const
-  · simp only [h, if_false]
-    exact OmegaCompletePartialOrder.ContinuousHom.ωScottContinuous.bind
-      OmegaCompletePartialOrder.ωScottContinuous.const
-      (OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
-        (fun _ => OmegaCompletePartialOrder.ωScottContinuous.id.apply₂ _))
-
-/-- Halt-step unrolling for `whileFrom_eval`. -/
-lemma Prog.whileFrom_eval_halt {body : Prog} {env : List Data} {acc : Data}
-    (h_halt : acc.asList.headD (Data.l []) = Data.l []) :
-    Prog.whileFrom_eval body env acc = .some acc := by
-  unfold Prog.whileFrom_eval
-  conv_lhs =>
-    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
-  simp only [h_halt, if_true]
-
-/-- Body-step unrolling for `whileFrom_eval`. -/
-lemma Prog.whileFrom_eval_step {body : Prog} {env : List Data} {acc : Data}
-    (h_step : acc.asList.headD (Data.l []) ≠ Data.l []) :
-    Prog.whileFrom_eval body env acc =
-      (body.eval (env ++ [acc])).bind (Prog.whileFrom_eval body env) := by
-  conv_lhs => unfold Prog.whileFrom_eval
-  conv_lhs =>
-    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
-  simp only [h_step, if_false]
-  rfl
-
-/-! ### Auxiliary metered/non-metered correspondence for `Prog.while_eval`.
-
-These private helpers factor out the metered and non-metered loop bodies and
-establish that the metered fix, projected to its data component, equals the
-non-metered `whileFrom_eval`. This is the key ingredient for `Prog.while_eval`.
--/
-
-private noncomputable def Prog.metered_F (body : Prog) (env : List Data) :
-    ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) → (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
-  fun rec d_ts =>
-    let (acc, t, s) := d_ts
-    if acc.asList.headD (Data.l []) = Data.l [] then
-      .some (acc, t, s)
-    else
-      (body.meteredEval (env ++ [acc])).bind fun y =>
-        rec (y.1, t + 1 + y.2.1, max s y.2.2)
-
-private noncomputable def Prog.nonmet_G (body : Prog) (env : List Data) :
-    (Data → Part Data) → Data → Part Data :=
-  fun rec acc =>
-    if acc.asList.headD (Data.l []) = Data.l [] then
-      Part.some acc
-    else
-      (body.eval (env ++ [acc])).bind rec
-
-private lemma Prog.metered_F_monotone (body : Prog) (env : List Data) :
-    Monotone (Prog.metered_F body env) := by
-  intro f g hfg ⟨acc, t, s⟩ x hx
-  unfold Prog.metered_F at hx ⊢
-  simp only at hx ⊢
-  by_cases h : acc.asList.headD (Data.l []) = Data.l []
-  · rw [if_pos h] at hx ⊢; exact hx
-  · rw [if_neg h] at hx ⊢
-    rw [Part.mem_bind_iff] at hx ⊢
-    obtain ⟨y, hy1, hy2⟩ := hx
-    exact ⟨y, hy1, hfg _ _ hy2⟩
-
-private lemma Prog.nonmet_G_monotone (body : Prog) (env : List Data) :
-    Monotone (Prog.nonmet_G body env) := by
-  intro f g hfg acc x hx
-  unfold Prog.nonmet_G at hx ⊢
-  by_cases h : acc.asList.headD (Data.l []) = Data.l []
-  · rw [if_pos h] at hx ⊢; exact hx
-  · rw [if_neg h] at hx ⊢
-    rw [Part.mem_bind_iff] at hx ⊢
-    obtain ⟨y, hy1, hy2⟩ := hx
-    exact ⟨y, hy1, hfg _ _ hy2⟩
-
-private lemma Prog.approx_metered_to_nonmet (body : Prog) (env : List Data) :
-    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data) (t' s' : ℕ),
-      (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) →
-      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i := by
-  intro n
-  induction n with
-  | zero => intro i t s r t' s' h; exact absurd h (Part.notMem_none _)
-  | succ n ih =>
-    intro i t s r t' s' h
-    show r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i
-    have hF : (r, t', s') ∈
-        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s) := h
-    unfold Prog.metered_F at hF
-    unfold Prog.nonmet_G
-    simp only at hF
-    by_cases hh : i.asList.headD (Data.l []) = Data.l []
-    · rw [if_pos hh] at hF; rw [if_pos hh]
-      rw [Part.mem_some_iff] at hF
-      have : r = i := (Prod.mk.injEq ..).mp hF |>.1
-      subst this
-      exact Part.mem_some _
-    · rw [if_neg hh] at hF; rw [if_neg hh]
-      rw [Part.mem_bind_iff] at hF
-      obtain ⟨⟨r0, bt, bs⟩, hb, hrec⟩ := hF
-      rw [Part.mem_bind_iff]
-      refine ⟨r0, ?_, ih r0 _ _ r t' s' hrec⟩
-      show r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst
-      rw [Part.mem_map_iff]
-      exact ⟨(r0, bt, bs), hb, rfl⟩
-
-private lemma Prog.approx_nonmet_to_metered (body : Prog) (env : List Data) :
-    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data),
-      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i →
-      ∃ t' s', (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) := by
-  intro n
-  induction n with
-  | zero => intro i t s r h; exact absurd h (Part.notMem_none _)
-  | succ n ih =>
-    intro i t s r h
-    show ∃ t' s', (r, t', s') ∈
-        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s)
-    have hG : r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i := h
-    unfold Prog.nonmet_G at hG
-    unfold Prog.metered_F
-    simp only
-    by_cases hh : i.asList.headD (Data.l []) = Data.l []
-    · rw [if_pos hh] at hG; rw [if_pos hh]
-      rw [Part.mem_some_iff] at hG; subst hG
-      exact ⟨t, s, Part.mem_some _⟩
-    · rw [if_neg hh] at hG; rw [if_neg hh]
-      rw [Part.mem_bind_iff] at hG
-      obtain ⟨r0, hbody, hrec⟩ := hG
-      have hbody' : r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst := hbody
-      rw [Part.mem_map_iff] at hbody'
-      obtain ⟨⟨r0', bt, bs⟩, hmev, heq⟩ := hbody'
-      simp only at heq
-      have : r0' = r0 := heq
-      subst this
-      obtain ⟨t', s', hF⟩ := ih r0' (t + 1 + bt) (max s bs) r hrec
-      refine ⟨t', s', ?_⟩
-      rw [Part.mem_bind_iff]
-      exact ⟨(r0', bt, bs), hmev, hF⟩
-
-private lemma Prog.proj_fix_eq (body : Prog) (env : List Data) (i : Data) (t s : ℕ) :
-    (Part.fix (Prog.metered_F body env) (i, t, s)).map Prod.fst =
-      Prog.whileFrom_eval body env i := by
-  apply Part.ext
-  intro r
-  rw [Part.mem_map_iff]
-  let F_oh : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →o
-      ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) :=
-    ⟨Prog.metered_F body env, Prog.metered_F_monotone body env⟩
-  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
-    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
-  have hF_eq : ∀ {a b}, b ∈ Part.fix (Prog.metered_F body env) a ↔ b ∈ Part.fix (⇑F_oh) a := by
-    intros; rfl
-  have hG_eq : ∀ {a b}, b ∈ Part.fix (Prog.nonmet_G body env) a ↔ b ∈ Part.fix (⇑G_oh) a := by
-    intros; rfl
-  constructor
-  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
-    rw [hF_eq, Part.Fix.mem_iff F_oh] at hmem
-    obtain ⟨n, hn⟩ := hmem
-    show r' ∈ Prog.whileFrom_eval body env i
-    unfold Prog.whileFrom_eval
-    show r' ∈ Part.fix (Prog.nonmet_G body env) i
-    rw [hG_eq, Part.Fix.mem_iff G_oh]
-    exact ⟨n, Prog.approx_metered_to_nonmet body env n i t s r' _ _ hn⟩
-  · intro hr
-    have hr' : r ∈ Part.fix (Prog.nonmet_G body env) i := hr
-    rw [hG_eq, Part.Fix.mem_iff G_oh] at hr'
-    obtain ⟨n, hn⟩ := hr'
-    obtain ⟨t', s', hF⟩ := Prog.approx_nonmet_to_metered body env n i t s r hn
-    refine ⟨(r, t', s'), ?_, rfl⟩
-    rw [hF_eq, Part.Fix.mem_iff F_oh]
-    exact ⟨n, hF⟩
-
-/-- Pointwise (single-env) version for `while_`: the program evaluates `init`,
-then runs the loop body starting from that value. -/
-lemma Prog.while_eval {init body : Prog} {env : List Data} :
-    (Prog.while_ init body).eval env =
-      (init.eval env).bind (Prog.whileFrom_eval body env) := by
-  show (Prog.meteredEval env (Prog.while_ init body)).map Prod.fst = _
-  have hmEq : Prog.meteredEval env (Prog.while_ init body) =
-      (init.meteredEval env).bind (fun x =>
-        Part.fix (Prog.metered_F body env) (x.1, 1 + x.2.1, max 1 x.2.2)) := by
-    rw [Prog.meteredEval]; rfl
-  rw [hmEq]
-  apply Part.ext
-  intro r
-  rw [Part.mem_map_iff]
-  constructor
-  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
-    rw [Part.mem_bind_iff] at hmem
-    obtain ⟨⟨i, it, is⟩, hmi, hf⟩ := hmem
-    rw [Part.mem_bind_iff]
-    refine ⟨i, ?_, ?_⟩
-    · show i ∈ (init.meteredEval env).map Prod.fst
-      rw [Part.mem_map_iff]; exact ⟨_, hmi, rfl⟩
-    · rw [← Prog.proj_fix_eq body env i (1 + it) (max 1 is), Part.mem_map_iff]
-      exact ⟨_, hf, rfl⟩
-  · intro hr
-    rw [Part.mem_bind_iff] at hr
-    obtain ⟨i, hi, hr2⟩ := hr
-    have hi' : i ∈ (init.meteredEval env).map Prod.fst := hi
-    rw [Part.mem_map_iff] at hi'
-    obtain ⟨⟨i', it, is⟩, hmi, heq⟩ := hi'
-    simp only at heq
-    have hii : i' = i := heq
-    subst hii
-    rw [← Prog.proj_fix_eq body env i' (1 + it) (max 1 is), Part.mem_map_iff] at hr2
-    obtain ⟨⟨r', t', s'⟩, hF, rfl⟩ := hr2
-    refine ⟨(r', t', s'), ?_, rfl⟩
-    rw [Part.mem_bind_iff]
-    exact ⟨(i', it, is), hmi, hF⟩
-
-/-- Termination-extraction for `whileFrom_eval`: if the loop returns `.some r`,
-then there exists an iteration index `n` such that running the body `n` times
-from `acc` along the (deterministic) trajectory yields `r`, the halt condition
-holds at `r`, and the halt condition does not hold at any intermediate value. -/
-lemma Prog.whileFrom_eval_some {body : Prog} {env : List Data} {acc r : Data}
-    (h : Prog.whileFrom_eval body env acc = .some r) :
-    ∃ (n : ℕ) (traj : ℕ → Data),
-      traj 0 = acc ∧
-      traj n = r ∧
-      (r.asList.headD (Data.l []) = Data.l []) ∧
-      (∀ k < n,
-          (traj k).asList.headD (Data.l []) ≠ Data.l [] ∧
-          body.eval (env ++ [traj k]) = .some (traj (k+1))) := by
-  -- Helper: induct on approx index to extract a trajectory.
-  have approx_some_traj : ∀ (n : ℕ) (acc r : Data),
-      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n acc →
-      ∃ (k : ℕ) (traj : ℕ → Data),
-        traj 0 = acc ∧ traj k = r ∧
-        (r.asList.headD (Data.l []) = Data.l []) ∧
-        (∀ j < k, (traj j).asList.headD (Data.l []) ≠ Data.l [] ∧
-                  body.eval (env ++ [traj j]) = .some (traj (j+1))) := by
-    intro n
-    induction n with
-    | zero => intro acc r h; exact absurd h (Part.notMem_none _)
-    | succ n ih =>
-      intro acc r h
-      have hG : r ∈ (Prog.nonmet_G body env)
-          (Part.Fix.approx (Prog.nonmet_G body env) n) acc := h
-      unfold Prog.nonmet_G at hG
-      by_cases hh : acc.asList.headD (Data.l []) = Data.l []
-      · rw [if_pos hh] at hG
-        rw [Part.mem_some_iff] at hG
-        cases hG
-        refine ⟨0, fun _ => acc, rfl, rfl, hh, ?_⟩
-        intro j hj; omega
-      · rw [if_neg hh] at hG
-        rw [Part.mem_bind_iff] at hG
-        obtain ⟨r0, hbody, hrec⟩ := hG
-        obtain ⟨k, traj', htraj0, htrajk, hr_halt, hsteps⟩ := ih r0 r hrec
-        refine ⟨k + 1, fun j => if j = 0 then acc else traj' (j - 1),
-                by simp, ?_, hr_halt, ?_⟩
-        · show (if k + 1 = 0 then acc else traj' (k + 1 - 1)) = r
-          rw [if_neg (by omega)]
-          have : k + 1 - 1 = k := by omega
-          rw [this]; exact htrajk
-        · intro j hj
-          cases j with
-          | zero =>
-            show (if (0 : ℕ) = 0 then acc else traj' (0 - 1)).asList.headD (Data.l []) ≠ Data.l [] ∧
-                 body.eval (env ++ [if (0 : ℕ) = 0 then acc else traj' (0 - 1)]) =
-                  .some (if (0 + 1 : ℕ) = 0 then acc else traj' (0 + 1 - 1))
-            simp only [if_true, if_neg (Nat.succ_ne_zero 0)]
-            refine ⟨hh, ?_⟩
-            have heval : body.eval (env ++ [acc]) = .some r0 :=
-              (Part.eq_some_iff.mpr hbody)
-            rw [heval]; congr 1
-            show r0 = traj' 0
-            exact htraj0.symm
-          | succ j =>
-            show (if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)).asList.headD
-                  (Data.l []) ≠ Data.l [] ∧
-                 body.eval (env ++ [if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)]) =
-                  .some (if (j + 1 + 1 : ℕ) = 0 then acc else traj' (j + 1 + 1 - 1))
-            rw [if_neg (Nat.succ_ne_zero _), if_neg (Nat.succ_ne_zero _)]
-            have hjk : j < k := by omega
-            have h_idx1 : (j + 1 - 1 : ℕ) = j := by omega
-            have h_idx2 : (j + 1 + 1 - 1 : ℕ) = j + 1 := by omega
-            rw [h_idx1, h_idx2]
-            exact hsteps j hjk
-  have hmem : r ∈ Prog.whileFrom_eval body env acc := by rw [h]; exact Part.mem_some _
-  have hmem' : r ∈ Part.fix (Prog.nonmet_G body env) acc := hmem
-  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
-    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
-  have hmem'' : r ∈ Part.fix (⇑G_oh) acc := hmem'
-  rw [Part.Fix.mem_iff G_oh] at hmem''
-  obtain ⟨n, hn⟩ := hmem''
-  exact approx_some_traj n acc r hn
-
-def Prog.Total (p : Prog) : Prop := ∀ env, (p.meteredEval env).Dom
-
-@[simp]
-def Prog.WhileFree (p : Prog) : Prop :=
-  match p with
-  | .var _ => True
-  | .letin val rest => Prog.WhileFree val ∧ Prog.WhileFree rest
-  | .empty => True
-  | .cons h t => Prog.WhileFree h ∧ Prog.WhileFree t
-  | .elim v em cs => Prog.WhileFree v ∧ Prog.WhileFree em ∧ Prog.WhileFree cs
-  | .eq a b => Prog.WhileFree a ∧ Prog.WhileFree b
-  | .fold body init list => Prog.WhileFree body ∧ Prog.WhileFree init ∧ Prog.WhileFree list
-  | .while_ _ _ => False
-
-theorem total_of_whileFree (p : Prog) (h_wf : p.WhileFree) : p.Total := by sorry
-
-/-- Evaluation of while-free programs. Do not expand this, because `Part` is cumbersome to
-deal with. -/
-def Prog.meteredEvalT (p : Prog) (h_wf : p.WhileFree) (env : List Data) : Data × ℕ × ℕ :=
-  (p.meteredEval env).get (total_of_whileFree p h_wf env)
-
-/-! ## Surface syntax with named binders
-
-Define convenience builder functions to allow binding the variables to names.
-
- -/
-
-/-- A program builder: given the current binder depth (i.e. the size of `env`
-at the point of insertion), produce a `Prog`. -/
-abbrev PB := ℕ → Prog
-
-namespace PB
-
-def empty : PB := fun _ => .empty
-def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
-def eq (a b : PB) : PB := fun n => .eq (a n) (b n)
-
-/-- `letIn val (fun x => body)`: bind the value of `val` as a fresh variable `x`
-visible in `body`. -/
-def letIn (val : PB) (body : PB → PB) : PB := fun n =>
-  .letin (val n) (body (fun _ => .var n) (n + 1))
-
-/-- `elim v em (fun head tail => body)`: case-analyse the result of `v`. -/
-def elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
-  .elim (v n) (em n) (cs (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2))
-
-/-- `fold (fun acc x => body) init list`: run `body` for each element `x`
-threading accumulator `acc`. -/
-def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
-  .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
-
-/-- `while_ init (fun acc => body)`. -/
-def while_ (init : PB) (body : PB → PB) : PB := fun n =>
-  .while_ (init n) (body (fun _ => .var n) (n + 1))
-
-/-- Close a builder into a concrete `Prog`. -/
-def build (p : PB) : Prog := p 0
-
-
-end PB
-
--------------------------------------
---- Encoding of generic types into Data
---------------------------------------
-
-class DataEncode (α : Type) where
-  encode : α → Data
-  h_inj : encode.Injective
-
-instance : DataEncode Bool where
-  encode b := if b then Data.l [ Data.l [] ] else Data.l []
-  h_inj := by intros a b h_eq; grind
-
-instance (α : Type) [DataEncode α] : DataEncode (List α) where
-  encode xs := Data.l (xs.map DataEncode.encode)
-  h_inj := by
-    intro a b h
-    have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode :=
-      Data.l.inj h
-    exact List.map_injective_iff.mpr DataEncode.h_inj h'
-
-@[simp, grind =]
-lemma DataEncode_list_nil {α : Type} [DataEncode α] :
-  DataEncode.encode ([] : List α) = Data.l [] := by
-  simp [DataEncode.encode]
-
-@[simp, grind =]
-lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
-  DataEncode.encode xs = Data.empty ↔ xs = [] := by
-  simp [DataEncode.encode]
-
-@[simp, scoped grind =]
-lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
-  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
-  simp [DataEncode.encode]
-
-instance (α : Type) [DataEncode α] : DataEncode (Option α) where
-  encode := fun
-    | none => Data.l []
-    | some x => Data.l [DataEncode.encode x]
-  h_inj := by
-    intro a b h
-    cases a <;> cases b <;> simp_all
-    exact DataEncode.h_inj h
-
-@[simp]
-lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
-  (DataEncode.encode x == Data.empty) = x.isNone := by
-  cases x <;> simp [DataEncode.encode, Data.empty]
-
-instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
-  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
-  h_inj := by
-    intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h
-    simp at h
-    exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩
-
-lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
-  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
-  simp [DataEncode.encode]
-
-instance : DataEncode ℕ where
-  encode x := DataEncode.encode (Nat.bits x)
-  h_inj := by
-    intro a b h
-    have hb : a.bits = b.bits := DataEncode.h_inj h
-    -- Reconstruct a from a.bits via binaryRec.
-    have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by
-      intro n
-      induction n using Nat.binaryRec' with
-      | zero => simp
-      | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih]
-    have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb
-    simpa [hrec] using this
-
-----------------------------------------------------
-
-def PB.computes (impl : PB) (f : List Data → Data) : Prop :=
-  ∀ env, (impl env.length).eval env = .some (f env)
-
--------------------------------------------------------
---- combinator semantics
-----------------------------------------------------
-
-@[simp]
-lemma meteredEvalT_var_val {env : List Data} {i : ℕ} :
-  ((Prog.var i).meteredEvalT (by simp) env).1 = env[i]?.getD (Data.l []) := by
-  simp [Prog.meteredEvalT, Prog.meteredEval]
-
-@[simp]
-lemma meteredEvalT_empty_val {env : List Data} :
-  ((Prog.empty).meteredEvalT (by simp) env).1 = Data.l [] := by
-  simp [Prog.meteredEvalT, Prog.meteredEval]
-
-lemma meteredEvalT_elim_val {env : List Data} {v em cs : Prog}
-    {h_wf : (Prog.elim v em cs).WhileFree} :
-  ((Prog.elim v em cs).meteredEvalT h_wf env).1 =
-    match ((v.meteredEvalT h_wf.1 env).1) with
-    | Data.l [] => ((em.meteredEvalT h_wf.2.1 env).1)
-    | Data.l (head :: tail) => ((cs.meteredEvalT h_wf.2.2 (env ++ [head, Data.l tail])).1) := by
-  sorry
--------------------------------------------------------------------
---- tools
--------------------------------------------
-
-lemma list_getElem_length_add {α : Type} (xs ys : List α) (i : ℕ) (h_lt : i < ys.length) :
-  (xs ++ ys)[xs.length + i]'(by grind) = ys[i] := by
-  sorry
-
-/-- Example: `tail x` returns the tail of the list bound at variable `x`, or `empty`
-    if `x` denotes the empty list. Built with `elim`: the empty branch yields `empty`,
-    the cons branch ignores the head and projects the bound tail. -/
-def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
-def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
-
-/-! ### Compositional `computes` rules for `PB` combinators
-
-The pattern: each combinator takes its `PB` arguments **paired with their `computes`
-specs**, and yields a `computes` for the composite. -/
-
-@[simp] lemma PB.empty_computes : PB.empty.computes (fun _ => Data.l []) := by
-  intro env
-  simp [PB.empty, Prog.eval, Prog.meteredEval]
-
-/-- The "bound-variable look-up" PB: at binder depth `n` it produces `var (n + offset)`. -/
-def PB.bound (offset : ℕ) : PB := fun n => Prog.var (n + offset)
-
-lemma PB.bound_computes (offset : ℕ) :
-    (PB.bound offset).computes (fun env => env[env.length + offset]?.getD (Data.l [])) := by
-  simp [PB.bound, PB.computes, Prog.eval, Prog.meteredEval]
-
-lemma PB.cons_computes {h t : PB} {fh ft : List Data → Data}
-    (hh : h.computes fh) (ht : t.computes ft) :
-    (PB.cons h t).computes (fun env => Data.l (fh env :: (ft env).asList)) := by
-  intro env
-  simp only [PB.cons]
-  exact Prog.cons_eval (hh env) (ht env)
-
-/-- Inside an `elim cs` branch, the two PBs passed to `cs` are constant closures
-returning `.var n` and `.var (n+1)`, where `n = env.length` at the outer call site.
-The body is then evaluated under env extended with `[head, Data.l tail]`.
-
-The spec for `cs` must therefore be parametric in the slot `n`: assume that for
-every `slot`, the body built with the two constant lookups computes a function
-expressed in terms of those two slot positions. -/
-lemma PB.elim_computes {v em : PB} {cs : PB → PB → PB}
-    {fv fem : List Data → Data}
-    {fcs : List Data → Data → Data → Data}
-    (hv : v.computes fv) (hem : em.computes fem)
-    (hcs : ∀ slot : ℕ,
-      (cs (fun _ => .var slot) (fun _ => .var (slot + 1))).computes
-        (fun env' => fcs (env'.take slot)
-                         (env'[slot]?.getD (Data.l []))
-                         (env'[slot + 1]?.getD (Data.l [])))) :
-    (PB.elim v em cs).computes (fun env =>
-      match (fv env).asList with
-      | [] => fem env
-      | head :: tail => fcs env head (Data.l tail)) := by
-  intro env
-  simp only [PB.elim]
-  -- Apply pointwise elim eval with hv env.
-  rw [Prog.elim_eval (hv env)]
-  -- Case split on (fv env).asList.
-  match h_fv : (fv env).asList with
-  | [] =>
-    simp only
-    exact hem env
-  | head :: tail =>
-    simp only
-    -- The cs body, instantiated at slot = env.length, computes the right function;
-    -- specialise its `computes` hypothesis to env' = env ++ [head, Data.l tail].
-    have hcs_inst := hcs env.length (env ++ [head, Data.l tail])
-    -- Beta-reduce the spec function on the extended env.
-    simp only at hcs_inst
-    -- The depth at the body's call site is (env ++ [head, Data.l tail]).length = env.length + 2.
-    have hlen : (env ++ [head, Data.l tail]).length = env.length + 2 := by simp
-    rw [hlen] at hcs_inst
-    have h_take : (env ++ [head, Data.l tail]).take env.length = env := by
-      simp
-    have h_get0 : (env ++ [head, Data.l tail])[env.length]? = some head := by
-      simp [List.getElem?_append_right]
-    have h_get1 : (env ++ [head, Data.l tail])[env.length + 1]? = some (Data.l tail) := by
-      simp [List.getElem?_append_right]
-    rw [h_take, h_get0, h_get1] at hcs_inst
-    simp only [Option.getD_some] at hcs_inst
-    exact hcs_inst
-
-lemma PB.elim_computes' {v em : PB} {cs : PB → PB → PB}
-    {fv fem : List Data → Data}
-    {fcs : Data → Data → List Data → Data}
-    (hv : v.computes fv) (hem : em.computes fem)
-    (hcs : ∀ slot : ℕ,
-      (cs (fun _ => .var slot) (fun _ => .var (slot + 1))).computes
-        (fun env' => fcs (env'[slot]?.getD (Data.l []))
-                         (env'[slot + 1]?.getD (Data.l []))
-                         (env'.take slot))) :
-    (PB.elim v em cs).computes (fun env =>
-      match (fv env).asList with
-      | [] => fem env
-      | head :: tail => fcs head (Data.l tail) env) := by
-  sorry
-
-/-- `PB.tail` computes the tail-of-list function applied to the spec of its argument.
-This is the direct combinator-level spec, obtainable from `PB.elim_computes` with
-`em := PB.empty` and `cs head tl := tl`. -/
-lemma PB.tail_computes {x : PB} {fx : List Data → Data} (hx : x.computes fx) :
-    (PB.tail x).computes (fun env => Data.l (fx env).asList.tail) := by
-  unfold PB.tail
-  have h := PB.elim_computes (cs := fun _head tl => tl)
-    (fv := fx) (fem := fun _ => Data.l [])
-    (fcs := fun _env _head tl => tl)
-    hx PB.empty_computes
-    (by
-      intro slot env'
-      simp [Prog.eval, Prog.meteredEval]
-      rfl)
-  intro env
-  have he := h env
-  simp only at he
-  change _ = Part.some (Data.l (fx env).asList.tail)
-  suffices h_eq :
-      (match (fx env).asList with
-       | [] => Data.l []
-       | _head :: tail => Data.l tail) = Data.l (fx env).asList.tail by
-    rw [← h_eq]; exact he
-  rcases (fx env).asList with _ | ⟨head, tail⟩
-  · rfl
-  · rfl
-
-/-- Same for `PB.head`. -/
-lemma PB.head_computes {x : PB} {fx : List Data → Data} (hx : x.computes fx) :
-    (PB.head x).computes (fun env => (fx env).asList.headD (Data.l [])) := by
-  sorry
-
-lemma PB.letIn_computes {val : PB} {body : PB → PB}
-    {fv : List Data → Data} {fb : List Data → Data → Data}
-    (hv : val.computes fv)
-    (hb : (body (PB.bound 0)).computes
-            (fun env => fb env.dropLast ((env.getLast?).getD (Data.l [])))) :
-    (PB.letIn val body).computes (fun env => fb env (fv env)) := by
-  sorry
-
-/-! ## Alternative reasoning layers
-
-The `PB.computes` framework above is awkward because the universal quantification
-over `env` is coupled to the depth `env.length` at which the PB is unfolded.
-Below are two lighter-weight alternatives. -/
-
-/-! ### Option A: pointwise `Prog`-level `simp` set
-
-Lifting eval rules to `@[simp]` lemmas lets you discharge most goals of the form
-`p.eval env = .some d` by `simp` plus at most one `rcases` on a list. -/
-
-@[simp] lemma Prog.var_eval {env : List Data} {i : ℕ} :
-    (Prog.var i).eval env = .some (env[i]?.getD (Data.l [])) := by
-  simp [Prog.eval, Prog.meteredEval]
-
-@[simp] lemma Prog.empty_eval {env : List Data} :
-    Prog.empty.eval env = .some (Data.l []) := by
-  simp [Prog.eval, Prog.meteredEval, Data.empty]
-
-@[simp] lemma Prog.cons_eval_simp {env : List Data} {h t : Prog} {dh dt : Data}
-    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
-    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) :=
-  Prog.cons_eval hh ht
-
-@[simp] lemma Prog.elim_eval_nil {env : List Data} {v em cs : Prog}
-    (hv : v.eval env = .some (Data.l [])) :
-    (Prog.elim v em cs).eval env = em.eval env := by
-  have := Prog.elim_eval (em := em) (cs := cs) hv
-  simpa using this
-
-@[simp] lemma Prog.elim_eval_cons {env : List Data} {v em cs : Prog}
-    {head : Data} {tail : List Data}
-    (hv : v.eval env = .some (Data.l (head :: tail))) :
-    (Prog.elim v em cs).eval env = cs.eval (env ++ [head, Data.l tail]) := by
-  have := Prog.elim_eval (em := em) (cs := cs) hv
-  simpa using this
-
-@[simp] lemma Prog.letin_eval {env : List Data} {val rest : Prog} {dv : Data}
-    (hv : val.eval env = .some dv) :
-    (Prog.letin val rest).eval env = rest.eval (env ++ [dv]) := by
-  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
-  show (Prog.meteredEval env (Prog.letin val rest)).map Prod.fst = _
-  rw [Prog.meteredEval, hmv]
-  simp only [bind, Part.bind_some]
-  rw [Prog.eval]; ext d
-  simp [Part.mem_map_iff, Part.mem_bind_iff]
-
-@[simp] lemma Prog.eq_eval {env : List Data} {a b : Prog} {da db : Data}
-    (ha : a.eval env = .some da) (hb : b.eval env = .some db) :
-    (Prog.eq a b).eval env =
-      .some (if da = db then Data.l [Data.l []] else Data.l []) := by
-  obtain ⟨ta, sa, hma⟩ := Prog.eval_some_iff_meteredEval.mp ha
-  obtain ⟨tb, sb, hmb⟩ := Prog.eval_some_iff_meteredEval.mp hb
-  show (Prog.meteredEval env (Prog.eq a b)).map Prod.fst = _
-  rw [Prog.meteredEval, hma]
-  simp only [bind, Part.bind_some, hmb, beq_iff_eq]
-  by_cases h : da = db <;> simp [h, Part.map_some]
-
-/-- Helper for `Prog.fold_eval`: chained `foldlM` over `meteredEval`. -/
-private lemma Prog.foldlM_chain (body : Prog) (env : List Data)
-    (acc : ℕ → Data) :
-    ∀ (dl : List Data) (start : ℕ) (t s : ℕ),
-      (∀ k (h : k < dl.length),
-        body.eval (env ++ [acc (start + k), dl[k]]) = .some (acc (start + k + 1))) →
-      ∃ t' s', List.foldlM
-        (fun x el => (body.meteredEval (env ++ [x.1, el])).bind fun y =>
-          pure (y.1, 1 + x.2.1 + y.2.1, max x.2.2 y.2.2))
-        (acc start, t, s) dl = .some (acc (start + dl.length), t', s') := by
-  intro dl
-  induction dl with
-  | nil => intro start t s _hstep
-           refine ⟨t, s, ?_⟩
-           simp [List.foldlM]
-  | cons hd tl ih =>
-    intro start t s hstep
-    have h0 : body.eval (env ++ [acc start, hd]) = .some (acc (start + 1)) := by
-      have := hstep 0 (by simp)
-      simpa using this
-    obtain ⟨bt, bs, hmb⟩ := Prog.eval_some_iff_meteredEval.mp h0
-    simp only [List.foldlM_cons, List.length_cons, hmb, Part.bind_some, pure, bind]
-    have hstep' : ∀ k (h : k < tl.length),
-        body.eval (env ++ [acc ((start + 1) + k), tl[k]]) = .some (acc ((start + 1) + k + 1)) := by
-      intro k hk
-      have hh : k + 1 < (hd :: tl).length := by rw [List.length_cons]; omega
-      have := hstep (k + 1) hh
-      have h_eq : (hd :: tl)[k + 1] = tl[k] := by simp
-      rw [h_eq] at this
-      have h1 : start + 1 + k = start + (k + 1) := by omega
-      rw [h1]; exact this
-    obtain ⟨t', s', ih_res⟩ := ih (start + 1) (1 + t + bt) (max s bs) hstep'
-    refine ⟨t', s', ?_⟩
-    have h_len : start + (tl.length + 1) = (start + 1) + tl.length := by omega
-    rw [h_len]; exact ih_res
-
-/-- Semantic spec for `Prog.fold`. Rather than quantifying the body universally
-over arbitrary `Data` accumulators/elements, we parameterise by the actually
-visited accumulator sequence `acc : ℕ → Data`. This makes the lemma usable both
-for untyped and typed/encoded fold reasoning. -/
-lemma Prog.fold_eval {env : List Data} {body init list : Prog}
-    {da : Data} {dl : List Data} {result : Data}
-    (hi : init.eval env = .some da)
-    (hl : list.eval env = .some (Data.l dl))
-    (acc : ℕ → Data)
-    (hacc0 : acc 0 = da)
-    (haccN : acc dl.length = result)
-    (hstep : ∀ k (h : k < dl.length),
-      body.eval (env ++ [acc k, dl[k]]) = .some (acc (k+1))) :
-    (Prog.fold body init list).eval env = .some result := by
-  obtain ⟨it, is, hmi⟩ := Prog.eval_some_iff_meteredEval.mp hi
-  obtain ⟨lt, ls, hml⟩ := Prog.eval_some_iff_meteredEval.mp hl
-  rw [← hacc0] at hmi
-  have hstep' : ∀ k (h : k < dl.length),
-      body.eval (env ++ [acc (0 + k), dl[k]]) = .some (acc (0 + k + 1)) := by
-    intro k hk; simpa using hstep k hk
-  obtain ⟨t', s', hfold⟩ := Prog.foldlM_chain body env acc dl 0 (1 + it + lt) (max is ls) hstep'
-  show (Prog.meteredEval env (Prog.fold body init list)).map Prod.fst = _
-  rw [Prog.meteredEval, hmi]
-  simp only [bind, Part.bind_some, hml, Data.l_asList]
-  rw [hfold]
-  simp [haccN]
-
-/-- Example: with the `simp` set above, the `tail` spec on a concrete env is short. -/
-example {env : List Data} {x : Prog} {dx : Data} (hx : x.eval env = .some dx) :
-    (Prog.elim x Prog.empty (Prog.var (env.length + 1))).eval env =
-      .some (Data.l dx.asList.tail) := by
-  rcases h : dx.asList with _ | ⟨head, tail⟩
-  · have hx' : x.eval env = .some (Data.l []) := by
-      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
-    simp [Prog.elim_eval_nil hx']
-  · have hx' : x.eval env = .some (Data.l (head :: tail)) := by
-      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
-    rw [Prog.elim_eval_cons hx', Prog.var_eval]
-    have hidx : (env ++ [head, Data.l tail])[env.length + 1]? = some (Data.l tail) := by
-      simp [List.getElem?_append_right]
-    simp only [hidx, Option.getD_some]
-    rfl
-
-/-! ### Option C: per-env `PB.computes_at`
-
-A pointwise version of `PB.computes` that talks about a specific env. -/
-
-/-- `PB.computes_at env impl d`: for every extension `ext` of `env`, when the
-program is unfolded at depth `(env ++ ext).length` and evaluated on `env ++ ext`,
-it yields `d`. The `∀ ext` quantifier captures the fact that well-formed PBs
-preserve their value under env-extension, which is essential for composing them
-inside binders. -/
-def PB.computes_at (env : List Data) (impl : PB) (d : Data) : Prop :=
-  ∀ ext : List Data,
-    (impl (env.length + ext.length)).eval (env ++ ext) = .some d
-
-/-- The basic per-env consequence, instantiating `ext := []`. -/
-lemma PB.computes_at.here {env : List Data} {impl : PB} {d : Data}
-    (h : PB.computes_at env impl d) :
-    (impl env.length).eval env = .some d := by
-  simpa using h []
-
-/-- Weakening: extending the env preserves `computes_at`. -/
-@[simp]
-lemma PB.computes_at.extend {env ext : List Data} {impl : PB} {d : Data}
-    (h : PB.computes_at env impl d) :
-    PB.computes_at (env ++ ext) impl d := by
-  intro ext'
-  have := h (ext ++ ext')
-  simpa [List.append_assoc, Nat.add_assoc] using this
-
-@[simp, grind .]
-lemma PB.var_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
-    PB.computes_at env (fun _ => .var i) env[i] := by
-  intro ext
-  simp [Prog.eval, Prog.meteredEval, List.getElem?_append_left h]
-  grind
-
-@[simp]
-lemma PB.var_last_computes_at {env ext : List Data} {d : Data} :
-    PB.computes_at (env ++ ext ++ [d])
-      (fun _ => Prog.var (env.length + ext.length)) d := by
-  have hlen : env.length + ext.length < (env ++ ext ++ [d]).length := by simp
-  have h := PB.var_computes_at (env := env ++ ext ++ [d]) hlen
-  convert h using 2
-  simp [List.getElem_append]
-
-@[simp, grind .]
-lemma PB.empty_computes_at {env : List Data} :
-    PB.computes_at env PB.empty (Data.l []) := by
-  intro ext
-  simp [PB.empty, Prog.eval, Prog.meteredEval]
-
-@[simp, grind .]
-lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
-    (hh : PB.computes_at env h dh) (ht : PB.computes_at env t dt) :
-    PB.computes_at env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
-  intro ext
-  simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
-
-lemma PB.eq_computes_at {env : List Data} {a b : PB} {da db : Data}
-    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db) :
-    PB.computes_at env (PB.eq a b)
-      (if da = db then Data.l [Data.l []] else Data.l []) := by
-  intro ext
-  simpa [PB.eq] using Prog.eq_eval (ha ext) (hb ext)
-
-/-! ### Body-of-binder abstraction
-
-The hypothesis shape arising for the body of a binder (`elim`, `letin`, `fold`,
-…) is that the body PB, built from var-lookup PBs for each new binding,
-computes the result on the env extended with those bindings, for any outer
-extension `ext`. We package this as `PB.computes_at_body` with arity-typed
-convenience wrappers. -/
-
-/-- Depth-agnostic var-lookup PB: `PB.atSlot i = fun _ => .var i`. -/
-def PB.atSlot (i : ℕ) : PB := fun _ => .var i
-
-@[simp]
-lemma PB.atSlot_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
-    PB.computes_at env (PB.atSlot i) env[i] :=
-  PB.var_computes_at h
-
-@[simp]
-lemma PB.atSlot_last_computes_at {env ext : List Data} {d : Data} :
-    PB.computes_at (env ++ ext ++ [d])
-      (PB.atSlot (env.length + ext.length)) d :=
-  PB.var_last_computes_at
-
-@[simp]
-lemma PB.atSlot_last_computes_at_right {env ext : List Data} {d : Data} :
-    PB.computes_at (env ++ (ext ++ [d]))
-      (PB.atSlot (env.length + ext.length)) d := by
-  rw [← List.append_assoc]; exact PB.atSlot_last_computes_at
-
-/-- Body-of-binder hypothesis. `mkBody` is an arity-`bindings.length` body
-builder that receives the var-lookup PBs for each binding and produces a PB.
-The result must compute `dr` on `env` extended with `bindings` (under any
-outer extension `ext`). -/
-def PB.computes_at_body (env : List Data) (bindings : List Data)
-    (mkBody : (Fin bindings.length → PB) → PB) (dr : Data) : Prop :=
-  ∀ ext : List Data,
-    PB.computes_at (env ++ ext ++ bindings)
-      (mkBody (fun i => PB.atSlot (env.length + ext.length + i))) dr
-
-/-- Arity-1 convenience: one new binding `b`, body `body : PB → PB`. -/
-abbrev PB.computes_at_body₁ (env : List Data) (b : Data)
-    (body : PB → PB) (dr : Data) : Prop :=
-  PB.computes_at_body env [b] (fun a => body (a 0)) dr
-
-/-- Arity-2 convenience: two new bindings `b₁, b₂`, body `body : PB → PB → PB`. -/
-abbrev PB.computes_at_body₂ (env : List Data) (b₁ b₂ : Data)
-    (body : PB → PB → PB) (dr : Data) : Prop :=
-  PB.computes_at_body env [b₁, b₂] (fun a => body (a 0) (a 1)) dr
-
-/-- `elim` at a fixed env, nil branch. -/
-@[grind .]
-lemma PB.elim_nil_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
-    {dr : Data}
-    (hv : PB.computes_at env v (Data.l []))
-    (hem : PB.computes_at env em dr) :
-    PB.computes_at env (PB.elim v em cs) dr := by
-  intro ext
-  simp only [PB.elim]
-  rw [Prog.elim_eval_nil (hv ext)]
-  exact hem ext
-
-/-- `elim` at a fixed env, cons branch. The body hypothesis is packaged as
-`PB.computes_at_body₂`: `cs`, applied to the var-lookup PBs for `head` and
-`Data.l tail`, computes `dr` on the env extended with `[head, Data.l tail]`. -/
-@[grind .]
-lemma PB.elim_cons_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
-    {head : Data} {tail : List Data} {dr : Data}
-    (hv : PB.computes_at env v (Data.l (head :: tail)))
-    (hcs : PB.computes_at_body₂ env head (Data.l tail) cs dr) :
-    PB.computes_at env (PB.elim v em cs) dr := by
-  intro ext
-  simp only [PB.elim]
-  rw [Prog.elim_eval_cons (hv ext)]
-  have h := (hcs ext).here
-  simpa [PB.atSlot, List.append_assoc] using h
-
-/-- The slot-lookup PB for `head` in the body of an `elim` (or any 2-binding
-body). -/
-lemma PB.elim_cons_head_var_computes_at {env ext : List Data}
-    {head : Data} {tail : Data} :
-    PB.computes_at (env ++ ext ++ [head, tail])
-      (PB.atSlot (env.length + ext.length)) head := by
-  show PB.computes_at _ (fun _ => .var (env.length + ext.length)) _
-  have hlen : env.length + ext.length
-      < (env ++ ext ++ [head, tail]).length := by simp
-  grind [PB.var_computes_at hlen]
-
-/-- The slot-lookup PB for the second binding in the body of an `elim`. -/
-lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
-    {head : Data} {tail : Data} :
-    PB.computes_at (env ++ ext ++ [head, tail])
-      (PB.atSlot (env.length + ext.length + 1)) tail := by
-  show PB.computes_at _ (fun _ => .var (env.length + ext.length + 1)) _
-  have hlen : env.length + ext.length + 1
-      < (env ++ ext ++ [head, tail]).length := by simp; omega
-  grind [PB.var_computes_at hlen]
-
-/-- `fold` at a fixed env: lifts `Prog.fold_eval` pointwise. The body hypothesis
-is packaged as `PB.computes_at_body₂` parameterised over the current
-accumulator `acc` and element `el`. -/
-lemma PB.fold_computes_at {env : List Data} {init list : PB}
-    {body : PB → PB → PB}
-    {da : Data} {dl : List Data} {f : Data → Data → Data}
-    (hi : PB.computes_at env init da)
-    (hl : PB.computes_at env list (Data.l dl))
-    (hbody : ∀ acc el, PB.computes_at_body₂ env acc el body (f acc el)) :
-    PB.computes_at env (PB.fold body init list) (dl.foldl f da) := by
-  intro ext
-  simp only [PB.fold]
-  refine Prog.fold_eval (hi ext) (hl ext)
-    (fun k => (dl.take k).foldl f da) rfl (by simp) ?_
-  intro k hk
-  have h := (hbody ((dl.take k).foldl f da) dl[k] ext).here
-  have hfoldl_succ :
-      (dl.take (k+1)).foldl f da = f ((dl.take k).foldl f da) dl[k] := by
-    rw [List.take_succ, List.foldl_append]
-    simp [List.getElem?_eq_getElem hk]
-  simp only [hfoldl_succ]
-  simpa [PB.atSlot, List.append_assoc] using h
-
-/-! ### Spec for `PB.while_`
-
-`PB.while_ init body` is a real while loop: it starts from `init`, checks the
-halt condition (`asList.headD = []`) on the current accumulator, and either
-returns it (halt) or runs `body` and loops with the body's result. -/
-
-/-- Generic iteration spec for `PB.while_`. The result is `f^[N] init` where
-`N` is the smallest iteration index whose encoding's `headD` is empty. -/
-lemma PB.while_computes_iter {α : Type} [DataEncode α]
-    {env : List Data} {p_init : PB} {body : PB → PB}
-    (f : α → α) (init : α)
-    (h_init : PB.computes_at env p_init (DataEncode.encode init))
-    (h_body : ∀ c, PB.computes_at_body₁ env (DataEncode.encode c) body
-        (DataEncode.encode (f c)))
-    (h_halts : ∃ n, (DataEncode.encode (f^[n] init)).asList.headD (Data.l []) = Data.l []) :
-    PB.computes_at env (PB.while_ p_init body) (DataEncode.encode (f^[Nat.find h_halts] init)) := by
-  intro ext
-  set n := env.length + ext.length with hn
-  set bd : Prog := body (fun _ => .var n) (n + 1) with bd_def
-  -- Unfold one level of `while_` at depth `n`.
-  change (Prog.while_ (p_init n) bd).eval (env ++ ext) = _
-  rw [Prog.while_eval]
-  rw [show (p_init n).eval (env ++ ext) = .some (DataEncode.encode init) by
-        simpa [hn] using h_init ext, Part.bind_some]
-  -- Reduce to a statement about `whileFrom_eval`.
-  set N := Nat.find h_halts with N_def
-  suffices ∀ k, k ≤ N →
-      Prog.whileFrom_eval bd (env ++ ext) (DataEncode.encode (f^[k] init))
-        = .some (DataEncode.encode (f^[N] init)) from this 0 (Nat.zero_le _)
-  intro k hk
-  -- Induct on the distance to `N`.
-  induction hd : N - k generalizing k with
-  | zero =>
-    have hkN : k = N := by omega
-    subst hkN
-    exact Prog.whileFrom_eval_halt (Nat.find_spec h_halts)
-  | succ m ih =>
-    have hkN : k < N := by omega
-    have h_not_halt :
-        (DataEncode.encode (f^[k] init)).asList.headD (Data.l []) ≠ Data.l [] :=
-      Nat.find_min h_halts hkN
-    rw [Prog.whileFrom_eval_step h_not_halt]
-    -- The body computes `f` at `f^[k] init`.
-    have h_body_eval : bd.eval ((env ++ ext) ++ [DataEncode.encode (f^[k] init)]) =
-        .some (DataEncode.encode (f (f^[k] init))) := by
-      have h := (h_body (f^[k] init) ext).here
-      simpa [bd_def, hn, PB.atSlot] using h
-    rw [h_body_eval, Part.bind_some]
-    rw [show f (f^[k] init) = f^[k+1] init from (Function.iterate_succ_apply' f k init).symm]
-    exact ih (k + 1) (by omega) (by omega)
-
-
-/-- `letIn` at a fixed env: the body hypothesis is packaged as `PB.computes_at_body₁`. -/
-lemma PB.letIn_computes_at {env : List Data} {val : PB} {body : PB → PB}
-    {dv dr : Data}
-    (hv : PB.computes_at env val dv)
-    (hbody : PB.computes_at_body₁ env dv body dr) :
-    PB.computes_at env (PB.letIn val body) dr := by
-  intro ext
-  show (Prog.letin (val (env.length + ext.length))
-      (body (fun _ => Prog.var (env.length + ext.length))
-        (env.length + ext.length + 1))).eval (env ++ ext) = .some dr
-  rw [Prog.letin_eval (hv ext)]
-  have h := (hbody ext).here
-  simpa [PB.atSlot] using h
-
-/-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
-lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
-    (hx : PB.computes_at env x dx) :
-    PB.computes_at env (PB.tail x) (Data.l dx.asList.tail) := by
-  cases h : dx.asList with
-  | nil =>
-    refine PB.elim_nil_computes_at ?_ ?_
-    · intro ext; have := hx ext; rw [this]; congr 1
-      rw [← Data.asList_l dx, h]
-    · simp
-  | cons head tail =>
-    unfold PB.tail
-    apply PB.elim_cons_computes_at (em := PB.empty) (cs := fun _h tl => tl)
-    · intro ext; rw [hx ext]; congr 1
-      rw [← Data.asList_l dx, h]
-    · intro ext
-      exact PB.elim_cons_tail_var_computes_at
-
-/-- `PB.head` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
-lemma PB.head_computes_at {env : List Data} {x : PB} {dx : Data}
-    (hx : PB.computes_at env x dx) :
-    PB.computes_at env (PB.head x) (dx.asList.headD (Data.l [])) := by
-  cases h : dx.asList with
-  | nil =>
-    refine PB.elim_nil_computes_at ?_ (by simp)
-    · intro ext; have := hx ext; rw [this]; congr 1
-      rw [← Data.asList_l dx, h]
-  | cons head tail =>
-    apply PB.elim_cons_computes_at
-    · intro ext; have := hx ext; rw [this]; congr 1
-      rw [← Data.asList_l dx, h]
-    · intro ext
-      exact PB.elim_cons_head_var_computes_at
-
-/-! ### Option B (mentioned for completeness): recover the ∀-quantified version
-
-`PB.computes` is implied by the per-env strengthened version pointwise: if `impl`
-computes-at every env, it computes the constant value function. -/
-lemma PB.computes_of_computes_at {impl : PB} {d : Data}
-    (h : ∀ env, PB.computes_at env impl d) :
-    impl.computes (fun _ => d) := by
-  intro env; exact (h env).here
-
-/-- Program that evaluates to the constant `a`. -/
-def constant (a : Data) : PB := match a with
-  | Data.l [] => PB.empty
-  | Data.l (x :: xs) => PB.cons (constant x) (constant (Data.l xs))
-
--- @[simp]
--- lemma constant_whileFree (a : Data) (n : ℕ) : (constant a n).WhileFree := by
---   induction a using Data.inductionL with
---   | nil => simp [constant]
---   | cons x xs ihx ihxs => simp [constant, ihx, ihxs]
-
--- lemma constant.semantics (a : Data) {n : ℕ} :
---     ((constant a n).meteredEvalT (by simp) []).1 = a := by
---   sorry
-
-lemma constant_computes {env : List Data} {a : Data} :
-    (constant a).computes_at env a := by
-  induction a using Data.inductionL with
-  | nil => simp [constant]
-  | cons x xs ihx ihxs =>
-    simpa [constant] using PB.cons_computes_at ihx ihxs
-
-def encConst {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a)
-
-def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
-  .elim (PB.eq a b)
-    else_
-    fun _ _ => then_
-
-lemma PB.ifEq_computes_at {env : List Data} {a b then_ else_ : PB} {da db dr : Data}
-    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db)
-    (hthen : da = db → PB.computes_at env then_ dr)
-    (helse : da ≠ db → PB.computes_at env else_ dr) :
-    (PB.ifEq a b then_ else_).computes_at env dr := by
-  unfold PB.ifEq
-  by_cases h : da = db
-  · have heq : PB.computes_at env (PB.eq a b) (Data.l [Data.l []]) := by
-      simpa [h] using PB.eq_computes_at ha hb
-    refine PB.elim_cons_computes_at heq ?_
-    intro ext
-    have h' := (hthen h).extend (ext := ext ++ [Data.l [], Data.l []])
-    simpa [List.append_assoc] using h'
-  · have heq : PB.computes_at env (PB.eq a b) (Data.l []) := by
-      simpa [h] using PB.eq_computes_at ha hb
-    exact PB.elim_nil_computes_at heq (helse h)
-
-------------------------------------------------------
------------ Tools
------------------------------------------------------------
-
-
-def PB.fst (x : PB) : PB := head x
-
--- Compute fun x => x.snd
-def PB.snd (x : PB) : PB := head (tail x)
-
--- Compute x => Option.some x
-def PB.some (x : PB) : PB := cons x empty
-
-def PB.optionElim (x : PB) (noneCase : PB) (someCase : PB → PB) : PB :=
-  elim x noneCase (fun hd _ => someCase hd)
-
------------------ Typed computation
-
-def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
-    PB.computes_at env x (DataEncode.encode a)
-
-@[simp]
-lemma PB.atSlot_last_computes_at_encoded {α : Type} [DataEncode α]
-    {env ext : List Data} {a : α} :
-    PB.computes_at_encoded (env ++ ext ++ [DataEncode.encode a])
-      (PB.atSlot (env.length + ext.length)) a :=
-  PB.atSlot_last_computes_at
-
-@[simp]
-lemma PB.atSlot_last_computes_at_encoded_right {α : Type} [DataEncode α]
-    {env ext : List Data} {a : α} :
-    PB.computes_at_encoded (env ++ (ext ++ [DataEncode.encode a]))
-      (PB.atSlot (env.length + ext.length)) a :=
-  PB.atSlot_last_computes_at_right
-
-/-- Encoded body-of-binder hypothesis: the body computes a typed value `a`
-under any outer env extension. -/
-abbrev PB.computes_at_body_encoded {α : Type} [DataEncode α]
-    (env : List Data) (bindings : List Data)
-    (mkBody : (Fin bindings.length → PB) → PB) (a : α) : Prop :=
-  PB.computes_at_body env bindings mkBody (DataEncode.encode a)
-
-abbrev PB.computes_at_body₁_encoded {α β : Type} [DataEncode α] [DataEncode β]
-    (env : List Data) (a : α) (body : PB → PB) (b : β) : Prop :=
-  PB.computes_at_body₁ env (DataEncode.encode a) body (DataEncode.encode b)
-
-abbrev PB.computes_at_body₂_encoded {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ]
-    (env : List Data) (a : α) (b : β) (body : PB → PB → PB) (c : γ) : Prop :=
-  PB.computes_at_body₂ env (DataEncode.encode a) (DataEncode.encode b) body (DataEncode.encode c)
-
-lemma PB.fst_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {x : PB} {a : α × β}
-    (hx : PB.computes_at_encoded env x a) :
-    PB.computes_at_encoded env (PB.fst x) a.fst := by
-  obtain ⟨a, b⟩ := a
-  simpa [Data.asList] using PB.head_computes_at hx
-
-lemma PB.snd_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {x : PB} {a : α × β}
-    (hx : PB.computes_at_encoded env x a) :
-    PB.computes_at_encoded env (PB.snd x) a.snd := by
-  obtain ⟨a, b⟩ := a
-  simpa [Data.asList] using PB.head_computes_at (PB.tail_computes_at hx)
-
-lemma PB.some_computes_at_encoded {α : Type} [DataEncode α]
-    {env : List Data} {x : PB} {a : α}
-    (hx : PB.computes_at_encoded env x a) :
-    PB.computes_at_encoded env (PB.some x) (Option.some a) := by
-  apply PB.cons_computes_at hx PB.empty_computes_at
-
-lemma PB.optionElim_computes_none {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
-    (hx : x.computes_at_encoded env (none : Option α))
-    {a : β}
-    (h_none : noneCase.computes_at_encoded env a) :
-    (PB.optionElim x noneCase someCase).computes_at_encoded env a := by
-  apply PB.elim_nil_computes_at hx h_none
-
-lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
-    {a : α}
-    (hx : x.computes_at_encoded env (Option.some a))
-    {b : β}
-    (h_some : PB.computes_at_body₁_encoded env a someCase b) :
-    (PB.optionElim x noneCase someCase).computes_at_encoded env b := by
-  apply PB.elim_cons_computes_at hx
-  intro ext
-  simpa [List.append_assoc] using (h_some ext).extend
-
-lemma PB.letIn_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {val : PB} {body : PB → PB} {v : α} {b : β}
-    (hv : val.computes_at_encoded env v)
-    (hbody : PB.computes_at_body₁_encoded env v body b) :
-    (PB.letIn val body).computes_at_encoded env b :=
-  PB.letIn_computes_at hv hbody
-
-/-- Encoded variant of `PB.fold_computes_at`: typed accumulator `a : α`, typed
-list elements of type `β`, and a typed step function `f : α → β → α`. The body
-hypothesis is `PB.computes_at_body₂_encoded` parameterised over `acc : α` and
-`el : β`. -/
-lemma PB.fold_computes_at_encoded
-    {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {init list : PB} {body : PB → PB → PB}
-    {a : α} {l : List β} {f : α → β → α}
-    (hi : init.computes_at_encoded env a)
-    (hl : list.computes_at_encoded env l)
-    (hbody : ∀ acc el, PB.computes_at_body₂_encoded env acc el body (f acc el)) :
-    PB.computes_at_encoded env (PB.fold body init list) (l.foldl f a) := by
-  intro ext
-  simp only [PB.fold]
-  have hl' :
-      (list (env.length + ext.length)).eval (env ++ ext)
-        = .some (Data.l (l.map DataEncode.encode)) := hl ext
-  refine Prog.fold_eval (hi ext) hl'
-    (fun k => DataEncode.encode ((l.take k).foldl f a)) rfl (by simp) ?_
-  intro k hk
-  have hk' : k < l.length := by simpa using hk
-  have h := (hbody ((l.take k).foldl f a) l[k] ext).here
-  have hfoldl_succ :
-      (l.take (k+1)).foldl f a = f ((l.take k).foldl f a) l[k] := by
-    rw [List.take_succ, List.foldl_append]
-    simp [List.getElem?_eq_getElem hk']
-  have hget : (l.map DataEncode.encode)[k] = DataEncode.encode l[k] := by simp
-  simp only [hget, hfoldl_succ]
-  simpa [PB.atSlot, List.append_assoc] using h
--------------------------------------------------------------------
----------------- Universal Turing Machine (simulation of a SingleTapeTM)
----------------------------------------------------------------------------
-
-variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
-
-public instance : DataEncode (Turing.StackTape Symbol) where
-  encode t := DataEncode.encode t.toList
-  h_inj := by
-    intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h
-    have : l₁ = l₂ := DataEncode.h_inj h
-    cases this; rfl
-
-public instance : DataEncode (Turing.BiTape Symbol) where
-  encode t := DataEncode.encode (t.head, t.left, t.right)
-  h_inj := by
-    intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
-    have heq := DataEncode.h_inj h
-    simp at heq
-    obtain ⟨hh, hl, hr⟩ := heq
-    cases hh; cases hl; cases hr; rfl
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma encode_biTape (t : Turing.BiTape Symbol) :
-    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
-    simp [DataEncode.encode]
-
-def bitape_write (t v : PB) : PB := PB.cons v t.tail
-
-lemma bitape_write_computes
-    {env : List Data} {p_t p_v : PB} {t : BiTape Symbol} {v : Option Symbol}
-    (h_t : PB.computes_at_encoded env p_t t)
-    (h_v : PB.computes_at_encoded env p_v v) :
-    PB.computes_at_encoded env (bitape_write p_t p_v) (t.write v) := by
-  simp only [PB.computes_at_encoded, encode_biTape, DataEncode_pair] at h_t h_v ⊢
-  apply PB.cons_computes_at h_v (PB.tail_computes_at h_t)
-
--- /-- Prepend an `Option` to the `StackTape` -/
--- @[scoped grind]
--- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
---   match x, xs with
---   | none, ⟨[], _⟩ => ⟨[], by grind⟩
---   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
---   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
-
-def stackTape_cons (x st : PB) : PB :=
-  PB.optionElim x
-    (PB.elim st
-      PB.empty
-      (fun _ _ => PB.cons x st))
-    (fun _ => PB.cons x st)
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma stackTape_cons_computes
-    {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
-    (h_x : PB.computes_at_encoded env p_x x)
-    (h_st : PB.computes_at_encoded env p_st st) :
-    (stackTape_cons p_x p_st).computes_at_encoded env (st.cons x) := by
-  cases x with
-  | none =>
-    apply PB.optionElim_computes_none h_x
-    obtain ⟨l, hl⟩ := st
-    cases l with
-    | nil =>
-      simpa [DataEncode.encode] using
-        PB.elim_nil_computes_at (by simpa using h_st) (PB.empty_computes_at)
-    | cons hd tl =>
-      apply PB.elim_cons_computes_at (by simpa [DataEncode.encode] using h_st)
-      intro ext
-      simpa using (PB.cons_computes_at h_x h_st).extend
-  | some a =>
-    apply PB.optionElim_computes_some h_x
-    intro ext
-    simpa using (PB.cons_computes_at (by simpa [DataEncode.encode] using h_x) h_st).extend
-
-def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
-
-lemma to_pair_computes {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {p_a p_b : PB}
-    {a : α} {b : β}
-    (h_a : p_a.computes_at_encoded env a)
-    (h_b : p_b.computes_at_encoded env b) :
-    (to_pair p_a p_b).computes_at_encoded env (a, b) := by
-  simpa [DataEncode.encode, to_pair] using
-    PB.cons_computes_at h_a (PB.cons_computes_at h_b PB.empty_computes_at)
-
---- The head component of the bitape
-def bitape_head (t : PB) : PB := t.fst
---- The left component of the bitape
-def bitape_left (t : PB) : PB := t.snd.fst
---- The right component of the bitape
-def bitape_right (t : PB) : PB := t.snd.snd
-
-omit [Inhabited Symbol] [Fintype Symbol]
-lemma bitape_head_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
-    (h_t : PB.computes_at_encoded env p_t t) :
-    (bitape_head p_t).computes_at_encoded env t.head := PB.head_computes_at h_t
-
-omit [Inhabited Symbol] [Fintype Symbol]
-lemma bitape_left_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
-    (h_t : PB.computes_at_encoded env p_t t) :
-    (bitape_left p_t).computes_at_encoded env t.left :=
-  PB.head_computes_at (PB.head_computes_at (PB.tail_computes_at h_t))
-
-omit [Inhabited Symbol] [Fintype Symbol]
-lemma bitape_right_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
-    (h_t : PB.computes_at_encoded env p_t t) :
-    (bitape_right p_t).computes_at_encoded env t.right :=
-  PB.head_computes_at (PB.tail_computes_at (PB.head_computes_at (PB.tail_computes_at h_t)))
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma encode_stackTape_head (st : StackTape Symbol) :
-    (DataEncode.encode st).asList.headD (Data.l []) = DataEncode.encode st.head := by
-  obtain ⟨l, hl⟩ := st
-  cases l <;> simp [DataEncode.encode, StackTape.head, Data.asList]
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma encode_stackTape_tail (st : StackTape Symbol) :
-    Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
-  obtain ⟨l, hl⟩ := st
-  cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList]
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma stackTape_head_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
-    (h_st : PB.computes_at_encoded env p_st st) :
-    (p_st.head).computes_at_encoded env st.head := by
-  unfold PB.computes_at_encoded
-  simpa [← encode_stackTape_head] using PB.head_computes_at h_st
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma stackTape_tail_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
-    (h_st : PB.computes_at_encoded env p_st st) :
-    (p_st.tail).computes_at_encoded env st.tail := by
-  unfold PB.computes_at_encoded
-  simpa [← encode_stackTape_tail] using PB.tail_computes_at h_st
-
--- def move_left (t : BiTape Symbol) : BiTape Symbol :=
---   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
-
-def bitape_move_left (t : PB) : PB :=
-  to_pair (bitape_left t).head
-    (to_pair
-      (bitape_left t).tail
-      (stackTape_cons (bitape_head t) (bitape_right t)))
-
-lemma bitape_move_left_computes
-    {env : List Data} {p_t : PB} {t : BiTape Symbol}
-    (h_t : PB.computes_at_encoded env p_t t) :
-    PB.computes_at_encoded env (bitape_move_left p_t) t.move_left := by
-  unfold PB.computes_at_encoded
-  rw [encode_biTape]
-  exact to_pair_computes
-    (stackTape_head_computes_at_encoded (bitape_left_computes h_t))
-    (to_pair_computes
-      (stackTape_tail_computes_at_encoded (bitape_left_computes h_t))
-      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
-
--- def move_right (t : BiTape Symbol) : BiTape Symbol :=
---   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
-
-def bitape_move_right (t : PB) : PB :=
-  to_pair (bitape_right t).head
-    (to_pair
-      (stackTape_cons (bitape_head t) (bitape_left t))
-      (bitape_right t).tail)
-
-lemma bitape_move_right_computes
-    {env : List Data} {p_t : PB} {t : BiTape Symbol}
-    (h_t : PB.computes_at_encoded env p_t t) :
-    PB.computes_at_encoded env (bitape_move_right p_t) t.move_right := by
-  unfold PB.computes_at_encoded
-  rw [encode_biTape]
-  exact to_pair_computes
-    (stackTape_head_computes_at_encoded (bitape_right_computes h_t))
-    (to_pair_computes
-      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_left_computes h_t))
-      (stackTape_tail_computes_at_encoded (bitape_right_computes h_t)))
-
-instance : DataEncode Dir where
-  encode := fun
-    | Dir.left => DataEncode.encode true
-    | Dir.right => DataEncode.encode false
-  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
-
--- /--
--- Move the head to the left or right, shifting the tape underneath it.
--- -/
--- def move (t : BiTape Symbol) : Dir → BiTape Symbol
---   | .left => t.move_left
---   | .right => t.move_right
-
-def bitape_move (tape dir : PB) : PB :=
-  PB.ifEq dir (constant (DataEncode.encode Dir.left))
-    (bitape_move_left tape)
-    (bitape_move_right tape)
-
-lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir}
-    (h_t : PB.computes_at_encoded env p_t t)
-    (h_dir : PB.computes_at_encoded env p_dir d) :
-    (bitape_move p_t p_dir).computes_at_encoded env (t.move d) := by
-  unfold PB.computes_at_encoded bitape_move
-  refine PB.ifEq_computes_at h_dir constant_computes ?_ ?_
-  · intro hd_eq
-    -- TODO could use injectivity here once we have it.
-    cases d with
-    | left => exact bitape_move_left_computes h_t
-    | right =>
-      exfalso
-      exact absurd hd_eq (by decide)
-  · intro hne
-    cases d with
-    | left => exact absurd rfl hne
-    | right => exact bitape_move_right_computes h_t
-
--- /--
--- Optionally perform a `move`, or do nothing if `none`.
--- -/
--- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
---   | t, none => t
---   | t, some d => t.move d
-
-def bitape_optionMove (t dir : PB) : PB :=
-  PB.optionElim dir
-    t
-    (fun d => bitape_move t d)
-
-lemma bitape_optionMove_computes {env : List Data} {p_t p_dir : PB}
-    {t : BiTape Symbol} {d : Option Dir}
-    (h_t : PB.computes_at_encoded env p_t t)
-    (h_dir : PB.computes_at_encoded env p_dir d) :
-    (bitape_optionMove p_t p_dir).computes_at_encoded env (t.optionMove d) := by
-  unfold PB.computes_at_encoded bitape_optionMove BiTape.optionMove
-  match d with
-  | none => simpa using PB.optionElim_computes_none h_dir h_t
-  | some d =>
-    apply PB.optionElim_computes_some h_dir
-    intro ext
-    exact bitape_move_computes (by simpa using h_t.extend) (by simp)
-
-instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
-    DataEncode (Turing.SingleTapeTM.Cfg tm) where
-  encode cfg := DataEncode.encode (cfg.state, cfg.BiTape)
-  h_inj := by
-    intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h
-    have heq := DataEncode.h_inj h
-    simp at heq
-    obtain ⟨hs, ht⟩ := heq
-    cases hs; cases ht; rfl
-
--- Evaluate a function `f` at `arg` where the function is given as a graph.
--- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise.
-def eval_fun_graph (graph : PB) (arg : PB) : PB :=
-  PB.fold
-    (fun acc x =>
-      PB.optionElim acc
-        (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
-        fun _ => acc)
-    PB.empty graph
-
-/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of
-`(α × β)`-pairs) and an encoded argument `a : α`, returns
-`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)`
-in the graph, else `none`. -/
-lemma eval_fun_graph_computes
-    {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α]
-    {env : List Data} {p_graph p_arg : PB}
-    {graph : List (α × β)} {a : α}
-    (h_graph : p_graph.computes_at_encoded env graph)
-    (h_arg : p_arg.computes_at_encoded env a) :
-    (eval_fun_graph p_graph p_arg).computes_at_encoded env
-      ((graph.find? (fun p => p.1 = a)).map (·.2)) := by
-  -- The Lean-level step function for the fold.
-  let step : Option β → α × β → Option β :=
-    fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc)
-  -- Once the accumulator is `some _`, it stays `some _`.
-  have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by
-    intro l b
-    induction l with
-    | nil => simp
-    | cons hd tl ih => simp [step, ih]
-  -- `foldl step none` matches `find?`-then-`map snd`.
-  have key : ∀ l : List (α × β),
-      l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by
-    intro l
-    induction l with
-    | nil => simp
-    | cons hd tl ih =>
-      simp only [List.foldl_cons, List.find?_cons]
-      by_cases h : hd.1 = a
-      · simp [step, h, stays]
-      · simp [step, h, ih]
-  rw [show (graph.find? (fun p => p.1 = a)).map (·.2)
-        = graph.foldl step none from (key graph).symm]
-  unfold eval_fun_graph
-  refine PB.fold_computes_at_encoded (a := (none : Option β)) (f := step)
-    (by simp [PB.computes_at_encoded, DataEncode.encode]) h_graph ?_
-  intro acc x ext
-  rcases acc with _ | v
-  · -- acc = none: step none x = if x.1 = a then some x.2 else none
-    refine PB.optionElim_computes_none (α := β)
-      PB.elim_cons_head_var_computes_at ?_
-    refine PB.ifEq_computes_at
-      (PB.fst_computes_at_encoded PB.elim_cons_tail_var_computes_at)
-      (by simpa using h_arg.extend) ?_ ?_
-    · intro h_enc
-      have h_eq : x.1 = a := DataEncode.h_inj h_enc
-      change PB.computes_at_encoded _ _ (step none x)
-      simp only [step, Option.elim_none, if_pos h_eq]
-      exact PB.some_computes_at_encoded
-        (PB.snd_computes_at_encoded PB.elim_cons_tail_var_computes_at)
-    · intro h_enc
-      have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h])
-      simp [DataEncode.encode, step, h_ne]
-  · -- acc = some v: step (some v) x = some v
-    refine PB.optionElim_computes_some (α := β)
-      (PB.elim_cons_head_var_computes_at
-        (head := DataEncode.encode (some v : Option β))) ?_
-    intro ext'
-    simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes_at.extend
-
--- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) :=
---   Fintype.elems.toList.map (fun a => (a, f a))
-
-lemma eval_fun_graph_computes_of_fun
-    {α β : Type} [DataEncode α] [DataEncode β] [Fintype α]
-    {env : List Data} {p_graph p_arg : PB}
-    {a : α}
-    {f : α → β}
-    (h_graph : p_graph.computes_at_encoded env (Fintype.elems.toList.map (fun a => (a, f a))))
-    (h_arg : p_arg.computes_at_encoded env a) :
-    (eval_fun_graph p_graph p_arg).head.computes_at_encoded env (f a) := by
-  classical
-  have heq : ∀ (L : List α), a ∈ L →
-      ((L.map (fun a' => (a', f a'))).find?
-        (fun p => p.1 = a)).map (·.2) = some (f a) := by
-    intro L hmem
-    induction L with
-    | nil => exact absurd hmem (by simp)
-    | cons hd tl ih => grind
-  have h := eval_fun_graph_computes h_graph h_arg
-  rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h
-  simpa [DataEncode.encode, Data.asList] using PB.head_computes_at h
-
-def cfg_state (cfg : PB) : PB := cfg.fst
-def cfg_bitape (cfg : PB) : PB := cfg.snd
-
-lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
-    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
-    (h : p.computes_at_encoded env cfg) :
-    (cfg_state p).computes_at_encoded env cfg.state :=
-  PB.fst_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
-
-lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
-    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
-    (h : p.computes_at_encoded env cfg) :
-    (cfg_bitape p).computes_at_encoded env cfg.BiTape :=
-  PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
-
-/-- Evaluate the transition function. Returns `((wr, dir), q')`.
- -- The return value is not wrapped inside an `Option` because the transition
- -- function is assumed to be total. -/
-def eval_tr (tr : PB) (q c : PB) : PB :=
-  (eval_fun_graph (eval_fun_graph tr q).head c).head
-
-instance : DataEncode (SingleTapeTM.Stmt Symbol) where
-  encode stmt := DataEncode.encode (stmt.symbol, stmt.movement)
-  h_inj := by
-    intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h
-    have heq := DataEncode.h_inj h
-    simp at heq
-    obtain ⟨hs, hm⟩ := heq
-    cases hs; cases hm; rfl
-
-lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State]
-    [DecidableEq State] [Fintype Symbol]
-    {env : List Data} {p_tr p_q p_c : PB}
-    {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State}
-    {q : State}
-    {c : Option Symbol}
-    (h_tr : p_tr.computes_at_encoded env
-      ((Fintype.elems : Finset State).toList.map (fun q' : State =>
-        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-          (fun c' : Option Symbol => (c', tr q' c'))))))
-    (h_q : p_q.computes_at_encoded env q)
-    (h_c : p_c.computes_at_encoded env c) :
-    (eval_tr p_tr p_q p_c).computes_at_encoded env (tr q c) := by
-  unfold eval_tr
-  exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q)
-    (eval_fun_graph_computes_of_fun (α := State) (f := fun q' =>
-      (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c')))
-      h_tr h_q) h_c
-
--- /-- The step function corresponding to a `SingleTapeTM`. -/
--- @[simp]
--- def step : tm.Cfg → Option tm.Cfg
---   | ⟨none, _⟩ =>
---     -- If in the halting state, there is no next configuration
---     none
---   | ⟨some q', t⟩ =>
---     -- If in state q', perform look up in the transition function
---     match tm.tr q' t.head with
---     -- and enter a new configuration with state q'' (or none for halting)
---     -- and tape updated according to the Stmt
---     | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩
-
--- Compute the step function given a transition function (as its graph) and a configuration.
--- Returns `Option Cfg`
-def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
-  PB.optionElim (cfg_state cfg)
-    PB.empty
-    (fun q' => PB.letIn (cfg_bitape cfg) (fun tape =>
-      PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
-        .some (to_pair
-          tr_val.snd
-          (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
-
-lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol]
-    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
-    [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
-    (h_tr : p_tr.computes_at_encoded env
-      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
-        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-          (fun c' => (c', tm.tr q' c'))))))
-    (h_cfg : p_cfg.computes_at_encoded env cfg) :
-    (singleTapeTM_step p_tr p_cfg).computes_at_encoded env (tm.step cfg) := by
-  unfold singleTapeTM_step
-  obtain ⟨state, t⟩ := cfg
-  match hst : state with
-  | none =>
-    refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_
-    change PB.empty.computes_at_encoded env (none : Option tm.Cfg)
-    simp [PB.computes_at_encoded, DataEncode.encode]
-  | some q' =>
-    refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_
-    intro ext1
-    -- TODO letin makes this proof complicated.
-    -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`.
-    apply PB.letIn_computes_at_encoded (v := t)
-      (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend)
-    intro ext2
-    set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def
-    -- The slot for `q'` at depth `env.length + ext1.length`.
-    have h_q'_slot : PB.computes_at_encoded
-        (env2 ++ ext2 ++ [DataEncode.encode t])
-        (PB.atSlot (env.length + ext1.length)) q' := by
-      simpa [env2_def] using PB.atSlot_last_computes_at_encoded.extend
-    -- The slot for `tape` at depth `env2.length + ext2.length`.
-    have h_tape_slot : PB.computes_at_encoded
-        (env2 ++ ext2 ++ [DataEncode.encode t])
-        (PB.atSlot (env2.length + ext2.length)) t :=
-      PB.atSlot_last_computes_at_encoded
-    apply PB.letIn_computes_at_encoded
-      (eval_tr_computes
-        (by simpa [env2_def, List.append_assoc] using h_tr.extend)
-        h_q'_slot (bitape_head_computes h_tape_slot))
-    intro ext3
-    set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def
-    set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def
-    -- Re-derive tape slot at envS.
-    have h_tape_slot' : PB.computes_at_encoded envS
-        (PB.atSlot (env2.length + ext2.length)) t := by
-      simpa [envS_def, env3_def, List.append_assoc] using
-        h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)])
-    -- Destructure the transition result.
-    rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩
-    have h_trval : PB.computes_at_encoded envS
-        (PB.atSlot (env3.length + ext3.length))
-        (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by
-      simp [envS_def, htr_eq]
-    unfold SingleTapeTM.step
-    simp only [htr_eq]
-    exact PB.some_computes_at_encoded
-      (to_pair_computes
-        (PB.snd_computes_at_encoded h_trval)
-        (bitape_optionMove_computes
-          (bitape_write_computes h_tape_slot'
-            (PB.fst_computes_at_encoded (a := (wr, dir))
-              (PB.fst_computes_at_encoded h_trval)))
-          (PB.snd_computes_at_encoded (a := (wr, dir))
-            (PB.fst_computes_at_encoded h_trval))))
-
-def tm_main_loop (tr : PB) (cfg : PB) : PB :=
-  -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step`
-  -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep
-  -- the current `acc` (which has `state = none`, signalling halt to `while_`).
-  PB.while_ cfg
-    (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
-
-/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/
-private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol]
-    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
-    [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_tr : PB}
-    (h_tr : p_tr.computes_at_encoded env
-      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
-        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-          (fun c' => (c', tm.tr q' c'))))))
-    (c : tm.Cfg) :
-    PB.computes_at_body₁ env (DataEncode.encode c)
-      (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
-      (DataEncode.encode ((tm.step c).getD c)) := by
-  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
-  intro ext
-  set E := env ++ ext with E_def
-  have hE_len : E.length = env.length + ext.length := by simp [E_def]
-  have h_acc : PB.computes_at_encoded (E ++ [DataEncode.encode c])
-      (PB.atSlot E.length) c := by
-    simpa using PB.atSlot_last_computes_at_encoded (env := E) (ext := []) (a := c)
-  have h_step_eval :
-      (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_at_encoded
-        (E ++ [DataEncode.encode c]) (tm.step c) := by
-    have h_tr_ext : PB.computes_at_encoded (E ++ [DataEncode.encode c]) p_tr
-        ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
-          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-            (fun c' => (c', tm.tr q' c'))))) := by
-      have := h_tr.extend (ext := ext ++ [DataEncode.encode c])
-      simpa [E_def, List.append_assoc] using this
-    exact singleTapeTM_step_computes h_tr_ext h_acc
-  change PB.computes_at (E ++ [DataEncode.encode c])
-    (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length)))
-      (PB.atSlot (env.length + ext.length))
-      (fun next => next)) (DataEncode.encode (step c))
-  rw [← hE_len]
-  cases hstep_c : tm.step c with
-  | none =>
-    rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl]
-    exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc
-  | some next =>
-    rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl]
-    refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_
-    intro ext'
-    simpa using PB.atSlot_last_computes_at_encoded
-      (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next)
-
-/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
-`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
-state), the loop computes the configuration obtained after the *minimal* such
-number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
-halt result `none` as a fixed point via `Option.getD`. -/
-lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
-    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
-    [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
-    (h_tr : p_tr.computes_at_encoded env
-      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
-        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-          (fun c' => (c', tm.tr q' c'))))))
-    (h_cfg : p_cfg.computes_at_encoded env cfg)
-    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
-    (tm_main_loop p_tr p_cfg).computes_at_encoded env
-      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
-  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
-  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
-  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
-  have headD_iff : ∀ c : tm.Cfg,
-      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
-    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
-  -- Translate the halting hypothesis through the iff.
-  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
-    h_halts.imp fun _ h => (headD_iff _).mpr h
-  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
-    le_antisymm
-      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
-      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
-  -- Reduce to a `while_` spec call.
-  change PB.computes_at env (tm_main_loop p_tr p_cfg)
-    (DataEncode.encode (step^[Nat.find h_halts] cfg))
-  rw [← find_eq]
-  unfold tm_main_loop
-  exact PB.while_computes_iter (env := env) (p_init := p_cfg)
-    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
-    step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts'
-
-def reverse (x : PB) : PB :=
-  PB.fold (fun acc el => PB.cons el acc) PB.empty x
-
-lemma reverse_computes {α : Type} [DataEncode α]
-    {env : List Data} {p : PB} {l : List α}
-    (h : p.computes_at_encoded env l) :
-    (reverse p).computes_at_encoded env l.reverse := by
-  unfold reverse
-  have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp
-  rw [h_fold]
-  apply PB.fold_computes_at_encoded (by simp [PB.computes_at_encoded]) h
-  -- TODO at this point, we should actually be able to just apply a combinator on the semantics
-  -- of PB.cons
-  intro acc el ext
-  have h_el : PB.computes_at
-      (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
-      (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by
-    simpa using (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
-  simpa [DataEncode.encode, Data.asList] using
-    PB.cons_computes_at h_el (by simpa using PB.atSlot_last_computes_at.extend)
-
-def list_map (x : PB) (f : PB → PB) : PB :=
-  reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x)
-
-lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β]
-    {env : List Data} {p : PB} {l : List α}
-    {f : PB → PB} {g : α → β}
-    (h : p.computes_at_encoded env l)
-    (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) :
-    (list_map p f).computes_at_encoded env (l.map g) := by
-  unfold list_map
-  -- TODO simplify proof
-  have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_at_encoded
-      env (l.foldl (fun acc el => g el :: acc) []) := by
-    apply PB.fold_computes_at_encoded (a := ([] : List β)) (f := fun acc el => g el :: acc)
-      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
-    intro acc el ext
-    have h_acc : PB.computes_at
-        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
-        (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
-      simpa using (PB.atSlot_last_computes_at (env := env) (ext := ext)
-        (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
-    have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_at_encoded
-        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by
-      simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc])
-    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_fel h_acc
-  have h_rev := reverse_computes h_fold
-  have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by
-    rw [show l.foldl (fun acc el => g el :: acc) []
-          = (l.map g).foldl (fun acc el => el :: acc) [] from
-        (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm]
-    simp
-  rwa [h_eq] at h_rev
-
-/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/
-def list_reduceOption (x : PB) : PB :=
-  reverse (PB.fold
-    (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc))
-    PB.empty x)
-
-lemma list_reduceOption_computes {α : Type} [DataEncode α]
-    {env : List Data} {p : PB} {l : List (Option α)}
-    (h : p.computes_at_encoded env l) :
-    (list_reduceOption p).computes_at_encoded env l.reduceOption := by
-  unfold list_reduceOption
-  set step : List α → Option α → List α :=
-    fun acc el => match el with | none => acc | some y => y :: acc with step_def
-  -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need
-  -- this generalized over the initial accumulator so the induction goes through.
-  have h_eq : ∀ (xs : List (Option α)) (init : List α),
-      (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by
-    intro xs
-    induction xs with
-    | nil => intro init; simp [List.reduceOption]
-    | cons hd tl ih =>
-      intro init
-      cases hd with
-      | none => simpa [step_def] using ih init
-      | some y =>
-        have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by
-          simp [step_def]
-        rw [h1, ih (y :: init)]
-        simp [List.reduceOption]
-  have h_fold : (PB.fold
-        (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p
-      ).computes_at_encoded env (l.foldl step []) := by
-    apply PB.fold_computes_at_encoded
-      (a := ([] : List α)) (f := step)
-      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
-    intro acc el ext
-    have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_at_encoded
-        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by
-      simpa [PB.computes_at_encoded] using
-        (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
-    have h_acc : (PB.atSlot (env.length + ext.length)).computes_at_encoded
-        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by
-      simpa [PB.computes_at_encoded] using
-        (PB.atSlot_last_computes_at (env := env) (ext := ext)
-          (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
-    cases el with
-    | none =>
-      simpa [step_def] using
-        PB.optionElim_computes_none (α := α) h_el h_acc
-    | some y =>
-      refine PB.optionElim_computes_some (α := α) h_el ?_
-      intro ext'
-      -- Inside someCase, the bound `y` lives at slot
-      -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`.
-      set ext_inner :=
-        ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def
-      have hlen : ext_inner.length = ext.length + 2 + ext'.length := by
-        simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm]
-      have h_y :
-          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
-            (PB.atSlot (env.length + ext.length + 2 + ext'.length))
-            (DataEncode.encode y) := by
-        have h := PB.atSlot_last_computes_at
-          (env := env) (ext := ext_inner) (d := DataEncode.encode y)
-        rw [hlen] at h
-        convert h using 2
-        omega
-      have h_acc' :
-          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
-            (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
-        have h := (h_acc :
-          PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)])
-            _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y])
-        simpa [ext_inner_def, List.append_assoc] using h
-      have h_cons := PB.cons_computes_at h_y h_acc'
-      simp only [ext_inner_def] at h_cons
-      simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons
-  have h_rev := reverse_computes h_fold
-  have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l []
-  rwa [h_eq₀] at h_rev
-
-def list_head_option (input : PB) : PB :=
-  PB.elim input PB.empty (fun hd _tl => PB.some hd)
-
-lemma list_head_option_computes {α : Type} [DataEncode α]
-    {env : List Data} {p : PB} {l : List α}
-    (h : p.computes_at_encoded env l) :
-    (list_head_option p).computes_at_encoded env l.head? := by
-  cases l with
-  | nil =>
-    apply PB.elim_nil_computes_at (em := PB.empty)
-    · simpa [DataEncode.encode] using h
-    · simp [DataEncode.encode]
-  | cons hd tl =>
-    apply PB.elim_cons_computes_at (head := DataEncode.encode hd)
-      (tail := tl.map DataEncode.encode)
-    · simpa [DataEncode.encode] using h
-    · intro ext
-      simpa [DataEncode.encode] using
-        PB.cons_computes_at PB.elim_cons_head_var_computes_at PB.empty_computes_at
-
-def string_to_tape (input : PB) : PB :=
-  to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some))
-
-lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol}
-    (h_input : p_input.computes_at_encoded env input) :
-    (string_to_tape p_input).computes_at_encoded env (BiTape.mk₁ input) := by
-  have h_tail : (PB.tail p_input).computes_at_encoded env input.tail := by
-    simpa [PB.computes_at_encoded, DataEncode.encode] using PB.tail_computes_at h_input
-  have h_map : (list_map (PB.tail p_input) PB.some).computes_at_encoded env
-      (StackTape.map_some input.tail : Turing.StackTape Symbol) := by
-    simpa [PB.computes_at_encoded, DataEncode.encode]
-      using list_map_computes h_tail (fun _ _ => by
-        simpa [DataEncode.encode] using
-          PB.cons_computes_at PB.atSlot_last_computes_at PB.empty_computes_at)
-  have h_empty : (PB.empty : PB).computes_at_encoded env (∅ : Turing.StackTape Symbol) := by
-    simp [PB.computes_at_encoded, DataEncode.encode]
-  simpa [PB.computes_at_encoded, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape]
-    using to_pair_computes (list_head_option_computes h_input)
-      (to_pair_computes h_empty h_map)
-
-
-def initial_config (q₀ : PB) (input : PB) : PB :=
-  to_pair (PB.some q₀) (string_to_tape input)
-
-/-- Turn the final config to an output, by taking the head and the right part of the tape
-    and discarding the blank (`none`) cells. -/
-def final_config_to_output (cfg : PB) : PB :=
-  list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))
-
-/-- Implements a universal Single-Tape TM, assuming that the input contains the following:
-((initialState, transitionFunction), input).
-If it terminates, the output is the tape contents under the head and to its right. -/
-def universal_tm (input : PB) :=
-  final_config_to_output
-    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd))
-
-lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
-    {env : List Data} {p_q₀ p_input : PB} {input : List Symbol}
-    (h_q₀ : p_q₀.computes_at_encoded env tm.q₀)
-    (h_input : p_input.computes_at_encoded env input) :
-    (initial_config p_q₀ p_input).computes_at_encoded env (tm.initCfg input) := by
-  -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes
-  -- through the `(state, BiTape)` pair, so this matches `to_pair`.
-  exact to_pair_computes (PB.some_computes_at_encoded h_q₀) (string_to_tape_computes h_input)
-
-lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
-    {env : List Data} {p_cfg : PB} {cfg : tm.Cfg}
-    (h_cfg : p_cfg.computes_at_encoded env cfg) :
-    (final_config_to_output p_cfg).computes_at_encoded env
-      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by
-  unfold final_config_to_output
-  have h_BiTape : (p_cfg.snd).computes_at_encoded env cfg.BiTape :=
-    PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h_cfg
-  have h_head := bitape_head_computes h_BiTape
-  have h_right := bitape_right_computes h_BiTape
-  -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`),
-  -- then `list_reduceOption` discards the blanks.
-  have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_at_encoded env
-      (cfg.BiTape.head :: cfg.BiTape.right.toList) := by
-    change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList))
-    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_head h_right
-  exact list_reduceOption_computes h_list
-
-lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_input : PB} {input : List Symbol}
-    (h_input : p_input.computes_at_encoded env
-      ((tm.q₀,
-        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
-          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-            (fun c' => (c', tm.tr q' c'))))),
-       input))
-    (h_halts : ∃ n,
-        ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) :
-    (universal_tm p_input).computes_at_encoded env
-      (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input)
-       (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by
-  unfold universal_tm
-  have h_fst := PB.fst_computes_at_encoded h_input
-  have h_q₀ := PB.fst_computes_at_encoded h_fst
-  have h_tr := PB.snd_computes_at_encoded h_fst
-  have h_inp := PB.snd_computes_at_encoded h_input
-  exact final_config_to_output_computes
-    (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts)
-
-/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding
-blanks) recovers `l`. -/
-private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) :
-    ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by
-  have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by
-    induction xs with
-    | nil => rfl
-    | cons _ _ ih => simp [ih]
-  cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h]
-
-/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`,
-then the universal Turing machine `universal_tm`, when given an encoding of `tm`
-together with `w`, computes `w'`.
-
-The encoded input has the shape `((tm.q₀, transitionTable), w)`, where
-`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/
-theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_input : PB} {w w' : List Symbol}
-    (h_input : p_input.computes_at_encoded env
-      ((tm.q₀,
-        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
-          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-            (fun c' => (c', tm.tr q' c'))))),
-       w))
-    (h_out : tm.Outputs w w') :
-    (universal_tm p_input).computes_at_encoded env w' := by
-  -- Lift `tm.step` to a total step function; halting states are fixed points.
-  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
-  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
-    rintro ⟨_, _⟩ rfl; rfl
-  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
-    intro k _ hc
-    induction k with
-    | zero => rfl
-    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
-  -- Convert `ReflTransGen` into an explicit step count via tail-induction.
-  obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by
-    suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' →
-        ∃ n, step^[n] c = c' from h h_out
-    intro c c' hrel
-    induction hrel with
-    | refl => exact ⟨0, rfl⟩
-    | tail _ h' ih =>
-      obtain ⟨n, hn⟩ := ih
-      refine ⟨n + 1, ?_⟩
-      rw [Function.iterate_succ_apply', hn]
-      change (tm.step _).getD _ = _
-      rw [h']
-      rfl
-  -- The halting hypothesis required by `universal_tm_computes`.
-  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩
-  -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`.
-  have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by
-    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl)
-    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
-    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter
-    exact h_iter.symm
-  -- Conclude via `universal_tm_computes`.
-  have h := universal_tm_computes (tm := tm) h_input h_halts
-  rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
-    tm.haltCfg w' from h_find] at h
-  simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h
-
-/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded
-output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/
-private lemma universal_tm_eval_some_imp_loop_eval_some
-    {p_input : PB} {env : List Data} {d : Data}
-    (h : (universal_tm p_input env.length).eval env = .some d) :
-    ∃ d', (tm_main_loop p_input.fst.snd
-      (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by
-  -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is
-  -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is
-  -- `.some`, the bound subexpression must be `.some` too.
-  set n := env.length with hn
-  set mloop : Prog := tm_main_loop p_input.fst.snd
-    (initial_config p_input.fst.fst p_input.snd) n with mloop_def
-  -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do.
-  have bd_cons : ∀ {a b : Prog} {env d},
-      (Prog.cons a b).eval env = .some d →
-      (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by
-    intro a b env d h
-    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
-    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
-    unfold Prog.meteredEval at hm
-    simp only [bind, Part.mem_bind_iff] at hm
-    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
-    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
-    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
-    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
-    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
-  -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does.
-  have bd_elim : ∀ {v em cs : Prog} {env d},
-      (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by
-    intro v em cs env d h
-    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
-    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
-    unfold Prog.meteredEval at hm
-    simp only [bind, Part.mem_bind_iff] at hm
-    obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm
-    refine ⟨ah, ?_⟩
-    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
-  -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init`
-  -- and `list` do.
-  have bd_fold : ∀ {body init list : Prog} {env d},
-      (Prog.fold body init list).eval env = .some d →
-      (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by
-    intro body init list env d h
-    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
-    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
-    unfold Prog.meteredEval at hm
-    simp only [bind, Part.mem_bind_iff] at hm
-    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
-    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
-    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
-    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
-    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
-  -- Now unfold `universal_tm = final_config_to_output (...)`,
-  -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`,
-  -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`.
-  -- At each step we bubble down through the relevant `Prog` constructor.
-  -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost
-  -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through
-  -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s)
-  -- to extract a `some` evaluation for `mloop`.
-  change (final_config_to_output (tm_main_loop p_input.fst.snd
-    (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h
-  unfold final_config_to_output list_reduceOption reverse at h
-  -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain)
-  obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h
-  obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1
-  -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2
-  -- where mloop' = tm_main_loop ...
-  change (Prog.cons _ _).eval env = .some d2 at h2
-  obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2
-  -- h3 : bitape_head (...).snd evaluates to some
-  -- bitape_head t = t.fst = head t = elim t empty (fun ...)
-  -- bitape_head (mloop').snd = head (head (tail mloop'))
-  change (Prog.elim _ _ _).eval env = .some d3 at h3
-  obtain ⟨d4, h4⟩ := bd_elim h3
-  -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _).
-  change (Prog.elim _ _ _).eval env = .some d4 at h4
-  obtain ⟨d5, h5⟩ := bd_elim h4
-  -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl).
-  change (Prog.elim _ _ _).eval env = .some d5 at h5
-  obtain ⟨d6, h6⟩ := bd_elim h5
-  -- h6 : mloop' n .eval env = some d6. Done.
-  exact ⟨d6, h6⟩
-
-/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to
-a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`,
-then there exists an iteration index `n` such that the TM is in a halt state and
-the tape contents under the head (with blanks discarded) equal `w'`. -/
-theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol]
-    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
-    [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_input : PB} {w w' : List Symbol}
-    (h_input : p_input.computes_at_encoded env
-      ((tm.q₀,
-        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
-          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-            (fun c' => (c', tm.tr q' c'))))),
-       w))
-    (h_out : (universal_tm p_input).computes_at_encoded env w') :
-    ∃ n : ℕ,
-      let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
-      cfg.state = none ∧
-      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by
-  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
-  by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none
-  · -- Halts: use forward direction to identify the output.
-    refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩
-    have h_fwd := universal_tm_computes (tm := tm) h_input h_halts
-    -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`;
-    -- since `Part.eval` is functional, the encoded values must agree, then apply
-    -- injectivity of `DataEncode.encode`.
-    have h1 := h_fwd []
-    have h2 := h_out []
-    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2
-    rw [h1] at h2
-    have h_eq := Part.some_inj.mp (by exact_mod_cast h2)
-    exact DataEncode.h_inj h_eq
-  · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`.
-    exfalso
-    have h_eval := h_out []
-    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval
-    obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval
-    -- Project `h_input` to get individual components.
-    have h_q₀ := PB.fst_computes_at_encoded (PB.fst_computes_at_encoded h_input)
-    have h_tr := PB.snd_computes_at_encoded (PB.fst_computes_at_encoded h_input)
-    have h_inp := PB.snd_computes_at_encoded h_input
-    -- Initial config evaluates to `encode (tm.initCfg w)`.
-    have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env
-        = .some (DataEncode.encode (tm.initCfg w)) := by
-      have := (initial_config_computes h_q₀ h_inp) []
-      simpa using this
-    -- Unfold tm_main_loop = PB.while_ init body.
-    set body_pb : PB → PB :=
-      fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc
-        (fun next => next) with body_pb_def
-    change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env
-      = .some d at h_loop
-    set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def
-    change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env
-      = .some d at h_loop
-    rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop
-    -- Extract the trajectory.
-    obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ :=
-      Prog.whileFrom_eval_some h_loop
-    -- The body computes `step` at every config.
-    have h_body_eval : ∀ c : tm.Cfg,
-        bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by
-      intro c
-      have h := (tm_main_loop_body_computes h_tr c (ext := [])).here
-      simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h
-    -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`.
-    have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by
-      intro k hk
-      induction k with
-      | zero => simpa using h_traj0
-      | succ k ih =>
-        have hkm : k < m := hk
-        have ih' := ih (Nat.le_of_lt hkm)
-        have h_step_k := (h_steps k hkm).2
-        rw [ih', h_body_eval] at h_step_k
-        have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) :=
-          (Part.some_inj.mp h_step_k).symm
-        rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from
-          (Function.iterate_succ_apply' step k _).symm]
-    -- Halt condition at `m` gives `state = none`.
-    have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl
-    rw [← h_trajm, h_at_m] at h_halt_at_m
-    have headD_iff : ∀ c : tm.Cfg,
-        (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
-      rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
-    exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩
-
-/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches
-a halted configuration whose tape content (head followed by the right stack, with
-blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization
-of `universal_tm`. -/
-private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
-    (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop :=
-  ∃ n : ℕ,
-    let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
-    cfg.state = none ∧
-    (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w'
-
-private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
-    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
-    {env : List Data} {p_input : PB} {w w' : List Symbol}
-    (h_input : p_input.computes_at_encoded env
-      ((tm.q₀,
-        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
-          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
-            (fun c' => (c', tm.tr q' c'))))),
-       w)) :
-    Outputs' tm w w' ↔ (universal_tm p_input).computes_at_encoded env w' := by
-  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def
-  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
-    rintro ⟨_, _⟩ rfl; rfl
-  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
-    intro k _ hc
-    induction k with
-    | zero => rfl
-    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
-  refine ⟨?_, ?_⟩
-  · -- Forward: `Outputs' tm w w' → universal_tm computes w'`.
-    rintro ⟨n, h_halt_n, h_eq⟩
-    have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩
-    have h := universal_tm_computes (tm := tm) h_input h_halts
-    -- Stationarity: any later iterate of a halted config equals it.
-    have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n
-    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
-    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter
-    rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
-      (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h
-    exact h
-  · -- Converse: directly from `universal_tm_simulates_converse`.
-    intro h_out
-    exact universal_tm_simulates_converse h_input h_out
-
-end RoseTreeMachine
-
-end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/Data.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/Data.lean
new file mode 100644
index 0000000000..ece53a03fc
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Data.lean
@@ -0,0 +1,115 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.Data.Part
+
+/-! # RoseTreeMachine V2 — Data
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-- ================= Data structure
+
+
+
+-- Rose-tree data structure, it allows us to
+-- 1. map most of Lean's data structures in a "natural" manner
+-- 2. define a "fold" operation
+inductive Data where
+  | l : List Data → Data
+deriving Repr
+
+mutual
+  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
+    | .l xs, .l ys =>
+      match Data.listDecEq xs ys with
+      | isTrue h => isTrue (congrArg Data.l h)
+      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
+  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
+    | [], [] => isTrue rfl
+    | [], _ :: _ => isFalse (by simp)
+    | _ :: _, [] => isFalse (by simp)
+    | x :: xs, y :: ys =>
+      match Data.decEq x y, Data.listDecEq xs ys with
+      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
+      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
+      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
+end
+
+instance : DecidableEq Data := Data.decEq
+instance : BEq Data := inferInstance
+instance : LawfulBEq Data := inferInstance
+
+abbrev Data.empty := Data.l []
+
+
+@[grind =]
+def Data.asList
+  | Data.l xs => xs
+
+@[simp]
+lemma Data.asList_empty : Data.empty.asList = [] := by rfl
+
+@[simp, grind =]
+lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
+
+@[simp, grind =]
+lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
+
+--- Encoding length of d.
+def Data.size : Data → ℕ
+  | Data.l xs => 2 + (xs.map Data.size |>.sum)
+
+@[simp, grind =]
+lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
+
+@[simp, grind =]
+lemma Data.cons_size {h : Data} {t : List Data} :
+    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
+  simp [Data.size]
+  grind
+
+/-- Recursion principle for `Data` that exposes the list-of-children structure:
+    a `motive` is built from the empty case and a cons case that combines the
+    motive on the head child and on the tail list (viewed as a `Data`).
+    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
+    through `List.rec`, leaving the recursive call on children to the user;
+    `Data.recL` performs both recursions and is the natural elimination principle
+    for definitions/proofs that need both IHs. -/
+@[elab_as_elim]
+def Data.recL {motive : Data → Sort*}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
+    ∀ d, motive d
+  | .l [] => nil
+  | .l (x :: xs) =>
+      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
+
+/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
+@[elab_as_elim]
+theorem Data.inductionL {motive : Data → Prop}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
+    (d : Data) : motive d :=
+  Data.recL nil cons d
+
+abbrev TapeIndex := ℕ
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/DataEncode.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/DataEncode.lean
new file mode 100644
index 0000000000..aba559e58b
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/DataEncode.lean
@@ -0,0 +1,101 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Data
+public import Mathlib.Data.Nat.Bits
+public import Mathlib.Data.List.Basic
+
+/-! # RoseTreeMachine V2 — DataEncode
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-------------------------------------
+--- Encoding of generic types into Data
+--------------------------------------
+
+class DataEncode (α : Type) where
+  encode : α → Data
+  h_inj : encode.Injective
+
+instance : DataEncode Bool where
+  encode b := if b then Data.l [ Data.l [] ] else Data.l []
+  h_inj := by intros a b h_eq; grind
+
+instance (α : Type) [DataEncode α] : DataEncode (List α) where
+  encode xs := Data.l (xs.map DataEncode.encode)
+  h_inj := by
+    intro a b h
+    have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode :=
+      Data.l.inj h
+    exact List.map_injective_iff.mpr DataEncode.h_inj h'
+
+@[simp, grind =]
+lemma DataEncode_list_nil {α : Type} [DataEncode α] :
+  DataEncode.encode ([] : List α) = Data.l [] := by
+  simp [DataEncode.encode]
+
+@[simp, grind =]
+lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
+  DataEncode.encode xs = Data.empty ↔ xs = [] := by
+  simp [DataEncode.encode]
+
+@[simp, scoped grind =]
+lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+  simp [DataEncode.encode]
+
+instance (α : Type) [DataEncode α] : DataEncode (Option α) where
+  encode := fun
+    | none => Data.l []
+    | some x => Data.l [DataEncode.encode x]
+  h_inj := by
+    intro a b h
+    cases a <;> cases b <;> simp_all
+    exact DataEncode.h_inj h
+
+@[simp]
+lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
+  (DataEncode.encode x == Data.empty) = x.isNone := by
+  cases x <;> simp [DataEncode.encode, Data.empty]
+
+instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
+  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
+  h_inj := by
+    intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h
+    simp at h
+    exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩
+
+lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
+  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
+  simp [DataEncode.encode]
+
+instance : DataEncode ℕ where
+  encode x := DataEncode.encode (Nat.bits x)
+  h_inj := by
+    intro a b h
+    have hb : a.bits = b.bits := DataEncode.h_inj h
+    -- Reconstruct a from a.bits via binaryRec.
+    have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by
+      intro n
+      induction n using Nat.binaryRec' with
+      | zero => simp
+      | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih]
+    have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb
+    simpa [hrec] using this
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
new file mode 100644
index 0000000000..f01e6bfa0f
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
@@ -0,0 +1,368 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.DataEncode
+
+/-! # RoseTreeMachine V2 — PB
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+/-- A program builder: given the current binder depth (i.e. the size of `env`
+at the point of insertion), produce a `Prog`. -/
+abbrev PB := ℕ → Prog
+
+namespace PB
+
+def empty : PB := fun _ => .empty
+def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
+def eq (a b : PB) : PB := fun n => .eq (a n) (b n)
+
+/-- `letIn val (fun x => body)`: bind the value of `val` as a fresh variable `x`
+visible in `body`. -/
+def letIn (val : PB) (body : PB → PB) : PB := fun n =>
+  .letin (val n) (body (fun _ => .var n) (n + 1))
+
+/-- `elim v em (fun head tail => body)`: case-analyse the result of `v`. -/
+def elim (v : PB) (em : PB) (cs : PB → PB → PB) : PB := fun n =>
+  .elim (v n) (em n) (cs (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2))
+
+/-- `fold (fun acc x => body) init list`: run `body` for each element `x`
+threading accumulator `acc`. -/
+def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
+  .fold (body (fun _ => .var n) (fun _ => .var (n + 1)) (n + 2)) (init n) (list n)
+
+/-- `while_ init (fun acc => body)`. -/
+def while_ (init : PB) (body : PB → PB) : PB := fun n =>
+  .while_ (init n) (body (fun _ => .var n) (n + 1))
+
+/-- Close a builder into a concrete `Prog`. -/
+def build (p : PB) : Prog := p 0
+
+
+end PB
+
+----------------------------------------------------
+
+def PB.computes (impl : PB) (f : List Data → Data) : Prop :=
+  ∀ env, (impl env.length).eval env = .some (f env)
+
+-------------------------------------------------------------------
+--- tools
+-------------------------------------------
+
+/-- Example: `tail x` returns the tail of the list bound at variable `x`, or `empty`
+    if `x` denotes the empty list. Built with `elim`: the empty branch yields `empty`,
+    the cons branch ignores the head and projects the bound tail. -/
+def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
+def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
+
+/-! ### Per-env `PB.computes_at`
+
+A pointwise version of `PB.computes` that talks about a specific env. -/
+
+/-- `PB.computes_at env impl d`: for every extension `ext` of `env`, when the
+program is unfolded at depth `(env ++ ext).length` and evaluated on `env ++ ext`,
+it yields `d`. The `∀ ext` quantifier captures the fact that well-formed PBs
+preserve their value under env-extension, which is essential for composing them
+inside binders. -/
+def PB.computes_at (env : List Data) (impl : PB) (d : Data) : Prop :=
+  ∀ ext : List Data,
+    (impl (env.length + ext.length)).eval (env ++ ext) = .some d
+
+/-- The basic per-env consequence, instantiating `ext := []`. -/
+lemma PB.computes_at.here {env : List Data} {impl : PB} {d : Data}
+    (h : PB.computes_at env impl d) :
+    (impl env.length).eval env = .some d := by
+  simpa using h []
+
+/-- Weakening: extending the env preserves `computes_at`. -/
+@[simp]
+lemma PB.computes_at.extend {env ext : List Data} {impl : PB} {d : Data}
+    (h : PB.computes_at env impl d) :
+    PB.computes_at (env ++ ext) impl d := by
+  intro ext'
+  have := h (ext ++ ext')
+  simpa [List.append_assoc, Nat.add_assoc] using this
+
+@[simp, grind .]
+lemma PB.var_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes_at env (fun _ => .var i) env[i] := by
+  intro ext
+  simp [Prog.eval, Prog.meteredEval, List.getElem?_append_left h]
+  grind
+
+@[simp]
+lemma PB.var_last_computes_at {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ ext ++ [d])
+      (fun _ => Prog.var (env.length + ext.length)) d := by
+  have hlen : env.length + ext.length < (env ++ ext ++ [d]).length := by simp
+  have h := PB.var_computes_at (env := env ++ ext ++ [d]) hlen
+  convert h using 2
+  simp [List.getElem_append]
+
+@[simp, grind .]
+lemma PB.empty_computes_at {env : List Data} :
+    PB.computes_at env PB.empty (Data.l []) := by
+  intro ext
+  simp [PB.empty, Prog.eval, Prog.meteredEval]
+
+@[simp, grind .]
+lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
+    (hh : PB.computes_at env h dh) (ht : PB.computes_at env t dt) :
+    PB.computes_at env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
+  intro ext
+  simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
+
+lemma PB.eq_computes_at {env : List Data} {a b : PB} {da db : Data}
+    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db) :
+    PB.computes_at env (PB.eq a b)
+      (if da = db then Data.l [Data.l []] else Data.l []) := by
+  intro ext
+  simpa [PB.eq] using Prog.eq_eval (ha ext) (hb ext)
+
+/-! ### Body-of-binder abstraction
+
+The hypothesis shape arising for the body of a binder (`elim`, `letin`, `fold`,
+…) is that the body PB, built from var-lookup PBs for each new binding,
+computes the result on the env extended with those bindings, for any outer
+extension `ext`. We package this as `PB.computes_at_body` with arity-typed
+convenience wrappers. -/
+
+/-- Depth-agnostic var-lookup PB: `PB.atSlot i = fun _ => .var i`. -/
+def PB.atSlot (i : ℕ) : PB := fun _ => .var i
+
+@[simp]
+lemma PB.atSlot_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes_at env (PB.atSlot i) env[i] :=
+  PB.var_computes_at h
+
+@[simp]
+lemma PB.atSlot_last_computes_at {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ ext ++ [d])
+      (PB.atSlot (env.length + ext.length)) d :=
+  PB.var_last_computes_at
+
+@[simp]
+lemma PB.atSlot_last_computes_at_right {env ext : List Data} {d : Data} :
+    PB.computes_at (env ++ (ext ++ [d]))
+      (PB.atSlot (env.length + ext.length)) d := by
+  rw [← List.append_assoc]; exact PB.atSlot_last_computes_at
+
+/-- Body-of-binder hypothesis. `mkBody` is an arity-`bindings.length` body
+builder that receives the var-lookup PBs for each binding and produces a PB.
+The result must compute `dr` on `env` extended with `bindings` (under any
+outer extension `ext`). -/
+def PB.computes_at_body (env : List Data) (bindings : List Data)
+    (mkBody : (Fin bindings.length → PB) → PB) (dr : Data) : Prop :=
+  ∀ ext : List Data,
+    PB.computes_at (env ++ ext ++ bindings)
+      (mkBody (fun i => PB.atSlot (env.length + ext.length + i))) dr
+
+/-- Arity-1 convenience: one new binding `b`, body `body : PB → PB`. -/
+abbrev PB.computes_at_body₁ (env : List Data) (b : Data)
+    (body : PB → PB) (dr : Data) : Prop :=
+  PB.computes_at_body env [b] (fun a => body (a 0)) dr
+
+/-- Arity-2 convenience: two new bindings `b₁, b₂`, body `body : PB → PB → PB`. -/
+abbrev PB.computes_at_body₂ (env : List Data) (b₁ b₂ : Data)
+    (body : PB → PB → PB) (dr : Data) : Prop :=
+  PB.computes_at_body env [b₁, b₂] (fun a => body (a 0) (a 1)) dr
+
+/-- `elim` at a fixed env, nil branch. -/
+@[grind .]
+lemma PB.elim_nil_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {dr : Data}
+    (hv : PB.computes_at env v (Data.l []))
+    (hem : PB.computes_at env em dr) :
+    PB.computes_at env (PB.elim v em cs) dr := by
+  intro ext
+  simp only [PB.elim]
+  rw [Prog.elim_eval_nil (hv ext)]
+  exact hem ext
+
+/-- `elim` at a fixed env, cons branch. The body hypothesis is packaged as
+`PB.computes_at_body₂`: `cs`, applied to the var-lookup PBs for `head` and
+`Data.l tail`, computes `dr` on the env extended with `[head, Data.l tail]`. -/
+@[grind .]
+lemma PB.elim_cons_computes_at {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {head : Data} {tail : List Data} {dr : Data}
+    (hv : PB.computes_at env v (Data.l (head :: tail)))
+    (hcs : PB.computes_at_body₂ env head (Data.l tail) cs dr) :
+    PB.computes_at env (PB.elim v em cs) dr := by
+  intro ext
+  simp only [PB.elim]
+  rw [Prog.elim_eval_cons (hv ext)]
+  have h := (hcs ext).here
+  simpa [PB.atSlot, List.append_assoc] using h
+
+/-- The slot-lookup PB for `head` in the body of an `elim` (or any 2-binding
+body). -/
+lemma PB.elim_cons_head_var_computes_at {env ext : List Data}
+    {head : Data} {tail : Data} :
+    PB.computes_at (env ++ ext ++ [head, tail])
+      (PB.atSlot (env.length + ext.length)) head := by
+  show PB.computes_at _ (fun _ => .var (env.length + ext.length)) _
+  have hlen : env.length + ext.length
+      < (env ++ ext ++ [head, tail]).length := by simp
+  grind [PB.var_computes_at hlen]
+
+/-- The slot-lookup PB for the second binding in the body of an `elim`. -/
+lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
+    {head : Data} {tail : Data} :
+    PB.computes_at (env ++ ext ++ [head, tail])
+      (PB.atSlot (env.length + ext.length + 1)) tail := by
+  show PB.computes_at _ (fun _ => .var (env.length + ext.length + 1)) _
+  have hlen : env.length + ext.length + 1
+      < (env ++ ext ++ [head, tail]).length := by simp; omega
+  grind [PB.var_computes_at hlen]
+
+/-- `fold` at a fixed env: lifts `Prog.fold_eval` pointwise. The body hypothesis
+is packaged as `PB.computes_at_body₂` parameterised over the current
+accumulator `acc` and element `el`. -/
+lemma PB.fold_computes_at {env : List Data} {init list : PB}
+    {body : PB → PB → PB}
+    {da : Data} {dl : List Data} {f : Data → Data → Data}
+    (hi : PB.computes_at env init da)
+    (hl : PB.computes_at env list (Data.l dl))
+    (hbody : ∀ acc el, PB.computes_at_body₂ env acc el body (f acc el)) :
+    PB.computes_at env (PB.fold body init list) (dl.foldl f da) := by
+  intro ext
+  simp only [PB.fold]
+  refine Prog.fold_eval (hi ext) (hl ext)
+    (fun k => (dl.take k).foldl f da) rfl (by simp) ?_
+  intro k hk
+  have h := (hbody ((dl.take k).foldl f da) dl[k] ext).here
+  have hfoldl_succ :
+      (dl.take (k+1)).foldl f da = f ((dl.take k).foldl f da) dl[k] := by
+    rw [List.take_succ, List.foldl_append]
+    simp [List.getElem?_eq_getElem hk]
+  simp only [hfoldl_succ]
+  simpa [PB.atSlot, List.append_assoc] using h
+
+/-! ### Spec for `PB.while_`
+
+`PB.while_ init body` is a real while loop: it starts from `init`, checks the
+halt condition (`asList.headD = []`) on the current accumulator, and either
+returns it (halt) or runs `body` and loops with the body's result. -/
+
+/-- Generic iteration spec for `PB.while_`. The result is `f^[N] init` where
+`N` is the smallest iteration index whose encoding's `headD` is empty. -/
+lemma PB.while_computes_iter {α : Type} [DataEncode α]
+    {env : List Data} {p_init : PB} {body : PB → PB}
+    (f : α → α) (init : α)
+    (h_init : PB.computes_at env p_init (DataEncode.encode init))
+    (h_body : ∀ c, PB.computes_at_body₁ env (DataEncode.encode c) body
+        (DataEncode.encode (f c)))
+    (h_halts : ∃ n, (DataEncode.encode (f^[n] init)).asList.headD (Data.l []) = Data.l []) :
+    PB.computes_at env (PB.while_ p_init body) (DataEncode.encode (f^[Nat.find h_halts] init)) := by
+  intro ext
+  set n := env.length + ext.length with hn
+  set bd : Prog := body (fun _ => .var n) (n + 1) with bd_def
+  -- Unfold one level of `while_` at depth `n`.
+  change (Prog.while_ (p_init n) bd).eval (env ++ ext) = _
+  rw [Prog.while_eval]
+  rw [show (p_init n).eval (env ++ ext) = .some (DataEncode.encode init) by
+        simpa [hn] using h_init ext, Part.bind_some]
+  -- Reduce to a statement about `whileFrom_eval`.
+  set N := Nat.find h_halts with N_def
+  suffices ∀ k, k ≤ N →
+      Prog.whileFrom_eval bd (env ++ ext) (DataEncode.encode (f^[k] init))
+        = .some (DataEncode.encode (f^[N] init)) from this 0 (Nat.zero_le _)
+  intro k hk
+  -- Induct on the distance to `N`.
+  induction hd : N - k generalizing k with
+  | zero =>
+    have hkN : k = N := by omega
+    subst hkN
+    exact Prog.whileFrom_eval_halt (Nat.find_spec h_halts)
+  | succ m ih =>
+    have hkN : k < N := by omega
+    have h_not_halt :
+        (DataEncode.encode (f^[k] init)).asList.headD (Data.l []) ≠ Data.l [] :=
+      Nat.find_min h_halts hkN
+    rw [Prog.whileFrom_eval_step h_not_halt]
+    -- The body computes `f` at `f^[k] init`.
+    have h_body_eval : bd.eval ((env ++ ext) ++ [DataEncode.encode (f^[k] init)]) =
+        .some (DataEncode.encode (f (f^[k] init))) := by
+      have h := (h_body (f^[k] init) ext).here
+      simpa [bd_def, hn, PB.atSlot] using h
+    rw [h_body_eval, Part.bind_some]
+    rw [show f (f^[k] init) = f^[k+1] init from (Function.iterate_succ_apply' f k init).symm]
+    exact ih (k + 1) (by omega) (by omega)
+
+
+/-- `letIn` at a fixed env: the body hypothesis is packaged as `PB.computes_at_body₁`. -/
+lemma PB.letIn_computes_at {env : List Data} {val : PB} {body : PB → PB}
+    {dv dr : Data}
+    (hv : PB.computes_at env val dv)
+    (hbody : PB.computes_at_body₁ env dv body dr) :
+    PB.computes_at env (PB.letIn val body) dr := by
+  intro ext
+  show (Prog.letin (val (env.length + ext.length))
+      (body (fun _ => Prog.var (env.length + ext.length))
+        (env.length + ext.length + 1))).eval (env ++ ext) = .some dr
+  rw [Prog.letin_eval (hv ext)]
+  have h := (hbody ext).here
+  simpa [PB.atSlot] using h
+
+/-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
+lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
+    (hx : PB.computes_at env x dx) :
+    PB.computes_at env (PB.tail x) (Data.l dx.asList.tail) := by
+  cases h : dx.asList with
+  | nil =>
+    refine PB.elim_nil_computes_at ?_ ?_
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+    · simp
+  | cons head tail =>
+    unfold PB.tail
+    apply PB.elim_cons_computes_at (em := PB.empty) (cs := fun _h tl => tl)
+    · intro ext; rw [hx ext]; congr 1
+      rw [← Data.asList_l dx, h]
+    · intro ext
+      exact PB.elim_cons_tail_var_computes_at
+
+/-- `PB.head` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
+lemma PB.head_computes_at {env : List Data} {x : PB} {dx : Data}
+    (hx : PB.computes_at env x dx) :
+    PB.computes_at env (PB.head x) (dx.asList.headD (Data.l [])) := by
+  cases h : dx.asList with
+  | nil =>
+    refine PB.elim_nil_computes_at ?_ (by simp)
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+  | cons head tail =>
+    apply PB.elim_cons_computes_at
+    · intro ext; have := hx ext; rw [this]; congr 1
+      rw [← Data.asList_l dx, h]
+    · intro ext
+      exact PB.elim_cons_head_var_computes_at
+
+/-! ### Option B (mentioned for completeness): recover the ∀-quantified version
+
+`PB.computes` is implied by the per-env strengthened version pointwise: if `impl`
+computes-at every env, it computes the constant value function. -/
+lemma PB.computes_of_computes_at {impl : PB} {d : Data}
+    (h : ∀ env, PB.computes_at env impl d) :
+    impl.computes (fun _ => d) := by
+  intro env; exact (h env).here
+
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
new file mode 100644
index 0000000000..b3acd20a75
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
@@ -0,0 +1,616 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Data
+public import Mathlib.Control.Fix
+public import Mathlib.Control.LawfulFix
+
+/-! # RoseTreeMachine V2 — Prog
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-- ================= Operations and programs
+
+-- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
+-- Each operation creates a new stack entry (a new tape) and can read from previous
+-- entries by index. Stack entries created in "inner" programs are temporary and deleted
+-- once the inner program terminates. This is especially relevant for space complexity of
+-- loops since it allows us to re-use the space of one iteration for the next iteration.
+
+def Var := ℕ
+deriving Repr
+
+/-- Abstract syntax tree. Binders (`letin`, `elim`'s cons branch, `fold`'s body, `while_`'s body)
+are *implicit*: each binder extends `env` with one or more fresh values, and the bound
+variable(s) are referred to as `var k` where `k = env.length` at the binding site.
+For ergonomic construction with named binders use `PB` below. -/
+inductive Prog where
+  | var (id : Var)
+  /-- `letin val rest`: evaluate `val`, append the result to `env`, then evaluate `rest`. -/
+  | letin (val : Prog) (rest : Prog)
+  | empty
+  | cons (h t : Prog)
+  /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
+      `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
+  | elim (v : Prog) (em : Prog) (cs : Prog)
+  | eq (a b : Prog)
+  /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
+      list; `body` runs once per element with `env` extended by `[acc, x]`. -/
+  | fold (body : Prog) (init list : Prog)
+  /-- `while_ init body`: `init` produces the starting accumulator; `body` runs with
+      `env` extended by the current accumulator. -/
+  | while_ (init body : Prog)
+deriving Repr
+
+/-- Evaluates `p` on `env` and returns the result, the time and the space consumption. -/
+def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
+  match p with
+    -- TODO charge for copy?
+  | .var id => .some (env[(show ℕ from id)]?.getD (Data.l []), 1, 1)
+  | .letin val rest => do
+    let (v, t, s) ← val.meteredEval env
+    let (r, t', s') ← rest.meteredEval (env ++ [v])
+    -- TODO charge for copy?
+    return (r, 1 + t + t', max s s')
+  | .empty => .some (Data.empty, 1, 1)
+  | .cons h t => do
+    let (head, h_t, h_s) ← h.meteredEval env
+    let (tail, t_t, t_s) ← t.meteredEval env
+    return (Data.l (head :: tail.asList), 1 + h_t + t_t, max h_s t_s)
+  | .elim v em cs => do
+    let (v', t, s) ← v.meteredEval env
+    match v' with
+    | Data.l [] =>
+      let (r, t', s') ← em.meteredEval env
+      return (r, 1 + t + t', max s s')
+    | Data.l (head :: tail) =>
+      let (r, t', s') ← cs.meteredEval (env ++ [head, Data.l tail])
+      return (r, 1 + t + t', max s s')
+  | .eq a b => do
+    let (a, a_t, a_s) ← a.meteredEval env
+    let (b, b_t, b_s) ← b.meteredEval env
+    (if a == b then Data.l [ Data.l [] ] else Data.l [], 1 + a_t + b_t, 1 + max a_s b_s)
+  | .fold body init list => do
+    let (i, i_t, i_s) ← init.meteredEval env
+    let (l, l_t, l_s) ← list.meteredEval env
+    l.asList.foldlM
+      (fun (acc, t, s) el => do
+        let (acc', b_t, b_s) ← body.meteredEval (env ++ [acc, el])
+        return (acc', 1 + t + b_t, max s b_s))
+      (i, 1 + i_t + l_t, max i_s l_s)
+  | .while_ init body => do
+    let (i, i_t, i_s) ← init.meteredEval env
+    -- Real while loop: check the halt condition on the current accumulator first.
+    -- If `acc.asList.headD = []` (empty head), halt and return `acc`.
+    -- Otherwise run `body` on the accumulator and loop with its result.
+    let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
+            (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
+      fun rec d_ts =>
+        let (acc, t, s) := d_ts
+        if acc.asList.headD (Data.l []) = Data.l [] then
+          .some (acc, t, s)
+        else
+          (body.meteredEval (env ++ [acc])).bind fun (r, b_t, b_s) =>
+            rec (r, t + 1 + b_t, max s b_s)
+    Part.fix F (i, 1 + i_t, max 1 i_s)
+  termination_by (sizeOf p, 0)
+
+------------------------------------
+--- We are just handling the semantics for now.
+--- Later on, it would probably make sense to define a variation of meteredEval
+--- that uses O-classes for the space and time, so we can use equality-transformations
+--- instead of inequalities in the semantics proofs.
+-------------------------------------------
+
+def Prog.eval (p : Prog) (env : List Data) : Part Data := (p.meteredEval env).map Prod.fst
+
+def Prog.computes (impl : Prog) (f : List Data → Data) : Prop :=
+  ∀ env, impl.eval env = .some (f env)
+
+/-- `Prog.eval` returns `.some d` iff the underlying metered evaluation returns some triple
+with first component `d`. -/
+lemma Prog.eval_some_iff_meteredEval {p : Prog} {env : List Data} {d : Data} :
+    p.eval env = .some d ↔ ∃ t s, p.meteredEval env = .some (d, t, s) := by
+  rw [Prog.eval]
+  constructor
+  · intro h
+    rw [Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', t, s⟩, hm, heq⟩ := h
+    cases heq
+    exact ⟨t, s, Part.eq_some_iff.mpr hm⟩
+  · rintro ⟨t, s, h⟩; rw [h]; rfl
+
+/-- Pointwise (single-env) version of `Prog.cons_computes`. -/
+lemma Prog.cons_eval {h t : Prog} {env : List Data} {dh dt : Data}
+    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
+    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) := by
+  obtain ⟨th, sh, hmh⟩ := Prog.eval_some_iff_meteredEval.mp hh
+  obtain ⟨tt, st, hmt⟩ := Prog.eval_some_iff_meteredEval.mp ht
+  show (Prog.meteredEval env (Prog.cons h t)).map Prod.fst = _
+  rw [Prog.meteredEval, hmh]
+  simp only [bind, Part.bind_some, hmt, pure, Part.map_some]
+
+/-- Pointwise (single-env) version for `elim`. -/
+lemma Prog.elim_eval {v em cs : Prog} {env : List Data} {dv : Data}
+    (hv : v.eval env = .some dv) :
+    (Prog.elim v em cs).eval env =
+      match dv.asList with
+      | [] => em.eval env
+      | head :: tail => cs.eval (env ++ [head, Data.l tail]) := by
+  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
+  show (Prog.meteredEval env (Prog.elim v em cs)).map Prod.fst = _
+  rw [Prog.meteredEval, hmv]
+  simp only [bind, Part.bind_some]
+  rcases h : dv.asList with _ | ⟨head, tail⟩
+  · have hdv : dv = Data.l [] := by rw [← Data.asList_l dv, h]
+    rw [hdv]; simp only; rw [Prog.eval]; ext d
+    simp [Part.mem_map_iff, Part.mem_bind_iff]
+  · have hdv : dv = Data.l (head :: tail) := by rw [← Data.asList_l dv, h]
+    rw [hdv]; simp only; rw [Prog.eval]; ext d
+    simp [Part.mem_map_iff, Part.mem_bind_iff]
+
+/-- The loop core of `while_`: starting from accumulator `acc` (a `Data`),
+halt and return `acc` if its `asList.headD` is empty; otherwise run `body` on
+`env ++ [acc]` and recurse on the result. -/
+noncomputable def Prog.whileFrom_eval (body : Prog) (env : List Data) : Data → Part Data :=
+  Part.fix fun rec acc =>
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      Part.some acc
+    else
+      (body.eval (env ++ [acc])).bind rec
+
+/-- The loop body for `whileFrom_eval` is `ωScottContinuous`, which gives us access
+to `Part.fix_eq` for unrolling. -/
+lemma Prog.whileFrom_eval_continuous (body : Prog) (env : List Data) :
+    OmegaCompletePartialOrder.ωScottContinuous
+      (fun (rec : Data → Part Data) (acc : Data) =>
+        if acc.asList.headD (Data.l []) = Data.l [] then
+          Part.some acc
+        else
+          (body.eval (env ++ [acc])).bind rec) := by
+  apply OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+  intro a
+  by_cases h : a.asList.headD (Data.l []) = Data.l []
+  · simp only [h, if_true]
+    exact OmegaCompletePartialOrder.ωScottContinuous.const
+  · simp only [h, if_false]
+    exact OmegaCompletePartialOrder.ContinuousHom.ωScottContinuous.bind
+      OmegaCompletePartialOrder.ωScottContinuous.const
+      (OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+        (fun _ => OmegaCompletePartialOrder.ωScottContinuous.id.apply₂ _))
+
+/-- Halt-step unrolling for `whileFrom_eval`. -/
+lemma Prog.whileFrom_eval_halt {body : Prog} {env : List Data} {acc : Data}
+    (h_halt : acc.asList.headD (Data.l []) = Data.l []) :
+    Prog.whileFrom_eval body env acc = .some acc := by
+  unfold Prog.whileFrom_eval
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
+  simp only [h_halt, if_true]
+
+/-- Body-step unrolling for `whileFrom_eval`. -/
+lemma Prog.whileFrom_eval_step {body : Prog} {env : List Data} {acc : Data}
+    (h_step : acc.asList.headD (Data.l []) ≠ Data.l []) :
+    Prog.whileFrom_eval body env acc =
+      (body.eval (env ++ [acc])).bind (Prog.whileFrom_eval body env) := by
+  conv_lhs => unfold Prog.whileFrom_eval
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.whileFrom_eval_continuous body env)]
+  simp only [h_step, if_false]
+  rfl
+
+/-! ### Auxiliary metered/non-metered correspondence for `Prog.while_eval`.
+
+These private helpers factor out the metered and non-metered loop bodies and
+establish that the metered fix, projected to its data component, equals the
+non-metered `whileFrom_eval`. This is the key ingredient for `Prog.while_eval`.
+-/
+
+private noncomputable def Prog.metered_F (body : Prog) (env : List Data) :
+    ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) → (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
+  fun rec d_ts =>
+    let (acc, t, s) := d_ts
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      .some (acc, t, s)
+    else
+      (body.meteredEval (env ++ [acc])).bind fun y =>
+        rec (y.1, t + 1 + y.2.1, max s y.2.2)
+
+private noncomputable def Prog.nonmet_G (body : Prog) (env : List Data) :
+    (Data → Part Data) → Data → Part Data :=
+  fun rec acc =>
+    if acc.asList.headD (Data.l []) = Data.l [] then
+      Part.some acc
+    else
+      (body.eval (env ++ [acc])).bind rec
+
+private lemma Prog.metered_F_monotone (body : Prog) (env : List Data) :
+    Monotone (Prog.metered_F body env) := by
+  intro f g hfg ⟨acc, t, s⟩ x hx
+  unfold Prog.metered_F at hx ⊢
+  simp only at hx ⊢
+  by_cases h : acc.asList.headD (Data.l []) = Data.l []
+  · rw [if_pos h] at hx ⊢; exact hx
+  · rw [if_neg h] at hx ⊢
+    rw [Part.mem_bind_iff] at hx ⊢
+    obtain ⟨y, hy1, hy2⟩ := hx
+    exact ⟨y, hy1, hfg _ _ hy2⟩
+
+private lemma Prog.nonmet_G_monotone (body : Prog) (env : List Data) :
+    Monotone (Prog.nonmet_G body env) := by
+  intro f g hfg acc x hx
+  unfold Prog.nonmet_G at hx ⊢
+  by_cases h : acc.asList.headD (Data.l []) = Data.l []
+  · rw [if_pos h] at hx ⊢; exact hx
+  · rw [if_neg h] at hx ⊢
+    rw [Part.mem_bind_iff] at hx ⊢
+    obtain ⟨y, hy1, hy2⟩ := hx
+    exact ⟨y, hy1, hfg _ _ hy2⟩
+
+private lemma Prog.approx_metered_to_nonmet (body : Prog) (env : List Data) :
+    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data) (t' s' : ℕ),
+      (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) →
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i := by
+  intro n
+  induction n with
+  | zero => intro i t s r t' s' h; exact absurd h (Part.notMem_none _)
+  | succ n ih =>
+    intro i t s r t' s' h
+    show r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i
+    have hF : (r, t', s') ∈
+        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s) := h
+    unfold Prog.metered_F at hF
+    unfold Prog.nonmet_G
+    simp only at hF
+    by_cases hh : i.asList.headD (Data.l []) = Data.l []
+    · rw [if_pos hh] at hF; rw [if_pos hh]
+      rw [Part.mem_some_iff] at hF
+      have : r = i := (Prod.mk.injEq ..).mp hF |>.1
+      subst this
+      exact Part.mem_some _
+    · rw [if_neg hh] at hF; rw [if_neg hh]
+      rw [Part.mem_bind_iff] at hF
+      obtain ⟨⟨r0, bt, bs⟩, hb, hrec⟩ := hF
+      rw [Part.mem_bind_iff]
+      refine ⟨r0, ?_, ih r0 _ _ r t' s' hrec⟩
+      show r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst
+      rw [Part.mem_map_iff]
+      exact ⟨(r0, bt, bs), hb, rfl⟩
+
+private lemma Prog.approx_nonmet_to_metered (body : Prog) (env : List Data) :
+    ∀ (n : ℕ) (i : Data) (t s : ℕ) (r : Data),
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n i →
+      ∃ t' s', (r, t', s') ∈ Part.Fix.approx (Prog.metered_F body env) n (i, t, s) := by
+  intro n
+  induction n with
+  | zero => intro i t s r h; exact absurd h (Part.notMem_none _)
+  | succ n ih =>
+    intro i t s r h
+    show ∃ t' s', (r, t', s') ∈
+        (Prog.metered_F body env) (Part.Fix.approx (Prog.metered_F body env) n) (i, t, s)
+    have hG : r ∈ (Prog.nonmet_G body env) (Part.Fix.approx (Prog.nonmet_G body env) n) i := h
+    unfold Prog.nonmet_G at hG
+    unfold Prog.metered_F
+    simp only
+    by_cases hh : i.asList.headD (Data.l []) = Data.l []
+    · rw [if_pos hh] at hG; rw [if_pos hh]
+      rw [Part.mem_some_iff] at hG; subst hG
+      exact ⟨t, s, Part.mem_some _⟩
+    · rw [if_neg hh] at hG; rw [if_neg hh]
+      rw [Part.mem_bind_iff] at hG
+      obtain ⟨r0, hbody, hrec⟩ := hG
+      have hbody' : r0 ∈ (body.meteredEval (env ++ [i])).map Prod.fst := hbody
+      rw [Part.mem_map_iff] at hbody'
+      obtain ⟨⟨r0', bt, bs⟩, hmev, heq⟩ := hbody'
+      simp only at heq
+      have : r0' = r0 := heq
+      subst this
+      obtain ⟨t', s', hF⟩ := ih r0' (t + 1 + bt) (max s bs) r hrec
+      refine ⟨t', s', ?_⟩
+      rw [Part.mem_bind_iff]
+      exact ⟨(r0', bt, bs), hmev, hF⟩
+
+private lemma Prog.proj_fix_eq (body : Prog) (env : List Data) (i : Data) (t s : ℕ) :
+    (Part.fix (Prog.metered_F body env) (i, t, s)).map Prod.fst =
+      Prog.whileFrom_eval body env i := by
+  apply Part.ext
+  intro r
+  rw [Part.mem_map_iff]
+  let F_oh : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →o
+      ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) :=
+    ⟨Prog.metered_F body env, Prog.metered_F_monotone body env⟩
+  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
+    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
+  have hF_eq : ∀ {a b}, b ∈ Part.fix (Prog.metered_F body env) a ↔ b ∈ Part.fix (⇑F_oh) a := by
+    intros; rfl
+  have hG_eq : ∀ {a b}, b ∈ Part.fix (Prog.nonmet_G body env) a ↔ b ∈ Part.fix (⇑G_oh) a := by
+    intros; rfl
+  constructor
+  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
+    rw [hF_eq, Part.Fix.mem_iff F_oh] at hmem
+    obtain ⟨n, hn⟩ := hmem
+    show r' ∈ Prog.whileFrom_eval body env i
+    unfold Prog.whileFrom_eval
+    show r' ∈ Part.fix (Prog.nonmet_G body env) i
+    rw [hG_eq, Part.Fix.mem_iff G_oh]
+    exact ⟨n, Prog.approx_metered_to_nonmet body env n i t s r' _ _ hn⟩
+  · intro hr
+    have hr' : r ∈ Part.fix (Prog.nonmet_G body env) i := hr
+    rw [hG_eq, Part.Fix.mem_iff G_oh] at hr'
+    obtain ⟨n, hn⟩ := hr'
+    obtain ⟨t', s', hF⟩ := Prog.approx_nonmet_to_metered body env n i t s r hn
+    refine ⟨(r, t', s'), ?_, rfl⟩
+    rw [hF_eq, Part.Fix.mem_iff F_oh]
+    exact ⟨n, hF⟩
+
+/-- Pointwise (single-env) version for `while_`: the program evaluates `init`,
+then runs the loop body starting from that value. -/
+lemma Prog.while_eval {init body : Prog} {env : List Data} :
+    (Prog.while_ init body).eval env =
+      (init.eval env).bind (Prog.whileFrom_eval body env) := by
+  show (Prog.meteredEval env (Prog.while_ init body)).map Prod.fst = _
+  have hmEq : Prog.meteredEval env (Prog.while_ init body) =
+      (init.meteredEval env).bind (fun x =>
+        Part.fix (Prog.metered_F body env) (x.1, 1 + x.2.1, max 1 x.2.2)) := by
+    rw [Prog.meteredEval]; rfl
+  rw [hmEq]
+  apply Part.ext
+  intro r
+  rw [Part.mem_map_iff]
+  constructor
+  · rintro ⟨⟨r', t', s'⟩, hmem, rfl⟩
+    rw [Part.mem_bind_iff] at hmem
+    obtain ⟨⟨i, it, is⟩, hmi, hf⟩ := hmem
+    rw [Part.mem_bind_iff]
+    refine ⟨i, ?_, ?_⟩
+    · show i ∈ (init.meteredEval env).map Prod.fst
+      rw [Part.mem_map_iff]; exact ⟨_, hmi, rfl⟩
+    · rw [← Prog.proj_fix_eq body env i (1 + it) (max 1 is), Part.mem_map_iff]
+      exact ⟨_, hf, rfl⟩
+  · intro hr
+    rw [Part.mem_bind_iff] at hr
+    obtain ⟨i, hi, hr2⟩ := hr
+    have hi' : i ∈ (init.meteredEval env).map Prod.fst := hi
+    rw [Part.mem_map_iff] at hi'
+    obtain ⟨⟨i', it, is⟩, hmi, heq⟩ := hi'
+    simp only at heq
+    have hii : i' = i := heq
+    subst hii
+    rw [← Prog.proj_fix_eq body env i' (1 + it) (max 1 is), Part.mem_map_iff] at hr2
+    obtain ⟨⟨r', t', s'⟩, hF, rfl⟩ := hr2
+    refine ⟨(r', t', s'), ?_, rfl⟩
+    rw [Part.mem_bind_iff]
+    exact ⟨(i', it, is), hmi, hF⟩
+
+/-- Termination-extraction for `whileFrom_eval`: if the loop returns `.some r`,
+then there exists an iteration index `n` such that running the body `n` times
+from `acc` along the (deterministic) trajectory yields `r`, the halt condition
+holds at `r`, and the halt condition does not hold at any intermediate value. -/
+lemma Prog.whileFrom_eval_some {body : Prog} {env : List Data} {acc r : Data}
+    (h : Prog.whileFrom_eval body env acc = .some r) :
+    ∃ (n : ℕ) (traj : ℕ → Data),
+      traj 0 = acc ∧
+      traj n = r ∧
+      (r.asList.headD (Data.l []) = Data.l []) ∧
+      (∀ k < n,
+          (traj k).asList.headD (Data.l []) ≠ Data.l [] ∧
+          body.eval (env ++ [traj k]) = .some (traj (k+1))) := by
+  -- Helper: induct on approx index to extract a trajectory.
+  have approx_some_traj : ∀ (n : ℕ) (acc r : Data),
+      r ∈ Part.Fix.approx (Prog.nonmet_G body env) n acc →
+      ∃ (k : ℕ) (traj : ℕ → Data),
+        traj 0 = acc ∧ traj k = r ∧
+        (r.asList.headD (Data.l []) = Data.l []) ∧
+        (∀ j < k, (traj j).asList.headD (Data.l []) ≠ Data.l [] ∧
+                  body.eval (env ++ [traj j]) = .some (traj (j+1))) := by
+    intro n
+    induction n with
+    | zero => intro acc r h; exact absurd h (Part.notMem_none _)
+    | succ n ih =>
+      intro acc r h
+      have hG : r ∈ (Prog.nonmet_G body env)
+          (Part.Fix.approx (Prog.nonmet_G body env) n) acc := h
+      unfold Prog.nonmet_G at hG
+      by_cases hh : acc.asList.headD (Data.l []) = Data.l []
+      · rw [if_pos hh] at hG
+        rw [Part.mem_some_iff] at hG
+        cases hG
+        refine ⟨0, fun _ => acc, rfl, rfl, hh, ?_⟩
+        intro j hj; omega
+      · rw [if_neg hh] at hG
+        rw [Part.mem_bind_iff] at hG
+        obtain ⟨r0, hbody, hrec⟩ := hG
+        obtain ⟨k, traj', htraj0, htrajk, hr_halt, hsteps⟩ := ih r0 r hrec
+        refine ⟨k + 1, fun j => if j = 0 then acc else traj' (j - 1),
+                by simp, ?_, hr_halt, ?_⟩
+        · show (if k + 1 = 0 then acc else traj' (k + 1 - 1)) = r
+          rw [if_neg (by omega)]
+          have : k + 1 - 1 = k := by omega
+          rw [this]; exact htrajk
+        · intro j hj
+          cases j with
+          | zero =>
+            show (if (0 : ℕ) = 0 then acc else traj' (0 - 1)).asList.headD (Data.l []) ≠ Data.l [] ∧
+                 body.eval (env ++ [if (0 : ℕ) = 0 then acc else traj' (0 - 1)]) =
+                  .some (if (0 + 1 : ℕ) = 0 then acc else traj' (0 + 1 - 1))
+            simp only [if_true, if_neg (Nat.succ_ne_zero 0)]
+            refine ⟨hh, ?_⟩
+            have heval : body.eval (env ++ [acc]) = .some r0 :=
+              (Part.eq_some_iff.mpr hbody)
+            rw [heval]; congr 1
+            show r0 = traj' 0
+            exact htraj0.symm
+          | succ j =>
+            show (if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)).asList.headD
+                  (Data.l []) ≠ Data.l [] ∧
+                 body.eval (env ++ [if (j + 1 : ℕ) = 0 then acc else traj' (j + 1 - 1)]) =
+                  .some (if (j + 1 + 1 : ℕ) = 0 then acc else traj' (j + 1 + 1 - 1))
+            rw [if_neg (Nat.succ_ne_zero _), if_neg (Nat.succ_ne_zero _)]
+            have hjk : j < k := by omega
+            have h_idx1 : (j + 1 - 1 : ℕ) = j := by omega
+            have h_idx2 : (j + 1 + 1 - 1 : ℕ) = j + 1 := by omega
+            rw [h_idx1, h_idx2]
+            exact hsteps j hjk
+  have hmem : r ∈ Prog.whileFrom_eval body env acc := by rw [h]; exact Part.mem_some _
+  have hmem' : r ∈ Part.fix (Prog.nonmet_G body env) acc := hmem
+  let G_oh : (Data → Part Data) →o (Data → Part Data) :=
+    ⟨Prog.nonmet_G body env, Prog.nonmet_G_monotone body env⟩
+  have hmem'' : r ∈ Part.fix (⇑G_oh) acc := hmem'
+  rw [Part.Fix.mem_iff G_oh] at hmem''
+  obtain ⟨n, hn⟩ := hmem''
+  exact approx_some_traj n acc r hn
+
+/-! ## Surface syntax with named binders
+
+Define convenience builder functions to allow binding the variables to names.
+
+ -/
+
+
+/-! ### Pointwise `Prog`-level `simp` set
+
+Lifting eval rules to `@[simp]` lemmas lets you discharge most goals of the form
+`p.eval env = .some d` by `simp` plus at most one `rcases` on a list. -/
+
+@[simp] lemma Prog.var_eval {env : List Data} {i : ℕ} :
+    (Prog.var i).eval env = .some (env[i]?.getD (Data.l [])) := by
+  simp [Prog.eval, Prog.meteredEval]
+
+@[simp] lemma Prog.empty_eval {env : List Data} :
+    Prog.empty.eval env = .some (Data.l []) := by
+  simp [Prog.eval, Prog.meteredEval, Data.empty]
+
+@[simp] lemma Prog.cons_eval_simp {env : List Data} {h t : Prog} {dh dt : Data}
+    (hh : h.eval env = .some dh) (ht : t.eval env = .some dt) :
+    (Prog.cons h t).eval env = .some (Data.l (dh :: dt.asList)) :=
+  Prog.cons_eval hh ht
+
+@[simp] lemma Prog.elim_eval_nil {env : List Data} {v em cs : Prog}
+    (hv : v.eval env = .some (Data.l [])) :
+    (Prog.elim v em cs).eval env = em.eval env := by
+  have := Prog.elim_eval (em := em) (cs := cs) hv
+  simpa using this
+
+@[simp] lemma Prog.elim_eval_cons {env : List Data} {v em cs : Prog}
+    {head : Data} {tail : List Data}
+    (hv : v.eval env = .some (Data.l (head :: tail))) :
+    (Prog.elim v em cs).eval env = cs.eval (env ++ [head, Data.l tail]) := by
+  have := Prog.elim_eval (em := em) (cs := cs) hv
+  simpa using this
+
+@[simp] lemma Prog.letin_eval {env : List Data} {val rest : Prog} {dv : Data}
+    (hv : val.eval env = .some dv) :
+    (Prog.letin val rest).eval env = rest.eval (env ++ [dv]) := by
+  obtain ⟨t, s, hmv⟩ := Prog.eval_some_iff_meteredEval.mp hv
+  show (Prog.meteredEval env (Prog.letin val rest)).map Prod.fst = _
+  rw [Prog.meteredEval, hmv]
+  simp only [bind, Part.bind_some]
+  rw [Prog.eval]; ext d
+  simp [Part.mem_map_iff, Part.mem_bind_iff]
+
+@[simp] lemma Prog.eq_eval {env : List Data} {a b : Prog} {da db : Data}
+    (ha : a.eval env = .some da) (hb : b.eval env = .some db) :
+    (Prog.eq a b).eval env =
+      .some (if da = db then Data.l [Data.l []] else Data.l []) := by
+  obtain ⟨ta, sa, hma⟩ := Prog.eval_some_iff_meteredEval.mp ha
+  obtain ⟨tb, sb, hmb⟩ := Prog.eval_some_iff_meteredEval.mp hb
+  show (Prog.meteredEval env (Prog.eq a b)).map Prod.fst = _
+  rw [Prog.meteredEval, hma]
+  simp only [bind, Part.bind_some, hmb, beq_iff_eq]
+  by_cases h : da = db <;> simp [h, Part.map_some]
+
+/-- Helper for `Prog.fold_eval`: chained `foldlM` over `meteredEval`. -/
+private lemma Prog.foldlM_chain (body : Prog) (env : List Data)
+    (acc : ℕ → Data) :
+    ∀ (dl : List Data) (start : ℕ) (t s : ℕ),
+      (∀ k (h : k < dl.length),
+        body.eval (env ++ [acc (start + k), dl[k]]) = .some (acc (start + k + 1))) →
+      ∃ t' s', List.foldlM
+        (fun x el => (body.meteredEval (env ++ [x.1, el])).bind fun y =>
+          pure (y.1, 1 + x.2.1 + y.2.1, max x.2.2 y.2.2))
+        (acc start, t, s) dl = .some (acc (start + dl.length), t', s') := by
+  intro dl
+  induction dl with
+  | nil => intro start t s _hstep
+           refine ⟨t, s, ?_⟩
+           simp [List.foldlM]
+  | cons hd tl ih =>
+    intro start t s hstep
+    have h0 : body.eval (env ++ [acc start, hd]) = .some (acc (start + 1)) := by
+      have := hstep 0 (by simp)
+      simpa using this
+    obtain ⟨bt, bs, hmb⟩ := Prog.eval_some_iff_meteredEval.mp h0
+    simp only [List.foldlM_cons, List.length_cons, hmb, Part.bind_some, pure, bind]
+    have hstep' : ∀ k (h : k < tl.length),
+        body.eval (env ++ [acc ((start + 1) + k), tl[k]]) = .some (acc ((start + 1) + k + 1)) := by
+      intro k hk
+      have hh : k + 1 < (hd :: tl).length := by rw [List.length_cons]; omega
+      have := hstep (k + 1) hh
+      have h_eq : (hd :: tl)[k + 1] = tl[k] := by simp
+      rw [h_eq] at this
+      have h1 : start + 1 + k = start + (k + 1) := by omega
+      rw [h1]; exact this
+    obtain ⟨t', s', ih_res⟩ := ih (start + 1) (1 + t + bt) (max s bs) hstep'
+    refine ⟨t', s', ?_⟩
+    have h_len : start + (tl.length + 1) = (start + 1) + tl.length := by omega
+    rw [h_len]; exact ih_res
+
+/-- Semantic spec for `Prog.fold`. Rather than quantifying the body universally
+over arbitrary `Data` accumulators/elements, we parameterise by the actually
+visited accumulator sequence `acc : ℕ → Data`. This makes the lemma usable both
+for untyped and typed/encoded fold reasoning. -/
+lemma Prog.fold_eval {env : List Data} {body init list : Prog}
+    {da : Data} {dl : List Data} {result : Data}
+    (hi : init.eval env = .some da)
+    (hl : list.eval env = .some (Data.l dl))
+    (acc : ℕ → Data)
+    (hacc0 : acc 0 = da)
+    (haccN : acc dl.length = result)
+    (hstep : ∀ k (h : k < dl.length),
+      body.eval (env ++ [acc k, dl[k]]) = .some (acc (k+1))) :
+    (Prog.fold body init list).eval env = .some result := by
+  obtain ⟨it, is, hmi⟩ := Prog.eval_some_iff_meteredEval.mp hi
+  obtain ⟨lt, ls, hml⟩ := Prog.eval_some_iff_meteredEval.mp hl
+  rw [← hacc0] at hmi
+  have hstep' : ∀ k (h : k < dl.length),
+      body.eval (env ++ [acc (0 + k), dl[k]]) = .some (acc (0 + k + 1)) := by
+    intro k hk; simpa using hstep k hk
+  obtain ⟨t', s', hfold⟩ := Prog.foldlM_chain body env acc dl 0 (1 + it + lt) (max is ls) hstep'
+  show (Prog.meteredEval env (Prog.fold body init list)).map Prod.fst = _
+  rw [Prog.meteredEval, hmi]
+  simp only [bind, Part.bind_some, hml, Data.l_asList]
+  rw [hfold]
+  simp [haccN]
+
+/-- Example: with the `simp` set above, the `tail` spec on a concrete env is short. -/
+example {env : List Data} {x : Prog} {dx : Data} (hx : x.eval env = .some dx) :
+    (Prog.elim x Prog.empty (Prog.var (env.length + 1))).eval env =
+      .some (Data.l dx.asList.tail) := by
+  rcases h : dx.asList with _ | ⟨head, tail⟩
+  · have hx' : x.eval env = .some (Data.l []) := by
+      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
+    simp [Prog.elim_eval_nil hx']
+  · have hx' : x.eval env = .some (Data.l (head :: tail)) := by
+      rw [hx]; congr 1; rw [← Data.asList_l dx, h]
+    rw [Prog.elim_eval_cons hx', Prog.var_eval]
+    have hidx : (env ++ [head, Data.l tail])[env.length + 1]? = some (Data.l tail) := by
+      simp [List.getElem?_append_right]
+    simp only [hidx, Option.getD_some]
+    rfl
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
new file mode 100644
index 0000000000..54d20a85aa
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
@@ -0,0 +1,191 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.PB
+
+/-! # RoseTreeMachine V2 — Tools
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+/-- Program that evaluates to the constant `a`. -/
+def constant (a : Data) : PB := match a with
+  | Data.l [] => PB.empty
+  | Data.l (x :: xs) => PB.cons (constant x) (constant (Data.l xs))
+
+lemma constant_computes {env : List Data} {a : Data} :
+    (constant a).computes_at env a := by
+  induction a using Data.inductionL with
+  | nil => simp [constant]
+  | cons x xs ihx ihxs =>
+    simpa [constant] using PB.cons_computes_at ihx ihxs
+
+def encConst {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a)
+
+def PB.ifEq (a b : PB) (then_ else_ : PB) : PB :=
+  .elim (PB.eq a b)
+    else_
+    fun _ _ => then_
+
+lemma PB.ifEq_computes_at {env : List Data} {a b then_ else_ : PB} {da db dr : Data}
+    (ha : PB.computes_at env a da) (hb : PB.computes_at env b db)
+    (hthen : da = db → PB.computes_at env then_ dr)
+    (helse : da ≠ db → PB.computes_at env else_ dr) :
+    (PB.ifEq a b then_ else_).computes_at env dr := by
+  unfold PB.ifEq
+  by_cases h : da = db
+  · have heq : PB.computes_at env (PB.eq a b) (Data.l [Data.l []]) := by
+      simpa [h] using PB.eq_computes_at ha hb
+    refine PB.elim_cons_computes_at heq ?_
+    intro ext
+    have h' := (hthen h).extend (ext := ext ++ [Data.l [], Data.l []])
+    simpa [List.append_assoc] using h'
+  · have heq : PB.computes_at env (PB.eq a b) (Data.l []) := by
+      simpa [h] using PB.eq_computes_at ha hb
+    exact PB.elim_nil_computes_at heq (helse h)
+
+------------------------------------------------------
+----------- Tools
+-----------------------------------------------------------
+
+
+def PB.fst (x : PB) : PB := head x
+
+-- Compute fun x => x.snd
+def PB.snd (x : PB) : PB := head (tail x)
+
+-- Compute x => Option.some x
+def PB.some (x : PB) : PB := cons x empty
+
+def PB.optionElim (x : PB) (noneCase : PB) (someCase : PB → PB) : PB :=
+  elim x noneCase (fun hd _ => someCase hd)
+
+----------------- Typed computation
+
+def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
+    PB.computes_at env x (DataEncode.encode a)
+
+@[simp]
+lemma PB.atSlot_last_computes_at_encoded {α : Type} [DataEncode α]
+    {env ext : List Data} {a : α} :
+    PB.computes_at_encoded (env ++ ext ++ [DataEncode.encode a])
+      (PB.atSlot (env.length + ext.length)) a :=
+  PB.atSlot_last_computes_at
+
+@[simp]
+lemma PB.atSlot_last_computes_at_encoded_right {α : Type} [DataEncode α]
+    {env ext : List Data} {a : α} :
+    PB.computes_at_encoded (env ++ (ext ++ [DataEncode.encode a]))
+      (PB.atSlot (env.length + ext.length)) a :=
+  PB.atSlot_last_computes_at_right
+
+/-- Encoded body-of-binder hypothesis: the body computes a typed value `a`
+under any outer env extension. -/
+abbrev PB.computes_at_body_encoded {α : Type} [DataEncode α]
+    (env : List Data) (bindings : List Data)
+    (mkBody : (Fin bindings.length → PB) → PB) (a : α) : Prop :=
+  PB.computes_at_body env bindings mkBody (DataEncode.encode a)
+
+abbrev PB.computes_at_body₁_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    (env : List Data) (a : α) (body : PB → PB) (b : β) : Prop :=
+  PB.computes_at_body₁ env (DataEncode.encode a) body (DataEncode.encode b)
+
+abbrev PB.computes_at_body₂_encoded {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ]
+    (env : List Data) (a : α) (b : β) (body : PB → PB → PB) (c : γ) : Prop :=
+  PB.computes_at_body₂ env (DataEncode.encode a) (DataEncode.encode b) body (DataEncode.encode c)
+
+lemma PB.fst_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.fst x) a.fst := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes_at hx
+
+lemma PB.snd_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.snd x) a.snd := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes_at (PB.tail_computes_at hx)
+
+lemma PB.some_computes_at_encoded {α : Type} [DataEncode α]
+    {env : List Data} {x : PB} {a : α}
+    (hx : PB.computes_at_encoded env x a) :
+    PB.computes_at_encoded env (PB.some x) (Option.some a) := by
+  apply PB.cons_computes_at hx PB.empty_computes_at
+
+lemma PB.optionElim_computes_none {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
+    (hx : x.computes_at_encoded env (none : Option α))
+    {a : β}
+    (h_none : noneCase.computes_at_encoded env a) :
+    (PB.optionElim x noneCase someCase).computes_at_encoded env a := by
+  apply PB.elim_nil_computes_at hx h_none
+
+lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
+    {a : α}
+    (hx : x.computes_at_encoded env (Option.some a))
+    {b : β}
+    (h_some : PB.computes_at_body₁_encoded env a someCase b) :
+    (PB.optionElim x noneCase someCase).computes_at_encoded env b := by
+  apply PB.elim_cons_computes_at hx
+  intro ext
+  simpa [List.append_assoc] using (h_some ext).extend
+
+lemma PB.letIn_computes_at_encoded {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {val : PB} {body : PB → PB} {v : α} {b : β}
+    (hv : val.computes_at_encoded env v)
+    (hbody : PB.computes_at_body₁_encoded env v body b) :
+    (PB.letIn val body).computes_at_encoded env b :=
+  PB.letIn_computes_at hv hbody
+
+/-- Encoded variant of `PB.fold_computes_at`: typed accumulator `a : α`, typed
+list elements of type `β`, and a typed step function `f : α → β → α`. The body
+hypothesis is `PB.computes_at_body₂_encoded` parameterised over `acc : α` and
+`el : β`. -/
+lemma PB.fold_computes_at_encoded
+    {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {init list : PB} {body : PB → PB → PB}
+    {a : α} {l : List β} {f : α → β → α}
+    (hi : init.computes_at_encoded env a)
+    (hl : list.computes_at_encoded env l)
+    (hbody : ∀ acc el, PB.computes_at_body₂_encoded env acc el body (f acc el)) :
+    PB.computes_at_encoded env (PB.fold body init list) (l.foldl f a) := by
+  intro ext
+  simp only [PB.fold]
+  have hl' :
+      (list (env.length + ext.length)).eval (env ++ ext)
+        = .some (Data.l (l.map DataEncode.encode)) := hl ext
+  refine Prog.fold_eval (hi ext) hl'
+    (fun k => DataEncode.encode ((l.take k).foldl f a)) rfl (by simp) ?_
+  intro k hk
+  have hk' : k < l.length := by simpa using hk
+  have h := (hbody ((l.take k).foldl f a) l[k] ext).here
+  have hfoldl_succ :
+      (l.take (k+1)).foldl f a = f ((l.take k).foldl f a) l[k] := by
+    rw [List.take_succ, List.foldl_append]
+    simp [List.getElem?_eq_getElem hk']
+  have hget : (l.map DataEncode.encode)[k] = DataEncode.encode l[k] := by simp
+  simp only [hget, hfoldl_succ]
+  simpa [PB.atSlot, List.append_assoc] using h
+-------------------------------------------------------------------
+---------------- Universal Turing Machine (simulation of a SingleTapeTM)
+---------------------------------------------------------------------------
+
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
new file mode 100644
index 0000000000..35312d1174
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
@@ -0,0 +1,1124 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Tools
+public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+public import Mathlib.Data.List.ReduceOption
+
+/-! # RoseTreeMachine V2 — UniversalTM
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
+
+public instance : DataEncode (Turing.StackTape Symbol) where
+  encode t := DataEncode.encode t.toList
+  h_inj := by
+    intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h
+    have : l₁ = l₂ := DataEncode.h_inj h
+    cases this; rfl
+
+public instance : DataEncode (Turing.BiTape Symbol) where
+  encode t := DataEncode.encode (t.head, t.left, t.right)
+  h_inj := by
+    intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hh, hl, hr⟩ := heq
+    cases hh; cases hl; cases hr; rfl
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_biTape (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+
+def bitape_write (t v : PB) : PB := PB.cons v t.tail
+
+lemma bitape_write_computes
+    {env : List Data} {p_t p_v : PB} {t : BiTape Symbol} {v : Option Symbol}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_v : PB.computes_at_encoded env p_v v) :
+    PB.computes_at_encoded env (bitape_write p_t p_v) (t.write v) := by
+  simp only [PB.computes_at_encoded, encode_biTape, DataEncode_pair] at h_t h_v ⊢
+  apply PB.cons_computes_at h_v (PB.tail_computes_at h_t)
+
+-- /-- Prepend an `Option` to the `StackTape` -/
+-- @[scoped grind]
+-- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
+--   match x, xs with
+--   | none, ⟨[], _⟩ => ⟨[], by grind⟩
+--   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
+--   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
+
+def stackTape_cons (x st : PB) : PB :=
+  PB.optionElim x
+    (PB.elim st
+      PB.empty
+      (fun _ _ => PB.cons x st))
+    (fun _ => PB.cons x st)
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma stackTape_cons_computes
+    {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
+    (h_x : PB.computes_at_encoded env p_x x)
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (stackTape_cons p_x p_st).computes_at_encoded env (st.cons x) := by
+  cases x with
+  | none =>
+    apply PB.optionElim_computes_none h_x
+    obtain ⟨l, hl⟩ := st
+    cases l with
+    | nil =>
+      simpa [DataEncode.encode] using
+        PB.elim_nil_computes_at (by simpa using h_st) (PB.empty_computes_at)
+    | cons hd tl =>
+      apply PB.elim_cons_computes_at (by simpa [DataEncode.encode] using h_st)
+      intro ext
+      simpa using (PB.cons_computes_at h_x h_st).extend
+  | some a =>
+    apply PB.optionElim_computes_some h_x
+    intro ext
+    simpa using (PB.cons_computes_at (by simpa [DataEncode.encode] using h_x) h_st).extend
+
+def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
+
+lemma to_pair_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p_a p_b : PB}
+    {a : α} {b : β}
+    (h_a : p_a.computes_at_encoded env a)
+    (h_b : p_b.computes_at_encoded env b) :
+    (to_pair p_a p_b).computes_at_encoded env (a, b) := by
+  simpa [DataEncode.encode, to_pair] using
+    PB.cons_computes_at h_a (PB.cons_computes_at h_b PB.empty_computes_at)
+
+--- The head component of the bitape
+def bitape_head (t : PB) : PB := t.fst
+--- The left component of the bitape
+def bitape_left (t : PB) : PB := t.snd.fst
+--- The right component of the bitape
+def bitape_right (t : PB) : PB := t.snd.snd
+
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_head_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_head p_t).computes_at_encoded env t.head := PB.head_computes_at h_t
+
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_left_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_left p_t).computes_at_encoded env t.left :=
+  PB.head_computes_at (PB.head_computes_at (PB.tail_computes_at h_t))
+
+omit [Inhabited Symbol] [Fintype Symbol]
+lemma bitape_right_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    (bitape_right p_t).computes_at_encoded env t.right :=
+  PB.head_computes_at (PB.tail_computes_at (PB.head_computes_at (PB.tail_computes_at h_t)))
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_stackTape_head (st : StackTape Symbol) :
+    (DataEncode.encode st).asList.headD (Data.l []) = DataEncode.encode st.head := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.head, Data.asList]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma encode_stackTape_tail (st : StackTape Symbol) :
+    Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList]
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma stackTape_head_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (p_st.head).computes_at_encoded env st.head := by
+  unfold PB.computes_at_encoded
+  simpa [← encode_stackTape_head] using PB.head_computes_at h_st
+
+omit [Inhabited Symbol] [Fintype Symbol] in
+lemma stackTape_tail_computes_at_encoded {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_at_encoded env p_st st) :
+    (p_st.tail).computes_at_encoded env st.tail := by
+  unfold PB.computes_at_encoded
+  simpa [← encode_stackTape_tail] using PB.tail_computes_at h_st
+
+-- def move_left (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
+
+def bitape_move_left (t : PB) : PB :=
+  to_pair (bitape_left t).head
+    (to_pair
+      (bitape_left t).tail
+      (stackTape_cons (bitape_head t) (bitape_right t)))
+
+lemma bitape_move_left_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    PB.computes_at_encoded env (bitape_move_left p_t) t.move_left := by
+  unfold PB.computes_at_encoded
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_at_encoded (bitape_left_computes h_t))
+    (to_pair_computes
+      (stackTape_tail_computes_at_encoded (bitape_left_computes h_t))
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
+
+-- def move_right (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
+
+def bitape_move_right (t : PB) : PB :=
+  to_pair (bitape_right t).head
+    (to_pair
+      (stackTape_cons (bitape_head t) (bitape_left t))
+      (bitape_right t).tail)
+
+lemma bitape_move_right_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_at_encoded env p_t t) :
+    PB.computes_at_encoded env (bitape_move_right p_t) t.move_right := by
+  unfold PB.computes_at_encoded
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_at_encoded (bitape_right_computes h_t))
+    (to_pair_computes
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_left_computes h_t))
+      (stackTape_tail_computes_at_encoded (bitape_right_computes h_t)))
+
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => DataEncode.encode true
+    | Dir.right => DataEncode.encode false
+  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
+
+-- /--
+-- Move the head to the left or right, shifting the tape underneath it.
+-- -/
+-- def move (t : BiTape Symbol) : Dir → BiTape Symbol
+--   | .left => t.move_left
+--   | .right => t.move_right
+
+def bitape_move (tape dir : PB) : PB :=
+  PB.ifEq dir (constant (DataEncode.encode Dir.left))
+    (bitape_move_left tape)
+    (bitape_move_right tape)
+
+lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_dir : PB.computes_at_encoded env p_dir d) :
+    (bitape_move p_t p_dir).computes_at_encoded env (t.move d) := by
+  unfold PB.computes_at_encoded bitape_move
+  refine PB.ifEq_computes_at h_dir constant_computes ?_ ?_
+  · intro hd_eq
+    -- TODO could use injectivity here once we have it.
+    cases d with
+    | left => exact bitape_move_left_computes h_t
+    | right =>
+      exfalso
+      exact absurd hd_eq (by decide)
+  · intro hne
+    cases d with
+    | left => exact absurd rfl hne
+    | right => exact bitape_move_right_computes h_t
+
+-- /--
+-- Optionally perform a `move`, or do nothing if `none`.
+-- -/
+-- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
+--   | t, none => t
+--   | t, some d => t.move d
+
+def bitape_optionMove (t dir : PB) : PB :=
+  PB.optionElim dir
+    t
+    (fun d => bitape_move t d)
+
+lemma bitape_optionMove_computes {env : List Data} {p_t p_dir : PB}
+    {t : BiTape Symbol} {d : Option Dir}
+    (h_t : PB.computes_at_encoded env p_t t)
+    (h_dir : PB.computes_at_encoded env p_dir d) :
+    (bitape_optionMove p_t p_dir).computes_at_encoded env (t.optionMove d) := by
+  unfold PB.computes_at_encoded bitape_optionMove BiTape.optionMove
+  match d with
+  | none => simpa using PB.optionElim_computes_none h_dir h_t
+  | some d =>
+    apply PB.optionElim_computes_some h_dir
+    intro ext
+    exact bitape_move_computes (by simpa using h_t.extend) (by simp)
+
+instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
+    DataEncode (Turing.SingleTapeTM.Cfg tm) where
+  encode cfg := DataEncode.encode (cfg.state, cfg.BiTape)
+  h_inj := by
+    intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, ht⟩ := heq
+    cases hs; cases ht; rfl
+
+-- Evaluate a function `f` at `arg` where the function is given as a graph.
+-- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise.
+def eval_fun_graph (graph : PB) (arg : PB) : PB :=
+  PB.fold
+    (fun acc x =>
+      PB.optionElim acc
+        (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
+        fun _ => acc)
+    PB.empty graph
+
+/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of
+`(α × β)`-pairs) and an encoded argument `a : α`, returns
+`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)`
+in the graph, else `none`. -/
+lemma eval_fun_graph_computes
+    {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α]
+    {env : List Data} {p_graph p_arg : PB}
+    {graph : List (α × β)} {a : α}
+    (h_graph : p_graph.computes_at_encoded env graph)
+    (h_arg : p_arg.computes_at_encoded env a) :
+    (eval_fun_graph p_graph p_arg).computes_at_encoded env
+      ((graph.find? (fun p => p.1 = a)).map (·.2)) := by
+  -- The Lean-level step function for the fold.
+  let step : Option β → α × β → Option β :=
+    fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc)
+  -- Once the accumulator is `some _`, it stays `some _`.
+  have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by
+    intro l b
+    induction l with
+    | nil => simp
+    | cons hd tl ih => simp [step, ih]
+  -- `foldl step none` matches `find?`-then-`map snd`.
+  have key : ∀ l : List (α × β),
+      l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by
+    intro l
+    induction l with
+    | nil => simp
+    | cons hd tl ih =>
+      simp only [List.foldl_cons, List.find?_cons]
+      by_cases h : hd.1 = a
+      · simp [step, h, stays]
+      · simp [step, h, ih]
+  rw [show (graph.find? (fun p => p.1 = a)).map (·.2)
+        = graph.foldl step none from (key graph).symm]
+  unfold eval_fun_graph
+  refine PB.fold_computes_at_encoded (a := (none : Option β)) (f := step)
+    (by simp [PB.computes_at_encoded, DataEncode.encode]) h_graph ?_
+  intro acc x ext
+  rcases acc with _ | v
+  · -- acc = none: step none x = if x.1 = a then some x.2 else none
+    refine PB.optionElim_computes_none (α := β)
+      PB.elim_cons_head_var_computes_at ?_
+    refine PB.ifEq_computes_at
+      (PB.fst_computes_at_encoded PB.elim_cons_tail_var_computes_at)
+      (by simpa using h_arg.extend) ?_ ?_
+    · intro h_enc
+      have h_eq : x.1 = a := DataEncode.h_inj h_enc
+      change PB.computes_at_encoded _ _ (step none x)
+      simp only [step, Option.elim_none, if_pos h_eq]
+      exact PB.some_computes_at_encoded
+        (PB.snd_computes_at_encoded PB.elim_cons_tail_var_computes_at)
+    · intro h_enc
+      have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h])
+      simp [DataEncode.encode, step, h_ne]
+  · -- acc = some v: step (some v) x = some v
+    refine PB.optionElim_computes_some (α := β)
+      (PB.elim_cons_head_var_computes_at
+        (head := DataEncode.encode (some v : Option β))) ?_
+    intro ext'
+    simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes_at.extend
+
+-- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) :=
+--   Fintype.elems.toList.map (fun a => (a, f a))
+
+lemma eval_fun_graph_computes_of_fun
+    {α β : Type} [DataEncode α] [DataEncode β] [Fintype α]
+    {env : List Data} {p_graph p_arg : PB}
+    {a : α}
+    {f : α → β}
+    (h_graph : p_graph.computes_at_encoded env (Fintype.elems.toList.map (fun a => (a, f a))))
+    (h_arg : p_arg.computes_at_encoded env a) :
+    (eval_fun_graph p_graph p_arg).head.computes_at_encoded env (f a) := by
+  classical
+  have heq : ∀ (L : List α), a ∈ L →
+      ((L.map (fun a' => (a', f a'))).find?
+        (fun p => p.1 = a)).map (·.2) = some (f a) := by
+    intro L hmem
+    induction L with
+    | nil => exact absurd hmem (by simp)
+    | cons hd tl ih => grind
+  have h := eval_fun_graph_computes h_graph h_arg
+  rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h
+  simpa [DataEncode.encode, Data.asList] using PB.head_computes_at h
+
+def cfg_state (cfg : PB) : PB := cfg.fst
+def cfg_bitape (cfg : PB) : PB := cfg.snd
+
+lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_at_encoded env cfg) :
+    (cfg_state p).computes_at_encoded env cfg.state :=
+  PB.fst_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
+
+lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_at_encoded env cfg) :
+    (cfg_bitape p).computes_at_encoded env cfg.BiTape :=
+  PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h
+
+/-- Evaluate the transition function. Returns `((wr, dir), q')`.
+ -- The return value is not wrapped inside an `Option` because the transition
+ -- function is assumed to be total. -/
+def eval_tr (tr : PB) (q c : PB) : PB :=
+  (eval_fun_graph (eval_fun_graph tr q).head c).head
+
+instance : DataEncode (SingleTapeTM.Stmt Symbol) where
+  encode stmt := DataEncode.encode (stmt.symbol, stmt.movement)
+  h_inj := by
+    intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, hm⟩ := heq
+    cases hs; cases hm; rfl
+
+lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State]
+    [DecidableEq State] [Fintype Symbol]
+    {env : List Data} {p_tr p_q p_c : PB}
+    {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State}
+    {q : State}
+    {c : Option Symbol}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset State).toList.map (fun q' : State =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' : Option Symbol => (c', tr q' c'))))))
+    (h_q : p_q.computes_at_encoded env q)
+    (h_c : p_c.computes_at_encoded env c) :
+    (eval_tr p_tr p_q p_c).computes_at_encoded env (tr q c) := by
+  unfold eval_tr
+  exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q)
+    (eval_fun_graph_computes_of_fun (α := State) (f := fun q' =>
+      (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c')))
+      h_tr h_q) h_c
+
+-- /-- The step function corresponding to a `SingleTapeTM`. -/
+-- @[simp]
+-- def step : tm.Cfg → Option tm.Cfg
+--   | ⟨none, _⟩ =>
+--     -- If in the halting state, there is no next configuration
+--     none
+--   | ⟨some q', t⟩ =>
+--     -- If in state q', perform look up in the transition function
+--     match tm.tr q' t.head with
+--     -- and enter a new configuration with state q'' (or none for halting)
+--     -- and tape updated according to the Stmt
+--     | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩
+
+-- Compute the step function given a transition function (as its graph) and a configuration.
+-- Returns `Option Cfg`
+def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
+  PB.optionElim (cfg_state cfg)
+    PB.empty
+    (fun q' => PB.letIn (cfg_bitape cfg) (fun tape =>
+      PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
+        .some (to_pair
+          tr_val.snd
+          (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
+
+lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_at_encoded env cfg) :
+    (singleTapeTM_step p_tr p_cfg).computes_at_encoded env (tm.step cfg) := by
+  unfold singleTapeTM_step
+  obtain ⟨state, t⟩ := cfg
+  match hst : state with
+  | none =>
+    refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_
+    change PB.empty.computes_at_encoded env (none : Option tm.Cfg)
+    simp [PB.computes_at_encoded, DataEncode.encode]
+  | some q' =>
+    refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_
+    intro ext1
+    -- TODO letin makes this proof complicated.
+    -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`.
+    apply PB.letIn_computes_at_encoded (v := t)
+      (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend)
+    intro ext2
+    set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def
+    -- The slot for `q'` at depth `env.length + ext1.length`.
+    have h_q'_slot : PB.computes_at_encoded
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env.length + ext1.length)) q' := by
+      simpa [env2_def] using PB.atSlot_last_computes_at_encoded.extend
+    -- The slot for `tape` at depth `env2.length + ext2.length`.
+    have h_tape_slot : PB.computes_at_encoded
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env2.length + ext2.length)) t :=
+      PB.atSlot_last_computes_at_encoded
+    apply PB.letIn_computes_at_encoded
+      (eval_tr_computes
+        (by simpa [env2_def, List.append_assoc] using h_tr.extend)
+        h_q'_slot (bitape_head_computes h_tape_slot))
+    intro ext3
+    set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def
+    set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def
+    -- Re-derive tape slot at envS.
+    have h_tape_slot' : PB.computes_at_encoded envS
+        (PB.atSlot (env2.length + ext2.length)) t := by
+      simpa [envS_def, env3_def, List.append_assoc] using
+        h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)])
+    -- Destructure the transition result.
+    rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩
+    have h_trval : PB.computes_at_encoded envS
+        (PB.atSlot (env3.length + ext3.length))
+        (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by
+      simp [envS_def, htr_eq]
+    unfold SingleTapeTM.step
+    simp only [htr_eq]
+    exact PB.some_computes_at_encoded
+      (to_pair_computes
+        (PB.snd_computes_at_encoded h_trval)
+        (bitape_optionMove_computes
+          (bitape_write_computes h_tape_slot'
+            (PB.fst_computes_at_encoded (a := (wr, dir))
+              (PB.fst_computes_at_encoded h_trval)))
+          (PB.snd_computes_at_encoded (a := (wr, dir))
+            (PB.fst_computes_at_encoded h_trval))))
+
+def tm_main_loop (tr : PB) (cfg : PB) : PB :=
+  -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step`
+  -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep
+  -- the current `acc` (which has `state = none`, signalling halt to `while_`).
+  PB.while_ cfg
+    (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
+
+/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/
+private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr : PB}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (c : tm.Cfg) :
+    PB.computes_at_body₁ env (DataEncode.encode c)
+      (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+      (DataEncode.encode ((tm.step c).getD c)) := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  intro ext
+  set E := env ++ ext with E_def
+  have hE_len : E.length = env.length + ext.length := by simp [E_def]
+  have h_acc : PB.computes_at_encoded (E ++ [DataEncode.encode c])
+      (PB.atSlot E.length) c := by
+    simpa using PB.atSlot_last_computes_at_encoded (env := E) (ext := []) (a := c)
+  have h_step_eval :
+      (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_at_encoded
+        (E ++ [DataEncode.encode c]) (tm.step c) := by
+    have h_tr_ext : PB.computes_at_encoded (E ++ [DataEncode.encode c]) p_tr
+        ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))) := by
+      have := h_tr.extend (ext := ext ++ [DataEncode.encode c])
+      simpa [E_def, List.append_assoc] using this
+    exact singleTapeTM_step_computes h_tr_ext h_acc
+  change PB.computes_at (E ++ [DataEncode.encode c])
+    (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length)))
+      (PB.atSlot (env.length + ext.length))
+      (fun next => next)) (DataEncode.encode (step c))
+  rw [← hE_len]
+  cases hstep_c : tm.step c with
+  | none =>
+    rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl]
+    exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc
+  | some next =>
+    rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl]
+    refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_
+    intro ext'
+    simpa using PB.atSlot_last_computes_at_encoded
+      (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next)
+
+/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
+`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
+state), the loop computes the configuration obtained after the *minimal* such
+number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
+halt result `none` as a fixed point via `Option.getD`. -/
+lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_at_encoded env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_at_encoded env cfg)
+    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
+    (tm_main_loop p_tr p_cfg).computes_at_encoded env
+      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
+  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
+  have headD_iff : ∀ c : tm.Cfg,
+      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+  -- Translate the halting hypothesis through the iff.
+  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
+    h_halts.imp fun _ h => (headD_iff _).mpr h
+  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
+    le_antisymm
+      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
+      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
+  -- Reduce to a `while_` spec call.
+  change PB.computes_at env (tm_main_loop p_tr p_cfg)
+    (DataEncode.encode (step^[Nat.find h_halts] cfg))
+  rw [← find_eq]
+  unfold tm_main_loop
+  exact PB.while_computes_iter (env := env) (p_init := p_cfg)
+    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+    step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts'
+
+def reverse (x : PB) : PB :=
+  PB.fold (fun acc el => PB.cons el acc) PB.empty x
+
+lemma reverse_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_at_encoded env l) :
+    (reverse p).computes_at_encoded env l.reverse := by
+  unfold reverse
+  have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp
+  rw [h_fold]
+  apply PB.fold_computes_at_encoded (by simp [PB.computes_at_encoded]) h
+  -- TODO at this point, we should actually be able to just apply a combinator on the semantics
+  -- of PB.cons
+  intro acc el ext
+  have h_el : PB.computes_at
+      (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+      (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by
+    simpa using (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
+  simpa [DataEncode.encode, Data.asList] using
+    PB.cons_computes_at h_el (by simpa using PB.atSlot_last_computes_at.extend)
+
+def list_map (x : PB) (f : PB → PB) : PB :=
+  reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x)
+
+lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p : PB} {l : List α}
+    {f : PB → PB} {g : α → β}
+    (h : p.computes_at_encoded env l)
+    (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) :
+    (list_map p f).computes_at_encoded env (l.map g) := by
+  unfold list_map
+  -- TODO simplify proof
+  have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_at_encoded
+      env (l.foldl (fun acc el => g el :: acc) []) := by
+    apply PB.fold_computes_at_encoded (a := ([] : List β)) (f := fun acc el => g el :: acc)
+      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
+    intro acc el ext
+    have h_acc : PB.computes_at
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+        (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+      simpa using (PB.atSlot_last_computes_at (env := env) (ext := ext)
+        (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by
+      simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc])
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_fel h_acc
+  have h_rev := reverse_computes h_fold
+  have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by
+    rw [show l.foldl (fun acc el => g el :: acc) []
+          = (l.map g).foldl (fun acc el => el :: acc) [] from
+        (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm]
+    simp
+  rwa [h_eq] at h_rev
+
+/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/
+def list_reduceOption (x : PB) : PB :=
+  reverse (PB.fold
+    (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc))
+    PB.empty x)
+
+lemma list_reduceOption_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List (Option α)}
+    (h : p.computes_at_encoded env l) :
+    (list_reduceOption p).computes_at_encoded env l.reduceOption := by
+  unfold list_reduceOption
+  set step : List α → Option α → List α :=
+    fun acc el => match el with | none => acc | some y => y :: acc with step_def
+  -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need
+  -- this generalized over the initial accumulator so the induction goes through.
+  have h_eq : ∀ (xs : List (Option α)) (init : List α),
+      (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by
+    intro xs
+    induction xs with
+    | nil => intro init; simp [List.reduceOption]
+    | cons hd tl ih =>
+      intro init
+      cases hd with
+      | none => simpa [step_def] using ih init
+      | some y =>
+        have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by
+          simp [step_def]
+        rw [h1, ih (y :: init)]
+        simp [List.reduceOption]
+  have h_fold : (PB.fold
+        (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p
+      ).computes_at_encoded env (l.foldl step []) := by
+    apply PB.fold_computes_at_encoded
+      (a := ([] : List α)) (f := step)
+      (by simp [PB.computes_at_encoded, DataEncode.encode]) h
+    intro acc el ext
+    have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by
+      simpa [PB.computes_at_encoded] using
+        (PB.atSlot_last_computes_at (ext := ext ++ [DataEncode.encode acc])).extend
+    have h_acc : (PB.atSlot (env.length + ext.length)).computes_at_encoded
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by
+      simpa [PB.computes_at_encoded] using
+        (PB.atSlot_last_computes_at (env := env) (ext := ext)
+          (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    cases el with
+    | none =>
+      simpa [step_def] using
+        PB.optionElim_computes_none (α := α) h_el h_acc
+    | some y =>
+      refine PB.optionElim_computes_some (α := α) h_el ?_
+      intro ext'
+      -- Inside someCase, the bound `y` lives at slot
+      -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`.
+      set ext_inner :=
+        ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def
+      have hlen : ext_inner.length = ext.length + 2 + ext'.length := by
+        simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm]
+      have h_y :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length + 2 + ext'.length))
+            (DataEncode.encode y) := by
+        have h := PB.atSlot_last_computes_at
+          (env := env) (ext := ext_inner) (d := DataEncode.encode y)
+        rw [hlen] at h
+        convert h using 2
+        omega
+      have h_acc' :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+        have h := (h_acc :
+          PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)])
+            _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y])
+        simpa [ext_inner_def, List.append_assoc] using h
+      have h_cons := PB.cons_computes_at h_y h_acc'
+      simp only [ext_inner_def] at h_cons
+      simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons
+  have h_rev := reverse_computes h_fold
+  have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l []
+  rwa [h_eq₀] at h_rev
+
+def list_head_option (input : PB) : PB :=
+  PB.elim input PB.empty (fun hd _tl => PB.some hd)
+
+lemma list_head_option_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_at_encoded env l) :
+    (list_head_option p).computes_at_encoded env l.head? := by
+  cases l with
+  | nil =>
+    apply PB.elim_nil_computes_at (em := PB.empty)
+    · simpa [DataEncode.encode] using h
+    · simp [DataEncode.encode]
+  | cons hd tl =>
+    apply PB.elim_cons_computes_at (head := DataEncode.encode hd)
+      (tail := tl.map DataEncode.encode)
+    · simpa [DataEncode.encode] using h
+    · intro ext
+      simpa [DataEncode.encode] using
+        PB.cons_computes_at PB.elim_cons_head_var_computes_at PB.empty_computes_at
+
+def string_to_tape (input : PB) : PB :=
+  to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some))
+
+lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_at_encoded env input) :
+    (string_to_tape p_input).computes_at_encoded env (BiTape.mk₁ input) := by
+  have h_tail : (PB.tail p_input).computes_at_encoded env input.tail := by
+    simpa [PB.computes_at_encoded, DataEncode.encode] using PB.tail_computes_at h_input
+  have h_map : (list_map (PB.tail p_input) PB.some).computes_at_encoded env
+      (StackTape.map_some input.tail : Turing.StackTape Symbol) := by
+    simpa [PB.computes_at_encoded, DataEncode.encode]
+      using list_map_computes h_tail (fun _ _ => by
+        simpa [DataEncode.encode] using
+          PB.cons_computes_at PB.atSlot_last_computes_at PB.empty_computes_at)
+  have h_empty : (PB.empty : PB).computes_at_encoded env (∅ : Turing.StackTape Symbol) := by
+    simp [PB.computes_at_encoded, DataEncode.encode]
+  simpa [PB.computes_at_encoded, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape]
+    using to_pair_computes (list_head_option_computes h_input)
+      (to_pair_computes h_empty h_map)
+
+
+def initial_config (q₀ : PB) (input : PB) : PB :=
+  to_pair (PB.some q₀) (string_to_tape input)
+
+/-- Turn the final config to an output, by taking the head and the right part of the tape
+    and discarding the blank (`none`) cells. -/
+def final_config_to_output (cfg : PB) : PB :=
+  list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))
+
+/-- Implements a universal Single-Tape TM, assuming that the input contains the following:
+((initialState, transitionFunction), input).
+If it terminates, the output is the tape contents under the head and to its right. -/
+def universal_tm (input : PB) :=
+  final_config_to_output
+    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd))
+
+lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_q₀ p_input : PB} {input : List Symbol}
+    (h_q₀ : p_q₀.computes_at_encoded env tm.q₀)
+    (h_input : p_input.computes_at_encoded env input) :
+    (initial_config p_q₀ p_input).computes_at_encoded env (tm.initCfg input) := by
+  -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes
+  -- through the `(state, BiTape)` pair, so this matches `to_pair`.
+  exact to_pair_computes (PB.some_computes_at_encoded h_q₀) (string_to_tape_computes h_input)
+
+lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_cfg : PB} {cfg : tm.Cfg}
+    (h_cfg : p_cfg.computes_at_encoded env cfg) :
+    (final_config_to_output p_cfg).computes_at_encoded env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by
+  unfold final_config_to_output
+  have h_BiTape : (p_cfg.snd).computes_at_encoded env cfg.BiTape :=
+    PB.snd_computes_at_encoded (a := (cfg.state, cfg.BiTape)) h_cfg
+  have h_head := bitape_head_computes h_BiTape
+  have h_right := bitape_right_computes h_BiTape
+  -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`),
+  -- then `list_reduceOption` discards the blanks.
+  have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_at_encoded env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList) := by
+    change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList))
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes_at h_head h_right
+  exact list_reduceOption_computes h_list
+
+lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       input))
+    (h_halts : ∃ n,
+        ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) :
+    (universal_tm p_input).computes_at_encoded env
+      (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input)
+       (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by
+  unfold universal_tm
+  have h_fst := PB.fst_computes_at_encoded h_input
+  have h_q₀ := PB.fst_computes_at_encoded h_fst
+  have h_tr := PB.snd_computes_at_encoded h_fst
+  have h_inp := PB.snd_computes_at_encoded h_input
+  exact final_config_to_output_computes
+    (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts)
+
+/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding
+blanks) recovers `l`. -/
+private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) :
+    ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by
+  have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by
+    induction xs with
+    | nil => rfl
+    | cons _ _ ih => simp [ih]
+  cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h]
+
+/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`,
+then the universal Turing machine `universal_tm`, when given an encoding of `tm`
+together with `w`, computes `w'`.
+
+The encoded input has the shape `((tm.q₀, transitionTable), w)`, where
+`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/
+theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : tm.Outputs w w') :
+    (universal_tm p_input).computes_at_encoded env w' := by
+  -- Lift `tm.step` to a total step function; halting states are fixed points.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  -- Convert `ReflTransGen` into an explicit step count via tail-induction.
+  obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by
+    suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' →
+        ∃ n, step^[n] c = c' from h h_out
+    intro c c' hrel
+    induction hrel with
+    | refl => exact ⟨0, rfl⟩
+    | tail _ h' ih =>
+      obtain ⟨n, hn⟩ := ih
+      refine ⟨n + 1, ?_⟩
+      rw [Function.iterate_succ_apply', hn]
+      change (tm.step _).getD _ = _
+      rw [h']
+      rfl
+  -- The halting hypothesis required by `universal_tm_computes`.
+  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩
+  -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`.
+  have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl)
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter
+    exact h_iter.symm
+  -- Conclude via `universal_tm_computes`.
+  have h := universal_tm_computes (tm := tm) h_input h_halts
+  rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+    tm.haltCfg w' from h_find] at h
+  simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h
+
+/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded
+output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/
+private lemma universal_tm_eval_some_imp_loop_eval_some
+    {p_input : PB} {env : List Data} {d : Data}
+    (h : (universal_tm p_input env.length).eval env = .some d) :
+    ∃ d', (tm_main_loop p_input.fst.snd
+      (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by
+  -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is
+  -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is
+  -- `.some`, the bound subexpression must be `.some` too.
+  set n := env.length with hn
+  set mloop : Prog := tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd) n with mloop_def
+  -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do.
+  have bd_cons : ∀ {a b : Prog} {env d},
+      (Prog.cons a b).eval env = .some d →
+      (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by
+    intro a b env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does.
+  have bd_elim : ∀ {v em cs : Prog} {env d},
+      (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by
+    intro v em cs env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm
+    refine ⟨ah, ?_⟩
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+  -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init`
+  -- and `list` do.
+  have bd_fold : ∀ {body init list : Prog} {env d},
+      (Prog.fold body init list).eval env = .some d →
+      (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by
+    intro body init list env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Now unfold `universal_tm = final_config_to_output (...)`,
+  -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`,
+  -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`.
+  -- At each step we bubble down through the relevant `Prog` constructor.
+  -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost
+  -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through
+  -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s)
+  -- to extract a `some` evaluation for `mloop`.
+  change (final_config_to_output (tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h
+  unfold final_config_to_output list_reduceOption reverse at h
+  -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain)
+  obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h
+  obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1
+  -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2
+  -- where mloop' = tm_main_loop ...
+  change (Prog.cons _ _).eval env = .some d2 at h2
+  obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2
+  -- h3 : bitape_head (...).snd evaluates to some
+  -- bitape_head t = t.fst = head t = elim t empty (fun ...)
+  -- bitape_head (mloop').snd = head (head (tail mloop'))
+  change (Prog.elim _ _ _).eval env = .some d3 at h3
+  obtain ⟨d4, h4⟩ := bd_elim h3
+  -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _).
+  change (Prog.elim _ _ _).eval env = .some d4 at h4
+  obtain ⟨d5, h5⟩ := bd_elim h4
+  -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl).
+  change (Prog.elim _ _ _).eval env = .some d5 at h5
+  obtain ⟨d6, h6⟩ := bd_elim h5
+  -- h6 : mloop' n .eval env = some d6. Done.
+  exact ⟨d6, h6⟩
+
+/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to
+a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`,
+then there exists an iteration index `n` such that the TM is in a halt state and
+the tape contents under the head (with blanks discarded) equal `w'`. -/
+theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : (universal_tm p_input).computes_at_encoded env w') :
+    ∃ n : ℕ,
+      let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+      cfg.state = none ∧
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none
+  · -- Halts: use forward direction to identify the output.
+    refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩
+    have h_fwd := universal_tm_computes (tm := tm) h_input h_halts
+    -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`;
+    -- since `Part.eval` is functional, the encoded values must agree, then apply
+    -- injectivity of `DataEncode.encode`.
+    have h1 := h_fwd []
+    have h2 := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2
+    rw [h1] at h2
+    have h_eq := Part.some_inj.mp (by exact_mod_cast h2)
+    exact DataEncode.h_inj h_eq
+  · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`.
+    exfalso
+    have h_eval := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval
+    obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval
+    -- Project `h_input` to get individual components.
+    have h_q₀ := PB.fst_computes_at_encoded (PB.fst_computes_at_encoded h_input)
+    have h_tr := PB.snd_computes_at_encoded (PB.fst_computes_at_encoded h_input)
+    have h_inp := PB.snd_computes_at_encoded h_input
+    -- Initial config evaluates to `encode (tm.initCfg w)`.
+    have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env
+        = .some (DataEncode.encode (tm.initCfg w)) := by
+      have := (initial_config_computes h_q₀ h_inp) []
+      simpa using this
+    -- Unfold tm_main_loop = PB.while_ init body.
+    set body_pb : PB → PB :=
+      fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc
+        (fun next => next) with body_pb_def
+    change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env
+      = .some d at h_loop
+    set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def
+    change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env
+      = .some d at h_loop
+    rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop
+    -- Extract the trajectory.
+    obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ :=
+      Prog.whileFrom_eval_some h_loop
+    -- The body computes `step` at every config.
+    have h_body_eval : ∀ c : tm.Cfg,
+        bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by
+      intro c
+      have h := (tm_main_loop_body_computes h_tr c (ext := [])).here
+      simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h
+    -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`.
+    have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by
+      intro k hk
+      induction k with
+      | zero => simpa using h_traj0
+      | succ k ih =>
+        have hkm : k < m := hk
+        have ih' := ih (Nat.le_of_lt hkm)
+        have h_step_k := (h_steps k hkm).2
+        rw [ih', h_body_eval] at h_step_k
+        have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) :=
+          (Part.some_inj.mp h_step_k).symm
+        rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from
+          (Function.iterate_succ_apply' step k _).symm]
+    -- Halt condition at `m` gives `state = none`.
+    have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl
+    rw [← h_trajm, h_at_m] at h_halt_at_m
+    have headD_iff : ∀ c : tm.Cfg,
+        (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+      rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+    exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩
+
+/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches
+a halted configuration whose tape content (head followed by the right stack, with
+blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization
+of `universal_tm`. -/
+private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
+    (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop :=
+  ∃ n : ℕ,
+    let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+    cfg.state = none ∧
+    (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w'
+
+private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_at_encoded env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w)) :
+    Outputs' tm w w' ↔ (universal_tm p_input).computes_at_encoded env w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  refine ⟨?_, ?_⟩
+  · -- Forward: `Outputs' tm w w' → universal_tm computes w'`.
+    rintro ⟨n, h_halt_n, h_eq⟩
+    have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩
+    have h := universal_tm_computes (tm := tm) h_input h_halts
+    -- Stationarity: any later iterate of a halted config equals it.
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter
+    rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+      (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h
+    exact h
+  · -- Converse: directly from `universal_tm_simulates_converse`.
+    intro h_out
+    exact universal_tm_simulates_converse h_input h_out
+
+
+end RoseTreeMachine
+
+end Turing

From 6cc5327b2a45ea7a317f1a4951f31c345a267c75 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Sat, 23 May 2026 09:49:04 +0800
Subject: [PATCH 073/106] feat: FullEta.step_lc_l (#589)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This PR adds a missing lemma to the `FullEta` development in the locally
nameless untyped λ‑calculus:
a proof that **the source term of a single‑step η‑reduction is locally
closed**. It also moves the definition of `LcAt` earlier to avoid some
duplication of proofs about `LC`.

#### New Lemmas

`FullEta.step_lc_l` : Proves that the left side of an η-reduction `step
(M ⭢ηᶠ M')` is locally closed.
Uses induction on the reduction step and the grind tactic.

`lcAt_openRec_above_lcAt` : Shows that opening a term at a higher index
than its locally closed level leaves it unchanged.

#### Refactored Lemmas

open_lc : Simplified proof using `lcAt_openRec_above_lcAt` and
`lcAt_iff_LC`.

PR description is generated by AI

---------

Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 .../LocallyNameless/Untyped/Basic.lean           | 12 ------------
 .../LocallyNameless/Untyped/FullEta.lean         |  8 ++++++++
 .../LocallyNameless/Untyped/LcAt.lean            | 16 ++++++++++++++++
 .../LocallyNameless/Untyped/Properties.lean      | 15 ++++-----------
 4 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Basic.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Basic.lean
index 6ac6c5d6c4..d1e4543a4d 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Basic.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Basic.lean
@@ -111,18 +111,6 @@ def fv : Term Var → Finset Var
 | abs e1 => e1.fv
 | app l r => l.fv ∪ r.fv
 
-/-- Locally closed terms. -/
-inductive LC : Term Var → Prop
-| fvar (x : Var)  : LC (fvar x)
-| abs (L : Finset Var) (e : Term Var) : (∀ x ∉ L, LC (e ^ fvar x)) → LC (abs e)
-| app {l r} : l.LC → r.LC → LC (app l r)
-
-attribute [scoped grind .] LC.fvar LC.app
-
-/-- Values are irreducible terms. -/
-inductive Value : Term Var → Prop
-| abs (e : Term Var) : e.abs.LC → e.abs.Value
-
 section
 
 omit [HasFresh Var]
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
index 10d29d35e5..517ce78683 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
@@ -44,6 +44,14 @@ lemma step_lc_r (step : M ⭢ηᶠ M') : LC M' := by
   refine Xi.step_lc_r ?_ step
   grind
 
+/-- The left side of an η-reduction is locally closed. -/
+lemma step_lc_l [HasFresh Var] (step : M ⭢ηᶠ M') : LC M := by
+  induction step with
+  | base h_e => cases h_e with | eta => apply LC.abs ∅; grind
+  | appL lc_Z _ ih => exact LC.app lc_Z ih
+  | appR lc_Z _ ih => exact LC.app ih lc_Z
+  | @abs M' _ xs _ ih => exact LC.abs xs M' ih
+
 /-- Left congruence rule for application in multiple reduction. -/
 theorem redex_app_l_cong (redex : M ↠ηᶠ M') (lc_N : LC N) : app M N ↠ηᶠ app M' N := by
   induction redex <;> grind
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
index 7222d84bb6..691939af75 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
@@ -72,6 +72,18 @@ theorem lcAt_openRec_fvar_iff_lcAt (M : Term Var) (x : Var) (i : ℕ) :
 theorem lcAt_open_fvar_iff_lcAt (M : Term Var) (x : Var) : LcAt 0 (M ^ fvar x) ↔ LcAt 1 M :=
   lcAt_openRec_fvar_iff_lcAt M x 0
 
+/-- Locally closed terms. -/
+inductive LC : Term Var → Prop
+| fvar (x : Var)  : LC (fvar x)
+| abs (L : Finset Var) (e : Term Var) : (∀ x ∉ L, LC (e ^ fvar x)) → LC (abs e)
+| app {l r} : l.LC → r.LC → LC (app l r)
+
+attribute [scoped grind .] LC.fvar LC.app
+
+/-- Values are irreducible terms. -/
+inductive Value : Term Var → Prop
+| abs (e : Term Var) : e.abs.LC → e.abs.Value
+
 /-- `M` is `LcAt 0` if and only if `M` is locally closed. -/
 theorem lcAt_iff_LC (M : Term Var) [HasFresh Var] : LcAt 0 M ↔ M.LC := by
   induction M using LambdaCalculus.LocallyNameless.Untyped.Term.ind_on_depth with
@@ -98,4 +110,8 @@ lemma open_abs_lc [HasFresh Var] {M N : Term Var} (hlc : LC (M ^ N)) : LC (M.abs
   rw [← lcAt_iff_LC] at *
   exact lcAt_openRec_lcAt _ _ _ hlc
 
+lemma lcAt_openRec_above_lcAt (M N : Term Var) (i j : ℕ) (h : i ≤ j) (lc : LcAt i M) :
+    M⟦j ↝ N⟧ = M := by
+  induction M generalizing i j <;> grind
+
 end Cslib.LambdaCalculus.LocallyNameless.Untyped.Term
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index e79c4bb960..06634fccd6 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -6,7 +6,7 @@ Authors: Chris Henson
 
 module
 
-public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.Basic
+public import Cslib.Languages.LambdaCalculus.LocallyNameless.Untyped.LcAt
 
 /-! General properties of opening and substitution in untyped lambda calculus terms. -/
 
@@ -22,11 +22,6 @@ namespace LambdaCalculus.LocallyNameless.Untyped.Term
 
 attribute [grind =] Finset.union_singleton
 
-/-- An opening appearing in both sides of an equality of terms can be removed. -/
-lemma open_lc_aux (e : Term Var) (j v i u) (neq : i ≠ j) (eq : e⟦j ↝ v⟧ = e⟦j ↝ v⟧⟦i ↝ u⟧) :
-    e = e ⟦i ↝ u⟧ := by
-  induction e generalizing j i <;> grind
-
 variable [DecidableEq Var]
 
 /-- Substitution of a free variable not present in a term leaves it unchanged. -/
@@ -77,11 +72,9 @@ variable [HasFresh Var]
 
 omit [DecidableEq Var] in
 /-- A locally closed term is unchanged by opening. -/
-@[scoped grind =_]
-lemma open_lc (k t) (e : Term Var) (e_lc : e.LC) : e = e⟦k ↝ t⟧ := by
-  induction e_lc generalizing k with
-  | abs xs e _ _ => grind [open_lc_aux e 0 (fvar (fresh xs)) (k+1) t]
-  | _ => grind
+@[scoped grind =]
+lemma open_lc (k t) (e : Term Var) (e_lc : e.LC) : e⟦k ↝ t⟧ = e :=
+  lcAt_openRec_above_lcAt e t 0 k k.zero_le ((lcAt_iff_LC e).mpr e_lc)
 
 omit [DecidableEq Var] in
 /-- Opening is associative for nonclashing locally closed terms. -/

From d5df0fd2ea07ea075fc728730f7bb701bb88a6ff Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sat, 23 May 2026 10:56:48 +0200
Subject: [PATCH 074/106] Remove old version.

---
 .../RoseTreeMachine/RoseTreeMachine.lean      | 1942 -----------------
 1 file changed, 1942 deletions(-)
 delete mode 100644 Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean b/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
deleted file mode 100644
index 247d7b448d..0000000000
--- a/Cslib/Computability/Machines/RoseTreeMachine/RoseTreeMachine.lean
+++ /dev/null
@@ -1,1942 +0,0 @@
-/-
-Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner
--/
-
-module
-
-public import Mathlib.Data.Part
-public import Mathlib.Control.Fix
-public import Std
-
-public import Cslib.Computability.Machines.SingleTapeTuring.Basic
-public import Mathlib.Data.Nat.Bits
-
-set_option profiler true
-set_option profiler.threshold 100
-/-!
--- This is a proposal to define a machine model and related time and space measure
--- such that it is linearly space- and polynomially time-related to multi-tape Turing machines.
-
--- The goal would be that the machine model is flexible enough to implement algorithms easily,
--- but still close enough to Turing machines to allow defining logspace and even loglogspace.
-
--- The machine as defined below will allow stateless / pure functional programs.
--- If we store the input tape position as a number, we should be able to define logspace.
--- In order to go down to loglogspace, we need to use the input tape head as a "pointer"
--- and cannot count its position. This could be doable as well, but requires a more stateful
--- model at least for the input tape. The input tape is currently not modeled, but I have some
--- plans to define actions on the input tape as further elementary operations.
-
--- The main insight over my current work is that it does not hurt to
--- (1) create a new tape for every elementary operation (the program size is constant, so the number
---     of tapes is constant)
--- (2) disallow modifications to existing tapes (work tape space has been spent, it is fine
---     to copy it finitely often
--- (3) if we have a built-in `fold` operation, we should be able to implement the required
---     operations at linear space overhead, because the fold operation implicitly re-uses the
---     space used by the accumulator.
--/
-
-@[expose] public section
-
-
-namespace Turing
-
-namespace RoseTreeMachine
-
--- ================= Data structure
-
-
-
--- Rose-tree data structure, it allows us to
--- 1. map most of Lean's data structures in a "natural" manner
--- 2. define a "fold" operation
-inductive Data where
-  | l : List Data → Data
-deriving Repr
-
-mutual
-  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
-    | .l xs, .l ys =>
-      match Data.listDecEq xs ys with
-      | isTrue h => isTrue (congrArg Data.l h)
-      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
-  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
-    | [], [] => isTrue rfl
-    | [], _ :: _ => isFalse (by simp)
-    | _ :: _, [] => isFalse (by simp)
-    | x :: xs, y :: ys =>
-      match Data.decEq x y, Data.listDecEq xs ys with
-      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
-      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
-      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
-end
-
-instance : DecidableEq Data := Data.decEq
-instance : BEq Data := inferInstance
-instance : LawfulBEq Data := inferInstance
-
-abbrev Data.empty := Data.l []
-
-
-@[grind =]
-def Data.asList
-  | Data.l xs => xs
-
-@[simp]
-lemma Data.asList_empty : Data.empty.asList = [] := by rfl
-
-@[simp, grind =]
-lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
-
-@[simp, grind =]
-lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
-
---- Encoding length of d.
-def Data.size : Data → ℕ
-  | Data.l xs => 2 + (xs.map Data.size |>.sum)
-
-@[simp, grind =]
-lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
-
-@[simp, grind =]
-lemma Data.cons_size {h : Data} {t : List Data} :
-    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
-  simp [Data.size]
-  grind
-
-/-- Recursion principle for `Data` that exposes the list-of-children structure:
-    a `motive` is built from the empty case and a cons case that combines the
-    motive on the head child and on the tail list (viewed as a `Data`).
-    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
-    through `List.rec`, leaving the recursive call on children to the user;
-    `Data.recL` performs both recursions and is the natural elimination principle
-    for definitions/proofs that need both IHs. -/
-@[elab_as_elim]
-def Data.recL {motive : Data → Sort*}
-    (nil : motive (Data.l []))
-    (cons : ∀ (x : Data) (xs : List Data),
-      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
-    ∀ d, motive d
-  | .l [] => nil
-  | .l (x :: xs) =>
-      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
-
-/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
-@[elab_as_elim]
-theorem Data.inductionL {motive : Data → Prop}
-    (nil : motive (Data.l []))
-    (cons : ∀ (x : Data) (xs : List Data),
-      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
-    (d : Data) : motive d :=
-  Data.recL nil cons d
-
-abbrev TapeIndex := ℕ
-
-
--- ================= Operations and programs
-
--- The machine is a "stack" machine, where each stack item represents a tape and holds a Data value.
--- Each operation creates a new stack entry (a new tape) and can read from previous
--- entries by index. Stack entries created in "inner" programs are temporary and deleted
--- once the inner program terminates. This is especially relevant for space complexity of
--- loops since it allows us to re-use the space of one iteration for the next iteration.
-
-inductive Operation where
-  -- create a new tape initialized with `Data.l []`
-  | empty  : Operation
-  -- cons tape h and tape t to a new tape (h :: t)
-  | cons   : TapeIndex → TapeIndex → Operation
-  -- head of the data if it exists, or empty otherwise
-  | head   : TapeIndex → Operation
-  -- tail of the data
-  | tail   : TapeIndex → Operation
-  -- compare two tapes, returning non-empty if equal, empty otherwise
-  | eq     : TapeIndex → TapeIndex → Operation
-  -- branch on tape i: if empty then then_ else else_
-  | ifEmpty : TapeIndex → (List Operation) → (List Operation) → Operation
-  -- fold over the children of tape l with initial accumulator tape i and body program b
-  | fold   : (List Operation) → TapeIndex → TapeIndex → Operation
-  -- while tape i is nonempty, run body b with stack extended by acc (the current value of tape i)
-  | while_ : TapeIndex → (List Operation) → Operation
-  -- call executes a sub-program on a swapped / copied stack and returns its stack top.
-  -- This is not strictly needed, but makes it easier to write programs.
-  -- Note that the subprogram only has access to the provided stack indices.
-  | call : (List Operation) → (List TapeIndex) → Operation
-deriving Repr
-
--- TODO maybe it is easier to "return" tapes by default, and make "store a tape" an explicit operation
-inductive Operation' where
-  -- read from the stack.
-  | load   : TapeIndex → Operation'
-  -- create a new tape initialized with `Data.l []`
-  | empty  : Operation'
-  -- cons tape h and tape t to a new tape (h :: t)
-  | cons   : (List Operation') → (List Operation') → Operation'
-  -- head of the data if it exists, or empty otherwise
-  | head   : (List Operation') → Operation'
-  -- tail of the data
-  | tail   : (List Operation') → Operation'
-  -- compare two tapes, returning non-empty if equal, empty otherwise
-  | eq     : (List Operation') → (List Operation') → Operation'
-  -- branch on tape i: if non-empty then then_ else else_
-  | ifNonEmpty : (List Operation') → (List Operation') → (List Operation') → Operation'
-  -- fold over the children of tape l with initial accumulator tape i and body program b
-  | fold   : (List Operation') → (List Operation') → (List Operation') → Operation'
-  -- TODO document
-  | while_ : (List Operation') → (List Operation') → Operation'
-  --- store the result of a program at the top of the stack.
-  | store : (List Operation) → Operation'
-deriving Repr
-
-
-abbrev Prog := List Operation
-
-mutual
-  /-- `WFOp n op` states that `op` is well-formed when the current stack has `n` entries.
-      All tape indices must be in bounds, and sub-programs must be well-formed at the
-      appropriate derived stack heights. -/
-  def WFOp (n : ℕ) : Operation → Prop
-    | .empty      => True
-    | .cons h t   => h < n ∧ t < n
-    | .head i     => i < n
-    | .tail i     => i < n
-    | .eq i j     => i < n ∧ j < n
-    | .ifEmpty i t e  => i < n ∧ WFProg n t ∧ WFProg n e
-    | .fold b i l => l < n ∧ i < n ∧ WFProg (n + 2) b
-    | .while_ i b => i < n ∧ WFProg (n + 1) b
-    | .call b idxs => (∀ i ∈ idxs, i < n) ∧ WFProg idxs.length b
-
-  /-- `WFProg n p` states that `p` is well-formed given an initial stack of size `n`.
-      Since each operation pushes exactly one value, the k-th operation (0-indexed) sees
-      a stack of size `n + k`, so the tail of the program is checked at height `n + 1`. -/
-  def WFProg : ℕ → Prog → Prop
-    | n, []         => n ≠ 0 -- we require this because a program has to return a result.
-    | n, op :: rest => WFOp n op ∧ WFProg (n + 1) rest
-end
-
-abbrev dataTrue := Data.l [Data.l []]
-abbrev dataFalse := Data.l []
-
-mutual
-  --- Evaluate a single operation and return the return value, additional time and additional space.
-  def meteredEvalOp (stack : List Data) (op : Operation) (h_wf : WFOp stack.length op) :
-      Part (Data × ℕ × ℕ) :=
-    match op with
-    | .empty => .some (Data.empty, 1, 1)
-    | .cons h t =>
-      let result := Data.l (stack[h]'h_wf.1 :: (stack[t]'h_wf.2).asList)
-      .some (result, 1 + result.size, 1 + result.size)
-    | .head i =>
-      let result := stack[i].asList.headD Data.empty
-      .some (result, 1 + result.size, 1 + result.size)
-    | .tail i =>
-      let result := Data.l stack[i].asList.tail
-      .some (result, 1 + stack[i].size, 1 + result.size)
-    | .eq i j => .some
-      (if stack[i]'h_wf.1 == stack[j]'h_wf.2 then dataTrue else dataFalse,
-      1 + (min (stack[i]'h_wf.1).size (stack[j]'h_wf.2).size),
-      1)
-    | .ifEmpty i then_ else_ =>
-      (if stack[i]'h_wf.1 == Data.empty then
-        meteredEvalProg then_ stack h_wf.2.1
-      else
-        meteredEvalProg else_ stack h_wf.2.2).map (fun (r, t, s) => (r, 1 + t, s))
-    | .fold body initial list =>
-      -- Time: 1 + Σ_iterations (1 + body_time).
-      -- Space: init.size + max_iterations(body_space).
-      (goMeteredFold (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) stack body h_wf.2.2)
-    | .while_ i body =>
-      -- Same accounting as fold: time sums per-iteration costs (each iteration adds 1 + body_time);
-      -- space is init.size plus the max body space across iterations.
-      let init := stack[i]'h_wf.1
-      let F : ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) →
-              (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
-        fun rec d_ts =>
-          let (d, t, s) := d_ts
-          (meteredEvalProg body (d :: stack) h_wf.2).bind fun (d', tBody, sBody) =>
-            let t' := t + 1 + tBody
-            let s' := max s sBody
-            if d'.asList.head? == .some dataTrue then rec (d', t', s')
-            else .some (Data.l d'.asList.tail, t', s')
-      (Part.fix F (init, 0, 0)).map fun (r, t, s) => (r, 1 + t, init.size + s)
-    | .call body idxs => goCall body idxs stack [] h_wf.1 (by simpa using h_wf.2)
-    -- cost of copying?
-  termination_by (sizeOf op, 0, 0)
-
-  /-- Metered analogue of `goFold`: walks the items, threading the accumulator and accumulating
-      `(sum of (1 + body_time), max of body_space)` across iterations. -/
-  def goMeteredFold (items : List Data) (acc : Data) (stack : List Data) (body : Prog)
-      (h_wf : WFProg (stack.length + 2) body) : Part (Data × ℕ × ℕ) :=
-    match items with
-    | []      => .some (acc, acc.size, acc.size)
-    | c :: cs =>
-      (meteredEvalProg body (c :: acc :: stack) h_wf).bind fun (acc', tBody, sBody) =>
-        (goMeteredFold cs acc' stack body h_wf).map fun (r, t, s) =>
-          (r, 1 + tBody + t, max sBody s)
-  -- Primary key `sizeOf body` decreases when entering goMeteredFold from meteredEvalOp .fold
-  -- (body is a strict subterm of the .fold op), enabling the secondary key `sizeOf items`
-  -- to be runtime data without breaking the well-founded ordering.
-  termination_by (sizeOf body, sizeOf items, 0)
-
-  @[simp, grind =]
-  def goCall (body : Prog) (idxs : List TapeIndex) (stack copiedStack : List Data)
-      (h_idxs : ∀ i ∈ idxs, i < stack.length)
-      (h_wf : WFProg (idxs.length + copiedStack.length) body) :
-      Part (Data × ℕ × ℕ) :=
-    match idxs with
-    | [] => meteredEvalProg body copiedStack (by simpa using h_wf)
-    | i :: idxs' =>
-      have : i < stack.length := h_idxs i (by simp)
-      goCall body idxs' stack (copiedStack ++ [stack[i]]) (by grind) (by grind)
-  -- Same lexicographic strategy as goMeteredFold: primary key `sizeOf body` lets us cross
-  -- function boundaries; secondary key `sizeOf idxs` handles goCall's own recursion.
-  termination_by (sizeOf body, 0, sizeOf idxs)
-
-  @[simp, grind =]
-  def meteredEvalProg (prog : Prog) (stack : List Data) (h_wf : WFProg stack.length prog) :
-      Part (Data × ℕ × ℕ) :=
-    match prog with
-    | [] => .some (stack.head (by grind [WFProg]), 0, 0)
-    | op :: rest => do
-      let (r, opTime, opSpace) ← meteredEvalOp stack op h_wf.1
-      let (r, time, space) ← meteredEvalProg rest (r :: stack) h_wf.2
-      (r, opTime + time, opSpace + space)
-  termination_by (sizeOf prog, 0, 0)
-
-end
-
-def Operation.Total (op : Operation) (h_wf : WFOp n op) : Prop :=
-  ∀ (stack : List Data) (h_len : stack.length = n),
-  (meteredEvalOp stack op (h_len ▸ h_wf)).Dom
-
-def Prog.Total {n : ℕ} (body : Prog) (h_wf : WFProg n body) : Prop :=
-  ∀ (stack : List Data) (h_len : stack.length = n),
-    (meteredEvalProg body stack (h_len ▸ h_wf)).Dom
-
-mutual
-  @[simp]
-  def Operation.WhileFree (op : Operation) : Prop :=
-    match op with
-    | .ifEmpty _ a b => Prog.WhileFree a ∧ Prog.WhileFree b
-    | .while_ _ _ => False
-    | .fold b _ _ => Prog.WhileFree b
-    | .call p _ => Prog.WhileFree p
-    | _ => True
-  @[simp]
-  def Prog.WhileFree (body : Prog) : Prop :=
-    match body with
-    | [] => True
-    | op :: rest => Operation.WhileFree op ∧ Prog.WhileFree rest
-end
-
-/-- Helper: assemble totality of `op :: rest` from totality of `op` (the operation) and
-    totality of `rest` (the remaining program). -/
-@[simp]
-lemma progConsCase {n : ℕ} {op : Operation} {rest : Prog}
-    (h_wf : WFProg n (op :: rest))
-    (h_op_total : Operation.Total op h_wf.1)
-    (h_rest_total : Prog.Total rest h_wf.2) :
-    Prog.Total (op :: rest) h_wf := by
-  intro stack h_len
-  subst h_len
-  simp only [meteredEvalProg]
-  exact Part.bind_dom.mpr ⟨h_op_total stack rfl,
-    Part.bind_dom.mpr ⟨h_rest_total _ (by simp), trivial⟩⟩
-
-@[simp]
-theorem Prog_total_of_WhileFree {n : ℕ} (body : Prog)
-    (h_wf : WFProg n body) (h_whileFree : Prog.WhileFree body) :
-    Prog.Total body h_wf := by
-  match body with
-  | [] => intro stack h_len; simp [meteredEvalProg]
-  | op :: rest =>
-    apply progConsCase _ _ (Prog_total_of_WhileFree rest h_wf.2 h_whileFree.2)
-    intro stack h_len
-    match op with
-    | .empty | .cons _ _ | .head _ | .tail _ | .eq _ _ =>
-      simp [meteredEvalOp]
-    | .ifEmpty i t e =>
-      have ht := Prog_total_of_WhileFree t h_wf.1.2.1 h_whileFree.1.1 stack h_len
-      have he := Prog_total_of_WhileFree e h_wf.1.2.2 h_whileFree.1.2 stack h_len
-      by_cases h : (stack[i]'(h_len ▸ h_wf.1.1)) = Data.empty <;> simp [meteredEvalOp, h, ht, he]
-    | .fold b init lst =>
-      simp only [meteredEvalOp]
-      subst h_len
-      suffices h : ∀ items acc, (goMeteredFold items acc stack b h_wf.1.2.2).Dom from h _ _
-      intro items
-      induction items with
-      | nil => simp [goMeteredFold]
-      | cons _ _ ih =>
-        intro acc
-        simp only [goMeteredFold]
-        have hb := Prog_total_of_WhileFree b h_wf.1.2.2 h_whileFree.1
-        exact Part.bind_dom.mpr ⟨hb _ (by simp), ih _⟩
-    | .while_ _ _ => exact absurd h_whileFree.1 (by simp)
-    | .call b idxs =>
-      simp only [meteredEvalOp]
-      have hb := Prog_total_of_WhileFree b (by simpa using h_wf.1.2) h_whileFree.1
-      have hrest := Prog_total_of_WhileFree rest h_wf.2 h_whileFree.2
-      subst h_len
-      suffices h : ∀ (idxs' : List TapeIndex) (copiedStack : List Data)
-          (h_idxs' : ∀ i ∈ idxs', i < stack.length)
-          (h_wf' : WFProg (idxs'.length + copiedStack.length) b)
-          (_ : ∀ (s : List Data) (hs : s.length = idxs'.length + copiedStack.length),
-            (meteredEvalProg b s (hs ▸ h_wf')).Dom),
-          (goCall b idxs' stack copiedStack h_idxs' h_wf').Dom by
-        have h_full := h idxs [] h_wf.1.1 (by simpa using h_wf.1.2)
-          (by intro s hs; simpa using hb s (by simpa using hs))
-        simpa using h_full
-      intro idxs' copiedStack h_idxs' h_wf' h_bdom
-      induction idxs' generalizing copiedStack with
-      | nil =>
-        simpa [goCall] using h_bdom copiedStack (by simp)
-      | cons i is ih =>
-        simp only [goCall]
-        apply ih
-        intro s hs
-        exact h_bdom s (by simp [hs]; omega)
-
-@[simp]
-theorem Op_total_of_WhileFree {n : ℕ} {op : Operation}
-    (h_wf : WFOp n op) (h_whileFree : Operation.WhileFree op) :
-    Operation.Total op h_wf := by
-  intro stack h_len
-  have h_wf_prog : WFProg n [op] := ⟨h_wf, by simp [WFProg]⟩
-  have h_whf_prog : Prog.WhileFree [op] := ⟨h_whileFree, by simp⟩
-  have h := Prog_total_of_WhileFree [op] h_wf_prog h_whf_prog stack h_len
-  simp only [meteredEvalProg] at h
-  exact (Part.bind_dom.mp h).1
-
-@[simp]
-theorem Dom_meteredEvalOp_of_WhileFree {op : Operation} {stack : List Data}
-    (h_wf : WFOp stack.length op) (h_whf : Operation.WhileFree op) :
-    (meteredEvalOp stack op h_wf).Dom :=
-  Op_total_of_WhileFree h_wf h_whf stack rfl
-
--- We now introduce some simplification lemmas. Because of the dependent types involed
--- in Part and for other reasons, we only do this for while-free programs.
--- It is not sufficient for a program to be total, because this does not imply that all
--- sub-programs are total, which is what we would need for simp lemmas to be clearly statable.
-
--- Note that you do not want to unfold or simplify Operation.meteredEvalT, because it introduces
--- the proof of termination, which blocks simp and rw rules. Because of that, we have
--- simp lemmas for each operation below.
-
-def Operation.meteredEvalT (op : Operation) (stack : List Data) (h_wf : WFOp stack.length op)
-    (h_whf : Operation.WhileFree op) : Data × ℕ × ℕ :=
-  (meteredEvalOp stack op h_wf).get (by simp [h_whf])
-
-def Prog.meteredEvalT (body : Prog) (stack : List Data)
-    (h_wf : WFProg stack.length body)
-    (h_whf : Prog.WhileFree body) : Data × ℕ × ℕ :=
-  (meteredEvalProg body stack h_wf).get (Prog_total_of_WhileFree body h_wf h_whf stack rfl)
-
--- @[simp, scoped grind =]
--- lemma Operation.meteredEvalT_fold {body : Prog} {initial list : TapeIndex} {stack : List Data}
---     {h_wf : WFOp stack.length (.fold body initial list)}
---     {h_whf : Operation.WhileFree (.fold body initial list)}
---     (h_body_total : body.Total h_wf.2.2) :
---     Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
---       ( -- data: fold over accumulator
---         (stack[list]'h_wf.1).asList.foldl
---           (fun acc x => (Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
---             (by simpa using h_whf)).1)
---           (stack[initial]'h_wf.2.1),
---         -- time: thread (acc, time), then add final acc size
---         (let (a', t) := (stack[list]'h_wf.1).asList.foldl
---             (fun (acc, t) x =>
---               let (r, t', _) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
---                 (by simpa using h_whf)
---               (r, t + 1 + t'))
---             (stack[initial]'h_wf.2.1, 0);
---           t + a'.size),
---         -- space: thread (acc, max-space), then max with final acc size
---         (let (a', s) := (stack[list]'h_wf.1).asList.foldl
---             (fun (acc, s) x =>
---               let (r, _, s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2
---                 (by simpa using h_whf)
---               (r, max s s'))
---             (stack[initial]'h_wf.2.1, 0);
---           max s a'.size)
---       )
---       := by
---   sorry
-
-/-- Recursive form of the per-iteration accumulator threading used by `meteredEvalT_fold`.
-    Mirrors `goMeteredFold` directly, but on the `meteredEvalT` side: every body run
-    is a total `Data × ℕ × ℕ` (no `Part`). -/
-def Operation.foldRec (body : Prog) (stack : List Data)
-    (h_wf : WFProg (stack.length + 2) body)
-    (h_whf : Prog.WhileFree body) :
-    List Data → Data → Data × ℕ × ℕ
-  | [], acc => (acc, acc.size, acc.size)
-  | x :: rest, acc =>
-    let (acc', t, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf h_whf
-    let (r, t', s') := Operation.foldRec body stack h_wf h_whf rest acc'
-    (r, 1 + t + t', max s s')
-
--- /-- Recursive analog of `Operation.meteredEvalT_fold`: instead of three `List.foldl`s,
---     express the fold operation's result by structural recursion on the list. -/
--- lemma Operation.meteredEvalT_fold_rec
---     {body : Prog} {initial list : TapeIndex} {stack : List Data}
---     {h_wf : WFOp stack.length (.fold body initial list)}
---     {h_whf : Operation.WhileFree (.fold body initial list)} :
---     Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf =
---       Operation.foldRec body stack h_wf.2.2 (by simpa using h_whf)
---         (stack[list]'h_wf.1).asList (stack[initial]'h_wf.2.1) := by
---   sorry
-
-
--- /-- Space bound for a fold operation. If the initial accumulator fits within `B`,
---     and for every accumulator with `acc.size ≤ B` the body uses space `≤ B` and
---     produces a new accumulator with size `≤ B`, then the entire fold uses space
---     `≤ B`. -/
--- lemma fold_bounded_space {body : Prog} {initial list : TapeIndex} {stack : List Data}
---     {h_wf : WFOp stack.length (.fold body initial list)}
---     {h_whf : Operation.WhileFree (.fold body initial list)}
---     (B : ℕ)
---     (h_init : (stack[initial]'h_wf.2.1).size ≤ B)
---     (h_step : ∀ acc x, acc.size ≤ B → x ∈ (stack[list]'h_wf.1).asList →
---       let (acc', _, s) := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
---       s ≤ B ∧ acc'.size ≤ B) :
---     (Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf).2.2 ≤ B := by
---   sorry
-
--- /-- Induction principle for `Operation.meteredEvalT` on a `.fold` operation.
---     To prove `motive` of the final `(acc, time, space)` triple, the caller supplies:
---     * `h_init`: the motive holds on `(initial, 0, 0)`;
---     * `h_step`: for every iteration item `x ∈ list`, the motive is preserved by one
---       body invocation — old triple `(acc, t, s)` is taken to
---       `(r.1, t + 1 + r.2.1, max s r.2.2)` where `r` is the body's result;
---     * `h_finish`: from the motive on the post-loop triple `(acc, t, s)`, derive
---       the motive on the final adjusted triple `(acc, t + acc.size, max s acc.size)`,
---       which accounts for the `[]` base case of `goMeteredFold`. -/
--- lemma Operation.meteredEvalT_fold_induction
---     {body : Prog} {initial list : TapeIndex} {stack : List Data}
---     {h_wf : WFOp stack.length (.fold body initial list)}
---     {h_whf : Operation.WhileFree (.fold body initial list)}
---     (motive : Data → ℕ → ℕ → Prop)
---     (h_init : motive (stack[initial]'h_wf.2.1) 0 0)
---     (h_step : ∀ acc t s x, x ∈ (stack[list]'h_wf.1).asList → motive acc t s →
---       let (r, t', s') := Prog.meteredEvalT body (x :: acc :: stack) h_wf.2.2 (by simpa using h_whf)
---       motive r (t + 1 + t') (max s s'))
---     (h_finish : ∀ acc t s, motive acc t s → motive acc (t + acc.size) (max s acc.size)) :
---     let (r, t, s) := Operation.meteredEvalT (.fold body initial list) stack h_wf h_whf
---     motive r t s := by
---   sorry
-
-@[simp, scoped grind =]
-lemma Prog.meteredEvalT_cons
-    {op : Operation} {rest : Prog} {stack : List Data}
-    {h_wf : WFProg stack.length (op :: rest)}
-    {h_whf : Prog.WhileFree (op :: rest)} :
-    Prog.meteredEvalT (op :: rest) stack h_wf h_whf =
-      let (r, opT, opS) := op.meteredEvalT stack h_wf.1 h_whf.1
-      let (stack, t, s) := meteredEvalT rest (r :: stack) h_wf.2 h_whf.2
-      (stack, opT + t, opS + s) := by
-  rw [Prog.meteredEvalT, Part.get_eq_iff_mem]
-  unfold meteredEvalProg
-  simp only [Part.bind_eq_bind, Part.mem_bind_iff]
-  refine ⟨_, Part.get_mem (Dom_meteredEvalOp_of_WhileFree h_wf.1 h_whf.1),
-    _, Part.get_mem (Prog_total_of_WhileFree rest h_wf.2 h_whf.2 _ (by simp)), ?_⟩
-  simp [Operation.meteredEvalT, Prog.meteredEvalT]
-
--- ========================= Compositional specifications =========================
-
-/-! ## Compositional specifications
-
-`Operation.Computes op f` (resp. `Prog.Computes p f`) says: whenever `op` (resp. `p`)
-is while-free and runs on a suitable stack `s`, the resulting data equals `f s h_wf`.
-The function `f` is allowed to depend on the well-formedness proof so that it can
-write `s[i]'_` directly.
-
-Why this exists: a naive `simp` chain that unfolds every step of an `n`-operation
-program produces a goal where intermediate stacks are duplicated `O(n²)` times.
-With `Computes`, each step is summarised once by its own `f`, and composition
-(`computes_cons`) chains them via `let`-bindings in the spec function — the
-proof of the composite program never instantiates a giant inlined stack term. -/
-
-/-- A specification for a single operation. -/
-def Operation.Computes (op : Operation)
-    (f : (s : List Data) → WFOp s.length op → Data) : Prop :=
-  ∀ (s : List Data) (h_wf : WFOp s.length op) (h_whf : Operation.WhileFree op),
-    (Operation.meteredEvalT op s h_wf h_whf).1 = f s h_wf
-
-/-- A specification for a program. -/
-def Prog.Computes (p : Prog)
-    (f : (s : List Data) → WFProg s.length p → Data) : Prop :=
-  ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
-    (Prog.meteredEvalT p s h_wf h_whf).1 = f s h_wf
-
--- ========================= Automation via type-class resolution =========================
-
-/-! ## Automatic spec synthesis
-
-The composition pattern `Prog.computes_cons (op_spec) (Prog.computes_cons ... Prog.computes_nil)`
-is mechanical and entirely determined by the program structure. We expose it via
-type classes so that, for any program built from registered operations, the spec
-function and proof can be obtained by `inferInstance`. -/
-
-class Operation.HasComputes (op : Operation) where
-  spec  : (s : List Data) → WFOp s.length op → Data
-  time  : (s : List Data) → WFOp s.length op → ℕ
-  space : (s : List Data) → WFOp s.length op → ℕ
-  proof : ∀ (s : List Data) (h_wf : WFOp s.length op) (h_whf : Operation.WhileFree op),
-    Operation.meteredEvalT op s h_wf h_whf = (spec s h_wf, time s h_wf, space s h_wf)
-
-class Prog.HasComputes (p : Prog) where
-  spec  : (s : List Data) → WFProg s.length p → Data
-  time  : (s : List Data) → WFProg s.length p → ℕ
-  space : (s : List Data) → WFProg s.length p → ℕ
-  proof : ∀ (s : List Data) (h_wf : WFProg s.length p) (h_whf : Prog.WhileFree p),
-    Prog.meteredEvalT p s h_wf h_whf = (spec s h_wf, time s h_wf, space s h_wf)
-
-instance : Prog.HasComputes ([] : Prog) where
-  spec  := fun s h_wf => s.head (by simpa [WFProg] using h_wf)
-  time  := fun _ _ => 0
-  space := fun _ _ => 0
-  proof := by simp [Prog.meteredEvalT]
-
-instance {op : Operation} {rest : Prog}
-    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
-    Prog.HasComputes (op :: rest) where
-  spec := fun s h_wf => hrest.spec ((hop.spec s h_wf.1) :: s) h_wf.2
-  time := fun s h_wf =>
-    let r := hop.spec s h_wf.1
-    hop.time s h_wf.1 + hrest.time (r :: s) h_wf.2
-  space := fun s h_wf =>
-    let r := hop.spec s h_wf.1
-    hop.space s h_wf.1 + hrest.space (r :: s) h_wf.2
-  proof := by
-    intros s h_wf h_whf
-    simp only [Prog.meteredEvalT_cons, hop.proof, hrest.proof]
-
-instance (h t : ℕ) : Operation.HasComputes (.cons h t) where
-  spec  := fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)
-  time  := fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size
-  space := fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size
-  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
-
-instance (i : ℕ) : Operation.HasComputes (.head i) where
-  spec  := fun s h_wf => (s[i]'h_wf).asList.headD Data.empty
-  time  := fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size
-  space := fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size
-  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
-
-instance (i : ℕ) : Operation.HasComputes (.tail i) where
-  spec  := fun s h_wf => Data.l (s[i]'h_wf).asList.tail
-  time  := fun s h_wf => 1 + (s[i]'h_wf).size
-  space := fun s h_wf => 1 + (Data.l (s[i]'h_wf).asList.tail).size
-  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
-
-instance : Operation.HasComputes .empty where
-  spec  := fun _ _ => Data.empty
-  time  := fun _ _ => 1
-  space := fun _ _ => 1
-  proof := by simp [Operation.meteredEvalT, meteredEvalOp]
-
-instance (i j : ℕ) : Operation.HasComputes (.eq i j) where
-  spec := fun s h_wf =>
-    if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse
-  time  := fun s h_wf =>
-    1 + min (s[i]'h_wf.1).size (s[j]'h_wf.2).size
-  space := fun _ _ => 1
-  proof := by
-    intros s h_wf h_whf
-    simp [Operation.meteredEvalT, meteredEvalOp]
-
-instance {i : ℕ} {then_ else_ : List Operation}
-    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
-    Operation.HasComputes (.ifEmpty i then_ else_) where
-  spec := fun s h_wf =>
-    if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1 else he.spec s h_wf.2.2
-  time := fun s h_wf =>
-    1 + (if (s[i]'h_wf.1) == Data.empty then ht.time s h_wf.2.1 else he.time s h_wf.2.2)
-  space := fun s h_wf =>
-    if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1 else he.space s h_wf.2.2
-  proof := by
-    intros s h_wf h_whf
-    simp only [Operation.meteredEvalT, meteredEvalOp]
-    split_ifs
-    · have := ht.proof s h_wf.2.1 h_whf.1
-      simp [Prog.meteredEvalT] at this
-      simp [this]
-    · have := he.proof s h_wf.2.2 h_whf.2
-      simp [Prog.meteredEvalT] at this
-      simp [this]
-
-
-instance {body : Prog} {idxs : List TapeIndex}
-    [hb : Prog.HasComputes body] :
-    Operation.HasComputes (.call body idxs) where
-  spec := fun s h_wf =>
-    hb.spec
-      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-      (by simpa using h_wf.2)
-  time := fun s h_wf =>
-    hb.time
-      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-      (by simpa using h_wf.2)
-  space := fun s h_wf =>
-    hb.space
-      (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-      (by simpa using h_wf.2)
-  proof := by
-    intros s h_wf h_whf
-    simp [Operation.meteredEvalT, meteredEvalOp]
-    sorry
-
-
-/-- One-liner: extract the data result of any auto-resolvable program. -/
-abbrev Prog.run (p : Prog) [h : Prog.HasComputes p]
-    (s : List Data) (h_wf : WFProg s.length p) : Data :=
-  h.spec s h_wf
-
--- --------- Bridge: `meteredEvalT` reduces to the triple of HasComputes fields ---------
-
-/-- The bridge: any `meteredEvalT` of a program with a `HasComputes` instance
-    rewrites to `(spec, time, space)`. Each projection (`.1`, `.2.1`, `.2.2`)
-    then reduces independently along its own simp chain. -/
-@[simp] lemma Prog.HasComputes.meteredEvalT_eq {p : Prog} [h : Prog.HasComputes p]
-    {s : List Data} {h_wf : WFProg s.length p} {h_whf : Prog.WhileFree p} :
-    Prog.meteredEvalT p s h_wf h_whf = (h.spec s h_wf, h.time s h_wf, h.space s h_wf) :=
-  h.proof s h_wf h_whf
-
-@[simp] lemma Operation.HasComputes.meteredEvalT_eq {op : Operation}
-    [h : Operation.HasComputes op]
-    {s : List Data} {h_wf : WFOp s.length op} {h_whf : Operation.WhileFree op} :
-    Operation.meteredEvalT op s h_wf h_whf = (h.spec s h_wf, h.time s h_wf, h.space s h_wf) :=
-  h.proof s h_wf h_whf
-
--- --------- Simp lemmas exposing each instance's spec/time/space ---------
--- These are all `rfl`: each instance's field is *definitionally* its RHS.
--- We expose them as `simp` lemmas so that `simp [...]` can unfold the chain
--- compositionally without needing the instances themselves to be reducible.
-
-@[simp] lemma Prog.HasComputes.spec_nil :
-    (Prog.HasComputes.spec (p := ([] : Prog))) =
-      fun s h_wf => s.head (by simp [WFProg] at h_wf; exact h_wf) := rfl
-@[simp] lemma Prog.HasComputes.time_nil :
-    (Prog.HasComputes.time (p := ([] : Prog))) = fun _ _ => 0 := rfl
-@[simp] lemma Prog.HasComputes.space_nil :
-    (Prog.HasComputes.space (p := ([] : Prog))) = fun _ _ => 0 := rfl
-
-@[simp] lemma Prog.HasComputes.spec_cons {op : Operation} {rest : Prog}
-    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
-    (Prog.HasComputes.spec (p := op :: rest)) =
-      fun s h_wf =>
-        let r := hop.spec s h_wf.1
-        hrest.spec (r :: s) h_wf.2 := rfl
-@[simp] lemma Prog.HasComputes.time_cons {op : Operation} {rest : Prog}
-    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
-    (Prog.HasComputes.time (p := op :: rest)) =
-      fun s h_wf =>
-        let r := hop.spec s h_wf.1
-        hop.time s h_wf.1 + hrest.time (r :: s) h_wf.2 := rfl
-@[simp] lemma Prog.HasComputes.space_cons {op : Operation} {rest : Prog}
-    [hop : Operation.HasComputes op] [hrest : Prog.HasComputes rest] :
-    (Prog.HasComputes.space (p := op :: rest)) =
-      fun s h_wf =>
-        let r := hop.spec s h_wf.1
-        hop.space s h_wf.1 + hrest.space (r :: s) h_wf.2 := rfl
-
-@[simp] lemma Operation.HasComputes.spec_cons (h t : ℕ) :
-    (Operation.HasComputes.spec (op := .cons h t)) =
-      fun s h_wf => Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList) := rfl
-@[simp] lemma Operation.HasComputes.time_cons (h t : ℕ) :
-    (Operation.HasComputes.time (op := .cons h t)) =
-      fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size := rfl
-@[simp] lemma Operation.HasComputes.space_cons (h t : ℕ) :
-    (Operation.HasComputes.space (op := .cons h t)) =
-      fun s h_wf => 1 + (Data.l ((s[h]'h_wf.1) :: (s[t]'h_wf.2).asList)).size := rfl
-
-@[simp] lemma Operation.HasComputes.spec_head (i : ℕ) :
-    (Operation.HasComputes.spec (op := .head i)) =
-      fun s h_wf => (s[i]'h_wf).asList.headD Data.empty := rfl
-@[simp] lemma Operation.HasComputes.time_head (i : ℕ) :
-    (Operation.HasComputes.time (op := .head i)) =
-      fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size := rfl
-@[simp] lemma Operation.HasComputes.space_head (i : ℕ) :
-    (Operation.HasComputes.space (op := .head i)) =
-      fun s h_wf => 1 + ((s[i]'h_wf).asList.headD Data.empty).size := rfl
-
-@[simp] lemma Operation.HasComputes.spec_tail (i : ℕ) :
-    (Operation.HasComputes.spec (op := .tail i)) =
-      fun s h_wf => Data.l (s[i]'h_wf).asList.tail := rfl
-@[simp] lemma Operation.HasComputes.time_tail (i : ℕ) :
-    (Operation.HasComputes.time (op := .tail i)) =
-      fun s h_wf => 1 + (s[i]'h_wf).size := rfl
-@[simp] lemma Operation.HasComputes.space_tail (i : ℕ) :
-    (Operation.HasComputes.space (op := .tail i)) =
-      fun s h_wf => 1 + (Data.l (s[i]'h_wf).asList.tail).size := rfl
-
-@[simp] lemma Operation.HasComputes.spec_empty :
-    (Operation.HasComputes.spec (op := .empty)) = fun _ _ => Data.empty := rfl
-@[simp] lemma Operation.HasComputes.time_empty :
-    (Operation.HasComputes.time (op := .empty)) = fun _ _ => 1 := rfl
-@[simp] lemma Operation.HasComputes.space_empty :
-    (Operation.HasComputes.space (op := .empty)) = fun _ _ => 1 := rfl
-
-@[simp] lemma Operation.HasComputes.spec_eq (i j : ℕ) :
-    (Operation.HasComputes.spec (op := .eq i j)) =
-      fun s h_wf =>
-        if (s[i]'h_wf.1) == (s[j]'h_wf.2) then dataTrue else dataFalse := rfl
-@[simp] lemma Operation.HasComputes.time_eq (i j : ℕ) :
-    (Operation.HasComputes.time (op := .eq i j)) =
-      fun s h_wf =>
-        1 + min (s[i]'h_wf.1).size (s[j]'h_wf.2).size := rfl
-@[simp] lemma Operation.HasComputes.space_eq (i j : ℕ) :
-    (Operation.HasComputes.space (op := .eq i j)) =
-      fun _ _ => 1 := rfl
-
-@[simp] lemma Operation.HasComputes.spec_ifEmpty {i : ℕ} {then_ else_ : List Operation}
-    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
-    (Operation.HasComputes.spec (op := .ifEmpty i then_ else_)) =
-      fun s h_wf =>
-        if (s[i]'h_wf.1) == Data.empty then ht.spec s h_wf.2.1
-        else he.spec s h_wf.2.2 := rfl
-@[simp] lemma Operation.HasComputes.time_ifEmpty {i : ℕ} {then_ else_ : List Operation}
-    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
-    (Operation.HasComputes.time (op := .ifEmpty i then_ else_)) =
-      fun s h_wf =>
-        1 + (if (s[i]'h_wf.1) == Data.empty then ht.time s h_wf.2.1
-             else he.time s h_wf.2.2) := rfl
-@[simp] lemma Operation.HasComputes.space_ifEmpty {i : ℕ} {then_ else_ : List Operation}
-    [ht : Prog.HasComputes then_] [he : Prog.HasComputes else_] :
-    (Operation.HasComputes.space (op := .ifEmpty i then_ else_)) =
-      fun s h_wf =>
-        if (s[i]'h_wf.1) == Data.empty then ht.space s h_wf.2.1
-        else he.space s h_wf.2.2 := rfl
-
-@[simp] lemma Operation.HasComputes.spec_call {body : Prog} {idxs : List TapeIndex}
-    [hb : Prog.HasComputes body] :
-    (Operation.HasComputes.spec (op := .call body idxs)) =
-      fun s h_wf =>
-        hb.spec
-          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-          (by simpa using h_wf.2) := rfl
-@[simp] lemma Operation.HasComputes.time_call {body : Prog} {idxs : List TapeIndex}
-    [hb : Prog.HasComputes body] :
-    (Operation.HasComputes.time (op := .call body idxs)) =
-      fun s h_wf =>
-        hb.time
-          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-          (by simpa using h_wf.2) := rfl
-@[simp] lemma Operation.HasComputes.space_call {body : Prog} {idxs : List TapeIndex}
-    [hb : Prog.HasComputes body] :
-    (Operation.HasComputes.space (op := .call body idxs)) =
-      fun s h_wf =>
-        hb.space
-          (idxs.attach.map (fun ⟨i, hi⟩ => s[i]'(h_wf.1 i hi)))
-          (by simpa using h_wf.2) := rfl
-
--------------------------------------
---- Encoding of generic types into Data
---------------------------------------
-
-class DataEncode (α : Type) where
-  encode : α → Data
-  h_inj : encode.Injective
-
-instance : DataEncode Bool where
-  encode b := if b then dataTrue else dataFalse
-  h_inj := by intros a b h_eq; grind
-
-instance (α : Type) [DataEncode α] : DataEncode (List α) where
-  encode xs := Data.l (xs.map DataEncode.encode)
-  h_inj := by sorry
-
-@[simp, grind =]
-lemma DataEncode_list_nil {α : Type} [DataEncode α] :
-  DataEncode.encode ([] : List α) = Data.l [] := by
-  simp [DataEncode.encode]
-
-@[simp, grind =]
-lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
-  DataEncode.encode xs = Data.empty ↔ xs = [] := by
-  simp [DataEncode.encode]
-
-@[simp, scoped grind =]
-lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
-  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
-  simp [DataEncode.encode]
-
-instance (α : Type) [DataEncode α] : DataEncode (Option α) where
-  encode := fun
-    | none => Data.l []
-    | some x => Data.l [DataEncode.encode x]
-  h_inj := by sorry
-
-@[simp]
-lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
-  (DataEncode.encode x == Data.empty) = x.isNone := by
-  cases x <;> simp [DataEncode.encode, Data.empty]
-
-instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
-  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
-  h_inj := by sorry
-
-lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
-  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
-  simp [DataEncode.encode]
-
-instance : DataEncode ℕ where
-  encode x := DataEncode.encode (Nat.bits x)
-  h_inj := by sorry
-
-
-------------------------------------------------------
------------ Tools
------------------------------------------------------------
-
-
-abbrev snd : Prog := [ .tail 0, .head 0 ]
-
-
-lemma snd.semantics {α β : Type} [DataEncode α] [DataEncode β]
-    {stack : List Data} {x : α} {y : β} :
-    (snd.meteredEvalT ((DataEncode.encode (x, y)) :: stack)
-      (by simp [WFProg, WFOp]) (by simp)) =
-      (DataEncode.encode y,
-        2 + ((DataEncode.encode y).size + (DataEncode.encode (x, y)).size),
-        4 + 2 * (DataEncode.encode y).size)
-      := by
-  simp [snd, DataEncode.encode]
-  grind
-
-/-- Data-only semantics of `snd`, proved via the `HasComputes` automation: instance
-    search assembles the spec function from per-operation specs for `.tail` and `.head`,
-    and `HasComputes.proof` discharges the equality. No simp chain through the
-    full `(Data × ℕ × ℕ)` triple, hence no `O(n²)` blowup. -/
-lemma snd.evalData_eq {α β : Type} [DataEncode α] [DataEncode β]
-    {stack : List Data} {x : α} {y : β} :
-    (Prog.meteredEvalT snd (DataEncode.encode (x, y) :: stack)
-      (by simp [WFProg, WFOp]) (by simp)).1 =
-      DataEncode.encode y := by
-  simp [DataEncode.encode]
-
-@[simp] lemma snd.spec_eq :
-    (Prog.HasComputes.spec (p := snd)) =
-      (Prog.HasComputes.spec (p := [Operation.tail 0, Operation.head 0])) := rfl
-
-def constant (a : Data) : Prog := match a with
-  | Data.l a => match a with
-    | [] => [ .empty ]
-    | x :: xs => [
-      .call (constant (Data.l xs)) [],
-      .call (constant x) [],
-      .cons 0 1 ]
-
-lemma constant_wf (a : Data) (n : ℕ) : WFProg n (constant a) := by
-  induction a using Data.inductionL generalizing n with
-  | nil => simp [constant, WFProg, WFOp]
-  | cons x xs ihx ihxs =>
-    simp [constant, WFProg, WFOp, ihx, ihxs]
-
-lemma constant_whf (a : Data) : Prog.WhileFree (constant a) := by
-  induction a using Data.inductionL with
-  | nil => simp [constant]
-  | cons x xs ihx ihxs =>
-    simp [constant, Prog.WhileFree, ihx, ihxs]
-
-lemma constant.semantics (a : Data) {stack : List Data} :
-    ((constant a).meteredEvalT stack (constant_wf _ _) (constant_whf _)).1 = a := by
-  induction a using Data.inductionL with
-  | nil => simp [constant]
-  | cons x xs ihx ihxs =>
-    simp [constant, ihx, ihxs, meteredEvalOp, meteredEvalProg]
-    sorry
---------------------------------
----------------- Universal Turing Machine (simulation of a SingleTapeTM)
----------------------------------------------------------------------------
-
-variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
-
-public instance : DataEncode (Turing.StackTape Symbol) where
-  encode t := DataEncode.encode t.toList
-  h_inj := by sorry
-
-public instance : DataEncode (Turing.BiTape Symbol) where
-  encode t := DataEncode.encode (t.head, t.left, t.right)
-  h_inj := by sorry
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma encode_biTape (t : Turing.BiTape Symbol) :
-    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
-    simp [DataEncode.encode]
-
-def tape_write : Prog := [
-  .tail 1,
-  .cons 1 0
-]
-
-def tape_write' : Operation' :=
-  .cons [.load 0] [.tail [.load 1]]
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-@[simp]
-lemma tape_write.semantics (t : Turing.BiTape Symbol) (a : Option Symbol) {stack : List Data} :
-    (tape_write.meteredEvalT (DataEncode.encode a :: DataEncode.encode t :: stack)
-      (by simp [tape_write, WFProg, WFOp]) (by simp [tape_write])).1 =
-      DataEncode.encode (t.write a) := by
-  simp [tape_write, Turing.BiTape.write]
-  rfl
-
-abbrev stackTape_cons : Prog := [
-  .ifEmpty 0 [ .ifEmpty 1 [ .empty ] [ .cons 0 1 ] ] [ .cons 0 1 ]
-]
-
--- def move_left (t : BiTape Symbol) : BiTape Symbol :=
---   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-@[simp]
-lemma stackTape_cons.spec_eq (head : Option Symbol) (tail : Turing.StackTape Symbol)
-      (h_wf : WFProg [DataEncode.encode head, DataEncode.encode tail].length stackTape_cons) :
-    (Prog.HasComputes.spec (p := stackTape_cons))
-      [DataEncode.encode head, DataEncode.encode tail] h_wf =
-      DataEncode.encode (tail.cons head)
-      := by
-  cases head with
-  | none =>
-    obtain ⟨l, hl⟩ := tail
-    cases l with
-    | nil => simp [DataEncode.encode, Turing.StackTape.cons]
-    | cons hd tl => simp [DataEncode.encode, Turing.StackTape.cons]
-  | some a => simp [DataEncode.encode, Turing.StackTape.cons]
-
-abbrev to_pair : Prog := [ .empty, .cons 2 0, .cons 2 0 ]
-
-lemma to_pair.semantics {α β : Type} [DataEncode α] [DataEncode β]
-    {stack : List Data} {x : α} {y : β} :
-    (to_pair.meteredEvalT (DataEncode.encode x :: DataEncode.encode y :: stack)
-      (by simp [WFProg, WFOp]) (by simp)).1 =
-      DataEncode.encode (x, y) := by
-  simp [to_pair, DataEncode.encode]
-
-abbrev tape_move_left : Prog := [
-  .head 0, -- t.head
-  .call [ .call snd [0], .call snd [0] ] [1], -- t.right
-  .call stackTape_cons [1, 0], -- StackTape.cons t.head t.right
-  .call [ .call snd [0], .head 0, .tail 0 ] [3], -- t.left.tail
-  .call [ .call snd [0], .head 0, .head 0 ] [4], -- t.left.head
-  .call to_pair [1, 2],
-  .call to_pair [1, 0],
-]
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma tape_move_left.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
-    (tape_move_left.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
-      (by simp)).1 =
-      DataEncode.encode (Turing.BiTape.move_left t)
-        := by
-  rw [Prog.HasComputes.proof (p := tape_move_left)]
-  unfold Turing.BiTape.move_left
-  simp [DataEncode_pair, encode_biTape]
-  refine ⟨?_, ?_⟩
-  · rcases t.left with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
-  · have : (t.left.tail).toList = (t.left.toList).tail :=
-      by rcases t.left with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
-        simp [Turing.StackTape.tail, Turing.StackTape.nil]
-    simp [DataEncode.encode, this]
-
--- def move_right (t : BiTape Symbol) : BiTape Symbol :=
---   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
-
-abbrev tape_move_right : Prog := [
-  .head 0,                                    -- t.head
-  .call [ .call snd [0], .call snd [0] ] [1], -- t.right
-  .call [ .call snd [0], .head 0 ] [2],       -- t.left
-  .call stackTape_cons [2, 0],                -- cons(t.head, t.left)
-  .head 2,                                    -- t.right.head
-  .tail 3,                                    -- t.right.tail
-  .call to_pair [2, 0],                       -- pair(cons(t.head,t.left), t.right.tail)
-  .call to_pair [2, 0],                       -- pair(t.right.head, ...)
-]
-
-
-omit [Inhabited Symbol] [Fintype Symbol] in
-lemma tape_move_right.semantics (t : Turing.BiTape Symbol) {stack : List Data} :
-    (tape_move_right.meteredEvalT (DataEncode.encode t :: stack) (by simp [WFProg, WFOp])
-      (by simp)).1 =
-      DataEncode.encode (Turing.BiTape.move_right t)
-        := by
-  rw [Prog.HasComputes.proof (p := tape_move_right)]
-  unfold Turing.BiTape.move_right
-  simp [DataEncode_pair, encode_biTape]
-  refine ⟨?_, ?_⟩
-  · rcases t.right with ⟨_ | ⟨hd, tl⟩, hw⟩ <;> simp [Turing.StackTape.head, DataEncode.encode]
-  · have : (t.right.tail).toList = (t.right.toList).tail :=
-      by rcases t.right with ⟨_ | ⟨hd, tl⟩, hw⟩ <;>
-        simp [Turing.StackTape.tail, Turing.StackTape.nil]
-    simp [DataEncode.encode, this]
-
--- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
---   | t, none => t
---   | t, some d => t.move d
-
-instance : DataEncode Dir where
-  encode := fun
-    | Dir.left => Data.l [Data.empty]
-    | Dir.right => Data.l [Data.l []]
-  h_inj := by sorry
-
-abbrev tapeOptionMove : Prog := [
-  .ifEmpty 1
-    [ .call [] [0] ] -- none case: return t
-    [ .tail 1,
-      .call (constant (DataEncode.encode Dir.left)) [],
-      .eq 0 1, -- direction == left?
-      .ifEmpty 0
-       [ .call [] [0] ] -- right
-       [ .call (constant (DataEncode.encode Dir.left)) [], .eq 1 2, -- direction == left?
-         .ite 3 tape_move_left tape_move_right
-       ]
-
-    -- some case: move t according to direction
-      .call [ .call snd [2], .head 0 ] [3], -- direction
-      .ite 3 tape_move_left tape_move_right
-    ]
-]
-
-
--- def put : Data → Prog
---   | Data.l [] => [ .empty ]
---   | Data.l (head :: tail) => [
---       .call (put (Data.l tail)),
---       .call (put head),
---       .cons 0 1
---     ]
-
--- --------------------- IDEAS ---------------------------------
--- -- Complexity:
--- -- If a program is loop-free (no .while, no .fold), then both its space and time complexity
--- -- is linear in the sum of the sizes of its inputs (determined by the smallest well-formedness
--- -- parameter)
--- ------------------------------------
-
-
--- @[simp]
--- lemma put_wf {i : ℕ} {d : Data} : WFProg i (put d) := by sorry
-
--- @[simp]
--- lemma put_whf {d : Data} : Prog.WhileFree (put d) := by sorry
-
--- @[simp]
--- lemma put_semantics {stack : List Data} {d : Data} :
---     ((put d).meteredEvalT stack (by simp) (by simp)).1 = d := by sorry
-
--- def copy (slot : ℕ) : Prog := [ .tail slot, .head (slot + 1), .cons 0 1 ]
-
--- @[simp]
--- lemma copy_wf {i slot : ℕ} (h_lt : slot < i) : WFProg i (copy slot) := by
---   simp [copy, WFProg, WFOp, h_lt]
-
--- @[simp]
--- lemma copy_whf {slot : ℕ} : Prog.WhileFree (copy slot) := by simp [copy]
-
--- @[simp]
--- lemma copy_semantics {stack : List Data} {slot : ℕ} (h_lt : slot < stack.length) :
---     ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
---   simp [copy, Operation.meteredEvalT, meteredEvalOp]
---   sorry
-
--- --- Runs `condition` on every element in the list and returns the first return value that
--- --- is non-empty.
--- def find? (condition : Prog) : Prog := [
---     .empty,
---     .fold [
---       -- element: 0, acc: 1
---       .ite 1 (copy 1) [.call condition],
---     ] 1 0
---   ]
-
--- @[simp]
--- lemma find?_semantics (condition : Prog) {stack : List Data} {slot : ℕ}
---     (h_lt : slot < stack.length) :
---     ((copy slot).meteredEvalT stack (by simp [h_lt]) (by simp)).1 = stack[slot] := by
---   simp [copy, Operation.meteredEvalT, meteredEvalOp]
---   sorry
-
--- def get_symbol : Prog := [
---     .head 0
---   ]
-
--- public instance (α : Type) [StrEnc α] (k : ℕ) : StrEnc (Vector α k) where
---   toData v := StrEnc.toData v.toList
-
--- public instance : StrEnc (MultiCell (k : ℕ)) where
---   toData mc := StrEnc.toData (mc.cells, mc.isLeftEnd, mc.isRightEnd)
-
--- /-
--- Outline of UTM:
--- while the current state is not None:
--- - for each tape, find the head position on the multi-tape
---   and copy the current symbol to an aux tape.
--- - now the aux tape contains the symbols in the correct order.
--- - copy the current state to the aux tape.
--- - the contents of the aux tape is exactly the input to the
---   transition function
--- - "evaluate the transition function" by iterating through its
---   table and storing the result on another tape
--- - execute the actions for each of the tapes:
---   - find the head. update the symbol, update the head marking
---     according to the move action
---     (potentially extend the tape to the left or right)
--- - update the current state
--- -/
-
--- /- sub-routines we need:
--- - move to the first element of a list that satisfies a condition:
---   tm₁ tm₂ tm₃: For each item in the list: if tm₁ outputs true on an aux tape, run tm₂.
---   if it never outputs true, run tm₃
--- - evaluate a function given by a list of input-output pairs
--- - update an element in a list, whose encoding size must be the same
--- - extend a list to the right
--- -/
-
--- /-- The encoding of the given tapes as a list of `MultiCell`s. -/
--- def encodeTapes (k : ℕ) (tapes : Fin k → BiTape Char) (shifts : Fin k → ℤ) :
---   List (MultiCell k) :=
---   sorry
-
--- def getHeadSymbol (k : ℕ) (tapeIdx : ℕ) (mt out aux : Fin k) : MultiTapeTM k Char :=
---   -- Find the cell where the tapeIdx-th tape has the head
---   find_list mt aux (atPath [0, tapeIdx, 1] mt (copyEnc mt aux))
---     -- copy the symbol to out
---     (atPath [0, tapeIdx, 0] mt (copy_to_list mt out))
---     -- otherwise do nothing (because we know there is a head marker)
---     (noop)
-
-
-
-
--- -----------------------------------------------------------------------------------------
--- --- The stuff below here still needs some work
--- -----------------------------------------------------------------------------
-
--- structure WellFormedProgram (inputs : ℕ) where
---   prog : Prog
---   h_wf : WFProg inputs prog
-
--- --- The output stack size of the program.
--- abbrev WellFormedProgram.stackSize {inputs : ℕ} (p : WellFormedProgram inputs) : ℕ :=
---    inputs + p.prog.length
-
--- def FunType (inputs : ℕ) : Type := match inputs with
---   | 0 => Data
---   | n + 1 => Data → FunType n
-
--- @[simp]
--- def WellFormedProgram.eval {inputs : ℕ} (p : WellFormedProgram inputs)
---     (stack : List Data) (h_len : stack.length ≥ inputs) : Part Data :=
---   (meteredEvalProg p.prog stack (by sorry)).map fun (d, _, _) => d
-
--- @[simp]
--- def WellFormedProgram.time {inputs : ℕ} (p : WellFormedProgram inputs)
---     (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
---   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, t, _) => t
-
--- @[simp]
--- def WellFormedProgram.space {inputs : ℕ} (p : WellFormedProgram inputs)
---     (stack : List Data) (h_len : stack.length = inputs) : Part ℕ :=
---   (meteredEvalProg p.prog stack (by simpa [h_len] using p.h_wf)).map fun (_, _, s) => s
-
--- structure TotalProgram (inputs : ℕ) extends WellFormedProgram inputs where
---   h_total : toWellFormedProgram.prog.Total toWellFormedProgram.h_wf
-
--- def TotalProgram.eval {inputs : ℕ} (p : TotalProgram inputs)
---     (stack : List Data) (h_len : stack.length ≥ inputs) : Data :=
---   (p.toWellFormedProgram.eval stack h_len).get (p.h_total stack sorry)
-
--- /-- Unfolding lemma that lets `simp` "execute" a `TotalProgram` step-by-step: it
---     rewrites `p.eval stack h_len` into a form mentioning `meteredEvalProg` directly,
---     so the `@[simp]` equations for `meteredEvalProg`/`meteredEvalOp` together with
---     `Part.some_bind`, `Part.map_some`, `Part.get_some` can reduce the program. -/
--- @[simp]
--- theorem TotalProgram.eval_eq {inputs : ℕ} (p : TotalProgram inputs)
---     (stack : List Data) (h_len : stack.length ≥ inputs) :
---     p.eval stack h_len =
---       ((meteredEvalProg p.prog stack (by sorry)).get
---          (by simpa [WellFormedProgram.eval] using p.h_total stack sorry)).1 := by
---   simp [TotalProgram.eval, WellFormedProgram.eval]
-
--- def TotalProgram.as_fun {inputs : ℕ} (p : TotalProgram inputs) :
---     FunType inputs :=
---   sorry
-
--- -- examples:
--- def prog_true : WellFormedProgram 0 := {
---   prog := [.empty, .cons 0 0],
---   h_wf := by simp [WFProg, WFOp]
--- }
--- def prog_false : WellFormedProgram 0 := {
---   prog := [.empty],
---   h_wf := by simp [WFProg, WFOp]
--- }
--- def prog_negate : WellFormedProgram 1 := {
---   prog := [.eq 0 0],
---   h_wf := by simp [WFProg, WFOp]
--- }
--- lemma prog_true.semantics : prog_true.eval [] rfl = .some dataTrue := by
---   simp [prog_true, meteredEvalOp]
-
--- lemma prog_true.space : prog_true.space [] rfl = .some 6 := by
---   simp [prog_true, meteredEvalOp, Data.size]
-
--- lemma prog_true.time : prog_true.time [] rfl = .some 6 := by
---   simp [prog_true, meteredEvalOp, Data.size]
-
--- def WellFormedProgram.append {in₁ in₁ : ℕ}
---     (p₁ : WellFormedProgram in₁) (p₂ : WellFormedProgram in₂) (h_le : in₂ ≤ p₁.stackSize) :
---     WellFormedProgram in₁ :=
---   { prog := p₁.prog ++ p₂.prog, h_wf := by sorry }
-
-
--- def RunsInSpace {inputs : ℕ} (p : WellFormedProgram inputs) (s : ℕ → ℕ) : Prop :=
---   ∃ s₁ s₂, ∀ x, (h_l : x.length = inputs) → ∃ s' ≤ s₁ * (s (Data.l x).size) + s₂,
---   p.space x h_l = .some s'
-
--- def RunsInTime {inputs : ℕ} (p : WellFormedProgram inputs) (t : ℕ → ℕ) : Prop :=
---   ∃ t₁ t₂, ∀ x, (h_l : x.length = inputs) → ∃ t' ≤ t₁ * (t (Data.l x).size) + t₂,
---   p.time x h_l = .some t'
-
--- def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β]
---   (p : WellFormedProgram 1) (f : α → β) (t s : ℕ → ℕ) : Prop :=
---   ∃ t₁ t₂ s₁ s₂,
---     (∀ x : α, p.eval [DataEncode.encode x] sorry = .some (DataEncode.encode (f x))) ∧
---     (∀ x : α, ∃ t' ≤ t₁ * (t (DataEncode.encode x).size) + t₂,
---         p.time [DataEncode.encode x] rfl = .some t') ∧
---     (∀ x : α, ∃ s' ≤ s₁ * (s (DataEncode.encode x).size) + s₂,
---         p.space [DataEncode.encode x] sorry = .some s')
-
--- def ComputableInTimeAndSpace (α β : Type) [DataEncode α] [DataEncode β]
---   (f : α → β) (t s : ℕ → ℕ) : Prop :=
---   ∃ (p : WellFormedProgram 1), ComputesInTimeAndSpace p f t s
-
-
--- def prog_reverse : TotalProgram 1 := {
---   prog := [
---     .empty,
---     .fold [
---       .cons 0 1
---     ] 0 1
---   ],
---   h_wf := by simp [WFProg, WFOp]
---   h_total := by simp
--- }
-
--- -- TODO continue here: Now we need a good lemma for goMeteredFold.
-
--- /-- The `(result, time, space)` triple produced by a single execution of a total fold
---     body on `c :: acc :: stack`. Derived from `meteredEvalProg`, so no extra data is
---     needed beyond the body, its well-formedness, and a totality witness. -/
--- def Prog.foldStep {body : Prog} {stack : List Data}
---     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
---     (c acc : Data) : Data × ℕ × ℕ :=
---   (meteredEvalProg body (c :: acc :: stack) h_wf).get
---     (h_total (c :: acc :: stack) (by simp))
-
--- lemma Prog.meteredEvalProg_eq_foldStep {body : Prog} {stack : List Data}
---     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
---     (c acc : Data) :
---     meteredEvalProg body (c :: acc :: stack) h_wf =
---       .some (Prog.foldStep h_wf h_total c acc) :=
---   (Part.some_get _).symm
-
--- /-- Simp form of `goMeteredFold_of_step`: a *total* body uniquely determines the fold
---     semantics, with no free `step`/`stepTime`/`stepSpace` variables for `simp` to
---     invent. The data result is exactly `List.foldl` over `Prog.foldStep`. -/
--- @[simp]
--- lemma goMeteredFold_of_total {body : Prog} {stack : List Data}
---     (h_wf : WFProg (stack.length + 2) body) (h_total : body.Total h_wf)
---     (xs : List Data) (acc : Data) :
---     goMeteredFold xs acc stack body h_wf = .some
---       (xs.foldl (fun a x => (Prog.foldStep h_wf h_total x a).1) acc,
---        foldTime (fun c a => (Prog.foldStep h_wf h_total c a).2.1)
---                 (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc,
---        foldSpace (fun c a => (Prog.foldStep h_wf h_total c a).2.2)
---                  (fun c a => (Prog.foldStep h_wf h_total c a).1) xs acc) := by
---   induction xs generalizing acc with
---   | nil => simp [foldTime, foldSpace, goMeteredFold]
---   | cons x xs ih =>
---     simp [ih, foldTime, foldSpace, goMeteredFold]
---     rw [Prog.meteredEvalProg_eq_foldStep h_wf h_total]
---     simp_all
-
--- -- TODO: summary of current problems: We canont re-write the stuff inside a
--- -- `Part.bind` because that would change the type (although it is equal)
--- -- Solution: Get rid of Part
-
--- lemma prog_reverse.semantics (x : Data) (xs : List Data) :
---     (prog_reverse.prog.meteredEvalT (x :: xs) (by simp; sorry) (by simp [prog_reverse])).1 =
---       Data.l (x.asList).reverse := by
---   have h (xs : List Data) (init : Data) : xs.foldl (fun a x => Data.l (x :: a.asList)) init =
---       Data.l (xs.reverse ++ init.asList) := by
---     induction xs generalizing init with
---     | nil => simp
---     | cons x xs ih => simp [List.foldl, ih]
---   simp [prog_reverse, h]
-
--- theorem ComputesInTimeAndSpace_reverse {α : Type} [DataEncode α]
---   : ComputesInTimeAndSpace prog_reverse (List.reverse : List α → List α)
---     (fun n => 1 + 2 * n + n * n) (fun n => 1 + 2 * n + n * n) := by
---   refine ⟨_, _, _, _, ?_⟩
---   · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
---   · intro xs
---     simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
---     use 1 + 2 * xs.size + xs.size * xs.size
---     omega
---   · intro xs; simp [prog_reverse, meteredEvalOp, Data.asList, List.reverse]
---     use 1 + 2 * xs.size + xs.size * xs.size; omega
-
--- /-- Generic time cost of a metered fold whose body acts as a pure step
---     `(item, acc) ↦ acc'` with per-iteration time `stepTime item acc`. -/
--- def foldTime (stepTime : Data → Data → ℕ) (step : Data → Data → Data)
---     : List Data → Data → ℕ
---   | [],      acc => acc.size
---   | x :: xs, acc => 1 + stepTime x acc + foldTime stepTime step xs (step x acc)
-
--- /-- Generic space cost: max of per-iteration body space and the rest of the fold. -/
--- def foldSpace (stepSpace : Data → Data → ℕ) (step : Data → Data → Data)
---     : List Data → Data → ℕ
---   | [],      acc => acc.size
---   | x :: xs, acc => max (stepSpace x acc) (foldSpace stepSpace step xs (step x acc))
-
--- /-- Generic space bound for `foldSpace` via a single budget `B`:
---     if `init.size ≤ B`, and for every reachable accumulator each iteration's per-step
---     space and the resulting accumulator both stay within `B`, then the entire fold's
---     space is at most `B`. -/
--- lemma foldSpace_le {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
---     (B : ℕ) (xs : List Data) (init : Data) (hInit : init.size ≤ B)
---     (hStep : ∀ acc c, acc.size ≤ B → c ∈ xs →
---                 stepSpace c acc ≤ B ∧ (step c acc).size ≤ B) :
---     foldSpace stepSpace step xs init ≤ B := by
---   induction xs generalizing init with
---   | nil => simpa [foldSpace] using hInit
---   | cons x xs ih =>
---     have ⟨hSp, hAcc⟩ := hStep init x hInit (List.mem_cons_self ..)
---     refine max_le hSp
---       (ih _ hAcc fun acc c hAcc' hc => hStep acc c hAcc' (List.mem_cons_of_mem _ hc))
-
--- /-- Linear-space body + constant-size init ⟹ linear-space fold.
-
---     If every step costs space at most `s₁ * (c.size + acc.size) + s₂`, the accumulator
---     grows by at most `c.size + k` per item, and `init.size ≤ c₀`, then `foldSpace` is
---     linear in `(xs.map Data.size).sum + xs.length * k + c₀`. -/
--- lemma fold_space_linear {step : Data → Data → Data} {stepSpace : Data → Data → ℕ}
---     {s₁ s₂ k c₀ : ℕ}
---     (hStepSpace : ∀ c acc, stepSpace c acc ≤ s₁ * (c.size + acc.size) + s₂)
---     (hGrowth : ∀ c acc, (step c acc).size ≤ acc.size + c.size + k)
---     (xs : List Data) (init : Data) (hInit : init.size ≤ c₀) :
---     foldSpace stepSpace step xs init ≤
---       max (c₀ + (xs.map Data.size).sum + xs.length * k)
---           (s₁ * ((xs.map Data.size).sum + c₀ + xs.length * k) + s₂) := by
---   -- Strengthen by allowing any starting bound `c₀'` on `init.size`.
---   suffices h : ∀ (xs : List Data) (init : Data) (c₀' : ℕ), init.size ≤ c₀' →
---       foldSpace stepSpace step xs init ≤
---         max (c₀' + (xs.map Data.size).sum + xs.length * k)
---             (s₁ * ((xs.map Data.size).sum + c₀' + xs.length * k) + s₂) from h xs init c₀ hInit
---   clear hInit init xs
---   intro xs
---   induction xs with
---   | nil => intro init c₀' hInit; simpa [foldSpace] using Or.inl (by omega)
---   | cons x xs ih =>
---     intro init c₀' hInit
---     have hStepSize : (step x init).size ≤ c₀' + x.size + k := by
---       have := hGrowth x init; omega
---     have ih' := ih (step x init) (c₀' + x.size + k) hStepSize
---     have hSp : stepSpace x init ≤
---         s₁ * (x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k) + s₂ := by
---       have := Nat.mul_le_mul_left s₁
---         (show x.size + init.size ≤ x.size + (xs.map Data.size).sum + c₀' + (xs.length + 1) * k by
---           omega)
---       have h1 := hStepSpace x init
---       omega
---     simp only [foldSpace, List.length_cons, List.map_cons, List.sum_cons]
---     refine max_le (le_trans hSp (le_max_right _ _)) (le_trans ih' (max_le_max ?_ ?_))
---     · have : (xs.length + 1) * k = xs.length * k + k := by ring
---       omega
---     · apply Nat.add_le_add_right
---       apply Nat.mul_le_mul_left
---       have : (xs.length + 1) * k = xs.length * k + k := by ring
---       omega
-
--- /-- Generic semantics + time + space for any well-formed fold body that acts as a pure
---     deterministic step.
-
---     The hypothesis `hbody` must hold for every iteration: running `body` on a stack of the
---     form `c :: acc :: stack` (for any `c, acc`) produces `step c acc` with cost
---     `(stepTime c acc, stepSpace c acc)`. -/
--- lemma goMeteredFold_of_step {body : Prog} {stack : List Data}
---     (h_wf : WFProg (stack.length + 2) body)
---     (step : Data → Data → Data) (stepTime stepSpace : Data → Data → ℕ)
---     (hbody : ∀ (c acc : Data),
---       meteredEvalProg body (c :: acc :: stack) h_wf =
---         .some (step c acc, stepTime c acc, stepSpace c acc))
---     (xs : List Data) (acc : Data) :
---     goMeteredFold xs acc stack body h_wf =
---       .some (xs.foldl (fun a x => step x a) acc,
---              foldTime stepTime step xs acc,
---              foldSpace stepSpace step xs acc) := by
---   induction xs generalizing acc with
---   | nil => simp [foldTime, foldSpace]
---   | cons x xs ih => simp [hbody, ih, foldTime, foldSpace]
-
--- /-- Time cost of running the body `[.cons 0 1]` repeatedly over `xs`, threading `acc`. -/
--- def revFoldTime (xs : List Data) (acc : Data) : ℕ :=
---   foldTime (fun x a => 1 + (Data.l (x :: a.asList)).size)
---            (fun x a => Data.l (x :: a.asList)) xs acc
-
--- /-- Space cost of the same fold: maximum live size across iterations. -/
--- def revFoldSpace (xs : List Data) (acc : Data) : ℕ :=
---   foldSpace (fun x a => 1 + (Data.l (x :: a.asList)).size)
---             (fun x a => Data.l (x :: a.asList)) xs acc
-
--- /-- Combined semantics + time + space for the inner fold of `prog_reverse`. -/
--- lemma goMeteredFold_reverseBody (xs : List Data) (acc : Data) (stack : List Data)
---     (h_wf : WFProg (stack.length + 2) [Operation.cons 0 1]) :
---     goMeteredFold xs acc stack [Operation.cons 0 1] h_wf =
---       .some (xs.foldl (fun a x => Data.l (x :: a.asList)) acc,
---              revFoldTime xs acc, revFoldSpace xs acc) := by
---   exact goMeteredFold_of_step h_wf
---     (fun x a => Data.l (x :: a.asList))
---     (fun x a => 1 + (Data.l (x :: a.asList)).size)
---     (fun x a => 1 + (Data.l (x :: a.asList)).size)
---     (by intro c acc'; simp [meteredEvalOp]) xs acc
-
--- /-- The reverse-body fold reverses the input list, prepended onto the accumulator. -/
--- lemma foldl_reverseBody (xs : List Data) (acc : Data) :
---     xs.foldl (fun a x => Data.l (x :: a.asList)) acc =
---       Data.l (xs.reverse ++ acc.asList) := by
---   induction xs generalizing acc with
---   | nil => cases acc with | l _ => simp [Data.asList]
---   | cons x xs ih => cases acc with | l _ => simp [ih, Data.asList, List.reverse_cons]
-
--- /-- `prog_reverse` reverses its input list, with concrete time and space cost. -/
--- theorem prog_reverse.semantics (xs : List Data) :
---     meteredEvalProg prog_reverse.prog [Data.l xs] prog_reverse.h_wf
---       = .some (Data.l xs.reverse,
---                1 + revFoldTime xs Data.empty,
---                1 + revFoldSpace xs Data.empty) := by
---   have h := goMeteredFold_reverseBody xs Data.empty [Data.empty, Data.l xs]
---     (by simp [WFProg, WFOp])
---   simp [prog_reverse, meteredEvalOp, h, foldl_reverseBody, Data.asList]
-
--- /-- Convenient corollary: `prog_reverse.eval` returns the reversed list. -/
--- theorem prog_reverse.eval_eq (xs : List Data) :
---     prog_reverse.eval [Data.l xs] rfl = .some (Data.l xs.reverse) := by
---   simp [WellFormedProgram.eval, prog_reverse.semantics]
-
--- -- Binary addition
--- def prog_inc : WellFormedProgram := {
---   prog := [
---     .fold 0 1 [
---       .cons 0 2, -- cons the bit to the accumulator
---       .ite 2 [ -- if the new accumulator is nonempty (the bit was 1)
---         .cons 1 2, -- add the carry from the previous bit
---         .empty -- else just put the carry (0 or 1) as the new accumulator
---       ] [
---          .cons 1 2 -- if the new bit is zero, we only get a carry if the previous carry was one
---       ]
---     ]
---     -- TODO
---   ],
---   inputs := 2,
---   h_wf := by sorry
--- }
-
--- def add (x y : List Bool) : List Bool :=
-
---   match prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl with
---   | .some d => d.asList.map (fun b => b == dataTrue)
---   | .none => [] -- this should never happen since the program is total
-
--- theorem prog_add_semantics : ∀ (x y : ℕ),
---     prog_add.eval [DataEncode.encode x, DataEncode.encode y] rfl =
---       .some (DataEncode.encode (x + y)) := by
---   sorry
-
-
--- mutual
---   def WhileFreeOp : Operation → Prop
---     | .while_ _ _ => False
---     | .fold _ _ b => WhileFreeProg b
---     | _           => True
-
---   def WhileFreeProg : Prog → Prop
---     | []         => True
---     | op :: rest => WhileFreeOp op ∧ WhileFreeProg rest
--- end
-
--- theorem whileFree_total (p : WellFormedProgram) (hwf : WhileFreeProg p.prog) : p.Total := by
---   intro data h_len
---   induction h : p.prog generalizing data with
---   | nil =>
---     simp [WellFormedProgram.eval, evalProg, h]
---   | cons op rest ih =>
---     simp [WellFormedProgram.eval, h]
---     cases op with
---     | empty =>
---       unfold evalProg evalOp
---       simp
---       sorry
---     | cons h t => sorry
---     | head i => sorry
---     | tail i => sorry
---     | eq i j => sorry
---     | ite i then_ else_ => sorry
---     | fold l i body => sorry
---     | while_ i body => sorry
-
-
--- -- Now the most important part: If a program is total, and well-formed we can talk about the
--- -- function computed by the program - this is something that was not really possible with my old
--- -- design:
-
--- -- With these at hand, we can define simp lemmas and thus auto-derive semantics
--- -- and maybe even resource requirements of programs:
-
--- -- @[simp]
--- -- theorem evalFold_eq_foldl
--- --     (stack : List Data) (l i : ℕ) (hl : l < stack.length) (hi : i < stack.length)
--- --     (body : Prog) (h : WellFormedTotal body)
--- --     (rest : Prog) :
--- --     evalProg ((.fold l i body) :: rest) stack =
--- --     .some (some (stack ++ [(stack[l].asList.foldl
--- --       (fun (acc : Data) (el : Data) => progFun body h (stack ++ [el, acc]))
--- --       stack[i])])) := by
--- --   sorry
-
-
--- -- ================= Builder monad
--- --
--- -- The problem with writing programs directly is that tape indices are top-relative
--- -- (0 = newest item), so every push shifts all existing indices by 1.
--- --
--- -- The builder monad solves this by working with *bottom-indexed* references internally.
--- -- A `Ref` stores the absolute position of a stack slot counting from the bottom (oldest = 0).
--- -- Bottom-indices are stable: pushing a new item never changes any existing Ref.
--- -- When an Operation is about to be emitted, we convert the stored bottom-index
--- -- to the top-relative index expected by the machine: `currentHeight - 1 - bottomIndex`.
--- --
--- -- The builder additionally **carries a proof of well-formedness** in its state, so that
--- -- `Build.run` returns a `WellFormedProgram` *by construction*, with no exceptions, no
--- -- `Option`, and no post-hoc decidable check.
-
--- /-- A weakening of `WFProg` that holds for the empty program at any `n` (including `0`).
---     Used as the in-flight invariant of the builder, since intermediate states may have
---     `prog = []` while `n_initial = 0`. -/
--- def WFProgRaw : ℕ → Prog → Prop
---   | _, []         => True
---   | n, op :: rest => WFOp n op ∧ WFProgRaw (n + 1) rest
-
--- /-- Snoc a single op (well-formed at the post-state height) onto a `WFProgRaw` program. -/
--- theorem WFProgRaw.append_op :
---     ∀ {n : ℕ} {prog : Prog} {op : Operation},
---       WFProgRaw n prog → WFOp (n + prog.length) op → WFProgRaw n (prog ++ [op])
---   | n, [], op, _, h_op => by
---     refine ⟨?_, trivial⟩
---     show WFOp n op
---     simpa using h_op
---   | n, o :: rest, op, h_p, h_op => by
---     obtain ⟨h_o, h_rest⟩ := h_p
---     refine ⟨h_o, ?_⟩
---     have h_op' : WFOp (n + 1 + rest.length) op := by
---       have heq : n + (o :: rest).length = n + 1 + rest.length := by
---         simp [List.length_cons]; omega
---       rw [heq] at h_op
---       exact h_op
---     exact WFProgRaw.append_op h_rest h_op'
-
--- /-- A `WFProgRaw` program with at least one element on the post-execution stack
---     (i.e. `n_initial + prog.length > 0`) lifts to a full `WFProg`. -/
--- theorem WFProgRaw_to_WFProg :
---     ∀ {n : ℕ} {prog : Prog}, WFProgRaw n prog → n + prog.length ≠ 0 → WFProg n prog
---   | n, [], _, hpos => by simpa using hpos
---   | _, _ :: rest, h_p, _ => by
---     obtain ⟨h_op, h_rest⟩ := h_p
---     refine ⟨h_op, ?_⟩
---     apply WFProgRaw_to_WFProg h_rest
---     simp
-
--- /-- Monad state: the initial stack size, the ops collected so far, and a proof that
---     the collected ops form a well-formed program at that initial stack size. -/
--- structure BuildCtx where
---   n_initial : ℕ
---   prog : Prog := []
---   h_wf : WFProgRaw n_initial prog := by trivial
-
--- /-- The current stack height of a build context. -/
--- @[simp] def BuildCtx.height (c : BuildCtx) : ℕ := c.n_initial + c.prog.length
-
--- /-- The builder monad: a state monad over `BuildCtx`. -/
--- abbrev Build := StateM BuildCtx
-
--- /-- A stable reference to a stack slot.  `val` is the slot's bottom-index (oldest = 0).
---     `bound` is a snapshot of `currentHeight` at the moment the ref was minted; the
---     invariant `val < bound` is what makes the ref usable.  All refs produced by the
---     builder API satisfy `bound ≤ currentHeight` from the moment of mint onwards
---     (since heights only grow). -/
--- structure Ref where
---   val : ℕ
---   bound : ℕ
---   h_lt : val < bound
-
--- /-- Current stack height (= `n_initial + prog.length`). -/
--- def Build.currentHeight : Build ℕ := do
---   let ctx ← get
---   return ctx.height
-
--- /-- Extend a `BuildCtx` by appending one well-formed operation. -/
--- private def BuildCtx.extend (ctx : BuildCtx) (op : Operation) (h_op : WFOp ctx.height op) :
---     BuildCtx :=
---   { n_initial := ctx.n_initial
---     prog := ctx.prog ++ [op]
---     h_wf := WFProgRaw.append_op ctx.h_wf (by simpa [BuildCtx.height] using h_op) }
-
--- @[simp] theorem BuildCtx.extend_n_initial (ctx : BuildCtx) (op : Operation)
---     (h_op : WFOp ctx.height op) : (ctx.extend op h_op).n_initial = ctx.n_initial := rfl
-
--- @[simp] theorem BuildCtx.extend_height (ctx : BuildCtx) (op : Operation)
---     (h_op : WFOp ctx.height op) : (ctx.extend op h_op).height = ctx.height + 1 := by
---   simp [BuildCtx.extend, BuildCtx.height, List.length_append, Nat.add_assoc]
-
--- /-- Obtain a `Ref` to an item that already exists in the initial stack.
---     `j = 0` is the top of the initial stack, `j = n_initial - 1` is the bottom.
---     If `j ≥ n_initial` the resulting `Ref` will be invalid; calls using such a ref will
---     silently fall back to emitting `.empty`. -/
--- def Build.inputRef (j : TapeIndex) : Build Ref := do
---   let ctx ← get
---   let h := ctx.height
---   if hp : ctx.n_initial > 0 then
---     -- val = ctx.n_initial - 1 - j (clamped at 0 for j ≥ n_initial); bound = h ≥ n_initial > 0
---     let v := if j < ctx.n_initial then ctx.n_initial - 1 - j else 0
---     return ⟨v, h, by simp [v, BuildCtx.height]; split <;> sorry⟩
---   else
---     -- No initial inputs: return a sentinel; can't be used since bound > val always fails.
---     return ⟨0, 1, Nat.lt_succ_self _⟩
-
--- -- ── Primitive operations ──────────────────────────────────────────────────────
-
--- /-- Emit an `.empty` operation; returns a `Ref` to the new (empty) item on top. -/
--- def Build.empty : Build Ref := do
---   let ctx ← get
---   let h := ctx.height
---   let h_op : WFOp h .empty := trivial
---   set (ctx.extend .empty h_op)
---   return ⟨h, h + 1, Nat.lt_succ_self _⟩
-
--- /-- Emit `.cons h t`. If either ref's bound exceeds the current height (impossible by
---     API contract), silently emits `.empty` instead so that the WF invariant is preserved. -/
--- def Build.cons (h t : Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hh : h.bound ≤ height then
---     if ht : t.bound ≤ height then
---       have h_hv : h.val < height := Nat.lt_of_lt_of_le h.h_lt hh
---       have h_tv : t.val < height := Nat.lt_of_lt_of_le t.h_lt ht
---       let i := height - 1 - h.val
---       let j := height - 1 - t.val
---       let op : Operation := .cons i j
---       have hi : i < height := by simp [i]; omega
---       have hj : j < height := by simp [j]; omega
---       have h_op : WFOp height op := ⟨hi, hj⟩
---       set (ctx.extend op h_op)
---       return ⟨height, height + 1, Nat.lt_succ_self _⟩
---     else
---       Build.empty
---   else
---     Build.empty
-
--- /-- Emit `.head r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
--- def Build.head (r : Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hr : r.bound ≤ height then
---     have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
---     let i := height - 1 - r.val
---     let op : Operation := .head i
---     have hi : i < height := by simp [i]; omega
---     have h_op : WFOp height op := hi
---     set (ctx.extend op h_op)
---     return ⟨height, height + 1, Nat.lt_succ_self _⟩
---   else
---     Build.empty
-
--- /-- Emit `.tail r`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
--- def Build.tail (r : Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hr : r.bound ≤ height then
---     have h_v : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
---     let i := height - 1 - r.val
---     let op : Operation := .tail i
---     have hi : i < height := by simp [i]; omega
---     have h_op : WFOp height op := hi
---     set (ctx.extend op h_op)
---     return ⟨height, height + 1, Nat.lt_succ_self _⟩
---   else
---     Build.empty
-
--- /-- Emit `.eq r s`; falls back to `.empty` on an out-of-bound ref (impossible by contract). -/
--- def Build.eq (r s : Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hr : r.bound ≤ height then
---     if hs : s.bound ≤ height then
---       have h_rv : r.val < height := Nat.lt_of_lt_of_le r.h_lt hr
---       have h_sv : s.val < height := Nat.lt_of_lt_of_le s.h_lt hs
---       let i := height - 1 - r.val
---       let j := height - 1 - s.val
---       let op : Operation := .eq i j
---       have hi : i < height := by simp [i]; omega
---       have hj : j < height := by simp [j]; omega
---       have h_op : WFOp height op := ⟨hi, hj⟩
---       set (ctx.extend op h_op)
---       return ⟨height, height + 1, Nat.lt_succ_self _⟩
---     else
---       Build.empty
---   else
---     Build.empty
-
--- -- ── Combinators ───────────────────────────────────────────────────────────────
-
--- /-- Run a sub-program builder in a fresh context whose initial stack height is `subN`,
---     returning the compiled `Prog` together with a `WFProg subN` proof.
---     The caller must supply `h_pos : subN > 0` so that the empty-`prog` case is handled.
---     `extraRefs` are the `Ref`s for the `subN - h` items prepended on top of the outer
---     stack (e.g. `[child, acc]` for `fold`). -/
--- private def Build.subProg (subN : ℕ) (h_pos : subN > 0)
---     (extraRefs : Array Ref) (inner : Array Ref → Build Ref) :
---     Build { p : Prog // WFProg subN p } := do
---   let init : BuildCtx := { n_initial := subN, prog := [], h_wf := trivial }
---   let (_, subCtx) := StateT.run (inner extraRefs) init
---   -- Trust that the smart constructors do not change `n_initial`; if some user code
---   -- did, we fall back to a trivial WF program of length 1.
---   if h_eq : subCtx.n_initial = subN then
---     have h_wf_raw : WFProgRaw subN subCtx.prog := h_eq ▸ subCtx.h_wf
---     have h_pos' : subN + subCtx.prog.length ≠ 0 := by omega
---     return ⟨subCtx.prog, WFProgRaw_to_WFProg h_wf_raw h_pos'⟩
---   else
---     have h_wf : WFProg subN [Operation.empty] := by
---       refine ⟨trivial, ?_⟩
---       show subN + 1 ≠ 0
---       omega
---     return ⟨[Operation.empty], h_wf⟩
-
--- /-- Build the bottom-index `Ref`s for the `extra` items prepended on top of the outer
---     stack `h` when entering a sub-builder.  Returns refs in order
---     `[topmost prepended, …, bottommost prepended]`. -/
--- private def Build.extraRefs (h extra : ℕ) : Array Ref :=
---   (Array.range extra).map fun k =>
---     let v := h + extra - 1 - k
---     have h_lt : v < h + extra := by simp [v]; omega
---     ⟨v, h + extra, h_lt⟩
-
--- /-- Branch on `cond`: if `cond == dataTrue` run `then_`, else run `else_`.
---     Both branches see the same outer stack.  Each branch must return the `Ref` it
---     wants as the result. -/
--- def Build.ite (cond : Ref) (then_ else_ : Build Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hc : cond.bound ≤ height then
---     have h_v : cond.val < height := Nat.lt_of_lt_of_le cond.h_lt hc
---     let i := height - 1 - cond.val
---     have hi : i < height := by simp [i]; omega
---     have h_pos : height > 0 := by omega
---     let ⟨thenProg, h_then⟩ ← Build.subProg height h_pos (Build.extraRefs height 0)
---          (fun _ => then_)
---     let ⟨elseProg, h_else⟩ ← Build.subProg height h_pos (Build.extraRefs height 0)
---          (fun _ => else_)
---     let op : Operation := .ite i thenProg elseProg
---     have h_op : WFOp height op := ⟨hi, h_then, h_else⟩
---     set (ctx.extend op h_op)
---     return ⟨height, height + 1, Nat.lt_succ_self _⟩
---   else
---     Build.empty
-
--- /-- Fold over the children of `list_`, starting with accumulator `acc_`, using `body`.
---     `body` receives `(child, acc)` as `Ref`s; outer `Ref`s remain valid unchanged. -/
--- def Build.fold (list_ acc_ : Ref) (body : Ref → Ref → Build Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hl : list_.bound ≤ height then
---     if ha : acc_.bound ≤ height then
---       have h_lv : list_.val < height := Nat.lt_of_lt_of_le list_.h_lt hl
---       have h_av : acc_.val < height := Nat.lt_of_lt_of_le acc_.h_lt ha
---       let li := height - 1 - list_.val
---       let ai := height - 1 - acc_.val
---       have hli : li < height := by simp [li]; omega
---       have hai : ai < height := by simp [ai]; omega
---       have h_pos : height + 2 > 0 := by omega
---       let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 2) h_pos
---         (Build.extraRefs height 2) (fun extra => body extra[0]! extra[1]!)
---       let op : Operation := .fold li ai bodyProg
---       have h_op : WFOp height op := ⟨hli, hai, h_body⟩
---       set (ctx.extend op h_op)
---       return ⟨height, height + 1, Nat.lt_succ_self _⟩
---     else
---       Build.empty
---   else
---     Build.empty
-
--- /-- While `cond_` is nonempty, run `body`.  `body` receives one `Ref` for the current
---     accumulator (= the current value of `cond_` on top of the outer stack). -/
--- def Build.while_ (cond_ : Ref) (body : Ref → Build Ref) : Build Ref := do
---   let ctx ← get
---   let height := ctx.height
---   if hc : cond_.bound ≤ height then
---     have h_v : cond_.val < height := Nat.lt_of_lt_of_le cond_.h_lt hc
---     let i := height - 1 - cond_.val
---     have hi : i < height := by simp [i]; omega
---     have h_pos : height + 1 > 0 := by omega
---     let ⟨bodyProg, h_body⟩ ← Build.subProg (height + 1) h_pos
---       (Build.extraRefs height 1) (fun extra => body extra[0]!)
---     let op : Operation := .while_ i bodyProg
---     have h_op : WFOp height op := ⟨hi, h_body⟩
---     set (ctx.extend op h_op)
---     return ⟨height, height + 1, Nat.lt_succ_self _⟩
---   else
---     Build.empty
-
--- -- ── Running the builder ───────────────────────────────────────────────────────
-
--- /-- Run a builder that starts with `n_initial` pre-existing stack items, producing a
---     `WellFormedProgram` *by construction*.  If the user's builder produces no ops and
---     `n_initial = 0`, an `.empty` op is appended so that the result is always a
---     syntactically valid `WFProg` (which requires the post-execution stack to be
---     non-empty). -/
--- def Build.run (n_initial : ℕ) (b : Build Ref) : WellFormedProgram :=
---   let init : BuildCtx := { n_initial, prog := [], h_wf := trivial }
---   let (_, ctx) := StateT.run b init
---   if h_pos : ctx.height ≠ 0 then
---     ⟨ctx.prog, ctx.n_initial, WFProgRaw_to_WFProg ctx.h_wf (by simpa [BuildCtx.height]
---      using h_pos)⟩
---   else
---     -- height = 0 ⇒ n_initial = 0 ∧ prog = []; emit a sentinel `.empty` to satisfy WFProg.
---     let extended := ctx.extend .empty trivial
---     have h_pos' : extended.n_initial + extended.prog.length ≠ 0 := by
---       simp [extended, BuildCtx.extend, List.length_append]
---     ⟨extended.prog, extended.n_initial, WFProgRaw_to_WFProg extended.h_wf h_pos'⟩
-
--- /-- Convenience: `Build.run` for programs that take no initial input. -/
--- def Build.runFresh (b : Build Ref) : WellFormedProgram := Build.run 0 b
-
-
--- def funFalse : WellFormedProgram := Build.runFresh do
---   Build.empty
-
--- def funTrue : WellFormedProgram := Build.runFresh do
---   let a ← Build.empty
---   Build.cons a a
-
--- #eval funFalse.prog
--- #eval funTrue.prog
-
-end RoseTreeMachine
-
-end Turing

From 85518e63634bbec88ae0a4800d1595869153e300 Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Sat, 23 May 2026 06:49:28 -0400
Subject: [PATCH 075/106] doc: link to Mathlib AI policy in CONTRIBUTING.md
 (#593)

For some time we have followed the Mathlib guideline of disclosing AI
usage in PR descriptions, but this was not documented in
`CONTRIBUTING.md`. This PR adds a mention of this and links to the new
Mathlib AI policy.

---------

Co-authored-by: Fabrizio Montesi <famontesi@gmail.com>
---
 CONTRIBUTING.md | 17 ++++++-----------
 1 file changed, 6 insertions(+), 11 deletions(-)

diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index b9b6b80687..a2f8f88415 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -2,6 +2,7 @@
 
 - [Contributing to CSLib](#contributing-to-cslib)
 - [Contribution model](#contribution-model)
+- [The role of AI](#the-role-of-ai)
 - [Style and documentation](#style-and-documentation)
   - [Variable names](#variable-names)
   - [Proof style and golfing :golf:](#proof-style-and-golfing-golf)
@@ -38,8 +39,6 @@
       - [Back ends for Boole](#back-ends-for-boole)
       - [Implementing verification paradigms](#implementing-verification-paradigms)
       - [Lean automation](#lean-automation)
-      - [The role of AI](#the-role-of-ai)
-
 
 # Contributing to CSLib
 
@@ -57,6 +56,11 @@ If you are adding something new to CSLib and are in doubt about it, you are very
 
 If you are unfamiliar with CSLib as a whole and want to understand how to get started, please see [Getting started](#getting-started).
 
+# The role of AI
+
+CSLib in general follows the Mathlib policy on [use of AI](https://leanprover-community.github.io/contribute/index.html#use-of-ai). In particular, take note of:
+> If you use artificial intelligence [...] please explain this in the PR description. Explain which tool(s) you used and how you used it. This provides useful context for reviewers: tools make different mistakes than humans, so knowing this makes it easier to spot common errors.
+
 # Style and documentation
 
 We generally follow the [mathlib style for coding and documentation](https://leanprover-community.github.io/contribute/style.html), so please read that as well. Some things worth mentioning and conventions specific to CSLib are explained next.
@@ -322,12 +326,3 @@ The formal methods community has a wide range of verification techniques that co
 Since Boole back ends reduce correctness questions to Lean conjectures, automation is central.
 
 We already rely on key techniques such as `grind` and `lean-smt`. Additional work on automation for conjectures generated from Boole is welcome, including domain-specific automation that remains performant and readable.
-
-#### The role of AI
-
-There are two primary areas where generative AI can help:
-
-- generating/refining specifications (at the front-end or Boole level)
-- helping to prove Lean conjectures
-
-Other creative uses of AI are welcome, but contributions should remain reviewable and maintainable.

From 107a51dd89f29c62c99d16b4c38d23d3b38bdc28 Mon Sep 17 00:00:00 2001
From: "mathlib-nightly-testing[bot]"
 <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com>
Date: Sun, 24 May 2026 02:35:36 -0400
Subject: [PATCH 076/106] chore: Bump `mathlib` dependency to d8de6b6 (#552)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Bump `mathlib` dependency to
[d8de6b6](https://github.com/leanprover-community/mathlib4/commit/d8de6b61f073daf518577b643724875545b98e89):
feat(Combinatorics/SimpleGraph/Coloring/VertexColoring):
`chromaticNumber ⊤` and other small lemmas (#38424) (2026-05-23)
Previously at:
[6cf3ab1](https://github.com/leanprover-community/mathlib4/commit/6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5):
chore: make argument in `zero_le`/`one_le` implicit (#38148)
(2026-04-29)

_This PR was last updated on 2026-05-23 by [this workflow
run](https://github.com/leanprover/cslib/actions/runs/26342584154). It
is an automated bump using
[downstream-reports/open-bump-pr](https://github.com/leanprover-community/downstream-reports)_

---------

Co-authored-by: mathlib-nightly-testing[bot] <mathlib-nightly-testing[bot]@users.noreply.github.com>
Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
---
 .../Languages/ExampleEventuallyZero.lean      |  30 +--
 .../Languages/OmegaRegularLanguage.lean       |   8 +-
 .../Machines/SingleTapeTuring/Basic.lean      |  54 ++---
 Cslib/Computability/URM/StraightLine.lean     |  24 +--
 Cslib/Foundations/Data/BiTape.lean            |  42 ++--
 Cslib/Foundations/Data/HasFresh.lean          |   2 +-
 Cslib/Foundations/Data/Relation.lean          |  22 +-
 Cslib/Foundations/Data/StackTape.lean         |   4 +-
 .../Foundations/Logic/LogicalEquivalence.lean |   2 +-
 Cslib/Foundations/Semantics/LTS/Notation.lean |   4 +-
 .../LocallyNameless/Context.lean              |   6 +-
 .../LocallyNameless/Fsub/Basic.lean           |  18 +-
 .../LocallyNameless/Fsub/Opening.lean         | 196 +++++++++---------
 .../LocallyNameless/Fsub/Reduction.lean       |   6 +-
 .../LocallyNameless/Fsub/Safety.lean          |  14 +-
 .../LocallyNameless/Fsub/Subtype.lean         |   4 +-
 .../LocallyNameless/Fsub/Typing.lean          |  20 +-
 .../LocallyNameless/Fsub/WellFormed.lean      |  10 +-
 .../LocallyNameless/Stlc/StrongNorm.lean      |  18 +-
 .../LocallyNameless/Untyped/MultiSubst.lean   |   6 +-
 Cslib/Logics/HML/LogicalEquivalence.lean      |   2 +-
 Cslib/Logics/LinearLogic/CLL/Basic.lean       |  42 ++--
 .../LinearLogic/CLL/PhaseSemantics/Basic.lean |  32 +--
 .../Propositional/NaturalDeduction/Basic.lean |  30 +--
 CslibTests/CLL.lean                           |  42 ++--
 lake-manifest.json                            |  10 +-
 lakefile.toml                                 |   2 +-
 27 files changed, 324 insertions(+), 326 deletions(-)

diff --git a/Cslib/Computability/Languages/ExampleEventuallyZero.lean b/Cslib/Computability/Languages/ExampleEventuallyZero.lean
index 7e03b8cfd5..dc777d9a8b 100644
--- a/Cslib/Computability/Languages/ExampleEventuallyZero.lean
+++ b/Cslib/Computability/Languages/ExampleEventuallyZero.lean
@@ -26,22 +26,22 @@ namespace Cslib.ωLanguage.Example
 
 open scoped LTS NA
 
-/-- A sequence `xs` is in `eventually_zero` iff `xs k = 0` for all large `k`. -/
+/-- A sequence `xs` is in `eventuallyZero` iff `xs k = 0` for all large `k`. -/
 @[scoped grind =]
-def eventually_zero : ωLanguage (Fin 2) :=
+def eventuallyZero : ωLanguage (Fin 2) :=
   { xs : ωSequence (Fin 2) | ∀ᶠ k in atTop, xs k = 0 }
 
-/-- `eventually_zero` is accepted by a 2-state nondeterministic Buchi automaton. -/
+/-- `eventuallyZero` is accepted by a 2-state nondeterministic Buchi automaton. -/
 @[scoped grind =]
-def eventually_zero_na : NA.Buchi (Fin 2) (Fin 2) where
+def eventuallyZeroNa : NA.Buchi (Fin 2) (Fin 2) where
   -- Once state 1 is reached, only symbol 0 is accepted and the next state is still 1
   Tr s x s' := s = 1 → x = 0 ∧ s' = 1
   start := {0}
   accept := {1}
 
-theorem eventually_zero_accepted_by_na_buchi :
-    language eventually_zero_na = eventually_zero := by
-  ext xs; unfold eventually_zero_na; constructor
+theorem eventuallyZero_accepted_by_na_buchi :
+    language eventuallyZeroNa = eventuallyZero := by
+  ext xs; unfold eventuallyZeroNa; constructor
   · rintro ⟨ss, h_run, h_acc⟩
     obtain ⟨m, h_m⟩ := Frequently.exists h_acc
     apply eventually_atTop.mpr
@@ -61,27 +61,27 @@ theorem eventually_zero_accepted_by_na_buchi :
       grind
 
 private lemma extend_by_zero (u : List (Fin 2)) :
-    u ++ω const 0 ∈ eventually_zero := by
+    u ++ω const 0 ∈ eventuallyZero := by
   apply eventually_atTop.mpr
   use u.length
   grind [get_append_right']
 
 private lemma extend_by_one (u : List (Fin 2)) :
-    ∃ v, 1 ∈ v ∧ u ++ v ++ω const 0 ∈ eventually_zero := by
+    ∃ v, 1 ∈ v ∧ u ++ v ++ω const 0 ∈ eventuallyZero := by
   use [1]
   grind [extend_by_zero]
 
-private lemma extend_by_hyp {l : Language (Fin 2)} (h : l↗ω = eventually_zero)
+private lemma extend_by_hyp {l : Language (Fin 2)} (h : l↗ω = eventuallyZero)
     (u : List (Fin 2)) : ∃ v, 1 ∈ v ∧ u ++ v ∈ l := by
   obtain ⟨v, _, h_pfx⟩ := extend_by_one u
   rw [← h] at h_pfx
   have := frequently_atTop.mp h_pfx (u ++ v).length
   grind [extract_append_zero_right]
 
-private noncomputable def oneSegs {l : Language (Fin 2)} (h : l↗ω = eventually_zero) (n : ℕ) :=
+private noncomputable def oneSegs {l : Language (Fin 2)} (h : l↗ω = eventuallyZero) (n : ℕ) :=
   Classical.choose <| extend_by_hyp h (List.ofFn (fun k : Fin n ↦ oneSegs h k)).flatten
 
-private lemma oneSegs_lemma {l : Language (Fin 2)} (h : l↗ω = eventually_zero) (n : ℕ) :
+private lemma oneSegs_lemma {l : Language (Fin 2)} (h : l↗ω = eventuallyZero) (n : ℕ) :
     1 ∈ oneSegs h n ∧ (List.ofFn (fun k : Fin (n + 1) ↦ oneSegs h k)).flatten ∈ l := by
   let P u v := 1 ∈ v ∧ u ++ v ∈ l
   have : P ((List.ofFn (fun k : Fin n ↦ oneSegs h k)).flatten) (oneSegs h n) := by
@@ -92,13 +92,13 @@ private lemma oneSegs_lemma {l : Language (Fin 2)} (h : l↗ω = eventually_zero
   rw [List.ofFn_succ_last]
   simpa
 
-theorem eventually_zero_not_omegaLim :
-    ¬ ∃ l : Language (Fin 2), l↗ω = eventually_zero := by
+theorem eventuallyZero_not_omegaLim :
+    ¬ ∃ l : Language (Fin 2), l↗ω = eventuallyZero := by
   rintro ⟨l, h⟩
   let ls := ωSequence.mk (oneSegs h)
   have h_segs := oneSegs_lemma h
   have h_pos : ∀ k, (ls k).length > 0 := by grind
-  have h_ev : ls.flatten ∈ eventually_zero := by
+  have h_ev : ls.flatten ∈ eventuallyZero := by
     rw [← h, mem_omegaLim, frequently_iff_strictMono]
     use (fun k ↦ ls.cumLen (k + 1))
     constructor
diff --git a/Cslib/Computability/Languages/OmegaRegularLanguage.lean b/Cslib/Computability/Languages/OmegaRegularLanguage.lean
index 1657c89e21..f3e799c63f 100644
--- a/Cslib/Computability/Languages/OmegaRegularLanguage.lean
+++ b/Cslib/Computability/Languages/OmegaRegularLanguage.lean
@@ -61,11 +61,11 @@ where the automaton is not even required to be finite-state. -/
 theorem IsRegular.not_da_buchi :
   ∃ (Symbol : Type) (p : ωLanguage Symbol), p.IsRegular ∧
     ¬ ∃ (State : Type) (da : DA.Buchi State Symbol), language da = p := by
-  refine ⟨Fin 2, Example.eventually_zero, ?_, ?_⟩
-  · use Fin 2, inferInstance, Example.eventually_zero_na,
-      Example.eventually_zero_accepted_by_na_buchi
+  refine ⟨Fin 2, Example.eventuallyZero, ?_, ?_⟩
+  · use Fin 2, inferInstance, Example.eventuallyZeroNa,
+      Example.eventuallyZero_accepted_by_na_buchi
   · rintro ⟨State, ⟨da, acc⟩, _⟩
-    have := Example.eventually_zero_not_omegaLim
+    have := Example.eventuallyZero_not_omegaLim
     grind [DA.buchi_eq_finAcc_omegaLim]
 
 /-- The ω-limit of a regular language is ω-regular. -/
diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
index 477ab60b14..b956b62869 100644
--- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
@@ -160,27 +160,27 @@ def haltCfg (tm : SingleTapeTM Symbol) (s : List Symbol) : tm.Cfg := ⟨none, Bi
 /--
 The space used by a configuration is the space used by its tape.
 -/
-def Cfg.space_used (tm : SingleTapeTM Symbol) (cfg : tm.Cfg) : ℕ := cfg.BiTape.space_used
+def Cfg.spaceUsed (tm : SingleTapeTM Symbol) (cfg : tm.Cfg) : ℕ := cfg.BiTape.spaceUsed
 
 @[scoped grind =]
-lemma Cfg.space_used_initCfg (tm : SingleTapeTM Symbol) (s : List Symbol) :
-    (tm.initCfg s).space_used = max 1 s.length := BiTape.space_used_mk₁ s
+lemma Cfg.spaceUsed_initCfg (tm : SingleTapeTM Symbol) (s : List Symbol) :
+    (tm.initCfg s).spaceUsed = max 1 s.length := BiTape.spaceUsed_mk₁ s
 
 @[scoped grind =]
-lemma Cfg.space_used_haltCfg (tm : SingleTapeTM Symbol) (s : List Symbol) :
-    (tm.haltCfg s).space_used = max 1 s.length := BiTape.space_used_mk₁ s
+lemma Cfg.spaceUsed_haltCfg (tm : SingleTapeTM Symbol) (s : List Symbol) :
+    (tm.haltCfg s).spaceUsed = max 1 s.length := BiTape.spaceUsed_mk₁ s
 
-lemma Cfg.space_used_step {tm : SingleTapeTM Symbol} (cfg cfg' : tm.Cfg)
-    (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + 1 := by
+lemma Cfg.spaceUsed_step {tm : SingleTapeTM Symbol} (cfg cfg' : tm.Cfg)
+    (hstep : tm.step cfg = some cfg') : cfg'.spaceUsed ≤ cfg.spaceUsed + 1 := by
   obtain ⟨_ | q, tape⟩ := cfg
   · simp [step] at hstep
   · simp only [step] at hstep
     generalize hM : tm.tr q tape.head = result at hstep
     obtain ⟨⟨wr, dir⟩, q''⟩ := result
     cases hstep; cases dir with
-    | none => simp [Cfg.space_used, BiTape.optionMove, BiTape.space_used_write, hM]
-    | some d => simpa [Cfg.space_used, BiTape.optionMove, BiTape.space_used_write, hM] using
-        BiTape.space_used_move (tape.write wr) d
+    | none => simp [Cfg.spaceUsed, BiTape.optionMove, BiTape.spaceUsed_write, hM]
+    | some d => simpa [Cfg.spaceUsed, BiTape.optionMove, BiTape.spaceUsed_write, hM] using
+        BiTape.spaceUsed_move (tape.write wr) d
 
 end Cfg
 
@@ -215,8 +215,8 @@ lemma output_length_le_input_length_add_time (tm : SingleTapeTM Symbol) (l l' :
     (h : tm.OutputsWithinTime l l' t) :
     l'.length ≤ max 1 l.length + t := by
   obtain ⟨steps, hsteps_le, hevals⟩ := h
-  grind [hevals.apply_le_apply_add (Cfg.space_used tm)
-      fun a b hstep ↦ Cfg.space_used_step a b (Option.mem_def.mp hstep)]
+  grind [hevals.apply_le_apply_add (Cfg.spaceUsed tm)
+      fun a b hstep ↦ Cfg.spaceUsed_step a b (Option.mem_def.mp hstep)]
 
 section Computers
 
@@ -392,15 +392,15 @@ structure TimeComputable (f : List Symbol → List Symbol) where
   /-- the underlying bundled SingleTapeTM -/
   tm : SingleTapeTM Symbol
   /-- a bound on runtime -/
-  time_bound : ℕ → ℕ
-  /-- proof this machine outputs `f` in at most `time_bound(input.length)` steps -/
-  outputsFunInTime (a) : tm.OutputsWithinTime a (f a) (time_bound a.length)
+  timeBound : ℕ → ℕ
+  /-- proof this machine outputs `f` in at most `timeBound(input.length)` steps -/
+  outputsFunInTime (a) : tm.OutputsWithinTime a (f a) (timeBound a.length)
 
 
 /-- The identity map on Symbol is computable in constant time. -/
 def TimeComputable.id : TimeComputable (Symbol := Symbol) id where
   tm := idComputer
-  time_bound _ := 1
+  timeBound _ := 1
   outputsFunInTime _ := ⟨1, le_rfl, RelatesInSteps.single rfl⟩
 
 /--
@@ -419,36 +419,36 @@ then the time bound for the second machine still holds for that shorter input to
 -/
 def TimeComputable.comp {f g : List Symbol → List Symbol}
     (hf : TimeComputable f) (hg : TimeComputable g)
-    (h_mono : Monotone hg.time_bound) :
+    (h_mono : Monotone hg.timeBound) :
     (TimeComputable (g ∘ f)) where
   tm := compComputer hf.tm hg.tm
   -- perhaps it would be good to track the blow up separately?
-  time_bound l := (hf.time_bound l) + hg.time_bound (max 1 l + hf.time_bound l)
+  timeBound l := (hf.timeBound l) + hg.timeBound (max 1 l + hf.timeBound l)
   outputsFunInTime a := by
     have hf_outputsFun := hf.outputsFunInTime a
     have hg_outputsFun := hg.outputsFunInTime (f a)
     simp only [OutputsWithinTime, initCfg, compComputer_q₀_eq, Function.comp_apply,
       haltCfg] at hg_outputsFun hf_outputsFun ⊢
-    -- The computer reduces a to f a in time hf.time_bound a.length
+    -- The computer reduces a to f a in time hf.timeBound a.length
     have h_a_reducesTo_f_a :
         RelatesWithinSteps (compComputer hf.tm hg.tm).TransitionRelation
           (initialCfg hf.tm hg.tm a)
           (intermediateCfg hf.tm hg.tm (f a))
-          (hf.time_bound a.length) :=
+          (hf.timeBound a.length) :=
       comp_left_relatesWithinSteps hf.tm hg.tm a (f a)
-        (hf.time_bound a.length) hf_outputsFun
-    -- The computer reduces f a to g (f a) in time hg.time_bound (f a).length
+        (hf.timeBound a.length) hf_outputsFun
+    -- The computer reduces f a to g (f a) in time hg.timeBound (f a).length
     have h_f_a_reducesTo_g_f_a :
         RelatesWithinSteps (compComputer hf.tm hg.tm).TransitionRelation
           (intermediateCfg hf.tm hg.tm (f a))
           (finalCfg hf.tm hg.tm (g (f a)))
-          (hg.time_bound (f a).length) :=
+          (hg.timeBound (f a).length) :=
       comp_right_relatesWithinSteps hf.tm hg.tm (f a) (g (f a))
-        (hg.time_bound (f a).length) hg_outputsFun
+        (hg.timeBound (f a).length) hg_outputsFun
     -- Therefore, the computer reduces a to g (f a) in the sum of those times.
     have h_a_reducesTo_g_f_a := RelatesWithinSteps.trans h_a_reducesTo_f_a h_f_a_reducesTo_g_f_a
     apply RelatesWithinSteps.of_le h_a_reducesTo_g_f_a
-    refine Nat.add_le_add_left ?_ (hf.time_bound a.length)
+    refine Nat.add_le_add_left ?_ (hf.timeBound a.length)
     · apply h_mono
       -- Use the lemma about output length being bounded by input length + time
       exact output_length_le_input_length_add_time hf.tm _ _ _ (hf.outputsFunInTime a)
@@ -478,7 +478,7 @@ structure PolyTimeComputable (f : List Symbol → List Symbol) extends TimeCompu
   /-- a polynomial time bound -/
   poly : Polynomial ℕ
   /-- proof that this machine outputs `f` in at most `time(input.length)` steps -/
-  bounds : ∀ n, time_bound n ≤ poly.eval n
+  bounds : ∀ n, timeBound n ≤ poly.eval n
 
 /-- A proof that the identity map on Symbol is computable in polytime. -/
 noncomputable def PolyTimeComputable.id : PolyTimeComputable (Symbol := Symbol) id where
@@ -493,7 +493,7 @@ A proof that the composition of two polytime computable functions is polytime co
 -/
 noncomputable def PolyTimeComputable.comp {f g : List Symbol → List Symbol}
     (hf : PolyTimeComputable f) (hg : PolyTimeComputable g)
-    (h_mono : Monotone hg.time_bound) :
+    (h_mono : Monotone hg.timeBound) :
     PolyTimeComputable (g ∘ f) where
   toTimeComputable := TimeComputable.comp hf.toTimeComputable hg.toTimeComputable h_mono
   poly := hf.poly + hg.poly.comp (1 + X + hf.poly)
diff --git a/Cslib/Computability/URM/StraightLine.lean b/Cslib/Computability/URM/StraightLine.lean
index bde52823e9..750a8c51da 100644
--- a/Cslib/Computability/URM/StraightLine.lean
+++ b/Cslib/Computability/URM/StraightLine.lean
@@ -20,7 +20,7 @@ they always halt exactly at their length.
 ## Main results
 
 - `straight_line_halts`: straight-line programs always halt
-- `straightLine_finalState`: final state after running a straight-line program
+- `straightLinefinalState`: final state after running a straight-line program
 -/
 
 @[expose] public section
@@ -100,27 +100,27 @@ theorem straight_line_halts {p : Program} (hsl : p.IsStraightLine) (inputs : Lis
 
 /-- The halting state for a straight-line program starting from registers r.
 Wraps Classical.choose to hide it from the API. -/
-noncomputable def straightLine_finalState {p : Program}
+noncomputable def straightLinefinalState {p : Program}
     (hsl : p.IsStraightLine) (r : Regs) : State :=
   Classical.choose (straight_line_halts_from_regs hsl r)
 
-/-- Specification: the state from straightLine_finalState satisfies Steps, isHalted,
+/-- Specification: the state from straightLinefinalState satisfies Steps, isHalted,
 and has pc = p.length. -/
-theorem straightLine_finalState_spec {p : Program} (hsl : p.IsStraightLine) (r : Regs) :
-    let s := straightLine_finalState hsl r
+theorem straightLinefinalState_spec {p : Program} (hsl : p.IsStraightLine) (r : Regs) :
+    let s := straightLinefinalState hsl r
     Steps p ⟨0, r⟩ s ∧ s.isHalted p ∧ s.pc = p.length :=
   Classical.choose_spec (straight_line_halts_from_regs hsl r)
 
 /-- The final registers after running a straight-line program from given starting registers. -/
-noncomputable def straightLine_finalRegs {p : Program} (hsl : p.IsStraightLine) (r : Regs) : Regs :=
-  (straightLine_finalState hsl r).regs
+noncomputable def straightLineFinalRegs {p : Program} (hsl : p.IsStraightLine) (r : Regs) : Regs :=
+  (straightLinefinalState hsl r).regs
 
-/-- For a straight-line program, s.regs equals straightLine_finalRegs if halted from r. -/
-theorem straightLine_finalRegs_eq_of_halted {p : Program} (hsl : p.IsStraightLine)
+/-- For a straight-line program, s.regs equals straightLineFinalRegs if halted from r. -/
+theorem straightLineFinalRegs_eq_of_halted {p : Program} (hsl : p.IsStraightLine)
     (r : Regs) (s : State) (hsteps : Steps p ⟨0, r⟩ s) (hhalted : s.isHalted p) :
-    s.regs = straightLine_finalRegs hsl r :=
-  Steps.eq_of_halts hsteps hhalted (straightLine_finalState_spec hsl r).1
-    (straightLine_finalState_spec hsl r).2.1 ▸ rfl
+    s.regs = straightLineFinalRegs hsl r :=
+  Steps.eq_of_halts hsteps hhalted (straightLinefinalState_spec hsl r).1
+    (straightLinefinalState_spec hsl r).2.1 ▸ rfl
 
 /-- In a straight-line program, we can characterize the state at any intermediate pc.
 This gives us the state after executing instructions 0..pc-1. -/
diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index ba71605564..e61272d57d 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -33,7 +33,7 @@ will not collide.
 * `BiTape`: A tape with a head symbol and left/right contents stored as `StackTape`
 * `BiTape.move`: Move the tape head left or right
 * `BiTape.write`: Write a symbol at the current head position
-* `BiTape.space_used`: The space used by the tape
+* `BiTape.spaceUsed`: The space used by the tape
 -/
 
 @[expose] public section
@@ -76,28 +76,28 @@ with the head under the first element of the list if it exists.
 def mk₁ (l : List Symbol) : BiTape Symbol :=
   match l with
   | [] => ∅
-  | h :: t => { head := some h, left := ∅, right := StackTape.map_some t }
+  | h :: t => { head := some h, left := ∅, right := StackTape.mapSome t }
 
 section Move
 
 /--
 Move the head left by shifting the left StackTape under the head.
 -/
-def move_left (t : BiTape Symbol) : BiTape Symbol :=
+def moveLeft (t : BiTape Symbol) : BiTape Symbol :=
   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
 /--
 Move the head right by shifting the right StackTape under the head.
 -/
-def move_right (t : BiTape Symbol) : BiTape Symbol :=
+def moveRight (t : BiTape Symbol) : BiTape Symbol :=
   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
 
 /--
 Move the head to the left or right, shifting the tape underneath it.
 -/
 def move (t : BiTape Symbol) : Dir → BiTape Symbol
-  | .left => t.move_left
-  | .right => t.move_right
+  | .left => t.moveLeft
+  | .right => t.moveRight
 
 /--
 Optionally perform a `move`, or do nothing if `none`.
@@ -107,12 +107,12 @@ def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
   | t, some d => t.move d
 
 @[simp]
-lemma move_left_move_right (t : BiTape Symbol) : t.move_left.move_right = t := by
-  simp [move_right, move_left]
+lemma moveLeft_moveRight (t : BiTape Symbol) : t.moveLeft.moveRight = t := by
+  simp [moveRight, moveLeft]
 
 @[simp]
-lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := by
-  simp [move_left, move_right]
+lemma moveRight_moveLeft (t : BiTape Symbol) : t.moveRight.moveLeft = t := by
+  simp [moveLeft, moveRight]
 
 end Move
 
@@ -126,22 +126,22 @@ The space used by a `BiTape` is the number of symbols
 between and including the head, and leftmost and rightmost non-blank symbols on the `BiTape`.
 -/
 @[scoped grind]
-def space_used (t : BiTape Symbol) : ℕ := 1 + t.left.length + t.right.length
+def spaceUsed (t : BiTape Symbol) : ℕ := 1 + t.left.length + t.right.length
 
 @[simp, grind =]
-lemma space_used_write (t : BiTape Symbol) (a : Option Symbol) :
-    (t.write a).space_used = t.space_used := by rfl
+lemma spaceUsed_write (t : BiTape Symbol) (a : Option Symbol) :
+    (t.write a).spaceUsed = t.spaceUsed := by rfl
 
-lemma space_used_mk₁ (l : List Symbol) :
-    (mk₁ l).space_used = max 1 l.length := by
+lemma spaceUsed_mk₁ (l : List Symbol) :
+    (mk₁ l).spaceUsed = max 1 l.length := by
   cases l with
-  | nil => simp [mk₁, space_used, nil, StackTape.length_nil]
-  | cons h t => simp [mk₁, space_used, StackTape.length_nil, StackTape.length_map_some]; omega
+  | nil => simp [mk₁, spaceUsed, nil, StackTape.length_nil]
+  | cons h t => simp [mk₁, spaceUsed, StackTape.length_nil, StackTape.length_mapSome]; omega
 
-lemma space_used_move (t : BiTape Symbol) (d : Dir) :
-    (t.move d).space_used ≤ t.space_used + 1 := by
-  cases d <;> grind [move_left, move_right, move,
-    space_used, StackTape.length_tail_le, StackTape.length_cons_le]
+lemma spaceUsed_move (t : BiTape Symbol) (d : Dir) :
+    (t.move d).spaceUsed ≤ t.spaceUsed + 1 := by
+  cases d <;> grind [moveLeft, moveRight, move,
+    spaceUsed, StackTape.length_tail_le, StackTape.length_cons_le]
 
 end BiTape
 
diff --git a/Cslib/Foundations/Data/HasFresh.lean b/Cslib/Foundations/Data/HasFresh.lean
index 689fe0a267..6c095a334d 100644
--- a/Cslib/Foundations/Data/HasFresh.lean
+++ b/Cslib/Foundations/Data/HasFresh.lean
@@ -134,7 +134,7 @@ instance HasFresh.to_infinite (α : Type u) [HasFresh α] : Infinite α := by
 
 /-- All infinite types have an associated (at least noncomputable) fresh function.
 This, in conjunction with `HasFresh.to_infinite`, characterizes `HasFresh`. -/
-noncomputable instance HasFresh.of_infinite (α : Type u) [Infinite α] : HasFresh α where
+noncomputable instance (α : Type u) [Infinite α] : HasFresh α where
   fresh s := Infinite.exists_notMem_finset s |>.choose
   fresh_notMem s := by grind
 
diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index 29635bee64..4ff14dfb03 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -294,21 +294,19 @@ theorem ChurchRosser.normal_eq (cr : ChurchRosser r) (nx : Normal r x) (ny : Nor
 
 /-- A pair of subrelations lifts to transitivity on the relation. -/
 @[implicit_reducible]
-def trans_of_subrelation (s s' r : α → α → Prop) (hr : IsTrans α r)
-    (h : Subrelation s r) (h' : Subrelation s' r) : Trans s s' r where
-  trans hab hbc := hr.trans _ _ _ (h hab) (h' hbc)
+def transLeftRight (s s' r : α → α → Prop) [IsTrans α r] (h : s ≤ r) (h' : s' ≤ r) :
+    Trans s s' r where
+  trans hab hbc := _root_.trans (h _ _ hab) (h' _ _ hbc)
 
 /-- A subrelation lifts to transitivity on the left of the relation. -/
 @[implicit_reducible]
-def trans_of_subrelation_left (s r : α → α → Prop) (hr : IsTrans α r)
-    (h : Subrelation s r) : Trans s r r where
-  trans hab hbc := hr.trans _ _ _ (h hab) hbc
+def transLeft (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans s r r where
+  trans hab hbc := _root_.trans (h _ _ hab) hbc
 
 /-- A subrelation lifts to transitivity on the right of the relation. -/
 @[implicit_reducible]
-def trans_of_subrelation_right (s r : α → α → Prop) (hr : IsTrans α r)
-    (h : Subrelation s r) : Trans r s r where
-  trans hab hbc := hr.trans _ _ _ hab (h hbc)
+def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r s r where
+  trans hab hbc := _root_.trans hab (h _ _ hbc)
 
 /-- Confluence implies that multi-step joinability is an equivalence. -/
 theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) :
@@ -559,7 +557,7 @@ theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) (
     exact ⟨w, yw, cz.trans zw⟩
 
 /-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/
-theorem reflTransGen_mono_closed (h₁ : Subrelation r₁ r₂) (h₂ : Subrelation r₂ (ReflTransGen r₁)) :
+theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) :
     ReflTransGen r₁ = ReflTransGen r₂ := by
   ext
   exact ⟨ReflTransGen.mono @h₁, reflTransGen_closed @h₂⟩
@@ -638,10 +636,10 @@ macro_rules
   def PredReduction (a b : ℕ) : Prop := a = b + 1
   ```
 -/
-syntax (name := reduction_sys) "reduction_sys" (ppSpace str)? : attr
+syntax (name := reductionSys) "reduction_sys" (ppSpace str)? : attr
 
 initialize Lean.registerBuiltinAttribute {
-  name := `reduction_sys
+  name := `reductionSys
   descr := "Register notation for a relation and its closures."
   add := fun decl stx _ => MetaM.run' do
     let currNamespace ← getCurrNamespace
diff --git a/Cslib/Foundations/Data/StackTape.lean b/Cslib/Foundations/Data/StackTape.lean
index f495d897a2..a252582b02 100644
--- a/Cslib/Foundations/Data/StackTape.lean
+++ b/Cslib/Foundations/Data/StackTape.lean
@@ -140,7 +140,7 @@ lemma cons_head_tail (l : StackTape Symbol) :
 
 /-- Create a `StackTape` from a list by mapping all elements to `some` -/
 @[scoped grind]
-def map_some (l : List Symbol) : StackTape Symbol := ⟨l.map some, by simp⟩
+def mapSome (l : List Symbol) : StackTape Symbol := ⟨l.map some, by simp⟩
 
 section Length
 
@@ -169,7 +169,7 @@ lemma length_cons_le (o : Option Symbol) (l : StackTape Symbol) :
   cases o <;> grind
 
 @[simp, scoped grind =]
-lemma length_map_some (l : List Symbol) : (map_some l).length = l.length := by grind
+lemma length_mapSome (l : List Symbol) : (mapSome l).length = l.length := by grind
 
 @[simp, scoped grind =]
 lemma length_nil : (nil : StackTape Symbol).length = 0 := by grind
diff --git a/Cslib/Foundations/Logic/LogicalEquivalence.lean b/Cslib/Foundations/Logic/LogicalEquivalence.lean
index e08755f014..7f6c0d332c 100644
--- a/Cslib/Foundations/Logic/LogicalEquivalence.lean
+++ b/Cslib/Foundations/Logic/LogicalEquivalence.lean
@@ -26,7 +26,7 @@ class LogicalEquivalence
   /-- Proof that `eqv` is a congruence. -/
   [congruence : Congruence Proposition eqv]
   /-- Validity is preserved for any judgemental context. -/
-  eqv_fill_valid (heqv : eqv a b) (c : HasHContext.Context Judgement Proposition)
+  eqvFillValid (heqv : eqv a b) (c : HasHContext.Context Judgement Proposition)
     (h : Valid (c<[a])) : Valid (c<[b])
 
 @[inherit_doc]
diff --git a/Cslib/Foundations/Semantics/LTS/Notation.lean b/Cslib/Foundations/Semantics/LTS/Notation.lean
index ea71ec88ea..59198c133b 100644
--- a/Cslib/Foundations/Semantics/LTS/Notation.lean
+++ b/Cslib/Foundations/Semantics/LTS/Notation.lean
@@ -77,10 +77,10 @@ macro_rules
      )
 
 /-- This attribute calls the `lts_transition_notation` command for the annotated declaration. -/
-syntax (name := lts_attr) "lts" ident (ppSpace str)? : attr
+syntax (name := ltsAttr) "lts" ident (ppSpace str)? : attr
 
 initialize Lean.registerBuiltinAttribute {
-  name := `lts_attr
+  name := `ltsAttr
   descr := "Register notation for an LTS"
   add := fun decl stx _ => MetaM.run' do
     let currNamespace ← getCurrNamespace
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Context.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Context.lean
index d8df3b2271..d78dd6eb3d 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Context.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Context.lean
@@ -68,17 +68,17 @@ variable {Γ Δ : Context α β}
 
 /-- A mapping of values within a context. -/
 @[simp, scoped grind]
-def map_val (f : β → β) (Γ : Context α β) : Context α β :=
+def mapVal (f : β → β) (Γ : Context α β) : Context α β :=
   Γ.map (fun ⟨var,ty⟩ => ⟨var,f ty⟩)
 
 omit [DecidableEq α] in
 /-- A mapping of values preserves keys. -/
 @[scoped grind .]
-lemma map_val_keys (f) : Γ.keys = (Γ.map_val f).keys := by
+lemma mapVal_keys (f) : Γ.keys = (Γ.mapVal f).keys := by
   induction Γ <;> grind
 
 /-- A mapping of values maps lookups. -/
-lemma map_val_mem (mem : σ ∈ Γ.dlookup x) (f) : f σ ∈ (Γ.map_val f).dlookup x := by
+lemma mapVal_mem (mem : σ ∈ Γ.dlookup x) (f) : f σ ∈ (Γ.mapVal f).dlookup x := by
   induction Γ <;> grind
 
 end LambdaCalculus.LocallyNameless.Context
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Basic.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Basic.lean
index 2b7483d3dc..51098b693f 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Basic.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Basic.lean
@@ -90,21 +90,21 @@ def Binding.fv : Binding Var → Finset Var
 
 /-- Free type variables of a term. -/
 @[scoped grind =]
-def Term.fv_ty : Term Var → Finset Var
+def Term.fvTy : Term Var → Finset Var
 | bvar _ | fvar _ => {}
-| abs σ t₁ | tabs σ t₁ | tapp t₁ σ => σ.fv ∪ t₁.fv_ty
-| inl t₁ | inr t₁ => t₁.fv_ty
-| app t₁ t₂ | let' t₁ t₂ => t₁.fv_ty ∪ t₂.fv_ty
-| case t₁ t₂ t₃ => t₁.fv_ty ∪ t₂.fv_ty ∪ t₃.fv_ty
+| abs σ t₁ | tabs σ t₁ | tapp t₁ σ => σ.fv ∪ t₁.fvTy
+| inl t₁ | inr t₁ => t₁.fvTy
+| app t₁ t₂ | let' t₁ t₂ => t₁.fvTy ∪ t₂.fvTy
+| case t₁ t₂ t₃ => t₁.fvTy ∪ t₂.fvTy ∪ t₃.fvTy
 
 /-- Free term variables of a term. -/
 @[scoped grind =]
-def Term.fv_tm : Term Var → Finset Var
+def Term.fvTm : Term Var → Finset Var
 | bvar _ => {}
 | fvar x => {x}
-| abs _ t₁ | tabs _ t₁ | tapp t₁ _ | inl t₁ | inr t₁ => t₁.fv_tm
-| app t₁ t₂ | let' t₁ t₂ => t₁.fv_tm ∪ t₂.fv_tm
-| case t₁ t₂ t₃ => t₁.fv_tm ∪ t₂.fv_tm ∪ t₃.fv_tm
+| abs _ t₁ | tabs _ t₁ | tapp t₁ _ | inl t₁ | inr t₁ => t₁.fvTm
+| app t₁ t₂ | let' t₁ t₂ => t₁.fvTm ∪ t₂.fvTm
+| case t₁ t₂ t₃ => t₁.fvTm ∪ t₂.fvTm ∪ t₃.fvTm
 
 /-- A context of bindings. -/
 abbrev Env (Var : Type*) := Context Var (Binding Var)
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean
index 489791ddc7..1d7060916e 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Opening.lean
@@ -144,51 +144,51 @@ open scoped Ty
 
 /-- Variable opening (term opening to type) of the ith bound variable. -/
 @[scoped grind =]
-def openRec_ty (X : ℕ) (δ : Ty Var) : Term Var → Term Var
+def openRecTy (X : ℕ) (δ : Ty Var) : Term Var → Term Var
 | bvar x => bvar x
 | fvar x => fvar x
-| abs σ t₁ => abs (σ⟦X ↝ δ⟧ᵞ) (openRec_ty X δ t₁)
-| app t₁ t₂ => app (openRec_ty X δ t₁) (openRec_ty X δ t₂)
-| tabs σ t₁ => tabs (σ⟦X ↝ δ⟧ᵞ) (openRec_ty (X + 1) δ t₁)
-| tapp t₁ σ => tapp (openRec_ty X δ t₁) (σ⟦X ↝ δ⟧ᵞ)
-| let' t₁ t₂ => let' (openRec_ty X δ t₁) (openRec_ty X δ t₂)
-| inl t₁ => inl (openRec_ty X δ t₁)
-| inr t₂ => inr (openRec_ty X δ t₂)
-| case t₁ t₂ t₃ => case (openRec_ty X δ t₁) (openRec_ty X δ t₂) (openRec_ty X δ t₃)
+| abs σ t₁ => abs (σ⟦X ↝ δ⟧ᵞ) (openRecTy X δ t₁)
+| app t₁ t₂ => app (openRecTy X δ t₁) (openRecTy X δ t₂)
+| tabs σ t₁ => tabs (σ⟦X ↝ δ⟧ᵞ) (openRecTy (X + 1) δ t₁)
+| tapp t₁ σ => tapp (openRecTy X δ t₁) (σ⟦X ↝ δ⟧ᵞ)
+| let' t₁ t₂ => let' (openRecTy X δ t₁) (openRecTy X δ t₂)
+| inl t₁ => inl (openRecTy X δ t₁)
+| inr t₂ => inr (openRecTy X δ t₂)
+| case t₁ t₂ t₃ => case (openRecTy X δ t₁) (openRecTy X δ t₂) (openRecTy X δ t₃)
 
 @[inherit_doc]
-scoped notation:68 t "⟦" X " ↝ " δ "⟧ᵗᵞ"=> openRec_ty X δ t
+scoped notation:68 t "⟦" X " ↝ " δ "⟧ᵗᵞ"=> openRecTy X δ t
 
 /-- Variable opening (term opening to type) of the closest binding. -/
 @[scoped grind =]
-def open_ty (t : Term Var) (δ : Ty Var) := openRec_ty 0 δ t
+def openTy (t : Term Var) (δ : Ty Var) := openRecTy 0 δ t
 
 @[inherit_doc]
-scoped infixr:80 " ^ᵗᵞ " => open_ty
+scoped infixr:80 " ^ᵗᵞ " => openTy
 
 /-- Variable opening (term opening to term) of the ith bound variable. -/
 @[scoped grind =]
-def openRec_tm (x : ℕ) (s : Term Var) : Term Var → Term Var
+def openRecTm (x : ℕ) (s : Term Var) : Term Var → Term Var
 | bvar y => if x = y then s else (bvar y)
 | fvar x => fvar x
-| abs σ t₁ => abs σ (openRec_tm (x + 1) s t₁)
-| app t₁ t₂ => app (openRec_tm x s t₁) (openRec_tm x s t₂)
-| tabs σ t₁ => tabs σ (openRec_tm x s t₁)
-| tapp t₁ σ => tapp (openRec_tm x s t₁) σ
-| let' t₁ t₂ => let' (openRec_tm x s t₁) (openRec_tm (x + 1) s t₂)
-| inl t₁ => inl (openRec_tm x s t₁)
-| inr t₂ => inr (openRec_tm x s t₂)
-| case t₁ t₂ t₃ => case (openRec_tm x s t₁) (openRec_tm (x + 1) s t₂) (openRec_tm (x + 1) s t₃)
+| abs σ t₁ => abs σ (openRecTm (x + 1) s t₁)
+| app t₁ t₂ => app (openRecTm x s t₁) (openRecTm x s t₂)
+| tabs σ t₁ => tabs σ (openRecTm x s t₁)
+| tapp t₁ σ => tapp (openRecTm x s t₁) σ
+| let' t₁ t₂ => let' (openRecTm x s t₁) (openRecTm (x + 1) s t₂)
+| inl t₁ => inl (openRecTm x s t₁)
+| inr t₂ => inr (openRecTm x s t₂)
+| case t₁ t₂ t₃ => case (openRecTm x s t₁) (openRecTm (x + 1) s t₂) (openRecTm (x + 1) s t₃)
 
 @[inherit_doc]
-scoped notation:68 t "⟦" x " ↝ " s "⟧ᵗᵗ"=> openRec_tm x s t
+scoped notation:68 t "⟦" x " ↝ " s "⟧ᵗᵗ"=> openRecTm x s t
 
 /-- Variable opening (term opening to term) of the closest binding. -/
 @[scoped grind =]
-def open_tm (t₁ t₂ : Term Var) := openRec_tm 0 t₂ t₁
+def openTm (t₁ t₂ : Term Var) := openRecTm 0 t₂ t₁
 
 @[inherit_doc]
-scoped infixr:80 " ^ᵗᵗ " => open_tm
+scoped infixr:80 " ^ᵗᵗ " => openTm
 
 /-- Locally closed terms. -/
 inductive LC : Term Var → Prop
@@ -212,189 +212,189 @@ variable {t : Term Var} {δ : Ty Var}
 
 omit [HasFresh Var] [DecidableEq Var] in
 /-- An opening (term to type) appearing in both sides of an equality of terms can be removed. -/
-lemma openRec_ty_neq_eq (neq : X ≠ Y) (eq : t⟦Y ↝ σ⟧ᵗᵞ = t⟦Y ↝ σ⟧ᵗᵞ⟦X ↝ τ⟧ᵗᵞ) :
+lemma openRecTy_neq_eq (neq : X ≠ Y) (eq : t⟦Y ↝ σ⟧ᵗᵞ = t⟦Y ↝ σ⟧ᵗᵞ⟦X ↝ τ⟧ᵗᵞ) :
     t = t⟦X ↝ τ⟧ᵗᵞ := by
   induction t generalizing X Y <;> grind [Ty.openRec_neq_eq]
 
 omit [HasFresh Var] [DecidableEq Var] in
 /-- Elimination of mixed term and type opening. -/
 @[scoped grind .]
-lemma openRec_tm_ty_eq (eq : t⟦x ↝ s⟧ᵗᵗ = t⟦x ↝ s⟧ᵗᵗ⟦y ↝ δ⟧ᵗᵞ) : t = t⟦y ↝ δ⟧ᵗᵞ
+lemma openRecTm_ty_eq (eq : t⟦x ↝ s⟧ᵗᵗ = t⟦x ↝ s⟧ᵗᵗ⟦y ↝ δ⟧ᵗᵞ) : t = t⟦y ↝ δ⟧ᵗᵞ
   := by induction t generalizing x y <;> grind
 
 /-- A locally closed term is unchanged by type opening. -/
 @[scoped grind =_]
-lemma openRec_ty_lc {t : Term Var} (lc : t.LC) : t = t⟦X ↝ σ⟧ᵗᵞ := by
+lemma openRecTy_lc {t : Term Var} (lc : t.LC) : t = t⟦X ↝ σ⟧ᵗᵞ := by
   induction lc generalizing X with
   | let' | case | tabs | abs =>
-    grind [fresh_exists <| free_union Var, Ty.openRec_lc, openRec_ty_neq_eq]
+    grind [fresh_exists <| free_union Var, Ty.openRec_lc, openRecTy_neq_eq]
   | _ => grind [Ty.openRec_lc]
 
 /-- Substitution of a type within a term. -/
 @[scoped grind =]
-def subst_ty (X : Var) (δ : Ty Var) : Term Var → Term Var
+def substTy (X : Var) (δ : Ty Var) : Term Var → Term Var
 | bvar x => bvar x
 | fvar x => fvar x
-| abs σ t₁ => abs (σ [X := δ]) (subst_ty X δ t₁)
-| app t₁ t₂ => app (subst_ty X δ t₁) (subst_ty X δ t₂)
-| tabs σ t₁ => tabs (σ [X := δ]) (subst_ty X δ t₁)
-| tapp t₁ σ => tapp (subst_ty X δ t₁) (σ[X := δ])
-| let' t₁ t₂ => let' (subst_ty X δ t₁) (subst_ty X δ t₂)
-| inl t₁ => inl (subst_ty X δ t₁)
-| inr t₁ => inr (subst_ty X δ t₁)
-| case t₁ t₂ t₃ => case (subst_ty X δ t₁) (subst_ty X δ t₂) (subst_ty X δ t₃)
+| abs σ t₁ => abs (σ [X := δ]) (substTy X δ t₁)
+| app t₁ t₂ => app (substTy X δ t₁) (substTy X δ t₂)
+| tabs σ t₁ => tabs (σ [X := δ]) (substTy X δ t₁)
+| tapp t₁ σ => tapp (substTy X δ t₁) (σ[X := δ])
+| let' t₁ t₂ => let' (substTy X δ t₁) (substTy X δ t₂)
+| inl t₁ => inl (substTy X δ t₁)
+| inr t₁ => inr (substTy X δ t₁)
+| case t₁ t₂ t₃ => case (substTy X δ t₁) (substTy X δ t₂) (substTy X δ t₃)
 
 instance : HasSubstitution (Term Var) Var (Ty Var) where
-  subst t X δ := Term.subst_ty X δ t
+  subst t X δ := Term.substTy X δ t
 
 omit [HasFresh Var] in
 @[scoped grind _=_]
-lemma subst_ty_def : subst_ty (X : Var) (δ : Ty Var) (t : Term Var) = t[X := δ] := by rfl
+lemma substTy_def : substTy (X : Var) (δ : Ty Var) (t : Term Var) = t[X := δ] := by rfl
 
 omit [HasFresh Var] in
 /-- Substitution of a free type variable not present in a term leaves it unchanged. -/
-lemma subst_ty_fresh (nmem : X ∉ t.fv_ty) (δ : Ty Var) : t = t [X := δ] :=
+lemma substTy_fresh (nmem : X ∉ t.fvTy) (δ : Ty Var) : t = t [X := δ] :=
   by induction t <;> grind [Ty.subst_fresh]
 
 /-- Substitution of a locally closed type distributes with term opening to a type . -/
-lemma openRec_ty_subst_ty (Y : ℕ) (t : Term Var) (σ : Ty Var) (lc : δ.LC) (X : Var) :
+lemma openRecTy_substTy (Y : ℕ) (t : Term Var) (σ : Ty Var) (lc : δ.LC) (X : Var) :
     (t⟦Y ↝ σ⟧ᵗᵞ)[X := δ] = (t[X := δ])⟦Y ↝  σ[X := δ]⟧ᵗᵞ := by
   induction t generalizing Y <;> grind [Ty.openRec_subst]
 
-/-- Specialize `Term.openRec_ty_subst` to the first opening. -/
-lemma open_ty_subst_ty (t : Term Var) (σ : Ty Var) (lc : δ.LC) (X : Var) :
-     (t ^ᵗᵞ σ)[X := δ] = t[X := δ] ^ᵗᵞ σ[X := δ] := openRec_ty_subst_ty 0 t σ lc X
+/-- Specialize `Term.openRecTy_subst` to the first opening. -/
+lemma openTy_substTy (t : Term Var) (σ : Ty Var) (lc : δ.LC) (X : Var) :
+     (t ^ᵗᵞ σ)[X := δ] = t[X := δ] ^ᵗᵞ σ[X := δ] := openRecTy_substTy 0 t σ lc X
 
-/-- Specialize `Term.open_ty_subst` to free type variables. -/
-lemma open_ty_subst_ty_var (t : Term Var) (neq : Y ≠ X) (lc : δ.LC) :
-    (t ^ᵗᵞ .fvar Y)[X := δ] = t[X := δ] ^ᵗᵞ .fvar Y := by grind [open_ty_subst_ty]
+/-- Specialize `Term.openTy_subst` to free type variables. -/
+lemma openTy_substTy_var (t : Term Var) (neq : Y ≠ X) (lc : δ.LC) :
+    (t ^ᵗᵞ .fvar Y)[X := δ] = t[X := δ] ^ᵗᵞ .fvar Y := by grind [openTy_substTy]
 
 omit [HasFresh Var]
 
 /-- Opening a term to a type is equivalent to opening to a free variable and substituting. -/
-lemma openRec_ty_subst_ty_intro (Y : ℕ) (t : Term Var) (nmem : X ∉ t.fv_ty) :
+lemma openRecTy_substTy_intro (Y : ℕ) (t : Term Var) (nmem : X ∉ t.fvTy) :
   t⟦Y ↝ δ⟧ᵗᵞ = (t⟦Y ↝ Ty.fvar X⟧ᵗᵞ)[X := δ] := by
   induction t generalizing X δ Y <;> grind [Ty.openRec_subst_intro]
 
-/-- Specialize `Term.openRec_ty_subst_ty_intro` to the first opening. -/
-lemma open_ty_subst_ty_intro (t : Term Var) (δ : Ty Var) (nmem : X ∉ t.fv_ty) :
-    t ^ᵗᵞ δ = (t ^ᵗᵞ Ty.fvar X)[X := δ] := openRec_ty_subst_ty_intro _ _ nmem
+/-- Specialize `Term.openRecTy_substTy_intro` to the first opening. -/
+lemma openTy_substTy_intro (t : Term Var) (δ : Ty Var) (nmem : X ∉ t.fvTy) :
+    t ^ᵗᵞ δ = (t ^ᵗᵞ Ty.fvar X)[X := δ] := openRecTy_substTy_intro _ _ nmem
 
 /-- Substitution of a term within a term. -/
 @[scoped grind =]
-def subst_tm (x : Var) (s : Term Var) : Term Var → Term Var
+def substTm (x : Var) (s : Term Var) : Term Var → Term Var
 | bvar x => bvar x
 | fvar y => if y = x then s else fvar y
-| abs σ t₁ => abs σ (subst_tm x s t₁)
-| app t₁ t₂ => app (subst_tm x s t₁) (subst_tm x s t₂)
-| tabs σ t₁ => tabs σ (subst_tm x s t₁)
-| tapp t₁ σ => tapp (subst_tm x s t₁) σ
-| let' t₁ t₂ => let' (subst_tm x s t₁) (subst_tm x s t₂)
-| inl t₁ => inl (subst_tm x s t₁)
-| inr t₁ => inr (subst_tm x s t₁)
-| case t₁ t₂ t₃ => case (subst_tm x s t₁) (subst_tm x s t₂) (subst_tm x s t₃)
+| abs σ t₁ => abs σ (substTm x s t₁)
+| app t₁ t₂ => app (substTm x s t₁) (substTm x s t₂)
+| tabs σ t₁ => tabs σ (substTm x s t₁)
+| tapp t₁ σ => tapp (substTm x s t₁) σ
+| let' t₁ t₂ => let' (substTm x s t₁) (substTm x s t₂)
+| inl t₁ => inl (substTm x s t₁)
+| inr t₁ => inr (substTm x s t₁)
+| case t₁ t₂ t₃ => case (substTm x s t₁) (substTm x s t₂) (substTm x s t₃)
 
 instance : HasSubstitution (Term Var) Var (Term Var) where
-  subst t x s := Term.subst_tm x s t
+  subst t x s := Term.substTm x s t
 
 @[scoped grind _=_]
-lemma subst_tm_def : subst_tm (x : Var) (s : Term Var) (t : Term Var) = t[x := s] := by rfl
+lemma substTm_def : substTm (x : Var) (s : Term Var) (t : Term Var) = t[x := s] := by rfl
 
 omit [DecidableEq Var] in
 /-- An opening (term to term) appearing in both sides of an equality of terms can be removed. -/
-lemma openRec_tm_neq_eq (neq : x ≠ y) (eq : t⟦y ↝ s₁⟧ᵗᵗ = t⟦y ↝ s₁⟧ᵗᵗ⟦x ↝ s₂⟧ᵗᵗ) :
+lemma openRecTm_neq_eq (neq : x ≠ y) (eq : t⟦y ↝ s₁⟧ᵗᵗ = t⟦y ↝ s₁⟧ᵗᵗ⟦x ↝ s₂⟧ᵗᵗ) :
     t = t⟦x ↝ s₂⟧ᵗᵗ := by
   induction t generalizing x y <;> grind
 
 omit [DecidableEq Var] in
 /-- Elimination of mixed term and type opening. -/
-lemma openRec_ty_tm_eq (eq : t⟦Y ↝ σ⟧ᵗᵞ = t⟦Y ↝ σ⟧ᵗᵞ⟦x ↝ s⟧ᵗᵗ) : t = t⟦x ↝ s⟧ᵗᵗ := by
+lemma openRecTy_tm_eq (eq : t⟦Y ↝ σ⟧ᵗᵞ = t⟦Y ↝ σ⟧ᵗᵞ⟦x ↝ s⟧ᵗᵗ) : t = t⟦x ↝ s⟧ᵗᵗ := by
   induction t generalizing x Y <;> grind
 
 variable [HasFresh Var]
 
 /-- A locally closed term is unchanged by term opening. -/
 @[scoped grind =_]
-lemma openRec_tm_lc (lc : t.LC) : t = t⟦x ↝ s⟧ᵗᵗ := by
+lemma openRecTm_lc (lc : t.LC) : t = t⟦x ↝ s⟧ᵗᵗ := by
   induction lc generalizing x with
   | let' | case | tabs | abs =>
-    grind [fresh_exists <| free_union Var, openRec_tm_neq_eq, openRec_ty_tm_eq]
+    grind [fresh_exists <| free_union Var, openRecTm_neq_eq, openRecTy_tm_eq]
   | _ => grind
 
 variable {t s : Term Var} {δ : Ty Var} {x : Var}
 
 omit [HasFresh Var] in
 /-- Substitution of a free term variable not present in a term leaves it unchanged. -/
-lemma subst_tm_fresh (nmem : x ∉ t.fv_tm) (s : Term Var) : t = t[x := s] := by
+lemma substTm_fresh (nmem : x ∉ t.fvTm) (s : Term Var) : t = t[x := s] := by
   induction t <;> grind
 
 /-- Substitution of a locally closed term distributes with term opening to a term. -/
-lemma openRec_tm_subst_tm (y : ℕ) (t₁ t₂ : Term Var) (lc : s.LC) (x : Var) :
+lemma openRecTm_substTm (y : ℕ) (t₁ t₂ : Term Var) (lc : s.LC) (x : Var) :
     (t₁⟦y ↝ t₂⟧ᵗᵗ)[x := s] = (t₁[x := s])⟦y ↝  t₂[x := s]⟧ᵗᵗ := by
   induction t₁ generalizing y <;> grind
 
-/-- Specialize `Term.openRec_tm_subst_tm` to the first opening. -/
-lemma open_tm_subst_tm (t₁ t₂ : Term Var) (lc : s.LC) (x : Var) :
-    (t₁ ^ᵗᵗ t₂)[x := s] = (t₁[x := s]) ^ᵗᵗ t₂[x := s] := openRec_tm_subst_tm 0 t₁ t₂ lc x
+/-- Specialize `Term.openRecTm_substTm` to the first opening. -/
+lemma openTm_substTm (t₁ t₂ : Term Var) (lc : s.LC) (x : Var) :
+    (t₁ ^ᵗᵗ t₂)[x := s] = (t₁[x := s]) ^ᵗᵗ t₂[x := s] := openRecTm_substTm 0 t₁ t₂ lc x
 
-/-- Specialize `Term.openRec_tm_subst_tm` to free term variables. -/
-lemma open_tm_subst_tm_var (t : Term Var) (neq : y ≠ x) (lc : s.LC) :
-     (t ^ᵗᵗ fvar y)[x := s] = (t[x := s]) ^ᵗᵗ fvar y := by grind [open_tm_subst_tm]
+/-- Specialize `Term.openRecTm_substTm` to free term variables. -/
+lemma openTm_substTm_var (t : Term Var) (neq : y ≠ x) (lc : s.LC) :
+     (t ^ᵗᵗ fvar y)[x := s] = (t[x := s]) ^ᵗᵗ fvar y := by grind [openTm_substTm]
 
 /-- Substitution of a locally closed type distributes with term opening to a term. -/
-lemma openRec_tm_subst_ty (y : ℕ) (t₁ t₂ : Term Var) (δ : Ty Var) (X : Var) :
+lemma openRecTm_substTy (y : ℕ) (t₁ t₂ : Term Var) (δ : Ty Var) (X : Var) :
     (t₁⟦y ↝ t₂⟧ᵗᵗ)[X := δ] = (t₁[X := δ])⟦y ↝  t₂[X := δ]⟧ᵗᵗ := by
   induction t₁ generalizing y <;> grind
 
-/-- Specialize `Term.openRec_tm_subst_ty` to the first opening -/
-lemma open_tm_subst_ty (t₁ t₂ : Term Var) (δ : Ty Var) (X : Var) :
-    (t₁ ^ᵗᵗ t₂)[X := δ] = (t₁[X := δ]) ^ᵗᵗ t₂[X := δ] := openRec_tm_subst_ty 0 t₁ t₂ δ X
+/-- Specialize `Term.openRecTm_substTy` to the first opening -/
+lemma openTm_substTy (t₁ t₂ : Term Var) (δ : Ty Var) (X : Var) :
+    (t₁ ^ᵗᵗ t₂)[X := δ] = (t₁[X := δ]) ^ᵗᵗ t₂[X := δ] := openRecTm_substTy 0 t₁ t₂ δ X
 
-/-- Specialize `Term.open_tm_subst_ty` to free term variables -/
-lemma open_tm_subst_ty_var (t₁ : Term Var) (δ : Ty Var) (X y : Var) :
-    (t₁ ^ᵗᵗ fvar y)[X := δ] = (t₁[X := δ]) ^ᵗᵗ fvar y := by grind [open_tm_subst_ty]
+/-- Specialize `Term.openTm_substTy` to free term variables -/
+lemma openTm_substTy_var (t₁ : Term Var) (δ : Ty Var) (X y : Var) :
+    (t₁ ^ᵗᵗ fvar y)[X := δ] = (t₁[X := δ]) ^ᵗᵗ fvar y := by grind [openTm_substTy]
 
 /-- Substitution of a locally closed term distributes with term opening to a type. -/
-lemma openRec_ty_subst_tm (Y : ℕ) (t : Term Var) (δ : Ty Var) (lc : s.LC) (x : Var) :
+lemma openRecTy_substTm (Y : ℕ) (t : Term Var) (δ : Ty Var) (lc : s.LC) (x : Var) :
     (t⟦Y ↝ δ⟧ᵗᵞ)[x := s] = t[x := s]⟦Y ↝ δ⟧ᵗᵞ := by
   induction t generalizing Y <;> grind
 
-/-- Specialize `Term.openRec_ty_subst_tm` to the first opening. -/
-lemma open_ty_subst_tm (t : Term Var) (δ : Ty Var) (lc : s.LC) (x : Var) :
-    (t ^ᵗᵞ δ)[x := s] = t[x := s] ^ᵗᵞ δ := openRec_ty_subst_tm 0 t δ lc x
+/-- Specialize `Term.openRecTy_substTm` to the first opening. -/
+lemma openTy_substTm (t : Term Var) (δ : Ty Var) (lc : s.LC) (x : Var) :
+    (t ^ᵗᵞ δ)[x := s] = t[x := s] ^ᵗᵞ δ := openRecTy_substTm 0 t δ lc x
 
-/-- Specialize `Term.open_ty_subst_tm` to free type variables. -/
-lemma open_ty_subst_tm_var (t : Term Var) (lc : s.LC) (x Y : Var) :
-    (t ^ᵗᵞ .fvar Y)[x := s] = t[x := s] ^ᵗᵞ .fvar Y := open_ty_subst_tm _ _ lc _
+/-- Specialize `Term.openTy_substTm` to free type variables. -/
+lemma openTy_substTm_var (t : Term Var) (lc : s.LC) (x Y : Var) :
+    (t ^ᵗᵞ .fvar Y)[x := s] = t[x := s] ^ᵗᵞ .fvar Y := openTy_substTm _ _ lc _
 
 omit [HasFresh Var]
 
 /-- Opening a term to a term is equivalent to opening to a free variable and substituting. -/
-lemma openRec_tm_subst_tm_intro (y : ℕ) (t s : Term Var) (nmem : x ∉ t.fv_tm) :
+lemma openRecTm_substTm_intro (y : ℕ) (t s : Term Var) (nmem : x ∉ t.fvTm) :
     t⟦y ↝ s⟧ᵗᵗ = (t⟦y ↝ fvar x⟧ᵗᵗ)[x := s] := by
   induction t generalizing y <;> grind
 
-/-- Specialize `Term.openRec_tm_subst_tm_intro` to the first opening. -/
-lemma open_tm_subst_tm_intro (t s : Term Var) (nmem : x ∉ t.fv_tm) :
-    t ^ᵗᵗs = (t ^ᵗᵗ fvar x)[x := s] := openRec_tm_subst_tm_intro _ _ _ nmem
+/-- Specialize `Term.openRecTm_substTm_intro` to the first opening. -/
+lemma openTm_substTm_intro (t s : Term Var) (nmem : x ∉ t.fvTm) :
+    t ^ᵗᵗs = (t ^ᵗᵗ fvar x)[x := s] := openRecTm_substTm_intro _ _ _ nmem
 
 variable [HasFresh Var]
 
-lemma subst_ty_lc (t_lc : t.LC) (δ_lc : δ.LC) (X : Var) : t[X := δ].LC := by
+lemma substTy_lc (t_lc : t.LC) (δ_lc : δ.LC) (X : Var) : t[X := δ].LC := by
   induction t_lc
   case' abs  => apply LC.abs (free_union Var)
   case' tabs => apply LC.tabs (free_union Var)
   case' let' => apply LC.let' (free_union Var)
   case' case => apply LC.case (free_union Var)
-  all_goals grind [Ty.subst_lc, open_tm_subst_ty_var, openRec_ty_subst_ty]
+  all_goals grind [Ty.subst_lc, openTm_substTy_var, openRecTy_substTy]
 
-lemma subst_tm_lc (t_lc : t.LC) (s_lc : s.LC) (x : Var) : t[x := s].LC := by
+lemma substTm_lc (t_lc : t.LC) (s_lc : s.LC) (x : Var) : t[x := s].LC := by
   induction t_lc
   case' abs  => apply LC.abs (free_union Var)
   case' let' => apply LC.let' (free_union Var)
   case' case => apply LC.case (free_union Var)
   case' tabs => apply LC.tabs (free_union Var)
-  all_goals grind [open_tm_subst_tm_var, open_ty_subst_tm_var]
+  all_goals grind [openTm_substTm_var, openTy_substTm_var]
 
 end Term
 
@@ -414,10 +414,10 @@ instance : HasSubstitution (Binding Var) Var (Ty Var) where
 variable {δ γ : Ty Var} {X : Var}
 
 @[scoped grind _=_]
-lemma subst_sub : (sub γ)[X := δ] = sub (γ[X := δ]) := by rfl
+lemma substSub : (sub γ)[X := δ] = sub (γ[X := δ]) := by rfl
 
 @[scoped grind _=_]
-lemma subst_ty : (ty γ)[X := δ] = ty (γ[X := δ]) := by rfl
+lemma substTy : (ty γ)[X := δ] = ty (γ[X := δ]) := by rfl
 
 open scoped Ty in
 /-- Substitution of a free variable not present in a binding leaves it unchanged. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean
index 8263fe2957..b9969aa49a 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Reduction.lean
@@ -68,7 +68,7 @@ variable [HasFresh Var]
 @[scoped grind <=]
 lemma open_tm_body (body : t₁.body) (lc : t₂.LC) : (t₁ ^ᵗᵗ t₂).LC := by
   cases body
-  grind [fresh_exists <| free_union [fv_tm] Var, subst_tm_lc, open_tm_subst_tm_intro]
+  grind [fresh_exists <| free_union [fvTm] Var, substTm_lc, openTm_substTm_intro]
 
 end
 
@@ -109,8 +109,8 @@ lemma Red.lc {t t' : Term Var} (red : t ⭢βᵛ t') : t.LC ∧ t'.LC := by
     · grind
     · cases lc
       grind [
-        fresh_exists <| free_union [fv_tm, fv_ty] Var, subst_tm_lc,
-        subst_ty_lc, open_tm_subst_tm_intro, open_ty_subst_ty_intro]
+        fresh_exists <| free_union [fvTm, fvTy] Var, substTm_lc,
+        substTy_lc, openTm_substTm_intro, openTy_substTy_intro]
   all_goals grind
 
 end Term
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
index c5e0116db4..cf294d3b1c 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
@@ -42,22 +42,22 @@ lemma Typing.preservation (der : Typing Γ t τ) (step : t ⭢βᵛ t') : Typing
     case abs der _ _ =>
       have sub : Sub Γ (σ.arrow τ) (σ.arrow τ) := by grind [Sub.refl]
       have ⟨_, _, ⟨_, _⟩⟩ := der.abs_inv sub
-      grind [fresh_exists <| free_union [fv_tm] Var, open_tm_subst_tm_intro, subst_tm, Sub.weaken]
+      grind [fresh_exists <| free_union [fvTm] Var, openTm_substTm_intro, subst_tm, Sub.weaken]
   case tapp Γ _ σ τ σ' _ _ _ =>
     cases step
     case tabs der _ _ =>
       have sub : Sub Γ (σ.all τ) (σ.all τ) := by grind [Sub.refl]
       have ⟨_, _, ⟨_, _⟩⟩ := der.tabs_inv sub
-      have ⟨X, mem⟩ := fresh_exists <| free_union [Ty.fv, fv_ty] Var
+      have ⟨X, mem⟩ := fresh_exists <| free_union [Ty.fv, fvTy] Var
       simp at mem
-      have : Γ = (Context.map_val (·[X:=σ']) []) ++ Γ := by grind
-      rw [open_ty_subst_ty_intro (X := X), open_subst_intro (X := X)] <;> grind [subst_ty]
+      have : Γ = (Context.mapVal (·[X:=σ']) []) ++ Γ := by grind
+      rw [openTy_substTy_intro (X := X), open_subst_intro (X := X)] <;> grind [subst_ty]
     case tapp => grind
   case let' Γ _ _ _ _ L der _ ih₁ _ =>
     cases step
     case let_bind red₁ _ => apply Typing.let' L (ih₁ red₁); grind
     case let_body =>
-      grind [fresh_exists <| free_union [fv_tm] Var, open_tm_subst_tm_intro, subst_tm]
+      grind [fresh_exists <| free_union [fvTm] Var, openTm_substTm_intro, subst_tm]
   case case Γ _ σ τ _ _ _ L _ _ _ ih₁ _ _ =>
     have sub : Sub Γ (σ.sum τ) (σ.sum τ) := by grind [Sub.refl]
     have : Γ = [] ++ Γ := by rfl
@@ -65,10 +65,10 @@ lemma Typing.preservation (der : Typing Γ t τ) (step : t ⭢βᵛ t') : Typing
     case «case» red₁ _ _ => apply Typing.case L (ih₁ red₁) <;> grind
     case case_inl der _ _ =>
       have ⟨_, ⟨_, _⟩⟩ := der.inl_inv sub
-      grind [fresh_exists <| free_union [fv_tm] Var, open_tm_subst_tm_intro, subst_tm]
+      grind [fresh_exists <| free_union [fvTm] Var, openTm_substTm_intro, subst_tm]
     case case_inr der _ _ =>
       have ⟨_, ⟨_, _⟩⟩ := der.inr_inv sub
-      grind [fresh_exists <| free_union [fv_tm] Var, open_tm_subst_tm_intro, subst_tm]
+      grind [fresh_exists <| free_union [fvTm] Var, openTm_substTm_intro, subst_tm]
   all_goals grind [cases Red]
 
 /-- Any typable term either has a reduction step or is a value. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
index 4f0635f5e8..1a8abe649d 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
@@ -144,7 +144,7 @@ lemma narrow (sub_δ : Sub Δ δ δ') (sub_narrow : Sub (Γ ++ ⟨X, Binding.sub
 variable [HasFresh Var] in
 /-- Subtyping of substitutions. -/
 lemma map_subst (sub₁ : Sub (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) σ τ) (sub₂ : Sub Δ δ δ') :
-    Sub (Γ.map_val (·[X:=δ]) ++ Δ) (σ[X:=δ]) (τ[X:=δ]) := by
+    Sub (Γ.mapVal (·[X:=δ]) ++ Δ) (σ[X:=δ]) (τ[X:=δ]) := by
   generalize eq : Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ = Θ at sub₁
   induction sub₁ generalizing Γ
   case all => apply Sub.all (free_union Var) <;> grind [open_subst_var]
@@ -152,7 +152,7 @@ lemma map_subst (sub₁ : Sub (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) σ τ) (sub
     have := map_subst_nmem Δ X δ
     have : Γ ++ ⟨X, .sub δ'⟩ :: Δ ~ ⟨X, .sub δ'⟩ :: (Γ ++ Δ) := perm_middle
     have : .sub σ ∈ dlookup X' (⟨X, .sub δ'⟩ :: (Γ ++ Δ)) := by grind [perm_dlookup]
-    have := @map_val_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var))
+    have := @mapVal_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var))
     by_cases X = X'
     · trans δ' <;> grind [→ mem_dlookup, Ty.subst_fresh, Ty.Wf.nmem_fv, weaken_head]
     · grind
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
index d0edd7896c..7a9e8efe0e 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
@@ -124,29 +124,29 @@ lemma subst_tm (der : Typing (Γ ++ ⟨X, .ty σ⟩ :: Δ) t τ) (der_sub : Typi
       -/
       grind [→ List.mem_dlookup, weaken_head, Env.Wf.strengthen, -append_assoc]
     · grind [Env.Wf.strengthen, => List.perm_dlookup]
-  case abs => grind [abs (free_union Var), open_tm_subst_tm_var]
-  case tabs => grind [tabs (free_union Var), open_ty_subst_tm_var]
-  case let' der _ => grind [let' (free_union Var) (der eq), open_tm_subst_tm_var]
+  case abs => grind [abs (free_union Var), openTm_substTm_var]
+  case tabs => grind [tabs (free_union Var), openTy_substTm_var]
+  case let' der _ => grind [let' (free_union Var) (der eq), openTm_substTm_var]
   case case der _ _ =>
-    apply case (free_union Var) (der eq) <;> grind [open_tm_subst_tm_var]
+    apply case (free_union Var) (der eq) <;> grind [openTm_substTm_var]
   all_goals grind [Env.Wf.strengthen, Ty.Wf.strengthen, Sub.strengthen]
 
 /-- Type substitution within a typing. -/
 lemma subst_ty (der : Typing (Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ) t τ) (sub : Sub Δ δ δ') :
-    Typing (Γ.map_val (·[X := δ]) ++ Δ) (t[X := δ]) (τ[X := δ]) := by
+    Typing (Γ.mapVal (·[X := δ]) ++ Δ) (t[X := δ]) (τ[X := δ]) := by
   generalize eq : Γ ++ ⟨X, Binding.sub δ'⟩ :: Δ = Θ at der
   induction der generalizing Γ X
   case var σ _ X' _ mem =>
     have := map_subst_nmem Δ X δ
-    have := @map_val_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var))
+    have := @mapVal_mem Var (f := ((·[X:=δ]) : Binding Var → Binding Var))
     grind [Env.Wf.map_subst, → notMem_keys_of_nodupKeys_cons]
-  case abs => grind [abs (free_union [Ty.fv] Var), Ty.subst_fresh, open_tm_subst_ty_var]
-  case tabs => grind [tabs (free_union Var), open_ty_subst_ty_var, open_subst_var]
+  case abs => grind [abs (free_union [Ty.fv] Var), Ty.subst_fresh, openTm_substTy_var]
+  case tabs => grind [tabs (free_union Var), openTy_substTy_var, open_subst_var]
   case let' der _ =>
     apply let' (free_union Var) (der eq)
-    grind [open_tm_subst_ty_var]
+    grind [openTm_substTy_var]
   case case der _ _ =>
-    apply case (free_union Var) (der eq) <;> grind [open_tm_subst_ty_var]
+    apply case (free_union Var) (der eq) <;> grind [openTm_substTy_var]
   case tapp => grind [Ty.open_subst, Env.Wf.map_subst, Ty.Wf.map_subst, Sub.map_subst]
   all_goals grind [Env.Wf.map_subst, Ty.Wf.map_subst, Sub.map_subst]
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
index 423312304e..ffb6f30237 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
@@ -121,8 +121,8 @@ lemma strengthen (wf : σ.Wf (Γ ++ ⟨X, Binding.ty τ⟩ :: Δ)) : σ.Wf (Γ +
 variable [HasFresh Var] in
 /-- A type remains well-formed under context substitution (of a well-formed type). -/
 lemma map_subst (wf_σ : σ.Wf (Γ ++ ⟨X, Binding.sub τ⟩ :: Δ)) (wf_τ' : τ'.Wf Δ)
-    (ok : (Γ.map_val (·[X:=τ']) ++ Δ)✓) : σ[X:=τ'].Wf <| Γ.map_val (·[X:=τ']) ++ Δ := by
-  have := @map_val_mem Var (Binding Var)
+    (ok : (Γ.mapVal (·[X:=τ']) ++ Δ)✓) : σ[X:=τ'].Wf <| Γ.mapVal (·[X:=τ']) ++ Δ := by
+  have := @mapVal_mem Var (Binding Var)
   generalize eq : Γ ++ ⟨X, Binding.sub τ⟩ :: Δ = Θ at wf_σ
   induction wf_σ generalizing Γ τ' with
   | all => apply all (free_union [dom] Var) <;> grind [open_subst_var]
@@ -133,7 +133,7 @@ variable [HasFresh Var] in
 lemma open_lc (ok_Γ : Γ✓) (wf_all : (Ty.all σ τ).Wf Γ) (wf_δ : δ.Wf Γ) : (τ ^ᵞ δ).Wf Γ := by
   cases wf_all with | all =>
     let ⟨X, _⟩ := fresh_exists <| free_union [fv, Context.dom] Var
-    have : Γ = Context.map_val (·[X:=δ]) [] ++ Γ := by grind
+    have : Γ = Context.mapVal (·[X:=δ]) [] ++ Γ := by grind
     grind [open_subst_intro, map_subst]
 
 /-- A type bound in a context is well formed. -/
@@ -176,7 +176,7 @@ lemma strengthen (wf : Env.Wf <| Γ ++ ⟨X, Binding.ty τ⟩ :: Δ) : Env.Wf <|
 variable [HasFresh Var] in
 /-- A context remains well-formed under substitution (of a well-formed type). -/
 lemma map_subst (wf_env : Env.Wf (Γ ++ ⟨X, Binding.sub τ⟩ :: Δ)) (wf_τ' : τ'.Wf Δ) :
-    Env.Wf <| Γ.map_val (·[X:=τ']) ++ Δ := by
+    Env.Wf <| Γ.mapVal (·[X:=τ']) ++ Δ := by
   induction Γ generalizing wf_τ' Δ τ' <;> cases wf_env
   case nil => grind
   case cons.sub | cons.ty => constructor <;> grind [Ty.Wf.map_subst]
@@ -185,7 +185,7 @@ variable [HasFresh Var]
 
 /-- A well-formed context is unchanged by substituting for a free key. -/
 lemma map_subst_nmem (Γ : Env Var) (X : Var) (σ : Ty Var) (wf : Γ.Wf) (nmem : X ∉ Γ.dom) :
-    Γ = Γ.map_val (·[X:=σ]) := by
+    Γ = Γ.mapVal (·[X:=σ]) := by
   induction wf <;> grind [Ty.Wf.nmem_fv, Binding.subst_fresh]
 
 end Env.Wf
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
index 9c98b17dac..d9ab413bdc 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
@@ -71,32 +71,32 @@ lemma semanticMap_saturated (τ : Ty Base) : @Saturated Var (semanticMap τ) :=
     · intro M N P _ _ _ s _
       grind [ih₂.multiApp M N (s :: P)]
 
-/-- The `entails_context` predicate ensures that each variable in the context
+/-- The `entailsContext` predicate ensures that each variable in the context
     is mapped to a term in the corresponding semantic map. -/
-abbrev entails_context (E : Term.Env Var) (Γ : Context Var (Ty Base)) :=
+abbrev entailsContext (E : Term.Env Var) (Γ : Context Var (Ty Base)) :=
   ∀ {x τ}, ⟨x, τ⟩ ∈ Γ → (multiSubst E (fvar x)) ∈ semanticMap τ
 
 /-- The empty context is entailed by any environment. -/
-lemma entails_context_empty {Γ : Context Var (Ty Base)} : entails_context [] Γ := by
+lemma entailsContext_empty {Γ : Context Var (Ty Base)} : entailsContext [] Γ := by
   have := semanticMap_saturated (Var := Var) (Base := Base)
   grind
 
 open scoped Context in
 omit [HasFresh Var] in
-/-- The `entails_context` predicate is preserved when extending the context
+/-- The `entailsContext` predicate is preserved when extending the context
     with a new variable, provided the new variable is fresh and its
     substitution is in the corresponding semantic map. -/
-lemma entails_context_cons (E : Term.Env Var) (Γ : Context Var (Ty Base))
+lemma entailsContext_cons (E : Term.Env Var) (Γ : Context Var (Ty Base))
     (x : Var) (τ : Ty Base) (sub : Term Var)
     (h_fresh : x ∉ E.dom ∪ E.fv ∪ Γ.dom)
     (h_mem : sub ∈ semanticMap τ) :
-    entails_context E Γ → entails_context (⟨ x, sub ⟩ :: E) (⟨ x, τ ⟩ :: Γ) := by
+    entailsContext E Γ → entailsContext (⟨ x, sub ⟩ :: E) (⟨ x, τ ⟩ :: Γ) := by
   grind [multiSubst_fvar_fresh, subst_fresh, multiSubst_preserves_not_fvar]
 
 /-- The `entails` predicate states that a term `t` is
     semantically valid with respect to a context `Γ` and a type `τ` -/
 abbrev entails (Γ : Context Var (Ty Base)) (t : Term Var) (τ : Ty Base) :=
-    ∀ E, env_LC E → (entails_context E Γ) → (multiSubst E t) ∈ semanticMap τ
+    ∀ E, envLC E → entailsContext E Γ → multiSubst E t ∈ semanticMap τ
 
 /-- The `soundness` lemma states that if a term `t` has type `τ` in context `Γ`,
     then `t` is semantically valid with respect to `Γ` and `τ` -/
@@ -111,7 +111,7 @@ lemma soundness {Γ : Context Var (Ty Base)} (derivation_t : Γ ⊢ t ∶ τ) :
     let := multiSubst E t
     have ⟨x, _⟩ := fresh_exists <| E.dom ∪ free_union [fv, Context.dom, Env.fv] Var
     have := IH (x := x) (E := ⟨x,s⟩ :: E)
-    grind [multiSubst_abs, entails_context_cons, multiSubst_open_var]
+    grind [multiSubst_abs, entailsContext_cons, multiSubst_open_var]
   | app => grind [multiSubst_app]
 
 /-- Using soundness and the fact that the empty context
@@ -119,7 +119,7 @@ lemma soundness {Γ : Context Var (Ty Base)} (derivation_t : Γ ⊢ t ∶ τ) :
     a well-typed term is strongly normalizing. -/
 theorem strong_norm {t : Term Var} {τ : Ty Base} (der : Γ ⊢ t ∶ τ) : SN FullBeta t := by
   apply (semanticMap_saturated τ).sn
-  apply (soundness der [] (by grind) entails_context_empty)
+  apply (soundness der [] (by grind) entailsContext_empty)
 
 end LambdaCalculus.LocallyNameless.Stlc
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
index 05db5bab3d..548b3d2c0c 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
@@ -51,10 +51,10 @@ def Env.fv (E : Env Var) : Finset Var :=
 attribute [scoped grind =] Env.fv
 
 /-- An environment is locally closed if all terms in the environment are locally closed -/
-abbrev env_LC (E : Env Var) : Prop := ∀ {x M}, ⟨x, M⟩ ∈ E → LC M
+abbrev envLC (E : Env Var) : Prop := ∀ {x M}, ⟨x, M⟩ ∈ E → LC M
 
 /-- Adding a locally closed term to an environment preserves local closure -/
-lemma env_LC_cons (lc_sub : LC sub) (lc_E : env_LC E) : env_LC (⟨ x, sub ⟩ :: E) := by
+lemma envLC_cons (lc_sub : LC sub) (lc_E : envLC E) : envLC (⟨ x, sub ⟩ :: E) := by
   grind
 
 /-- Multi-substitution of a fresh variable does nothing -/
@@ -81,7 +81,7 @@ lemma multiSubst_abs (M : Term Var) (E : Env Var) :
     provided that the variable is not in the domain of the environment
     and the environment is locally closed -/
 lemma multiSubst_open_var [HasFresh Var] (M : Term Var) (E : Env Var) (x : Var)
-  (h_ndom : x ∉ E.dom) (h_lc : env_LC E) :
+  (h_ndom : x ∉ E.dom) (h_lc : envLC E) :
     multiSubst E (M ^ fvar x) = multiSubst E M ^ fvar x := by
   induction E with grind
 
diff --git a/Cslib/Logics/HML/LogicalEquivalence.lean b/Cslib/Logics/HML/LogicalEquivalence.lean
index 3bd8c11bfd..5bad96e468 100644
--- a/Cslib/Logics/HML/LogicalEquivalence.lean
+++ b/Cslib/Logics/HML/LogicalEquivalence.lean
@@ -105,7 +105,7 @@ instance judgementalContext :
 instance : LogicalEquivalence
     (Proposition Label) (Satisfies.Judgement State Label) (Satisfies.Bundled) where
   eqv := Proposition.Equiv
-  eqv_fill_valid {a b : Proposition Label} (heqv : a.Equiv (State := State) b)
+  eqvFillValid {a b : Proposition Label} (heqv : a.Equiv (State := State) b)
       (c : HasHContext.Context (Satisfies.Judgement State Label) (Proposition Label))
       (h : Satisfies.Bundled c<[a]) : Satisfies.Bundled c<[b] := by
     simp only [Satisfies.bundled_char, HasHContext.fill, Satisfies.Context.fill]
diff --git a/Cslib/Logics/LinearLogic/CLL/Basic.lean b/Cslib/Logics/LinearLogic/CLL/Basic.lean
index bb9b145de7..c331ae2ae8 100644
--- a/Cslib/Logics/LinearLogic/CLL/Basic.lean
+++ b/Cslib/Logics/LinearLogic/CLL/Basic.lean
@@ -114,11 +114,11 @@ def Proposition.negative : Proposition Atom → Bool
   | _ => false
 
 /-- Whether a `Proposition` is positive is decidable. -/
-instance Proposition.positive_decidable (a : Proposition Atom) : Decidable a.positive :=
+instance Proposition.positiveDecidable (a : Proposition Atom) : Decidable a.positive :=
   a.positive.decEq true
 
 /-- Whether a `Proposition` is negative is decidable. -/
-instance Proposition.negative_decidable (a : Proposition Atom) : Decidable a.negative :=
+instance Proposition.negativeDecidable (a : Proposition Atom) : Decidable a.negative :=
   a.negative.decEq true
 
 /-- Propositional duality. -/
@@ -225,21 +225,21 @@ def Proof.cut' (p : ⇓(a⫠ ::ₘ Γ)) (q : ⇓(a ::ₘ Δ)) : ⇓(Γ + Δ) :=
   p.cut r
 
 /-- Inversion of the ⅋ rule. -/
-def Proof.parr_inversion {Γ : Sequent Atom} (h : ⇓((a ⅋ b) ::ₘ Γ)) : ⇓(a ::ₘ b ::ₘ Γ) :=
+def Proof.parrInversion {Γ : Sequent Atom} (h : ⇓((a ⅋ b) ::ₘ Γ)) : ⇓(a ::ₘ b ::ₘ Γ) :=
   show a ::ₘ b ::ₘ Γ = {a, b} + Γ by simp ▸
     cut' (show ({a, b} : Sequent Atom) = {a} + {b} by simp ▸ tensor ax' ax') h
 
 /-- Inversion of the ⊥ rule. -/
-def Proof.bot_inversion {Γ : Sequent Atom} (h : ⇓(⊥ ::ₘ Γ)) : ⇓Γ := by
+def Proof.botInversion {Γ : Sequent Atom} (h : ⇓(⊥ ::ₘ Γ)) : ⇓Γ := by
   convert Proof.cut' (a := ⊥) (Γ := {}) (Δ := Γ) Proof.one h
   simp
 
 /-- Inversion of the & rule, first component. -/
-def Proof.with_inversion₁ {Γ : Sequent Atom} (h : ⇓((a & b) ::ₘ Γ)) : ⇓(a ::ₘ Γ) :=
+def Proof.withInversion₁ {Γ : Sequent Atom} (h : ⇓((a & b) ::ₘ Γ)) : ⇓(a ::ₘ Γ) :=
   cut' (a := a & b) (oplus₁ ax') h
 
 /-- Inversion of the & rule, second component. -/
-def Proof.with_inversion₂ {Γ : Sequent Atom} (h : ⇓((a & b) ::ₘ Γ)) : ⇓(b ::ₘ Γ) :=
+def Proof.withInversion₂ {Γ : Sequent Atom} (h : ⇓((a & b) ::ₘ Γ)) : ⇓(b ::ₘ Γ) :=
   cut' (a := a & b) (oplus₂ ax') h
 
 section LogicalEquiv
@@ -314,23 +314,23 @@ instance : IsEquiv (Proposition Atom) Proposition.Equiv where
 
 /-- !⊤ ≡⇓ 1 -/
 @[scoped grind =]
-def bang_top_eqv_one : (!⊤ : Proposition Atom) ≡⇓ 1 :=
+def bangTopEqvOne : (!⊤ : Proposition Atom) ≡⇓ 1 :=
   ⟨.weaken .one, .bot (.bang rfl .top)⟩
 
 /-- ʔ0 ≡⇓ ⊥ -/
 @[scoped grind =]
-def quest_zero_eqv_bot : (ʔ0 : Proposition Atom) ≡⇓ ⊥ :=
+def questZeroEqvBot : (ʔ0 : Proposition Atom) ≡⇓ ⊥ :=
   ⟨rwConclusion (Multiset.pair_comm ..) <| .bot (.bang rfl .top),
    rwConclusion (Multiset.pair_comm ..) <| .weaken .one⟩
 
 /-- a ⊗ 0 ≡⇓ 0 -/
 @[scoped grind =]
-def tensor_zero_eqv_zero (a : Proposition Atom) : a ⊗ 0 ≡⇓ 0 :=
+def tensorZeroEqvZero (a : Proposition Atom) : a ⊗ 0 ≡⇓ 0 :=
   ⟨.parr <| .rwConclusion (Multiset.cons_swap ..) .top, .top⟩
 
 /-- a ⅋ ⊤ ≡⇓ ⊤ -/
 @[scoped grind =]
-def parr_top_eqv_top (a : Proposition Atom) : a ⅋ ⊤ ≡⇓ ⊤ :=
+def parrTopEqvTop (a : Proposition Atom) : a ⅋ ⊤ ≡⇓ ⊤ :=
   ⟨.rwConclusion (Multiset.cons_swap ..) .top,
    .rwConclusion (Multiset.cons_swap ..) <| .parr <| .rwConclusion (Multiset.cons_swap ..) .top⟩
 
@@ -343,7 +343,7 @@ attribute [local grind =] Multiset.insert_eq_cons
 
 open scoped Multiset in
 /-- ⊗ distributes over ⊕. -/
-def tensor_distrib_oplus (a b c : Proposition Atom) : a ⊗ (b ⊕ c) ≡⇓ (a ⊗ b) ⊕ (a ⊗ c) :=
+def tensorDistribOplus (a b c : Proposition Atom) : a ⊗ (b ⊕ c) ≡⇓ (a ⊗ b) ⊕ (a ⊗ c) :=
   ⟨.parr <|
     .rwConclusion (Multiset.cons_swap ..) <|
     .with
@@ -362,7 +362,7 @@ def tensor_distrib_oplus (a b c : Proposition Atom) : a ⊗ (b ⊕ c) ≡⇓ (a
 /-- The proposition at the head of a proof can be substituted by an equivalent
   proposition. -/
 @[scoped grind =]
-def subst_eqv_head {Γ : Sequent Atom} (heqv : a ≡⇓ b) (p : ⇓(a ::ₘ Γ)) : ⇓(b ::ₘ Γ) :=
+def substEqvHead {Γ : Sequent Atom} (heqv : a ≡⇓ b) (p : ⇓(a ::ₘ Γ)) : ⇓(b ::ₘ Γ) :=
   show b ::ₘ Γ = Γ + {b} by grind ▸ p.cut heqv.1
 
 theorem add_middle_eq_cons {a : Proposition Atom} : Γ + {a} + Δ = a ::ₘ (Γ + Δ) := by
@@ -372,8 +372,8 @@ open scoped Multiset in
 /-- Any proposition in a proof (regardless of its position) can be substituted by
   an equivalent proposition. -/
 @[scoped grind =]
-def subst_eqv {Γ Δ : Sequent Atom} (heqv : a ≡⇓ b) (p : ⇓(Γ + {a} + Δ)) : ⇓(Γ + {b} + Δ) :=
-  add_middle_eq_cons ▸ subst_eqv_head heqv (add_middle_eq_cons ▸ p)
+def substEqv {Γ Δ : Sequent Atom} (heqv : a ≡⇓ b) (p : ⇓(Γ + {a} + Δ)) : ⇓(Γ + {b} + Δ) :=
+  add_middle_eq_cons ▸ substEqvHead heqv (add_middle_eq_cons ▸ p)
 
 open scoped Context
 
@@ -652,14 +652,14 @@ instance : Congruence (Proposition Atom) Proposition.Equiv where
 
 noncomputable instance : LogicalEquivalence (Proposition Atom) (Sequent Atom) Proof where
   eqv := Proposition.Equiv
-  eqv_fill_valid {a b : Proposition Atom} (heqv : a.Equiv b)
+  eqvFillValid {a b : Proposition Atom} (heqv : a.Equiv b)
       (c : HasHContext.Context (Sequent Atom) (Proposition Atom))
       (h : ⇓c<[a]) : ⇓c<[b] := by
-    apply subst_eqv_head (chooseEquiv heqv) h
+    apply substEqvHead (chooseEquiv heqv) h
 
 /-- Tensor is commutative. -/
 @[scoped grind ←]
-def tensor_symm {a b : Proposition Atom} : a ⊗ b ≡⇓ b ⊗ a :=
+def tensorSymm {a b : Proposition Atom} : a ⊗ b ≡⇓ b ⊗ a :=
   ⟨.parr <| show a⫠ ::ₘ b⫠ ::ₘ {b ⊗ a} = (b ⊗ a) ::ₘ {b⫠} + {a⫠} by grind ▸ .tensor .ax .ax,
    .parr <| show b⫠ ::ₘ a⫠ ::ₘ {a ⊗ b} = (a ⊗ b) ::ₘ {a⫠} + {b⫠} by grind ▸ .tensor .ax .ax⟩
 
@@ -667,7 +667,7 @@ def tensor_symm {a b : Proposition Atom} : a ⊗ b ≡⇓ b ⊗ a :=
 open scoped Multiset in
 /-- ⊗ is associative. -/
 @[scoped grind ←]
-def tensor_assoc {a b c : Proposition Atom} : a ⊗ (b ⊗ c) ≡⇓ (a ⊗ b) ⊗ c :=
+def tensorAssoc {a b c : Proposition Atom} : a ⊗ (b ⊗ c) ≡⇓ (a ⊗ b) ⊗ c :=
   ⟨.parr <|
      Multiset.cons_swap .. ▸
      (.parr <|
@@ -679,17 +679,17 @@ def tensor_assoc {a b c : Proposition Atom} : a ⊗ (b ⊗ c) ≡⇓ (a ⊗ b) 
      (.tensor .ax <| .tensor .ax .ax)⟩
 
 instance {Γ : Sequent Atom} : Std.Symm (fun a b => Derivable ((a ⊗ b) ::ₘ Γ)) where
-  symm _ _ h := DerivableIn.fromDerivation (subst_eqv_head tensor_symm (DerivableIn.toDerivation h))
+  symm _ _ h := DerivableIn.fromDerivation (substEqvHead tensorSymm (DerivableIn.toDerivation h))
 
 /-- ⊕ is idempotent. -/
 @[scoped grind ←]
-def oplus_idem {a : Proposition Atom} : a ⊕ a ≡⇓ a :=
+def oplusIdem {a : Proposition Atom} : a ⊕ a ≡⇓ a :=
   ⟨.with .ax' .ax',
    show ({a⫠, a ⊕ a} : Sequent Atom) = {a ⊕ a, a⫠} by grind ▸ .oplus₁ .ax⟩
 
 /-- & is idempotent. -/
 @[scoped grind ←]
-def with_idem {a : Proposition Atom} : a & a ≡⇓ a :=
+def withIdem {a : Proposition Atom} : a & a ≡⇓ a :=
   ⟨.oplus₁ .ax',
    show ({a⫠, a & a} : Sequent Atom) = {a & a, a⫠} by grind ▸ .with .ax .ax⟩
 
diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
index 7f7a237131..df33df215b 100644
--- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
+++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
@@ -179,7 +179,7 @@ lemma of_Fact {G : Fact P} {p : P}
 @[scoped grind =, simp] lemma mem_carrier (G : Fact P) : G.carrier = (G : Set P) := rfl
 
 /-- Construct a fact from a set G and a proof that its biorthogonal closure is contained in G. -/
-@[simps] def Fact.mk_subset (G : Set P) (h : G⫠⫠ ⊆ G) : Fact P where
+@[simps] def Fact.mkSubset (G : Set P) (h : G⫠⫠ ⊆ G) : Fact P where
   carrier := G
   property := by grind [isFact, orth_extensive]
 
@@ -187,8 +187,8 @@ lemma dual_subset_dual {G H : Set P} (h : G ⊆ H) :
     H⫠ ⊆ G⫠ := fun _ hp _ hq => hp _ (h hq)
 
 /-- Construct a fact from a set G and a proof that G equals the orthogonal of some set H. -/
-@[simps!] def Fact.mk_dual (G H : Set P) (h : G = H⫠) : Fact P :=
-  Fact.mk_subset G <| by rw [h, triple_orth]
+@[simps!] def Fact.mkDual (G H : Set P) (h : G = H⫠) : Fact P :=
+  Fact.mkSubset G <| by rw [h, triple_orth]
 
 lemma coe_mk {X : Set P} {h : isFact X} : ((⟨X, h⟩ : Fact P) : Set P) = X := rfl
 
@@ -205,7 +205,7 @@ lemma orth_one_eq_bot :
     simpa [orthogonal, mem_setOf, mul_one] using hm
 
 /-- The fact given by the dual of G. -/
-@[simps!] def dualFact (G : Set P) : Fact P := Fact.mk_dual (G⫠) G rfl
+@[simps!] def dualFact (G : Set P) : Fact P := Fact.mkDual (G⫠) G rfl
 
 lemma dual_dual_subset_Fact_iff {G : Set P} {H : Fact P} : G⫠⫠ ⊆ H ↔ G ⊆ H := by
   constructor <;> rw [H.eq] <;> grind
@@ -227,7 +227,7 @@ lemma mul_mem_one (hp : p ∈ (1 : Fact P)) (hq : q ∈ (1 : Fact P)) : p * q 
   grind
 
 instance : Top (Fact P) where
-  top := Fact.mk_subset Set.univ <| fun _ _ => Set.mem_univ _
+  top := Fact.mkSubset Set.univ <| fun _ _ => Set.mem_univ _
 
 @[scoped grind =, simp] lemma coe_top : ((⊤ : Fact P) : Set P) = Set.univ := rfl
 
@@ -246,7 +246,7 @@ lemma mem_zero : p ∈ (0 : Fact P) ↔ ∀ q, p * q ∈ PhaseSpace.bot := by
   simp [← SetLike.mem_coe]
 
 instance : Bot (Fact P) where
-  bot := Fact.mk_dual (PhaseSpace.bot : Set P) {1} (orth_one_eq_bot).symm
+  bot := Fact.mkDual (PhaseSpace.bot : Set P) {1} (orth_one_eq_bot).symm
 
 /-- In a phase space, `G⫠⫠` is the smallest fact containing `G`. -/
 lemma biorth_least_fact (G : Set P) :
@@ -326,7 +326,7 @@ lemma inter_eq_orth_union_orth (G H : Fact P) :
     grind [Fact.eq]
 
 instance : Min (Fact P) where
-  min G H := Fact.mk_dual (G ∩ H) (G⫠ ∪ H⫠) <| by simp
+  min G H := Fact.mkDual (G ∩ H) (G⫠ ∪ H⫠) <| by simp
 
 @[simp] lemma coe_min {G H : Fact P} : ((G ⊓ H : Fact P) : Set P) = (G : Set P) ∩ H := rfl
 
@@ -394,7 +394,7 @@ def parr (X Y : Fact P) : Fact P := dualFact ((X⫠) * (Y⫠))
   refine SetLike.coe_injective ?_
   rw [tensor]
   refine Set.Subset.antisymm ?_ ?_
-  · simp only [dualFact, mk_dual, mk_subset, coe_mk]
+  · simp only [dualFact, mkDual, mkSubset, coe_mk]
     rw [dual_dual_subset_Fact_iff]
     grind [SetLike.mem_coe, Set.mem_mul]
   · exact Set.Subset.trans (orth_extensive _) <| orth_antitone <| orth_antitone <|
@@ -417,7 +417,7 @@ lemma coe_tensor_assoc {G H K : Fact P} :
     ((G ⊗ H) ⊗ K : Set P) = ((G : Set P) * ((H : Set P) * (K : Set P)))⫠⫠ := by
   simp only [tensor]
   refine Set.Subset.antisymm ?_ ?_
-  · simp only [dualFact, mk_dual, mk_subset, coe_mk, dual_dual_subset_dual_iff]
+  · simp only [dualFact, mkDual, mkSubset, coe_mk, dual_dual_subset_dual_iff]
     rw [K.eq]
     refine tensor_assoc_aux.trans ?_
     rw [← K.eq]
@@ -442,7 +442,7 @@ lemma tensor_le_tensor {G K H} {L : Fact P} (hGK : G ≤ K) (hHL : H ≤ L) : (G
 
 lemma tensor_of_par {G H : Fact P} : (G ⊗ H) = (Gᗮ ⅋ Hᗮ)ᗮ :=
   SetLike.coe_injective <| by
-    simp only [tensor, parr, dualFact, mk_dual, mk_subset, coe_mk]
+    simp only [tensor, parr, dualFact, mkDual, mkSubset, coe_mk]
     rw [G.eq, H.eq]
     #adaptation_note
     /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/
@@ -471,7 +471,7 @@ def linImpl (X Y : Fact P) : Fact P := dualFact ((X : Set P) * (Y : Set P)⫠)
 
 lemma linImpl_of_tensor {G H : Fact P} : (G ⊸ H) = (G ⊗ Hᗮ)ᗮ :=
   SetLike.coe_injective <| by
-    simp only [linImpl, tensor, coe_neg, dualFact, mk_dual, mk_subset, coe_mk]
+    simp only [linImpl, tensor, coe_neg, dualFact, mkDual, mkSubset, coe_mk]
     apply Set.Subset.antisymm <;> grind
 
 lemma par_of_linImpl {G H : Fact P} : (G ⅋ H) = (Gᗮ ⊸ H) :=
@@ -589,14 +589,14 @@ lemma le_plus_right {G H : Fact P} : H ≤ G ⊕ H := fun _ hx ↦
 
 lemma tensor_distrib_plus : (G ⊗ (H ⊕ K) : Fact P) = (G ⊗ H) ⊕ (G ⊗ K) := by
   refine SetLike.coe_injective <| Set.Subset.antisymm ?_ ?_
-  · rw [tensor, dualFact, mk_dual_coe, oplus, dualFact, mk_dual_coe]
+  · rw [tensor, dualFact, mkDual_coe, oplus, dualFact, mkDual_coe]
     rw [dual_dual_subset_Fact_iff, G.eq]
     refine tensor_assoc_aux.trans ?_
-    rw [Set.mul_union, oplus, dualFact, mk_dual_coe, tensor, dualFact, mk_dual_coe]
+    rw [Set.mul_union, oplus, dualFact, mkDual_coe, tensor, dualFact, mkDual_coe]
     exact dual_subset_dual <| dual_subset_dual <|
       Set.union_subset_union subset_dual_dual subset_dual_dual
-  · rw [oplus, dualFact, mk_dual_coe, dual_dual_subset_Fact_iff, tensor, dualFact, mk_dual_coe,
-      tensor, dualFact, mk_dual_coe, Set.union_subset_iff]
+  · rw [oplus, dualFact, mkDual_coe, dual_dual_subset_Fact_iff, tensor, dualFact, mkDual_coe,
+      tensor, dualFact, mkDual_coe, Set.union_subset_iff]
     simp only [dual_dual_subset_Fact_iff]
     exact ⟨(Set.mul_subset_mul_left le_plus_left).trans mul_subset_tensor,
            (Set.mul_subset_mul_left le_plus_right).trans mul_subset_tensor⟩
@@ -640,7 +640,7 @@ lemma par_semi_distrib_plus : ((G ⅋ H) ⊕ (G ⅋ K) : Fact P) ≤ G ⅋ (H 
   rw [coe_top]
   rw [Set.eq_univ_iff_forall]
   intro x
-  simp only [parr, dualFact, mk_dual, mk_subset, coe_mk, coe_top]
+  simp only [parr, dualFact, mkDual, mkSubset, coe_mk, coe_top]
   rw [PhaseSpace.orthogonal_def, Set.mem_setOf_eq]
   intro w hw
   rcases Set.mem_mul.mp hw with ⟨y, hy, z, hz, rfl⟩
diff --git a/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean b/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean
index fd3853c563..b1a8947e20 100644
--- a/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean
+++ b/Cslib/Logics/Propositional/NaturalDeduction/Basic.lean
@@ -183,12 +183,12 @@ def Theory.Derivation.weak {T T' : Theory Atom} {Γ Δ : Ctx Atom} {A : Proposit
   | implE D D' => implE (D.weak hTheory hCtx) (D'.weak hTheory hCtx)
 
 /-- Weakening the theory only. -/
-def Theory.Derivation.weak_theory {T T' : Theory Atom} {Γ : Ctx Atom} {A : Proposition Atom}
+def Theory.Derivation.weakTheory {T T' : Theory Atom} {Γ : Ctx Atom} {A : Proposition Atom}
     (hTheory : T ⊆ T') : T⇓(Γ ⊢ A) → T'⇓(Γ ⊢ A):=
   Derivation.weak hTheory Finset.Subset.rfl
 
 /-- Weakening the context only. -/
-def Theory.Derivation.weak_ctx {T : Theory Atom} {Γ Δ : Ctx Atom} {A : Proposition Atom}
+def Theory.Derivation.weakCtx {T : Theory Atom} {Γ Δ : Ctx Atom} {A : Proposition Atom}
     (hCtx : Γ ⊆ Δ) : T⇓(Γ ⊢ A) → T⇓(Δ ⊢ A) :=
   Derivation.weak Set.Subset.rfl hCtx
 
@@ -198,14 +198,14 @@ theorem DerivableIn.weak {T T' : Theory Atom} {Γ Δ : Ctx Atom} {A : Propositio
   | ⟨D⟩ => ⟨D.weak hTheory hCtx⟩
 
 /-- Proof irrelevant weakening of the theory. -/
-theorem DerivableIn.weak_theory {T T' : Theory Atom} {Γ : Ctx Atom} {A : Proposition Atom}
+theorem DerivableIn.weakTheory {T T' : Theory Atom} {Γ : Ctx Atom} {A : Proposition Atom}
     (hTheory : T ⊆ T') : DerivableIn T (Γ ⊢ A) → DerivableIn T' (Γ ⊢ A)
-  | ⟨D⟩ => ⟨D.weak_theory hTheory⟩
+  | ⟨D⟩ => ⟨D.weakTheory hTheory⟩
 
 /-- Proof irrelevant weakening of the context. -/
-theorem DerivableIn.weak_ctx {T : Theory Atom} {Γ Δ : Ctx Atom} {A : Proposition Atom}
+theorem DerivableIn.weakCtx {T : Theory Atom} {Γ Δ : Ctx Atom} {A : Proposition Atom}
     (hCtx : Γ ⊆ Δ) : DerivableIn T (Γ ⊢ A) → DerivableIn T (Δ ⊢ A)
-  | ⟨D⟩ => ⟨D.weak_ctx hCtx⟩
+  | ⟨D⟩ => ⟨D.weakCtx hCtx⟩
 
 /--
 Implement the cut rule, removing a hypothesis `A` from `E` using a derivation `D`. This is *not*
@@ -213,9 +213,9 @@ substitution, which would replace appeals to `A` in `E` by the whole derivation
 -/
 def Theory.Derivation.cut {Γ Δ : Ctx Atom} {A B : Proposition Atom}
     (D : T⇓(Γ ⊢ A)) (E : T⇓(insert A Δ ⊢ B)) : T⇓((Γ ∪ Δ) ⊢ B) := by
-  refine implE (A := A) ?_ (D.weak_ctx Finset.subset_union_left)
+  refine implE (A := A) ?_ (D.weakCtx Finset.subset_union_left)
   have : insert A Δ ⊆ insert A (Γ ∪ Δ) := by grind
-  exact implI (Γ ∪ Δ) <| E.weak_ctx this
+  exact implI (Γ ∪ Δ) <| E.weakCtx this
 
 /-- Proof irrelevant cut rule. -/
 theorem DerivableIn.cut {Γ Δ : Ctx Atom} {A B : Proposition Atom} :
@@ -228,7 +228,7 @@ theorem DerivableIn.cut_away {Γ Γ' : Ctx Atom} {B : Proposition Atom}
     (hΔ : ∀ A ∈ Γ', DerivableIn T (Γ ⊢ A)) (hDer : DerivableIn T ((Γ ∪ Γ') ⊢ B)) :
     DerivableIn T (Γ ⊢ B) := by
   induction Γ' using Finset.induction with
-  | empty => exact DerivableIn.weak_ctx (by grind) hDer
+  | empty => exact DerivableIn.weakCtx (by grind) hDer
   | insert A Δ hA ih =>
     apply ih
     · intro A' hA'
@@ -246,7 +246,7 @@ def Theory.Derivation.subs {Γ Γ' Δ : Ctx Atom} {B : Proposition Atom}
   | @ass _ _ _ _ B hB => by
     by_cases B ∈ Γ'
     case pos h =>
-      exact (Ds B h).weak_ctx <| by grind
+      exact (Ds B h).weakCtx <| by grind
     case neg h =>
       exact ass <| by grind
   | andI E E' => andI (E.subs Ds) (E'.subs Ds)
@@ -257,13 +257,13 @@ def Theory.Derivation.subs {Γ Γ' Δ : Ctx Atom} {B : Proposition Atom}
   | @orE _ _ _ _ C C' _ E E' E'' .. => by
     apply orE (E.subs Ds)
     · rw [show insert C (Γ \ Γ' ∪ Δ) = (insert C Γ \ Γ') ∪ insert C Δ by grind]
-      exact E'.subs Ds |>.weak_ctx (by grind)
+      exact E'.subs Ds |>.weakCtx (by grind)
     · rw [show insert C' (Γ \ Γ' ∪ Δ) = (insert C' Γ \ Γ') ∪ insert C' Δ by grind]
-      exact E''.subs Ds |>.weak_ctx (by grind)
+      exact E''.subs Ds |>.weakCtx (by grind)
   | @implI _ _ _ A' _ _ E .. => by
     apply implI
     rw [show insert A' (Γ \ Γ' ∪ Δ) = (insert A' Γ \ Γ') ∪ insert A' Δ by grind]
-    exact E.subs Ds |>.weak_ctx (by grind)
+    exact E.subs Ds |>.weakCtx (by grind)
   | implE E E' => implE (E.subs Ds) (E'.subs Ds)
 
 /-- Transport a derivation along a substitution of atoms. -/
@@ -300,9 +300,9 @@ theorem derivableIn_top [Inhabited Atom] : DerivableIn T (⊤ : Proposition Atom
 theorem derivable_iff_equiv_top [Inhabited Atom] (A : Proposition Atom) :
     DerivableIn T A ↔ A ≡[T] ⊤ := by
   constructor <;> intro h
-  · refine ⟨derivationTop.weak_ctx <| by grind, ?_⟩
+  · refine ⟨derivationTop.weakCtx <| by grind, ?_⟩
     let D := Classical.choice h
-    exact D.weak_ctx <| by grind
+    exact D.weakCtx <| by grind
   · have := DerivableIn.cut (derivableIn_top (T := T)) (B := A) (Δ := ∅)
     rw [←show (∅ : Ctx Atom) = ∅ ∪ ∅ by rfl] at this
     exact this h.mpr
diff --git a/CslibTests/CLL.lean b/CslibTests/CLL.lean
index 47c6bda616..55f15b98fc 100644
--- a/CslibTests/CLL.lean
+++ b/CslibTests/CLL.lean
@@ -119,15 +119,15 @@ example (h : (a : P) ≡ b) : b ≡ a := Proposition.Equiv.symm h
 example (hab : (a : P) ≡ b) (hbc : b ≡ c) : a ≡ c := Proposition.Equiv.trans hab hbc
 
 -- Coercion from proof-relevant to proof-irrelevant (via .toProp)
-example : (!⊤ : P) ≡ 1 := Proposition.bang_top_eqv_one.toProp
-example : (ʔ0 : P) ≡ ⊥ := Proposition.quest_zero_eqv_bot.toProp
-example : (a ⊗ 0 : P) ≡ 0 := (Proposition.tensor_zero_eqv_zero a).toProp
-example : (a ⅋ ⊤ : P) ≡ ⊤ := (Proposition.parr_top_eqv_top a).toProp
-example : (a ⊗ b : P) ≡ b ⊗ a := Proposition.tensor_symm.toProp
-example : (a ⊗ (b ⊗ c) : P) ≡ (a ⊗ b) ⊗ c := Proposition.tensor_assoc.toProp
-example : (a ⊗ (b ⊕ c) : P) ≡ (a ⊗ b) ⊕ (a ⊗ c) := (Proposition.tensor_distrib_oplus a b c).toProp
-example : (a ⊕ a : P) ≡ a := Proposition.oplus_idem.toProp
-example : (a & a : P) ≡ a := Proposition.with_idem.toProp
+example : (!⊤ : P) ≡ 1 := Proposition.bangTopEqvOne.toProp
+example : (ʔ0 : P) ≡ ⊥ := Proposition.questZeroEqvBot.toProp
+example : (a ⊗ 0 : P) ≡ 0 := (Proposition.tensorZeroEqvZero a).toProp
+example : (a ⅋ ⊤ : P) ≡ ⊤ := (Proposition.parrTopEqvTop a).toProp
+example : (a ⊗ b : P) ≡ b ⊗ a := Proposition.tensorSymm.toProp
+example : (a ⊗ (b ⊗ c) : P) ≡ (a ⊗ b) ⊗ c := Proposition.tensorAssoc.toProp
+example : (a ⊗ (b ⊕ c) : P) ≡ (a ⊗ b) ⊕ (a ⊗ c) := (Proposition.tensorDistribOplus a b c).toProp
+example : (a ⊕ a : P) ≡ a := Proposition.oplusIdem.toProp
+example : (a & a : P) ≡ a := Proposition.withIdem.toProp
 
 
 /-! ## Proof-relevant equivalence tests -/
@@ -142,25 +142,25 @@ example (h : (a : P) ≡⇓ b) : b ≡⇓ a := Proposition.equiv.symm a h
 example (hab : (a : P) ≡⇓ b) (hbc : (b : P) ≡⇓ c) : a ≡⇓ c := Proposition.equiv.trans hab hbc
 
 -- Proof-relevant versions of logical equivalences
-example : (!⊤ : P) ≡⇓ 1 := Proposition.bang_top_eqv_one
-example : (ʔ0 : P) ≡⇓ ⊥ := Proposition.quest_zero_eqv_bot
-example : (a ⊗ b : P) ≡⇓ b ⊗ a := Proposition.tensor_symm
-example : (a ⊗ (b ⊗ c) : P) ≡⇓ (a ⊗ b) ⊗ c := Proposition.tensor_assoc
-example : (a ⊕ a : P) ≡⇓ a := Proposition.oplus_idem
-example : (a & a : P) ≡⇓ a := Proposition.with_idem
+example : (!⊤ : P) ≡⇓ 1 := Proposition.bangTopEqvOne
+example : (ʔ0 : P) ≡⇓ ⊥ := Proposition.questZeroEqvBot
+example : (a ⊗ b : P) ≡⇓ b ⊗ a := Proposition.tensorSymm
+example : (a ⊗ (b ⊗ c) : P) ≡⇓ (a ⊗ b) ⊗ c := Proposition.tensorAssoc
+example : (a ⊕ a : P) ≡⇓ a := Proposition.oplusIdem
+example : (a & a : P) ≡⇓ a := Proposition.withIdem
 
 
 /-! ## Inversion tests -/
 
--- parr_inversion
-example (h : ⇓({a ⅋ b} : Sequent Nat)) : ⇓({a, b} : Sequent Nat) := Proof.parr_inversion h
+-- parrInversion
+example (h : ⇓({a ⅋ b} : Sequent Nat)) : ⇓({a, b} : Sequent Nat) := Proof.parrInversion h
 
--- bot_inversion
-example (h : ⇓({⊥, 1} : Sequent Nat)) : ⇓({1} : Sequent Nat) := Proof.bot_inversion h
+-- botInversion
+example (h : ⇓({⊥, 1} : Sequent Nat)) : ⇓({1} : Sequent Nat) := Proof.botInversion h
 
 -- with_inversion
-example (h : ⇓({a & b} : Sequent Nat)) : ⇓({a} : Sequent Nat) := Proof.with_inversion₁ h
-example (h : ⇓({a & b} : Sequent Nat)) : ⇓({b} : Sequent Nat) := Proof.with_inversion₂ h
+example (h : ⇓({a & b} : Sequent Nat)) : ⇓({a} : Sequent Nat) := Proof.withInversion₁ h
+example (h : ⇓({a & b} : Sequent Nat)) : ⇓({b} : Sequent Nat) := Proof.withInversion₂ h
 
 
 /-! ## Positive/Negative classification tests -/
diff --git a/lake-manifest.json b/lake-manifest.json
index ca8591cf36..1b6933333f 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,10 +5,10 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5",
+   "rev": "d8de6b61f073daf518577b643724875545b98e89",
    "name": "mathlib",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5",
+   "inputRev": "d8de6b61f073daf518577b643724875545b98e89",
    "inherited": false,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/plausible",
@@ -35,7 +35,7 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "cdab3938ccabbdb044be6896e251b5814bec932e",
+   "rev": "fd70b40073aeca8fa60fe0fb492f189d3b12c0ef",
    "name": "importGraph",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -75,10 +75,10 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "5c57f3857ba81924a88b2cdf4f062e34ec04ff11",
+   "rev": "4ee56e687ce2b9b51b097bfa65947a499da0c453",
    "name": "batteries",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "main",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover/lean4-cli",
diff --git a/lakefile.toml b/lakefile.toml
index 4169d4b8e6..92c711279e 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false
 [[require]]
 name = "mathlib"
 scope = "leanprover-community"
-rev = "6cf3ab1c11e19e328c2e535bdd32d66dc7842fb5"
+rev = "d8de6b61f073daf518577b643724875545b98e89"
 
 [[lean_lib]]
 name = "Cslib"

From c6bb800929dde8c1ab62f2f9ff74bba198644ec6 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Tue, 26 May 2026 12:34:18 +0800
Subject: [PATCH 077/106] feat(locallynameless): signature of fv theorems 
 (#588)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This PR refactors several free‑variable (`fv`) lemmas in the Locally
Nameless Lambda Calculus library to make the API more uniform,
algebraic, and easier to use. The changes focus on replacing
negative‑membership lemmas with equalities of `fv` sets, consolidating
redundant lemmas, and updating downstream proofs accordingly.

---

## What’s changed

### 1. Rename and consolidate closing lemmas
- `close_preserve_not_fvar` is replaced with the more general and
consistently named
**`close_rec_fv`**, which states the same property using a cleaner proof
structure
- The old `close_var_not_fvar_rec` and its specialization are removed.
A simpler lemma **`close_var_not_fvar`** now derives directly from
`close_rec_fv`


### 2. Strengthen theorem signatures for opening and substitution
Several lemmas now express **equalities of free‑variable sets** instead
of
“`x ∉ …`”‑style statements:

- **`open_preserve_not_fvar`** now states that opening yields either
  ```
  m⟦k ↝ n⟧.fv = m.fv ∪ n.fv
  ```
  or
  ```
  m⟦k ↝ n⟧.fv = m.fv
  ```
  replacing the previous negative‑membership lemma


- **`subst_preserve_not_fvar`** now characterizes substitution via:
  ```
  (m[y := n]).fv = m.fv.erase y ∪ n.fv
  ```
again replacing a negated membership lemma with a structural equality


These equalities are more compositional and better suited for downstream
reasoning.

### 3. Update dependent proofs
Proofs that relied on the old lemma names or signatures—particularly in
`open_close_to_subst`—are updated to use:

- `close_rec_fv` instead of the removed lemma
- the new `open_preserve_not_fvar` signature
- the updated `subst_preserve_not_fvar` behavior

### 4. Rename `open_close_to_subst` to `close_open_to_subst` and
generalize

### 5. Minor cleanup
- Adds `@[scoped grind]` annotations for consistency.
- Slightly reorganizes lemma order for readability.





Aggregation of #579, #585 and #586

PR description is generated by Copilot

---------

Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
---
 .../LocallyNameless/Untyped/FullBeta.lean     |  6 ++--
 .../Untyped/FullBetaEtaConfluence.lean        |  4 +--
 .../LocallyNameless/Untyped/FullEta.lean      |  4 +--
 .../LocallyNameless/Untyped/MultiSubst.lean   |  4 +--
 .../LocallyNameless/Untyped/Properties.lean   | 33 +++++++++----------
 5 files changed, 24 insertions(+), 27 deletions(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
index f9a5f00c86..698f52b6ca 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
@@ -98,13 +98,13 @@ lemma redex_subst_cong (s s' : Term Var) (x y : Var) (step : s ⭢βᶠ s') :
   redex_subst_cong_lc _ _ _ _ step (.fvar y)
 
 /-- An β-reduction step does not introduce new free variables. -/
-lemma step_not_fv (step : M ⭢βᶠ N) (hw : w ∉ M.fv) : w ∉ N.fv := by
+lemma step_not_fv (step : M ⭢βᶠ N) : N.fv ⊆ M.fv := by
   induction step with
   | base h => cases h with | beta => grind [open_preserve_not_fvar]
-  | abs =>
+  | @abs M N =>
     have ⟨x, _⟩ := fresh_exists <| free_union [fv] Var
     have := open_close x
-    grind [close_preserve_not_fvar, open_preserve_not_fvar]
+    grind [open_preserve_not_fvar 0 M N]
   | _ => grind
 
 /-- Abstracting then closing preserves a single reduction. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
index d56359e8ad..989142ac67 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaEtaConfluence.lean
@@ -74,9 +74,9 @@ lemma stronglyCommute_eta_beta : StronglyCommute (@FullEta Var) FullBeta := by
       cases h_eta with | eta =>
         have ⟨w, _⟩ := fresh_exists <| free_union [fv] Var
         have st_beta_w : app y₁ (fvar w) ⭢βᶠ N ^ fvar w := by grind [st_body_beta w]
-        rcases invert_step_app_fvar st_beta_w with ⟨u', _, st_u⟩ | ⟨u1, _, _⟩
+        rcases invert_step_app_fvar st_beta_w with ⟨u', h, st_u⟩ | ⟨u1, _, _⟩
         · use u'
-          grind [open_eq_app ?_ (step_not_fv st_u ?_)]
+          apply open_eq_app at h <;> grind [FullBeta.step_not_fv st_u]
         · use abs u1
           grind [open_injective w N u1]
     case abs S ys st_body_eta =>
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
index 517ce78683..856541e6e3 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
@@ -71,13 +71,13 @@ lemma invert_step_app_fvar (step : (app M (fvar x)) ⭢ηᶠ N) :
 variable [HasFresh Var] [DecidableEq Var]
 
 /-- An η-reduction step does not introduce new free variables. -/
-lemma step_not_fv (step : M ⭢ηᶠ M') (hw : w ∉ M.fv) : w ∉ M'.fv := by
+lemma step_not_fv (step : M ⭢ηᶠ M') : M.fv = M'.fv := by
   induction step with
   | base => grind
   | abs =>
     have ⟨x, _⟩ := fresh_exists <| free_union [fv] Var
     have := open_close x
-    grind [close_preserve_not_fvar, open_preserve_not_fvar]
+    grind [open_preserve_not_fvar]
   | _ => grind
 
 /-- Substitution of a fresh variable preserves an η-reduction step. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
index 548b3d2c0c..4cf0657415 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
@@ -63,8 +63,8 @@ lemma multiSubst_fvar_fresh (E : Env Var) : ∀ x ∉ E.dom, multiSubst E (fvar
 
 /-- If x is neither a free variable of an environment Ns or a term M, then
     x is also not a free variable of the multi-substitution of Ns into M -/
-lemma multiSubst_preserves_not_fvar (M : Term Var) (E : Env Var) (nmem : x ∉ M.fv ∪ E.fv) :
-    x ∉ (multiSubst E M).fv := by
+lemma multiSubst_preserves_not_fvar (M : Term Var) (E : Env Var) :
+    (multiSubst E M).fv ⊆ M.fv ∪ E.fv := by
   induction E with grind [subst_preserve_not_fvar]
 
 /-- Multi-substitution propagates recursively through an application -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index 06634fccd6..76fd322972 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -47,27 +47,24 @@ lemma swap_open_fvar_close (k n : ℕ) (x y : Var) (m : Term Var) (neq₁ : k 
   induction m generalizing k n <;> grind
 
 /-- Closing preserves free variables. -/
-lemma close_preserve_not_fvar {k y} (m : Term Var) : (m⟦k ↜ y⟧).fv = m.fv.erase y := by
+@[scoped grind =]
+lemma close_rec_fv {k y} (m : Term Var) : (m⟦k ↜ y⟧).fv = m.fv.erase y := by
   induction m generalizing k <;> grind
 
+/-- Specializes `close_var_not_fvar_rec` to first closing. -/
+@[scoped grind =]
+lemma close_var_not_fvar (x) (t : Term Var) : (t ^* x).fv = t.fv.erase x := close_rec_fv t
+
 /-- Opening preserves free variables. -/
-lemma open_preserve_not_fvar {k x} (m n : Term Var) (nmem_m : x ∉ m.fv) (nmem_n : x ∉ n.fv) :
-    x ∉ (m⟦k ↝ n⟧).fv := by
+theorem open_preserve_not_fvar (k) (m n : Term Var) :
+    m⟦k ↝ n⟧.fv = m.fv ∪ n.fv ∨ m⟦k ↝ n⟧.fv = m.fv := by
   induction m generalizing k <;> grind
 
 /-- Substitution preserves free variables. -/
-lemma subst_preserve_not_fvar {x y : Var} (m n : Term Var) (nmem : x ∉ m.fv ∪ n.fv) :
-    x ∉ (m [y := n]).fv := by
+lemma subst_preserve_not_fvar {y : Var} (m n : Term Var) :
+    m [y := n].fv = m.fv.erase y ∨ m [y := n].fv = m.fv.erase y ∪ n.fv:= by
   induction m <;> grind
 
-/-- Closing removes a free variable. -/
-@[scoped grind ←]
-lemma close_var_not_fvar_rec (x) (k) (t : Term Var) : x ∉ (t⟦k ↜ x⟧).fv := by
-  induction t generalizing k <;> grind
-
-/-- Specializes `close_var_not_fvar_rec` to first closing. -/
-lemma close_var_not_fvar (x) (t : Term Var) : x ∉ (t ^* x).fv := close_var_not_fvar_rec x 0 t
-
 variable [HasFresh Var]
 
 omit [DecidableEq Var] in
@@ -122,17 +119,17 @@ theorem beta_lc {M N : Term Var} (m_lc : M.abs.LC) (n_lc : LC N) : LC (M ^ N) :=
   cases m_lc with
   | abs => grind [fresh_exists <| free_union [fv] Var]
 
-/-- Opening then closing is equivalent to substitution. -/
+/-- Closing then opening is equivalent to substitution. -/
 @[scoped grind =]
-lemma open_close_to_subst (m : Term Var) (x y : Var) (k : ℕ) (m_lc : LC m) :
-    m ⟦k ↜ x⟧⟦k ↝ fvar y⟧ = m [x := fvar y] := by
+lemma close_open_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_lc : LC n) :
+    m ⟦k ↜ x⟧⟦k ↝ n⟧ = m [x := n] := by
   induction m_lc generalizing k with
   | abs xs t =>
     have ⟨x', _⟩ := fresh_exists <| free_union [fv] Var
     grind [
       swap_open, =_ swap_open_fvar_close,
-      open_close x' (t⟦k+1 ↜ x⟧⟦k+1 ↝ fvar y⟧) 0, open_close x' (t[x := fvar y]) 0,
-       open_preserve_not_fvar, close_preserve_not_fvar, subst_preserve_not_fvar]
+      open_close x' (t⟦k+1 ↜ x⟧⟦k+1 ↝ n⟧) 0, open_close x' (t[x := n]) 0,
+       open_preserve_not_fvar, close_rec_fv, subst_preserve_not_fvar]
   | _ => grind
 
 /-- Closing and opening are inverses. -/

From 28e0b17ac0e01d7284e559e5bf149ad474bdf158 Mon Sep 17 00:00:00 2001
From: lyj <sjtu5140809011@gmail.com>
Date: Tue, 26 May 2026 13:13:18 +0800
Subject: [PATCH 078/106] feat: subst_refl (#599)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This pr

1. adds a new lemma: `subst_refl`

```
lemma subst_refl (m : Term Var) (x : Var) :
  m[x := fvar x] = m
```

This states that substituting a variable with its own free-variable form
leaves the term unchanged.
The proof is implemented using structural induction and `grind` tactics.

---

2. Refactors the `close_open` lemma

The lemma:

```
lemma close_open (x : Var) (t : Term Var) (k : ℕ) (t_lc : LC t) :
  t⟦k ↜ x⟧⟦k ↝ fvar x⟧ = t
```

is rewritten with ` grind [subst_refl]`


PR summary generated by copilot
---
 .../LocallyNameless/Untyped/Properties.lean            | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index 76fd322972..f7810940df 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -65,6 +65,9 @@ lemma subst_preserve_not_fvar {y : Var} (m n : Term Var) :
     m [y := n].fv = m.fv.erase y ∨ m [y := n].fv = m.fv.erase y ∪ n.fv:= by
   induction m <;> grind
 
+lemma subst_refl (m : Term Var) (x : Var) : m[x := fvar x] = m := by
+  induction m <;> grind
+
 variable [HasFresh Var]
 
 omit [DecidableEq Var] in
@@ -134,12 +137,7 @@ lemma close_open_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_
 
 /-- Closing and opening are inverses. -/
 lemma close_open (x : Var) (t : Term Var) (k : ℕ) (t_lc : LC t) : t⟦k ↜ x⟧⟦k ↝ fvar x⟧ = t := by
-  induction t_lc generalizing k with
-  | abs _ t _ ih =>
-    let z := t⟦k + 1 ↜ x⟧⟦k + 1 ↝ fvar x⟧
-    have ⟨y, _⟩ := fresh_exists <| free_union [fv] Var
-    grind [ih y ?_ (k+1), open_injective, swap_open_fvar_close, swap_open]
-  | _ => grind
+  grind [subst_refl]
 
 end LambdaCalculus.LocallyNameless.Untyped.Term
 

From f7dd399b075b5ae3b2035c1bd7921a7d78246161 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 26 May 2026 21:03:55 +0200
Subject: [PATCH 079/106] bounds for while.

---
 Cslib.lean                                    |   2 +-
 .../Machines/RoseTreeMachine/V2/PB.lean       | 136 ++++++-
 .../Machines/RoseTreeMachine/V2/Prog.lean     |   7 +-
 .../RoseTreeMachine/V2/UniversalTM.lean       |  49 ++-
 .../RoseTreeMachine/V2/WhileBounds.lean       | 339 ++++++++++++++++++
 5 files changed, 522 insertions(+), 11 deletions(-)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V2/WhileBounds.lean

diff --git a/Cslib.lean b/Cslib.lean
index 490c509e02..c3a7d1118f 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -70,7 +70,6 @@ public import Cslib.Computability.Machines.MultiTapeTuring.UniversalTM
 public import Cslib.Computability.Machines.MultiTapeTuring.WhileCombinator
 public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes
 public import Cslib.Computability.Machines.RoseTreeMachine.RTM_to_TM
-public import Cslib.Computability.Machines.RoseTreeMachine.RoseTreeMachine
 public import Cslib.Computability.Machines.RoseTreeMachine.V2
 public import Cslib.Computability.Machines.RoseTreeMachine.V2.Data
 public import Cslib.Computability.Machines.RoseTreeMachine.V2.DataEncode
@@ -78,6 +77,7 @@ public import Cslib.Computability.Machines.RoseTreeMachine.V2.PB
 public import Cslib.Computability.Machines.RoseTreeMachine.V2.Prog
 public import Cslib.Computability.Machines.RoseTreeMachine.V2.Tools
 public import Cslib.Computability.Machines.RoseTreeMachine.V2.UniversalTM
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.WhileBounds
 public import Cslib.Computability.Machines.RoseTreeMachine.V3
 public import Cslib.Computability.Machines.RoseTreeMachine.log
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
index f01e6bfa0f..de50c222c5 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
@@ -83,6 +83,32 @@ def PB.computes_at (env : List Data) (impl : PB) (d : Data) : Prop :=
   ∀ ext : List Data,
     (impl (env.length + ext.length)).eval (env ++ ext) = .some d
 
+-- TODO mabe we should think about using the following version of `computes_at`,
+-- which should be sufficient for most cases:
+-- (I think this was problematic at the binder bodies,
+-- where the body PB is parameterised over var-lookup PBs for the bindings,
+-- so the body PB itself needs to be depth-agnostic. But maybe we can still use this version for
+-- the body hypotheses, and then show that the body PBs are depth-agnostic as a consequence of
+-- their own `computes_at` hypotheses?)
+def PB.computes_at_v2 (impl : PB) (f : List Data → Data) : Prop :=
+  ∀ env : List Data, (impl (env.length)).eval env = .some (f env)
+
+def PB.outputsOSize (impl : PB) (s : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env : List Data, ∃ s' ≤ a * (s env) + b,
+    (((impl env.length).meteredEval env).map fun (d, _, _) => d.size) = .some s'
+
+def PB.usesOTime (impl : PB) (t : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env : List Data, ∃ t' ≤ a * (t env) + b,
+    (((impl env.length).meteredEval env).map fun (_, t'', _) => t'') = .some t'
+
+def PB.usesOSpace (impl : PB) (s : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env : List Data, ∃ s' ≤ a * (s env) + b,
+    (((impl env.length).meteredEval env).map fun (_, _, s'') => s'') = .some s'
+
+def PB.usesLinearTimeAndSpace (impl : PB) : Prop :=
+  PB.usesOTime impl (fun env => (Data.l env).size) ∧
+  PB.usesOSpace impl (fun env => (Data.l env).size)
+
 /-- The basic per-env consequence, instantiating `ext := []`. -/
 lemma PB.computes_at.here {env : List Data} {impl : PB} {d : Data}
     (h : PB.computes_at env impl d) :
@@ -105,6 +131,12 @@ lemma PB.var_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
   simp [Prog.eval, Prog.meteredEval, List.getElem?_append_left h]
   grind
 
+@[simp]
+lemma PB.var_computes_at_v2 {i : ℕ} :
+    PB.computes_at_v2 (fun _ => .var i) fun env => env[i]?.getD (Data.l []) := by
+  intro ext
+  simp [Prog.eval, Prog.meteredEval]
+
 @[simp]
 lemma PB.var_last_computes_at {env ext : List Data} {d : Data} :
     PB.computes_at (env ++ ext ++ [d])
@@ -112,14 +144,45 @@ lemma PB.var_last_computes_at {env ext : List Data} {d : Data} :
   have hlen : env.length + ext.length < (env ++ ext ++ [d]).length := by simp
   have h := PB.var_computes_at (env := env ++ ext ++ [d]) hlen
   convert h using 2
-  simp [List.getElem_append]
+  simp
+
+@[simp, grind .]
+lemma DB.var_usesOTime {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.usesOTime (fun _ => .var i) 1 := by
+  use 1, 0
+  intro ext
+  simp [Prog.meteredEval]
+
+@[simp]
+lemma PB.var_usesLinearTimeAndSpace {i : ℕ} :
+    PB.usesLinearTimeAndSpace (fun _ => .var i) := by
+  sorry
+
 
 @[simp, grind .]
-lemma PB.empty_computes_at {env : List Data} :
-    PB.computes_at env PB.empty (Data.l []) := by
+lemma PB.empty_computes_at {env : List Data} : PB.computes_at env PB.empty (Data.l []) := by
   intro ext
   simp [PB.empty, Prog.eval, Prog.meteredEval]
 
+@[simp, grind .]
+lemma PB.empty_outputsOSize : PB.outputsOSize PB.empty (fun _ => 1) := by
+  use 2, 0
+  simp [PB.empty, Prog.meteredEval]
+
+@[simp, grind .]
+lemma PB.empty_usesOTime : PB.usesOTime PB.empty 1 := by
+  use 1, 0
+  simp [PB.empty, Prog.meteredEval]
+
+@[simp, grind .]
+lemma PB.empty_usesOSpace : PB.usesOSpace PB.empty 1 := by
+  use 1, 0
+  simp [PB.empty, Prog.meteredEval]
+
+@[simp, grind .]
+lemma PB.empty_usesLinearTimeAndSpace : PB.usesLinearTimeAndSpace PB.empty := by
+  sorry
+
 @[simp, grind .]
 lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
     (hh : PB.computes_at env h dh) (ht : PB.computes_at env t dt) :
@@ -127,6 +190,59 @@ lemma PB.cons_computes_at {env : List Data} {h t : PB} {dh dt : Data}
   intro ext
   simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
 
+@[simp, grind .]
+lemma PB.cons_computes_at_v2 {h t : PB} {fh ft : List Data → Data}
+    (hh : PB.computes_at_v2 h fh) (ht : PB.computes_at_v2 t ft) :
+    PB.computes_at_v2 (PB.cons h t) (fun env => Data.l ((fh env) :: (ft env).asList)) := by
+  intro ext
+  simpa [PB.cons] using Prog.cons_eval_simp (hh ext) (ht ext)
+
+@[simp, grind .]
+lemma PB.cons_outputsOSize {h t : PB} {s_h s_t : List Data → ℕ}
+    (hh : PB.outputsOSize h s_h) (ht : PB.outputsOSize t s_t) :
+    PB.outputsOSize (PB.cons h t) (s_h + s_t) := by
+  obtain ⟨ah, bh, hh⟩ := hh
+  obtain ⟨a_t, b_t, ht⟩ := ht
+  refine ⟨max ah a_t, bh + b_t, fun env => ?_⟩
+  obtain ⟨sh', hsh_le, hsh_eq⟩ := hh env
+  obtain ⟨st', hst_le, hst_eq⟩ := ht env
+  -- TODO this proof can be simplified if we introduce 'Prog.sizeOfOutput' similar to 'Prog.eval'
+  rw [Part.eq_some_iff, Part.mem_map_iff] at hsh_eq hst_eq
+  obtain ⟨⟨dh, th, sph⟩, hh_mem, rfl⟩ := hsh_eq
+  obtain ⟨⟨dt, tt, spt⟩, ht_mem, rfl⟩ := hst_eq
+  refine ⟨dh.size + dt.size, ?_, ?_⟩
+  · calc dh.size + dt.size
+        ≤ (ah * s_h env + bh) + (a_t * s_t env + b_t) := Nat.add_le_add hsh_le hst_le
+      _ ≤ max ah a_t * s_h env + max ah a_t * s_t env + (bh + b_t) := by
+          have h1 := Nat.mul_le_mul_right (s_h env) (le_max_left ah a_t)
+          have h2 := Nat.mul_le_mul_right (s_t env) (le_max_right ah a_t)
+          omega
+      _ = max ah a_t * ((s_h + s_t) env) + (bh + b_t) := by
+          simp [Pi.add_apply, Nat.mul_add]
+  · have hh_eq : Prog.meteredEval env (h env.length) = .some (dh, th, sph) :=
+      Part.eq_some_iff.mpr hh_mem
+    have ht_eq : Prog.meteredEval env (t env.length) = .some (dt, tt, spt) :=
+      Part.eq_some_iff.mpr ht_mem
+    simp [PB.cons, Prog.meteredEval, hh_eq, ht_eq]
+
+@[simp, grind .]
+lemma PB.cons_usesOTime {h t : PB} {t_h t_t : List Data → ℕ}
+    (hh : PB.usesOTime h t_h) (ht : PB.usesOTime t t_t) :
+    PB.usesOTime (PB.cons h t) (t_h + t_t) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_usesOSpace {h t : PB} {s_h s_t : List Data → ℕ}
+    (hh : PB.usesOSpace h s_h) (ht : PB.usesOSpace t s_t) :
+    PB.usesOSpace (PB.cons h t) (fun env => max (s_h env) (s_t env)) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_preserves_linearity {h t : PB}
+    (hh : PB.usesLinearTimeAndSpace h) (ht : PB.usesLinearTimeAndSpace t) :
+    PB.usesLinearTimeAndSpace (PB.cons h t) := by
+  sorry
+
 lemma PB.eq_computes_at {env : List Data} {a b : PB} {da db : Data}
     (ha : PB.computes_at env a da) (hb : PB.computes_at env b db) :
     PB.computes_at env (PB.eq a b)
@@ -145,6 +261,12 @@ convenience wrappers. -/
 /-- Depth-agnostic var-lookup PB: `PB.atSlot i = fun _ => .var i`. -/
 def PB.atSlot (i : ℕ) : PB := fun _ => .var i
 
+@[simp, grind .]
+lemma PB.atSlot_usesLinearTimeAndSpace {i : ℕ} :
+    PB.usesLinearTimeAndSpace (PB.atSlot i) := by
+  unfold PB.atSlot
+  simp [PB.var_usesLinearTimeAndSpace]
+
 @[simp]
 lemma PB.atSlot_computes_at {env : List Data} {i : ℕ} (h : i < env.length) :
     PB.computes_at env (PB.atSlot i) env[i] :=
@@ -230,6 +352,14 @@ lemma PB.elim_cons_tail_var_computes_at {env ext : List Data}
       < (env ++ ext ++ [head, tail]).length := by simp; omega
   grind [PB.var_computes_at hlen]
 
+@[simp, grind .]
+lemma PB.elim_preserves_linearity {v em : PB} {cs : PB → PB → PB}
+    (hv : PB.usesLinearTimeAndSpace v) (hem : PB.usesLinearTimeAndSpace em)
+    (hcs : ∀ i j, PB.usesLinearTimeAndSpace (cs (PB.atSlot i) (PB.atSlot j))) :
+    PB.usesLinearTimeAndSpace (PB.elim v em cs) := by
+  sorry
+
+
 /-- `fold` at a fixed env: lifts `Prog.fold_eval` pointwise. The body hypothesis
 is packaged as `PB.computes_at_body₂` parameterised over the current
 accumulator `acc` and element `el`. -/
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
index b3acd20a75..4d2a39fc3d 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
@@ -40,12 +40,14 @@ For ergonomic construction with named binders use `PB` below. -/
 inductive Prog where
   | var (id : Var)
   /-- `letin val rest`: evaluate `val`, append the result to `env`, then evaluate `rest`. -/
+  -- TODO maybe scrap this
   | letin (val : Prog) (rest : Prog)
   | empty
   | cons (h t : Prog)
   /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
       `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
   | elim (v : Prog) (em : Prog) (cs : Prog)
+  -- TOOD swap this out with `ifEq (a b then_ else_ : Prog)`.
   | eq (a b : Prog)
   /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
       list; `body` runs once per element with `env` extended by `[acc, x]`. -/
@@ -69,6 +71,9 @@ def Prog.meteredEval (env : List Data) (p : Prog) : Part (Data × ℕ × ℕ) :=
   | .cons h t => do
     let (head, h_t, h_s) ← h.meteredEval env
     let (tail, t_t, t_s) ← t.meteredEval env
+    -- TODO is it correct that we don't charge for the size of the output?
+    -- probably yes, since the output size of both is (max h_s t_s), so there is just a
+    -- linear factor lost.
     return (Data.l (head :: tail.asList), 1 + h_t + t_t, max h_s t_s)
   | .elim v em cs => do
     let (v', t, s) ← v.meteredEval env
@@ -219,7 +224,7 @@ establish that the metered fix, projected to its data component, equals the
 non-metered `whileFrom_eval`. This is the key ingredient for `Prog.while_eval`.
 -/
 
-private noncomputable def Prog.metered_F (body : Prog) (env : List Data) :
+noncomputable def Prog.metered_F (body : Prog) (env : List Data) :
     ((Data × ℕ × ℕ) → Part (Data × ℕ × ℕ)) → (Data × ℕ × ℕ) → Part (Data × ℕ × ℕ) :=
   fun rec d_ts =>
     let (acc, t, s) := d_ts
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
index 35312d1174..460beeec4e 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
@@ -22,23 +22,27 @@ namespace Turing
 
 namespace RoseTreeMachine
 
+-- TODO Working on the resource bounds now.
+-- The proof outline should be:
+-- each iteration of the loop causes the accumulator to grow by at most a constant.
+-- this can actually be shown from the semantics and the proof that the tape size grows by at
+-- most a constant.
+-- then, we show that the time and space of each iteration is linear in its input.
+-- so overall, t iterations are computed in O(t^2) time and O(t) space.
+
 variable [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
 
 public instance : DataEncode (Turing.StackTape Symbol) where
   encode t := DataEncode.encode t.toList
   h_inj := by
     intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h
-    have : l₁ = l₂ := DataEncode.h_inj h
-    cases this; rfl
+    grind [DataEncode.h_inj h]
 
 public instance : DataEncode (Turing.BiTape Symbol) where
   encode t := DataEncode.encode (t.head, t.left, t.right)
   h_inj := by
     intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
-    have heq := DataEncode.h_inj h
-    simp at heq
-    obtain ⟨hh, hl, hr⟩ := heq
-    cases hh; cases hl; cases hr; rfl
+    grind [DataEncode.h_inj h]
 
 omit [Inhabited Symbol] [Fintype Symbol] in
 lemma encode_biTape (t : Turing.BiTape Symbol) :
@@ -55,6 +59,17 @@ lemma bitape_write_computes
   simp only [PB.computes_at_encoded, encode_biTape, DataEncode_pair] at h_t h_v ⊢
   apply PB.cons_computes_at h_v (PB.tail_computes_at h_t)
 
+@[simp]
+lemma bitape_usesLinearTimeAndSpace
+    {p_t p_v : PB}
+    (h_t : PB.usesLinearTimeAndSpace p_t)
+    (h_v : PB.usesLinearTimeAndSpace p_v) :
+    (bitape_write p_t p_v).usesLinearTimeAndSpace := by
+  unfold bitape_write PB.tail
+  apply PB.cons_preserves_linearity (h_v)
+  apply PB.elim_preserves_linearity (by grind) (by grind)
+  simp_all
+
 -- /-- Prepend an `Option` to the `StackTape` -/
 -- @[scoped grind]
 -- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
@@ -175,6 +190,20 @@ lemma bitape_move_left_computes
       (stackTape_tail_computes_at_encoded (bitape_left_computes h_t))
       (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
 
+lemma bitape_move_left_uses_linear_time_and_space
+    {p_t : PB} (h_t : PB.usesLinearTimeAndSpace p_t) :
+    (bitape_move_left p_t).usesLinearTimeAndSpace := by
+  simp [h_t, bitape_move_left, to_pair, bitape_left, PB.fst, PB.snd, PB.tail, PB.head, stackTape_cons, bitape_head, bitape_right]
+  apply PB.cons_preserves_linearity
+  · apply PB.elim_preserves_linearity'
+    · apply PB.elim_preserves_linearity'
+      · grind --refine PB.elim_preserves_linearity' (by grind) (by grind) (by grind)
+      · grind
+      · grind
+    · grind
+    · sorry
+  · sorry
+
 -- def move_right (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
 
@@ -436,6 +465,14 @@ def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
           tr_val.snd
           (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
 
+-- TODO for space and time bounds, we need to prove for singleTapeTM_step, than:
+-- for any `env`,
+-- 1) the size of the output is the size of `env` plus a constant (not with a linear factor!)
+-- 2) the time and space required is linear in the size of `env`.
+-- the problematic bits are that we don't know what `tr` and `cfg` do, they are programs,
+-- we cannot just look at their outputs
+-- What is the right condition for `tr` and `cfg`?
+
 lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol]
     [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
     [DataEncode tm.State] [DecidableEq tm.State]
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/WhileBounds.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/WhileBounds.lean
new file mode 100644
index 0000000000..58c3244903
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/WhileBounds.lean
@@ -0,0 +1,339 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V2.Tools
+public import Mathlib.Algebra.BigOperators.Group.Finset.Basic
+public import Mathlib.Order.Interval.Finset.Nat
+public import Mathlib.Order.Interval.Finset.SuccPred
+public import Mathlib.Data.Nat.SuccPred
+
+/-! # RoseTreeMachine V2 — Resource bounds for `while_`
+
+Foundation lemmas describing how `Prog.while_` / `PB.while_` consume time and
+space along a known trajectory, and a high-level complexity spec saying that a
+linear-cost body with constant accumulator growth yields linear-space and
+quadratic-time loops.
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+/-! ### Foundation lemma: metered `while_` along a known trajectory
+
+Given a trajectory `acc 0, acc 1, …, acc N` such that `body.meteredEval` carries
+`acc k` to `acc (k+1)` with cost `(bt k, bs k)` for each `k < N`, that the halt
+condition fails at every `acc k` for `k < N` and holds at `acc N`, and that
+`init` evaluates to `acc 0` with metered cost `(i_t, i_s)`, then
+`(Prog.while_ init body).meteredEval env` is fully determined.
+
+All future `PB.usesO*`/`outputsOSize` lemmas about `PB.while_` factor through
+this.
+-/
+
+/-- Continuity of `metered_F`, parallel to `Prog.whileFrom_eval_continuous`. -/
+private lemma Prog.metered_F_continuous (body : Prog) (env : List Data) :
+    OmegaCompletePartialOrder.ωScottContinuous (Prog.metered_F body env) := by
+  apply OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+  intro ⟨acc, t, s⟩
+  unfold Prog.metered_F
+  simp only
+  by_cases h : acc.asList.headD (Data.l []) = Data.l []
+  · simp only [h, if_true]
+    exact OmegaCompletePartialOrder.ωScottContinuous.const
+  · simp only [h, if_false]
+    exact OmegaCompletePartialOrder.ContinuousHom.ωScottContinuous.bind
+      OmegaCompletePartialOrder.ωScottContinuous.const
+      (OmegaCompletePartialOrder.ωScottContinuous.of_apply₂
+        (fun _ => OmegaCompletePartialOrder.ωScottContinuous.id.apply₂ _))
+
+/-- Halt-step unrolling for `Part.fix (metered_F …)`. -/
+lemma Prog.metered_fix_halt {body : Prog} {env : List Data}
+    {acc : Data} {t s : ℕ}
+    (h_halt : acc.asList.headD (Data.l []) = Data.l []) :
+    Part.fix (Prog.metered_F body env) (acc, t, s) = .some (acc, t, s) := by
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.metered_F_continuous body env)]
+  unfold Prog.metered_F
+  simp only [h_halt, if_true]
+
+/-- Body-step unrolling for `Part.fix (metered_F …)`. -/
+lemma Prog.metered_fix_step {body : Prog} {env : List Data}
+    {acc : Data} {t s : ℕ}
+    (h_step : acc.asList.headD (Data.l []) ≠ Data.l []) :
+    Part.fix (Prog.metered_F body env) (acc, t, s) =
+      (body.meteredEval (env ++ [acc])).bind fun y =>
+        Part.fix (Prog.metered_F body env) (y.1, t + 1 + y.2.1, max s y.2.2) := by
+  conv_lhs =>
+    rw [Part.fix_eq_of_ωScottContinuous (Prog.metered_F_continuous body env)]
+  unfold Prog.metered_F
+  simp only [h_step, if_false]
+
+/-- **Foundation lemma.** Metered evaluation of `Part.fix (metered_F body env)`
+starting from `(acc 0, t₀, s₀)` along a known body-trajectory of length `N`. -/
+lemma Prog.metered_fix_trajectory {body : Prog} {env : List Data}
+    (acc : ℕ → Data) (bt bs : ℕ → ℕ) (N : ℕ)
+    (h_step : ∀ k < N,
+        (acc (k + 1), bt k, bs k) ∈ body.meteredEval (env ++ [acc k]))
+    (h_no_halt : ∀ k < N, (acc k).asList.headD (Data.l []) ≠ Data.l [])
+    (h_halt : (acc N).asList.headD (Data.l []) = Data.l []) :
+    ∀ k ≤ N, ∀ t s,
+      Part.fix (Prog.metered_F body env) (acc k, t, s) =
+        .some
+          ( acc N
+          , (Finset.Ico k N).sum (fun j => 1 + bt j) + t
+          , (Finset.Ico k N).fold max s bs ) := by
+  -- Helper: pushing an extra max-arg into the fold accumulator.
+  have fold_max_acc : ∀ (S : Finset ℕ) (b c : ℕ),
+      S.fold max (max b c) bs = max c (S.fold max b bs) := by
+    intro S b c
+    induction S using Finset.induction with
+    | empty => simp [max_comm]
+    | insert _ _ hmem ih =>
+      simp [Finset.fold_insert hmem, ih, max_left_comm]
+  intro k hk
+  induction hd : N - k generalizing k with
+  | zero =>
+    have hkN : k = N := by omega
+    subst hkN
+    intro t s
+    simp [Prog.metered_fix_halt h_halt]
+  | succ m ih =>
+    have hk' : k < N := by omega
+    intro t s
+    rw [Prog.metered_fix_step (h_no_halt k hk')]
+    rw [Part.eq_some_iff.mpr (h_step k hk')]
+    simp only [Part.bind_some]
+    rw [ih (k+1) (by omega) (by omega) (t + 1 + bt k) (max s (bs k))]
+    congr 1
+    refine Prod.ext rfl (Prod.ext ?_ ?_)
+    · rw [show Finset.Ico k N = insert k (Finset.Ico (k+1) N) from
+            (Finset.insert_Ico_succ_left_eq_Ico hk').symm,
+          Finset.sum_insert (by simp)]
+      ac_rfl
+    · rw [show Finset.Ico k N = insert k (Finset.Ico (k+1) N) from
+            (Finset.insert_Ico_succ_left_eq_Ico hk').symm,
+          Finset.fold_insert (by simp), fold_max_acc]
+
+/-- **Foundation lemma (entry point).** Metered evaluation of `Prog.while_ init body`
+along a known trajectory: if `init` produces `acc 0` with cost `(i_t, i_s)` and
+`body` carries `acc k` to `acc (k+1)` with cost `(bt k, bs k)` for `k < N`,
+halting exactly at `acc N`, then the whole metered cost is fully determined. -/
+lemma Prog.while_meteredEval_trajectory {init body : Prog} {env : List Data}
+    (acc : ℕ → Data) (i_t i_s : ℕ) (bt bs : ℕ → ℕ) (N : ℕ)
+    (h_init : (acc 0, i_t, i_s) ∈ init.meteredEval env)
+    (h_step : ∀ k < N,
+        (acc (k+1), bt k, bs k) ∈ body.meteredEval (env ++ [acc k]))
+    (h_no_halt : ∀ k < N, (acc k).asList.headD (Data.l []) ≠ Data.l [])
+    (h_halt : (acc N).asList.headD (Data.l []) = Data.l []) :
+    (Prog.while_ init body).meteredEval env =
+      .some
+        ( acc N
+        , (Finset.Ico 0 N).sum (fun j => 1 + bt j) + (1 + i_t)
+        , (Finset.Ico 0 N).fold max (max 1 i_s) bs ) := by
+  have hmEq : (Prog.while_ init body).meteredEval env =
+      (init.meteredEval env).bind (fun x =>
+        Part.fix (Prog.metered_F body env) (x.1, 1 + x.2.1, max 1 x.2.2)) := by
+    rw [Prog.meteredEval]; rfl
+  rw [hmEq, Part.eq_some_iff.mpr h_init, Part.bind_some]
+  simpa using Prog.metered_fix_trajectory acc bt bs N h_step h_no_halt h_halt 0
+      (Nat.zero_le _) (1 + i_t) (max 1 i_s)
+
+/-! ### Complexity spec for `PB.while_`
+
+Conjecture: if `init` and `body` each use linear time and space, the body
+semantically computes `f` (uniformly in the env), and `f` grows the encoded
+accumulator by at most a constant `Δ` per iteration, then running
+`PB.while_ p_init body` for `N` iterations uses
+
+* **space**  linear in `|env| + N`
+* **time**   quadratic in `|env| + N`  (≈ `|env|·N + N²`)
+
+Intuition: at iteration `k` the accumulator has size `≤ |init| + k·Δ`, so the
+body's per-iteration cost (linear in the env-with-accumulator) is `O(|env| + k)`;
+summing for `k = 0 … N-1` gives `O(|env|·N + N²)` time and `O(|env| + N)` peak
+space.
+-/
+
+/-- Generic complexity spec for `PB.while_`. -/
+lemma PB.while_uses_linear_space_quadratic_time
+    {α : Type} [DataEncode α]
+    {p_init : PB} {body : PB → PB}
+    {f : α → α} {init : α}
+    -- Body semantically computes `f` on every env (env-uniform link f ↔ body).
+    (h_init_sem : ∀ env, p_init.computes_at_encoded env init)
+    (h_body_sem : ∀ env c, PB.computes_at_body₁_encoded env c body (f c))
+    -- Linearity of `init`. The body needs *uniform-in-`i`* concrete constants
+    -- (not big-O), since the loop spans many slots and we need a single bound.
+    (h_init_lin : p_init.usesLinearTimeAndSpace)
+    (h_body_lin : ∃ a b, ∀ i env,
+        ∃ d t s, ((body (PB.atSlot i)) env.length).meteredEval env = .some (d, t, s) ∧
+          t ≤ a * (Data.l env).size + b ∧ s ≤ a * (Data.l env).size + b)
+    -- Constant accumulator-size growth per body iteration (semantic side).
+    (Δ : ℕ)
+    (h_growth : ∀ c : α,
+        (DataEncode.encode (f c)).size ≤ (DataEncode.encode c).size + Δ)
+    -- The loop halts after exactly `N` iterations starting from `init`.
+    (N : ℕ)
+    (h_halt : (DataEncode.encode (f^[N] init)).asList.headD (Data.l []) = Data.l [])
+    (h_min  : ∀ k < N,
+        (DataEncode.encode (f^[k] init)).asList.headD (Data.l []) ≠ Data.l []) :
+    PB.usesOSpace (PB.while_ p_init body)
+        (fun env => (Data.l env).size + N) ∧
+    PB.usesOTime (PB.while_ p_init body)
+        (fun env => (Data.l env).size * N + N * N + 1) := by
+  -- Convenient abbreviation for the trajectory.
+  let acc : ℕ → Data := fun k => DataEncode.encode (f^[k] init)
+  -- Per-iteration accumulator-size bound.
+  have h_acc_size : ∀ k, (acc k).size ≤ (DataEncode.encode init).size + k * Δ := by
+    intro k
+    induction k with
+    | zero => simp [acc]
+    | succ k ih =>
+      have hgrow := h_growth (f^[k] init)
+      have heq : acc (k+1) = DataEncode.encode (f (f^[k] init)) := by
+        simp [acc, Function.iterate_succ_apply']
+      rw [heq]
+      have : (acc k) = DataEncode.encode (f^[k] init) := rfl
+      have h1 : (DataEncode.encode (f (f^[k] init))).size ≤
+          (DataEncode.encode (f^[k] init)).size + Δ := hgrow
+      have h2 : (DataEncode.encode (f^[k] init)).size = (acc k).size := rfl
+      rw [Nat.succ_mul]
+      omega
+  -- Unpack the linearity hypotheses into explicit constants.
+  obtain ⟨a_it, b_it, h_init_t⟩ := h_init_lin.1
+  obtain ⟨a_is, b_is, h_init_s⟩ := h_init_lin.2
+  obtain ⟨a_b, b_b, h_body_lin'⟩ := h_body_lin
+  -- Convenience: the initial encoded value's size as a constant.
+  set Si : ℕ := (DataEncode.encode init).size with Si_def
+  -- ------------------------------------------------------------------
+  -- Per-env construction of the trajectory using the foundation lemma.
+  -- This builds, for any `env`, a metered evaluation of `PB.while_ p_init body`
+  -- at depth `env.length`, returning the explicit cost tuple.
+  -- ------------------------------------------------------------------
+  have trajectory_eval :
+      ∀ env : List Data,
+      ∃ (bt bs : ℕ → ℕ),
+        (∀ k < N,
+            bt k ≤ a_b * ((Data.l env).size + (acc k).size) + b_b ∧
+            bs k ≤ a_b * ((Data.l env).size + (acc k).size) + b_b) ∧
+        ∃ (i_t i_s : ℕ),
+          i_t ≤ a_it * (Data.l env).size + b_it ∧
+          i_s ≤ a_is * (Data.l env).size + b_is ∧
+          ((PB.while_ p_init body) env.length).meteredEval env =
+            .some
+              ( acc N
+              , (Finset.Ico 0 N).sum (fun j => 1 + bt j) + (1 + i_t)
+              , (Finset.Ico 0 N).fold max (max 1 i_s) bs ) := by
+    intro env
+    let n := env.length
+    have h_init_eval : (p_init n).eval env = .some (acc 0) :=
+      PB.computes_at.here (h_init_sem env)
+    obtain ⟨i_t, i_s, h_init_m⟩ := Prog.eval_some_iff_meteredEval.mp h_init_eval
+    obtain ⟨i_t', h_i_t_le, h_i_t_eval⟩ := h_init_t env
+    obtain ⟨i_s', h_i_s_le, h_i_s_eval⟩ := h_init_s env
+    have h_it_eq : i_t = i_t' := by
+      rw [h_init_m, Part.map_some] at h_i_t_eval; exact Part.some_inj.mp h_i_t_eval
+    have h_is_eq : i_s = i_s' := by
+      rw [h_init_m, Part.map_some] at h_i_s_eval; exact Part.some_inj.mp h_i_s_eval
+    -- Specialize body's uniform metered-bound to slot `n`.
+    -- For each k, get the body's metered eval at env ++ [acc k] and its bound.
+    have body_step_data : ∀ k,
+        ∃ bt_k bs_k : ℕ,
+          (body (PB.atSlot n) (n + 1)).meteredEval (env ++ [acc k]) =
+            .some (acc (k+1), bt_k, bs_k) ∧
+          bt_k ≤ a_b * (Data.l (env ++ [acc k])).size + b_b ∧
+          bs_k ≤ a_b * (Data.l (env ++ [acc k])).size + b_b := by
+      intro k
+      have h_body_eval :
+          (body (PB.atSlot n) (n + 1)).eval (env ++ [acc k]) = .some (acc (k+1)) := by
+        have h1 := PB.computes_at.here ((h_body_sem env (f^[k] init)) [])
+        simp only [List.append_nil, List.length_append, List.length_singleton,
+                   Nat.add_zero] at h1
+        have hacc : acc (k+1) = DataEncode.encode (f (f^[k] init)) := by
+          show DataEncode.encode (f^[k+1] init) = _
+          rw [Function.iterate_succ_apply']
+        rw [hacc]; exact h1
+      obtain ⟨bt_k, bs_k, h_body_m⟩ := Prog.eval_some_iff_meteredEval.mp h_body_eval
+      obtain ⟨d', t', s', h_body_eval', h_t_le, h_s_le⟩ :=
+        h_body_lin' n (env ++ [acc k])
+      have hlen : (env ++ [acc k]).length = n + 1 := by
+        rw [List.length_append, List.length_singleton]
+      rw [hlen] at h_body_eval'
+      have htriple : (acc (k+1), bt_k, bs_k) = (d', t', s') :=
+        Part.some_inj.mp (h_body_m.symm.trans h_body_eval')
+      refine ⟨bt_k, bs_k, h_body_m, ?_, ?_⟩ <;> grind
+    -- Collect the per-step data into functions.
+    choose bt bs h_meval h_bt_le h_bs_le using body_step_data
+    refine ⟨bt, bs, ?_, i_t, i_s, h_it_eq ▸ h_i_t_le, h_is_eq ▸ h_i_s_le, ?_⟩
+    · intro k _hk
+      have hsize : (Data.l (env ++ [acc k])).size =
+          (Data.l env).size + (acc k).size := by
+        simp [Data.size, List.map_append]; omega
+      have ht := h_bt_le k
+      have hs := h_bs_le k
+      grind
+    · show (Prog.while_ (p_init n) (body (PB.atSlot n) (n + 1))).meteredEval env = _
+      apply Prog.while_meteredEval_trajectory acc i_t i_s bt bs N
+        (Part.eq_some_iff.mp h_init_m)
+      · intro k _; rw [h_meval k]; exact Part.mem_some _
+      · exact h_min
+      · exact h_halt
+  -- Helper: bound `Finset.fold max` by a uniform bound on initial and elements.
+  have fold_max_le : ∀ (S : Finset ℕ) (b : ℕ) (g : ℕ → ℕ) (M : ℕ),
+      b ≤ M → (∀ k ∈ S, g k ≤ M) → S.fold max b g ≤ M := by
+    intro S b g M hb hg
+    induction S using Finset.induction with
+    | empty => simpa
+    | insert a S ha ih =>
+      rw [Finset.fold_insert ha]
+      have hgm := hg a (by simp)
+      have := ih (fun k hk => hg k (by simp [hk]))
+      exact max_le hgm this
+  -- ============================ SPACE ============================
+  refine ⟨?_, ?_⟩
+  · -- Choose the linear-bound constants.
+    refine ⟨max a_is a_b,
+            1 + b_is + a_b * (Si + N * Δ) + b_b + 1, ?_⟩
+    intro env
+    obtain ⟨bt, bs, h_step_le, i_t, i_s, h_it_le, h_is_le, h_eval⟩ :=
+      trajectory_eval env
+    -- The space output is `fold max (max 1 i_s) bs (Ico 0 N)`.
+    refine ⟨_, ?_, by rw [h_eval, Part.map_some]⟩
+    -- Bound the fold by a uniform linear bound on initial and elements.
+    have h_a_b_le : a_b ≤ max a_is a_b := le_max_right _ _
+    have h_a_is_le : a_is ≤ max a_is a_b := le_max_left _ _
+    have hmul_env : ∀ c : ℕ, c * (Data.l env).size ≤ c * ((Data.l env).size + N) :=
+      fun _ => Nat.mul_le_mul_left _ (Nat.le_add_right _ _)
+    apply fold_max_le
+    · -- Bound `max 1 i_s`.
+      have := Nat.mul_le_mul_right ((Data.l env).size + N) h_a_is_le
+      grind
+    · intro k hk
+      simp only [Finset.mem_Ico] at hk
+      have hsum : (acc k).size ≤ Si + N * Δ := by
+        have := h_acc_size k
+        have := Nat.mul_le_mul_right Δ (le_of_lt hk.2)
+        omega
+      have hmul_acc : a_b * ((Data.l env).size + (acc k).size) ≤
+          a_b * (Data.l env).size + a_b * (Si + N * Δ) :=
+        le_trans (Nat.mul_le_mul_left _ (Nat.add_le_add_left hsum _))
+          (Nat.mul_add _ _ _).le
+      have := Nat.mul_le_mul_right (Data.l env).size h_a_b_le
+      grind
+  · -- ============================ TIME =============================
+    sorry
+
+end RoseTreeMachine
+
+end Turing

From c7944a9fb44c3298f1a960a5e574ab23a6ab8ed5 Mon Sep 17 00:00:00 2001
From: Garmelon <joscha@plugh.de>
Date: Tue, 26 May 2026 22:48:17 +0100
Subject: [PATCH 080/106] chore: bump toolchain to v4.30.0 (#601)

---
 lake-manifest.json | 26 +++++++++++++-------------
 lakefile.toml      |  2 +-
 lean-toolchain     |  2 +-
 3 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/lake-manifest.json b/lake-manifest.json
index 1b6933333f..7b2d3b8f19 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,17 +5,17 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "d8de6b61f073daf518577b643724875545b98e89",
+   "rev": "c5ea00351c28e24afc9f0f84379aa41082b1188f",
    "name": "mathlib",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "d8de6b61f073daf518577b643724875545b98e89",
+   "inputRev": "c5ea00351c28e24afc9f0f84379aa41082b1188f",
    "inherited": false,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/plausible",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "293af9b2a383eed4d04d66b898d608d0a44b750f",
+   "rev": "a456461b368b71d2accd95234832cd9c174b5437",
    "name": "plausible",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -35,7 +35,7 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "fd70b40073aeca8fa60fe0fb492f189d3b12c0ef",
+   "rev": "515cf9d0c00ece5e661f6de4326a53dedc1e8ea1",
    "name": "importGraph",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -45,37 +45,37 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "2db6054a44326f8c0230ee0570e2ddb894816511",
+   "rev": "a84b3e2475d5c5ab979567b1ad8aea21b764bcf8",
    "name": "proofwidgets",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v0.0.98",
+   "inputRev": "v0.0.99",
    "inherited": true,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/aesop",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "f0c6e183ea26531e82773feb4b73ab6595ca17a5",
+   "rev": "558915ae105bfd8074e22d597613d1961822adc2",
    "name": "aesop",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "v4.30.0",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover-community/quote4",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "1cc7e819b9b9bc1e87c9edcccb62e0269e00a809",
+   "rev": "a6e6c34c4ef182f83b219a3a5a385f51f44bdc4c",
    "name": "Qq",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "v4.30.0",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover-community/batteries",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "4ee56e687ce2b9b51b097bfa65947a499da0c453",
+   "rev": "32dc18cde3684679f3c003de608743b57498c56f",
    "name": "batteries",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -85,10 +85,10 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover",
-   "rev": "13567aed1ac4f12aea9484178e07e51f8c9f7658",
+   "rev": "6b907cf12b2e445ccb7c24bc208ef04a1f39e84c",
    "name": "Cli",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "v4.30.0",
    "inherited": true,
    "configFile": "lakefile.toml"}],
  "name": "cslib",
diff --git a/lakefile.toml b/lakefile.toml
index 92c711279e..38c08dd947 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false
 [[require]]
 name = "mathlib"
 scope = "leanprover-community"
-rev = "d8de6b61f073daf518577b643724875545b98e89"
+rev = "c5ea00351c28e24afc9f0f84379aa41082b1188f"
 
 [[lean_lib]]
 name = "Cslib"
diff --git a/lean-toolchain b/lean-toolchain
index 6c7e31fffe..af9e5d339a 100644
--- a/lean-toolchain
+++ b/lean-toolchain
@@ -1 +1 @@
-leanprover/lean4:v4.30.0-rc2
+leanprover/lean4:v4.30.0

From d780a2ad97124ab8f23e3c02fad896b3742745c6 Mon Sep 17 00:00:00 2001
From: Eric Wieser <efw@google.com>
Date: Wed, 27 May 2026 15:09:49 -0700
Subject: [PATCH 081/106] refactor: change the simpNF for FreeM (#417)

This declares `liftBind` an implementation detail, encouraging users to
work with `lift` and `bind` separately instead.

In particular:
* `>>=` is now the simp-normal form of `FreeM.bind`
* `<$>` is now the simp-normal form of `FreeM.map`
* `Pure.pure` is now the simp-normal form of `FreeM.pure`

Note that due to a failing in the design of monads in Lean around
universes, it is not always possible to use the notation.
The advantage of using it when it _is_ available is that standard lemmas
about lawful monads can apply.

---

Depends on:
* #439
* #490
* #525
---
 Cslib/Foundations/Control/Monad/Free.lean     | 130 +++++++++-------
 .../Control/Monad/Free/Effects.lean           | 140 ++++++++----------
 .../Foundations/Control/Monad/Free/Fold.lean  |  34 +++--
 CslibTests/FreeMonad.lean                     |  30 ++--
 4 files changed, 177 insertions(+), 157 deletions(-)

diff --git a/Cslib/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean
index 0fe0805218..dd8b2e66ad 100644
--- a/Cslib/Foundations/Control/Monad/Free.lean
+++ b/Cslib/Foundations/Control/Monad/Free.lean
@@ -49,8 +49,6 @@ The `FreeM` monad is defined using an inductive type with constructors `.pure` a
 We implement `Functor` and `Monad` instances, and prove the corresponding `LawfulFunctor`
 and `LawfulMonad` instances.
 
-For now we choose to make the constructors the simp-normal form, as opposed to the standard
-monad notation.
 
 The file `Free/Effects.lean` demonstrates practical applications by implementing State, Writer, and
 Continuations monads using `FreeM` with appropriate effect signatures.
@@ -71,6 +69,9 @@ Free monad, state monad
 
 namespace Cslib
 
+-- Disable generation of unneeded lemmas which the simpNF linter would complain about.
+set_option genInjectivity false in
+set_option genSizeOfSpec false in
 /-- The Free monad over a type constructor `F`.
 
 A `FreeM F a` is a tree of operations from the type constructor `F`, with leaves of type `a`.
@@ -94,83 +95,100 @@ universe u v w w' w''
 namespace FreeM
 variable {F : Type u → Type v} {ι : Type u} {α : Type w} {β : Type w'} {γ : Type w''}
 
+section notations
+
 instance : Pure (FreeM F) where pure := .pure
 
 @[simp]
-theorem pure_eq_pure : (pure : α → FreeM F α) = FreeM.pure := rfl
+theorem pure_eq_pure : FreeM.pure = (pure : α → FreeM F α) := rfl
+
+/-- Bind operation for the `FreeM` monad.
 
-/-- Bind operation for the `FreeM` monad. -/
+The builtin `>>=` notation should be preferred when `α` and `β` are in the same universe. -/
 protected def bind (x : FreeM F α) (f : α → FreeM F β) : FreeM F β :=
   match x with
   | .pure a => f a
   | .liftBind op cont => .liftBind op fun z => FreeM.bind (cont z) f
 
-protected theorem bind_assoc (x : FreeM F α) (f : α → FreeM F β) (g : β → FreeM F γ) :
-    (x.bind f).bind g = x.bind (fun x => (f x).bind g) := by
-  induction x with
-  | pure a => rfl
-  | liftBind op cont ih =>
-    simp [FreeM.bind] at *
-    simp [ih]
-
 instance : Bind (FreeM F) where bind := .bind
 
+/-- Note that this lemma does not always apply, as it is universe-constrained by `Bind.bind`. -/
 @[simp]
-theorem bind_eq_bind {α β : Type w} : Bind.bind = (FreeM.bind : FreeM F α → _ → FreeM F β) := rfl
+theorem bind_eq_bind {α β : Type w} : (FreeM.bind : FreeM F α → _ → FreeM F β) = Bind.bind := rfl
 
-/-- Map a function over a `FreeM` monad. -/
-@[simp]
+/-- Map a function over a `FreeM` monad.
+
+The builtin `<$>` notation should be preferred when `α` and `β` are in the same universe. -/
 def map (f : α → β) : FreeM F α → FreeM F β
   | .pure a => .pure (f a)
   | .liftBind op cont => .liftBind op fun z => FreeM.map f (cont z)
 
-@[simp]
-theorem id_map : ∀ x : FreeM F α, map id x = x
-  | .pure a => rfl
-  | .liftBind op cont => by simp_all [map, id_map]
-
-theorem comp_map (h : β → γ) (g : α → β) : ∀ x : FreeM F α, map (h ∘ g) x = map h (map g x)
-  | .pure a => rfl
-  | .liftBind op cont => by simp_all [map, comp_map]
-
 instance : Functor (FreeM F) where
   map := .map
 
+/-- Note that this lemma does not always apply, as it is universe-constrained by `Functor.map`. -/
 @[simp]
-theorem map_eq_map {α β : Type w} : Functor.map = FreeM.map (F := F) (α := α) (β := β) := rfl
+theorem map_eq_map {α β : Type w} : FreeM.map (F := F) (α := α) (β := β) = Functor.map := rfl
 
 /-- Lift an operation from the effect signature `F` into the `FreeM F` monad. -/
 def lift (op : F ι) : FreeM F ι :=
-  .liftBind op .pure
+  .liftBind op pure
 
-/-- Rewrite `lift` to the constructor form so that simplification stays in constructor normal
-form. -/
 @[simp]
-lemma lift_def (op : F ι) :
-    (lift op : FreeM F ι) = liftBind op .pure := rfl
+lemma liftBind_eq (op : F ι) :
+    liftBind op cont = (lift op : FreeM F ι).bind cont :=
+  rfl
 
-@[simp]
-lemma map_lift (f : ι → α) (op : F ι) :
-    map f (lift op : FreeM F ι) = liftBind op (fun z => (.pure (f z) : FreeM F α)) := rfl
+set_option linter.unusedVariables false in
+/-- An override for the default induction principle that is in simp-normal form.
+
+Note that when `α` and `ι` are in the same universe, this simplifies slightly further. -/
+@[induction_eliminator]
+protected theorem induction {motive : FreeM F α → Prop}
+    (pure : ∀ a, motive (pure a))
+    (lift_bind : ∀ {ι} (op : F ι) (cont : ι → FreeM F α) (ih : ∀ i, motive (cont i)),
+      motive ((lift op).bind cont)) : ∀ x, motive x
+  | .pure a => pure a
+  | liftBind _ _ => lift_bind _ _ fun _ => FreeM.induction pure lift_bind _
+
+end notations
+
+protected theorem bind_assoc (x : FreeM F α) (f : α → FreeM F β) (g : β → FreeM F γ) :
+    (x.bind f).bind g = x.bind (fun x => (f x).bind g) := by
+  induction x with
+  | pure a => rfl
+  | lift_bind op cont ih => simp [← liftBind_eq, FreeM.bind, ih] at *
 
 /-- `.pure a` followed by `bind` collapses immediately. -/
 @[simp]
-lemma pure_bind (a : α) (f : α → FreeM F β) : (.pure a : FreeM F α).bind f = f a := rfl
+lemma pure_bind (a : α) (f : α → FreeM F β) : (pure a : FreeM F α).bind f = f a := rfl
 
 @[simp]
-lemma bind_pure : ∀ x : FreeM F α, x.bind (.pure) = x
+lemma bind_pure : ∀ x : FreeM F α, x.bind pure = x
   | .pure a => rfl
-  | liftBind op k => by simp [FreeM.bind, bind_pure]
+  | liftBind op k => by simp [FreeM.bind, bind_pure, -bind_eq_bind]
 
 @[simp]
-lemma bind_pure_comp (f : α → β) : ∀ x : FreeM F α, x.bind (.pure ∘ f) = map f x
+lemma bind_pure_comp (f : α → β) : ∀ x : FreeM F α, x.bind (pure ∘ f) = map f x
   | .pure a => rfl
   | liftBind op k => by simp only [FreeM.bind, map, bind_pure_comp]
 
-/-- Collapse a `.bind` that follows a `liftBind` into a single `liftBind` -/
 @[simp]
-lemma liftBind_bind (op : F ι) (cont : ι → FreeM F α) (f : α → FreeM F β) :
-    (liftBind op cont).bind f = liftBind op fun x => (cont x).bind f := rfl
+theorem map_pure (f : α → β) (x : α) : map f (pure x : FreeM F α) = pure (f x) := rfl
+
+@[simp]
+theorem map_bind (f : β → γ) (x : FreeM F α) (c : α → FreeM F β) :
+    map f (x.bind c) = x.bind fun a => (c a).map f := by
+  simp_rw [← bind_pure_comp, FreeM.bind_assoc]
+
+@[simp]
+theorem id_map : ∀ x : FreeM F α, map id x = x
+  | .pure a => rfl
+  | .liftBind op cont => by simp_all [map, id_map]
+
+theorem comp_map (h : β → γ) (g : α → β) : ∀ x : FreeM F α, map (h ∘ g) x = map h (map g x)
+  | .pure a => rfl
+  | .liftBind op cont => by simp_all [map, comp_map]
 
 instance : LawfulFunctor (FreeM F) where
   map_const := rfl
@@ -202,32 +220,31 @@ protected def liftM (interp : {ι : Type u} → F ι → m ι) : FreeM F α →
 
 @[simp]
 lemma liftM_pure (interp : {ι : Type u} → F ι → m ι) (a : α) :
-    (.pure a : FreeM F α).liftM interp = pure a := rfl
+    (pure a : FreeM F α).liftM interp = pure a := rfl
 
 @[simp]
-lemma liftM_liftBind (interp : {ι : Type u} → F ι → m ι) (op : F β) (cont : β → FreeM F α) :
-    (liftBind op cont).liftM interp = (do let b ← interp op; (cont b).liftM interp) := by
+lemma liftM_lift_bind (interp : {ι : Type u} → F ι → m ι) (op : F β) (cont : β → FreeM F α) :
+    ((lift op) >>= cont).liftM interp = (do let b ← interp op; (cont b).liftM interp) := by
   rfl
 
+@[simp]
 lemma liftM_lift [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (op : F β) :
     (lift op).liftM interp = interp op := by
-  simp_rw [lift_def, liftM_liftBind, liftM_pure, _root_.bind_pure]
+  simp_rw [lift, FreeM.liftM, _root_.bind_pure]
 
 @[simp]
 lemma liftM_bind [LawfulMonad m]
     (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) (f : α → FreeM F β) :
-    (x.bind f).liftM interp = (do let a ← x.liftM interp; (f a).liftM interp) := by
+    (x >>= f).liftM interp = (do let a ← x.liftM interp; (f a).liftM interp) := by
   induction x generalizing f with
-  | pure a => simp only [pure_bind, liftM_pure, LawfulMonad.pure_bind]
-  | liftBind op cont ih =>
-    rw [FreeM.bind, liftM_liftBind, liftM_liftBind, bind_assoc]
-    simp_rw [ih]
+  | pure a => simp only [liftM_pure, LawfulMonad.pure_bind]
+  | lift_bind op cont ih => simp [← ih]
 
 @[simp]
 lemma liftM_map [LawfulMonad m]
     (interp : {ι : Type u} → F ι → m ι) (f : α → β) (x : FreeM F α) :
-    (x.map f).liftM interp = f <$> x.liftM interp := by
-  simp_rw [← bind_pure_comp, ← LawfulMonad.bind_pure_comp, liftM_bind, Function.comp, liftM_pure]
+    (f <$> x).liftM interp = f <$> x.liftM interp := by
+  simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure]
 
 @[simp]
 lemma liftM_seq [LawfulMonad m]
@@ -261,8 +278,8 @@ Formally, `interp` satisfies the two equations:
 -/
 structure Interprets (handler : {ι : Type u} → F ι → m ι) (interp : FreeM F α → m α) : Prop where
   apply_pure (a : α) : interp (.pure a) = pure a
-  apply_liftBind {ι : Type u} (op : F ι) (cont : ι → FreeM F α) :
-    interp (liftBind op cont) = handler op >>= fun x => interp (cont x)
+  apply_lift_bind {ι : Type u} (op : F ι) (cont : ι → FreeM F α) :
+    interp (lift op >>= cont) = handler op >>= fun x => interp (cont x)
 
 theorem Interprets.eq {handler : {ι : Type u} → F ι → m ι} {interp : FreeM F α → m α}
     (h : Interprets handler interp) :
@@ -270,14 +287,13 @@ theorem Interprets.eq {handler : {ι : Type u} → F ι → m ι} {interp : Free
   ext x
   induction x with
   | pure a => exact h.apply_pure a
-  | liftBind op cont ih =>
-    rw [liftM_liftBind, h.apply_liftBind]
-    simp [ih]
+  | lift_bind op cont ih =>
+    simp [h.apply_lift_bind, ih]
 
 theorem Interprets.liftM (handler : {ι : Type u} → F ι → m ι) :
     Interprets handler (·.liftM handler : FreeM F α → _) where
   apply_pure _ := rfl
-  apply_liftBind _ _ := rfl
+  apply_lift_bind _ _ := rfl
 
 /--
 The universal property of the free monad `FreeM`.
diff --git a/Cslib/Foundations/Control/Monad/Free/Effects.lean b/Cslib/Foundations/Control/Monad/Free/Effects.lean
index 98d0f11241..7c58bca5a9 100644
--- a/Cslib/Foundations/Control/Monad/Free/Effects.lean
+++ b/Cslib/Foundations/Control/Monad/Free/Effects.lean
@@ -110,24 +110,24 @@ theorem run_toStateM {α : Type u} (comp : FreeState σ α) (s₀ : σ) :
 
 @[simp]
 lemma run_pure (a : α) (s₀ : σ) :
-    run (.pure a : FreeState σ α) s₀ = (a, s₀) := rfl
+    run (pure a : FreeState σ α) s₀ = (a, s₀) := rfl
 
 @[simp]
-lemma run_get (k : σ → FreeState σ α) (s₀ : σ) :
-    run (liftBind .get k) s₀ = run (k s₀) s₀ := rfl
+lemma run_get (s₀ : σ) :
+    run (lift .get) s₀ = (s₀, s₀) := rfl
 
 @[simp]
-lemma run_set (s' : σ) (k : PUnit → FreeState σ α) (s₀ : σ) :
-    run (liftBind (.set s') k) s₀ = run (k .unit) s' := rfl
+lemma run_set (s' : σ) (s₀ : σ) :
+    run (lift (.set s')) s₀ = (.unit, s') := rfl
 
 @[simp]
 lemma run_bind (x : FreeState σ α) (f : α → FreeState σ β) (s₀ : σ) :
     run (x.bind f) s₀ = let p := x.run s₀; (f p.1).run p.2 := by
-  induction x generalizing f s₀ with
+  induction x using FreeM.induction generalizing f s₀ with
   | pure => simp
-  | liftBind op cont ih =>
-    rw [FreeM.liftBind_bind]
-    cases op <;> simp [run, ih]
+  | lift_bind op cont ih =>
+    simp_rw [FreeM.bind_assoc]
+    cases op <;> simp [← liftBind_eq, run, ih]
 
 /-- Run a state computation, returning only the result. -/
 def run' (c : FreeState σ α) (s₀ : σ) : α := (run c s₀).1
@@ -140,15 +140,15 @@ theorem run'_toStateM {α : Type u} (comp : FreeState σ α) (s₀ : σ) :
 
 @[simp]
 lemma run'_pure (a : α) (s₀ : σ) :
-    run' (.pure a : FreeState σ α) s₀ = a := rfl
+    run' (pure a : FreeState σ α) s₀ = a := rfl
 
 @[simp]
-lemma run'_get (k : σ → FreeState σ α) (s₀ : σ) :
-    run' (liftBind .get k) s₀ = run' (k s₀) s₀ := rfl
+lemma run'_get (s₀ : σ) :
+    run' (lift .get) s₀ = s₀ := rfl
 
 @[simp]
-lemma run'_set (s' : σ) (k : PUnit → FreeState σ α) (s₀ : σ) :
-    run' (liftBind (.set s') k) s₀ = run' (k .unit) s' := rfl
+lemma run'_set (s' : σ) (s₀ : σ) :
+    run' (lift (.set s')) s₀ = .unit := rfl
 
 @[simp]
 lemma run'_bind (x : FreeState σ α) (f : α → FreeState σ β) (s₀ : σ) :
@@ -174,7 +174,7 @@ abbrev FreeWriter (ω : Type u) := FreeM (WriterF ω)
 namespace FreeWriter
 
 open WriterF
-variable {ω : Type u} {α : Type u}
+variable {ω : Type u} {α β : Type*}
 
 /-- Interpret `WriterF` operations into `WriterT`. -/
 @[simp]
@@ -212,21 +212,21 @@ def run [Monoid ω] : FreeWriter ω α → α × ω
 
 @[simp]
 lemma run_pure [Monoid ω] (a : α) :
-    run (.pure a : FreeWriter ω α) = (a, 1) := rfl
+    run (pure a : FreeWriter ω α) = (a, 1) := rfl
+
+@[simp]
+lemma run_lift_tell [Monoid ω] (w : ω) :
+    run (lift (.tell w)) = (.unit, w) := Prod.ext rfl <| mul_one _
 
 @[simp]
 lemma run_bind [Monoid ω] (x : FreeWriter ω α) (f : α → FreeWriter ω β) :
     run (x.bind f) = let p := run x; ((f p.1).run.1, p.2 * (f p.1).run.2) := by
-  induction x generalizing f with
+  induction x using FreeM.induction generalizing f with
   | pure => simp
-  | liftBind op cont ih =>
-    rw [FreeM.liftBind_bind]
+  | lift_bind op cont ih =>
+    simp_rw [FreeM.bind_assoc]
     cases op
-    simp [run, ih, mul_assoc]
-
-@[simp]
-lemma run_liftBind_tell [Monoid ω] (w : ω) (k : PUnit → FreeWriter ω α) :
-    run (liftBind (.tell w) k) = (let (a, w') := run (k .unit); (a, w * w')) := rfl
+    simp [← liftBind_eq, run, ih, mul_assoc]
 
 /--
 The canonical interpreter `toWriterT` derived from `liftM` agrees with the hand-written
@@ -235,14 +235,13 @@ recursive interpreter `run` for `FreeWriter`.
 @[simp]
 theorem run_toWriterT {α : Type u} [Monoid ω] (comp : FreeWriter ω α) :
     (toWriterT comp).run = pure (run comp) := by
-  ext : 1
-  induction comp with
-  | pure _ => simp only [liftM_pure, run_pure, pure, WriterT.run]
-  | liftBind op cont ih =>
+  induction comp using FreeM.induction with
+  | pure _ => simp [toWriterT]
+  | lift_bind op cont ih =>
+    simp only [toWriterT, run_bind] at *
+    ext : 1
     cases op
-    simp only [liftM_liftBind, run_liftBind_tell, Id.run_pure] at *
-    rw [ ← ih]
-    simp [WriterT.run_bind]
+    simp [ih]
 
 /--
 `listen` captures the log produced by a subcomputation incrementally. It traverses the computation,
@@ -257,13 +256,13 @@ def listen [Monoid ω] : FreeWriter ω α → FreeWriter ω (α × ω)
 
 @[simp]
 lemma listen_pure [Monoid ω] (a : α) :
-    listen (.pure a : FreeWriter ω α) = .pure (a, 1) := rfl
+    listen (pure a : FreeWriter ω α) = .pure (a, 1) := rfl
 
 @[simp]
-lemma listen_liftBind_tell [Monoid ω] (w : ω)
+lemma listen_lift_tell_bind [Monoid ω] (w : ω)
     (k : PUnit → FreeWriter ω α) :
-    listen (liftBind (.tell w) k) =
-      liftBind (.tell w) (fun _ =>
+    listen (lift (.tell w) >>= k) =
+      lift (.tell w) >>= (fun _ =>
         listen (k .unit) >>= fun (a, w') =>
           pure (a, w * w')) := by
   rfl
@@ -324,51 +323,43 @@ def run : FreeCont r α → (α → r) → r
   | .pure a, k => k a
   | .liftBind (.callCC g) cont, k => g (fun a => run (cont a) k)
 
-/--
-The canonical interpreter `toContT` derived from `liftM` agrees with the hand-written
-recursive interpreter `run` for `FreeCont`.
--/
 @[simp]
-theorem run_toContT {α : Type u} (comp : FreeCont r α) (k : α → r) :
-    (toContT comp).run k = pure (run comp k) := by
-  induction comp with
-  | pure a => rfl
-  | liftBind op cont ih =>
-    simp only [FreeM.liftM]
-    cases op
-    simp only [ContT.run_bind]
-    congr with x
-    apply ih
+lemma run_pure (a : α) (k : α → r) :
+    run (pure a : FreeCont r α) k = k a := rfl
 
 @[simp]
-lemma run_pure (a : α) (k : α → r) :
-    run (.pure a : FreeCont r α) k = k a := rfl
+lemma run_lift_callCC (g : (α → r) → r) (k : α → r) :
+    run (lift (.callCC g)) k = g k := rfl
 
 @[simp]
 lemma run_bind (x : FreeCont r α) (f : α → FreeCont r β) (k : β → r) :
     run (x.bind f) k = run x (fun i => run (f i) k) := by
-  induction x generalizing k with
+  induction x using FreeM.induction generalizing k with
   | pure a => rfl
-  | liftBind op cont ih =>
-    rw [FreeM.liftBind_bind]
+  | lift_bind op cont ih =>
+    rw [FreeM.bind_assoc]
     cases op
-    simp [run, ih]
+    simp [← liftBind_eq, run, ih]
 
+/--
+The canonical interpreter `toContT` derived from `liftM` agrees with the hand-written
+recursive interpreter `run` for `FreeCont`.
+-/
 @[simp]
-lemma run_liftBind_callCC (g : (α → r) → r)
-    (cont : α → FreeCont r β) (k : β → r) :
-    run (liftBind (.callCC g) cont) k = g (fun a => run (cont a) k) := rfl
+theorem run_toContT {α : Type u} (comp : FreeCont r α) (k : α → r) :
+    (toContT comp).run k = pure (run comp k) := by
+  simp only [toContT]
+  induction comp using FreeM.induction with
+  | pure a => rfl
+  | lift_bind op cont ih =>
+    cases op
+    simp_rw [run_bind]
+    simp [ih]
 
 /-- Call with current continuation for the Free continuation monad. -/
 def callCC (f : MonadCont.Label α (FreeCont r) β → FreeCont r α) :
     FreeCont r α :=
-  liftBind (.callCC fun k => run (f ⟨fun x => liftBind (.callCC fun _ => k x) pure⟩) k) pure
-
-@[simp]
-lemma callCC_def (f : MonadCont.Label α (FreeCont r) β → FreeCont r α) :
-    callCC f =
-      liftBind (.callCC fun k => run (f ⟨fun x => liftBind (.callCC fun _ => k x) pure⟩) k) pure :=
-  rfl
+  lift (.callCC fun k => run (f ⟨fun x => lift (.callCC fun _ => k x)⟩) k)
 
 instance : MonadCont (FreeCont r) where
   callCC := .callCC
@@ -376,8 +367,8 @@ instance : MonadCont (FreeCont r) where
 /-- `run` of a `callCC` node simplifies to running the handler with the current continuation. -/
 @[simp]
 lemma run_callCC (f : MonadCont.Label α (FreeCont r) β → FreeCont r α) (k : α → r) :
-    run (callCC f) k = run (f ⟨fun x => liftBind (.callCC fun _ => k x) pure⟩) k := by
-  simp [callCC, run_liftBind_callCC]
+    run (callCC f) k = run (f ⟨fun x => lift (.callCC fun _ => k x)⟩) k := by
+  simp [callCC]
 
 end FreeCont
 
@@ -395,7 +386,6 @@ variable {σ : Type u} {α : Type u}
 instance : MonadReaderOf σ (FreeReader σ) where
   read := .lift .read
 
-@[simp]
 lemma read_def : (read : FreeReader σ σ) = .lift .read := rfl
 
 instance : MonadReader σ (FreeReader σ) := inferInstance
@@ -433,19 +423,17 @@ theorem run_toReaderM {α : Type u} (comp : FreeReader σ α) (s : σ) :
 
 @[simp]
 lemma run_pure (a : α) (s₀ : σ) :
-    run (.pure a : FreeReader σ α) s₀ = a := rfl
+    run (pure a : FreeReader σ α) s₀ = a := rfl
 
 @[simp]
-lemma run_read (k : σ → FreeReader σ α) (s₀ : σ) :
-    run (liftBind .read k) s₀ = run (k s₀) s₀ := rfl
+lemma run_read (s₀ : σ) :
+    run read s₀ = s₀ := rfl
 
 @[simp]
 lemma run_bind (x : FreeReader σ α) (f : α → FreeReader σ β) (s₀ : σ) :
-    run (x.bind f) s₀ = run (f <| run x s₀) s₀ := by
-  induction x generalizing s₀ with
-  | pure a => rfl
-  | liftBind op cont ih =>
-    cases op; apply ih
+    run (x >>= f) s₀ = run (f <| run x s₀) s₀ := by
+  rw [← Id.run_pure (run _ _), ← run_toReaderM, toReaderM, liftM_bind, ReaderT.run_bind,
+    Id.run_bind, run_toReaderM, run_toReaderM, Id.run_pure, Id.run_pure]
 
 instance instMonadWithReaderOf : MonadWithReaderOf σ (FreeReader σ) where
   withReader {α} f m :=
diff --git a/Cslib/Foundations/Control/Monad/Free/Fold.lean b/Cslib/Foundations/Control/Monad/Free/Fold.lean
index 6b1f979094..7b07faed33 100644
--- a/Cslib/Foundations/Control/Monad/Free/Fold.lean
+++ b/Cslib/Foundations/Control/Monad/Free/Fold.lean
@@ -59,20 +59,36 @@ def foldFreeM
 theorem foldFreeM_pure
     (onValue : α → β)
     (onEffect : {ι : Type u} → F ι → (ι → β) → β)
-    (a : α) : foldFreeM onValue onEffect (.pure a) = onValue a := rfl
+    (a : α) : foldFreeM onValue onEffect (pure a) = onValue a := rfl
 
 @[simp]
-theorem foldFreeM_liftBind
+theorem foldFreeM_lift_bind
     (onValue : α → β)
     (onEffect : {ι : Type u} → F ι → (ι → β) → β)
     (op : F ι) (k : ι → FreeM F α) :
-    foldFreeM onValue onEffect (.liftBind op k)
+      foldFreeM onValue onEffect ((lift op).bind k)
       = onEffect op (fun x => foldFreeM onValue onEffect (k x)) := rfl
 
+@[simp]
+theorem foldFreeM_lift_bind' {F : Type w → Type v} {ι : Type w}
+    (onValue : α → β)
+    (onEffect : {ι : Type w} → F ι → (ι → β) → β)
+    (op : F ι) (k : ι → FreeM F α) :
+      foldFreeM onValue onEffect (lift op >>= k)
+      = onEffect op (fun x => foldFreeM onValue onEffect (k x)) := rfl
+
+@[simp]
+theorem foldFreeM_lift
+    (onValue : ι → β)
+    (onEffect : {ι : Type u} → F ι → (ι → β) → β)
+    (op : F ι) :
+    foldFreeM onValue onEffect (lift op) = onEffect op onValue :=
+  rfl
+
 /--
 **Universal Property**: If `h : FreeM F α → β` satisfies:
-* `h (.pure a) = onValue a`
-* `h (.liftBind op k) = onEffect op (fun x => h (k x))`
+* `h (pure a) = onValue a`
+* `h ((lift op).bind k) = onEffect op (fun x => h (k x))`
 
 then `h` is equal to `foldFreeM onValue onEffect`.
 -/
@@ -80,16 +96,16 @@ theorem foldFreeM_unique
     (onValue : α → β)
     (onEffect : {ι : Type u} → F ι → (ι → β) → β)
     (h : FreeM F α → β)
-    (h_pure : ∀ a, h (.pure a) = onValue a)
+    (h_pure : ∀ a, h (pure a) = onValue a)
     (h_liftBind : ∀ {ι} (op : F ι) (k : ι → FreeM F α),
-      h (.liftBind op k) = onEffect op (fun x => h (k x))) :
+      h ((lift op).bind k) = onEffect op (fun x => h (k x))) :
     h = foldFreeM onValue onEffect := by
   funext x
   induction x with
   | pure a =>
     rw [foldFreeM_pure, h_pure]
-  | liftBind op k ih =>
-    rw [foldFreeM_liftBind, h_liftBind]
+  | lift_bind op k ih =>
+    rw [foldFreeM_lift_bind, h_liftBind]
     grind
 
 end FreeM
diff --git a/CslibTests/FreeMonad.lean b/CslibTests/FreeMonad.lean
index 947fa9ff5f..9928038563 100644
--- a/CslibTests/FreeMonad.lean
+++ b/CslibTests/FreeMonad.lean
@@ -266,7 +266,7 @@ theorem runEff_bind_ok {α β}
   revert h
   induction p generalizing env env' tr tr' v <;> simp only [runEff, bind, foldFreeM] <;> intro h
   · case pure => cases h; rfl
-  · case liftBind _ op _ ih =>
+  · case lift_bind _ op _ ih =>
     cases op
     · case inl s => cases s <;> exact ih _ h
     · case inr s =>
@@ -287,7 +287,7 @@ theorem runEff_bind_err {α β}
     runEff (p >>= k) env tr = .error msg := by
   induction p generalizing env tr msg <;> simp only [runEff, bind, foldFreeM] <;> intro h
   · case pure => simp [effPure] at h
-  · case liftBind _ op _ ih =>
+  · case lift_bind _ op _ ih =>
     cases op
     · case inl s => cases s <;> exact ih _ h
     · case inr s =>
@@ -309,39 +309,39 @@ theorem runEff_eval_correct (e : Expr) (env : Env) (trace : Trace)
     runEff (eval e) env trace = res := by
   induction h
   · case val z env trace =>
-    simp [eval, pure_eq_pure, runEff, effPure]
+    simp [eval, runEff, effPure]
   · case var_found x env trace v h =>
-    simp [runEff, eval, getEnv, lift_def, effStep, h, effPure]
+    simp [runEff, eval, getEnv, effStep, h, effPure]
   · case var_missing x env trace h =>
-    simp [runEff, eval, bind, getEnv, fail, lift_def, effStep, h]
+    simp [runEff, eval, getEnv, fail, effStep, h, - LawfulMonad.bind_pure_comp]
   · case add e₁ e₂ env trace₁ trace₂ trace₃ v1 v2 env₂ env₃ h₁ h₂ ih₁ ih₂ =>
-    simp [eval, bind]
+    simp [eval]
     have step₁ := runEff_bind_ok (p := eval e₁ ) (k := fun v1 => do
       let v2 ← eval e₂
       pure (v1 + v2)) ih₁
-    simp [bind] at step₁; simp [step₁]
+    simp at step₁; simp [step₁]
     have step₂ := runEff_bind_ok (p := eval e₂) (k := fun v2 => pure (v1 + v2)) ih₂
-    simp [bind] at step₂; simp [step₂]; rfl
+    simp at step₂; simp [step₂]; rfl
   · case div_ok e₁ e₂ env trace₁ trace₂ trace₃ v₁ v₂ env₂ env₃ v₂_ne_0 h₁ h₂ ih₁ ih₂  =>
-    simp [eval, bind]
+    simp [eval]
     have step₁ := runEff_bind_ok (p := eval e₁) (k := fun v1 => do
       let v2 ← eval e₂
       if v2 = 0 then do fail "divide by zero"; pure 0 else pure (v1 / v2)) ih₁
-    simp [bind] at step₁; simp [step₁]
+    simp at step₁; simp [step₁]
     have step₂ := runEff_bind_ok (p := eval e₂) (k := fun v₂ =>
       if v₂ = 0 then do fail "divide by zero"; pure 0 else pure (v₁ / v₂)) ih₂
-    simp [bind] at step₂; simp [step₂, v₂_ne_0]
+    simp at step₂; simp [step₂, v₂_ne_0]
     rfl
   · case div_zero e₁ e₂ env' trace₁ trace₂ trace₃ v₁ v₂ env₂ env₃ v₂_eq_0 h₁ h₂ ih₁ ih₂ =>
-    simp [eval, bind]
+    simp [eval]
     have step₁ := runEff_bind_ok (p := eval e₁) (k := fun v₁ => do
       let v₂ ← eval e₂
       if v₂ = 0 then fail "divide by zero"; pure 0 else pure (v₁ / v₂)) ih₁
-    simp [bind] at step₁; simp [step₁]
+    simp at step₁; simp [step₁]
     have step₂ := runEff_bind_ok (p := eval e₂) (k := fun v₂ =>
       if v₂ = 0 then (do fail "divide by zero"; pure 0) else pure (v₁ / v₂)) ih₂
-    simp [bind] at step₂; simp [step₂, v₂_eq_0]
-    simp [fail, lift, runEff]
+    simp at step₂; simp [step₂, v₂_eq_0]
+    simp [fail, runEff]
     rfl
 
 end CslibTests

From 024db9e781e518602763841e57b73d4eadc00183 Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Thu, 28 May 2026 12:46:13 -0400
Subject: [PATCH 082/106] chore: use `tfae_*` tactics (#600)

I wasn't aware previously that `TFAE` came with these tactics. This is a
bit nicer since all these theorems are `private`.
---
 Cslib/Foundations/Data/Relation.lean | 21 ++++++---------------
 1 file changed, 6 insertions(+), 15 deletions(-)

diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index 4ff14dfb03..bc3f0ec2bf 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -8,6 +8,7 @@ module
 
 public import Cslib.Init
 public import Mathlib.Data.List.TFAE
+public import Mathlib.Tactic.TFAE
 public import Mathlib.Order.Comparable
 public import Mathlib.Order.WellFounded
 public import Mathlib.Order.BooleanAlgebra.Basic
@@ -141,22 +142,12 @@ section euclidean_symm
 
 variable [Std.Symm r]
 
-private theorem RightEuclidean.symm_leftEuclidean [RightEuclidean r] : LeftEuclidean r where
-  leftEuclidean ac bc := rightEuclidean (symm ac) (symm bc)
-
-private theorem LeftEuclidean.symm_trans [LeftEuclidean r] : IsTrans α r where
-  trans _ _ _ ab bc := leftEuclidean ab (symm bc)
-
-private theorem RightEuclidean.trans_symm [IsTrans α r] : RightEuclidean r where
-  rightEuclidean ab ac := _root_.trans (symm ab) ac
-
+open RightEuclidean LeftEuclidean in
 private theorem symm_equivalents : [RightEuclidean r, LeftEuclidean r, IsTrans α r].TFAE := by
-  apply List.tfae_of_cycle
-  · simp only [List.isChain_cons_cons, List.IsChain.singleton, and_true]
-    split_ands
-    · exact @RightEuclidean.symm_leftEuclidean _ _ _
-    · exact @LeftEuclidean.symm_trans _ _ _
-  · exact @RightEuclidean.trans_symm _ _ _
+  tfae_have 1 → 2 := fun _ => ⟨fun ac bc => rightEuclidean (symm ac) (symm bc)⟩
+  tfae_have 2 → 3 := fun _ => ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩
+  tfae_have 3 → 1 := fun _ => ⟨fun ab ac => _root_.trans (symm ab) ac⟩
+  tfae_finish
 
 /-- For a symmetric relation, `LeftEuclidean` and `RightEuclidean` are equivalent. -/
 theorem symm_leftEuclidean_iff_rightEuclidean : LeftEuclidean r ↔ RightEuclidean r :=

From a264a6002ac2d10c658d840c5c24479e0a0cc220 Mon Sep 17 00:00:00 2001
From: Samuel Schlesinger <SamuelSchlesinger@users.noreply.github.com>
Date: Thu, 28 May 2026 12:47:28 -0400
Subject: [PATCH 083/106] feat(MachineLearning/PACLearning): VC dimension
 (#563)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Adds the Vapnik-Chervonenkis dimension for binary concept classes `C :
ConceptClass α Bool`, with:

- `SetShatters C W`: `C` shatters a set `W` if every `W' ⊆ W` arises as
the intersection of some `c ⁻¹' {true}` with `W` for `c ∈ C`.
- `SetShatters.subset` / `SetShatters.superset`: anti/monotonicity in
the shattered set and the concept class.
- `Finset.Shatters.toSetShatters`: bridge from Mathlib's
`Finset.Shatters` to `SetShatters` via characteristic functions.
- `vcDim C`: VC dimension as `sSup` of shattered finite-set
cardinalities.
- `HasFiniteVCDim C` and `hasFiniteVCDim_iff`: the predicate making
`vcDim` mathematically meaningful (uniform bound on shattered
cardinalities), required as a hypothesis by downstream `vcDim`-stated
lower bounds.

First layer of a stacked PR sequence formalizing the EHKV lower bound on
PAC sample complexity.
---
 Cslib.lean                                    |   1 +
 .../PACLearning/VCDimension.lean              | 128 ++++++++++++++++++
 2 files changed, 129 insertions(+)
 create mode 100644 Cslib/MachineLearning/PACLearning/VCDimension.lean

diff --git a/Cslib.lean b/Cslib.lean
index b504973c3e..070e6dc0f2 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -139,4 +139,5 @@ public import Cslib.Logics.Modal.Denotation
 public import Cslib.Logics.Propositional.Defs
 public import Cslib.Logics.Propositional.NaturalDeduction.Basic
 public import Cslib.MachineLearning.PACLearning.Defs
+public import Cslib.MachineLearning.PACLearning.VCDimension
 public import Cslib.Probability.PMF
diff --git a/Cslib/MachineLearning/PACLearning/VCDimension.lean b/Cslib/MachineLearning/PACLearning/VCDimension.lean
new file mode 100644
index 0000000000..3084b95629
--- /dev/null
+++ b/Cslib/MachineLearning/PACLearning/VCDimension.lean
@@ -0,0 +1,128 @@
+/-
+Copyright (c) 2026 Samuel Schlesinger. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Samuel Schlesinger
+-/
+
+module
+
+public import Cslib.MachineLearning.PACLearning.Defs
+public import Mathlib.Combinatorics.SetFamily.Shatter
+
+/-! # VC Dimension for Concept Classes
+
+This file defines *shattering* and the *Vapnik-Chervonenkis dimension* for
+binary concept classes `C : ConceptClass α Bool`, i.e. sets of `α → Bool`
+classifiers. Each Boolean classifier `c` is identified with the subset
+`c ⁻¹' {true} ⊆ α` (the "positive set"), and `C` shatters a set `W` if every
+subset of `W` can be obtained as the positive set of some `c ∈ C` intersected
+with `W`. See also the `Finset`-based definitions in
+`Mathlib.Combinatorics.SetFamily.Shatter`.
+
+## Main definitions
+
+- `SetShatters C W`: the concept class `C` shatters the set `W`.
+- `vcDim C`: the VC dimension of `C`, i.e. the supremum of the cardinalities of
+  finite sets shattered by `C`.
+
+## Main statements
+
+- `SetShatters.subset`: shattering is anti-monotone in the shattered set.
+- `SetShatters.superset`: shattering is monotone in the concept class.
+- `Finset.Shatters.toSetShatters`: bridge from Mathlib's `Finset.Shatters`
+  to `SetShatters`.
+
+## References
+
+* [A. Ehrenfeucht, D. Haussler, M. Kearns, L. Valiant,
+  *A General Lower Bound on the Number of Examples Needed
+  for Learning*][EHKV1989]
+-/
+
+@[expose] public section
+
+open Set
+
+namespace Cslib.MachineLearning.PACLearning
+
+variable {α : Type*}
+
+/-- A binary concept class `C` *shatters* a set `W` if for every subset `W' ⊆ W`,
+there exists a concept `c ∈ C` whose positive set `c ⁻¹' {true}` intersects `W`
+in exactly `W'`. -/
+def SetShatters (C : ConceptClass α Bool) (W : Set α) : Prop :=
+  ∀ W' ⊆ W, ∃ c ∈ C, c ⁻¹' {true} ∩ W = W'
+
+/-- Shattering is anti-monotone in the shattered set: if `C` shatters `W` and
+`V ⊆ W`, then `C` shatters `V`. -/
+theorem SetShatters.subset {C : ConceptClass α Bool} {W V : Set α}
+    (hW : SetShatters C W) (hVW : V ⊆ W) : SetShatters C V := by
+  intro V' hV'V
+  obtain ⟨c, hc, hc_eq⟩ := hW (V' ∪ (W \ V))
+    (union_subset (hV'V.trans hVW) diff_subset)
+  refine ⟨c, hc, ?_⟩
+  rw [show V = W ∩ V from (inter_eq_self_of_subset_right hVW).symm,
+    ← inter_assoc, hc_eq]
+  ext x
+  simp only [mem_inter_iff, mem_union, mem_diff]
+  refine ⟨?_, fun h => ⟨Or.inl h, hV'V h⟩⟩
+  rintro ⟨h1 | ⟨_, h2⟩, h3⟩
+  · exact h1
+  · exact absurd h3 h2
+
+/-- Shattering is monotone in the concept class: if `C` shatters `W` and `C ⊆ C'`,
+then `C'` shatters `W`. -/
+theorem SetShatters.superset {C C' : ConceptClass α Bool} {W : Set α}
+    (hW : SetShatters C W) (hCC' : C ⊆ C') : SetShatters C' W := by
+  intro W' hW'
+  obtain ⟨c, hc, hcW⟩ := hW W' hW'
+  exact ⟨c, hCC' hc, hcW⟩
+
+open Classical in
+/-- If a finite set family `𝒜` shatters a finite set `s` in the sense of Mathlib's
+`Finset.Shatters`, then the concept class of characteristic functions of sets in `𝒜`
+shatters `↑s` in the sense of `SetShatters`. This bridges Mathlib's finset-based
+shattering to the predicate used by the PAC learning lower bounds. -/
+theorem _root_.Finset.Shatters.toSetShatters {𝒜 : Finset (Finset α)} {s : Finset α}
+    (h : 𝒜.Shatters s) :
+    SetShatters
+      {c : α → Bool | ∃ t ∈ 𝒜, ∀ x, c x = decide (x ∈ t)} ↑s := by
+  intro W' hW'
+  have hfin : Set.Finite W' := s.finite_toSet.subset hW'
+  set t := hfin.toFinset
+  have ht_eq : (↑t : Set α) = W' := hfin.coe_toFinset
+  have ht_sub : t ⊆ s := Finset.coe_subset.mp (ht_eq ▸ hW')
+  obtain ⟨u, hu, hsu⟩ := h ht_sub
+  have hut : u ∩ s = t := by rwa [Finset.inter_comm] at hsu
+  refine ⟨fun x => decide (x ∈ u), ⟨u, hu, fun _ => rfl⟩, ?_⟩
+  rw [← ht_eq]
+  ext x
+  simp only [mem_inter_iff, mem_preimage, mem_singleton_iff,
+    decide_eq_true_eq, Finset.mem_coe]
+  exact ⟨fun ⟨h1, h2⟩ => hut ▸ Finset.mem_inter.mpr ⟨h1, h2⟩,
+    fun h => Finset.mem_inter.mp (hut.symm ▸ h)⟩
+
+/-- The *Vapnik-Chervonenkis dimension* of a binary concept class `C` is the
+supremum of the cardinalities of finite sets shattered by `C`. Returns `0` when
+no finite set is shattered (i.e. the defining set is empty).
+
+**Caveat**: because `sSup` on `ℕ` returns `0` for unbounded sets, this definition
+is only meaningful when the VC dimension is finite — see `HasFiniteVCDim`. -/
+noncomputable def vcDim (C : ConceptClass α Bool) : ℕ :=
+  sSup {n : ℕ | ∃ W : Finset α, W.card = n ∧ SetShatters C (↑W)}
+
+/-- A binary concept class `C` has *finite VC dimension* if there is a uniform
+upper bound on the cardinalities of finite sets it shatters. This is the
+hypothesis under which `vcDim C` is mathematically meaningful (otherwise
+`vcDim` returns `0` for unbounded shattered families via `sSup` on `ℕ`). -/
+def HasFiniteVCDim (C : ConceptClass α Bool) : Prop :=
+  BddAbove {n : ℕ | ∃ W : Finset α, W.card = n ∧ SetShatters C (↑W)}
+
+/-- A class has finite VC dimension iff there is a uniform bound on the
+cardinality of every shattered finite set. -/
+theorem hasFiniteVCDim_iff {C : ConceptClass α Bool} :
+    HasFiniteVCDim C ↔ ∃ N : ℕ, ∀ W : Finset α, SetShatters C ↑W → W.card ≤ N :=
+  ⟨fun ⟨N, hN⟩ => ⟨N, fun W hW => hN ⟨W, rfl, hW⟩⟩,
+   fun ⟨N, hN⟩ => ⟨N, fun _ ⟨W, hWc, hW⟩ => hWc ▸ hN W hW⟩⟩
+
+end Cslib.MachineLearning.PACLearning

From 8e4dcb32d320e261e6a4ee5ad619bbde6c7b6f3a Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Thu, 28 May 2026 12:54:57 -0400
Subject: [PATCH 084/106] feat: more lemmas on Euclidean relations (#574)

A few more lemmas on Euclidean relations. Some other changes to note:
- The addition of `Relation.{cod,dom}`, mirroring what is done in
Mathlib with `SetRel` but for unbundled relations. I am mulling over
making a dedicated definition for restrictions of an unbundled relation,
but wanted to have a few theorems to test with first.
- I change the name `RightEuclidean.refl_range` to
`RightEuclidean.refl_cod` for naming consistency
- Using `Relator.LeftTotal` for the definition of `Serial`. None of the
modal logic proofs change at all, as these are identical.
---
 Cslib/Foundations/Data/Relation.lean | 229 ++++++++++++++++++++++++++-
 references.bib                       |  12 ++
 2 files changed, 235 insertions(+), 6 deletions(-)

diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index bc3f0ec2bf..4e8953f121 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -12,18 +12,22 @@ public import Mathlib.Tactic.TFAE
 public import Mathlib.Order.Comparable
 public import Mathlib.Order.WellFounded
 public import Mathlib.Order.BooleanAlgebra.Basic
+public import Mathlib.Data.Fintype.EquivFin
 
 /-! # Relations
 
 ## References
 
 * [*Term Rewriting and All That*][Baader1998]
+* [*Simple Laws about Nonprominent Properties of Binary Relations*][Burghardt2018]
 
 -/
 
 @[expose] public section
 
-variable {α : Type*} {r : α → α → Prop}
+open Relator
+
+variable {α : Type*} {r r₁ r₂ : α → α → Prop}
 
 theorem WellFounded.ofTransGen (trans_wf : WellFounded (Relation.TransGen r)) : WellFounded r := by
   grind [WellFounded.wellFounded_iff_has_min, Relation.TransGen]
@@ -38,6 +42,78 @@ namespace Relation
 @[nolint unusedArguments]
 def emptyHRelation {α : Sort u} {β : Sort v} (_ : α) (_ : β) := False
 
+@[simp, grind =]
+theorem emptyHRelation_emptyRelation : (emptyHRelation : α → α → Prop) = emptyRelation := rfl
+
+@[simp, grind =]
+theorem emptyHrelation_apply (a : α) (b : β) : emptyHRelation a b ↔ False := .rfl
+
+section dom_cod
+
+variable {β : Type*} {r : α → β → Prop}
+
+/-- Domain of a relation. -/
+def dom (r : α → β → Prop) : Set α := {a | ∃ b, r a b}
+
+/-- Codomain of a relation, aka range. -/
+def cod (r : α → β → Prop) : Set β := {b | ∃ a, r a b}
+
+@[simp, grind =] lemma mem_dom : a ∈ dom r ↔ ∃ b, r a b := .rfl
+@[simp, grind =] lemma mem_cod : b ∈ cod r ↔ ∃ a, r a b := .rfl
+
+@[gcongr] lemma dom_mono (h : r₁ ≤ r₂) : dom r₁ ⊆ dom r₂ := fun a ⟨b, hab⟩ => ⟨b, h a b hab⟩
+@[gcongr] lemma cod_mono (h : r₁ ≤ r₂) : cod r₁ ⊆ cod r₂ := fun b ⟨a, hab⟩ => ⟨a, h a b hab⟩
+
+@[simp, grind =]
+lemma dom_empty : dom (emptyHRelation : α → β → Prop) = ∅ := by grind
+
+@[simp, grind =]
+lemma cod_empty : cod (emptyHRelation : α → β → Prop) = ∅ := by grind
+
+@[simp, grind =]
+lemma dom_eq_empty_iff : dom r = ∅ ↔ r = emptyHRelation where
+  mp h := by
+    ext a b
+    simp
+    grind => have : a ∈ dom r; finish
+  mpr := by grind
+
+@[simp, grind =]
+lemma cod_eq_empty_iff : cod r = ∅ ↔ r = emptyHRelation where
+  mp h := by
+    ext a b
+    simp
+    grind => have : b ∈ cod r; finish
+  mpr h := by grind
+
+@[simp]
+lemma cod_inv : cod (fun a b => r b a) = dom r := rfl
+
+@[simp]
+lemma dom_inv : dom (fun a b => r b a) = cod r := rfl
+
+end dom_cod
+
+instance : CoeDep (α → α → Prop) r (dom r → dom r → Prop) where
+  coe a b := r a b
+
+instance : CoeDep (α → α → Prop) r (cod r → cod r → Prop) where
+  coe a b := r a b
+
+theorem _root_.Std.Trichotomous.subsingleton_cod [Std.Trichotomous r] :
+    Subsingleton ((cod r)ᶜ : Set α) := by
+  constructor
+  rintro ⟨b₁, _⟩ ⟨b₂, _⟩
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b₁ b₂
+  grind
+
+theorem _root_.Std.Trichotomous.subsingleton_dom [Std.Trichotomous r] :
+    Subsingleton ((dom r)ᶜ : Set α) := by
+  constructor
+  rintro ⟨a₁, _⟩ ⟨a₂, _⟩
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a₁ a₂
+  grind
+
 attribute [scoped grind] ReflGen TransGen ReflTransGen EqvGen CompRel
 
 theorem ReflGen.to_eqvGen (h : ReflGen r a b) : EqvGen r a b := by
@@ -83,7 +159,9 @@ namespace RightEuclidean
 variable [RightEuclidean r]
 
 /-- A `RightEuclidean` relation is reflexive on its range -/
-theorem refl_range (ab : r a b) : r b b := rightEuclidean ab ab
+theorem refl_cod (ab : r a b) : r b b := rightEuclidean ab ab
+
+theorem refl_cod' : b ∈ cod r → r b b := fun ⟨_, ab⟩ ↦ refl_cod ab
 
 /-- The converse of a `RightEuclidean` relation is `LeftEuclidean` -/
 theorem leftEuclidean_swap : LeftEuclidean (fun a b => r b a) where
@@ -95,7 +173,7 @@ instance [Std.Refl r] : Std.Symm r where
 theorem trichotomous_trans [Std.Trichotomous r] : IsTrans α r where
   trans a b c ab bc := by
     have := Std.Trichotomous.trichotomous (r := r) a c
-    have cc := refl_range bc
+    have cc := refl_cod bc
     have (ca : r c a) := rightEuclidean ca cc
     grind
 
@@ -104,7 +182,63 @@ theorem antisymm_rightUnique [Std.Antisymm r] : Relator.RightUnique r := by
   exact antisymm (rightEuclidean ab ac) (rightEuclidean ac ab)
 
 theorem rightUnique_antisymm (h : Relator.RightUnique r) : Std.Antisymm r where
-  antisymm _ _ ab ba := h ba (refl_range ab)
+  antisymm _ _ ab ba := h ba (refl_cod ab)
+
+theorem rightUnique_trans (h : Relator.RightUnique r) : IsTrans α r where
+  trans a b c ab bc := by
+    have eq : c = b := h bc (refl_cod ab)
+    simpa [eq]
+
+theorem rightTotal_equiv (h : Relator.RightTotal r) : IsEquiv α r := by
+  have : Std.Refl r := ⟨fun a => refl_cod (h a).choose_spec⟩
+  exact {toIsTrans := ⟨fun _ _ _ ab bc => rightEuclidean (symm ab) bc⟩}
+
+omit [RightEuclidean r] in
+theorem leftTotal_rightUnique_trans (h₁ : LeftTotal r) (h₂ : RightUnique r) [IsTrans α r] :
+    RightEuclidean r where
+  rightEuclidean {a b c} ab ac := by
+    obtain ⟨d, dc⟩ := h₁ c
+    have : b = c := h₂ ab ac
+    have : d = c := h₂ (_root_.trans ac dc) ac
+    grind
+
+private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] :
+    ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by
+  rintro ⟨a, b, c, _⟩
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c
+  have := antisymm_rightUnique (r := r)
+  have := @refl_cod (r := r)
+  grind [Relator.RightUnique]
+
+theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by
+  classical
+  by_contra! h
+  apply three_contra (r := r)
+  have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3
+  have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard
+  use a, b, c
+
+theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] :
+    Fintype.card α ≤ 2 := by
+  by_contra! h
+  apply three_contra (r := r)
+  have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h
+  use a, b, c
+
+theorem cod_subset_dom : cod r ⊆ dom r := fun b ⟨_, ab⟩ ↦ ⟨b, refl_cod ab⟩
+
+instance : RightEuclidean (α := cod r) r where
+  rightEuclidean := rightEuclidean
+
+instance : RightEuclidean (α := dom r) r where
+  rightEuclidean := rightEuclidean
+
+theorem rightTotal_cod : Relator.RightTotal (α := cod r) (β := cod r) r :=
+  fun ⟨_, _, h⟩ => ⟨_, refl_cod h⟩
+
+theorem equiv_cod : IsEquiv (cod r) r := rightTotal_equiv rightTotal_cod
 
 end RightEuclidean
 
@@ -115,6 +249,8 @@ variable [LeftEuclidean r]
 /-- A `LeftEuclidean` relation is reflexive on its domain -/
 theorem refl_dom (ab : r a b) : r a a := leftEuclidean ab ab
 
+theorem refl_dom' : a ∈ dom r → r a a := fun ⟨_, ab⟩ ↦ refl_dom ab
+
 /-- The converse of a `LeftEuclidean` relation is `RightEuclidean` -/
 theorem rightEuclidean_swap : RightEuclidean (fun a b => r b a) where
   rightEuclidean ab ac := leftEuclidean ac ab
@@ -136,6 +272,62 @@ theorem antisymm_leftUnique [Std.Antisymm r] : Relator.LeftUnique r := by
 theorem leftUnique_antisymm (h : Relator.LeftUnique r) : Std.Antisymm r where
   antisymm _ _ ab ba := h ab (refl_dom ba)
 
+theorem leftUnique_trans (h : Relator.LeftUnique r) : IsTrans α r where
+  trans a b c ab bc := by
+    have eq : a = b := h ab (refl_dom bc)
+    simpa [eq]
+
+theorem leftTotal_equiv (h : Relator.LeftTotal r) : IsEquiv α r := by
+  have : Std.Refl r := ⟨fun a => refl_dom (h a).choose_spec⟩
+  exact {toIsTrans := ⟨fun _ _ _ ab bc => leftEuclidean ab (symm bc)⟩}
+
+omit [LeftEuclidean r] in
+theorem rightTotal_leftUnique_trans (h₁ : RightTotal r) (h₂ : LeftUnique r) [IsTrans α r] :
+    LeftEuclidean r where
+  leftEuclidean {a b c} ac bc := by
+    obtain ⟨d, da⟩ := h₁ a
+    have : a = b := h₂ ac bc
+    have : a = d := h₂ ac (_root_.trans da ac)
+    grind
+
+private theorem three_contra [Std.Trichotomous r] [Std.Antisymm r] :
+    ¬ ∃ (a b c : α), a ≠ b ∧ a ≠ c ∧ b ≠ c := by
+  rintro ⟨a, b, c, _⟩
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a b
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ a c
+  have := @Std.Trichotomous.rel_or_eq_or_rel_swap _ r _ b c
+  have := antisymm_leftUnique (r := r)
+  have := @refl_dom (r := r)
+  grind [Relator.LeftUnique]
+
+theorem trichotomous_antisymm_finite [Std.Trichotomous r] [Std.Antisymm r] : Finite α := by
+  classical
+  by_contra! h
+  apply three_contra (r := r)
+  have ⟨_, hcard⟩ := Infinite.exists_subset_card_eq α 3
+  have ⟨a, b, c, _, _, _, _⟩ := Finset.card_eq_three.mp hcard
+  use a, b, c
+
+theorem trichotomous_antisymm_card [Std.Trichotomous r] [Std.Antisymm r] [Fintype α] :
+    Fintype.card α ≤ 2 := by
+  by_contra! h
+  apply three_contra (r := r)
+  have ⟨a, b, c, _⟩ := Fintype.two_lt_card_iff.mp h
+  use a, b, c
+
+theorem dom_subset_cod : dom r ⊆ cod r := fun a ⟨_, ab⟩ ↦ ⟨a, refl_dom ab⟩
+
+instance : LeftEuclidean (α := cod r) r where
+  leftEuclidean := leftEuclidean
+
+instance : LeftEuclidean (α := dom r) r where
+  leftEuclidean := leftEuclidean
+
+theorem leftTotal_dom : Relator.LeftTotal (α := dom r) (β := dom r) r :=
+  fun ⟨_, _, h⟩ => ⟨_, refl_dom h⟩
+
+theorem equiv_dom : IsEquiv (dom r) r := leftTotal_equiv leftTotal_dom
+
 end LeftEuclidean
 
 section euclidean_symm
@@ -163,6 +355,31 @@ theorem symm_rightEuclidean_iff_trans : RightEuclidean r ↔ IsTrans α r :=
 
 end euclidean_symm
 
+theorem leftEuclidean_rightEuclidean_dom_cod_eq [LeftEuclidean r] [RightEuclidean r] :
+    dom r = cod r := by
+  have : dom r ⊆ cod r := LeftEuclidean.dom_subset_cod
+  have : cod r ⊆ dom r := RightEuclidean.cod_subset_dom
+  grind
+
+theorem dom_cod_leftEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] :
+    LeftEuclidean r where
+  leftEuclidean {a b c} ac bc := by
+    have cb : r c b := equiv_dom.symm ⟨_, _, bc⟩ ⟨c, by grind⟩ bc
+    exact equiv_dom.trans ⟨_, _, ac⟩ ⟨_, _, cb⟩ ⟨_, by grind⟩ ac cb
+
+lemma dom_cod_rightEuclidean (eq : dom r = cod r) [equiv_dom : IsEquiv (dom r) r] :
+    RightEuclidean r where
+  rightEuclidean {a b c} ab ac := by
+    have ba : r b a := equiv_dom.symm ⟨a, _, ab⟩ ⟨b, by grind⟩ ab
+    exact equiv_dom.trans ⟨_, _, ba⟩ ⟨_, _, ac⟩ ⟨c, by grind⟩ ba ac
+
+/-- A relation is both left and right Euclidean if and only if the relation is an equivalence on
+  coinciding domain and codomain. -/
+theorem leftEuclidean_rightEuclidean_iff_dom_cod :
+    LeftEuclidean r ∧ RightEuclidean r ↔ dom r = cod r ∧ IsEquiv (dom r) r where
+  mp := fun ⟨_, _⟩ ↦ ⟨leftEuclidean_rightEuclidean_dom_cod_eq, LeftEuclidean.equiv_dom⟩
+  mpr := fun ⟨eq, _⟩ ↦ ⟨dom_cod_leftEuclidean eq, dom_cod_rightEuclidean eq⟩
+
 /-- A relation has the diamond property when all reductions with a common origin are joinable -/
 abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c
 
@@ -242,9 +459,9 @@ theorem Confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) :
 /-- An element is reducible with respect to a relation if there is a value it is related to. -/
 abbrev Reducible (r : α → α → Prop) (x : α) : Prop := ∃ y, r x y
 
-/-- A relation `r` is serial if every element is `Reducible`. -/
+/-- A relation `r` is serial if every element is `Reducible`, i.e. `Relator.LeftTotal`. -/
 class Serial (r : α → α → Prop) where
-  serial a : Reducible r a
+  serial : Relator.LeftTotal r
 
 @[scoped grind →]
 lemma refl_serial (r : α → α → Prop) (h : Std.Refl r) : Relation.Serial r where
diff --git a/references.bib b/references.bib
index f0d122d179..7b68d1f7ad 100644
--- a/references.bib
+++ b/references.bib
@@ -49,6 +49,18 @@ @book{Blackburn2001
   collection={Cambridge Tracts in Theoretical Computer Science}
 }
 
+@misc{Burghardt2018,
+	title = {Simple {Laws} about {Nonprominent} {Properties} of {Binary} {Relations}},
+	url = {https://arxiv.org/abs/1806.05036v2},
+	abstract = {We checked each binary relation on a 5-element set for a given set of properties, including usual ones like asymmetry and less known ones like Euclideanness. Using a poor man's Quine-McCluskey algorithm, we computed prime implicants of non-occurring property combinations, like "not irreflexive, but asymmetric". We considered the non-trivial laws obtained this way, and manually proved them true for binary relations on arbitrary sets, thus contributing to the encyclopedic knowledge about less known properties.},
+	language = {en},
+	urldate = {2026-05-19},
+	journal = {arXiv.org},
+	author = {Burghardt, Jochen},
+	month = jun,
+	year = {2018},
+}
+
 @inproceedings{Danielsson2008,
 author = {Danielsson, Nils Anders},
 title = {Lightweight semiformal time complexity analysis for purely functional data structures},

From 00ecf15624690cf6bdc9ce244efe3fa40bdc54fb Mon Sep 17 00:00:00 2001
From: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Date: Thu, 28 May 2026 13:12:31 -0400
Subject: [PATCH 085/106] chore: refactor proofs where `grind?` fails (#602)

These are sources of technical debt as now reported in the [weekly
linting
report](https://leanprover.zulipchat.com/#narrow/channel/513188-CSLib/topic/Weekly.20linting.20log/with/563737370).
The idea is that a successful grind proof can fail to report the
theorems it used via `grind?`, which means that if these proofs break
across toolchains that it becomes significantly harder to repair.

Most of these are fixed by squeezing the call to grind and unsetting
`linter.tacticAnalysis.verifyGrindOnly` so they no longer appear in the
weekly report. Unfortunately, this can't be on by default for
performance reasons, but I highly encourage using this linter when
adding any grind proofs.

---------

Co-authored-by: Ching-Tsun Chou <chingtsun.chou@gmail.com>
---
 Cslib/Computability/Automata/DA/ToNA.lean     |  5 ++-
 .../Computability/Automata/NA/BuchiInter.lean |  4 +-
 Cslib/Computability/Automata/NA/Concat.lean   | 11 +++++-
 Cslib/Computability/Automata/NA/Hist.lean     |  3 +-
 Cslib/Computability/Automata/NA/Loop.lean     |  9 ++++-
 Cslib/Computability/Automata/NA/Pair.lean     |  7 ++--
 Cslib/Computability/Automata/NA/Prod.lean     |  3 +-
 Cslib/Computability/Automata/NA/Sum.lean      |  9 +++--
 .../Congruences/BuchiCongruence.lean          | 23 ++++++-----
 .../Languages/ExampleEventuallyZero.lean      |  7 +++-
 .../Languages/OmegaLanguage.lean              | 11 ++++--
 Cslib/Computability/URM/Execution.lean        |  7 +++-
 Cslib/Computability/URM/StraightLine.lean     |  7 +++-
 .../Foundations/Data/OmegaSequence/Defs.lean  |  3 +-
 .../Foundations/Data/OmegaSequence/Init.lean  |  6 ++-
 .../Data/OmegaSequence/Temporal.lean          |  3 +-
 Cslib/Foundations/Data/Relation.lean          |  5 ++-
 .../Foundations/Semantics/FLTS/LTSToFLTS.lean |  4 +-
 .../Semantics/LTS/Bisimulation.lean           |  7 ++--
 .../Foundations/Semantics/LTS/Execution.lean  |  2 +-
 .../Semantics/LTS/OmegaExecution.lean         |  8 ++--
 Cslib/Foundations/Semantics/LTS/Total.lean    |  5 ++-
 Cslib/Languages/CCS/Basic.lean                |  2 +-
 .../LocallyNameless/Fsub/Safety.lean          |  9 ++++-
 .../LocallyNameless/Fsub/Subtype.lean         |  4 +-
 .../LocallyNameless/Fsub/Typing.lean          | 39 ++++++++++++++-----
 .../LocallyNameless/Fsub/WellFormed.lean      |  3 +-
 .../LocallyNameless/Stlc/Basic.lean           |  4 +-
 .../LocallyNameless/Stlc/StrongNorm.lean      |  5 ++-
 .../LocallyNameless/Untyped/FullBeta.lean     |  5 ++-
 .../LocallyNameless/Untyped/FullEta.lean      |  6 ++-
 .../LocallyNameless/Untyped/LcAt.lean         | 15 ++++++-
 .../LocallyNameless/Untyped/MultiApp.lean     |  3 +-
 .../LocallyNameless/Untyped/Properties.lean   | 19 ++++++---
 .../LocallyNameless/Untyped/StrongNorm.lean   |  4 +-
 .../LinearLogic/CLL/PhaseSemantics/Basic.lean |  5 ++-
 Cslib/Logics/Modal/Cube.lean                  | 21 +++++-----
 37 files changed, 200 insertions(+), 93 deletions(-)

diff --git a/Cslib/Computability/Automata/DA/ToNA.lean b/Cslib/Computability/Automata/DA/ToNA.lean
index cd1a98501a..fe8c58f25c 100644
--- a/Cslib/Computability/Automata/DA/ToNA.lean
+++ b/Cslib/Computability/Automata/DA/ToNA.lean
@@ -30,6 +30,7 @@ def toNA (a : DA State Symbol) : NA State Symbol :=
 instance : Coe (DA State Symbol) (NA State Symbol) where
   coe := toNA
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 open scoped FLTS NA NA.Run LTS in
 @[simp, scoped grind =]
 theorem toNA_run {a : DA State Symbol} {xs : ωSequence Symbol} {ss : ωSequence State} :
@@ -37,7 +38,9 @@ theorem toNA_run {a : DA State Symbol} {xs : ωSequence Symbol} {ss : ωSequence
   constructor
   · rintro _
     ext n
-    induction n <;> grind [NA.Run]
+    induction n
+    · grind only [NA.Run, toNA, = run_zero, = Set.mem_singleton_iff]
+    · grind only [NA.Run, toNA, = run_succ, = LTS.OmegaExecution, = FLTS.toLTS_tr]
   · grind [NA.Run]
 
 namespace FinAcc
diff --git a/Cslib/Computability/Automata/NA/BuchiInter.lean b/Cslib/Computability/Automata/NA/BuchiInter.lean
index 17fab7eff4..b68b0a5311 100644
--- a/Cslib/Computability/Automata/NA/BuchiInter.lean
+++ b/Cslib/Computability/Automata/NA/BuchiInter.lean
@@ -93,6 +93,7 @@ lemma inter_freq_comp_acc_freq_acc {xs : ωSequence Symbol} {ss : ωSequence ((
   apply leadsTo_cases_or (q := {⟨_, b⟩ | b = false}) <;>
   grind [until_frequently_leadsTo_and, univ_inter]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- The language accepted by the intersection automaton is the intersection of
 the languages accepted by the two component automata. -/
 @[simp, scoped grind =]
@@ -122,7 +123,8 @@ theorem inter_language_eq :
   · intro h
     choose ss_i h_ss_i using h
     let ss_p : ωSequence (Π i, State i) := fun k i ↦ ss_i i k
-    have h_ss_p : (iProd na).Run xs ss_p := by grind [Run]
+    have h_ss_p : (iProd na).Run xs ss_p := by
+      grind only [Run, = iProd_run_iff, = get_fun, = LTS.OmegaExecution, = get_map]
     have (k : ℕ) (i : Bool) : ss_p k i = ss_i i k := rfl
     obtain ⟨ss, h_run, _⟩ := hist_run_exists h_ss_p
     use ss, h_run
diff --git a/Cslib/Computability/Automata/NA/Concat.lean b/Cslib/Computability/Automata/NA/Concat.lean
index 298e607fd1..9b53b12fc8 100644
--- a/Cslib/Computability/Automata/NA/Concat.lean
+++ b/Cslib/Computability/Automata/NA/Concat.lean
@@ -90,6 +90,7 @@ theorem concat_run_proj {xs : ωSequence Symbol} {ss : ωSequence (State1 ⊕ St
     · grind [concat_run_left_right]
   · exact concat_run_right hc n hl (Nat.find_spec hr')
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Given an accepting finite run of `na1` and a run of `na2`, there exists a run of
 `concat na1 na2` that is the concatenation of the two runs. -/
 theorem concat_run_exists {xs1 : List Symbol} {xs2 : ωSequence Symbol} {ss2 : ωSequence State2}
@@ -97,7 +98,11 @@ theorem concat_run_exists {xs1 : List Symbol} {xs2 : ωSequence Symbol} {ss2 : 
     ∃ ss, (concat na1 na2).Run (xs1 ++ω xs2) ss ∧ ss.drop xs1.length = ss2.map inr := by
   by_cases h_xs1 : xs1.length = 0
   · obtain ⟨rfl⟩ : xs1 = [] := List.eq_nil_iff_length_eq_zero.mpr h_xs1
-    refine ⟨ss2.map inr, by simp only [concat]; grind [Run, LTS.OmegaExecution], by simp⟩
+    use ss2.map inr
+    split_ands
+    · simp [concat]
+      grind only [LTS.OmegaExecution, = Set.mem_union, = get_map, = Set.mem_image, Run]
+    · simp
   · obtain ⟨s0, _, _, _, h_mtr⟩ := h1
     obtain ⟨ss1, _, _, _, _⟩ := LTS.Execution.of_mTr h_mtr
     let ss := (ss1.map inl).take xs1.length ++ω ss2.map inr
@@ -105,7 +110,9 @@ theorem concat_run_exists {xs1 : List Symbol} {xs2 : ωSequence Symbol} {ss2 : 
     · grind [concat, get_append_left]
     · have (k) (h_k : ¬ k < xs1.length) : k + 1 - xs1.length = k - xs1.length + 1 := by grind
       simp only [concat]
-      grind [Run, LTS.OmegaExecution, get_append_right', get_append_left, LTS.Execution]
+      grind only [Run, LTS.OmegaExecution, get_append_right', get_append_left,
+        = List.length_take, = get_map, = List.length_map, = min_def, = List.getElem_take,
+        = List.getElem_map]
     · grind [drop_append_of_le_length]
 
 namespace Buchi
diff --git a/Cslib/Computability/Automata/NA/Hist.lean b/Cslib/Computability/Automata/NA/Hist.lean
index 41c4432715..ed2137efe6 100644
--- a/Cslib/Computability/Automata/NA/Hist.lean
+++ b/Cslib/Computability/Automata/NA/Hist.lean
@@ -49,6 +49,7 @@ def makeHist (start' : State → Hist) (tr' : State × Hist → Symbol → State
   | 0 => start' (ss 0)
   | n + 1 => tr' (ss n, makeHist start' tr' xs ss n) (xs n) (ss (n + 1))
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- For every run `ss` of the original automaton, there exists a run `ss'` of the history automaton
 which projects back onto `ss`. -/
 theorem hist_run_exists {xs : ωSequence Symbol} {ss : ωSequence State}
@@ -56,7 +57,7 @@ theorem hist_run_exists {xs : ωSequence Symbol} {ss : ωSequence State}
   use ⟨fun n ↦ (ss n, makeHist start' tr' xs ss n)⟩
   constructor
   · simp only [addHist]
-    grind [Run]
+    grind only [Run, usr Set.mem_setOf_eq, = get_fun, = LTS.OmegaExecution, makeHist]
   · grind
 
 end Cslib.Automata.NA
diff --git a/Cslib/Computability/Automata/NA/Loop.lean b/Cslib/Computability/Automata/NA/Loop.lean
index a114cb384b..2b543787fe 100644
--- a/Cslib/Computability/Automata/NA/Loop.lean
+++ b/Cslib/Computability/Automata/NA/Loop.lean
@@ -92,6 +92,7 @@ theorem loop_run_one_iter {xs : ωSequence Symbol} {ss : ωSequence (Unit ⊕ St
     exact neq.imp (congrArg List.length)
   · grind [loop_run_from_left]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 open List in
 /-- For any finite word in `language na`, there is a corresponding finite run of `na.loop`. -/
 theorem loop_fin_run_exists {xl : List Symbol} (h : xl ∈ language na) :
@@ -127,7 +128,8 @@ theorem loop_run_exists [Inhabited Symbol] {xls : ωSequence (List Symbol)}
     ∃ ss, na.loop.Run xls.flatten ss ∧ ∀ k, ss (xls.cumLen k) = inl () := by
   let ts := ωSequence.const (inl () : Unit ⊕ State)
   have h_mtr (k : ℕ) : na.loop.MTr (ts k) (xls k) (ts (k + 1)) := by grind [loop_fin_run_mtr]
-  have h_pos (k : ℕ) : (xls k).length > 0 := by grind
+  have (k : ℕ) : xls k ≠ [] := by grind
+  have h_pos (k : ℕ) : (xls k).length > 0 := List.length_pos_iff.mpr (this k)
   obtain ⟨ss, _, _⟩ := LTS.OmegaExecution.flatten_mTr h_mtr h_pos
   use ss
   grind [Run.mk, FinAcc.loop, cumLen_zero (ls := xls)]
@@ -158,7 +160,10 @@ theorem loop_language_eq [Inhabited Symbol] :
     use ss, h_run
     apply frequently_iff_strictMono.mpr
     use xls.cumLen, ?_, by grind
-    grind [cumLen_strictMono, List.eq_nil_iff_length_eq_zero]
+    apply cumLen_strictMono
+    intro k
+    apply List.length_pos_iff.mpr
+    grind
 
 end Buchi
 
diff --git a/Cslib/Computability/Automata/NA/Pair.lean b/Cslib/Computability/Automata/NA/Pair.lean
index e1df491330..45beb89d7a 100644
--- a/Cslib/Computability/Automata/NA/Pair.lean
+++ b/Cslib/Computability/Automata/NA/Pair.lean
@@ -99,6 +99,7 @@ namespace Automata.NA.Buchi
 
 open Set Filter ωSequence ωLanguage ωAcceptor
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- The ω-language accepted by a finite-state Büchi automaton is the finite union of ω-languages
 of the form `L * M^ω`, where all `L`s and `M`s are regular languages. -/
 theorem language_eq_fin_iSup_hmul_omegaPow
@@ -110,11 +111,11 @@ theorem language_eq_fin_iSup_hmul_omegaPow
   constructor
   · rintro ⟨ss, h_run, h_inf⟩
     obtain ⟨t, h_acc, h_t⟩ := frequently_in_finite_type.mp h_inf
-    use ss 0, by grind [NA.Run], t, h_acc
+    use ss 0, by grind only [NA.Run], t, h_acc
     obtain ⟨f, h_mono, h_f⟩ := frequently_iff_strictMono.mp h_t
     refine ⟨xs.take (f 0), ?_, xs.drop (f 0), ?_, by grind⟩
     · have : na.MTr (ss 0) (xs.extract 0 (f 0)) (ss (f 0)) := by
-        grind [LTS.OmegaExecution.extract_mTr, NA.Run]
+        grind only [LTS.OmegaExecution.extract_mTr, NA.Run]
       grind [extract_eq_drop_take]
     · simp only [omegaPow_seq_prop, LTS.mem_pairLang]
       use (f · - f 0)
@@ -131,7 +132,7 @@ theorem language_eq_fin_iSup_hmul_omegaPow
     have h_mtr (n : ℕ) : na.MTr (ts n) (zls n) (ts (n + 1)) := by
       grind [Language.mem_sub_one, LTS.mem_pairLang]
     have h_pos (n : ℕ) : (zls n).length > 0 := by
-      grind [Language.mem_sub_one, List.eq_nil_iff_length_eq_zero]
+      grind only [Language.mem_sub_one, List.eq_nil_iff_length_eq_zero]
     obtain ⟨zss, h_zss, _⟩ := LTS.OmegaExecution.flatten_mTr h_mtr h_pos
     have (n : ℕ) : zss (zls.cumLen n) = t := by grind
     obtain ⟨xss, _, _, _, _⟩ := LTS.OmegaExecution.append h_yl h_zss
diff --git a/Cslib/Computability/Automata/NA/Prod.lean b/Cslib/Computability/Automata/NA/Prod.lean
index 8b86ab9406..37ea9afc60 100644
--- a/Cslib/Computability/Automata/NA/Prod.lean
+++ b/Cslib/Computability/Automata/NA/Prod.lean
@@ -25,6 +25,7 @@ def iProd (na : (i : I) → NA (State i) Symbol) : NA (Π i, State i) Symbol whe
   Tr s x t := ∀ i, (na i).Tr (s i) x (t i)
   start := ⋂ i, (· i) ⁻¹' (na i).start
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Every run of the product automaton projects onto runs of its component automata,
 and vice versa. -/
 @[simp, scoped grind =]
@@ -39,7 +40,7 @@ theorem iProd_run_iff {na : (i : I) → NA (State i) Symbol}
   · intro h
     constructor
     · simp only [mem_iInter]
-      grind [Run]
+      grind only [Run, = mem_preimage, Run.mk, = ωSequence.head_map]
     · intro n i
       exact (h i).trans n
 
diff --git a/Cslib/Computability/Automata/NA/Sum.lean b/Cslib/Computability/Automata/NA/Sum.lean
index 029e912eda..26bbe0c9d7 100644
--- a/Cslib/Computability/Automata/NA/Sum.lean
+++ b/Cslib/Computability/Automata/NA/Sum.lean
@@ -25,6 +25,7 @@ def iSum (na : (i : I) → NA (State i) Symbol) : NA (Σ i, State i) Symbol wher
   start := ⋃ i, Sigma.mk i '' (na i).start
   Tr s x t := ∃ i s_i t_i, (na i).Tr s_i x t_i ∧ ⟨i, s_i⟩ = s ∧ ⟨i, t_i⟩ = t
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- An infinite run of the sum automaton is an infinite run of one of its component automata. -/
 @[simp, scoped grind =]
 theorem iSum_run_iff {na : (i : I) → NA (State i) Symbol}
@@ -50,9 +51,9 @@ theorem iSum_run_iff {na : (i : I) → NA (State i) Symbol}
   · rintro ⟨i, ss, h_run, rfl⟩
     constructor
     · simp only [iSum, get_map, mem_iUnion]
-      grind [NA.Run]
+      grind only [NA.Run, = mem_image]
     · simp only [LTS.OmegaExecution]
-      grind [NA.Run]
+      grind only [NA.Run, = get_map, iSum, LTS.OmegaExecution]
 
 namespace Buchi
 
@@ -76,7 +77,9 @@ theorem iSum_language_eq {na : (i : I) → NA (State i) Symbol} {acc : (i : I) 
   · rintro ⟨i, ss_i, _⟩
     use ss_i.map (Sigma.mk i)
     simp only [mem_iUnion]
-    grind
+    constructor
+    · grind
+    · grind
 
 end Buchi
 
diff --git a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
index 48e60cb611..f9c3ff0051 100644
--- a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
+++ b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
@@ -25,6 +25,7 @@ open Function Set Filter ωAcceptor ωLanguage ωSequence
 
 variable {Symbol : Type*} {State : Type}
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Given a Buchi automaton `na`, two finite words `u` and `v` are Buchi-congruent
 according to `na` iff for every pair of states `s` and `t` of `na`, both of the
 following two conditions hold:
@@ -40,7 +41,7 @@ def BuchiCongruence (na : Buchi State Symbol) : RightCongruence Symbol where
   eq.iseqv.symm := by grind
   eq.iseqv.trans := by grind
   right_cov.elim := by
-    grind [Covariant, → LTS.pairLang_split, <= LTS.pairLang_append, → LTS.pairViaLang_split,
+    grind only [Covariant, → LTS.pairLang_split, <= LTS.pairLang_append, → LTS.pairViaLang_split,
       <= LTS.pairViaLang_append_pairLang, <= LTS.pairLang_append_pairViaLang]
 
 open scoped Classical in
@@ -89,11 +90,12 @@ lemma buchiCongruence_transfer
     have : ⟦xl⟧ = a := mem_singleton_iff.mp <| mem_preimage.mp hc
     have : ⟦yl⟧ = a := mem_singleton_iff.mp <| mem_preimage.mp hc'
     grind
-  have := h_eq s t
-  have h_yl : yl ∈ na.pairLang s t := by grind
-  have := LTS.Execution.of_mTr h_yl
-  grind [LTS.mem_pairViaLang, LTS.Execution, → LTS.Execution.comp,
-    → LTS.Execution.of_mTr]
+  obtain ⟨l, r⟩ := h_eq s t
+  by_cases h_xl : xl ∈ na.pairViaLang na.accept s t
+  · obtain := LTS.mem_pairViaLang.mp (r.mp h_xl)
+    grind [LTS.Execution, → LTS.Execution.comp, → LTS.Execution.of_mTr]
+  · use LTS.Execution.of_mTr (l.mp hp) |>.choose
+    grind
 
 /-- `na.buchiFamily` is a family of ω-languages indexed by a pair of equivalence classes
 of `na.BuchiCongruence` which will turn out to saturate the ω-language accepted by `na`
@@ -184,13 +186,15 @@ theorem buchiFamily_saturation [Inhabited Symbol] :
   obtain ⟨ss, ⟨h_init, h_exec⟩, h_acc⟩ := h_lang
   let f (k : ℕ) := xl.length + xls.cumLen k
   let ts := ωSequence.mk (fun k ↦ ss (f k))
-  have h_xls_p (k : ℕ) : (xls k).length > 0 := by grind [Language.mem_sub_one]
+  have (k : ℕ) : xls k ≠ [] := by grind [Language.mem_sub_one]
+  have h_xls_p (k : ℕ) : (xls k).length > 0 := List.length_pos_iff.mpr (this k)
   have h_xls_e (k : ℕ) : xls k ∈ na.pairLang (ts k) (ts (k + 1)) := by
     grind [LTS.OmegaExecution.extract_mTr h_exec (?_ : f k ≤ f (k + 1)), LTS.mem_pairLang,
       extract_append_right_right, add_tsub_cancel_left]
   have h_yls (k : ℕ) := buchiCongruence_transfer ((h_xls_c k).left) ((h_yls_c k).left) (h_xls_e k)
   choose sls h_yls_e h_yls_a using h_yls
-  have h_yls_p (k : ℕ) : (yls k).length > 0 := by grind [Language.mem_sub_one]
+  have (k : ℕ) : yls k ≠ [] := by grind [Language.mem_sub_one]
+  have h_yls_p (k : ℕ) : (yls k).length > 0 := List.length_pos_iff.mpr (this k)
   obtain ⟨ss1, h_ss1_run, h_ss1_seg⟩ := LTS.OmegaExecution.flatten_execution h_yls_e h_yls_p
   suffices ∃ᶠ (k : ℕ) in atTop, ss1 k ∈ na.accept by
     have h_xl_e : xl ∈ na.pairLang (ss 0) (ts 0) := by
@@ -200,7 +204,8 @@ theorem buchiFamily_saturation [Inhabited Symbol] :
       grind [buchiCongruence_transfer h_xl_c h_yl_c h_xl_e, LTS.mem_pairLang, LTS.Execution.to_mTr]
     have h_ss1_ts : ss1 0 = ts 0 := by
       have h : 0 < yls.cumLen 1 - yls.cumLen 0 := by grind
-      have : 0 < (sls 0).length := by grind
+      have : sls 0 ≠ [] := by grind
+      have : 0 < (sls 0).length := List.length_pos_iff.mpr this
       have : ss1 0 = (sls 0)[0] := by grind [get_extract (xs := ss1) h]
       have : (sls 0)[0] = ts 0 := h_yls_e 0 |>.choose_spec |>.1
       grind
diff --git a/Cslib/Computability/Languages/ExampleEventuallyZero.lean b/Cslib/Computability/Languages/ExampleEventuallyZero.lean
index dc777d9a8b..19f637161e 100644
--- a/Cslib/Computability/Languages/ExampleEventuallyZero.lean
+++ b/Cslib/Computability/Languages/ExampleEventuallyZero.lean
@@ -39,6 +39,7 @@ def eventuallyZeroNa : NA.Buchi (Fin 2) (Fin 2) where
   start := {0}
   accept := {1}
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 theorem eventuallyZero_accepted_by_na_buchi :
     language eventuallyZeroNa = eventuallyZero := by
   ext xs; unfold eventuallyZeroNa; constructor
@@ -49,7 +50,9 @@ theorem eventuallyZero_accepted_by_na_buchi :
     obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le h_n
     suffices h1 : xs (m + k) = 0 ∧ ss (m + k) = 1 by grind
     have := h_run.trans m
-    induction k <;> grind [NA.Run]
+    induction k
+    · grind
+    · grind only [NA.Run, = LTS.OmegaExecution]
   · intro h
     obtain ⟨m, h_m⟩ := eventually_atTop.mp h
     let ss : ωSequence (Fin 2) := fun k ↦ if k ≤ m then (0 : Fin 2) else 1
@@ -97,7 +100,7 @@ theorem eventuallyZero_not_omegaLim :
   rintro ⟨l, h⟩
   let ls := ωSequence.mk (oneSegs h)
   have h_segs := oneSegs_lemma h
-  have h_pos : ∀ k, (ls k).length > 0 := by grind
+  have h_pos (k : ℕ) : 0 < (ls k).length := List.length_pos_iff.mpr (by grind)
   have h_ev : ls.flatten ∈ eventuallyZero := by
     rw [← h, mem_omegaLim, frequently_iff_strictMono]
     use (fun k ↦ ls.cumLen (k + 1))
diff --git a/Cslib/Computability/Languages/OmegaLanguage.lean b/Cslib/Computability/Languages/OmegaLanguage.lean
index 8cf0229cb8..14dfff4d36 100644
--- a/Cslib/Computability/Languages/OmegaLanguage.lean
+++ b/Cslib/Computability/Languages/OmegaLanguage.lean
@@ -98,9 +98,10 @@ def equiv : ωLanguage α ≃ Set (ωSequence α) where
 instance : CompleteAtomicBooleanAlgebra (ωLanguage α) :=
   equiv.completeAtomicBooleanAlgebra
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 instance : SetLike (ωLanguage α) (ωSequence α) where
   coe := ωLanguage.toSet
-  coe_injective' := by grind [Function.Injective, ωLanguage]
+  coe_injective' := by grind only [Function.Injective, ωLanguage]
 
 instance : HasSubset (ωLanguage α) := ⟨(· ≤ ·)⟩
 
@@ -400,8 +401,12 @@ theorem omegaPow_coind [Inhabited α] (h_le : p ≤ (l - 1) * p) : p ≤ l^ω :=
 theorem omegaPow_le_hmul_omegaPow' [Inhabited α] (l : Language α) :
     l^ω ≤ (l - 1) * l^ω := by
   rintro s ⟨xs, rfl, h_xs⟩
-  refine ⟨xs.head, h_xs 0, xs.tail.flatten, ⟨xs.tail, rfl, ?_⟩, ?_⟩ <;>
-  grind [l.mem_sub_one]
+  refine ⟨xs.head, h_xs 0, xs.tail.flatten, ⟨xs.tail, rfl, ?_⟩, ?_⟩
+  · grind
+  · apply cons_flatten
+    intro k
+    apply List.length_pos_iff.mpr
+    exact h_xs k |>.right
 
 theorem omegaPow_le_hmul_omegaPow [Inhabited α] (l : Language α) : l^ω ≤ l * l^ω := by
   have h1 := omegaPow_le_hmul_omegaPow' l
diff --git a/Cslib/Computability/URM/Execution.lean b/Cslib/Computability/URM/Execution.lean
index ace5db66b4..00526d3893 100644
--- a/Cslib/Computability/URM/Execution.lean
+++ b/Cslib/Computability/URM/Execution.lean
@@ -82,8 +82,9 @@ namespace Step
 
 variable {p : Program}
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- The step relation is deterministic: each state has at most one successor. -/
-theorem deterministic : Relator.RightUnique (Step p) := by grind [Relator.RightUnique]
+theorem deterministic : Relator.RightUnique (Step p) := by grind only [Relator.RightUnique]
 
 /-- A halted state has no successor in the step relation. -/
 theorem no_step_of_halted {s s' : State} (hhalted : s.isHalted p) : ¬Step p s s' := by
@@ -146,7 +147,7 @@ theorem preserves_register {s s' : State} {r : ℕ}
     s'.regs.read r = s.regs.read r := by
   induction hsteps using Relation.ReflTransGen.head_induction_on with
   | refl => rfl
-  | head => grind [Step.preserves_register]
+  | head hstep => grind [Step.preserves_register hstep (r := r)]
 
 /-- If two halted states are reachable from the same start, they are equal.
 
@@ -160,6 +161,8 @@ theorem eq_of_halts {init s₁ s₂ : State}
   -- But s₁ and s₂ are normal forms, so w must equal both
   have hn1 := isHalted_iff_normal.mp hh1
   have hn2 := isHalted_iff_normal.mp hh2
+  obtain ⟨pc₁, regs₁⟩ := s₁
+  obtain ⟨pc₂, regs₂⟩ := s₂
   grind
 
 end Steps
diff --git a/Cslib/Computability/URM/StraightLine.lean b/Cslib/Computability/URM/StraightLine.lean
index 750a8c51da..f8c0d2e382 100644
--- a/Cslib/Computability/URM/StraightLine.lean
+++ b/Cslib/Computability/URM/StraightLine.lean
@@ -87,10 +87,13 @@ theorem straight_line_halts_from_regs {p : Program} (hsl : p.IsStraightLine) (r
     exact ⟨s', hsteps, Nat.le_of_eq hpc'.symm, hpc'⟩
   intro s hpc_le
   generalize hrem : p.length - s.pc = remaining
-  induction remaining using Nat.strong_induction_on generalizing s
+  induction remaining using Nat.strong_induction_on generalizing s with
+  | h n ih =>
   by_cases hhalted : s.pc ≥ p.length
   · grind
-  · grind [Program.IsStraightLine, Step.of_nonJump, Relation.ReflTransGen.head]
+  · have jmp : ¬p[s.pc].IsJump := by apply hsl; grind
+    have := Step.of_nonJump (by lia) jmp
+    grind [Relation.ReflTransGen.head]
 
 /-- A straight-line program halts on any input. -/
 theorem straight_line_halts {p : Program} (hsl : p.IsStraightLine) (inputs : List ℕ) :
diff --git a/Cslib/Foundations/Data/OmegaSequence/Defs.lean b/Cslib/Foundations/Data/OmegaSequence/Defs.lean
index 49f73f00fe..20a4b7d190 100644
--- a/Cslib/Foundations/Data/OmegaSequence/Defs.lean
+++ b/Cslib/Foundations/Data/OmegaSequence/Defs.lean
@@ -35,9 +35,10 @@ structure ωSequence (α : Type u) where
   /-- The function that defines this infinite sequence. -/
   get : ℕ → α
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 instance : FunLike (ωSequence α) ℕ α where
   coe := ωSequence.get
-  coe_injective' := by grind [ωSequence, Function.Injective]
+  coe_injective' := by grind only [ωSequence, Function.Injective]
 
 instance : Coe (ℕ → α) (ωSequence α) where
   coe f := ⟨f⟩
diff --git a/Cslib/Foundations/Data/OmegaSequence/Init.lean b/Cslib/Foundations/Data/OmegaSequence/Init.lean
index a5b3cf0996..3c54d06ecf 100644
--- a/Cslib/Foundations/Data/OmegaSequence/Init.lean
+++ b/Cslib/Foundations/Data/OmegaSequence/Init.lean
@@ -516,8 +516,10 @@ theorem take_extract {xs : ωSequence α} {m n k : ℕ} (h : k ≤ n - m) :
 @[simp, scoped grind =]
 theorem drop_extract {xs : ωSequence α} {m n k : ℕ} (h : k ≤ n - m) :
     (xs.extract m n).drop k = xs.extract (m + k) n := by
-  have := extract_lu_extract_lu (xs := xs) (m := m) (n := n) (i := k) (j := n - m)
-  grind [length_extract, List.take_length]
+  by_cases m ≤ n
+  · grind only [extract_lu_extract_lu, length_extract, List.length_drop, List.take_length]
+  · have : k = 0 := by grind only
+    grind only [List.drop_zero]
 
 end ωSequence
 
diff --git a/Cslib/Foundations/Data/OmegaSequence/Temporal.lean b/Cslib/Foundations/Data/OmegaSequence/Temporal.lean
index 884f7350c3..22fb04aafa 100644
--- a/Cslib/Foundations/Data/OmegaSequence/Temporal.lean
+++ b/Cslib/Foundations/Data/OmegaSequence/Temporal.lean
@@ -49,10 +49,11 @@ variable {xs : ωSequence α}
 theorem step_leadsTo {p q : Set α} (h : xs.Step p q) : xs.LeadsTo p q := by
   grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- `LeadsTo` is transitive. -/
 theorem leadsTo_trans {p q r : Set α}
     (h1 : xs.LeadsTo p q) (h2 : xs.LeadsTo q r) : xs.LeadsTo p r := by
-  grind
+  grind only [LeadsTo]
 
 /-- If `p ∩ q` leads to `r` and `p ∩ qᶜ` leads to `s`, then `p` leads to `r ∪ s`. -/
 theorem leadsTo_cases_or {p q r s : Set α}
diff --git a/Cslib/Foundations/Data/Relation.lean b/Cslib/Foundations/Data/Relation.lean
index 4e8953f121..262ccbbd8c 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -497,7 +497,7 @@ theorem ChurchRosser.normal_eqvGen_reflTransGen (cr : ChurchRosser r) (norm : No
 /-- For a Church-Rosser relation there is one normal form in each equivalence class. -/
 theorem ChurchRosser.normal_eq (cr : ChurchRosser r) (nx : Normal r x) (ny : Normal r y)
     (xy : EqvGen r x y) : x = y := by
-  have ⟨_, _, _⟩ := cr xy
+  have ⟨z, _, _⟩ := cr xy
   grind
 
 /-- A pair of subrelations lifts to transitivity on the relation. -/
@@ -526,7 +526,8 @@ theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) :
 the inverse of `r`. -/
 abbrev SN (r : α → α → Prop) := Acc (fun a b => r b a)
 
-lemma SN_iff_SN_of_rel (x : α) : SN r x ↔ ∀ y, r x y → SN r y := by grind [Acc]
+set_option linter.tacticAnalysis.verifyGrindOnly false in
+lemma SN_iff_SN_of_rel (x : α) : SN r x ↔ ∀ y, r x y → SN r y := by grind only [Acc]
 
 lemma SN.intro : (h : ∀ y, r x y → SN r y) → SN r x := (SN_iff_SN_of_rel x).mpr
 
diff --git a/Cslib/Foundations/Semantics/FLTS/LTSToFLTS.lean b/Cslib/Foundations/Semantics/FLTS/LTSToFLTS.lean
index f286c1eeb4..34ff856e7a 100644
--- a/Cslib/Foundations/Semantics/FLTS/LTSToFLTS.lean
+++ b/Cslib/Foundations/Semantics/FLTS/LTSToFLTS.lean
@@ -33,8 +33,8 @@ theorem toFLTS_mem_tr {lts : LTS State Label} {S : Set State} {s' : State} {μ :
 original `LTS`. -/
 @[scoped grind =]
 theorem toFLTS_mem_mtr {lts : LTS State Label} {S : Set State} {s' : State} {μs : List Label} :
-  s' ∈ lts.toFLTS.mtr S μs ↔ ∃ s ∈ S, lts.MTr s μs s' := by
-  grind [LTS.toFLTS, FLTS.mtr]
+    s' ∈ lts.toFLTS.mtr S μs ↔ ∃ s ∈ S, lts.MTr s μs s' :=
+  ⟨by grind [FLTS.mtr], by grind [FLTS.mtr]⟩
 
 /-- Characterisation of multistep transitions in `LTS.toFLTS` as image transitions in `LTS`. -/
 @[scoped grind =]
diff --git a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean
index 2d4009c2e8..21ffd67eb5 100644
--- a/Cslib/Foundations/Semantics/LTS/Bisimulation.lean
+++ b/Cslib/Foundations/Semantics/LTS/Bisimulation.lean
@@ -777,6 +777,7 @@ theorem IsBisimulation.isSimulation_iff :
   have _ (s₁ s₂) : r s₁ s₂ → flip r s₂ s₁ := id
   grind [IsSimulation, flip]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Homogeneous bisimilarity can also be characterized through symmetric simulations. -/
 theorem HomBisimilarity.symm_simulation :
   HomBisimilarity lts =
@@ -790,10 +791,8 @@ theorem HomBisimilarity.symm_simulation :
       grind [Std.Symm, Bisimilarity.symm, IsBisimulation.isSimulation]
     grind
   · intro ⟨r, hr, hsymm, hsim⟩
-    have : r = (flip r) := by
-      grind [flip, Std.Symm]
-    have : IsHomBisimulation lts r := by
-      grind [IsBisimulation.isSimulation_iff]
+    have : r = (flip r) := by grind only [flip, Std.Symm]
+    have : IsHomBisimulation lts r := by grind [IsBisimulation.isSimulation_iff]
     grind
 
 end Bisimulation
diff --git a/Cslib/Foundations/Semantics/LTS/Execution.lean b/Cslib/Foundations/Semantics/LTS/Execution.lean
index 589819fa45..ac51c2a1c8 100644
--- a/Cslib/Foundations/Semantics/LTS/Execution.lean
+++ b/Cslib/Foundations/Semantics/LTS/Execution.lean
@@ -119,7 +119,7 @@ theorem Execution.comp
     · grind only [Execution, = List.getElem_append]
     · have := Execution.comp_helper h1 h2 (k - μs1.length)
       have := Execution.comp_helper h1 h2 (k - μs1.length + 1)
-      grind
+      grind only [Execution, = List.getElem_append]
 
 /-- An execution can be split at any intermediate state into two executions. -/
 theorem Execution.split
diff --git a/Cslib/Foundations/Semantics/LTS/OmegaExecution.lean b/Cslib/Foundations/Semantics/LTS/OmegaExecution.lean
index 963035f0cc..66502ed9cf 100644
--- a/Cslib/Foundations/Semantics/LTS/OmegaExecution.lean
+++ b/Cslib/Foundations/Semantics/LTS/OmegaExecution.lean
@@ -31,8 +31,8 @@ variable {State Label : Type*} {lts : LTS State Label}
 /-- Any finite execution extracted from an infinite execution is valid. -/
 theorem OmegaExecution.extract_execution
     (h : lts.OmegaExecution ss μs) {n m : ℕ} (hnm : n ≤ m) :
-    lts.Execution (ss n) (μs.extract n m) (ss m) (ss.extract n (m + 1)) := by
-  grind
+    lts.Execution (ss n) (μs.extract n m) (ss m) (ss.extract n (m + 1)) :=
+  ⟨by grind, by grind⟩
 
 /-- Any multistep transition extracted from an infinite execution is valid. -/
 theorem OmegaExecution.extract_mTr
@@ -113,7 +113,9 @@ theorem OmegaExecution.flatten_mTr [Inhabited Label]
   obtain ⟨ss, h_ss, h_seg⟩ := OmegaExecution.flatten_execution h_sls hpos
   use ss, h_ss
   intro k
-  have h1 : 0 < (ss.extract (μls.cumLen k) (μls.cumLen (k + 1))).length := by grind
+  have : ss.extract (μls.cumLen k) (μls.cumLen (k + 1)) ≠ [] := by grind
+  have h1 : 0 < (ss.extract (μls.cumLen k) (μls.cumLen (k + 1))).length :=
+    List.length_pos_iff.mpr this
   grind [List.getElem_of_eq (h_seg k) h1]
 
 end Cslib.LTS
diff --git a/Cslib/Foundations/Semantics/LTS/Total.lean b/Cslib/Foundations/Semantics/LTS/Total.lean
index 37073920f3..2980aa9261 100644
--- a/Cslib/Foundations/Semantics/LTS/Total.lean
+++ b/Cslib/Foundations/Semantics/LTS/Total.lean
@@ -74,6 +74,7 @@ instance (lts : LTS State Label) : lts.totalize.Total where
     use none
     simp [totalize]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- In `totalize`, there is no finite execution from the sink state to any non-sink state. -/
 theorem totalize.no_sink_to_nonsink {μs : List Label} {t : State} :
     ¬ lts.totalize.MTr (none) μs (some t) := by
@@ -81,7 +82,9 @@ theorem totalize.no_sink_to_nonsink {μs : List Label} {t : State} :
   generalize h_s : (none : Option State) = s'
   generalize h_t : (some t : Option State) = t'
   rw [h_s, h_t] at h
-  induction h <;> grind [totalize]
+  induction h
+  · grind
+  · grind only [totalize]
 
 /-- In `totalize`, the transitions between non-sink states correspond exactly to
 the transitions in the original LTS. -/
diff --git a/Cslib/Languages/CCS/Basic.lean b/Cslib/Languages/CCS/Basic.lean
index 4a9956085f..c30c1849d4 100644
--- a/Cslib/Languages/CCS/Basic.lean
+++ b/Cslib/Languages/CCS/Basic.lean
@@ -87,7 +87,7 @@ def isCo [DecidableEq Name] (μ μ' : Act Name) : Bool :=
   | _, _ => false
 
 theorem isCo_iff [DecidableEq Name] {μ μ' : Act Name} : isCo μ μ' ↔ Co μ μ' := by
-  grind [cases Act]
+  cases μ <;> cases μ' <;> grind
 
 /-- `Act.Co` is decidable if `Name` equality is decidable. -/
 instance [DecidableEq Name] {μ μ' : Act Name} : Decidable (Co μ μ') :=
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
index cf294d3b1c..1bb05bd29f 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
@@ -71,6 +71,7 @@ lemma Typing.preservation (der : Typing Γ t τ) (step : t ⭢βᵛ t') : Typing
       grind [fresh_exists <| free_union [fvTm] Var, openTm_substTm_intro, subst_tm]
   all_goals grind [cases Red]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Any typable term either has a reduction step or is a value. -/
 lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t' := by
   generalize eq : [] = Γ at der
@@ -146,11 +147,15 @@ lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t'
   case abs σ _ τ L _ _=>
     left
     constructor
-    apply LC.abs L <;> grind [cases Env.Wf, cases Term.LC]
+    apply LC.abs L
+    · grind only [→ wf, cases Term.LC]
+    · grind only [→ wf]
   case tabs L _ _=>
     left
     constructor
-    apply LC.tabs L <;> grind [cases Env.Wf, cases Term.LC]
+    apply LC.tabs L
+    · grind only [→ wf, cases Term.LC]
+    · grind only [→ wf]
 
 end LambdaCalculus.LocallyNameless.Fsub
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
index 1a8abe649d..7cdb72133c 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Subtype.lean
@@ -112,10 +112,10 @@ lemma trans : Sub Γ σ δ → Sub Γ δ τ → Sub Γ σ τ := by
     induction sub₁ <;> grind [cases Sub]
   case arrow σ' τ' _ _ _ _ =>
     generalize eq : σ'.arrow τ' = γ at sub₁
-    induction sub₁ <;> grind [cases Sub]
+    induction sub₁ <;> cases sub₂ <;> grind
   case sum σ' τ' _ _ _ _ =>
     generalize eq : σ'.sum τ' = γ at sub₁
-    induction sub₁ <;> grind [cases Sub]
+    induction sub₁ <;> cases sub₂ <;> grind
   case all σ' τ' _ _ _ _ _ =>
     generalize eq : σ'.all τ' = γ at sub₁
     induction sub₁
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
index 7a9e8efe0e..c4aa13facd 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Typing.lean
@@ -62,19 +62,25 @@ variable {Γ Δ Θ : Env Var} {σ τ δ : Ty Var}
 
 attribute [grind .] Typing.var Typing.app Typing.tapp Typing.sub Typing.inl Typing.inr
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Typings have well-formed contexts and types. -/
 @[grind →]
 lemma wf {Γ : Env Var} {t : Term Var} {τ : Ty Var} (der : Typing Γ t τ) : Γ.Wf ∧ t.LC ∧ τ.Wf Γ := by
   induction der <;> let L := free_union Var <;> have ⟨x, nmem⟩ := fresh_exists L
   case tabs ih =>
     cases (ih x (by grind)).left
-    grind [LC.tabs L, Ty.Wf.all L]
+    split_ands
+    · grind
+    · apply LC.tabs L <;> grind
+    · apply Ty.Wf.all L <;> grind
   case abs ih =>
     cases (ih x (by grind)).left
     grind [LC.abs L, Wf.strengthen]
   case let' => grind [LC.let' L, Ty.Wf.strengthen]
   case case => refine ⟨?_, LC.case L ?_ ?_ ?_, ?_⟩ <;> grind [Ty.Wf.strengthen]
-  all_goals grind [of_bind_ty, open_lc, cases Ty.Wf]
+  case var => grind [of_bind_ty]
+  case app => grind only [LC.app, cases Ty.Wf]
+  all_goals grind [open_lc]
 
 /-- Weakening of typings. -/
 lemma weaken (der : Typing (Γ ++ Δ) t τ) (wf : (Γ ++ Θ ++ Δ).Wf) :
@@ -203,38 +209,53 @@ lemma tabs_inv (der : Typing Γ (.tabs γ' t) τ) (sub : Sub Γ τ (all γ δ))
     · exists δ', L
   all_goals grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Invert the typing of a left case. -/
 lemma inl_inv (der : Typing Γ (.inl t) τ) (sub : Sub Γ τ (sum γ δ)) :
     ∃ γ', Typing Γ t γ' ∧ Sub Γ γ' γ := by
-  generalize eq : t.inl =t at der
-  induction der generalizing γ δ <;> grind [cases Sub]
+  generalize eq : t.inl = t at der
+  induction der generalizing γ δ with
+  | inl => grind only [cases Sub]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Invert the typing of a right case. -/
 lemma inr_inv (der : Typing Γ (.inr t) T) (sub : Sub Γ T (sum γ δ)) :
     ∃ δ', Typing Γ t δ' ∧ Sub Γ δ' δ := by
-  generalize eq : t.inr =t at der
-  induction der generalizing γ δ <;> grind [cases Sub]
+  generalize eq : t.inr = t at der
+  induction der generalizing γ δ with
+  | inr => grind only [cases Sub]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- A value that types as a function is an abstraction. -/
 lemma canonical_form_abs (val : Value t) (der : Typing [] t (arrow σ τ)) :
     ∃ δ t', t = .abs δ t' := by
   generalize eq  : σ.arrow τ = γ at der
   generalize eq' : [] = Γ at der
-  induction der generalizing σ τ <;> grind [cases Sub, cases Value]
+  induction der generalizing σ τ with
+  | sub _ _ _ => grind only [= Option.mem_def, = dlookup_nil, cases Sub]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- A value that types as a quantifier is a type abstraction. -/
 lemma canonical_form_tabs (val : Value t) (der : Typing [] t (all σ τ)) :
     ∃ δ t', t = .tabs δ t' := by
   generalize eq  : σ.all τ = γ at der
   generalize eq' : [] = Γ at der
-  induction der generalizing σ τ <;> grind [cases Sub, cases Value]
+  induction der generalizing σ τ with
+  | sub _ _ _ => grind only [= Option.mem_def, = dlookup_nil, cases Sub]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- A value that types as a sum is a left or right case. -/
 lemma canonical_form_sum (val : Value t) (der : Typing [] t (sum σ τ)) :
     ∃ t', t = .inl t' ∨ t = .inr t' := by
   generalize eq  : σ.sum τ = γ at der
   generalize eq' : [] = Γ at der
-  induction der generalizing σ τ <;> grind [cases Sub, cases Value]
+  induction der generalizing σ τ with
+  | sub => grind only [= Option.mem_def, = dlookup_nil, cases Sub]
+  |  _ => grind
 
 end Typing
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
index ffb6f30237..c24a0ab669 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/WellFormed.lean
@@ -155,7 +155,8 @@ variable [HasFresh Var] in
 lemma nmem_fv {σ : Ty Var} (wf : σ.Wf Γ) (nmem : X ∉ Γ.dom) : X ∉ σ.fv := by
   induction wf with
   | all => grind [fresh_exists <| free_union [dom] Var, nmem_fv_open, openRec_lc]
-  | _ => grind [dlookup_isSome]
+  | @var _ Γ => grind => have : (dlookup X Γ).isSome = true; finish;
+  | _ => grind
 
 end Ty.Wf
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean
index a3e80e3310..405554ffb4 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/Basic.lean
@@ -110,8 +110,8 @@ lemma subst_aux (h : Δ ++ ⟨x, σ⟩ :: Γ ⊢ t ∶ τ) (der : Γ ⊢ s ∶ 
     case cons =>
     observe perm : (Γ ++ Δ).Perm (Δ ++ Γ)
     by_cases h : x = x'
-    case neg => grind
-    case pos => grind [(weaken der ?_).perm perm]
+    · have := (weaken der ?_).perm perm <;> grind
+    · grind
   case abs =>
     grind [Typing.abs <| free_union Var, subst_open_var _ _ _ _ ?_ der.lc]
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
index d9ab413bdc..8496ba8b9e 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Stlc/StrongNorm.lean
@@ -59,13 +59,16 @@ def semanticMap : Ty Base → Set (Term Var)
   | .base _ => { t | SN FullBeta t ∧ LC t }
   | .arrow τ₁ τ₂ => { t | ∀ s, s ∈ semanticMap τ₁ → app t s ∈ semanticMap τ₂ }
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- The sets constructed by semanticMap are saturated -/
 lemma semanticMap_saturated (τ : Ty Base) : @Saturated Var (semanticMap τ) := by
   induction τ with
   | base => grind [sn_abs_app_multiApp, sn_neutral, open_abs_lc]
   | arrow τ₁ τ₂ ih₁ ih₂ =>
     constructor
-    · grind [ih₁.neutal_lc (fvar <| fresh {}) (.fvar <| fresh {}) (.fvar <| fresh {}), cases LC]
+    · let x : Var := fresh {}
+      have := ih₁.neutal_lc (fvar x) (.fvar x) (.fvar x)
+      grind only [semanticMap, usr Set.mem_setOf_eq, cases LC]
     · grind [sn_app_left (Var := Var) (N := fvar <| fresh {})]
     · grind
     · intro M N P _ _ _ s _
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
index 698f52b6ca..f23f6c5083 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
@@ -63,6 +63,7 @@ theorem redex_app_l_cong (redex : M ↠βᶠ M') (lc_N : LC N) : app M N ↠β
 theorem redex_app_r_cong (redex : M ↠βᶠ M') (lc_N : LC N) : app N M ↠βᶠ app N M' := by
   induction redex <;> grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /- Single reduction `app M (fvar x) ⭢βᶠ N` implies reduction on `M` or a root beta step. -/
 @[scoped grind →]
 lemma invert_step_app_fvar (step : app M (fvar x) ⭢βᶠ N) :
@@ -70,7 +71,7 @@ lemma invert_step_app_fvar (step : app M (fvar x) ⭢βᶠ N) :
   cases step
   case base h => cases h with | beta => exact .inr ⟨_, rfl, rfl⟩
   case appR step_M _ => exact .inl ⟨_, rfl, step_M⟩
-  all_goals grind [cases Xi]
+  all_goals grind only [cases Xi]
 
 variable [HasFresh Var] [DecidableEq Var]
 
@@ -88,7 +89,7 @@ lemma steps_lc_or_rfl {M M' : Term Var} (redex : M ↠βᶠ M') : (LC M ∧ LC M
 lemma redex_subst_cong_lc (s s' t : Term Var) (x : Var) (step : s ⭢βᶠ s') (h_lc : LC t) :
     s [ x := t ] ⭢βᶠ s' [ x := t ] := by
   induction step with
-  | base => grind [subst_open]
+  | base beta => cases beta; grind [subst_open]
   | abs  => grind [Xi.abs <| free_union Var]
   | _ => grind
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
index 856541e6e3..ee2ee01d1c 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullEta.lean
@@ -60,13 +60,14 @@ theorem redex_app_l_cong (redex : M ↠ηᶠ M') (lc_N : LC N) : app M N ↠η
 theorem redex_app_r_cong (redex : M ↠ηᶠ M') (lc_N : LC N) : app N M ↠ηᶠ app N M' := by
   induction redex <;> grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /- Single reduction `app M (fvar x) ⭢ηᶠ N` implies `N = app M' (fvar x)` for some M' -/
 @[scoped grind →]
 lemma invert_step_app_fvar (step : (app M (fvar x)) ⭢ηᶠ N) :
     ∃ M', N = app M' (fvar x) ∧ M ⭢ηᶠ M' := by
   cases step with
   | appR _ step_M => exact ⟨_, rfl, step_M⟩
-  | _ => grind [cases Xi]
+  | _ => grind only [cases Xi]
 
 variable [HasFresh Var] [DecidableEq Var]
 
@@ -84,7 +85,8 @@ lemma step_not_fv (step : M ⭢ηᶠ M') : M.fv = M'.fv := by
 @[scoped grind ←]
 lemma eta_subst_fvar {x y : Var} (step : M ⭢ηᶠ M') : M [ x := fvar y ] ⭢ηᶠ M' [ x := fvar y ] := by
   induction step with
-  | abs => grind [Xi.abs <| free_union Var]
+  | abs => apply Xi.abs <| free_union Var; grind
+  | @base M N => grind
   | _ => grind
 
 /-- Abstracting then closing preserves a single η-reduction step. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
index 691939af75..72fce48957 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/LcAt.lean
@@ -41,6 +41,7 @@ def depth : Term Var → ℕ
 | app t₁ t₂ => max (depth t₁) (depth t₂)
 | abs t => depth t + 1
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 @[elab_as_elim]
 protected lemma ind_on_depth (P : Term Var → Prop) (bvar : ∀ i, P (bvar i)) (fvar : ∀ x, P (fvar x))
     (app : ∀ M N, P M → P N → P (app M N))
@@ -49,7 +50,8 @@ protected lemma ind_on_depth (P : Term Var → Prop) (bvar : ∀ i, P (bvar i))
   induction h : M.depth using Nat.strong_induction_on generalizing M with | _ n ih
   induction M with
   | abs M' => apply abs M' <;> grind
-  | _ => grind [sup_le_iff]
+  | bvar | fvar => grind
+  | app => apply app <;> grind only [depth, = max_def]
 
 /-- The depth of the lambda expression doesn't change by opening at i-th bound variable
  for some free variable. -/
@@ -84,6 +86,7 @@ attribute [scoped grind .] LC.fvar LC.app
 inductive Value : Term Var → Prop
 | abs (e : Term Var) : e.abs.LC → e.abs.Value
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- `M` is `LcAt 0` if and only if `M` is locally closed. -/
 theorem lcAt_iff_LC (M : Term Var) [HasFresh Var] : LcAt 0 M ↔ M.LC := by
   induction M using LambdaCalculus.LocallyNameless.Untyped.Term.ind_on_depth with
@@ -93,7 +96,15 @@ theorem lcAt_iff_LC (M : Term Var) [HasFresh Var] : LcAt 0 M ↔ M.LC := by
       · intros h2
         rcases h2 with ⟨⟩|⟨L,_,_⟩
         grind [fresh_exists L]
-    | _ => grind [cases LC]
+    | fvar => grind
+    | bvar =>
+      constructor
+      · grind
+      · grind only [cases LC]
+    | app =>
+      constructor
+      · grind
+      · grind only [cases LC, LcAt]
 
 instance [HasFresh Var] (t : Term Var) : Decidable t.LC := by
   rw [← lcAt_iff_LC]
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean
index f9f85133e7..d7016d7dc4 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiApp.lean
@@ -72,6 +72,7 @@ lemma step_multiApp_r (steps : Ns ⭢lβᶠ Ns') (lc_M : LC M) : M.multiApp Ns 
 lemma steps_multiApp_r (steps : Ns ↠lβᶠ Ns') (lc_M : LC M) : M.multiApp Ns ↠βᶠ M.multiApp Ns' := by
   induction steps <;> grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- If a term (λ M) N P_1 ... P_n reduces in a single step to Q, then
     Q must be one of the following forms:
 
@@ -86,7 +87,7 @@ lemma invert_abs_multiApp_st {Ps} {M N Q : Term Var}
     (∃ Ps', Ps ⭢lβᶠ Ps' ∧ Q = multiApp (M.abs.app N) Ps') ∨
     (Q = multiApp (M ^ N) Ps) := by
   induction Ps generalizing M N Q with
-  | nil => grind [cases Xi]
+  | nil => grind only [cases Xi, multiApp]
   | cons P Ps ih =>
     generalize Heq : (M.abs.app N).multiApp Ps = Q'
     have : ∀ P', Q'.app P' = (M.abs.app N).multiApp (P' :: Ps) := by grind
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index f7810940df..54b3b6c9ab 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
@@ -55,15 +55,21 @@ lemma close_rec_fv {k y} (m : Term Var) : (m⟦k ↜ y⟧).fv = m.fv.erase y :=
 @[scoped grind =]
 lemma close_var_not_fvar (x) (t : Term Var) : (t ^* x).fv = t.fv.erase x := close_rec_fv t
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Opening preserves free variables. -/
 theorem open_preserve_not_fvar (k) (m n : Term Var) :
     m⟦k ↝ n⟧.fv = m.fv ∪ n.fv ∨ m⟦k ↝ n⟧.fv = m.fv := by
-  induction m generalizing k <;> grind
+  induction m generalizing k with
+  | app => grind only [= openRec, = fv]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Substitution preserves free variables. -/
 lemma subst_preserve_not_fvar {y : Var} (m n : Term Var) :
     m [y := n].fv = m.fv.erase y ∨ m [y := n].fv = m.fv.erase y ∪ n.fv:= by
-  induction m <;> grind
+  induction m with
+  | app => grind only [fv, = subst_app, = Finset.mem_union, = Finset.mem_erase]
+  | _ => grind
 
 lemma subst_refl (m : Term Var) (x : Var) : m[x := fvar x] = m := by
   induction m <;> grind
@@ -129,10 +135,11 @@ lemma close_open_to_subst (m n : Term Var) (x : Var) (k : ℕ) (m_lc : LC m) (n_
   induction m_lc generalizing k with
   | abs xs t =>
     have ⟨x', _⟩ := fresh_exists <| free_union [fv] Var
-    grind [
-      swap_open, =_ swap_open_fvar_close,
-      open_close x' (t⟦k+1 ↜ x⟧⟦k+1 ↝ n⟧) 0, open_close x' (t[x := n]) 0,
-       open_preserve_not_fvar, close_rec_fv, subst_preserve_not_fvar]
+    simp only [closeRec_abs, openRec_abs, subst_abs]
+    rw [open_close x' (t⟦k+1 ↜ x⟧⟦k+1 ↝ n⟧) 0, open_close x' (t[x := n]) 0]
+    · grind [swap_open, =_ swap_open_fvar_close]
+    · grind [subst_preserve_not_fvar]
+    · grind [open_preserve_not_fvar]
   | _ => grind
 
 /-- Closing and opening are inverses. -/
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
index 793061cfee..6a0163c97a 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
@@ -36,6 +36,7 @@ lemma sn_step (t_st_t' : t ⭢βᶠ t') (sn_t : SN FullBeta t) : SN FullBeta t'
 lemma sn_steps (t_st_t' : t ↠βᶠ t') (sn_t : SN FullBeta t) : SN FullBeta t' :=
   sn_t.of_rel_reflTransGen t_st_t'
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Free variables are strongly normalizing. -/
 lemma sn_fvar {x : Var} : SN FullBeta (fvar x) := by
   rw [SN_iff_SN_of_rel]
@@ -92,10 +93,11 @@ lemma neutral_step (Hneut : Neutral t) (Hstep : t ⭢βᶠ t') : Neutral t' := b
 lemma neutral_steps (Hneut : Neutral t) (Hsteps : t ↠βᶠ t') : Neutral t' := by
   induction Hsteps <;> grind [neutral_step]
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Neutral terms are strongly normalizing. -/
 lemma sn_neutral (Hneut : Neutral t) : SN FullBeta t := by
   induction Hneut with
-  | app => grind [→ neutral_steps, sn_app]
+  | app => grind only [→ neutral_steps, sn_app]
   | _ =>
     rw [SN_iff_SN_of_rel]
     grind only [cases Xi]
diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
index df33df215b..32d86d85c8 100644
--- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
+++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
@@ -149,9 +149,10 @@ structure Fact (P : Type*) [PhaseSpace P] where
   (carrier : Set P)
   (property : isFact carrier)
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 instance : SetLike (Fact P) P where
   coe := Fact.carrier
-  coe_injective' _ _ _ := by grind [cases Fact]
+  coe_injective' _ _ _ := by grind only [cases Fact]
 
 instance : PartialOrder (Fact P) := PartialOrder.ofSetLike (Fact P) P
 
@@ -174,7 +175,7 @@ lemma subset_dual_dual {G : Set P} :
 lemma of_Fact {G : Fact P} {p : P}
     (hp : ∀ q, (∀ r ∈ G, q * r ∈ PhaseSpace.bot) → p * q ∈ PhaseSpace.bot) : p ∈ G := by
   rw [← SetLike.mem_coe, G.eq]
-  grind
+  simpa
 
 @[scoped grind =, simp] lemma mem_carrier (G : Fact P) : G.carrier = (G : Set P) := rfl
 
diff --git a/Cslib/Logics/Modal/Cube.lean b/Cslib/Logics/Modal/Cube.lean
index 38b28295af..3106b08fda 100644
--- a/Cslib/Logics/Modal/Cube.lean
+++ b/Cslib/Logics/Modal/Cube.lean
@@ -94,22 +94,23 @@ in `k_subset_t`.
 -/
 
 open scoped Proposition
+open Set
 
-theorem k_subset_d : (K World Atom ⊆ D World Atom) := by
-  intro φ; grind
+theorem k_subset_d : K World Atom ⊆ D World Atom := by
+  grind only [subset_def, D, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid]
 
-theorem k_subset_b : (K World Atom ⊆ B World Atom) := by
-  intro φ; grind
+theorem k_subset_b : K World Atom ⊆ B World Atom := by
+  grind only [subset_def, B, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid]
 
-theorem k_subset_four : (K World Atom ⊆ Four World Atom) := by
-  intro φ; grind
+theorem k_subset_four : K World Atom ⊆ Four World Atom := by
+  grind only [subset_def, Four, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid]
 
-theorem k_subset_five : (K World Atom ⊆ Five World Atom) := by
-  intro φ; grind
+theorem k_subset_five : K World Atom ⊆ Five World Atom := by
+  grind only [subset_def, Five, K, = setOf_true, = logic, mem_setOf_eq, = Proposition.valid]
 
 open scoped Relation in
-theorem d_subset_t : (D World Atom ⊆ T World Atom) := by
-  intro φ; grind
+theorem d_subset_t : D World Atom ⊆ T World Atom := by
+  grind
 
 theorem k_subset_t : (K World Atom ⊆ T World Atom) := by
   calc

From 45072a305103b7a1383b2ce66a37a6a367d4a80a Mon Sep 17 00:00:00 2001
From: Dhruv Gupta <dhruv@zetesislabs.com>
Date: Fri, 29 May 2026 18:11:27 +0530
Subject: [PATCH 086/106] feat(MachineLearning/PACLearning): add VersionSpace
 abstraction (#592)

Adds the classical version space abstraction (Mitchell 1982, Angluin
1980) as a companion to the PAC learning definitions from #492.

- `VersionSpace C S`: the subset of `C` whose concepts agree with `S` on
every sample point
- `versionSpace_subset`, `versionSpace_empty_sample`: sanity lemmas
- `versionSpace_antitone`: more data gives a smaller version space
- `IsConsistent A C`: predicate on learners whose output always lies in
the version space
- `mem_versionSpace_of_realizable`,
`versionSpace_nonempty_of_realizable`: realizable-case bridge

Foundation for downstream proofs (Sauer-Shelah, PAC lower bounds,
infinite NFL).

---------

Co-authored-by: dhruvgupta-zetesis <dhruv.gupta@artpark.in>
Co-authored-by: Fabrizio Montesi <famontesi@gmail.com>
---
 Cslib.lean                                    |   1 +
 .../PACLearning/VersionSpace.lean             | 310 ++++++++++++++++++
 references.bib                                |  39 +++
 3 files changed, 350 insertions(+)
 create mode 100644 Cslib/MachineLearning/PACLearning/VersionSpace.lean

diff --git a/Cslib.lean b/Cslib.lean
index 070e6dc0f2..565352e8e3 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -140,4 +140,5 @@ public import Cslib.Logics.Propositional.Defs
 public import Cslib.Logics.Propositional.NaturalDeduction.Basic
 public import Cslib.MachineLearning.PACLearning.Defs
 public import Cslib.MachineLearning.PACLearning.VCDimension
+public import Cslib.MachineLearning.PACLearning.VersionSpace
 public import Cslib.Probability.PMF
diff --git a/Cslib/MachineLearning/PACLearning/VersionSpace.lean b/Cslib/MachineLearning/PACLearning/VersionSpace.lean
new file mode 100644
index 0000000000..37f8072cf0
--- /dev/null
+++ b/Cslib/MachineLearning/PACLearning/VersionSpace.lean
@@ -0,0 +1,310 @@
+/-
+Copyright (c) 2026 Dhruv Gupta. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Dhruv Gupta
+-/
+
+module
+
+public import Cslib.MachineLearning.PACLearning.Defs
+public import Mathlib.MeasureTheory.Measure.Dirac
+public import Mathlib.MeasureTheory.Measure.Map
+
+/-! # Version Space
+
+The *version space* of a concept class `C` given a labeled sample `S` is the
+subset of `C` whose concepts agree with `S` on every observed point — the
+classical "concepts still consistent with the data" of Mitchell (1977) and
+Angluin (1980).
+
+## Main definitions
+
+- `VersionSpace C S`: the subset of `C` whose concepts agree with `S` on every
+  sample point.
+- `IsConsistent A C`: a learner is consistent with `C` if its output always lies
+  in the version space at the received sample.
+- `empiricalMiscount h S`: number of sample points where `h` errs (`[DecidableEq β]`).
+- `empiricalMeasure S`: the uniform Dirac mixture over the sample.
+- `empiricalError h S`: the empirical distribution's mass on the disagreement set.
+- `Realizable C S`: some concept in `C` labels every sample point correctly.
+
+## Main results
+
+- `versionSpace_subset`, `versionSpace_empty_sample`, `versionSpace_reindex`,
+  `versionSpace_antitone`, `versionSpace_mono_C`: structural properties.
+- `mem_versionSpace_iff_empiricalMiscount_zero`: combinatorial bridge.
+- `mem_versionSpace_iff_empiricalError_zero`: measure-theoretic bridge.
+- `IsConsistent.empiricalMiscount_eq_zero`, `IsConsistent.empiricalError_eq_zero`:
+  consistent learners achieve zero error / miscount on every sample.
+- `mem_versionSpace_of_realizable`, `Realizable.versionSpace_nonempty`: realizable
+  samples give non-empty version spaces.
+- `ae_mem_versionSpace_of_realizable`: under iid sampling from a realizable
+  joint distribution, the target concept lies in the version space almost surely.
+
+## References
+
+* [Mitchell1977]
+* [Mitchell1982]
+* [Angluin1980]
+* [Mitchell1997]
+-/
+
+@[expose] public section
+
+open MeasureTheory Set
+open scoped ENNReal
+
+namespace Cslib.MachineLearning.PACLearning
+
+variable {α : Type*} {β : Type*}
+
+/-! ### Version Space -/
+
+/-- The *version space* of a concept class `C` given a labeled sample `S`:
+the set of concepts in `C` whose labels agree with `S` on every observed point. -/
+def VersionSpace {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) :
+    ConceptClass α β :=
+  {h ∈ C | ∀ i : Fin m, h (S i).1 = (S i).2}
+
+/-- Membership in the version space unfolds to concept membership plus
+per-sample consistency. -/
+theorem mem_versionSpace_iff {m : ℕ} {C : ConceptClass α β}
+    {S : LabeledSample α β m} {h : α → β} :
+    h ∈ VersionSpace C S ↔ h ∈ C ∧ ∀ i : Fin m, h (S i).1 = (S i).2 := Iff.rfl
+
+/-- The version space is a subset of the original concept class. -/
+theorem versionSpace_subset {m : ℕ} (C : ConceptClass α β)
+    (S : LabeledSample α β m) :
+    VersionSpace C S ⊆ C := fun _ hh => hh.1
+
+/-- Version space on the empty sample equals the whole concept class. -/
+theorem versionSpace_empty_sample (C : ConceptClass α β)
+    (S : LabeledSample α β 0) :
+    VersionSpace C S = C := by
+  ext h
+  refine ⟨fun hh => hh.1, fun hh => ⟨hh, fun i => i.elim0⟩⟩
+
+/-- *Version space reindexing.* For any reindexing `f : Fin m → Fin n`, the
+version space on `S` is contained in the version space on the reindexed sample
+`S ∘ f`. -/
+theorem versionSpace_reindex {m n : ℕ} (f : Fin m → Fin n) (C : ConceptClass α β)
+    (S : LabeledSample α β n) :
+    VersionSpace C S ⊆ VersionSpace C (S ∘ f) :=
+  fun _ hh => ⟨hh.1, fun i => hh.2 (f i)⟩
+
+/-- *Version space antitonicity.* Given a sample of size `n` and `m ≤ n`, the
+version space on all `n` observations is a subset of the version space on the
+first `m` observations. Special case of `versionSpace_reindex` with
+`f := Fin.castLE hmn`. -/
+theorem versionSpace_antitone {m n : ℕ} (hmn : m ≤ n) (C : ConceptClass α β)
+    (S : LabeledSample α β n) :
+    VersionSpace C S ⊆ VersionSpace C (S ∘ Fin.castLE hmn) :=
+  versionSpace_reindex (Fin.castLE hmn) C S
+
+/-- *Version space is monotone in the concept class.* -/
+theorem versionSpace_mono_C {m : ℕ} {C C' : ConceptClass α β} (hCC' : C ⊆ C')
+    (S : LabeledSample α β m) :
+    VersionSpace C S ⊆ VersionSpace C' S :=
+  fun _ hh => ⟨hCC' hh.1, hh.2⟩
+
+/-! ### Empirical Error -/
+
+/-- The *empirical miscount* of a hypothesis `h` on a labeled sample `S`: the
+number of sample points where `h` predicts incorrectly. -/
+def empiricalMiscount [DecidableEq β] {m : ℕ} (h : α → β)
+    (S : LabeledSample α β m) : ℕ :=
+  (Finset.univ.filter fun i : Fin m => h (S i).1 ≠ (S i).2).card
+
+section EmpiricalMeasure
+variable [MeasurableSpace α] [MeasurableSpace β]
+
+/-- The *empirical distribution* of a labeled sample: the uniform mixture of
+Dirac measures at each sample point. Equals the zero measure when `m = 0`. -/
+noncomputable def empiricalMeasure {m : ℕ} (S : LabeledSample α β m) :
+    Measure (α × β) :=
+  if _hm : m = 0 then 0
+  else (m : ℝ≥0∞)⁻¹ • ∑ i, Measure.dirac (S i)
+
+/-- The *empirical 0-1 error* of `h` on `S`: the empirical distribution's
+mass on the disagreement set. -/
+noncomputable def empiricalError {m : ℕ} (h : α → β) (S : LabeledSample α β m) :
+    ℝ≥0∞ :=
+  error (empiricalMeasure S) h
+
+end EmpiricalMeasure
+
+/-- Version-space membership equals concept-class membership plus zero empirical
+miscount (combinatorial bridge). -/
+theorem mem_versionSpace_iff_empiricalMiscount_zero [DecidableEq β]
+    {m : ℕ} {C : ConceptClass α β} {S : LabeledSample α β m} {h : α → β} :
+    h ∈ VersionSpace C S ↔ h ∈ C ∧ empiricalMiscount h S = 0 := by
+  simp only [empiricalMiscount, Finset.card_eq_zero, Finset.filter_eq_empty_iff,
+             Finset.mem_univ, true_implies, ne_eq, Decidable.not_not]
+  rfl
+
+/-- Version-space membership equals concept-class membership plus zero empirical
+error (measure-theoretic bridge). -/
+theorem mem_versionSpace_iff_empiricalError_zero
+    [MeasurableSpace α] [MeasurableSpace β]
+    [MeasurableSingletonClass α] [MeasurableSingletonClass β]
+    {m : ℕ} {C : ConceptClass α β} {S : LabeledSample α β m} {h : α → β} :
+    h ∈ VersionSpace C S ↔ h ∈ C ∧ empiricalError h S = 0 := by
+  refine and_congr_right fun _ => ?_
+  unfold empiricalError empiricalMeasure error
+  rcases Nat.eq_zero_or_pos m with hm | hm
+  · subst hm
+    rw [dif_pos rfl]
+    simp only [Measure.coe_zero, Pi.zero_apply]
+    exact iff_of_true (fun i => i.elim0) trivial
+  · have hm_ne : m ≠ 0 := Nat.pos_iff_ne_zero.mp hm
+    have hm_inv_ne : (m : ℝ≥0∞)⁻¹ ≠ 0 :=
+      ENNReal.inv_ne_zero.mpr (ENNReal.natCast_ne_top m)
+    rw [dif_neg hm_ne, Measure.smul_apply, Measure.finsetSum_apply]
+    simp only [Measure.dirac_apply, Set.indicator, Set.mem_setOf_eq, Pi.one_apply,
+               smul_eq_mul]
+    rw [mul_eq_zero]
+    constructor
+    · intro hh
+      right
+      apply Finset.sum_eq_zero
+      intro i _
+      rw [if_neg]
+      intro hne
+      exact hne (hh i)
+    · rintro (h1 | h2)
+      · exact absurd h1 hm_inv_ne
+      · intro i
+        have hi := (Finset.sum_eq_zero_iff.mp h2) i (Finset.mem_univ i)
+        by_contra hne
+        rw [if_pos hne] at hi
+        exact one_ne_zero hi
+
+/-- The empirical 0-1 error equals the empirical miscount divided by the
+sample size. -/
+theorem empiricalError_eq_div [DecidableEq β]
+    [MeasurableSpace α] [MeasurableSpace β]
+    [MeasurableSingletonClass α] [MeasurableSingletonClass β]
+    {m : ℕ} (hm : 0 < m) (h : α → β) (S : LabeledSample α β m) :
+    empiricalError h S = (empiricalMiscount h S : ℝ≥0∞) / m := by
+  have hm_ne : m ≠ 0 := hm.ne'
+  unfold empiricalError empiricalMeasure error empiricalMiscount
+  rw [dif_neg hm_ne, Measure.smul_apply, Measure.finsetSum_apply]
+  simp only [Measure.dirac_apply, Set.indicator, Set.mem_setOf_eq, Pi.one_apply,
+             smul_eq_mul]
+  rw [Finset.sum_boole, ← ENNReal.div_eq_inv_mul]
+
+/-! ### Consistent Learners -/
+
+/-- A learner is *consistent* with the concept class `C` if, on every labeled
+sample it receives, its output hypothesis lies in the version space of `C` at
+that sample — i.e. the output is in `C` and agrees with every observed
+labeled pair. -/
+def IsConsistent {m : ℕ} (A : Learner α β m) (C : ConceptClass α β) : Prop :=
+  ∀ S : LabeledSample α β m, A S ∈ VersionSpace C S
+
+/-- A consistent learner's output is always in the concept class. -/
+theorem IsConsistent.output_mem_conceptClass {m : ℕ} {A : Learner α β m}
+    {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) :
+    A S ∈ C := (hA S).1
+
+/-- A consistent learner's output agrees with the sample on every observed
+point. -/
+theorem IsConsistent.output_agrees {m : ℕ} {A : Learner α β m}
+    {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m)
+    (i : Fin m) :
+    A S (S i).1 = (S i).2 := (hA S).2 i
+
+/-- A consistent learner has zero empirical miscount on every sample. -/
+theorem IsConsistent.empiricalMiscount_eq_zero [DecidableEq β]
+    {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} (hA : IsConsistent A C)
+    (S : LabeledSample α β m) :
+    empiricalMiscount (A S) S = 0 :=
+  (mem_versionSpace_iff_empiricalMiscount_zero.mp (hA S)).2
+
+/-- A consistent learner has zero empirical error on every sample. -/
+theorem IsConsistent.empiricalError_eq_zero
+    [MeasurableSpace α] [MeasurableSpace β]
+    [MeasurableSingletonClass α] [MeasurableSingletonClass β]
+    {m : ℕ} {A : Learner α β m} {C : ConceptClass α β}
+    (hA : IsConsistent A C) (S : LabeledSample α β m) :
+    empiricalError (A S) S = 0 :=
+  (mem_versionSpace_iff_empiricalError_zero.mp (hA S)).2
+
+/-! ### Realizable case -/
+
+/-- A labeled sample `S` is *realizable* by concept class `C` if some concept
+in `C` labels every sample point correctly. -/
+def Realizable {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) : Prop :=
+  ∃ c ∈ C, ∀ i : Fin m, (S i).2 = c (S i).1
+
+/-- *Realizable version-space nonemptiness.* If a target concept `c` lies in
+`C` and the sample `S` is labeled by `c` (i.e. every `(S i).2 = c (S i).1`),
+then `c` itself lies in the version space `VersionSpace C S`. -/
+theorem mem_versionSpace_of_realizable {m : ℕ} {C : ConceptClass α β}
+    {c : α → β} (hc : c ∈ C) (S : LabeledSample α β m)
+    (hS : ∀ i : Fin m, (S i).2 = c (S i).1) :
+    c ∈ VersionSpace C S :=
+  ⟨hc, fun i => (hS i).symm⟩
+
+/-- A realizable sample has nonempty version space. -/
+theorem Realizable.versionSpace_nonempty {m : ℕ} {C : ConceptClass α β}
+    {S : LabeledSample α β m} (h : Realizable C S) :
+    (VersionSpace C S).Nonempty :=
+  ⟨h.choose, mem_versionSpace_of_realizable h.choose_spec.1 S h.choose_spec.2⟩
+
+/-! ### Probabilistic Realizable -/
+
+/-- Under the pushforward of a probability measure `P` along the graph map
+`x ↦ (x, c x)`, the graph of `c` has measure `1`. -/
+private lemma map_graph_eq_one
+    [MeasurableSpace α] [MeasurableSpace β]
+    {c : α → β} (hcm : Measurable c) (P : Measure α) [IsProbabilityMeasure P]
+    (hG : MeasurableSet {p : α × β | p.2 = c p.1}) :
+    (P.map (fun x => (x, c x))) {p : α × β | p.2 = c p.1} = 1 := by
+  have hφ : Measurable (fun x : α => (x, c x)) := by fun_prop
+  rw [Measure.map_apply hφ hG]
+  have hpre : (fun x : α => (x, c x)) ⁻¹' {p : α × β | p.2 = c p.1} = Set.univ := by
+    ext x; simp
+  rw [hpre, measure_univ]
+
+/-- The iid product of the realizable joint distribution assigns measure `1`
+to the set of samples where every coordinate lies on the graph of `c`. -/
+private lemma pi_map_graph_eq_one
+    [MeasurableSpace α] [MeasurableSpace β]
+    {c : α → β} (hcm : Measurable c) (P : Measure α) [IsProbabilityMeasure P]
+    (hG : MeasurableSet {p : α × β | p.2 = c p.1}) {m : ℕ} :
+    (Measure.pi (fun _ : Fin m => P.map (fun x => (x, c x))))
+      (Set.univ.pi (fun _ : Fin m => {p : α × β | p.2 = c p.1})) = 1 := by
+  have hφ : Measurable (fun x : α => (x, c x)) := by fun_prop
+  haveI : IsProbabilityMeasure (P.map (fun x : α => (x, c x))) :=
+    Measure.isProbabilityMeasure_map hφ.aemeasurable
+  rw [Measure.pi_pi]
+  simp [map_graph_eq_one hcm P hG]
+
+/-- Under iid sampling from the realizable joint distribution induced by
+`c ∈ C` and a probability measure `P` on `α`, the target concept `c` lies in
+the version space almost surely. -/
+theorem ae_mem_versionSpace_of_realizable
+    [MeasurableSpace α] [MeasurableSpace β]
+    {C : ConceptClass α β} {c : α → β} (hc : c ∈ C) (hcm : Measurable c)
+    (hG : MeasurableSet {p : α × β | p.2 = c p.1})
+    (P : Measure α) [IsProbabilityMeasure P] (m : ℕ) :
+    ∀ᵐ S : LabeledSample α β m
+      ∂(Measure.pi (fun _ : Fin m => P.map (fun x => (x, c x)))),
+      c ∈ VersionSpace C S := by
+  have hφ : Measurable (fun x : α => (x, c x)) := by fun_prop
+  haveI : IsProbabilityMeasure (P.map (fun x : α => (x, c x))) :=
+    Measure.isProbabilityMeasure_map hφ.aemeasurable
+  rw [ae_iff]
+  have hsub : {S : Fin m → α × β | ¬ c ∈ VersionSpace C S} ⊆
+      (Set.univ.pi (fun _ : Fin m => {p : α × β | p.2 = c p.1}))ᶜ := by
+    intro S hS hcontra
+    simp only [Set.mem_pi, Set.mem_univ, true_implies, Set.mem_setOf_eq] at hcontra
+    exact hS ⟨hc, fun i => (hcontra i).symm⟩
+  have hcompl : (Measure.pi (fun _ : Fin m => P.map (fun x : α => (x, c x))))
+      ((Set.univ.pi (fun _ : Fin m => {p : α × β | p.2 = c p.1}))ᶜ) = 0 := by
+    rw [prob_compl_eq_one_sub (MeasurableSet.univ_pi fun _ => hG),
+        pi_map_graph_eq_one hcm P hG, tsub_self]
+  exact measure_mono_null hsub hcompl
+
+end Cslib.MachineLearning.PACLearning
diff --git a/references.bib b/references.bib
index 7b68d1f7ad..e43b1cdbeb 100644
--- a/references.bib
+++ b/references.bib
@@ -382,3 +382,42 @@ @incollection{WinskelNielsen1995
   url          = {https://doi.org/10.1093/oso/9780198537809.003.0001},
   eprint       = {https://academic.oup.com/book/0/chapter/421962123/chapter-pdf/52352653/isbn-9780198537809-book-part-1.pdf},
 }
+
+@inproceedings{Mitchell1977,
+  author       = {Mitchell, Tom M.},
+  title        = {Version Spaces: A Candidate Elimination Approach to Rule Learning},
+  booktitle    = {Proceedings of the 5th International Joint Conference on Artificial Intelligence},
+  volume       = {1},
+  pages        = {305--310},
+  year         = {1977}
+}
+
+@article{Mitchell1982,
+  author       = {Mitchell, Tom M.},
+  title        = {Generalization as Search},
+  journal      = {Artificial Intelligence},
+  volume       = {18},
+  number       = {2},
+  pages        = {203--226},
+  year         = {1982},
+  doi          = {10.1016/0004-3702(82)90040-6}
+}
+
+@article{Angluin1980,
+  author       = {Angluin, Dana},
+  title        = {Inductive Inference of Formal Languages from Positive Data},
+  journal      = {Information and Control},
+  volume       = {45},
+  number       = {2},
+  pages        = {117--135},
+  year         = {1980},
+  doi          = {10.1016/S0019-9958(80)90285-5}
+}
+
+@book{Mitchell1997,
+  author       = {Mitchell, Tom M.},
+  title        = {Machine Learning},
+  year         = {1997},
+  publisher    = {McGraw-Hill},
+  isbn         = {0070428077}
+}

From d0c137a2e65bb13d906be55bcde4fecaa7972c0b Mon Sep 17 00:00:00 2001
From: Fabrizio Montesi <famontesi@gmail.com>
Date: Fri, 29 May 2026 15:30:25 +0200
Subject: [PATCH 087/106] doc(Governance): add @SamuelSchlesinger to reviewers
 (#608)

Adds @SamuelSchlesinger to the GOVERNANCE file as a reviewer.
---
 GOVERNANCE.md | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/GOVERNANCE.md b/GOVERNANCE.md
index 50bc561aff..200340c6e7 100644
--- a/GOVERNANCE.md
+++ b/GOVERNANCE.md
@@ -46,5 +46,6 @@ Area maintainers are trusted contributors who take ownership of specific areas o
 Reviewers are trusted contributors who provide regular reviewing and technical guidance to PRs to CSLib.
 
 - Ching-Tsun Chou (@ctchou).
-- Thomas Waring (@thomaskwaring). 
+- Samuel Schlesinger (@SamuelSchlesinger).
+- Thomas Waring (@thomaskwaring).
 - Eric Wieser (@eric-wieser), Google DeepMind.

From 2f677bfc8ef76fa7a27feafc597c1e4a7eda3e42 Mon Sep 17 00:00:00 2001
From: Garmelon <joscha@plugh.de>
Date: Fri, 29 May 2026 16:31:42 +0100
Subject: [PATCH 088/106] chore: bump toolchain to v4.31.0-rc1 (#609)

Co-authored-by: Kim Morrison <477956+kim-em@users.noreply.github.com>
Co-authored-by: mathlib4-bot <github-mathlib4-bot@leanprover.zulipchat.com>
Co-authored-by: mathlib-nightly-testing[bot] <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com>
Co-authored-by: leanprover-community-mathlib4-bot <129911861+leanprover-community-mathlib4-bot@users.noreply.github.com>
Co-authored-by: Kim Morrison <kim@tqft.net>
Co-authored-by: leanprover-community-mathlib4-bot <leanprover-community-mathlib4-bot@users.noreply.github.com>
Co-authored-by: Chris Henson <chrishenson.net@gmail.com>
Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com>
Co-authored-by: Ching-Tsun Chou <chingtsun.chou@gmail.com>
Co-authored-by: Alexandre Rademaker <arademaker@gmail.com>
Co-authored-by: mathlib-nightly-testing[bot] <mathlib-nightly-testing[bot]@users.noreply.github.com>
Co-authored-by: Fabrizio Montesi <famontesi@gmail.com>
---
 Cslib.lean                                    |   2 +-
 Cslib/Computability/Automata/DA/Congr.lean    |   2 +-
 .../Congruences/BuchiCongruence.lean          |   2 +-
 .../Machines/SingleTapeTuring/Basic.lean      |   4 -
 .../Protocols/SecretSharing/Shamir.lean       |   2 +-
 Cslib/Foundations/Control/Monad/Free.lean     |   3 +-
 .../Control/Monad/Free/Effects.lean           |   2 +-
 Cslib/Foundations/Data/HasFresh.lean          | 121 +++++++++---------
 .../LocallyNameless/Fsub/Safety.lean          |  22 ++--
 .../LinearLogic/CLL/PhaseSemantics/Basic.lean |   4 +-
 Cslib/Logics/Modal/Cube.lean                  |  30 ++---
 CslibTests.lean                               |   2 +-
 CslibTests/FreeMonad.lean                     |   4 +-
 lake-manifest.json                            |  28 ++--
 lakefile.toml                                 |   2 +-
 lean-toolchain                                |   2 +-
 16 files changed, 116 insertions(+), 116 deletions(-)

diff --git a/Cslib.lean b/Cslib.lean
index 565352e8e3..22881196dc 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -1,4 +1,4 @@
-module  -- shake: keep-all
+module  -- shake: keep-all --deprecated_module: ignore
 
 public import Cslib.Algorithms.Lean.MergeSort.MergeSort
 public import Cslib.Algorithms.Lean.TimeM
diff --git a/Cslib/Computability/Automata/DA/Congr.lean b/Cslib/Computability/Automata/DA/Congr.lean
index c1c49edf5d..d4c4356373 100644
--- a/Cslib/Computability/Automata/DA/Congr.lean
+++ b/Cslib/Computability/Automata/DA/Congr.lean
@@ -62,7 +62,7 @@ theorem congr_language_eq {a : Quotient c.eq} : language (FinAcc.mk c.toDA {a})
   /-- A grind regression found moving to nightly-2026-03-31 (changes from lean#13166) -/
   constructor <;>
   · intro h
-    simpa [mem_language, Accepts, congr_mtr_eq] using h
+    simpa [mem_language, Accepts, congr_mtr_eq] using! h
 
 end FinAcc
 
diff --git a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
index f9c3ff0051..9f837fd73f 100644
--- a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
+++ b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
@@ -142,7 +142,7 @@ theorem buchiFamily_cover [Inhabited Symbol] [Finite State] :
       simp_all only [extract_drop, color]
       split_ifs with h
       · have : f k ≤ f (k + 1) := by lia
-        have : f 0 + (f k - f 0) = f k := by lia
+        have : f 0 + (f k - f 0) = f k := by grind
         have : f 0 + (f (k + 1) - f 0) = f (k + 1) := by lia
         simp_all
         rfl
diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
index b956b62869..debad7d43f 100644
--- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
@@ -384,8 +384,6 @@ This section defines the notion of time-bounded Turing Machines
 
 section TimeComputable
 
-variable [Inhabited Symbol] [Fintype Symbol]
-
 /-- A Turing machine + a time function +
 a proof it outputs `f` in at most `time(input.length)` steps. -/
 structure TimeComputable (f : List Symbol → List Symbol) where
@@ -470,8 +468,6 @@ section PolyTimeComputable
 
 open Polynomial
 
-variable [Inhabited Symbol] [Fintype Symbol]
-
 /-- A Turing machine + a polynomial time function +
 a proof it outputs `f` in at most `time(input.length)` steps. -/
 structure PolyTimeComputable (f : List Symbol → List Symbol) extends TimeComputable f where
diff --git a/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
index 5e5d7f2930..bd0de00d3b 100644
--- a/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
+++ b/Cslib/Crypto/Protocols/SecretSharing/Shamir.lean
@@ -153,7 +153,7 @@ private theorem privacyCorrectionPolynomial_eval
     (privacyCorrectionPolynomial (F := F) params s secret₀ secret₁).eval (params.point i) =
       (secret₀ - secret₁) / params.point i := by
   classical
-  simpa using
+  simpa using!
     (_root_.Lagrange.eval_interpolate_at_node
       (s := s.attach)
       (v := fun j : s => params.point j)
diff --git a/Cslib/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean
index dd8b2e66ad..90b2fea4c0 100644
--- a/Cslib/Foundations/Control/Monad/Free.lean
+++ b/Cslib/Foundations/Control/Monad/Free.lean
@@ -230,7 +230,8 @@ lemma liftM_lift_bind (interp : {ι : Type u} → F ι → m ι) (op : F β) (co
 @[simp]
 lemma liftM_lift [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (op : F β) :
     (lift op).liftM interp = interp op := by
-  simp_rw [lift, FreeM.liftM, _root_.bind_pure]
+  rw [lift, FreeM.liftM]
+  simp
 
 @[simp]
 lemma liftM_bind [LawfulMonad m]
diff --git a/Cslib/Foundations/Control/Monad/Free/Effects.lean b/Cslib/Foundations/Control/Monad/Free/Effects.lean
index 7c58bca5a9..65ab32302e 100644
--- a/Cslib/Foundations/Control/Monad/Free/Effects.lean
+++ b/Cslib/Foundations/Control/Monad/Free/Effects.lean
@@ -449,7 +449,7 @@ instance instMonadWithReaderOf : MonadWithReaderOf σ (FreeReader σ) where
   | pure a => rfl
   | liftBind op cont ih =>
     cases op
-    simpa [withTheReader, instMonadWithReaderOf, run] using (ih (f s) s)
+    simpa [withTheReader, instMonadWithReaderOf, run] using! (ih (f s) s)
 
 end FreeReader
 
diff --git a/Cslib/Foundations/Data/HasFresh.lean b/Cslib/Foundations/Data/HasFresh.lean
index 6c095a334d..01ae7bc7fd 100644
--- a/Cslib/Foundations/Data/HasFresh.lean
+++ b/Cslib/Foundations/Data/HasFresh.lean
@@ -8,16 +8,17 @@ module -- shake: keep-downstream
 
 public import Cslib.Init
 public import Mathlib.Analysis.Normed.Field.Lemmas
+meta import Lean.Elab.ConfigEval
 import Qq
 
 /-! Computable chacterization of infinite types. -/
 
+namespace Cslib
+
 @[expose] public section
 
 universe u
 
-namespace Cslib
-
 /-- A type `α` has a computable `fresh` function if it is always possible, for any finite set
 of `α`, to compute a fresh element not in the set. -/
 class HasFresh (α : Type u) where
@@ -33,6 +34,63 @@ in proofs. -/
 theorem HasFresh.fresh_exists {α : Type u} [HasFresh α] (s : Finset α) : ∃ a, a ∉ s :=
   ⟨fresh s, fresh_notMem s⟩
 
+export HasFresh (fresh fresh_notMem fresh_exists)
+
+/-- `HasFresh α` implies a computably infinite type. -/
+instance HasFresh.to_infinite (α : Type u) [HasFresh α] : Infinite α := by
+  apply Infinite.of_not_fintype
+  rintro ⟨elems, _⟩
+  grind [fresh_notMem elems]
+
+/-- All infinite types have an associated (at least noncomputable) fresh function.
+This, in conjunction with `HasFresh.to_infinite`, characterizes `HasFresh`. -/
+noncomputable instance (α : Type u) [Infinite α] : HasFresh α where
+  fresh s := Infinite.exists_notMem_finset s |>.choose
+  fresh_notMem s := by grind
+
+open Finset in
+/-- Construct a fresh element from an embedding of `ℕ` using `Nat.find`. -/
+@[implicit_reducible]
+def HasFresh.ofNatEmbed {α : Type u} [DecidableEq α] (e : ℕ ↪ α) : HasFresh α where
+  fresh s := e (Nat.find (p := fun n ↦ e n ∉ s) ⟨(s.preimage e e.2.injOn).max.succ,
+    fun h ↦ not_lt_of_ge (le_max <| mem_preimage.2 h) (WithBot.lt_succ _)⟩)
+  fresh_notMem s := Nat.find_spec (p := fun n ↦ e n ∉ s) _
+
+/-- Construct a fresh element given a function `f` with `x < f x`. -/
+@[implicit_reducible]
+def HasFresh.ofSucc {α : Type u} [Inhabited α] [SemilatticeSup α] (f : α → α) (hf : ∀ x, x < f x) :
+    HasFresh α where
+  fresh s := if hs : s.Nonempty then f (s.sup' hs id) else default
+  fresh_notMem s h := if hs : s.Nonempty
+    then not_le_of_gt (hf (s.sup' hs id)) <| by rw [dif_pos hs] at h; exact s.le_sup' id h
+    else hs ⟨_, h⟩
+
+/-- `ℕ` has a computable fresh function. -/
+instance : HasFresh ℕ :=
+  .ofSucc (· + 1) Nat.lt_add_one
+
+/-- `ℤ` has a computable fresh function. -/
+instance : HasFresh ℤ :=
+  .ofSucc (· + 1) Int.lt_succ
+
+/-- `ℚ` has a computable fresh function. -/
+instance : HasFresh ℚ :=
+  .ofSucc (· + 1) fun x ↦ lt_add_of_pos_right x one_pos
+
+/-- If `α` has a computable fresh function, then so does `Finset α`. -/
+instance {α : Type u} [DecidableEq α] [HasFresh α] : HasFresh (Finset α) :=
+  .ofSucc (fun s ↦ insert (fresh s) s) fun s ↦ Finset.ssubset_insert <| fresh_notMem s
+
+/-- If `α` is inhabited, then `Multiset α` has a computable fresh function. -/
+instance {α : Type u} [DecidableEq α] [Inhabited α] : HasFresh (Multiset α) :=
+  .ofSucc (fun s ↦ default ::ₘ s) fun _ ↦ Multiset.lt_cons_self _ _
+
+/-- `ℕ → ℕ` has a computable fresh function. -/
+instance : HasFresh (ℕ → ℕ) :=
+  .ofSucc (fun f x ↦ f x + 1) fun _ ↦ Pi.lt_def.2 ⟨fun _ ↦ Nat.le_succ _, 0, Nat.lt_succ_self _⟩
+
+end
+
 public meta section
 
 open Lean Elab Term Meta Parser Tactic
@@ -45,7 +103,7 @@ structure FreeUnionConfig where
   finset : Bool := true
 
 /-- Elaborate a FreeUnionConfig. -/
-declare_config_elab elabFreeUnionConfig FreeUnionConfig
+declare_term_config_elab elabFreeUnionConfig FreeUnionConfig
 
 /--
   Given a `DecidableEq Var` instance, this elaborator automatically constructs
@@ -87,7 +145,7 @@ set_option linter.style.emptyLine false in
 def HasFresh.freeUnion : TermElab := fun stx _ => do
   match stx with
   | `(free_union $cfg $[[$maps,*]]? $var:term) =>
-    let cfg ← elabFreeUnionConfig cfg |>.run { elaborator := .anonymous } |>.run' { goals := [] }
+    let cfg ← elabFreeUnionConfig cfg
 
     -- the type of our variables
     let var ← elabType var
@@ -124,59 +182,4 @@ def HasFresh.freeUnion : TermElab := fun stx _ => do
 
 end
 
-export HasFresh (fresh fresh_notMem fresh_exists)
-
-/-- `HasFresh α` implies a computably infinite type. -/
-instance HasFresh.to_infinite (α : Type u) [HasFresh α] : Infinite α := by
-  apply Infinite.of_not_fintype
-  rintro ⟨elems, _⟩
-  grind [fresh_notMem elems]
-
-/-- All infinite types have an associated (at least noncomputable) fresh function.
-This, in conjunction with `HasFresh.to_infinite`, characterizes `HasFresh`. -/
-noncomputable instance (α : Type u) [Infinite α] : HasFresh α where
-  fresh s := Infinite.exists_notMem_finset s |>.choose
-  fresh_notMem s := by grind
-
-open Finset in
-/-- Construct a fresh element from an embedding of `ℕ` using `Nat.find`. -/
-@[implicit_reducible]
-def HasFresh.ofNatEmbed {α : Type u} [DecidableEq α] (e : ℕ ↪ α) : HasFresh α where
-  fresh s := e (Nat.find (p := fun n ↦ e n ∉ s) ⟨(s.preimage e e.2.injOn).max.succ,
-    fun h ↦ not_lt_of_ge (le_max <| mem_preimage.2 h) (WithBot.lt_succ _)⟩)
-  fresh_notMem s := Nat.find_spec (p := fun n ↦ e n ∉ s) _
-
-/-- Construct a fresh element given a function `f` with `x < f x`. -/
-@[implicit_reducible]
-def HasFresh.ofSucc {α : Type u} [Inhabited α] [SemilatticeSup α] (f : α → α) (hf : ∀ x, x < f x) :
-    HasFresh α where
-  fresh s := if hs : s.Nonempty then f (s.sup' hs id) else default
-  fresh_notMem s h := if hs : s.Nonempty
-    then not_le_of_gt (hf (s.sup' hs id)) <| by rw [dif_pos hs] at h; exact s.le_sup' id h
-    else hs ⟨_, h⟩
-
-/-- `ℕ` has a computable fresh function. -/
-instance : HasFresh ℕ :=
-  .ofSucc (· + 1) Nat.lt_add_one
-
-/-- `ℤ` has a computable fresh function. -/
-instance : HasFresh ℤ :=
-  .ofSucc (· + 1) Int.lt_succ
-
-/-- `ℚ` has a computable fresh function. -/
-instance : HasFresh ℚ :=
-  .ofSucc (· + 1) fun x ↦ lt_add_of_pos_right x one_pos
-
-/-- If `α` has a computable fresh function, then so does `Finset α`. -/
-instance {α : Type u} [DecidableEq α] [HasFresh α] : HasFresh (Finset α) :=
-  .ofSucc (fun s ↦ insert (fresh s) s) fun s ↦ Finset.ssubset_insert <| fresh_notMem s
-
-/-- If `α` is inhabited, then `Multiset α` has a computable fresh function. -/
-instance {α : Type u} [DecidableEq α] [Inhabited α] : HasFresh (Multiset α) :=
-  .ofSucc (fun s ↦ default ::ₘ s) fun _ ↦ Multiset.lt_cons_self _ _
-
-/-- `ℕ → ℕ` has a computable fresh function. -/
-instance : HasFresh (ℕ → ℕ) :=
-  .ofSucc (fun f x ↦ f x + 1) fun _ ↦ Pi.lt_def.2 ⟨fun _ ↦ Nat.le_succ _, 0, Nat.lt_succ_self _⟩
-
 end Cslib
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
index 1bb05bd29f..e777ed0ea7 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Fsub/Safety.lean
@@ -75,14 +75,14 @@ set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- Any typable term either has a reduction step or is a value. -/
 lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t' := by
   generalize eq : [] = Γ at der
-  have der' : Typing Γ t τ := by assumption
-  induction der <;> subst eq <;> simp only [forall_const] at *
+  have der' : Typing Γ t τ := der
+  induction der <;> subst eq
   case var mem => grind
   case app t₁ _ _ t₂ l r ih_l ih_r =>
     right
-    cases ih_l l with
+    cases ih_l rfl l with
     | inl val_l =>
-        cases ih_r r with
+        cases ih_r rfl r with
         | inl val_r =>
             have ⟨σ, t₁, eq⟩ := l.canonical_form_abs val_l
             exists t₁ ^ᵗᵗ t₂
@@ -97,7 +97,7 @@ lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t'
         grind
   case tapp σ' der _ ih =>
     right
-    specialize ih der
+    specialize ih rfl der
     cases ih with
     | inl val =>
         obtain ⟨_, t, _⟩ := der.canonical_form_tabs val
@@ -107,9 +107,9 @@ lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t'
         obtain ⟨t', _⟩ := red
         exists .tapp t' σ'
         grind
-  case let' t₁ σ t₂ τ L der _ _ ih =>
+  case let' t₁ σ t₂ τ L der _ ih _ =>
     right
-    cases ih der with
+    cases ih rfl der with
     | inl _ =>
         exists t₂ ^ᵗᵗ t₁
         grind
@@ -118,7 +118,7 @@ lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t'
         exists t₁'.let' t₂
         grind
   case inl der _ ih =>
-    cases (ih der) with
+    cases (ih rfl der) with
     | inl val => grind
     | inr red =>
         right
@@ -126,16 +126,16 @@ lemma Typing.progress (der : Typing [] t τ) : t.Value ∨ ∃ t', t ⭢βᵛ t'
         exists .inl t'
         grind
   case inr der _ ih =>
-    cases (ih der) with
+    cases (ih rfl der) with
     | inl val => grind
     | inr red =>
         right
         obtain ⟨t', _⟩ := red
         exists .inr t'
         grind
-  case case t₁ _ _ t₂ _ t₃ _ der _ _ _ _ ih =>
+  case case t₁ _ _ t₂ _ t₃ _ der _ _ ih _ _ =>
     right
-    cases ih der with
+    cases ih rfl der with
     | inl val =>
         have ⟨t₁, lr⟩ := der.canonical_form_sum val
         cases lr <;> [exists t₂ ^ᵗᵗ t₁; exists t₃ ^ᵗᵗ t₁] <;> grind
diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
index 32d86d85c8..887d8f549d 100644
--- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
+++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean
@@ -264,7 +264,7 @@ lemma biorth_least_fact (G : Set P) :
       symm at hF ⊢
       apply ClosureOperator.IsClosed.closure_eq (congrArg orthogonal (congrArg orthogonal hF))
     have hF_closed : c.IsClosed F := (c.isClosed_iff).2 this.symm
-    simpa [c] using ClosureOperator.closure_min hGF hF_closed
+    simpa [c] using! ClosureOperator.closure_min hGF hF_closed
   apply h_min
 
 /-- `0` is the least fact (w.r.t. inclusion). -/
@@ -304,7 +304,7 @@ lemma inter_isFact_of_isFact {A B : Set P}
   let FB : Fact P := ⟨B, hB⟩
   have h := sInf_isFact (S := ({FA, FB} : Set (Fact P)))
   simpa [carriersInf, Set.image_pair, sInf_insert, sInf_singleton, inf_eq_inter]
-    using h
+    using! h
 
 instance : InfSet (Fact P) where
   sInf S := ⟨carriersInf S, sInf_isFact (S := S)⟩
diff --git a/Cslib/Logics/Modal/Cube.lean b/Cslib/Logics/Modal/Cube.lean
index 3106b08fda..98e825014c 100644
--- a/Cslib/Logics/Modal/Cube.lean
+++ b/Cslib/Logics/Modal/Cube.lean
@@ -24,63 +24,63 @@ relationships.
 namespace Cslib.Logic.Modal
 
 /-- The modal logic K. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def K World Atom := logic (Set.univ (α := Model World Atom))
 
 /-- The modal logic T. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def T World Atom := logic {m : Model World Atom | Std.Refl m.r}
 
 /-- The modal logic B. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def B World Atom := logic {m : Model World Atom | Std.Symm m.r}
 
 /-- The modal logic 4. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def Four World Atom := logic {m : Model World Atom | IsTrans World m.r}
 
 /-- The modal logic 5. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def Five World Atom := logic {m : Model World Atom | Relation.RightEuclidean m.r}
 
 /-- The modal logic K45. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def K45 World Atom := (K World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
 
 /-- The modal logic D. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def D World Atom := logic {m : Model World Atom | Relation.Serial m.r}
 
 /-- The modal logic D4. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def D4 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom)
 
 /-- The modal logic D5. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def D5 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Five World Atom)
 
 /-- The modal logic D45. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def D45 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
 
 /-- The modal logic DB. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def DB World Atom := (K World Atom) ∪ (D World Atom) ∪ (B World Atom)
 
 /-- The modal logic TB. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def TB World Atom := (K World Atom) ∪ (T World Atom) ∪ (B World Atom)
 
 /-- The modal logic KB5. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def KB5 World Atom := (K World Atom) ∪ (B World Atom) ∪ (Five World Atom)
 
 /-- The modal logic S4. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def S4 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom)
 
 /-- The modal logic S5. -/
-@[simp, scoped grind =]
+@[scoped grind =]
 def S5 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
 
 section Order
diff --git a/CslibTests.lean b/CslibTests.lean
index 7b52a3a319..12bc0e4611 100644
--- a/CslibTests.lean
+++ b/CslibTests.lean
@@ -1,4 +1,4 @@
-module  -- shake: keep-all
+module  -- shake: keep-all --deprecated_module: ignore
 
 public import CslibTests.Bisimulation
 public import CslibTests.CCS
diff --git a/CslibTests/FreeMonad.lean b/CslibTests/FreeMonad.lean
index 9928038563..6e6ce0359a 100644
--- a/CslibTests/FreeMonad.lean
+++ b/CslibTests/FreeMonad.lean
@@ -264,7 +264,7 @@ theorem runEff_bind_ok {α β}
     (h : runEff p env tr = .ok (v, env', tr')) :
     runEff (p >>= k) env tr = runEff (k v) env' tr' := by
   revert h
-  induction p generalizing env env' tr tr' v <;> simp only [runEff, bind, foldFreeM] <;> intro h
+  induction p generalizing env env' tr tr' v <;> simp only [runEff, bind] <;> intro h
   · case pure => cases h; rfl
   · case lift_bind _ op _ ih =>
     cases op
@@ -285,7 +285,7 @@ theorem runEff_bind_err {α β}
     {env : Env} {tr : Trace} {msg : String} :
     runEff p env tr = .error msg →
     runEff (p >>= k) env tr = .error msg := by
-  induction p generalizing env tr msg <;> simp only [runEff, bind, foldFreeM] <;> intro h
+  induction p generalizing env tr msg <;> simp only [runEff, bind] <;> intro h
   · case pure => simp [effPure] at h
   · case lift_bind _ op _ ih =>
     cases op
diff --git a/lake-manifest.json b/lake-manifest.json
index 7b2d3b8f19..16cc306345 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,17 +5,17 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "c5ea00351c28e24afc9f0f84379aa41082b1188f",
+   "rev": "d568c8c09630de097a046763c17b9ea99f95f950",
    "name": "mathlib",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "c5ea00351c28e24afc9f0f84379aa41082b1188f",
+   "inputRev": "d568c8c09630de097a046763c17b9ea99f95f950",
    "inherited": false,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/plausible",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "a456461b368b71d2accd95234832cd9c174b5437",
+   "rev": "d575be693add4fe9cb996968968ce42ce75c5ccd",
    "name": "plausible",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -35,7 +35,7 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "515cf9d0c00ece5e661f6de4326a53dedc1e8ea1",
+   "rev": "6db47de43aa7f516708053ae2fdadd29dd9baaaa",
    "name": "importGraph",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -45,50 +45,50 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "a84b3e2475d5c5ab979567b1ad8aea21b764bcf8",
+   "rev": "85bb7e7637e84a7d9803be7d954579fdae42c64b",
    "name": "proofwidgets",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v0.0.99",
+   "inputRev": "v0.0.100",
    "inherited": true,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/aesop",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "558915ae105bfd8074e22d597613d1961822adc2",
+   "rev": "fafca80479ff95e041d84373dda7122adf1295f2",
    "name": "aesop",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover-community/quote4",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "a6e6c34c4ef182f83b219a3a5a385f51f44bdc4c",
+   "rev": "8d33324ee877e9735d2829bc6f1f439e60cf98b1",
    "name": "Qq",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover-community/batteries",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "32dc18cde3684679f3c003de608743b57498c56f",
+   "rev": "708b057842c4cd0845fba132bd94b08493f6fc42",
    "name": "batteries",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "main",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover/lean4-cli",
    "type": "git",
    "subDir": null,
    "scope": "leanprover",
-   "rev": "6b907cf12b2e445ccb7c24bc208ef04a1f39e84c",
+   "rev": "48bdcff4c5fa27e09028f9f330e59baa0d4640cf",
    "name": "Cli",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"}],
  "name": "cslib",
diff --git a/lakefile.toml b/lakefile.toml
index 38c08dd947..4168dea38a 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false
 [[require]]
 name = "mathlib"
 scope = "leanprover-community"
-rev = "c5ea00351c28e24afc9f0f84379aa41082b1188f"
+rev = "d568c8c09630de097a046763c17b9ea99f95f950"
 
 [[lean_lib]]
 name = "Cslib"
diff --git a/lean-toolchain b/lean-toolchain
index af9e5d339a..8c7e931aab 100644
--- a/lean-toolchain
+++ b/lean-toolchain
@@ -1 +1 @@
-leanprover/lean4:v4.30.0
+leanprover/lean4:v4.31.0-rc1

From 43f68e97153616714e31d90163b958f4bf4b532d Mon Sep 17 00:00:00 2001
From: Ching-Tsun Chou <chingtsun.chou@gmail.com>
Date: Mon, 1 Jun 2026 00:18:02 -0700
Subject: [PATCH 089/106] feat(FLP): distributed algorithms for solving the
 consensus problem (#556)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This is the first PR of the formalization of Völzer's proof of the
famous result in distributed computing, first proved by Fischer, Lynch
and Paterson, that distributed consensus is impossible in the presence
of even a single crash fault.
* `Algorithm.lean` defines the "syntax" of a distributed algorithm for
solving the consensus problem and proves some basic properties.
* `Consensus.lean` defines what it means for a distributed algorithm to
solve the consensus problem in a fault-tolerant way and proves some
basic properties.
* README.md is for the overall project and mentions Lean files which
will be PR-ed later.
* references.bib is updated to add the papers by FLP and Völzer.

Zulip discussion:
[#CSLib > Impossibility of distributed
consensus](https://leanprover.zulipchat.com/#narrow/channel/513188-CSLib/topic/Impossibility.20of.20distributed.20consensus/with/592462001)
[#CSLib: PR reviews > #556:
consensus](https://leanprover.zulipchat.com/#narrow/channel/605128-CSLib.3A-PR-reviews/topic/.23556.3A.20consensus/with/598654217)
---
 Cslib.lean                                    |   2 +
 .../Distributed/FLP/Algorithm.lean            | 239 ++++++++++++++++++
 .../Distributed/FLP/Consensus.lean            | 144 +++++++++++
 Cslib/Computability/Distributed/FLP/README.md |  49 ++++
 references.bib                                |  31 +++
 5 files changed, 465 insertions(+)
 create mode 100644 Cslib/Computability/Distributed/FLP/Algorithm.lean
 create mode 100644 Cslib/Computability/Distributed/FLP/Consensus.lean
 create mode 100644 Cslib/Computability/Distributed/FLP/README.md

diff --git a/Cslib.lean b/Cslib.lean
index 22881196dc..c0269e0bbb 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -22,6 +22,8 @@ public import Cslib.Computability.Automata.NA.Prod
 public import Cslib.Computability.Automata.NA.Sum
 public import Cslib.Computability.Automata.NA.ToDA
 public import Cslib.Computability.Automata.NA.Total
+public import Cslib.Computability.Distributed.FLP.Algorithm
+public import Cslib.Computability.Distributed.FLP.Consensus
 public import Cslib.Computability.Languages.Congruences.BuchiCongruence
 public import Cslib.Computability.Languages.Congruences.RightCongruence
 public import Cslib.Computability.Languages.ExampleEventuallyZero
diff --git a/Cslib/Computability/Distributed/FLP/Algorithm.lean b/Cslib/Computability/Distributed/FLP/Algorithm.lean
new file mode 100644
index 0000000000..ccd90dbf65
--- /dev/null
+++ b/Cslib/Computability/Distributed/FLP/Algorithm.lean
@@ -0,0 +1,239 @@
+/-
+Copyright (c) 2026 Ching-Tsun Chou. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Ching-Tsun Chou
+-/
+
+module
+
+public import Cslib.Foundations.Semantics.LTS.OmegaExecution
+
+/-! # Distributed algorithms for solving the consensus problem
+
+In the consensus problem, each process of a distributed algorithm is given a boolean value
+at the beginning.  Then by exchanging messages asynchronously, they are supposed to agree on
+one of the initial boolean values. This file contains a very general definition of such
+a distributed algorithm.
+
+Borrowing an idea from Leslie Lamport, we allow the LTS defined by such an algorithm to
+"stutter" at any time, in the sense of taking a dummy step without changing the
+global state of the distributed algorithm.  This idea enables us to focus on infinite
+executions alone without loss of generality, because an algorithm that has run out of
+useful steps to take can always take the stuttering step.  Pathological executions in which
+the stuttering step is taken forever when there is useful work to be done are outlawed by
+the fairness assumptions defined in `Consensus.lean`.
+
+The types `P`, `M`, and `S` below are the types of processes (more precisely, process identifiers),
+messages contents, and process states.  Eventually `P` will be assumed to be finite in the form of
+`[Fintype P]`, but that assumption will be added only where necessary.  No assumption whatsoever
+will be made about `M` and `S`.  In particular, they could be infinite.
+-/
+
+@[expose] public section
+
+namespace Cslib.FLP
+
+open Set Sum Multiset
+
+variable {P M S : Type*} [DecidableEq P] [DecidableEq M]
+
+/-- The type of messages that processes send to each other. -/
+@[ext]
+structure Message (P M : Type*) where
+  /-- The destination of a message. -/
+  dest : P
+  /-- The content of the message, where the `Bool` option is used to carry to the
+      initial boolean value to each process. -/
+  msg : Bool ⊕ M
+deriving DecidableEq
+
+/-- The type of a process's local state. -/
+structure ProcState (S : Type*) where
+  /-- The internal state of a process. -/
+  state : S
+  /-- The state component used by a process to signal the boolean value it decides on. -/
+  out : Option Bool
+
+/-- The global state of the distributed algorithm. -/
+structure State (P M S : Type*) where
+  /-- A multiset containing all messages that are in-flight (namely, they have been sent but
+  not yet received). Note that being a multiset implies that the messages are not ordered. -/
+  msgs : Multiset (Message P M)
+  /-- A map giving the local states of all processes. -/
+  proc : P → ProcState S
+
+/-- The specification of a distributed algorithm for solving the consensus problem.
+Note that each field below can depend on a process's identifier (recall that each `Message`
+contains its destination's identifier), so the algorithm is not required to be uniform
+across processes. -/
+structure Algorithm (P M S : Type*) where
+  /-- A map specifying the initial state of each process. -/
+  init : P → S
+  /-- A map specifying how a process changes its internal state upon receiving a message. -/
+  next : Message P M → ProcState S → S
+  /-- A map specifying what messages a process sends out upon receiving a message. -/
+  send : Message P M → ProcState S → Multiset (Message P M)
+  /-- A map specifying the boolean decision a process makes upon receiving a message,
+      where `none` means that no decision is made. -/
+  out : Message P M → ProcState S → Option Bool
+
+/-- The type of labels of the LTS defined by an `Algorithm`, where `some m` denotes
+the reception of message `m` and `none` denotes a stuttering step. -/
+abbrev Action (P M : Type*) := Option (Message P M)
+
+/-- `DestIn ps x` means that if `x ≠ none`, then `x = some m` with `m.dest ∈ ps`. -/
+def DestIn (ps : Set P) : Action P M → Prop
+  | some m => m.dest ∈ ps
+  | none => True
+
+/-- Given `inp : P → Bool`, the initial state of the algorithm `a` contains a single message
+carrying the boolean value `inp p` to each process `p`, where the initial internal state is
+`a.init p` and no decision has been made.  The assumption `[Fintype P]` is made because
+a multiset may contain only finitely many elements. -/
+def Algorithm.start [Fintype P] (a : Algorithm P M S) (inp : P → Bool) : State P M S where
+  msgs := Multiset.map (fun p ↦ ⟨p, inl (inp p)⟩) Finset.univ.val
+  proc := fun p ↦ ⟨a.init p, none⟩
+
+/-- The specification of how the global state of the algorithm changes when a process `p`
+receives a message `m`.  (This function will be used only when such a message `m` exists.)
+Note that once `p` has made a boolean decision in its `out` field, it is not allowed to
+"change its mind" anymore. -/
+def Algorithm.recvMsg (a : Algorithm P M S) (m : Message P M) (s : State P M S) : State P M S :=
+  let p := m.dest
+  { msgs := s.msgs.erase m + a.send m (s.proc p)
+    proc := fun q ↦
+      if q = p then
+        ⟨ a.next m (s.proc p),
+          if (s.proc p).out.isNone then a.out m (s.proc p) else (s.proc p).out ⟩
+      else s.proc q }
+
+/-- The transition relation of the LTS defined by the algorithm `a`.
+Note that the stuttering step is always allowed. -/
+def Algorithm.lts (a : Algorithm P M S) : LTS (State P M S) (Action P M) where
+  Tr s x s' := match x with
+    | some m => m ∈ s.msgs ∧ s' = a.recvMsg m s
+    | none => s' = s
+
+/-- `a.Reachable inp s` means that `s` is a reachable state of `a` given the initial `inp`. -/
+def Algorithm.Reachable [Fintype P]
+    (a : Algorithm P M S) (inp : P → Bool) (s : State P M S) : Prop :=
+  a.lts.CanReach (a.start inp) s
+
+/-- `s.ProcDecided p b` means that process `p` is decided on the boolean value `b`
+in the state `s`. -/
+abbrev State.ProcDecided (s : State P M S) (p : P) (b : Bool) : Prop :=
+  (s.proc p).out = some b
+
+/-- `s.Decided b` means that at least one process is decided on the boolean value `b`
+in the state `s`. -/
+def State.Decided (s : State P M S) (b : Bool) : Prop :=
+  ∃ p, s.ProcDecided p b
+
+/-- `s.Agreed` says that all boolean values decided on in state `s` must agree with each other. -/
+def State.Agreed (s : State P M S) : Prop :=
+  ∀ b b', s.Decided b ∧ s.Decided b' → b = b'
+
+/-- `a.SafeConsensus` says that in any reachable state of `a`, (1) all boolean values decided on
+in that state must agree with each other and (2) that boolean value (if it exists) must be
+one of the boolean values given by `inp` at the beginning.  `a.SafeConsensus` is the minimal
+correctness requirement on `a` and is a safety property (hence its name). -/
+def Algorithm.SafeConsensus [Fintype P] (a : Algorithm P M S) : Prop :=
+  ∀ inp s, a.Reachable inp s → s.Agreed ∧ ∀ b, s.Decided b → ∃ p, inp p = b
+
+namespace Algorithm
+
+variable {a : Algorithm P M S} {inp : P → Bool}
+
+/-- The stuttering step does not change the global state. -/
+theorem tr_none {s s' : State P M S} (h : a.lts.Tr s none s') : s = s' := by
+  grind [Algorithm.lts]
+
+/-- The initial state is reachable. -/
+theorem reachable_start [Fintype P] :
+    a.Reachable inp (a.start inp) := by
+  simp [Algorithm.Reachable, LTS.CanReach.refl]
+
+/-- If `s` is reachable from the initial state and `s'` is reachable from `s`,
+then `s'` is reachable from the initial state. -/
+theorem reachable_stable [Fintype P] {s s' : State P M S}
+    (hr : a.Reachable inp s) (hc : a.lts.CanReach s s') : a.Reachable inp s' := by
+  obtain ⟨xs, _⟩ := hr
+  obtain ⟨xs', _⟩ := hc
+  use xs ++ xs'
+  grind [LTS.MTr.comp]
+
+/-- If `p` is decided on the boolean value `b` in `s` and `s'` is reachable from `s`,
+then `p` is still decided on `b` in `s'`. -/
+theorem procDecided_stable {s s' : State P M S} {p : P} {b : Bool}
+    (hd : s.ProcDecided p b) (hc : a.lts.CanReach s s') : s'.ProcDecided p b := by
+  obtain ⟨xs, h_mtr⟩ := hc
+  induction h_mtr <;> grind [Algorithm.lts, Algorithm.recvMsg]
+
+/-- If at least one process is decided on the boolean value `b` in `s` and `s'` is reachable
+from `s`, then at least one process is still decided on `b` in `s'`. -/
+theorem decided_stable {s s' : State P M S} {b : Bool}
+    (hd : s.Decided b) (hc : a.lts.CanReach s s') : s'.Decided b := by
+  obtain ⟨p, _⟩ := hd
+  use p
+  grind [procDecided_stable]
+
+/-- If `m1` and `m2` are both inflight and they have different destinations,
+then receiving them in either order produces the same end state. -/
+theorem recvMsg_comm {m1 m2 : Message P M} {s : State P M S}
+    (hd : m1.dest ≠ m2.dest) (h1 : m1 ∈ s.msgs) (h2 : m2 ∈ s.msgs) :
+    m2 ∈ (a.recvMsg m1 s).msgs ∧ m1 ∈ (a.recvMsg m2 s).msgs ∧
+    a.recvMsg m2 (a.recvMsg m1 s) = a.recvMsg m1 (a.recvMsg m2 s) := by
+  rw [State.mk.injEq]
+  split_ands
+  · grind [Algorithm.recvMsg, mem_erase_of_ne]
+  · grind [Algorithm.recvMsg, mem_erase_of_ne]
+  · have he1 (x) : (s.msgs.erase m1 + x).erase m2 = (s.msgs.erase m1).erase m2 + x := by
+      grind [erase_add_left_pos, mem_erase_of_ne]
+    have he2 (x) : (s.msgs.erase m2 + x).erase m1 = (s.msgs.erase m1).erase m2 + x := by
+      grind [erase_add_left_pos, mem_erase_of_ne, erase_comm]
+    simp [Algorithm.recvMsg, hd, hd.symm, he1, he2, add_assoc]
+    grind [add_comm]
+  · ext p
+    by_cases h_p1 : p = m1.dest <;> by_cases h_p2 : p = m2.dest <;>
+      simp [Algorithm.recvMsg, h_p1, h_p2, hd, hd.symm]
+
+/-- A diamond property for the transition relation `a.lts.Tr`. -/
+theorem tr_diamond {ps : Set P} {x1 x2 : Action P M} {s s1 s2 : State P M S}
+    (hx1 : DestIn ps x1) (hs1 : a.lts.Tr s x1 s1)
+    (hx2 : DestIn psᶜ x2) (hs2 : a.lts.Tr s x2 s2) :
+    ∃ s', a.lts.Tr s1 x2 s' ∧ a.lts.Tr s2 x1 s' := by
+  cases x1 <;> cases x2 <;> try grind [Algorithm.lts]
+  case some m1 m2 =>
+    have hd : m1.dest ≠ m2.dest := by grind [DestIn]
+    obtain ⟨h_m1, rfl⟩ := hs1
+    obtain ⟨h_m2, rfl⟩ := hs2
+    simp only [Algorithm.lts, exists_eq_right_right]
+    grind [recvMsg_comm (a := a) hd h_m1 h_m2]
+
+/-- A message that is in-flight stays in-flight as long as it is not received
+(finite execution version). -/
+theorem mTr_notRcvd_enabled {s t : State P M S} {xl : List (Action P M)} {m : Message P M}
+    (hst : a.lts.MTr s xl t) (hs : m ∈ s.msgs) (hxl : ¬ some m ∈ xl) : m ∈ t.msgs := by
+  induction hst
+  case refl _ => assumption
+  case stepL s x s1 xl t h_tr h_mtr h_ind =>
+    rcases Option.eq_none_or_eq_some x <;>
+      grind [Algorithm.lts, Algorithm.recvMsg, mem_erase_of_ne]
+
+/-- A message that is in-flight stays in-flight as long as it is not received
+(infinite execution version). -/
+theorem omega_notRcvd_enabled
+    {ss : ωSequence (State P M S)} {xs : ωSequence (Action P M)} {k : ℕ} {m : Message P M}
+    (he : a.lts.OmegaExecution ss xs) (hm : m ∈ (ss k).msgs) (hn : ∀ j, k ≤ j → xs j ≠ some m) :
+    ∀ j, k ≤ j → m ∈ (ss j).msgs := by
+  intro j h_j
+  obtain ⟨i, rfl⟩ : ∃ i, j = k + i := by use j - k; grind
+  induction i
+  case zero => grind
+  case succ i _ =>
+    rcases Option.eq_none_or_eq_some (xs (k + i)) <;>
+      grind [he (k + i), Algorithm.lts, Algorithm.recvMsg, mem_erase_of_ne]
+
+end Algorithm
+
+end Cslib.FLP
diff --git a/Cslib/Computability/Distributed/FLP/Consensus.lean b/Cslib/Computability/Distributed/FLP/Consensus.lean
new file mode 100644
index 0000000000..b7209ed905
--- /dev/null
+++ b/Cslib/Computability/Distributed/FLP/Consensus.lean
@@ -0,0 +1,144 @@
+/-
+Copyright (c) 2026 Ching-Tsun Chou. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Ching-Tsun Chou
+-/
+
+module
+
+public import Cslib.Computability.Distributed.FLP.Algorithm
+public import Mathlib.Data.Set.Card
+
+/-! # Fault-tolerant consensus
+
+Roughly speaking, a distributed consensus algorithm can tolerate `f` faults if up to `f`
+processes can be "faulty" and yet the non-faulty processes can still reach a consensus.
+The fault we consider here is limited to the crash fault, in which a process stops responding
+to messages from some point onward.  We do not consider Byzantine faults.
+-/
+
+@[expose] public section
+
+namespace Cslib.FLP
+
+open Function Set Multiset Fintype ωSequence
+
+variable {P M S : Type*}
+
+/-- A process `p` is faulty in an infinite execution iff there is a time `k` from which onward
+there is a message in-flight to `p` but `p` has stopped receiving messages. -/
+def ProcFaulty (p : P) (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : Prop :=
+  ∃ k, (∃ m, m ∈ (ss k).msgs ∧ m.dest = p) ∧ ∀ j, k ≤ j → ∀ m', xs j = some m' → m'.dest ≠ p
+
+/-- A process `p` is fair in an infinite execution iff every message in-flight to `p` is
+received by `p`. -/
+def ProcFair (p : P) (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : Prop :=
+  ∀ m, m.dest = p → ∀ k, m ∈ (ss k).msgs → ∃ j, k ≤ j ∧ xs j = some m
+
+/-- A process `p` cannot be both faulty and fair in an infinite execution.  Note, however, that
+it is possible for `p` to be neither faulty nor fair, because `p` can keep on receiving messages
+but at the same time keep ignoring some messages sent to it. -/
+theorem not_procFaulty_and_procFair (p : P)
+    (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) :
+    ¬ (ProcFaulty p ss xs ∧ ProcFair p ss xs) := by
+  grind [ProcFaulty, ProcFair]
+
+/-- An infinite execution is fair iff every process is either faulty or fair
+(cf. the comment for the theorem `not_procFaulty_and_procFair`). -/
+def FairRun (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : Prop :=
+  ∀ p, ProcFaulty p ss xs ∨ ProcFair p ss xs
+
+/-- The number of faulty processes in an infinite execution. -/
+noncomputable def numProcFaulty (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : ℕ :=
+  {p | ProcFaulty p ss xs}.ncard
+
+/-- If the number of faulty processes in an infinite execution is less than the total number
+of processes, then at least one process is not faulty. -/
+theorem not_procFaulty_of_numProcFaulty [Fintype P]
+    {ss : ωSequence (State P M S)} {xs : ωSequence (Action P M)}
+    (h : numProcFaulty ss xs < card P) : ∃ p, ¬ ProcFaulty p ss xs := by
+  let nf := {p | ProcFaulty p ss xs}ᶜ
+  have h1 : 0 < nf.ncard := by
+    rw [ncard_compl]
+    grind [numProcFaulty, card_eq_nat_card]
+  obtain ⟨p, _⟩ := (ncard_pos (s := nf)).mp h1
+  grind
+
+/-- If every process in a set `ps` is fair, then the number of faulty processes is bounded by
+the total number of processes minus the cardinality of `ps`. -/
+theorem numProcFaulty_le_not_procFair [Fintype P]
+    {ss : ωSequence (State P M S)} {xs : ωSequence (Action P M)} {ps : Set P}
+    (h : ∀ p, p ∈ ps → ProcFair p ss xs) : numProcFaulty ss xs ≤ card P - ps.ncard := by
+  rw [numProcFaulty, card_eq_nat_card, ← ncard_compl]
+  suffices h1 : {p | ProcFaulty p ss xs} ⊆ psᶜ by exact ncard_le_ncard h1
+  grind [not_procFaulty_and_procFair]
+
+variable [DecidableEq P] [DecidableEq M]
+
+/-- The notion of an infinite admissible execution for an algorithm `a` with input `inp`
+and containing at most `f` faulty processes. -/
+def Algorithm.AdmissibleRun [Fintype P] (a : Algorithm P M S) (inp : P → Bool) (f : ℕ)
+    (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : Prop :=
+  ss 0 = a.start inp ∧ a.lts.OmegaExecution ss xs ∧
+  FairRun ss xs ∧ numProcFaulty ss xs ≤ f
+
+/-- A process terminates in an infinite execution iff either it crashes or it decides on
+a boolean value at some point. -/
+def ProcTermination (p : P) (ss : ωSequence (State P M S)) (xs : ωSequence (Action P M)) : Prop :=
+  ProcFaulty p ss xs ∨ ∃ k b, (ss k).ProcDecided p b
+
+/-- An algorithm `a` terminates with up to `f` faulty processes iff all its processes terminate
+in every infinite admissible execution containing at most `f` faulty processes. -/
+def Algorithm.Termination [Fintype P] (a : Algorithm P M S) (f : ℕ) : Prop :=
+  ∀ inp ss xs, a.AdmissibleRun inp f ss xs → ∀ p, ProcTermination p ss xs
+
+/-- An algorithm `a` is a consensus algorithm tolerating up to `f` faulty processes iff
+it both satisfies the consensus safety property `a.SafeConsensus` and terminates
+with up to `f` faulty processes. -/
+def Algorithm.Consensus [Fintype P] (a : Algorithm P M S) (f : ℕ) : Prop :=
+  a.SafeConsensus ∧ a.Termination f
+
+variable {a : Algorithm P M S} {inp : P → Bool}
+
+/-- If an infinite execution is admissible with up tp `f` faulty processes,
+then it is also admissible with with up tp `f' ≥ f` faulty processes. -/
+theorem AdmissibleRun.fault_mono [Fintype P] {f f' : ℕ}
+    {xs : ωSequence (Action P M)} {ss : ωSequence (State P M S)}
+    (hle : f ≤ f') (ha : a.AdmissibleRun inp f ss xs) : a.AdmissibleRun inp f' ss xs := by
+  grind [Algorithm.AdmissibleRun]
+
+/-- If `a` is a consensus algorithm tolerating up to `f` faulty processes,
+then it is also a consensus algorithm tolerating up to `f' ≤ f` faulty processes. -/
+theorem Consensus.fault_mono [Fintype P] {f f' : ℕ}
+    (hle : f ≥ f') (hc : a.Consensus f) : a.Consensus f' := by
+  obtain ⟨h_sc, h_f⟩ := hc
+  use h_sc
+  intro inp
+  grind [h_f inp, AdmissibleRun.fault_mono]
+
+/-- If a process `p` is not fair in an infinite execution of an algorithm `a`, then there is
+a message that is in-flight to, but never received, by `p` from some point onward. -/
+theorem Algorithm.not_fair_stay_enabled
+    {ss : ωSequence (State P M S)} {xs : ωSequence (Action P M)} {p : P}
+    (he : a.lts.OmegaExecution ss xs) (hnf : ¬ ProcFair p ss xs) :
+    ∃ m, m.dest = p ∧ ∃ k, m ∈ (ss k).msgs ∧ ∀ j, k ≤ j → m ∈ (ss j).msgs ∧ (xs j) ≠ some m := by
+  simp only [ProcFair, not_forall, not_exists, not_and] at hnf
+  grind only [omega_notRcvd_enabled]
+
+/-- In an infinite execution of an algorithm `a`, a process `p` is fair iff `p` is fair in
+all suffixes of the execution. -/
+theorem Algorithm.drop_procFair_iff
+    {ss : ωSequence (State P M S)} {xs : ωSequence (Action P M)}
+    (he : a.lts.OmegaExecution ss xs) (p : P) (n : ℕ) :
+    ProcFair p (ss.drop n) (xs.drop n) ↔ ProcFair p ss xs := by
+  constructor <;> intro h
+  · by_contra h_contra
+    obtain ⟨m, h_m, k, h_k, h_ge⟩ := Algorithm.not_fair_stay_enabled he h_contra
+    have := h m h_m k
+    grind
+  · intro m h_m k h_k
+    obtain ⟨j, _, _⟩ := h m h_m (n + k) (by grind)
+    use j - n
+    grind
+
+end Cslib.FLP
diff --git a/Cslib/Computability/Distributed/FLP/README.md b/Cslib/Computability/Distributed/FLP/README.md
new file mode 100644
index 0000000000..7bc8e7bd36
--- /dev/null
+++ b/Cslib/Computability/Distributed/FLP/README.md
@@ -0,0 +1,49 @@
+# Impossibility of distributed consensus
+
+This directory contains a formalization of Völzer's proof [Volzer2004] of the famous result in
+distributed computing, first proved by Fischer, Lynch and Paterson [FLP1985], that distributed
+consensus is impossible in the presence of even a single crash fault.
+
+## Lean files
+
+1. `Algorithm.lean` defines the "syntax" of a distributed algorithm for solving the consensus problem
+   and proves some basic properties.
+
+2. `Consensus.lean` defines what it means for a distributed algorithm to solve the consensus problem
+   in a fault-tolerant way and proves some basic properties.
+
+*The following files will appear in future PRs:*
+
+3. `FairScheduler.lean` contains a technical machinery for constructing "fair executions", which is used
+    in the proof of `PseudoConsensus.of_consensus` in `PseudoConsensus.lean` and in the proof of
+    `OnePseudoConsensus.fair_nonUniform` in `Impossibility.lean`.
+
+4. `CanReachVia.lean` defines the notion of reachability via a subset of processes and proves some of
+   its properties.
+
+5. `PseudoConsensus.lean` defines the notion of a fault-tolerant "pseudo-consensus" algorithm, which
+   is central to Völzer's proof, and proves that every `f`-tolerant consensus algorithm is also a
+   `f`-tolerant pseudo-consensus algorithm.
+
+6. `OnePseudoConsensus.lean` focuses on 1-tolerant pseudo-consensus algorithms, defines the key notion
+   of "nonuniformity", and proves a number of their properties.
+
+7. `Impossibility.lean` proves that every 1-tolerant pseudo-consensus algorithms has a fair execution
+   which doesn't contain any fault but never reaches a consensus, which then implies that there cannot
+   be a consensus algorithm that can tolerate even a single fault.
+
+Files #1 and #2 contains materials common to both [FLP1985] and [Volzer2004].
+File #3 provides proof details that are either completely omitted (in the case of
+`PseudoConsensus.of_consensus`) or only hinted at (in the case of
+`OnePseudoConsensus.fair_nonUniform`) in [Volzer2004].
+The remaining files follow the development in [Volzer2004] fairly closely,
+as is explained further in each file.
+
+## References
+
+[FLP1985]
+M.J. Fischer, N.A. Lynch, M.S. Paterson, Impossibility of distributed consensus with one faulty process,
+JACM 32 (2) (April 1985) 374–382.
+
+[Volzer2004]
+H. Völzer, A constructive proof for FLP. Information Processing Letters 92(2), (October 2004) 83–87.
diff --git a/references.bib b/references.bib
index e43b1cdbeb..b2d78518f8 100644
--- a/references.bib
+++ b/references.bib
@@ -113,6 +113,24 @@ @article{         Chargueraud2012
 	file = {Full Text PDF:/home/chenson/mount/Zotero/storage/WBJWAZGI/Charguéraud - 2012 - The Locally Nameless Representation.pdf:application/pdf},
 }
 
+@article{ FLP1985,
+  author    = {Fischer, Michael J. and Lynch, Nancy A. and Paterson, Michael S.},
+  title     = {Impossibility of Distributed Consensus with One Faulty Process},
+  year      = {1985},
+  issue_date = {April 1985},
+  publisher = {Association for Computing Machinery},
+  address   = {New York, NY, USA},
+  volume    = {32},
+  number    = {2},
+  issn      = {0004-5411},
+  url       = {https://doi.org/10.1145/3149.214121},
+  doi       = {10.1145/3149.214121},
+  journal   = {J. ACM},
+  month     = {apr},
+  pages     = {374–382},
+  numpages  = {9}
+}
+
 @article{        Girard1987,
   title={Linear logic},
   author={Girard, Jean-Yves},
@@ -370,6 +388,19 @@ @book{KearnsVazirani1994
   address      = {Cambridge, MA, USA}
 }
 
+@article{ Volzer2004,
+  title     = {A constructive proof for {FLP}},
+  author    = {V{\"o}lzer, Hagen},
+  journal   = {Information Processing Letters},
+  volume    = {92},
+  number    = {2},
+  pages     = {83--87},
+  year      = {2004},
+  publisher = {Elsevier},
+  doi       = {10.1016/j.ipl.2004.06.008},
+  url       = {https://doi.org/10.1016/j.ipl.2004.06.008}
+}
+
 @incollection{WinskelNielsen1995,
   author       = {Winskel, Glynn and Nielsen, Mogens},
   isbn         = {9780198537809},

From 96134c0cbf75ff1e42275fe2859e0f0095a7c9d8 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 1 Jun 2026 13:54:36 +0200
Subject: [PATCH 090/106] v3

---
 .../Machines/RoseTreeMachine/V3/Prog.lean     | 82 +++++++++++++++++++
 1 file changed, 82 insertions(+)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
new file mode 100644
index 0000000000..30e4310fc3
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
@@ -0,0 +1,82 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Data
+public import Mathlib.Control.Fix
+public import Mathlib.Control.LawfulFix
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+def Var := ℕ
+deriving Repr
+
+inductive Prog where
+  | var (id : Var)
+  | empty
+  | cons (h t : Prog)
+  /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
+      `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
+  | elim (v em cs : Prog)
+  | ifEq (x y then_ else_ : Prog)
+  /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
+      list; `body` runs once per element with `env` extended by `[acc, x]`. -/
+  | fold (body init list : Prog)
+  /-- `while_ init body`: `init` produces the starting accumulator; `body` runs with
+      `env` extended by the current accumulator. -/
+  | while_ (init body : Prog)
+deriving Repr
+
+
+-- TODO this version uses super reduced time and space bounds. Whenever we can remove a
+-- factor, we do. Check if this is ok.
+
+abbrev set (σ : ℕ → Data) (i : ℕ) (v : Data) := Function.update σ i v
+
+/-- Semantics of Prog including time and space resource bounds.
+`ProgSem σ i p x t s` means that on environment `σ` with variable height
+`i`, the program `p` evaluates to `x` and uses `t` time and `s` space. -/
+inductive ProgSem : (ℕ → Data) → ℕ → Prog → Data → ℕ → ℕ → Prop
+  | var : ProgSem σ i (.var x) (σ x) (σ x).size (σ x).size
+  | empty : ProgSem σ i .empty (Data.l []) 1 1
+  | cons (h₁ : ProgSem σ i head hd hd_t hd_s) (h₂ : ProgSem σ i tail tl tl_t tl_s) :
+      ProgSem σ i (.cons head tail) (Data.l (hd :: tl.asList)) (hd_t + tl_t) (max hd_s tl_s)
+  | elim_nil
+      (h₁ : ProgSem σ i val (Data.l []) t_v s_v)
+      (h₂ : ProgSem σ i empty r t_em s_em) :
+      ProgSem σ i (.elim val empty _) r (t_v + em_v) (max s_v s_em)
+  | elim_cons
+      (h₁ : ProgSem σ i val (Data.l (hd :: tl)) t_v s_v)
+      (h₂ : ProgSem (set (set σ i hd) (i + 1) (Data.l tl)) (i + 2) cons r t_em s_em) :
+      -- TODO include the size of hd for time and space?
+      ProgSem σ i (.elim val _ cons) r (t_v + em_v) (max s_v s_em)
+  | ifEq_eq
+      (h_a : ProgSem σ i p_a a t_a s_a)
+      (h_b : ProgSem σ i p_b a t_b s_b)
+      (h_then : ProgSem σ i then_ r t_t s_t) :
+      ProgSem σ i (.ifEq p_a p_b then_ _) r (t_a + t_b + t_t) (max (max s_a s_b) s_t)
+  | ifEq_veq
+      (h_a : ProgSem σ i p_a a t_a s_a)
+      (h_b : ProgSem σ i p_b b t_b s_b)
+      (h_neq : a ≠ b)
+      (h_else : ProgSem σ i else_ r t_e s_e) :
+      ProgSem σ i (.ifEq p_a p_b _ else_) r (t_a + t_b + t_e) (max (max s_a s_b) s_e)
+  | fold_empty
+      (h_a : ProgSem σ i p_a a t_a s_a)
+      (h_b : ProgSem σ i p_b b t_b s_b)
+      (h_neq : a ≠ b)
+      (h_else : ProgSem σ i else_ r t_e s_e) :
+      ProgSem σ i (.fold body init list) r (t_a + t_b + t_e) (max (max s_a s_b) s_e)
+
+
+end RoseTreeMachine
+
+end Turing

From d7503979ef2fdba7181895c12f057e703134aaba Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 1 Jun 2026 17:19:48 +0200
Subject: [PATCH 091/106] work on v3

---
 .../Machines/RoseTreeMachine/V2/PB.lean       | 12 +--
 .../Machines/RoseTreeMachine/V2/Tools.lean    |  3 +
 .../Machines/RoseTreeMachine/V3/Prog.lean     | 95 +++++++++++++------
 3 files changed, 74 insertions(+), 36 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
index de50c222c5..fcbdb11cc5 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
@@ -60,15 +60,6 @@ end PB
 def PB.computes (impl : PB) (f : List Data → Data) : Prop :=
   ∀ env, (impl env.length).eval env = .some (f env)
 
--------------------------------------------------------------------
---- tools
--------------------------------------------
-
-/-- Example: `tail x` returns the tail of the list bound at variable `x`, or `empty`
-    if `x` denotes the empty list. Built with `elim`: the empty branch yields `empty`,
-    the cons branch ignores the head and projects the bound tail. -/
-def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
-def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
 
 /-! ### Per-env `PB.computes_at`
 
@@ -449,6 +440,9 @@ lemma PB.letIn_computes_at {env : List Data} {val : PB} {body : PB → PB}
   have h := (hbody ext).here
   simpa [PB.atSlot] using h
 
+def PB.tail (x : PB) : PB := PB.elim x PB.empty (fun _head tl => tl)
+def PB.head (x : PB) : PB := PB.elim x PB.empty (fun hd _tl => hd)
+
 /-- `PB.tail` at a fixed env, derived directly from `PB.elim_*_computes_at`. -/
 lemma PB.tail_computes_at {env : List Data} {x : PB} {dx : Data}
     (hx : PB.computes_at env x dx) :
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
index 54d20a85aa..b56f16a65c 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
@@ -74,6 +74,9 @@ def PB.optionElim (x : PB) (noneCase : PB) (someCase : PB → PB) : PB :=
 
 ----------------- Typed computation
 
+-- def PB.computes_encoded {α β : Type} [DataEncode α] [DataEncode β] (x : PB) (f : α → β) : Prop :=
+--     PB.computes x (fun DataEncode.encode a)
+
 def PB.computes_at_encoded {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
     PB.computes_at env x (DataEncode.encode a)
 
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
index 30e4310fc3..6a99221519 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
@@ -39,42 +39,83 @@ deriving Repr
 -- TODO this version uses super reduced time and space bounds. Whenever we can remove a
 -- factor, we do. Check if this is ok.
 
-abbrev set (σ : ℕ → Data) (i : ℕ) (v : Data) := Function.update σ i v
-
+mutual
 /-- Semantics of Prog including time and space resource bounds.
 `ProgSem σ i p x t s` means that on environment `σ` with variable height
 `i`, the program `p` evaluates to `x` and uses `t` time and `s` space. -/
-inductive ProgSem : (ℕ → Data) → ℕ → Prog → Data → ℕ → ℕ → Prop
-  | var : ProgSem σ i (.var x) (σ x) (σ x).size (σ x).size
-  | empty : ProgSem σ i .empty (Data.l []) 1 1
-  | cons (h₁ : ProgSem σ i head hd hd_t hd_s) (h₂ : ProgSem σ i tail tl tl_t tl_s) :
-      ProgSem σ i (.cons head tail) (Data.l (hd :: tl.asList)) (hd_t + tl_t) (max hd_s tl_s)
+inductive ProgSem : (List Data) → Prog → Data → ℕ → ℕ → Prop
+  | var (h : σ[(i : ℕ)]? = some v) : ProgSem σ (.var i) v v.size v.size
+  | empty : ProgSem σ .empty (Data.l []) 2 2
+  | cons (h₁ : ProgSem σ head hd hd_t hd_s) (h₂ : ProgSem σ tail tl tl_t tl_s) :
+      ProgSem σ (.cons head tail) (Data.l (hd :: tl.asList)) (hd_t + tl_t) (hd_s + tl_s)
   | elim_nil
-      (h₁ : ProgSem σ i val (Data.l []) t_v s_v)
-      (h₂ : ProgSem σ i empty r t_em s_em) :
-      ProgSem σ i (.elim val empty _) r (t_v + em_v) (max s_v s_em)
+      (h₁ : ProgSem σ val (Data.l []) t_v s_v)
+      (h₂ : ProgSem σ empty r t_em s_em) :
+      ProgSem σ (.elim val empty _) r (t_v + em_v) (max s_v s_em)
   | elim_cons
-      (h₁ : ProgSem σ i val (Data.l (hd :: tl)) t_v s_v)
-      (h₂ : ProgSem (set (set σ i hd) (i + 1) (Data.l tl)) (i + 2) cons r t_em s_em) :
+      (h₁ : ProgSem σ val (Data.l (hd :: tl)) t_v s_v)
+      (h₂ : ProgSem (σ ++ [hd, Data.l tl]) cons r t_em s_em) :
       -- TODO include the size of hd for time and space?
-      ProgSem σ i (.elim val _ cons) r (t_v + em_v) (max s_v s_em)
+      ProgSem σ (.elim val _ cons) r (t_v + em_v) (max s_v s_em)
   | ifEq_eq
-      (h_a : ProgSem σ i p_a a t_a s_a)
-      (h_b : ProgSem σ i p_b a t_b s_b)
-      (h_then : ProgSem σ i then_ r t_t s_t) :
-      ProgSem σ i (.ifEq p_a p_b then_ _) r (t_a + t_b + t_t) (max (max s_a s_b) s_t)
+      (h_a : ProgSem σ p_a a t_a s_a)
+      (h_b : ProgSem σ p_b a t_b s_b)
+      (h_then : ProgSem σ then_ r t_t s_t) :
+      ProgSem σ (.ifEq p_a p_b then_ _) r (t_a + t_b + t_t) (max (max s_a s_b) s_t)
   | ifEq_veq
-      (h_a : ProgSem σ i p_a a t_a s_a)
-      (h_b : ProgSem σ i p_b b t_b s_b)
-      (h_neq : a ≠ b)
-      (h_else : ProgSem σ i else_ r t_e s_e) :
-      ProgSem σ i (.ifEq p_a p_b _ else_) r (t_a + t_b + t_e) (max (max s_a s_b) s_e)
-  | fold_empty
-      (h_a : ProgSem σ i p_a a t_a s_a)
-      (h_b : ProgSem σ i p_b b t_b s_b)
+      (h_a : ProgSem σ p_a a t_a s_a)
+      (h_b : ProgSem σ p_b b t_b s_b)
       (h_neq : a ≠ b)
-      (h_else : ProgSem σ i else_ r t_e s_e) :
-      ProgSem σ i (.fold body init list) r (t_a + t_b + t_e) (max (max s_a s_b) s_e)
+      (h_else : ProgSem σ else_ r t_e s_e) :
+      ProgSem σ (.ifEq p_a p_b _ else_) r (t_a + t_b + t_e) (max (max s_a s_b) s_e)
+  /-- `fold body init list`: evaluate `init` to the starting accumulator and `list` to the
+      input list, then thread the accumulator through `body` over the elements via `FoldSem`. -/
+  | fold
+      (h_init : ProgSem σ init acc t_init s_init)
+      (h_list : ProgSem σ list (Data.l xs) t_list s_list)
+      (h_fold : FoldSem σ acc xs body r t_f s_f) :
+      ProgSem σ (.fold body init list) r (t_init + t_list + t_f)
+        (max (max s_init s_list) s_f)
+  /-- `while_ init body`: evaluate `init` to the starting accumulator, then iterate `body`
+      via `WhileSem` until it signals halting. -/
+  | while_
+      (h_init : ProgSem σ init acc t_init s_init)
+      (h_while : WhileSem σ acc body r t_w s_w) :
+      ProgSem σ (.while_ init body) r (t_init + t_w) (max s_init s_w)
+
+/-- Folds `body` over the remaining elements `xs`, threading the accumulator.
+`FoldSem σ acc xs body r t s` means that starting from accumulator `acc` and processing the
+elements `xs` (each step running `body` with `env` extended by `[acc, x]`) yields result `r`
+using `t` time and `s` space. -/
+inductive FoldSem : (List Data) → Data → List Data → Prog → Data → ℕ → ℕ → Prop
+  | nil : FoldSem σ acc [] body acc 0 0
+  | cons
+      (h_body : ProgSem (σ ++ [acc, x]) body acc' t_b s_b)
+      (h_rest : FoldSem σ acc' xs body r t_r s_r) :
+      FoldSem σ acc (x :: xs) body r (t_b + t_r) (max s_b s_r)
+
+/-- Iterates `body` of a `while_` loop, threading the accumulator.
+`WhileSem σ body acc r t s` means that, starting from accumulator `acc`, repeatedly running
+`body` with `env` extended by `[acc]` eventually yields result `r` using `t` time and `s` space.
+Before each iteration the halting condition is checked on the current accumulator: iteration
+terminates (with the accumulator as result) when `acc` is empty or its head is empty. Otherwise
+`body` is evaluated and its result becomes the new accumulator. Non-terminating loops simply have
+no derivation. -/
+inductive WhileSem : (List Data) → Data → Prog → Data → ℕ → ℕ → Prop
+  | halt
+      (h_stop : acc.asList.head?.getD (Data.l []) = Data.l []) :
+      WhileSem σ acc body acc acc.size acc.size
+  | step
+      (h_cont : acc.asList.head?.getD (Data.l []) ≠ Data.l [])
+      (h_body : ProgSem (σ ++ [acc]) body v t_b s_b)
+      (h_rest : WhileSem σ v body r t_r s_r) :
+      WhileSem σ acc body r (t_b + t_r) (max s_b s_r)
+end
+
+/-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/
+def ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop :=
+  ProgSem [x] p y t s
+
 
 
 end RoseTreeMachine

From 15b9d99bfaf415e017e532e9cdf86397672d9ec6 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 1 Jun 2026 20:43:53 +0200
Subject: [PATCH 092/106] progress

---
 Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
index 6a99221519..7ed49b7921 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
@@ -44,19 +44,21 @@ mutual
 `ProgSem σ i p x t s` means that on environment `σ` with variable height
 `i`, the program `p` evaluates to `x` and uses `t` time and `s` space. -/
 inductive ProgSem : (List Data) → Prog → Data → ℕ → ℕ → Prop
-  | var (h : σ[(i : ℕ)]? = some v) : ProgSem σ (.var i) v v.size v.size
+  | var :
+      ProgSem σ (.var (i : ℕ)) (σ[i]?.getD (Data.l []))
+        (σ[i]?.getD (Data.l [])).size (σ[i]?.getD (Data.l [])).size
   | empty : ProgSem σ .empty (Data.l []) 2 2
   | cons (h₁ : ProgSem σ head hd hd_t hd_s) (h₂ : ProgSem σ tail tl tl_t tl_s) :
       ProgSem σ (.cons head tail) (Data.l (hd :: tl.asList)) (hd_t + tl_t) (hd_s + tl_s)
   | elim_nil
       (h₁ : ProgSem σ val (Data.l []) t_v s_v)
       (h₂ : ProgSem σ empty r t_em s_em) :
-      ProgSem σ (.elim val empty _) r (t_v + em_v) (max s_v s_em)
+      ProgSem σ (.elim val empty _) r (t_v + t_em) (max s_v s_em)
   | elim_cons
       (h₁ : ProgSem σ val (Data.l (hd :: tl)) t_v s_v)
       (h₂ : ProgSem (σ ++ [hd, Data.l tl]) cons r t_em s_em) :
       -- TODO include the size of hd for time and space?
-      ProgSem σ (.elim val _ cons) r (t_v + em_v) (max s_v s_em)
+      ProgSem σ (.elim val _ cons) r (t_v + t_em) (max s_v s_em)
   | ifEq_eq
       (h_a : ProgSem σ p_a a t_a s_a)
       (h_b : ProgSem σ p_b a t_b s_b)

From 9d9a87c02e12ba143ebc1594a82ef0de936c1d01 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 1 Jun 2026 23:02:09 +0200
Subject: [PATCH 093/106] progress

---
 .../Machines/RoseTreeMachine/V3/Data.lean     |  110 ++
 .../RoseTreeMachine/V3/DataEncode.lean        |   99 ++
 .../Machines/RoseTreeMachine/V3/PB.lean       |  280 ++++
 .../Machines/RoseTreeMachine/V3/Tools.lean    |  193 +++
 .../RoseTreeMachine/V3/UniversalTM.lean       | 1144 +++++++++++++++++
 5 files changed, 1826 insertions(+)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/Data.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/DataEncode.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Data.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Data.lean
new file mode 100644
index 0000000000..4c032f8941
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Data.lean
@@ -0,0 +1,110 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.Data.Part
+
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-- ================= Data structure
+
+
+
+-- Rose-tree data structure, it allows us to
+-- 1. map most of Lean's data structures in a "natural" manner
+-- 2. define a "fold" operation
+inductive Data where
+  | l : List Data → Data
+deriving Repr
+
+mutual
+  def Data.decEq : ∀ (a b : Data), Decidable (a = b)
+    | .l xs, .l ys =>
+      match Data.listDecEq xs ys with
+      | isTrue h => isTrue (congrArg Data.l h)
+      | isFalse h => isFalse fun heq => h (Data.l.inj heq)
+  def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys)
+    | [], [] => isTrue rfl
+    | [], _ :: _ => isFalse (by simp)
+    | _ :: _, [] => isFalse (by simp)
+    | x :: xs, y :: ys =>
+      match Data.decEq x y, Data.listDecEq xs ys with
+      | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys)
+      | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1
+      | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2
+end
+
+instance : DecidableEq Data := Data.decEq
+instance : BEq Data := inferInstance
+instance : LawfulBEq Data := inferInstance
+
+abbrev Data.empty := Data.l []
+
+
+@[grind =]
+def Data.asList
+  | Data.l xs => xs
+
+@[simp]
+lemma Data.asList_empty : Data.empty.asList = [] := by rfl
+
+@[simp, grind =]
+lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind
+
+@[simp, grind =]
+lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList]
+
+--- Encoding length of d.
+def Data.size : Data → ℕ
+  | Data.l xs => 2 + (xs.map Data.size |>.sum)
+
+@[simp, grind =]
+lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size]
+
+@[simp, grind =]
+lemma Data.cons_size {h : Data} {t : List Data} :
+    (Data.l (h :: t)).size = h.size + (Data.l t).size := by
+  simp [Data.size]
+  grind
+
+/-- Recursion principle for `Data` that exposes the list-of-children structure:
+    a `motive` is built from the empty case and a cons case that combines the
+    motive on the head child and on the tail list (viewed as a `Data`).
+    Lean's auto-generated `Data.rec` for the nested inductive only iterates once
+    through `List.rec`, leaving the recursive call on children to the user;
+    `Data.recL` performs both recursions and is the natural elimination principle
+    for definitions/proofs that need both IHs. -/
+@[elab_as_elim]
+def Data.recL {motive : Data → Sort*}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) :
+    ∀ d, motive d
+  | .l [] => nil
+  | .l (x :: xs) =>
+      cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs))
+
+/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/
+@[elab_as_elim]
+theorem Data.inductionL {motive : Data → Prop}
+    (nil : motive (Data.l []))
+    (cons : ∀ (x : Data) (xs : List Data),
+      motive x → motive (Data.l xs) → motive (Data.l (x :: xs)))
+    (d : Data) : motive d :=
+  Data.recL nil cons d
+
+abbrev TapeIndex := ℕ
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/DataEncode.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/DataEncode.lean
new file mode 100644
index 0000000000..dd16a325d4
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/DataEncode.lean
@@ -0,0 +1,99 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Data
+public import Mathlib.Data.Nat.Bits
+public import Mathlib.Data.List.Basic
+
+/-! # RoseTreeMachine V3 — DataEncode
+
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-------------------------------------
+--- Encoding of generic types into Data
+--------------------------------------
+
+class DataEncode (α : Type) where
+  encode : α → Data
+  h_inj : encode.Injective
+
+instance : DataEncode Bool where
+  encode b := if b then Data.l [ Data.l [] ] else Data.l []
+  h_inj := by intros a b h_eq; grind
+
+instance (α : Type) [DataEncode α] : DataEncode (List α) where
+  encode xs := Data.l (xs.map DataEncode.encode)
+  h_inj := by
+    intro a b h
+    have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode :=
+      Data.l.inj h
+    exact List.map_injective_iff.mpr DataEncode.h_inj h'
+
+@[simp, grind =]
+lemma DataEncode_list_nil {α : Type} [DataEncode α] :
+  DataEncode.encode ([] : List α) = Data.l [] := by
+  simp [DataEncode.encode]
+
+@[simp, grind =]
+lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) :
+  DataEncode.encode xs = Data.empty ↔ xs = [] := by
+  simp [DataEncode.encode]
+
+@[simp, scoped grind =]
+lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) :
+  (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by
+  simp [DataEncode.encode]
+
+instance (α : Type) [DataEncode α] : DataEncode (Option α) where
+  encode := fun
+    | none => Data.l []
+    | some x => Data.l [DataEncode.encode x]
+  h_inj := by
+    intro a b h
+    cases a <;> cases b <;> simp_all
+    exact DataEncode.h_inj h
+
+@[simp]
+lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) :
+  (DataEncode.encode x == Data.empty) = x.isNone := by
+  cases x <;> simp [DataEncode.encode, Data.empty]
+
+instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where
+  encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b]
+  h_inj := by
+    intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h
+    simp at h
+    exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩
+
+lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) :
+  DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by
+  simp [DataEncode.encode]
+
+instance : DataEncode ℕ where
+  encode x := DataEncode.encode (Nat.bits x)
+  h_inj := by
+    intro a b h
+    have hb : a.bits = b.bits := DataEncode.h_inj h
+    -- Reconstruct a from a.bits via binaryRec.
+    have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by
+      intro n
+      induction n using Nat.binaryRec' with
+      | zero => simp
+      | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih]
+    have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb
+    simpa [hrec] using this
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
new file mode 100644
index 0000000000..59fe394cb4
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
@@ -0,0 +1,280 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+
+/-! # RoseTreeMachine V2 — PB
+
+Part of the RoseTreeMachine V2 development; see
+`Cslib/Computability/Machines/RoseTreeMachine/V2.lean` for an overview.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+/-- A program builder: given the current binder depth (i.e. the size of `env`
+at the point of insertion), produce a `Prog`. -/
+abbrev PB := ℕ → Prog
+
+namespace PB
+
+/-- Reference the variable at (absolute) de Bruijn level `i`. -/
+def var (i : ℕ) : PB := fun _ => .var i
+def empty : PB := fun _ => .empty
+def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
+def ifEq (a b then_ else_ : PB) : PB := fun n => .ifEq (a n) (b n) (then_ n) (else_ n)
+def elim (v em : PB) (cs : PB → PB → PB) : PB := fun n =>
+  .elim (v n) (em n) (cs (var n) (var (n + 1)) (n + 2))
+def fold (body : PB → PB → PB) (init list : PB) : PB := fun n =>
+  .fold (body (var n) (var (n + 1)) (n + 2)) (init n) (list n)
+def while_ (init : PB) (body : PB → PB) : PB := fun n =>
+  .while_ (init n) (body (var n) (n + 1))
+
+/-- Close a builder into a concrete `Prog`. -/
+def build (p : PB) : Prog := p 0
+
+
+end PB
+
+/-! ### Resource-erased (`ProgSem`-based) semantics for program builders
+
+`PB.computes env impl out` says that, under any outer extension `ext`, the builder
+unfolded at the current variable depth `(env ++ ext).length` evaluates (via `ProgSem`) to
+`out` for *some* time and space. Time and space bounds are intentionally ignored here; only
+the returned value is tracked. The `∀ ext` quantifier lets a builder be plugged into a
+binder body where the environment later grows. -/
+
+/-- Resource-erased relational semantics of a program builder. -/
+def PB.computes (env : List Data) (impl : PB) (out : Data) : Prop :=
+  ∀ ext : List Data,
+    ∃ t s, ProgSem (env ++ ext) (impl (env.length + ext.length)) out t s
+
+def PB.computes_enc {α : Type} [DataEncode α] (env : List Data) (x : PB) (a : α) : Prop :=
+    PB.computes env x (DataEncode.encode a)
+
+/-- The basic per-env consequence, instantiating `ext := []`. -/
+lemma PB.computes.here {env : List Data} {impl : PB} {out : Data}
+    (h : PB.computes env impl out) :
+    ∃ t s, ProgSem env (impl env.length) out t s := by
+  simpa using h []
+
+@[simp]
+lemma PB.computes.extend {env ext : List Data} {impl : PB} {d : Data}
+    (h : PB.computes env impl d) :
+    PB.computes (env ++ ext) impl d := by
+  intro ext'
+  simpa [List.append_assoc, Nat.add_assoc] using (h (ext ++ ext'))
+
+/-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/
+@[simp, grind .]
+lemma PB.var_computes {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes env (PB.var i) env[i] := by
+  intro ext
+  refine ⟨env[i].size, env[i].size, ?_⟩
+  simp only [PB.var]
+  have hval : (env ++ ext)[i]?.getD (Data.l []) = env[i] := by
+    rw [List.getElem?_append_left h, List.getElem?_eq_getElem h]
+    rfl
+  rw [← hval]
+  exact ProgSem.var
+
+@[simp, grind .]
+lemma PB.empty_computes {env : List Data} :
+    PB.computes env PB.empty (Data.l []) := by
+  intro ext
+  exact ⟨2, 2, ProgSem.empty⟩
+
+@[simp, grind .]
+lemma PB.cons_computes {env : List Data} {h t : PB} {dh dt : Data}
+    (hh : PB.computes env h dh) (ht : PB.computes env t dt) :
+    PB.computes env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
+  intro ext
+  obtain ⟨th, sh, hh'⟩ := hh ext
+  obtain ⟨tt, st, ht'⟩ := ht ext
+  exact ⟨_, _, ProgSem.cons hh' ht'⟩
+
+/-- The code in `body` computes a function of one argument and returns `out`. -/
+@[simp, grind .]
+def PB.computesFun₁ (env : List Data) (x : Data) (body : PB → PB) (out : Data) : Prop :=
+  ∀ ext : List Data, ∃ t s, ProgSem
+    (env ++ ext ++ [x])
+    (body (PB.var (env.length + ext.length))
+    (env.length + ext.length + 1))
+    out
+    t
+    s
+
+/-- The code in `body` computes a function of two arguments `x`, `y` and returns `out`. -/
+@[simp, grind .]
+def PB.computesFun₂ (env : List Data) (x y : Data) (body : PB → PB → PB) (out : Data) : Prop :=
+  ∀ ext : List Data, ∃ t s, ProgSem
+    (env ++ ext ++ [x, y])
+    (body (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))
+      (env.length + ext.length + 2))
+    out
+    t
+    s
+
+/-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`.
+This is the additive lookup used to discharge HOAS branch bodies (see `PB.elim_cons_computes`):
+the `j`-th binding introduced after `env ++ ext` sits at level `(env ++ ext).length + j`. -/
+@[simp]
+lemma PB.var_computesFun {env binds : List Data} {j : ℕ} (ext : List Data) :
+    ∃ t s,
+      ProgSem (env ++ ext ++ binds) (.var (env.length + ext.length + j))
+        (binds[j]?.getD (Data.l [])) t s := by
+  refine ⟨(binds[j]?.getD (Data.l [])).size, (binds[j]?.getD (Data.l [])).size, ?_⟩
+  have hval : (env ++ ext ++ binds)[env.length + ext.length + j]?.getD (Data.l [])
+      = binds[j]?.getD (Data.l []) := by
+    have e1 : env.length + ext.length + j = (env ++ ext).length + j := by
+      simp only [List.length_append]
+    rw [e1, List.getElem?_append_right (Nat.le_add_right _ _), Nat.add_sub_cancel_left]
+  rw [← hval]
+  exact ProgSem.var
+
+/-- Specialisation of `PB.var_computesFun` to the first freshly-bound variable (`j = 0`):
+a `PB.var` at the absolute level `(env ++ ext).length` reads `binds[0]`. -/
+@[simp]
+lemma PB.var_computesFun_zero {env binds : List Data} (ext : List Data) :
+    ∃ t s,
+      ProgSem (env ++ ext ++ binds) (.var (env.length + ext.length))
+        (binds[0]?.getD (Data.l [])) t s := by
+  simpa using PB.var_computesFun (j := 0) ext
+
+/-- `elim`, nil branch: `v` computes `[]`, so the empty branch `em` runs. -/
+@[simp, grind .]
+lemma PB.elim_nil_computes {env : List Data} {v em : PB} {cs : PB → PB → PB} {out : Data}
+    (hv : PB.computes env v (Data.l []))
+    (hem : PB.computes env em out) :
+    PB.computes env (PB.elim v em cs) out := by
+  intro ext
+  obtain ⟨tv, sv, hv'⟩ := hv ext
+  obtain ⟨tem, sem, hem'⟩ := hem ext
+  simp only [PB.elim]
+  exact ⟨_, _, ProgSem.elim_nil hv' hem'⟩
+
+/-- `elim`, cons branch: `v` computes `head :: tail`, so the body `cs` runs on the env
+extended with `[head, Data.l tail]`. -/
+@[simp, grind .]
+lemma PB.elim_cons_computes {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {head : Data} {tail : List Data} {out : Data}
+    (hv : PB.computes env v (Data.l (head :: tail)))
+    (hcs : PB.computesFun₂ env head (Data.l tail) cs out) :
+    PB.computes env (PB.elim v em cs) out := by
+  intro ext
+  obtain ⟨tv, sv, hv'⟩ := hv ext
+  obtain ⟨tr, sr, hb⟩ := hcs ext
+  simp only [PB.elim]
+  have hb' : ProgSem (env ++ ext ++ [head, Data.l tail])
+      (cs (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))
+        (env.length + ext.length + 2)) out tr sr := by
+    simpa using hb
+  exact ⟨_, _, ProgSem.elim_cons hv' hb'⟩
+
+------------------- Resource Consumption -------------------------
+
+-- TODO these are harder to use now because we don't know that the RHS of the
+-- relation is unique.
+
+def PB.outputsOSize (impl : PB) (s : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env : List Data, ∃ out,
+    PB.computes env impl out ∧ out.size ≤ a * (s env) + b
+
+def PB.usesOTime (impl : PB) (t : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env, ∃ out s, ∃ t' ≤ a * (t env) + b,
+    ProgSem env (impl env.length) out t' s
+
+def PB.usesOSpace (impl : PB) (s : List Data → ℕ) : Prop :=
+  ∃ a b, ∀ env, ∃ out t, ∃ s' ≤ a * (s env) + b,
+    ProgSem env (impl env.length) out t s'
+
+@[simp]
+def PB.usesLinearTimeAndSpace (impl : PB) : Prop :=
+  PB.usesOTime impl (fun env => (Data.l env).size) ∧
+  PB.usesOSpace impl (fun env => (Data.l env).size)
+
+
+
+@[simp, grind .]
+lemma PB.var_usesOTime {i : ℕ} :
+    PB.usesOTime (PB.var i) 1 := by
+  use 1, 0
+  intro ext
+  sorry
+
+@[simp, grind .]
+lemma PB.var_usesLinearTimeAndSpace {i : ℕ} :
+    PB.usesLinearTimeAndSpace (PB.var i) := by
+  sorry
+
+
+
+@[simp, grind .]
+lemma PB.empty_outputsOSize : PB.outputsOSize PB.empty (fun _ => 1) := by
+  use 2, 0
+  intro env
+  refine ⟨Data.l [], by simp, by simp⟩
+
+@[simp, grind .]
+lemma PB.empty_usesOTime : PB.usesOTime PB.empty 1 := by
+  use 2, 0
+  intro env
+  use Data.l [], 2, 2
+  simpa using ProgSem.empty
+
+@[simp, grind .]
+lemma PB.empty_usesOSpace : PB.usesOSpace PB.empty 1 := by
+  use 2, 0
+  intro env
+  use Data.l [], 2, 2
+  simpa using ProgSem.empty
+
+@[simp, grind .]
+lemma PB.empty_usesLinearTimeAndSpace : PB.usesLinearTimeAndSpace PB.empty := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_outputsOSize {h t : PB} {s_h s_t : List Data → ℕ}
+    (hh : PB.outputsOSize h s_h) (ht : PB.outputsOSize t s_t) :
+    PB.outputsOSize (PB.cons h t) (s_h + s_t) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_usesOTime {h t : PB} {t_h t_t : List Data → ℕ}
+    (hh : PB.usesOTime h t_h) (ht : PB.usesOTime t t_t) :
+    PB.usesOTime (PB.cons h t) (t_h + t_t) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_usesOSpace {h t : PB} {s_h s_t : List Data → ℕ}
+    (hh : PB.usesOSpace h s_h) (ht : PB.usesOSpace t s_t) :
+    PB.usesOSpace (PB.cons h t) (fun env => max (s_h env) (s_t env)) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.cons_preserves_linearity {h t : PB}
+    (hh : PB.usesLinearTimeAndSpace h) (ht : PB.usesLinearTimeAndSpace t) :
+    PB.usesLinearTimeAndSpace (PB.cons h t) := by
+  sorry
+
+@[simp, grind .]
+lemma PB.elim_preserves_linearity {v em : PB} {cs : PB → PB → PB}
+    (hv : PB.usesLinearTimeAndSpace v) (hem : PB.usesLinearTimeAndSpace em)
+    -- TODO is this correct?
+    (hcs : ∀ i j, PB.usesLinearTimeAndSpace (cs (PB.var i) (PB.var j))) :
+    PB.usesLinearTimeAndSpace (PB.elim v em cs) := by
+  sorry
+
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
new file mode 100644
index 0000000000..46f267ae0e
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
@@ -0,0 +1,193 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.PB
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+/-- Program that evaluates to the constant `a`. -/
+def constant (a : Data) : PB := match a with
+  | Data.l [] => .empty
+  | Data.l (x :: xs) => .cons (constant x) (constant (Data.l xs))
+
+@[simp]
+lemma constant_computes {n : ℕ} {env : List Data} {a : Data} :
+    ProgSem env (constant a n) a a.size a.size := by
+  induction a using Data.inductionL with
+  | nil => simp [constant, PB.empty, ProgSem.empty]
+  | cons x xs ihx ihxs =>
+    simpa [constant] using ProgSem.cons ihx ihxs
+
+def encConst {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a)
+
+
+/-- Returns the tail of a list-valued builder. -/
+def PB.tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl)
+
+/-- Returns the head of a list-valued builder (`Data.l []` when empty). -/
+def PB.head (x : PB) : PB := .elim x .empty (fun hd _tl => hd)
+
+lemma PB.tail_computes {env : List Data} {x : PB} {dx : Data} (hx : PB.computes env x dx) :
+    PB.computes env (.tail x) (Data.l dx.asList.tail) := by
+  obtain ⟨dx⟩ := dx
+  cases dx with
+  | nil => grind [PB.tail]
+  | cons hd tl =>
+    refine PB.elim_cons_computes hx ?_
+    intro ext
+    simpa using PB.var_computesFun ext
+
+lemma PB.head_computes {env : List Data} {x : PB} {dx : Data}
+    (hx : PB.computes env x dx) :
+    PB.computes env (PB.head x) (dx.asList.headD (Data.l [])) := by
+  obtain ⟨dx⟩ := dx
+  cases dx with
+  | nil => grind [PB.head]
+  | cons hd tl =>
+    refine PB.elim_cons_computes hx ?_
+    intro ext
+    simpa using PB.var_computesFun_zero _
+
+def PB.fst (x : PB) : PB := PB.head x
+
+/-- Compute `fun x => x.snd`. -/
+def PB.snd (x : PB) : PB := PB.head (PB.tail x)
+
+/-- Compute `fun x => Option.some x`. -/
+def PB.some (x : PB) : PB := PB.cons x PB.empty
+
+def PB.optionElim (x noneCase : PB) (someCase : PB → PB) : PB :=
+  PB.elim x noneCase (fun x _ => someCase x)
+
+----------------- Typed computation
+
+-- @[simp]
+-- lemma PB.atSlot_last_computes_enc {α : Type} [DataEncode α]
+--     {env ext : List Data} {a : α} :
+--     PB.computes_enc (env ++ ext ++ [DataEncode.encode a])
+--       (PB.atSlot (env.length + ext.length)) a :=
+--   PB.atSlot_last_computes_at
+
+-- @[simp]
+-- lemma PB.atSlot_last_computes_enc_right {α : Type} [DataEncode α]
+--     {env ext : List Data} {a : α} :
+--     PB.computes_enc (env ++ (ext ++ [DataEncode.encode a]))
+--       (PB.atSlot (env.length + ext.length)) a :=
+--   PB.atSlot_last_computes_at_right
+
+-- /-- Encoded body-of-binder hypothesis: the body computes a typed value `a`
+-- under any outer env extension. -/
+-- abbrev PB.computes_at_body_encoded {α : Type} [DataEncode α]
+--     (env : List Data) (bindings : List Data)
+--     (mkBody : (Fin bindings.length → PB) → PB) (a : α) : Prop :=
+--   PB.computes_at_body env bindings mkBody (DataEncode.encode a)
+
+-- abbrev PB.computes_at_body₁_encoded {α β : Type} [DataEncode α] [DataEncode β]
+--     (env : List Data) (a : α) (body : PB → PB) (b : β) : Prop :=
+--   PB.computes_at_body₁ env (DataEncode.encode a) body (DataEncode.encode b)
+
+-- abbrev PB.computes_at_body₂_encoded {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ]
+--     (env : List Data) (a : α) (b : β) (body : PB → PB → PB) (c : γ) : Prop :=
+--   PB.computes_at_body₂ env (DataEncode.encode a) (DataEncode.encode b) body (DataEncode.encode c)
+
+lemma PB.fst_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_enc env x a) :
+    PB.computes_enc env (PB.fst x) a.fst := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes hx
+
+lemma PB.snd_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {a : α × β}
+    (hx : PB.computes_enc env x a) :
+    PB.computes_enc env (PB.snd x) a.snd := by
+  obtain ⟨a, b⟩ := a
+  simpa [Data.asList] using PB.head_computes (PB.tail_computes hx)
+
+lemma PB.some_computes_enc {α : Type} [DataEncode α]
+    {env : List Data} {x : PB} {a : α}
+    (hx : PB.computes_enc env x a) :
+    PB.computes_enc env (PB.some x) (Option.some a) := by
+  simpa using PB.cons_computes hx PB.empty_computes
+
+lemma PB.optionElim_computes_none {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x noneCase : PB} {someCase : PB → PB}
+    (hx : x.computes_enc env (none : Option α))
+    {a : β}
+    (h_none : noneCase.computes_enc env a) :
+    (PB.optionElim x noneCase someCase).computes_enc env a := by
+  apply PB.elim_nil_computes hx h_none
+
+/-- `some`-branch of `PB.optionElim`. Since `some a = Data.l [encode a]`, eliminating it binds the
+contained value `encode a` together with the (empty) list tail `Data.l []`, so the obligation is a
+`computesFun₂` whose second binding is the unused empty tail. -/
+lemma PB.optionElim_computes_some {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {x : PB} {noneCase : PB} {someCase : PB → PB}
+    {a : α}
+    (hx : x.computes_enc env (Option.some a))
+    {b : β}
+    (h_some : PB.computesFun₂ env (DataEncode.encode a) (Data.l []) (fun v _ => someCase v)
+      (DataEncode.encode b)) :
+    (PB.optionElim x noneCase someCase).computes_enc env b := by
+  exact PB.elim_cons_computes hx h_some
+
+/-- Build a `FoldSem` over an encoded list: starting from accumulator `a`, threading `f` through
+the elements of `l`, given that the (already depth-instantiated) `body` realises one step
+`acc, el ↦ f acc el` under the environment extended by the two encoded bindings `[encode acc,
+encode el]`. -/
+lemma PB.foldSem_encode {α β : Type} [DataEncode α] [DataEncode β]
+    {σ : List Data} {body : Prog} {f : α → β → α}
+    (hbody : ∀ acc el, ∃ t s,
+      ProgSem (σ ++ [DataEncode.encode acc, DataEncode.encode el]) body
+        (DataEncode.encode (f acc el)) t s) :
+    ∀ (a : α) (l : List β), ∃ t s,
+      FoldSem σ (DataEncode.encode a) (l.map DataEncode.encode) body
+        (DataEncode.encode (l.foldl f a)) t s := by
+  intro a l
+  induction l generalizing a with
+  | nil => exact ⟨0, 0, FoldSem.nil⟩
+  | cons x xs ih =>
+    obtain ⟨tb, sb, hb⟩ := hbody a x
+    obtain ⟨tr, sr, hr⟩ := ih (f a x)
+    exact ⟨_, _, FoldSem.cons hb hr⟩
+
+/-- Typed `fold`: with `init` computing the accumulator `a`, `list` computing the elements `l`, and
+`body` realising one step of `f` over its two bindings, `PB.fold body init list` computes
+`l.foldl f a`. -/
+lemma PB.fold_computes_enc
+    {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {init list : PB} {body : PB → PB → PB}
+    {a : α} {l : List β} {f : α → β → α}
+    (hi : init.computes_enc env a)
+    (hl : list.computes_enc env l)
+    (hbody : ∀ acc el, PB.computesFun₂ env (DataEncode.encode acc) (DataEncode.encode el) body
+        (DataEncode.encode (f acc el))) :
+    PB.computes_enc env (PB.fold body init list) (l.foldl f a) := by
+  intro ext
+  obtain ⟨ti, si, hinit⟩ := hi ext
+  obtain ⟨tl, sl, hlist⟩ := hl ext
+  have hlist' : ProgSem (env ++ ext) (list (env.length + ext.length))
+      (Data.l (l.map DataEncode.encode)) tl sl := hlist
+  obtain ⟨tf, sf, hf⟩ :=
+    PB.foldSem_encode (σ := env ++ ext) (f := f)
+      (body := body (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))
+        (env.length + ext.length + 2))
+      (fun acc el => hbody acc el ext) a l
+  simp only [PB.fold]
+  exact ⟨_, _, ProgSem.fold hinit hlist' hf⟩
+
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
new file mode 100644
index 0000000000..92c076b096
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
@@ -0,0 +1,1144 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Tools
+public import Cslib.Computability.Machines.SingleTapeTuring.Basic
+public import Mathlib.Data.List.ReduceOption
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+-- TODO Working on the resource bounds now.
+-- The proof outline should be:
+-- each iteration of the loop causes the accumulator to grow by at most a constant.
+-- this can actually be shown from the semantics and the proof that the tape size grows by at
+-- most a constant.
+-- then, we show that the time and space of each iteration is linear in its input.
+-- so overall, t iterations are computed in O(t^2) time and O(t) space.
+
+variable [DataEncode Symbol]
+
+public instance : DataEncode (Turing.StackTape Symbol) where
+  encode t := DataEncode.encode t.toList
+  h_inj := by
+    intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h
+    grind [DataEncode.h_inj h]
+
+public instance : DataEncode (Turing.BiTape Symbol) where
+  encode t := DataEncode.encode (t.head, t.left, t.right)
+  h_inj := by
+    intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
+    grind [DataEncode.h_inj h]
+
+lemma encode_biTape (t : Turing.BiTape Symbol) :
+    DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
+    simp [DataEncode.encode]
+
+def bitape_write (t v : PB) : PB := PB.cons v t.tail
+
+lemma bitape_write_computes
+    {env : List Data} {p_t p_v : PB} {t : BiTape Symbol} {v : Option Symbol}
+    (h_t : PB.computes_enc env p_t t)
+    (h_v : PB.computes_enc env p_v v) :
+    PB.computes_enc env (bitape_write p_t p_v) (t.write v) := by
+  simp only [PB.computes_enc, encode_biTape, DataEncode_pair] at h_t h_v ⊢
+  apply PB.cons_computes h_v (PB.tail_computes h_t)
+
+@[simp, grind .]
+lemma bitape_usesLinearTimeAndSpace
+    {p_t p_v : PB}
+    (h_t : PB.usesLinearTimeAndSpace p_t)
+    (h_v : PB.usesLinearTimeAndSpace p_v) :
+    (bitape_write p_t p_v).usesLinearTimeAndSpace := by
+  unfold bitape_write PB.tail
+  grind
+
+-- /-- Prepend an `Option` to the `StackTape` -/
+-- @[scoped grind]
+-- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol :=
+--   match x, xs with
+--   | none, ⟨[], _⟩ => ⟨[], by grind⟩
+--   | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩
+--   | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩
+
+def stackTape_cons (x st : PB) : PB :=
+  PB.optionElim x
+    (PB.elim st
+      PB.empty
+      (fun _ _ => PB.cons x st))
+    (fun _ => PB.cons x st)
+
+lemma stackTape_cons_computes
+    {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
+    (h_x : PB.computes_enc env p_x x)
+    (h_st : PB.computes_enc env p_st st) :
+    (stackTape_cons p_x p_st).computes_enc env (st.cons x) := by
+  cases x with
+  | none =>
+    apply PB.optionElim_computes_none h_x
+    obtain ⟨l, hl⟩ := st
+    cases l with
+    | nil =>
+      simpa [DataEncode.encode] using
+        PB.elim_nil_computes (by simpa using h_st) (PB.empty_computes)
+    | cons hd tl =>
+      apply PB.elim_cons_computes (by simpa [DataEncode.encode] using h_st)
+      intro ext
+      simpa using (PB.cons_computes h_x h_st).extend
+  | some a =>
+    apply PB.optionElim_computes_some h_x
+    intro ext
+    simpa using (PB.cons_computes (by simpa [DataEncode.encode] using h_x) h_st).extend
+
+def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
+
+lemma to_pair_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p_a p_b : PB}
+    {a : α} {b : β}
+    (h_a : p_a.computes_enc env a)
+    (h_b : p_b.computes_enc env b) :
+    (to_pair p_a p_b).computes_enc env (a, b) := by
+  simpa [DataEncode.encode, to_pair] using
+    PB.cons_computes h_a (PB.cons_computes h_b PB.empty_computes)
+
+--- The head component of the bitape
+def bitape_head (t : PB) : PB := t.fst
+--- The left component of the bitape
+def bitape_left (t : PB) : PB := t.snd.fst
+--- The right component of the bitape
+def bitape_right (t : PB) : PB := t.snd.snd
+
+lemma bitape_head_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_enc env p_t t) :
+    (bitape_head p_t).computes_enc env t.head := PB.head_computes h_t
+
+lemma bitape_left_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_enc env p_t t) :
+    (bitape_left p_t).computes_enc env t.left :=
+  PB.head_computes (PB.head_computes (PB.tail_computes h_t))
+
+lemma bitape_right_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_enc env p_t t) :
+    (bitape_right p_t).computes_enc env t.right :=
+  PB.head_computes (PB.tail_computes (PB.head_computes (PB.tail_computes h_t)))
+
+lemma encode_stackTape_head (st : StackTape Symbol) :
+    (DataEncode.encode st).asList.headD (Data.l []) = DataEncode.encode st.head := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.head, Data.asList]
+
+lemma encode_stackTape_tail (st : StackTape Symbol) :
+    Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by
+  obtain ⟨l, hl⟩ := st
+  cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList]
+
+lemma stackTape_head_computes_enc {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_enc env p_st st) :
+    (p_st.head).computes_enc env st.head := by
+  unfold PB.computes_enc
+  simpa [← encode_stackTape_head] using PB.head_computes h_st
+
+lemma stackTape_tail_computes_enc {env : List Data} {p_st : PB} {st : StackTape Symbol}
+    (h_st : PB.computes_enc env p_st st) :
+    (p_st.tail).computes_enc env st.tail := by
+  unfold PB.computes_enc
+  simpa [← encode_stackTape_tail] using PB.tail_computes h_st
+
+-- def move_left (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
+
+def bitape_move_left (t : PB) : PB :=
+  to_pair (bitape_left t).head
+    (to_pair
+      (bitape_left t).tail
+      (stackTape_cons (bitape_head t) (bitape_right t)))
+
+lemma bitape_move_left_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_enc env p_t t) :
+    PB.computes_enc env (bitape_move_left p_t) t.move_left := by
+  unfold PB.computes_enc
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_enc (bitape_left_computes h_t))
+    (to_pair_computes
+      (stackTape_tail_computes_enc (bitape_left_computes h_t))
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
+
+lemma bitape_move_left_uses_linear_time_and_space
+    {p_t : PB} (h_t : PB.usesLinearTimeAndSpace p_t) :
+    (bitape_move_left p_t).usesLinearTimeAndSpace := by
+  simp [h_t, bitape_move_left, to_pair, bitape_left, PB.fst, PB.snd, PB.tail, PB.head, stackTape_cons, bitape_head, bitape_right]
+  apply PB.cons_preserves_linearity
+  · apply PB.elim_preserves_linearity'
+    · apply PB.elim_preserves_linearity'
+      · grind --refine PB.elim_preserves_linearity' (by grind) (by grind) (by grind)
+      · grind
+      · grind
+    · grind
+    · sorry
+  · sorry
+
+-- def move_right (t : BiTape Symbol) : BiTape Symbol :=
+--   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
+
+def bitape_move_right (t : PB) : PB :=
+  to_pair (bitape_right t).head
+    (to_pair
+      (stackTape_cons (bitape_head t) (bitape_left t))
+      (bitape_right t).tail)
+
+lemma bitape_move_right_computes
+    {env : List Data} {p_t : PB} {t : BiTape Symbol}
+    (h_t : PB.computes_enc env p_t t) :
+    PB.computes_enc env (bitape_move_right p_t) t.move_right := by
+  unfold PB.computes_enc
+  rw [encode_biTape]
+  exact to_pair_computes
+    (stackTape_head_computes_enc (bitape_right_computes h_t))
+    (to_pair_computes
+      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_left_computes h_t))
+      (stackTape_tail_computes_enc (bitape_right_computes h_t)))
+
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => DataEncode.encode true
+    | Dir.right => DataEncode.encode false
+  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
+
+-- /--
+-- Move the head to the left or right, shifting the tape underneath it.
+-- -/
+-- def move (t : BiTape Symbol) : Dir → BiTape Symbol
+--   | .left => t.move_left
+--   | .right => t.move_right
+
+def bitape_move (tape dir : PB) : PB :=
+  PB.ifEq dir (constant (DataEncode.encode Dir.left))
+    (bitape_move_left tape)
+    (bitape_move_right tape)
+
+lemma bitape_move_computes {env : List Data} {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir}
+    (h_t : PB.computes_enc env p_t t)
+    (h_dir : PB.computes_enc env p_dir d) :
+    (bitape_move p_t p_dir).computes_enc env (t.move d) := by
+  unfold PB.computes_enc bitape_move
+  refine PB.ifEq_computes h_dir constant_computes ?_ ?_
+  · intro hd_eq
+    -- TODO could use injectivity here once we have it.
+    cases d with
+    | left => exact bitape_move_left_computes h_t
+    | right =>
+      exfalso
+      exact absurd hd_eq (by decide)
+  · intro hne
+    cases d with
+    | left => exact absurd rfl hne
+    | right => exact bitape_move_right_computes h_t
+
+-- /--
+-- Optionally perform a `move`, or do nothing if `none`.
+-- -/
+-- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
+--   | t, none => t
+--   | t, some d => t.move d
+
+def bitape_optionMove (t dir : PB) : PB :=
+  PB.optionElim dir
+    t
+    (fun d => bitape_move t d)
+
+lemma bitape_optionMove_computes {env : List Data} {p_t p_dir : PB}
+    {t : BiTape Symbol} {d : Option Dir}
+    (h_t : PB.computes_enc env p_t t)
+    (h_dir : PB.computes_enc env p_dir d) :
+    (bitape_optionMove p_t p_dir).computes_enc env (t.optionMove d) := by
+  unfold PB.computes_enc bitape_optionMove BiTape.optionMove
+  match d with
+  | none => simpa using PB.optionElim_computes_none h_dir h_t
+  | some d =>
+    apply PB.optionElim_computes_some h_dir
+    intro ext
+    exact bitape_move_computes (by simpa using h_t.extend) (by simp)
+
+instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] :
+    DataEncode (Turing.SingleTapeTM.Cfg tm) where
+  encode cfg := DataEncode.encode (cfg.state, cfg.BiTape)
+  h_inj := by
+    intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, ht⟩ := heq
+    cases hs; cases ht; rfl
+
+-- Evaluate a function `f` at `arg` where the function is given as a graph.
+-- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise.
+def eval_fun_graph (graph : PB) (arg : PB) : PB :=
+  PB.fold
+    (fun acc x =>
+      PB.optionElim acc
+        (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
+        fun _ => acc)
+    PB.empty graph
+
+/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of
+`(α × β)`-pairs) and an encoded argument `a : α`, returns
+`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)`
+in the graph, else `none`. -/
+lemma eval_fun_graph_computes
+    {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α]
+    {env : List Data} {p_graph p_arg : PB}
+    {graph : List (α × β)} {a : α}
+    (h_graph : p_graph.computes_enc env graph)
+    (h_arg : p_arg.computes_enc env a) :
+    (eval_fun_graph p_graph p_arg).computes_enc env
+      ((graph.find? (fun p => p.1 = a)).map (·.2)) := by
+  -- The Lean-level step function for the fold.
+  let step : Option β → α × β → Option β :=
+    fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc)
+  -- Once the accumulator is `some _`, it stays `some _`.
+  have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by
+    intro l b
+    induction l with
+    | nil => simp
+    | cons hd tl ih => simp [step, ih]
+  -- `foldl step none` matches `find?`-then-`map snd`.
+  have key : ∀ l : List (α × β),
+      l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by
+    intro l
+    induction l with
+    | nil => simp
+    | cons hd tl ih =>
+      simp only [List.foldl_cons, List.find?_cons]
+      by_cases h : hd.1 = a
+      · simp [step, h, stays]
+      · simp [step, h, ih]
+  rw [show (graph.find? (fun p => p.1 = a)).map (·.2)
+        = graph.foldl step none from (key graph).symm]
+  unfold eval_fun_graph
+  refine PB.fold_computes_enc (a := (none : Option β)) (f := step)
+    (by simp [PB.computes_enc, DataEncode.encode]) h_graph ?_
+  intro acc x ext
+  rcases acc with _ | v
+  · -- acc = none: step none x = if x.1 = a then some x.2 else none
+    refine PB.optionElim_computes_none (α := β)
+      PB.elim_cons_head_var_computes ?_
+    refine PB.ifEq_computes
+      (PB.fst_computes_enc PB.elim_cons_tail_var_computes)
+      (by simpa using h_arg.extend) ?_ ?_
+    · intro h_enc
+      have h_eq : x.1 = a := DataEncode.h_inj h_enc
+      change PB.computes_enc _ _ (step none x)
+      simp only [step, Option.elim_none, if_pos h_eq]
+      exact PB.some_computes_enc
+        (PB.snd_computes_enc PB.elim_cons_tail_var_computes)
+    · intro h_enc
+      have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h])
+      simp [DataEncode.encode, step, h_ne]
+  · -- acc = some v: step (some v) x = some v
+    refine PB.optionElim_computes_some (α := β)
+      (PB.elim_cons_head_var_computes
+        (head := DataEncode.encode (some v : Option β))) ?_
+    intro ext'
+    simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes.extend
+
+-- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) :=
+--   Fintype.elems.toList.map (fun a => (a, f a))
+
+lemma eval_fun_graph_computes_of_fun
+    {α β : Type} [DataEncode α] [DataEncode β] [Fintype α]
+    {env : List Data} {p_graph p_arg : PB}
+    {a : α}
+    {f : α → β}
+    (h_graph : p_graph.computes_enc env (Fintype.elems.toList.map (fun a => (a, f a))))
+    (h_arg : p_arg.computes_enc env a) :
+    (eval_fun_graph p_graph p_arg).head.computes_enc env (f a) := by
+  classical
+  have heq : ∀ (L : List α), a ∈ L →
+      ((L.map (fun a' => (a', f a'))).find?
+        (fun p => p.1 = a)).map (·.2) = some (f a) := by
+    intro L hmem
+    induction L with
+    | nil => exact absurd hmem (by simp)
+    | cons hd tl ih => grind
+  have h := eval_fun_graph_computes h_graph h_arg
+  rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h
+  simpa [DataEncode.encode, Data.asList] using PB.head_computes h
+
+def cfg_state (cfg : PB) : PB := cfg.fst
+def cfg_bitape (cfg : PB) : PB := cfg.snd
+
+lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_enc env cfg) :
+    (cfg_state p).computes_enc env cfg.state :=
+  PB.fst_computes_enc (a := (cfg.state, cfg.BiTape)) h
+
+lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm}
+    (h : p.computes_enc env cfg) :
+    (cfg_bitape p).computes_enc env cfg.BiTape :=
+  PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h
+
+/-- Evaluate the transition function. Returns `((wr, dir), q')`.
+ -- The return value is not wrapped inside an `Option` because the transition
+ -- function is assumed to be total. -/
+def eval_tr (tr : PB) (q c : PB) : PB :=
+  (eval_fun_graph (eval_fun_graph tr q).head c).head
+
+instance : DataEncode (SingleTapeTM.Stmt Symbol) where
+  encode stmt := DataEncode.encode (stmt.symbol, stmt.movement)
+  h_inj := by
+    intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp at heq
+    obtain ⟨hs, hm⟩ := heq
+    cases hs; cases hm; rfl
+
+lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State]
+    [DecidableEq State] [Fintype Symbol]
+    {env : List Data} {p_tr p_q p_c : PB}
+    {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State}
+    {q : State}
+    {c : Option Symbol}
+    (h_tr : p_tr.computes_enc env
+      ((Fintype.elems : Finset State).toList.map (fun q' : State =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' : Option Symbol => (c', tr q' c'))))))
+    (h_q : p_q.computes_enc env q)
+    (h_c : p_c.computes_enc env c) :
+    (eval_tr p_tr p_q p_c).computes_enc env (tr q c) := by
+  unfold eval_tr
+  exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q)
+    (eval_fun_graph_computes_of_fun (α := State) (f := fun q' =>
+      (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c')))
+      h_tr h_q) h_c
+
+-- /-- The step function corresponding to a `SingleTapeTM`. -/
+-- @[simp]
+-- def step : tm.Cfg → Option tm.Cfg
+--   | ⟨none, _⟩ =>
+--     -- If in the halting state, there is no next configuration
+--     none
+--   | ⟨some q', t⟩ =>
+--     -- If in state q', perform look up in the transition function
+--     match tm.tr q' t.head with
+--     -- and enter a new configuration with state q'' (or none for halting)
+--     -- and tape updated according to the Stmt
+--     | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩
+
+-- Compute the step function given a transition function (as its graph) and a configuration.
+-- Returns `Option Cfg`
+def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
+  PB.optionElim (cfg_state cfg)
+    PB.empty
+    (fun q' => PB.letIn (cfg_bitape cfg) (fun tape =>
+      PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
+        .some (to_pair
+          tr_val.snd
+          (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
+
+-- TODO for space and time bounds, we need to prove for singleTapeTM_step, than:
+-- for any `env`,
+-- 1) the size of the output is the size of `env` plus a constant (not with a linear factor!)
+-- 2) the time and space required is linear in the size of `env`.
+-- the problematic bits are that we don't know what `tr` and `cfg` do, they are programs,
+-- we cannot just look at their outputs
+-- What is the right condition for `tr` and `cfg`?
+
+lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_enc env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_enc env cfg) :
+    (singleTapeTM_step p_tr p_cfg).computes_enc env (tm.step cfg) := by
+  unfold singleTapeTM_step
+  obtain ⟨state, t⟩ := cfg
+  match hst : state with
+  | none =>
+    refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_
+    change PB.empty.computes_enc env (none : Option tm.Cfg)
+    simp [PB.computes_enc, DataEncode.encode]
+  | some q' =>
+    refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_
+    intro ext1
+    -- TODO letin makes this proof complicated.
+    -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`.
+    apply PB.letIn_computes_enc (v := t)
+      (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend)
+    intro ext2
+    set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def
+    -- The slot for `q'` at depth `env.length + ext1.length`.
+    have h_q'_slot : PB.computes_enc
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env.length + ext1.length)) q' := by
+      simpa [env2_def] using PB.atSlot_last_computes_enc.extend
+    -- The slot for `tape` at depth `env2.length + ext2.length`.
+    have h_tape_slot : PB.computes_enc
+        (env2 ++ ext2 ++ [DataEncode.encode t])
+        (PB.atSlot (env2.length + ext2.length)) t :=
+      PB.atSlot_last_computes_enc
+    apply PB.letIn_computes_enc
+      (eval_tr_computes
+        (by simpa [env2_def, List.append_assoc] using h_tr.extend)
+        h_q'_slot (bitape_head_computes h_tape_slot))
+    intro ext3
+    set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def
+    set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def
+    -- Re-derive tape slot at envS.
+    have h_tape_slot' : PB.computes_enc envS
+        (PB.atSlot (env2.length + ext2.length)) t := by
+      simpa [envS_def, env3_def, List.append_assoc] using
+        h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)])
+    -- Destructure the transition result.
+    rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩
+    have h_trval : PB.computes_enc envS
+        (PB.atSlot (env3.length + ext3.length))
+        (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by
+      simp [envS_def, htr_eq]
+    unfold SingleTapeTM.step
+    simp only [htr_eq]
+    exact PB.some_computes_enc
+      (to_pair_computes
+        (PB.snd_computes_enc h_trval)
+        (bitape_optionMove_computes
+          (bitape_write_computes h_tape_slot'
+            (PB.fst_computes_enc (a := (wr, dir))
+              (PB.fst_computes_enc h_trval)))
+          (PB.snd_computes_enc (a := (wr, dir))
+            (PB.fst_computes_enc h_trval))))
+
+def tm_main_loop (tr : PB) (cfg : PB) : PB :=
+  -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step`
+  -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep
+  -- the current `acc` (which has `state = none`, signalling halt to `while_`).
+  PB.while_ cfg
+    (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
+
+/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/
+private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr : PB}
+    (h_tr : p_tr.computes_enc env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (c : tm.Cfg) :
+    PB.computes_at_body₁ env (DataEncode.encode c)
+      (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+      (DataEncode.encode ((tm.step c).getD c)) := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  intro ext
+  set E := env ++ ext with E_def
+  have hE_len : E.length = env.length + ext.length := by simp [E_def]
+  have h_acc : PB.computes_enc (E ++ [DataEncode.encode c])
+      (PB.atSlot E.length) c := by
+    simpa using PB.atSlot_last_computes_enc (env := E) (ext := []) (a := c)
+  have h_step_eval :
+      (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_enc
+        (E ++ [DataEncode.encode c]) (tm.step c) := by
+    have h_tr_ext : PB.computes_enc (E ++ [DataEncode.encode c]) p_tr
+        ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))) := by
+      have := h_tr.extend (ext := ext ++ [DataEncode.encode c])
+      simpa [E_def, List.append_assoc] using this
+    exact singleTapeTM_step_computes h_tr_ext h_acc
+  change PB.computes_at (E ++ [DataEncode.encode c])
+    (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length)))
+      (PB.atSlot (env.length + ext.length))
+      (fun next => next)) (DataEncode.encode (step c))
+  rw [← hE_len]
+  cases hstep_c : tm.step c with
+  | none =>
+    rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl]
+    exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc
+  | some next =>
+    rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl]
+    refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_
+    intro ext'
+    simpa using PB.atSlot_last_computes_enc
+      (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next)
+
+/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from
+`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none`
+state), the loop computes the configuration obtained after the *minimal* such
+number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the
+halt result `none` as a fixed point via `Option.getD`. -/
+lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg}
+    (h_tr : p_tr.computes_enc env
+      ((Fintype.elems : Finset tm.State).toList.map (fun q' =>
+        (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+          (fun c' => (c', tm.tr q' c'))))))
+    (h_cfg : p_cfg.computes_enc env cfg)
+    (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) :
+    (tm_main_loop p_tr p_cfg).computes_enc env
+      ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by
+  -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def
+  -- `headD` of an encoded `Cfg` is empty iff the state is `none`.
+  have headD_iff : ∀ c : tm.Cfg,
+      (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+    rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+  -- Translate the halting hypothesis through the iff.
+  have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] :=
+    h_halts.imp fun _ h => (headD_iff _).mpr h
+  have find_eq : Nat.find h_halts' = Nat.find h_halts :=
+    le_antisymm
+      (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts)))
+      (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts')))
+  -- Reduce to a `while_` spec call.
+  change PB.computes_at env (tm_main_loop p_tr p_cfg)
+    (DataEncode.encode (step^[Nat.find h_halts] cfg))
+  rw [← find_eq]
+  unfold tm_main_loop
+  exact PB.while_computes_iter (env := env) (p_init := p_cfg)
+    (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next))
+    step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts'
+
+def reverse (x : PB) : PB :=
+  PB.fold (fun acc el => PB.cons el acc) PB.empty x
+
+lemma reverse_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_enc env l) :
+    (reverse p).computes_enc env l.reverse := by
+  unfold reverse
+  have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp
+  rw [h_fold]
+  apply PB.fold_computes_enc (by simp [PB.computes_enc]) h
+  -- TODO at this point, we should actually be able to just apply a combinator on the semantics
+  -- of PB.cons
+  intro acc el ext
+  have h_el : PB.computes_at
+      (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+      (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by
+    simpa using (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend
+  simpa [DataEncode.encode, Data.asList] using
+    PB.cons_computes h_el (by simpa using PB.atSlot_last_computes.extend)
+
+def list_map (x : PB) (f : PB → PB) : PB :=
+  reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x)
+
+lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β]
+    {env : List Data} {p : PB} {l : List α}
+    {f : PB → PB} {g : α → β}
+    (h : p.computes_enc env l)
+    (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) :
+    (list_map p f).computes_enc env (l.map g) := by
+  unfold list_map
+  -- TODO simplify proof
+  have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_enc
+      env (l.foldl (fun acc el => g el :: acc) []) := by
+    apply PB.fold_computes_enc (a := ([] : List β)) (f := fun acc el => g el :: acc)
+      (by simp [PB.computes_enc, DataEncode.encode]) h
+    intro acc el ext
+    have h_acc : PB.computes_at
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el])
+        (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+      simpa using (PB.atSlot_last_computes (env := env) (ext := ext)
+        (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_enc
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by
+      simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc])
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_fel h_acc
+  have h_rev := reverse_computes h_fold
+  have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by
+    rw [show l.foldl (fun acc el => g el :: acc) []
+          = (l.map g).foldl (fun acc el => el :: acc) [] from
+        (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm]
+    simp
+  rwa [h_eq] at h_rev
+
+/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/
+def list_reduceOption (x : PB) : PB :=
+  reverse (PB.fold
+    (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc))
+    PB.empty x)
+
+lemma list_reduceOption_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List (Option α)}
+    (h : p.computes_enc env l) :
+    (list_reduceOption p).computes_enc env l.reduceOption := by
+  unfold list_reduceOption
+  set step : List α → Option α → List α :=
+    fun acc el => match el with | none => acc | some y => y :: acc with step_def
+  -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need
+  -- this generalized over the initial accumulator so the induction goes through.
+  have h_eq : ∀ (xs : List (Option α)) (init : List α),
+      (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by
+    intro xs
+    induction xs with
+    | nil => intro init; simp [List.reduceOption]
+    | cons hd tl ih =>
+      intro init
+      cases hd with
+      | none => simpa [step_def] using ih init
+      | some y =>
+        have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by
+          simp [step_def]
+        rw [h1, ih (y :: init)]
+        simp [List.reduceOption]
+  have h_fold : (PB.fold
+        (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p
+      ).computes_enc env (l.foldl step []) := by
+    apply PB.fold_computes_enc
+      (a := ([] : List α)) (f := step)
+      (by simp [PB.computes_enc, DataEncode.encode]) h
+    intro acc el ext
+    have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_enc
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by
+      simpa [PB.computes_enc] using
+        (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend
+    have h_acc : (PB.atSlot (env.length + ext.length)).computes_enc
+        (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by
+      simpa [PB.computes_enc] using
+        (PB.atSlot_last_computes (env := env) (ext := ext)
+          (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el])
+    cases el with
+    | none =>
+      simpa [step_def] using
+        PB.optionElim_computes_none (α := α) h_el h_acc
+    | some y =>
+      refine PB.optionElim_computes_some (α := α) h_el ?_
+      intro ext'
+      -- Inside someCase, the bound `y` lives at slot
+      -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`.
+      set ext_inner :=
+        ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def
+      have hlen : ext_inner.length = ext.length + 2 + ext'.length := by
+        simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm]
+      have h_y :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length + 2 + ext'.length))
+            (DataEncode.encode y) := by
+        have h := PB.atSlot_last_computes
+          (env := env) (ext := ext_inner) (d := DataEncode.encode y)
+        rw [hlen] at h
+        convert h using 2
+        omega
+      have h_acc' :
+          PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y])
+            (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by
+        have h := (h_acc :
+          PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)])
+            _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y])
+        simpa [ext_inner_def, List.append_assoc] using h
+      have h_cons := PB.cons_computes h_y h_acc'
+      simp only [ext_inner_def] at h_cons
+      simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons
+  have h_rev := reverse_computes h_fold
+  have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l []
+  rwa [h_eq₀] at h_rev
+
+def list_head_option (input : PB) : PB :=
+  PB.elim input PB.empty (fun hd _tl => PB.some hd)
+
+lemma list_head_option_computes {α : Type} [DataEncode α]
+    {env : List Data} {p : PB} {l : List α}
+    (h : p.computes_enc env l) :
+    (list_head_option p).computes_enc env l.head? := by
+  cases l with
+  | nil =>
+    apply PB.elim_nil_computes (em := PB.empty)
+    · simpa [DataEncode.encode] using h
+    · simp [DataEncode.encode]
+  | cons hd tl =>
+    apply PB.elim_cons_computes (head := DataEncode.encode hd)
+      (tail := tl.map DataEncode.encode)
+    · simpa [DataEncode.encode] using h
+    · intro ext
+      simpa [DataEncode.encode] using
+        PB.cons_computes PB.elim_cons_head_var_computes PB.empty_computes
+
+def string_to_tape (input : PB) : PB :=
+  to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some))
+
+lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_enc env input) :
+    (string_to_tape p_input).computes_enc env (BiTape.mk₁ input) := by
+  have h_tail : (PB.tail p_input).computes_enc env input.tail := by
+    simpa [PB.computes_enc, DataEncode.encode] using PB.tail_computes h_input
+  have h_map : (list_map (PB.tail p_input) PB.some).computes_enc env
+      (StackTape.map_some input.tail : Turing.StackTape Symbol) := by
+    simpa [PB.computes_enc, DataEncode.encode]
+      using list_map_computes h_tail (fun _ _ => by
+        simpa [DataEncode.encode] using
+          PB.cons_computes PB.atSlot_last_computes PB.empty_computes)
+  have h_empty : (PB.empty : PB).computes_enc env (∅ : Turing.StackTape Symbol) := by
+    simp [PB.computes_enc, DataEncode.encode]
+  simpa [PB.computes_enc, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape]
+    using to_pair_computes (list_head_option_computes h_input)
+      (to_pair_computes h_empty h_map)
+
+
+def initial_config (q₀ : PB) (input : PB) : PB :=
+  to_pair (PB.some q₀) (string_to_tape input)
+
+/-- Turn the final config to an output, by taking the head and the right part of the tape
+    and discarding the blank (`none`) cells. -/
+def final_config_to_output (cfg : PB) : PB :=
+  list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))
+
+/-- Implements a universal Single-Tape TM, assuming that the input contains the following:
+((initialState, transitionFunction), input).
+If it terminates, the output is the tape contents under the head and to its right. -/
+def universal_tm (input : PB) :=
+  final_config_to_output
+    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd))
+
+lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_q₀ p_input : PB} {input : List Symbol}
+    (h_q₀ : p_q₀.computes_enc env tm.q₀)
+    (h_input : p_input.computes_enc env input) :
+    (initial_config p_q₀ p_input).computes_enc env (tm.initCfg input) := by
+  -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes
+  -- through the `(state, BiTape)` pair, so this matches `to_pair`.
+  exact to_pair_computes (PB.some_computes_enc h_q₀) (string_to_tape_computes h_input)
+
+lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State]
+    {env : List Data} {p_cfg : PB} {cfg : tm.Cfg}
+    (h_cfg : p_cfg.computes_enc env cfg) :
+    (final_config_to_output p_cfg).computes_enc env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by
+  unfold final_config_to_output
+  have h_BiTape : (p_cfg.snd).computes_enc env cfg.BiTape :=
+    PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h_cfg
+  have h_head := bitape_head_computes h_BiTape
+  have h_right := bitape_right_computes h_BiTape
+  -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`),
+  -- then `list_reduceOption` discards the blanks.
+  have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_enc env
+      (cfg.BiTape.head :: cfg.BiTape.right.toList) := by
+    change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList))
+    simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_head h_right
+  exact list_reduceOption_computes h_list
+
+lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {input : List Symbol}
+    (h_input : p_input.computes_enc env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       input))
+    (h_halts : ∃ n,
+        ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) :
+    (universal_tm p_input).computes_enc env
+      (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input)
+       (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by
+  unfold universal_tm
+  have h_fst := PB.fst_computes_enc h_input
+  have h_q₀ := PB.fst_computes_enc h_fst
+  have h_tr := PB.snd_computes_enc h_fst
+  have h_inp := PB.snd_computes_enc h_input
+  exact final_config_to_output_computes
+    (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts)
+
+/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding
+blanks) recovers `l`. -/
+private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) :
+    ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by
+  have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by
+    induction xs with
+    | nil => rfl
+    | cons _ _ ih => simp [ih]
+  cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h]
+
+/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`,
+then the universal Turing machine `universal_tm`, when given an encoding of `tm`
+together with `w`, computes `w'`.
+
+The encoded input has the shape `((tm.q₀, transitionTable), w)`, where
+`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/
+theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_enc env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : tm.Outputs w w') :
+    (universal_tm p_input).computes_enc env w' := by
+  -- Lift `tm.step` to a total step function; halting states are fixed points.
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  -- Convert `ReflTransGen` into an explicit step count via tail-induction.
+  obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by
+    suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' →
+        ∃ n, step^[n] c = c' from h h_out
+    intro c c' hrel
+    induction hrel with
+    | refl => exact ⟨0, rfl⟩
+    | tail _ h' ih =>
+      obtain ⟨n, hn⟩ := ih
+      refine ⟨n + 1, ?_⟩
+      rw [Function.iterate_succ_apply', hn]
+      change (tm.step _).getD _ = _
+      rw [h']
+      rfl
+  -- The halting hypothesis required by `universal_tm_computes`.
+  have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩
+  -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`.
+  have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl)
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter
+    exact h_iter.symm
+  -- Conclude via `universal_tm_computes`.
+  have h := universal_tm_computes (tm := tm) h_input h_halts
+  rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+    tm.haltCfg w' from h_find] at h
+  simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h
+
+/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded
+output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/
+private lemma universal_tm_eval_some_imp_loop_eval_some
+    {p_input : PB} {env : List Data} {d : Data}
+    (h : (universal_tm p_input env.length).eval env = .some d) :
+    ∃ d', (tm_main_loop p_input.fst.snd
+      (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by
+  -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is
+  -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is
+  -- `.some`, the bound subexpression must be `.some` too.
+  set n := env.length with hn
+  set mloop : Prog := tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd) n with mloop_def
+  -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do.
+  have bd_cons : ∀ {a b : Prog} {env d},
+      (Prog.cons a b).eval env = .some d →
+      (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by
+    intro a b env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does.
+  have bd_elim : ∀ {v em cs : Prog} {env d},
+      (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by
+    intro v em cs env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm
+    refine ⟨ah, ?_⟩
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+  -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init`
+  -- and `list` do.
+  have bd_fold : ∀ {body init list : Prog} {env d},
+      (Prog.fold body init list).eval env = .some d →
+      (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by
+    intro body init list env d h
+    rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h
+    obtain ⟨⟨d', _, _⟩, hm, _⟩ := h
+    unfold Prog.meteredEval at hm
+    simp only [bind, Part.mem_bind_iff] at hm
+    obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm
+    obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest
+    refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩
+    · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩
+  -- Now unfold `universal_tm = final_config_to_output (...)`,
+  -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`,
+  -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`.
+  -- At each step we bubble down through the relevant `Prog` constructor.
+  -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost
+  -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through
+  -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s)
+  -- to extract a `some` evaluation for `mloop`.
+  change (final_config_to_output (tm_main_loop p_input.fst.snd
+    (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h
+  unfold final_config_to_output list_reduceOption reverse at h
+  -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain)
+  obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h
+  obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1
+  -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2
+  -- where mloop' = tm_main_loop ...
+  change (Prog.cons _ _).eval env = .some d2 at h2
+  obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2
+  -- h3 : bitape_head (...).snd evaluates to some
+  -- bitape_head t = t.fst = head t = elim t empty (fun ...)
+  -- bitape_head (mloop').snd = head (head (tail mloop'))
+  change (Prog.elim _ _ _).eval env = .some d3 at h3
+  obtain ⟨d4, h4⟩ := bd_elim h3
+  -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _).
+  change (Prog.elim _ _ _).eval env = .some d4 at h4
+  obtain ⟨d5, h5⟩ := bd_elim h4
+  -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl).
+  change (Prog.elim _ _ _).eval env = .some d5 at h5
+  obtain ⟨d6, h6⟩ := bd_elim h5
+  -- h6 : mloop' n .eval env = some d6. Done.
+  exact ⟨d6, h6⟩
+
+/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to
+a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`,
+then there exists an iteration index `n` such that the TM is in a halt state and
+the tape contents under the head (with blanks discarded) equal `w'`. -/
+theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol]
+    [DecidableEq Symbol] {tm : SingleTapeTM Symbol}
+    [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_enc env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w))
+    (h_out : (universal_tm p_input).computes_enc env w') :
+    ∃ n : ℕ,
+      let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+      cfg.state = none ∧
+      (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep
+  by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none
+  · -- Halts: use forward direction to identify the output.
+    refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩
+    have h_fwd := universal_tm_computes (tm := tm) h_input h_halts
+    -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`;
+    -- since `Part.eval` is functional, the encoded values must agree, then apply
+    -- injectivity of `DataEncode.encode`.
+    have h1 := h_fwd []
+    have h2 := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2
+    rw [h1] at h2
+    have h_eq := Part.some_inj.mp (by exact_mod_cast h2)
+    exact DataEncode.h_inj h_eq
+  · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`.
+    exfalso
+    have h_eval := h_out []
+    simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval
+    obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval
+    -- Project `h_input` to get individual components.
+    have h_q₀ := PB.fst_computes_enc (PB.fst_computes_enc h_input)
+    have h_tr := PB.snd_computes_enc (PB.fst_computes_enc h_input)
+    have h_inp := PB.snd_computes_enc h_input
+    -- Initial config evaluates to `encode (tm.initCfg w)`.
+    have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env
+        = .some (DataEncode.encode (tm.initCfg w)) := by
+      have := (initial_config_computes h_q₀ h_inp) []
+      simpa using this
+    -- Unfold tm_main_loop = PB.while_ init body.
+    set body_pb : PB → PB :=
+      fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc
+        (fun next => next) with body_pb_def
+    change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env
+      = .some d at h_loop
+    set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def
+    change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env
+      = .some d at h_loop
+    rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop
+    -- Extract the trajectory.
+    obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ :=
+      Prog.whileFrom_eval_some h_loop
+    -- The body computes `step` at every config.
+    have h_body_eval : ∀ c : tm.Cfg,
+        bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by
+      intro c
+      have h := (tm_main_loop_body_computes h_tr c (ext := [])).here
+      simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h
+    -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`.
+    have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by
+      intro k hk
+      induction k with
+      | zero => simpa using h_traj0
+      | succ k ih =>
+        have hkm : k < m := hk
+        have ih' := ih (Nat.le_of_lt hkm)
+        have h_step_k := (h_steps k hkm).2
+        rw [ih', h_body_eval] at h_step_k
+        have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) :=
+          (Part.some_inj.mp h_step_k).symm
+        rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from
+          (Function.iterate_succ_apply' step k _).symm]
+    -- Halt condition at `m` gives `state = none`.
+    have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl
+    rw [← h_trajm, h_at_m] at h_halt_at_m
+    have headD_iff : ∀ c : tm.Cfg,
+        (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by
+      rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList]
+    exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩
+
+/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches
+a halted configuration whose tape content (head followed by the right stack, with
+blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization
+of `universal_tm`. -/
+private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
+    (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop :=
+  ∃ n : ℕ,
+    let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w)
+    cfg.state = none ∧
+    (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w'
+
+private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol]
+    {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State]
+    {env : List Data} {p_input : PB} {w w' : List Symbol}
+    (h_input : p_input.computes_enc env
+      ((tm.q₀,
+        (Fintype.elems : Finset tm.State).toList.map (fun q' =>
+          (q', (Fintype.elems : Finset (Option Symbol)).toList.map
+            (fun c' => (c', tm.tr q' c'))))),
+       w)) :
+    Outputs' tm w w' ↔ (universal_tm p_input).computes_enc env w' := by
+  set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def
+  have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by
+    rintro ⟨_, _⟩ rfl; rfl
+  have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by
+    intro k _ hc
+    induction k with
+    | zero => rfl
+    | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc]
+  refine ⟨?_, ?_⟩
+  · -- Forward: `Outputs' tm w w' → universal_tm computes w'`.
+    rintro ⟨n, h_halt_n, h_eq⟩
+    have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩
+    have h := universal_tm_computes (tm := tm) h_input h_halts
+    -- Stationarity: any later iterate of a halted config equals it.
+    have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n
+    have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts)
+    rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter
+    rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) =
+      (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h
+    exact h
+  · -- Converse: directly from `universal_tm_simulates_converse`.
+    intro h_out
+    exact universal_tm_simulates_converse h_input h_out
+
+
+end RoseTreeMachine
+
+end Turing

From 89278385ee43b7a5260304b5bc95dda2e214a282 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 1 Jun 2026 23:24:08 +0200
Subject: [PATCH 094/106] progress

---
 .../Machines/RoseTreeMachine/V3/PB.lean       |  8 ++++++++
 .../RoseTreeMachine/V3/UniversalTM.lean       | 19 +++++++++++--------
 2 files changed, 19 insertions(+), 8 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
index 59fe394cb4..21bf6444a9 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
@@ -124,6 +124,14 @@ def PB.computesFun₂ (env : List Data) (x y : Data) (body : PB → PB → PB) (
     t
     s
 
+/-- A body that ignores its two freshly-bound arguments satisfies `computesFun₂` as soon as the
+underlying program computes `out`: the two extra bindings are just an environment extension. -/
+lemma PB.computesFun₂_const {env : List Data} {x y : Data} {impl : PB} {out : Data}
+    (h : PB.computes env impl out) :
+    PB.computesFun₂ env x y (fun _ _ => impl) out := by
+  intro ext
+  simpa [List.append_assoc, Nat.add_assoc] using h (ext ++ [x, y])
+
 /-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`.
 This is the additive lookup used to discharge HOAS branch bodies (see `PB.elim_cons_computes`):
 the `j`-th binding introduced after `env ++ ext` sits at level `(env ++ ext).length + j`. -/
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
index 92c076b096..1f3a8b0691 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
@@ -91,12 +91,12 @@ lemma stackTape_cons_computes
         PB.elim_nil_computes (by simpa using h_st) (PB.empty_computes)
     | cons hd tl =>
       apply PB.elim_cons_computes (by simpa [DataEncode.encode] using h_st)
-      intro ext
-      simpa using (PB.cons_computes h_x h_st).extend
+      simpa [DataEncode.encode, StackTape.cons] using
+        PB.computesFun₂_const (PB.cons_computes h_x h_st)
   | some a =>
     apply PB.optionElim_computes_some h_x
-    intro ext
-    simpa using (PB.cons_computes (by simpa [DataEncode.encode] using h_x) h_st).extend
+    simpa [DataEncode.encode, StackTape.cons] using
+      PB.computesFun₂_const (PB.cons_computes (by simpa [DataEncode.encode] using h_x) h_st)
 
 def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
 
@@ -178,14 +178,17 @@ lemma bitape_move_left_uses_linear_time_and_space
     (bitape_move_left p_t).usesLinearTimeAndSpace := by
   simp [h_t, bitape_move_left, to_pair, bitape_left, PB.fst, PB.snd, PB.tail, PB.head, stackTape_cons, bitape_head, bitape_right]
   apply PB.cons_preserves_linearity
-  · apply PB.elim_preserves_linearity'
-    · apply PB.elim_preserves_linearity'
-      · grind --refine PB.elim_preserves_linearity' (by grind) (by grind) (by grind)
+  · apply PB.elim_preserves_linearity
+    · apply PB.elim_preserves_linearity
+      · refine PB.elim_preserves_linearity (by grind) (by grind) (by grind)
       · grind
       · grind
     · grind
+    · grind
+  · refine PB.cons_preserves_linearity ?_ (by grind)
+    refine PB.cons_preserves_linearity ?_ ?_
+    · sorry
     · sorry
-  · sorry
 
 -- def move_right (t : BiTape Symbol) : BiTape Symbol :=
 --   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩

From 1f99cdffbf61dbb112edc9fe41353c926a771601 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 2 Jun 2026 09:13:06 +0200
Subject: [PATCH 095/106] computes tactic

---
 .../RoseTreeMachine/V3/ComputesAttr.lean      | 77 +++++++++++++++++++
 .../Machines/RoseTreeMachine/V3/PB.lean       | 66 +++++++++++++++-
 .../Machines/RoseTreeMachine/V3/Tools.lean    |  5 ++
 .../RoseTreeMachine/V3/UniversalTM.lean       | 25 +++---
 4 files changed, 155 insertions(+), 18 deletions(-)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
new file mode 100644
index 0000000000..50cfe10d40
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
@@ -0,0 +1,77 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Lean.LabelAttribute
+public meta import Lean.LabelAttribute
+public import Lean.Elab.Tactic.SolveByElim
+public import Lean.Meta.Tactic.Simp.RegisterCommand
+public meta import Lean.Meta.Tactic.Simp.Attr
+
+/-! # The `computes` tactic for RoseTreeMachine V3 program semantics
+
+The resource-erased semantic correctness lemmas of program builders (`*_computes` /
+`*_computes_enc`) follow the structure of the program: to prove that a compound builder
+computes a value, one applies the `_computes` lemma of the outermost combinator/routine and
+recurses on the arguments, closing leaves with the hypotheses about the inputs. This is a
+structural, backtracking proof search — exactly what `solve_by_elim` performs over a labelled
+set of lemmas together with the local hypotheses.
+
+This module provides:
+
+* `register_label_attr computes` — tag the routine `_computes` lemmas that the search may use.
+* `register_simp_attr computes_simp` — the encode-bridge lemmas used to expose the encoded
+  structure of a value before the search starts.
+* the `computes` tactic — `simp only` preprocessing (unfolding `PB.computes_enc`, any
+  user-supplied program/value definitions and the `computes_simp` bridges) followed by
+  `solve_by_elim ... using computes`.
+
+The attribute must be *registered in a separate, imported module* (its `initialize` does not
+run in the file that defines it), which is why this lives in its own file. -/
+
+public meta section
+
+/-- Lemmas of the form `… .computes …` / `… .computes_enc …` for the `computes` tactic to use
+during proof search. -/
+register_label_attr computes
+
+/-- Encode-bridge lemmas (e.g. `encode_biTape`) that rewrite the encoding of a structured value
+into the encoding of its components, exposing the shape that the routine `_computes` lemmas
+conclude about. Used by the preprocessing step of the `computes` tactic. -/
+register_simp_attr computes_simp
+
+end
+
+namespace Turing.RoseTreeMachine
+
+open Lean Elab Tactic
+
+/-- Prove a resource-erased semantic goal `… .computes_enc env value` (or `PB.computes …`) by
+structural proof search. The optional bracketed list supplies the program and value definitions
+to unfold (e.g. `computes [bitape_move_right, BiTape.move_right]`) so that the outermost
+combinator and the encoded value structure are exposed. The search then applies `@[computes]`
+lemmas and local hypotheses via `solve_by_elim`. -/
+syntax (name := computesTac) "computes" (" [" Lean.Parser.Tactic.simpLemma,* "]")? : tactic
+
+open Lean in
+macro_rules
+  | `(tactic| computes) => do
+      let cenc := mkIdent `Turing.RoseTreeMachine.PB.computes_enc
+      let csimp := mkIdent `computes_simp
+      let clab := mkIdent `computes
+      `(tactic|
+        simp only [$cenc:ident, $csimp:ident] <;>
+        solve_by_elim (config := { maxDepth := 30 }) using $clab:ident)
+  | `(tactic| computes [ $unfolds,* ]) => do
+      let cenc := mkIdent `Turing.RoseTreeMachine.PB.computes_enc
+      let csimp := mkIdent `computes_simp
+      let clab := mkIdent `computes
+      `(tactic|
+        simp only [$cenc:ident, $csimp:ident, $unfolds,*] <;>
+        solve_by_elim (config := { maxDepth := 30 }) using $clab:ident)
+
+end Turing.RoseTreeMachine
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
index 21bf6444a9..2309d14c69 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
@@ -8,6 +8,7 @@ module
 
 public import Cslib.Computability.Machines.RoseTreeMachine.V3.Prog
 public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.ComputesAttr
 
 /-! # RoseTreeMachine V2 — PB
 
@@ -87,13 +88,41 @@ lemma PB.var_computes {env : List Data} {i : ℕ} (h : i < env.length) :
   rw [← hval]
   exact ProgSem.var
 
-@[simp, grind .]
+/-- The first of two freshly-bound variables (at absolute level `(env ++ ext).length`) reads
+back the first bound value `x`. This is the leaf used by the `computesFun₂` bridge when a binder
+body projects out its first argument (e.g. the `head` branch of `PB.elim`). -/
+@[computes]
+lemma PB.var_computes_fst {env ext : List Data} {x y : Data} :
+    PB.computes (env ++ ext ++ [x, y]) (PB.var (env.length + ext.length)) x := by
+  have h : env.length + ext.length < (env ++ ext ++ [x, y]).length := by
+    simp [List.length_append]
+  have hv := PB.var_computes (env := env ++ ext ++ [x, y]) (i := env.length + ext.length) h
+  have he : (env ++ ext ++ [x, y])[env.length + ext.length] = x := by
+    rw [List.getElem_append_right (by simp [List.length_append])]
+    simp [List.length_append]
+  rwa [he] at hv
+
+/-- The second of two freshly-bound variables (at absolute level `(env ++ ext).length + 1`) reads
+back the second bound value `y`. This is the leaf used by the `computesFun₂` bridge when a binder
+body projects out its second argument (e.g. the `tail` branch of `PB.elim`). -/
+@[computes]
+lemma PB.var_computes_snd {env ext : List Data} {x y : Data} :
+    PB.computes (env ++ ext ++ [x, y]) (PB.var (env.length + ext.length + 1)) y := by
+  have h : env.length + ext.length + 1 < (env ++ ext ++ [x, y]).length := by
+    simp [List.length_append]; omega
+  have hv := PB.var_computes (env := env ++ ext ++ [x, y]) (i := env.length + ext.length + 1) h
+  have he : (env ++ ext ++ [x, y])[env.length + ext.length + 1] = y := by
+    rw [List.getElem_append_right (by simp [List.length_append])]
+    simp [List.length_append]
+  rwa [he] at hv
+
+@[simp, grind ., computes]
 lemma PB.empty_computes {env : List Data} :
     PB.computes env PB.empty (Data.l []) := by
   intro ext
   exact ⟨2, 2, ProgSem.empty⟩
 
-@[simp, grind .]
+@[simp, grind ., computes]
 lemma PB.cons_computes {env : List Data} {h t : PB} {dh dt : Data}
     (hh : PB.computes env h dh) (ht : PB.computes env t dt) :
     PB.computes env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
@@ -126,12 +155,41 @@ def PB.computesFun₂ (env : List Data) (x y : Data) (body : PB → PB → PB) (
 
 /-- A body that ignores its two freshly-bound arguments satisfies `computesFun₂` as soon as the
 underlying program computes `out`: the two extra bindings are just an environment extension. -/
+@[computes]
 lemma PB.computesFun₂_const {env : List Data} {x y : Data} {impl : PB} {out : Data}
     (h : PB.computes env impl out) :
     PB.computesFun₂ env x y (fun _ _ => impl) out := by
   intro ext
   simpa [List.append_assoc, Nat.add_assoc] using h (ext ++ [x, y])
 
+/-- Bridge from a uniform `PB.computes` goal to `computesFun₂`: if, under any extension `ext`, the
+binder body — with its two arguments instantiated to the freshly-bound variables — computes `out`,
+then the body satisfies `computesFun₂`. This reduces a `computesFun₂` obligation to an ordinary
+`PB.computes` goal that the same proof search continues on, with the bound variables discharged by
+`PB.var_computes_fst`/`PB.var_computes_snd`. -/
+lemma PB.computesFun₂_intro {env : List Data} {x y : Data} {body : PB → PB → PB} {out : Data}
+    (h : ∀ ext : List Data, PB.computes (env ++ ext ++ [x, y])
+          (body (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))) out) :
+    PB.computesFun₂ env x y body out := by
+  intro ext
+  simpa using (h ext).here
+
+/-- A binder body that projects out its first argument (e.g. `PB.head`'s branch) returns the first
+bound value. -/
+@[computes]
+lemma PB.computesFun₂_fst {env : List Data} {x y : Data} :
+    PB.computesFun₂ env x y (fun hd _ => hd) x := by
+  intro ext
+  exact (PB.var_computes_fst (ext := ext)).here
+
+/-- A binder body that projects out its second argument (e.g. `PB.tail`'s branch) returns the
+second bound value. -/
+@[computes]
+lemma PB.computesFun₂_snd {env : List Data} {x y : Data} :
+    PB.computesFun₂ env x y (fun _ tl => tl) y := by
+  intro ext
+  exact (PB.var_computes_snd (ext := ext)).here
+
 /-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`.
 This is the additive lookup used to discharge HOAS branch bodies (see `PB.elim_cons_computes`):
 the `j`-th binding introduced after `env ++ ext` sits at level `(env ++ ext).length + j`. -/
@@ -159,7 +217,7 @@ lemma PB.var_computesFun_zero {env binds : List Data} (ext : List Data) :
   simpa using PB.var_computesFun (j := 0) ext
 
 /-- `elim`, nil branch: `v` computes `[]`, so the empty branch `em` runs. -/
-@[simp, grind .]
+@[simp, grind ., computes]
 lemma PB.elim_nil_computes {env : List Data} {v em : PB} {cs : PB → PB → PB} {out : Data}
     (hv : PB.computes env v (Data.l []))
     (hem : PB.computes env em out) :
@@ -172,7 +230,7 @@ lemma PB.elim_nil_computes {env : List Data} {v em : PB} {cs : PB → PB → PB}
 
 /-- `elim`, cons branch: `v` computes `head :: tail`, so the body `cs` runs on the env
 extended with `[head, Data.l tail]`. -/
-@[simp, grind .]
+@[simp, grind ., computes]
 lemma PB.elim_cons_computes {env : List Data} {v em : PB} {cs : PB → PB → PB}
     {head : Data} {tail : List Data} {out : Data}
     (hv : PB.computes env v (Data.l (head :: tail)))
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
index 46f267ae0e..3fcf6f9296 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
@@ -38,6 +38,7 @@ def PB.tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl)
 /-- Returns the head of a list-valued builder (`Data.l []` when empty). -/
 def PB.head (x : PB) : PB := .elim x .empty (fun hd _tl => hd)
 
+@[computes]
 lemma PB.tail_computes {env : List Data} {x : PB} {dx : Data} (hx : PB.computes env x dx) :
     PB.computes env (.tail x) (Data.l dx.asList.tail) := by
   obtain ⟨dx⟩ := dx
@@ -48,6 +49,7 @@ lemma PB.tail_computes {env : List Data} {x : PB} {dx : Data} (hx : PB.computes
     intro ext
     simpa using PB.var_computesFun ext
 
+@[computes]
 lemma PB.head_computes {env : List Data} {x : PB} {dx : Data}
     (hx : PB.computes env x dx) :
     PB.computes env (PB.head x) (dx.asList.headD (Data.l [])) := by
@@ -101,6 +103,7 @@ def PB.optionElim (x noneCase : PB) (someCase : PB → PB) : PB :=
 --     (env : List Data) (a : α) (b : β) (body : PB → PB → PB) (c : γ) : Prop :=
 --   PB.computes_at_body₂ env (DataEncode.encode a) (DataEncode.encode b) body (DataEncode.encode c)
 
+@[computes]
 lemma PB.fst_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
     {env : List Data} {x : PB} {a : α × β}
     (hx : PB.computes_enc env x a) :
@@ -108,6 +111,7 @@ lemma PB.fst_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
   obtain ⟨a, b⟩ := a
   simpa [Data.asList] using PB.head_computes hx
 
+@[computes]
 lemma PB.snd_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
     {env : List Data} {x : PB} {a : α × β}
     (hx : PB.computes_enc env x a) :
@@ -115,6 +119,7 @@ lemma PB.snd_computes_enc {α β : Type} [DataEncode α] [DataEncode β]
   obtain ⟨a, b⟩ := a
   simpa [Data.asList] using PB.head_computes (PB.tail_computes hx)
 
+@[computes]
 lemma PB.some_computes_enc {α : Type} [DataEncode α]
     {env : List Data} {x : PB} {a : α}
     (hx : PB.computes_enc env x a) :
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
index 1f3a8b0691..0405fa20df 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
@@ -38,12 +38,14 @@ public instance : DataEncode (Turing.BiTape Symbol) where
     intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h
     grind [DataEncode.h_inj h]
 
+@[computes_simp]
 lemma encode_biTape (t : Turing.BiTape Symbol) :
     DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by
     simp [DataEncode.encode]
 
 def bitape_write (t v : PB) : PB := PB.cons v t.tail
 
+@[computes]
 lemma bitape_write_computes
     {env : List Data} {p_t p_v : PB} {t : BiTape Symbol} {v : Option Symbol}
     (h_t : PB.computes_enc env p_t t)
@@ -76,6 +78,7 @@ def stackTape_cons (x st : PB) : PB :=
       (fun _ _ => PB.cons x st))
     (fun _ => PB.cons x st)
 
+@[computes]
 lemma stackTape_cons_computes
     {env : List Data} {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol}
     (h_x : PB.computes_enc env p_x x)
@@ -100,6 +103,7 @@ lemma stackTape_cons_computes
 
 def to_pair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
 
+@[computes]
 lemma to_pair_computes {α β : Type} [DataEncode α] [DataEncode β]
     {env : List Data} {p_a p_b : PB}
     {a : α} {b : β}
@@ -116,15 +120,18 @@ def bitape_left (t : PB) : PB := t.snd.fst
 --- The right component of the bitape
 def bitape_right (t : PB) : PB := t.snd.snd
 
+@[computes]
 lemma bitape_head_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     (bitape_head p_t).computes_enc env t.head := PB.head_computes h_t
 
+@[computes]
 lemma bitape_left_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     (bitape_left p_t).computes_enc env t.left :=
   PB.head_computes (PB.head_computes (PB.tail_computes h_t))
 
+@[computes]
 lemma bitape_right_computes {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     (bitape_right p_t).computes_enc env t.right :=
@@ -140,12 +147,14 @@ lemma encode_stackTape_tail (st : StackTape Symbol) :
   obtain ⟨l, hl⟩ := st
   cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList]
 
+@[computes]
 lemma stackTape_head_computes_enc {env : List Data} {p_st : PB} {st : StackTape Symbol}
     (h_st : PB.computes_enc env p_st st) :
     (p_st.head).computes_enc env st.head := by
   unfold PB.computes_enc
   simpa [← encode_stackTape_head] using PB.head_computes h_st
 
+@[computes]
 lemma stackTape_tail_computes_enc {env : List Data} {p_st : PB} {st : StackTape Symbol}
     (h_st : PB.computes_enc env p_st st) :
     (p_st.tail).computes_enc env st.tail := by
@@ -165,13 +174,7 @@ lemma bitape_move_left_computes
     {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     PB.computes_enc env (bitape_move_left p_t) t.move_left := by
-  unfold PB.computes_enc
-  rw [encode_biTape]
-  exact to_pair_computes
-    (stackTape_head_computes_enc (bitape_left_computes h_t))
-    (to_pair_computes
-      (stackTape_tail_computes_enc (bitape_left_computes h_t))
-      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_right_computes h_t)))
+  computes [bitape_move_left, BiTape.move_left]
 
 lemma bitape_move_left_uses_linear_time_and_space
     {p_t : PB} (h_t : PB.usesLinearTimeAndSpace p_t) :
@@ -203,13 +206,7 @@ lemma bitape_move_right_computes
     {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     PB.computes_enc env (bitape_move_right p_t) t.move_right := by
-  unfold PB.computes_enc
-  rw [encode_biTape]
-  exact to_pair_computes
-    (stackTape_head_computes_enc (bitape_right_computes h_t))
-    (to_pair_computes
-      (stackTape_cons_computes (bitape_head_computes h_t) (bitape_left_computes h_t))
-      (stackTape_tail_computes_enc (bitape_right_computes h_t)))
+  computes [bitape_move_right, BiTape.move_right]
 
 instance : DataEncode Dir where
   encode := fun

From 7bf725e35047729c5dcc7541d04f259c8bd24f70 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 2 Jun 2026 09:29:26 +0200
Subject: [PATCH 096/106] inline

---
 .../RoseTreeMachine/V3/ComputesAttr.lean      | 55 +++++--------------
 .../RoseTreeMachine/V3/UniversalTM.lean       |  8 ++-
 2 files changed, 21 insertions(+), 42 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
index 50cfe10d40..3a9f7141d6 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
@@ -12,7 +12,7 @@ public import Lean.Elab.Tactic.SolveByElim
 public import Lean.Meta.Tactic.Simp.RegisterCommand
 public meta import Lean.Meta.Tactic.Simp.Attr
 
-/-! # The `computes` tactic for RoseTreeMachine V3 program semantics
+/-! # The `computes` attributes for RoseTreeMachine V3 program semantics
 
 The resource-erased semantic correctness lemmas of program builders (`*_computes` /
 `*_computes_enc`) follow the structure of the program: to prove that a compound builder
@@ -21,57 +21,32 @@ recurses on the arguments, closing leaves with the hypotheses about the inputs.
 structural, backtracking proof search — exactly what `solve_by_elim` performs over a labelled
 set of lemmas together with the local hypotheses.
 
-This module provides:
+This module provides the two attributes used to drive such proofs:
 
 * `register_label_attr computes` — tag the routine `_computes` lemmas that the search may use.
 * `register_simp_attr computes_simp` — the encode-bridge lemmas used to expose the encoded
   structure of a value before the search starts.
-* the `computes` tactic — `simp only` preprocessing (unfolding `PB.computes_enc`, any
-  user-supplied program/value definitions and the `computes_simp` bridges) followed by
-  `solve_by_elim ... using computes`.
 
-The attribute must be *registered in a separate, imported module* (its `initialize` does not
-run in the file that defines it), which is why this lives in its own file. -/
+A typical proof unfolds `PB.computes_enc`, the relevant program/value definitions and the
+`computes_simp` bridges, then runs the search, e.g.:
+
+```
+simp only [PB.computes_enc, computes_simp, bitape_move_right, BiTape.move_right] <;>
+  solve_by_elim (config := { maxDepth := 30 }) using computes
+```
+
+The attributes must be *registered in a separate, imported module* (their `initialize` does not
+run in the file that defines them), which is why this lives in its own file. -/
 
 public meta section
 
-/-- Lemmas of the form `… .computes …` / `… .computes_enc …` for the `computes` tactic to use
-during proof search. -/
+/-- Lemmas of the form `… .computes …` / `… .computes_enc …` for `solve_by_elim ... using computes`
+to use during proof search. -/
 register_label_attr computes
 
 /-- Encode-bridge lemmas (e.g. `encode_biTape`) that rewrite the encoding of a structured value
 into the encoding of its components, exposing the shape that the routine `_computes` lemmas
-conclude about. Used by the preprocessing step of the `computes` tactic. -/
+conclude about. Used by the `simp only [..., computes_simp]` preprocessing step. -/
 register_simp_attr computes_simp
 
 end
-
-namespace Turing.RoseTreeMachine
-
-open Lean Elab Tactic
-
-/-- Prove a resource-erased semantic goal `… .computes_enc env value` (or `PB.computes …`) by
-structural proof search. The optional bracketed list supplies the program and value definitions
-to unfold (e.g. `computes [bitape_move_right, BiTape.move_right]`) so that the outermost
-combinator and the encoded value structure are exposed. The search then applies `@[computes]`
-lemmas and local hypotheses via `solve_by_elim`. -/
-syntax (name := computesTac) "computes" (" [" Lean.Parser.Tactic.simpLemma,* "]")? : tactic
-
-open Lean in
-macro_rules
-  | `(tactic| computes) => do
-      let cenc := mkIdent `Turing.RoseTreeMachine.PB.computes_enc
-      let csimp := mkIdent `computes_simp
-      let clab := mkIdent `computes
-      `(tactic|
-        simp only [$cenc:ident, $csimp:ident] <;>
-        solve_by_elim (config := { maxDepth := 30 }) using $clab:ident)
-  | `(tactic| computes [ $unfolds,* ]) => do
-      let cenc := mkIdent `Turing.RoseTreeMachine.PB.computes_enc
-      let csimp := mkIdent `computes_simp
-      let clab := mkIdent `computes
-      `(tactic|
-        simp only [$cenc:ident, $csimp:ident, $unfolds,*] <;>
-        solve_by_elim (config := { maxDepth := 30 }) using $clab:ident)
-
-end Turing.RoseTreeMachine
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
index 0405fa20df..162b0b5e8e 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
@@ -170,11 +170,14 @@ def bitape_move_left (t : PB) : PB :=
       (bitape_left t).tail
       (stackTape_cons (bitape_head t) (bitape_right t)))
 
+set_option trace.Meta.Tactic.solveByElim true in
 lemma bitape_move_left_computes
     {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     PB.computes_enc env (bitape_move_left p_t) t.move_left := by
-  computes [bitape_move_left, BiTape.move_left]
+  simp only [PB.computes_enc, computes_simp, bitape_move_left, BiTape.move_left,
+             bitape_right, bitape_head]
+  solve_by_elim (config := { maxDepth := 15 }) using computes
 
 lemma bitape_move_left_uses_linear_time_and_space
     {p_t : PB} (h_t : PB.usesLinearTimeAndSpace p_t) :
@@ -206,7 +209,8 @@ lemma bitape_move_right_computes
     {env : List Data} {p_t : PB} {t : BiTape Symbol}
     (h_t : PB.computes_enc env p_t t) :
     PB.computes_enc env (bitape_move_right p_t) t.move_right := by
-  computes [bitape_move_right, BiTape.move_right]
+  simp only [PB.computes_enc, computes_simp, bitape_move_right, BiTape.move_right] <;>
+    solve_by_elim (config := { maxDepth := 30 }) using computes
 
 instance : DataEncode Dir where
   encode := fun

From 883e8687949015f702629dc1722445386c2d6a5b Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 2 Jun 2026 18:03:35 +0200
Subject: [PATCH 097/106] Introduce read-only input tape and write-only output
 tape and define time and space consumption.

---
 .../Machines/MultiTapeTuring/Basic.lean       | 404 ++++++++++--------
 1 file changed, 223 insertions(+), 181 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 91ee0c781d..5aed397c69 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -8,56 +8,51 @@ module
 
 public import Mathlib.Data.Part
 public import Mathlib.Data.Fintype.Defs
+public import Mathlib.Data.Finset.Max
+public import Mathlib.Algebra.Order.BigOperators.Group.Finset
+public import Mathlib.Computability.Language
 public import Cslib.Foundations.Data.BiTape
 public import Cslib.Foundations.Data.RelatesInSteps
 public import Cslib.Computability.Machines.TuringCommon
-public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 
 /-!
 # Multi-Tape Turing Machines
 
-Defines Turing machines with `k` tapes (bidirectionally infinite, `BiTape`) containing symbols
-from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the blank symbol).
+Defines Turing machines with a read-only input tape, `k` work tapes and one write-only output tape.
+The tapes contain symbols from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the
+blank symbol).
 
 ## Design
 
-The design of the multi-tape Turing machine follows the one for single-tape Turing machines.
-With multiple tapes, it is not immediatly clear how to define the function computed by a Turing
-machine. For a single-tape Turing machine, function composition follows easily from composition
-of configurations. For multi-tape machines, we focus on composition of tape configurations
-(cf. `MultiTapeTM.eval`) and defer the decision of how to define the function computed by a
-Turing machine to a later stage.
-
-Since these Turing machines are deterministic, we base the definition of semantics on the sequence
-of configurations instead of reachability in a configuration relation, although equivalence
-between these two notions is proven.
+The multi-tape Turing machine uses a read-only input tape, `k` work tapes and a write-only output
+tape.
+The input head can move freely on the input, but any move attempt beyond one cell outside the input
+results in no movement.
+The transition function can optionally output one symbol, which models the write-only output tape.
+Because of these restrictions, the input and output tapes do not count towards the space usage of
+the machine. The space usage of the work tapes is the number of cells the head accessed.
 
 ## Important Declarations
 
-We define a number of structures related to multi-tape Turing machine computation:
+We define a number of structures and concepts related to multi-tape Turing machine computation:
 
 * `MultiTapeTM`: the TM itself
-* `Cfg`: the configuration of a TM, including internal state and the state of the tapes
-* `UsesSpaceUntilStep`: a TM uses at most space `s` when run for up to `t` steps
-* `TrasformsTapesInExactTime`: a TM transforms tapes `tapes` to `tapes'` in exactly `t` steps
-* `TransformsTapesInTime`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps
-* `TransformsTapes`: a TM transforms tapes `tapes` to `tapes'` in some number of steps
-* `TransformsTapesInTimeAndSpace`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps
-  and uses at most `s` space
-
-There are multiple ways to talk about the behaviour of a multi-tape Turing machine:
+* `Cfg`: the configuration of a TM, including internal state, the tapes and the output so far
+* `spaceUsed`: the number of work tape cells touched by the head until a certain step
+* `TransitionRelation`: the transition relation from one configuration to the next
+* `ComputesInTimeAndSpace`: a proof that a TM computes an output from an input in a certain number
+    of steps and using a certain number of tape cells
+* `ComputesFunInTimeAndSpace`: a proof that a TM computes a function (on strings) respecting a
+    time and space bound in the input length
+* `DecidesLanguageInTimeAndSpace`: a proof that a TM decides a language within a certain time
+    and space bound
+
+There are two ways to talk about the behaviour of a multi-tape Turing machine, and they are
+proven to be equivalent.
 
 * `MultiTapeTM.configs`: a sequence of configurations by execution step
-* `TransformsTapes`: a TM transforms initial tapes `tapes` and halts with tapes `tapes'`
-* `MultiTapeTM.eval`: executes a TM on initial tapes `tapes` and returns the resulting tapes if it
-  eventually halts
-
-## TODOs
-
-* Define sequential composition of multi-tape Turing machines.
-* Define different kinds of tapes (input-only, output-only, oracle, etc) and how they influence
-   how space is counted.
-* Define the notion of a multi-tape Turing machine computing a function.
+* `RelatesInSteps tm.TransitionRelation cfg cfg' t`: a proof that `tm` transforms the configuration
+    `cfg` into `cfg'` in exactly `t` steps
 
 -/
 
@@ -73,9 +68,20 @@ variable {Symbol : Type}
 
 variable {k : ℕ}
 
+/-- The output of the transition function. -/
+structure TransitionOut (k : ℕ) (Symbol State : Type) where
+  /-- The movement (attempt) of the input head. -/
+  inputMove : Option Dir
+  /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/
+  stmts : Fin k → Stmt Symbol
+  /-- An optional symbol to output. -/
+  outS : Option Symbol
+  /-- The successor state or none to halt. -/
+  q' : Option State
+
 /--
-A `k`-tape Turing machine
-over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol).
+A multi-tape Turing machine with `k` work tapes over the alphabet of `Option Symbol` (where `none`
+is the blank `BiTape` symbol).
 -/
 structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   /-- type of state labels -/
@@ -84,9 +90,9 @@ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   [stateFintype : Fintype State]
   /-- initial state -/
   q₀ : State
-  /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke
-  for each tape and optionally the new state to transition to afterwards (`none` for halt) -/
-  tr : State → (Fin k → Option Symbol) → ((Fin k → (Stmt Symbol)) × Option State)
+  /-- transition function, mapping a state and a tuple of head symbols to a movement for the
+  input head, actions on the work tape, optionally a symbol to output and the successor state -/
+  tr : State → (Fin (k + 1) → Option Symbol) → TransitionOut k Symbol State
 
 namespace MultiTapeTM
 
@@ -102,43 +108,54 @@ and the intended initial and final configurations.
 
 variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol)
 
-instance : Inhabited tm.State := ⟨tm.q₀⟩
-
-instance : Fintype tm.State := tm.stateFintype
-
-instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
-
-
 /--
 The configurations of a Turing machine consist of:
-an `Option`al state (or none for the halting state),
-and a `BiTape` representing the tape contents.
+- an `Option`al state (or none for the halting state),
+- `BiTape`s representing the tape contents and
+- the output so far.
 -/
 @[ext]
 structure Cfg : Type where
   /-- the state of the TM (or none for the halting state) -/
   state : Option tm.State
-  /-- the BiTape contents -/
-  tapes : Fin k → BiTape Symbol
+  /-- the tape contents -/
+  tapes : Fin (k + 1) → BiTape Symbol
+  /-- the output so far -/
+  output : List Symbol
 deriving Inhabited
 
+/-- Applies the actions / statements to the tapes.
+The input tape is handled specially: The machine can read one empty cell outside of the input,
+but any attempted movement beyond that results in no movement. -/
+def applyTapeActions
+    (inputMove : Option Dir)
+    (stmts : Fin k → Stmt Symbol)
+    (tapes : Fin (k + 1) → BiTape Symbol) :
+    Fin (k + 1) → BiTape Symbol
+  | ⟨0, _⟩ => match inputMove, tapes ⟨0, by omega⟩ with
+    | none, t => t
+    | some .left, t => if t.left.toList = [] ∧ t.head = none then t else t.move_left
+    | some .right, t => if t.right.toList = [] ∧ t.head = none then t else t.move_right
+  | ⟨i + 1, _⟩ => let s := stmts ⟨i, by omega⟩
+    ((tapes ⟨i + 1, by omega⟩).write s.symbol).optionMove s.movement
+
+/-- The output of the transition function applied to a configuration. -/
+def transitionOutput : tm.Cfg → Option (TransitionOut k Symbol tm.State)
+  | ⟨none, _, _⟩ => none -- halting state
+  | ⟨some q, tapes, _⟩ => some (tm.tr q (fun i => (tapes i).head))
+
 /-- The step function corresponding to a `MultiTapeTM`. -/
-def step : tm.Cfg → Option tm.Cfg
-  | ⟨none, _⟩ =>
-    -- If in the halting state, there is no next configuration
-    none
-  | ⟨some q, tapes⟩ =>
-    -- If in state q, perform look up in the transition function
-    match tm.tr q (fun i => (tapes i).head) with
-    -- and enter a new configuration with state q' (or none for halting)
-    -- and tapes updated according to the Stmt
-    | ⟨stmts, q'⟩ => some ⟨q', fun i =>
-        ((tapes i).write (stmts i).symbol).optionMove (stmts i).movement⟩
+def step (cfg : tm.Cfg) : Option tm.Cfg :=
+  (tm.transitionOutput cfg).map fun {inputMove, stmts, outS, q'} =>
+    let output := match outS with
+      | none => cfg.output
+      | some s => cfg.output ++ [s]
+    ⟨q', applyTapeActions inputMove stmts cfg.tapes, output⟩
 
 /-- Any number of positive steps run from a halting configuration lead to `none`. -/
 @[simp, scoped grind =]
-lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) :
-    (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by
+lemma step_iter_none_eq_none (tapes : Fin (k + 1) → BiTape Symbol) (out : List Symbol) (n : ℕ) :
+    (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes, out⟩) = none := by
   rw [Function.iterate_succ_apply]
   induction n with
   | zero => rfl
@@ -149,64 +166,124 @@ def firstTape (s : List Symbol) : Fin k → BiTape Symbol
   | ⟨0, _⟩ => BiTape.mk₁ s
   | ⟨_, _⟩ => default
 
-/--
-The initial configuration corresponding to a list in the input alphabet.
-Note that the entries of the tape constructed by `BiTape.mk₁` are all `some` values.
-This is to ensure that distinct lists map to distinct initial configurations.
--/
+/-- The initial configuration corresponding to a list in the input alphabet. -/
 @[simp]
 def initCfg (s : List Symbol) : tm.Cfg :=
-  ⟨some tm.q₀, firstTape s⟩
+  ⟨some tm.q₀, firstTape s, []⟩
 
-/-- Create an initial configuration given a tuple of tapes. -/
-@[simp]
-def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
-  ⟨some tm.q₀, tapes⟩
+/-- The sequence of configurations of the Turing machine starting from `cfg`.
+If the Turing machine halts, it will eventually get and stay `none` after reaching the halting
+configuration. -/
+def configs (cfg : tm.Cfg) (t : ℕ) : Option tm.Cfg :=
+  (Option.bind · tm.step)^[t] cfg
+
+end Cfg
+
+section Space
+/-! Now we define space usage and add some helper lemmas. -/
+
+variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol)
+
+/-- Convert an "optional movement" to an integer where positive is "right". -/
+@[simp, grind]
+def OptionDirToInt : Option Dir → ℤ
+  | some .left => -1
+  | none => 0
+  | some .right => 1
 
-/-- The final configuration corresponding to a list in the output alphabet.
-(We demand that the head halts at the leftmost position of the output.)
+/-- The movements of the work tape heads after configuration `cfg`. -/
+def headMovements (cfg : tm.Cfg) : Fin k → ℤ
+  | i => match tm.transitionOutput cfg with
+      | some tro => OptionDirToInt (tro.stmts ⟨i, by omega⟩).movement
+      | none => 0
+
+/-- The head positions of the work tapes as a function of the number of steps, relative to
+the starting position in `cfg`. -/
+def headPositions (cfg : tm.Cfg) (t : ℕ) : Fin k → ℤ
+  | i => ∑ t' ∈ Finset.range t, (tm.configs cfg t').elim 0 (tm.headMovements · i)
+
+/--
+The number of work tape cells touched by the head of tape `i` in the computation starting from
+configuration `cfg` up to step `t`.
 -/
-@[simp]
-def haltCfg (s : List Symbol) : tm.Cfg :=
-  ⟨none, firstTape s⟩
+def spaceUsedByTape (cfg : tm.Cfg) (t : ℕ) (i : Fin k) : ℕ :=
+  let positions := (Finset.range (t + 1)).image (fun t' => tm.headPositions cfg t' i)
+  have ne := Finset.image_nonempty.mpr ⟨0, by simp⟩
+  (positions.max' ne - positions.min' ne).toNat + 1
 
-/-- The final configuration of a Turing machine given a tuple of tapes. -/
-@[simp]
-def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
-  ⟨none, tapes⟩
+/--
+The number of work tape cells touched by a computation starting from configuration
+`cfg` up to step `t`.
+-/
+def spaceUsed (cfg : tm.Cfg) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i
 
-/-- The sequence of configurations of the Turing machine starting with initial state and
-given tapes at step `t`.
-If the Turing machine halts, it will eventually get and stay `none` after reaching the halting
-configuration. -/
-def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg :=
-  (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes)
+/-- A zero-tape Turing machine uses zero space. -/
+@[simp]
+lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) :
+    tm.spaceUsed cfg t = 0 := by
+  unfold spaceUsed
+  subst h_zero
+  simp
+
+@[scoped grind .]
+lemma OptionDirToInt_bound (d : Option Dir) :
+    -1 ≤ OptionDirToInt d ∧ OptionDirToInt d ≤ 1 := by
+  rcases d with _ | d
+  · decide
+  · rcases d <;> decide
+
+/-- A single step moves each work tape head by at most one cell. -/
+lemma step_head_movement_bound (cfg : tm.Cfg) (t : ℕ) (i : Fin k) :
+    -1 ≤ (tm.configs cfg t).elim 0 (tm.headMovements · i)
+      ∧ (tm.configs cfg t).elim 0 (tm.headMovements · i) ≤ 1 := by
+  unfold headMovements
+  dsimp
+  rcases h : tm.configs cfg t <;>
+  grind
+
+/-- The head position changes by the corresponding head movement on each step. -/
+lemma headPositions_succ (cfg : tm.Cfg) (t : ℕ) (i : Fin k) :
+    tm.headPositions cfg (t + 1) i
+      = tm.headPositions cfg t i + (tm.configs cfg t).elim 0 (tm.headMovements · i) := by
+  simp only [headPositions, Finset.sum_range_succ]
 
 /--
-The space used by a configuration is the sum of the space used by its tapes.
+Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned
+interval `max' - min'` by at most one cell.
 -/
-def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used
+lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty)
+    {a q : ℤ} (hSeq : S = insert a s) (hq : q ∈ s) (h1 : a ≤ q + 1) (h2 : q ≤ a + 1) :
+    (S.max' hS - S.min' hS).toNat ≤ (s.max' hs - s.min' hs).toNat + 1 := by
+  subst hSeq
+  rw [Finset.max'_insert _ _ hs, Finset.min'_insert _ _ hs]
+  have hm := Finset.min'_le _ _ hq
+  have hM := Finset.le_max' _ _ hq
+  grind
+
+/-- The number of cells touched by a single work tape grows by at most one each step. -/
+lemma spaceUsedByTape_succ_le (cfg : tm.Cfg) (t : ℕ) (i : Fin k) :
+    tm.spaceUsedByTape cfg (t + 1) i ≤ tm.spaceUsedByTape cfg t i + 1 := by
+  unfold spaceUsedByTape
+  have hs := tm.headPositions_succ cfg t i
+  have step_bound := tm.step_head_movement_bound cfg t i
+  apply Nat.add_le_add_right
+  refine span_insert_le _ _
+    (by rw [Finset.range_add_one, Finset.image_insert])
+    (by exact Finset.mem_image_of_mem _ (Finset.mem_range.mpr (Nat.lt_succ_self t)))
+    (by grind)
+    (by grind)
 
 /--
 The space used by a configuration grows by at most `k` each step.
 -/
-lemma Cfg.space_used_step (cfg cfg' : tm.Cfg)
-    (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + k := by
-  obtain ⟨_ | q, tapes⟩ := cfg
-  · simp [step] at hstep
-  · simp only [step] at hstep
-    generalize h_tr : tm.tr q (fun i => (tapes i).head) = result at hstep
-    obtain ⟨stmts, q''⟩ := result
-    injection hstep with hstep
-    subst hstep
-    simp only [space_used]
-    trans ∑ i : Fin k, ((tapes i).space_used + 1)
-    · refine Finset.sum_le_sum fun i _ => ?_
-      unfold BiTape.optionMove
-      grind [BiTape.space_used_write, BiTape.space_used_move]
-    · simp [Finset.sum_add_distrib]
+lemma spaceUsed_linear (cfg : tm.Cfg) (t : ℕ) :
+    tm.spaceUsed cfg (t + 1) ≤ tm.spaceUsed cfg t + k := by
+  calc tm.spaceUsed cfg (t + 1)
+      ≤ ∑ i, (tm.spaceUsedByTape cfg t i + 1) :=
+        Finset.sum_le_sum fun i _ => tm.spaceUsedByTape_succ_le cfg t i
+    _ = (∑ i, tm.spaceUsedByTape cfg t i) + k := by simp [Finset.sum_add_distrib]
 
-end Cfg
+end Space
 
 open Cfg
 
@@ -221,44 +298,38 @@ which maps a configuration to its next configuration, if it exists.
 def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop :=
   tm.step c₁ = some c₂
 
-/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly
-`t` steps. -/
-def TransformsTapesInExactTime
-    (tm : MultiTapeTM k Symbol)
-    (tapes tapes' : Fin k → BiTape Symbol)
-    (t : ℕ) : Prop :=
-  RelatesInSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t
-
-/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in up to
-`t` steps. -/
-def TransformsTapesInTime
-    (tm : MultiTapeTM k Symbol)
-    (tapes tapes' : Fin k → BiTape Symbol)
-    (t : ℕ) : Prop :=
-  RelatesWithinSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t
-
-/-- The Turing machine `tm` transforms tapes `tapes` to `tapes'`. -/
-def TransformsTapes (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) : Prop :=
-  ∃ t, tm.TransformsTapesInExactTime tapes tapes' t
-
-/-- A proof that the Turing machine `tm` uses at most space `s` when run for up to `t` steps
-on initial tapes `tapes`. -/
-def UsesSpaceUntilStep
-    (tm : MultiTapeTM k Symbol)
-    (tapes : Fin k → BiTape Symbol)
-    (s t : ℕ) : Prop :=
-  ∀ t' ≤ t, match tm.configs tapes t' with
-    | none => true
-    | some cfg => cfg.space_used ≤ s
-
-/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps
+/-- A proof that the Turing machine `tm` on input `input` outputs `output` in exactly `t` steps
 and uses at most `s` space. -/
-def TransformsTapesInTimeAndSpace
+def ComputesInTimeAndSpace
     (tm : MultiTapeTM k Symbol)
-    (tapes tapes' : Fin k → BiTape Symbol)
+    (input output : List Symbol)
     (t s : ℕ) : Prop :=
-  tm.TransformsTapesInExactTime tapes tapes' t ∧
-    tm.UsesSpaceUntilStep tapes s t
+  ∃ cfg,
+  cfg.state = none ∧
+  cfg.output = output ∧
+  RelatesInSteps tm.TransitionRelation (tm.initCfg input) cfg t ∧
+  tm.spaceUsed (tm.initCfg input) t = s
+
+/-- A proof that the Turing machine `tm` computes the function `f` such that on all inputs of
+length `n` it uses at most `t n` steps and `s n` space. -/
+def ComputesFunInTimeAndSpace
+    (tm : MultiTapeTM k Symbol)
+    (f : List Symbol → List Symbol)
+    (t s : ℕ → ℕ) : Prop :=
+  ∀ input, ∃ t' ≤ t input.length, ∃ s' ≤ s input.length,
+  ComputesInTimeAndSpace tm input (f input) t' s'
+
+open Classical in
+/-- The indicator function of a language. -/
+noncomputable def indicator (l : Language Symbol) : List Symbol → List Symbol
+  | x => if x ∈ l then [default] else []
+
+/-- A proof that a Turing machine `tm` decides a language `l` with time and space bounds. -/
+def DecidesLanguageInTimeAndSpace
+    (tm : MultiTapeTM k Symbol)
+    (L : Language Symbol)
+    (t s : ℕ → ℕ) : Prop :=
+  ComputesFunInTimeAndSpace tm (indicator L) t s
 
 /-- This lemma translates between the relational notion and the iterated step notion. The latter
 can be more convenient especially for deterministic machines as we have here. -/
@@ -282,19 +353,19 @@ lemma relatesInSteps_iff_step_iter_eq_some
         use cfg'
         grind
 
-/-- The Turing machine `tm` halts after exactly `t` steps on initial tapes `tapes`. -/
-def haltsAtStep (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool :=
-  match (tm.configs tapes t) with
-  | some ⟨none, _⟩ => true
+/-- The Turing machine `tm` halts after exactly `t` steps on input `input`. -/
+def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool :=
+  match (tm.configs (tm.initCfg input) t) with
+  | some ⟨none, _, _⟩ => true
   | _ => false
 
 /-- If a Turing machine halts, the time step is uniquely determined. -/
 lemma halting_step_unique
     {tm : MultiTapeTM k Symbol}
-    {tapes : Fin k → BiTape Symbol}
+    {input : List Symbol}
     {t₁ t₂ : ℕ}
-    (h_halts₁ : tm.haltsAtStep tapes t₁)
-    (h_halts₂ : tm.haltsAtStep tapes t₂) :
+    (h_halts₁ : tm.haltsAtStep input t₁)
+    (h_halts₂ : tm.haltsAtStep input t₂) :
     t₁ = t₂ := by
   wlog h : t₁ ≤ t₂
   · exact (this h_halts₂ h_halts₁ (Nat.le_of_not_le h)).symm
@@ -302,46 +373,17 @@ lemma halting_step_unique
   cases d with
   | zero => rfl
   | succ d =>
-    -- this is a contradiction.
     unfold haltsAtStep configs at h_halts₁ h_halts₂
-    split at h_halts₁ <;> try contradiction
-    next tapes' h_iter_t₁ =>
-      rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply, h_iter_t₁,
-          step_iter_none_eq_none (tm := tm) tapes' d] at h_halts₂
-      simp at h_halts₂
+    rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply] at h_halts₂
+    grind
 
 /-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/
 lemma configs_isSome_of_haltsAtStep
-    {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t : ℕ}
-    (h_halts : tm.haltsAtStep tapes t) :
-    (tm.configs tapes t).isSome := by
+    {tm : MultiTapeTM k Symbol} {input : List Symbol} {t : ℕ}
+    (h_halts : tm.haltsAtStep input t) :
+    (tm.configs (tm.initCfg input) t).isSome := by
   grind [haltsAtStep]
 
-/-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes
-if it eventually halts. -/
-def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) :
-    Part (Fin k → BiTape Symbol) :=
-  ⟨∃ t, tm.haltsAtStep tapes t,
-    fun h => ((tm.configs tapes (Nat.find h)).get
-      (configs_isSome_of_haltsAtStep (Nat.find_spec h))).tapes⟩
-
-/-- Evaluating a Turing machine on a tuple of tapes `tapes` has a value `tapes'` if and only if
-it transforms `tapes` into `tapes'`. -/
-@[scoped grind =]
-lemma eval_eq_some_iff_transformsTapes
-    {tm : MultiTapeTM k Symbol}
-    {tapes tapes' : Fin k → BiTape Symbol} :
-    tm.eval tapes = .some tapes' ↔ tm.TransformsTapes tapes tapes' := by
-  simp only [eval, Part.eq_some_iff, Part.mem_mk_iff]
-  constructor
-  · intro ⟨h_dom, h_get⟩
-    use Nat.find h_dom
-    grind [TransformsTapesInExactTime, configs, haltCfgTapes, haltsAtStep]
-  · intro ⟨t, h_iter⟩
-    rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some, ← configs] at h_iter
-    have h_halts_at_t : tm.haltsAtStep tapes t := by grind [haltsAtStep]
-    have : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩
-    grind [haltCfgTapes, halting_step_unique]
 
 end MultiTapeTM
 

From 3ac3ac872da42fa2b2f45f672c7fdc49270852bd Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 2 Jun 2026 18:06:03 +0200
Subject: [PATCH 098/106] Clean up imports.

---
 Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 2 --
 1 file changed, 2 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 5aed397c69..6147be7269 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -6,8 +6,6 @@ Authors: Christian Reitwiessner
 
 module
 
-public import Mathlib.Data.Part
-public import Mathlib.Data.Fintype.Defs
 public import Mathlib.Data.Finset.Max
 public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 public import Mathlib.Computability.Language

From b5689a11b478d952501d7e69c42e0514c6c9f775 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Tue, 2 Jun 2026 18:09:34 +0200
Subject: [PATCH 099/106] more cleanup

---
 Cslib/Computability/Machines/MultiTapeTuring/Basic.lean | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 6147be7269..4c5bb9d500 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -249,7 +249,7 @@ lemma headPositions_succ (cfg : tm.Cfg) (t : ℕ) (i : Fin k) :
 Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned
 interval `max' - min'` by at most one cell.
 -/
-lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty)
+private lemma span_insert_le {s S : Finset ℤ} (hs : s.Nonempty) (hS : S.Nonempty)
     {a q : ℤ} (hSeq : S = insert a s) (hq : q ∈ s) (h1 : a ≤ q + 1) (h2 : q ≤ a + 1) :
     (S.max' hS - S.min' hS).toNat ≤ (s.max' hs - s.min' hs).toNat + 1 := by
   subst hSeq
@@ -319,8 +319,8 @@ def ComputesFunInTimeAndSpace
 
 open Classical in
 /-- The indicator function of a language. -/
-noncomputable def indicator (l : Language Symbol) : List Symbol → List Symbol
-  | x => if x ∈ l then [default] else []
+noncomputable def indicator (L : Language Symbol) : List Symbol → List Symbol
+  | x => if x ∈ L then [default] else []
 
 /-- A proof that a Turing machine `tm` decides a language `l` with time and space bounds. -/
 def DecidesLanguageInTimeAndSpace

From 3d406b75e131e3e010056ad847f9b8f380f43cdd Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Thu, 4 Jun 2026 16:37:36 +0200
Subject: [PATCH 100/106] Do not use BiTape for input.

---
 .../Machines/MultiTapeTuring/Basic.lean       | 105 +++++++++++-------
 1 file changed, 65 insertions(+), 40 deletions(-)

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 4c5bb9d500..aa53df046d 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -88,9 +88,10 @@ structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where
   [stateFintype : Fintype State]
   /-- initial state -/
   q₀ : State
-  /-- transition function, mapping a state and a tuple of head symbols to a movement for the
-  input head, actions on the work tape, optionally a symbol to output and the successor state -/
-  tr : State → (Fin (k + 1) → Option Symbol) → TransitionOut k Symbol State
+  /-- transition function, mapping a state, the current input symbol and a tuple of head symbols
+  to a movement for the input head, actions on the work tape, optionally a symbol to output and
+  the successor state -/
+  tr : State → (Option Symbol) → (Fin k → Option Symbol) → TransitionOut k Symbol State
 
 namespace MultiTapeTM
 
@@ -116,58 +117,73 @@ The configurations of a Turing machine consist of:
 structure Cfg : Type where
   /-- the state of the TM (or none for the halting state) -/
   state : Option tm.State
-  /-- the tape contents -/
-  tapes : Fin (k + 1) → BiTape Symbol
+  /-- the input -/
+  input : List Symbol
+  /-- the position of the input head, shifted by one -/
+  inputPos : Fin (input.length + 2)
+  /-- the work tape -/
+  workTapes : Fin k → BiTape Symbol
   /-- the output so far -/
   output : List Symbol
 deriving Inhabited
 
-/-- Applies the actions / statements to the tapes.
-The input tape is handled specially: The machine can read one empty cell outside of the input,
-but any attempted movement beyond that results in no movement. -/
-def applyTapeActions
-    (inputMove : Option Dir)
-    (stmts : Fin k → Stmt Symbol)
-    (tapes : Fin (k + 1) → BiTape Symbol) :
-    Fin (k + 1) → BiTape Symbol
-  | ⟨0, _⟩ => match inputMove, tapes ⟨0, by omega⟩ with
-    | none, t => t
-    | some .left, t => if t.left.toList = [] ∧ t.head = none then t else t.move_left
-    | some .right, t => if t.right.toList = [] ∧ t.head = none then t else t.move_right
-  | ⟨i + 1, _⟩ => let s := stmts ⟨i, by omega⟩
-    ((tapes ⟨i + 1, by omega⟩).write s.symbol).optionMove s.movement
-
-/-- The output of the transition function applied to a configuration. -/
-def transitionOutput : tm.Cfg → Option (TransitionOut k Symbol tm.State)
-  | ⟨none, _, _⟩ => none -- halting state
-  | ⟨some q, tapes, _⟩ => some (tm.tr q (fun i => (tapes i).head))
+/-- Attempt to move the input tape head.
+The machine can only read one empty cell outside of the input,
+any attempted movement beyond that results in no movement. -/
+@[scoped grind =]
+def moveInputPos {n : ℕ} (pos : Fin (n + 2)) (m : Option Dir) : Fin (n + 2) :=
+  let p := (pos + optionDirToInt m).toNat
+  if h : p < n + 2 then ⟨p, h⟩ else ⟨n + 1, by omega⟩
+
+/-- The output of the transition function applied to a state and the set of topes. -/
+def transitionOutput (q : tm.State) (inputSymbol : Option Symbol) (work : Fin k → BiTape Symbol) :
+    TransitionOut k Symbol tm.State :=
+  tm.tr q inputSymbol (fun i => (work i).head)
+
+/-- The symbol currently under the input tape head. -/
+@[scoped grind =]
+def inputSymbol (cfg : tm.Cfg) : Option Symbol :=
+  if h₁ : cfg.inputPos = 0 then none
+  else if h₂ : cfg.inputPos = cfg.input.length + 1 then none
+  else cfg.input[cfg.inputPos.val - 1]'(by grind)
+
+@[simp]
+lemma inputSymbolInner {cfg : tm.Cfg} (p : ℕ)
+    (h₁ : cfg.inputPos.val = 1 + p)
+    (h₂ : p < cfg.input.length) :
+    tm.inputSymbol cfg = some cfg.input[p] := by
+  simp [inputSymbol, h₁]
+  grind
 
 /-- The step function corresponding to a `MultiTapeTM`. -/
 def step (cfg : tm.Cfg) : Option tm.Cfg :=
-  (tm.transitionOutput cfg).map fun {inputMove, stmts, outS, q'} =>
-    let output := match outS with
+  match cfg.state with
+  | none => none
+  | some q =>
+    let {inputMove, stmts, outS, q'} := tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes
+    some {
+      state := q',
+      input := cfg.input,
+      inputPos := moveInputPos cfg.inputPos inputMove,
+      workTapes i := cfg.workTapes i |>.write (stmts i).symbol |>.optionMove (stmts i).movement
+      output := match outS with
       | none => cfg.output
       | some s => cfg.output ++ [s]
-    ⟨q', applyTapeActions inputMove stmts cfg.tapes, output⟩
+    }
 
 /-- Any number of positive steps run from a halting configuration lead to `none`. -/
 @[simp, scoped grind =]
-lemma step_iter_none_eq_none (tapes : Fin (k + 1) → BiTape Symbol) (out : List Symbol) (n : ℕ) :
-    (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes, out⟩) = none := by
+lemma step_iter_none_eq_none (cfg : tm.Cfg) (n : ℕ) (h_halt : cfg.state = none) :
+    (Option.bind · tm.step)^[n + 1] (some cfg) = none := by
   rw [Function.iterate_succ_apply]
   induction n with
-  | zero => rfl
+  | zero => simp [step, h_halt]
   | succ n ih => grind [Function.iterate_succ_apply']
 
-/-- A collection of tapes where the first tape contains `s` -/
-def firstTape (s : List Symbol) : Fin k → BiTape Symbol
-  | ⟨0, _⟩ => BiTape.mk₁ s
-  | ⟨_, _⟩ => default
-
 /-- The initial configuration corresponding to a list in the input alphabet. -/
 @[simp]
 def initCfg (s : List Symbol) : tm.Cfg :=
-  ⟨some tm.q₀, firstTape s, []⟩
+  ⟨some tm.q₀, s, 1, default, []⟩
 
 /-- The sequence of configurations of the Turing machine starting from `cfg`.
 If the Turing machine halts, it will eventually get and stay `none` after reaching the halting
@@ -175,6 +191,14 @@ configuration. -/
 def configs (cfg : tm.Cfg) (t : ℕ) : Option tm.Cfg :=
   (Option.bind · tm.step)^[t] cfg
 
+lemma configs_succ' (cfg : tm.Cfg) (t : ℕ) :
+    tm.configs cfg (t + 1) = (Option.bind · tm.step) (tm.configs cfg t) := by
+  simp [configs, Function.iterate_succ_apply']
+
+lemma configs_succ (cfg : tm.Cfg) (t : ℕ) :
+    tm.configs cfg (t + 1) = tm.configs cfg t >>= tm.step := by
+  simp [configs, Function.iterate_succ_apply']
+
 end Cfg
 
 section Space
@@ -191,9 +215,10 @@ def OptionDirToInt : Option Dir → ℤ
 
 /-- The movements of the work tape heads after configuration `cfg`. -/
 def headMovements (cfg : tm.Cfg) : Fin k → ℤ
-  | i => match tm.transitionOutput cfg with
-      | some tro => OptionDirToInt (tro.stmts ⟨i, by omega⟩).movement
-      | none => 0
+  | i => match cfg.state with
+    | none => 0
+    | some q => OptionDirToInt
+      (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.movement)
 
 /-- The head positions of the work tapes as a function of the number of steps, relative to
 the starting position in `cfg`. -/
@@ -354,7 +379,7 @@ lemma relatesInSteps_iff_step_iter_eq_some
 /-- The Turing machine `tm` halts after exactly `t` steps on input `input`. -/
 def haltsAtStep (tm : MultiTapeTM k Symbol) (input : List Symbol) (t : ℕ) : Bool :=
   match (tm.configs (tm.initCfg input) t) with
-  | some ⟨none, _, _⟩ => true
+  | some ⟨none, _, _, _, _⟩ => true
   | _ => false
 
 /-- If a Turing machine halts, the time step is uniquely determined. -/

From 2534d6249e760d9ea5a3881e21ed3c2fe3633e4c Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 5 Jun 2026 13:18:12 +0200
Subject: [PATCH 101/106] Some more simp lemmas and some improvements.

---
 Cslib/Foundations/Data/BiTape.lean | 62 ++++++++++++++++++++++--------
 1 file changed, 46 insertions(+), 16 deletions(-)

diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index dc760e2045..67cd589e79 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -54,19 +54,17 @@ structure BiTape (Symbol : Type) where
 
 namespace BiTape
 
-variable {Symbol : Type}
+open StackTape
 
-/-- The empty `BiTape` -/
-def nil : BiTape Symbol := ⟨none, ∅, ∅⟩
+variable {Symbol : Type}
 
 instance : Inhabited (BiTape Symbol) where
-  default := nil
+  default := ⟨none, ∅, ∅⟩
 
-instance : EmptyCollection (BiTape Symbol) :=
-  ⟨nil⟩
+instance : EmptyCollection (BiTape Symbol) := ⟨default⟩
 
 @[simp]
-lemma empty_eq_nil : (∅ : BiTape Symbol) = nil := rfl
+lemma empty_eq_default : (∅ : BiTape Symbol) = default := rfl
 
 /--
 Given a `List` of `Symbol`s, construct a `BiTape` by mapping the list to `some` elements
@@ -74,9 +72,10 @@ and laying them out to the right side,
 with the head under the first element of the list if it exists.
 -/
 def mk₁ (l : List Symbol) : BiTape Symbol :=
-  match l with
-  | [] => ∅
-  | h :: t => { head := some h, left := ∅, right := StackTape.map_some t }
+  { head := l.head?, left := ∅, right := StackTape.map_some l.tail }
+
+@[simp, scoped grind =]
+lemma mk₁_nil : mk₁ ([] : List Symbol) = ∅ := rfl
 
 open scoped Int in
 /-- Returns the tape symbol at positon `p` relative to the head, where
@@ -101,24 +100,36 @@ lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.g
     intro p
     simpa [get] using h_get_eq (p + 1)
 
+/-- Simplification lemma that explains the contents of each of the cells after tape
+construction using mk₁. -/
+@[simp, scoped grind =]
+lemma get_mk₁ (l : List Symbol) (p : ℤ) :
+  (mk₁ l).get p = if p < 0 then none else l[p.toNat]? := by
+  match p with
+  | Int.ofNat 0 => simp [mk₁, get, List.head?_eq_getElem?]
+  | Int.ofNat (n + 1) => grind [mk₁, get]
+  | Int.negSucc n => cases l <;> simp [mk₁, get]
 
 section Move
 
 /--
 Move the head left by shifting the left StackTape under the head.
 -/
+@[scoped grind =]
 def move_left (t : BiTape Symbol) : BiTape Symbol :=
   ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩
 
 /--
 Move the head right by shifting the right StackTape under the head.
 -/
+@[scoped grind =]
 def move_right (t : BiTape Symbol) : BiTape Symbol :=
   ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩
 
 /--
 Move the head to the left or right, shifting the tape underneath it.
 -/
+@[scoped grind =]
 def move (t : BiTape Symbol) : Dir → BiTape Symbol
   | .left => t.move_left
   | .right => t.move_right
@@ -126,6 +137,7 @@ def move (t : BiTape Symbol) : Dir → BiTape Symbol
 /--
 Optionally perform a `move`, or do nothing if `none`.
 -/
+@[simp, scoped grind =]
 def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
   | t, none => t
   | t, some d => t.move d
@@ -140,7 +152,7 @@ lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := b
 
 /-- Translate an optional direction into a head movement offset, where the positive
 direction is to the right. -/
-@[scoped grind]
+@[scoped grind =]
 def optionDirToInt (d : Option Dir) : ℤ :=
   match d with
   | none => 0
@@ -173,10 +185,9 @@ lemma get_move_right (t : BiTape Symbol) (p : ℤ) : t.move_right.get p = t.get
     simp
 
 @[simp, scoped grind =]
-lemma get_optionMove (t : BiTape Symbol) (d : Option Dir) (p : ℤ) :
-    (t.optionMove d).get p = t.get (p + optionDirToInt d) := by
-  unfold optionMove optionDirToInt
-  grind [move]
+lemma get_move (t : BiTape Symbol) (d : Dir) (p : ℤ) :
+    (t.move d).get p = t.get (p + optionDirToInt (some d)) := by
+  cases d <;> grind
 
 @[simp, scoped grind =]
 lemma get_move_right_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
@@ -194,6 +205,25 @@ lemma get_move_left_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
     have : p - n - 1 = p - (n + 1) := by lia
     simp [Function.iterate_succ_apply, ih, this]
 
+/-- Move the tape head by an integer amount where positive numbers move the head to the right and
+negative to the left. -/
+def moveInt (t : BiTape Symbol) (Δ : ℤ) : BiTape Symbol :=
+  if Δ ≥ 0 then
+    .move_right^[Δ.toNat] t
+  else
+    .move_left^[(-Δ).toNat] t
+
+@[simp, scoped grind =]
+lemma get_moveInt (t : BiTape Symbol) (Δ p : ℤ) :
+  (moveInt t Δ).get p = t.get (p + Δ) := by
+  grind [moveInt]
+
+@[simp, scoped grind =]
+lemma moveInt_head (t : BiTape Symbol) (Δ : ℤ) :
+  (moveInt t Δ).head = t.get Δ := by
+  rw [show (moveInt t Δ).head = (moveInt t Δ).get 0 from rfl]
+  grind [moveInt]
+
 end Move
 
 /--
@@ -225,7 +255,7 @@ lemma space_used_write (t : BiTape Symbol) (a : Option Symbol) :
 lemma space_used_mk₁ (l : List Symbol) :
     (mk₁ l).space_used = max 1 l.length := by
   cases l with
-  | nil => simp [mk₁, space_used, nil, StackTape.length_nil]
+  | nil => simp [mk₁, space_used, StackTape.length_nil]
   | cons h t => simp [mk₁, space_used, StackTape.length_nil, StackTape.length_map_some]; omega
 
 lemma space_used_move (t : BiTape Symbol) (d : Dir) :

From 6847a62c39b365a3404809394a75d286813c7bcc Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Fri, 5 Jun 2026 17:46:49 +0200
Subject: [PATCH 102/106] Make move optional.

---
 Cslib.lean                                    |  1 -
 .../Machines/MultiTapeTuring/Basic.lean       | 15 +++++-----
 .../Machines/SingleTapeTuring/Basic.lean      | 21 ++++++++++++--
 .../Computability/Machines/TuringCommon.lean  | 28 -------------------
 Cslib/Foundations/Data/BiTape.lean            |  9 ++++++
 5 files changed, 36 insertions(+), 38 deletions(-)
 delete mode 100644 Cslib/Computability/Machines/TuringCommon.lean

diff --git a/Cslib.lean b/Cslib.lean
index 32cde3201e..7dd907cd62 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -33,7 +33,6 @@ public import Cslib.Computability.Languages.OmegaRegularLanguage
 public import Cslib.Computability.Languages.RegularLanguage
 public import Cslib.Computability.Machines.MultiTapeTuring.Basic
 public import Cslib.Computability.Machines.SingleTapeTuring.Basic
-public import Cslib.Computability.Machines.TuringCommon
 public import Cslib.Computability.URM.Basic
 public import Cslib.Computability.URM.Computable
 public import Cslib.Computability.URM.Defs
diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index aa53df046d..f83bf9c47a 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -11,7 +11,6 @@ public import Mathlib.Algebra.Order.BigOperators.Group.Finset
 public import Mathlib.Computability.Language
 public import Cslib.Foundations.Data.BiTape
 public import Cslib.Foundations.Data.RelatesInSteps
-public import Cslib.Computability.Machines.TuringCommon
 
 /-!
 # Multi-Tape Turing Machines
@@ -71,7 +70,7 @@ structure TransitionOut (k : ℕ) (Symbol State : Type) where
   /-- The movement (attempt) of the input head. -/
   inputMove : Option Dir
   /-- Actions on the work tapes: optionally a symbol to write and the head movement. -/
-  stmts : Fin k → Stmt Symbol
+  stmts : Fin k → (Option (Option Symbol)) × (Option Dir)
   /-- An optional symbol to output. -/
   outS : Option Symbol
   /-- The successor state or none to halt. -/
@@ -165,7 +164,9 @@ def step (cfg : tm.Cfg) : Option tm.Cfg :=
       state := q',
       input := cfg.input,
       inputPos := moveInputPos cfg.inputPos inputMove,
-      workTapes i := cfg.workTapes i |>.write (stmts i).symbol |>.optionMove (stmts i).movement
+      workTapes i := match stmts i with
+        | (none, m) =>  cfg.workTapes i |>.optionMove m
+        | (some s, m) => cfg.workTapes i |>.write s |>.optionMove m
       output := match outS with
       | none => cfg.output
       | some s => cfg.output ++ [s]
@@ -208,7 +209,7 @@ variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol)
 
 /-- Convert an "optional movement" to an integer where positive is "right". -/
 @[simp, grind]
-def OptionDirToInt : Option Dir → ℤ
+def optionDirToInt : Option Dir → ℤ
   | some .left => -1
   | none => 0
   | some .right => 1
@@ -217,8 +218,8 @@ def OptionDirToInt : Option Dir → ℤ
 def headMovements (cfg : tm.Cfg) : Fin k → ℤ
   | i => match cfg.state with
     | none => 0
-    | some q => OptionDirToInt
-      (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.movement)
+    | some q => optionDirToInt
+      (tm.transitionOutput q (tm.inputSymbol cfg) cfg.workTapes |>.stmts i |>.2)
 
 /-- The head positions of the work tapes as a function of the number of steps, relative to
 the starting position in `cfg`. -/
@@ -250,7 +251,7 @@ lemma spaceUsed_zero_tapes_eq_zero (cfg : tm.Cfg) (t : ℕ) (h_zero : k = 0) :
 
 @[scoped grind .]
 lemma OptionDirToInt_bound (d : Option Dir) :
-    -1 ≤ OptionDirToInt d ∧ OptionDirToInt d ≤ 1 := by
+    -1 ≤ optionDirToInt d ∧ optionDirToInt d ≤ 1 := by
   rcases d with _ | d
   · decide
   · rcases d <;> decide
diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
index 80d5d13181..debad7d43f 100644
--- a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
@@ -9,7 +9,6 @@ module
 public import Cslib.Foundations.Data.BiTape
 public import Cslib.Foundations.Data.RelatesInSteps
 public import Mathlib.Algebra.Polynomial.Eval.Defs
-public import Cslib.Computability.Machines.TuringCommon
 
 /-!
 # Single-Tape Turing Machines
@@ -43,6 +42,7 @@ for convenience in composition of machines.
 
 We define a number of structures related to Turing machine computation:
 
+* `Stmt`: the write and movement operations a TM can do in a single step.
 * `SingleTapeTM`: the TM itself.
 * `Cfg`: the configuration of a TM, including internal and tape state.
 * `TimeComputable f`: a TM for computing `f`, packaged with a bound on runtime.
@@ -70,6 +70,21 @@ open BiTape StackTape
 
 variable {Symbol : Type}
 
+namespace SingleTapeTM
+
+/--
+A Turing machine "statement" is just a `Option`al command to move left or right,
+and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape`
+-/
+structure Stmt (Symbol : Type) where
+  /-- The symbol to write at the current head position -/
+  symbol : Option Symbol
+  /-- The direction to move the tape head -/
+  movement : Option Dir
+deriving Inhabited
+
+end SingleTapeTM
+
 /--
 A single-tape Turing machine
 over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol).
@@ -83,7 +98,7 @@ structure SingleTapeTM Symbol [Inhabited Symbol] [Fintype Symbol] where
   (q₀ : State)
   /-- Transition function, mapping a state and a head symbol to a `Stmt` to invoke,
   and optionally the new state to transition to afterwards (`none` for halt) -/
-  (tr : State → Option Symbol → Stmt Symbol × Option State)
+  (tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State)
 
 namespace SingleTapeTM
 
@@ -103,6 +118,8 @@ instance : Inhabited tm.State := ⟨tm.q₀⟩
 
 instance : Fintype tm.State := tm.stateFintype
 
+instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
+
 /--
 The configurations of a Turing machine consist of:
 an `Option`al state (or none for the halting state),
diff --git a/Cslib/Computability/Machines/TuringCommon.lean b/Cslib/Computability/Machines/TuringCommon.lean
deleted file mode 100644
index 60d0636639..0000000000
--- a/Cslib/Computability/Machines/TuringCommon.lean
+++ /dev/null
@@ -1,28 +0,0 @@
-/-
-Copyright (c) 2026 Bolton Bailey. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Bolton Bailey, Pim Spelier, Daan van Gent
--/
-
-module
-
-public import Mathlib.Computability.TuringMachine.Tape
-
-@[expose] public section
-
-namespace Turing
-
-/--
-A Turing machine "statement" is just a `Option`al command to move left or right,
-and write a symbol (i.e. an `Option Symbol`, where `none` is the blank symbol) on the `BiTape`
--/
-structure Stmt (Symbol : Type) where
-  /-- The symbol to write at the current head position -/
-  symbol : Option Symbol
-  /-- The direction to move the tape head -/
-  movement : Option Dir
-deriving Inhabited
-
-instance inhabitedStmt : Inhabited (Stmt Symbol) := inferInstance
-
-end Turing
diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index e61272d57d..7df3d2e736 100644
--- a/Cslib/Foundations/Data/BiTape.lean
+++ b/Cslib/Foundations/Data/BiTape.lean
@@ -114,6 +114,15 @@ lemma moveLeft_moveRight (t : BiTape Symbol) : t.moveLeft.moveRight = t := by
 lemma moveRight_moveLeft (t : BiTape Symbol) : t.moveRight.moveLeft = t := by
   simp [moveLeft, moveRight]
 
+/-- Translate an optional direction into a head movement offset, where the positive
+direction is to the right. -/
+@[scoped grind =]
+def optionDirToInt (d : Option Dir) : ℤ :=
+  match d with
+  | none => 0
+  | some .left => -1
+  | some .right => 1
+
 end Move
 
 /--

From 523e52cb28a4fb7e172ee929f77b45c53d48aea1 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Sun, 7 Jun 2026 22:19:34 +0200
Subject: [PATCH 103/106] Fourth iteration: functional prog plus syntactic
 fragment equal to non-functional prog.

---
 .../Machines/RoseTreeMachine/V3/Prog.lean     |   2 +
 .../Machines/RoseTreeMachine/V4/Prog.lean     | 195 ++++++++++++++++++
 2 files changed, 197 insertions(+)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
index 7ed49b7921..e754278be2 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
@@ -26,9 +26,11 @@ inductive Prog where
   /-- `elim v em cs`: if `v` evaluates to `empty`, run `em`; otherwise destructure into
       `head` and `tail` (both appended to `env`, in that order) and run `cs`. -/
   | elim (v em cs : Prog)
+  -- TODO ifEq is actually redundant
   | ifEq (x y then_ else_ : Prog)
   /-- `fold body init list`: `init` and `list` produce starting accumulator and the input
       list; `body` runs once per element with `env` extended by `[acc, x]`. -/
+  -- TODO fold is actually redundant
   | fold (body init list : Prog)
   /-- `while_ init body`: `init` produces the starting accumulator; `body` runs with
       `env` extended by the current accumulator. -/
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
new file mode 100644
index 0000000000..e8b70afb3b
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
@@ -0,0 +1,195 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.Data
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+/-- A variable, referenced by its de Bruijn level into the environment. -/
+def Var := ℕ
+deriving Repr
+
+/-- The full functional language.
+
+Unlike the first-order language, this language has functions (`fn`) and application (`app`)
+as its *only* binding mechanism: `elim` and `while_` no longer extend the environment
+themselves but instead take ordinary program terms that must evaluate to functions
+(closures) which are then applied to the bound values.
+
+A first-order program is recovered as the fragment in which every `fn` is the immediate
+operator of an `app` (or the curried branch of an `elim`/`while_`), so that no closure ever
+escapes; that fragment is the target of a later defunctionalising compiler. -/
+inductive Prog where
+  /-- Variable reference at de Bruijn level `id`. -/
+  | var (id : Var)
+  /-- The empty rose tree `[]`. -/
+  | empty
+  /-- `cons h t`: prepend the value of `h` (a rose tree) to the list value of `t`. -/
+  | cons (h t : Prog)
+  /-- `elim v em cs`: evaluate `v`; if it is `empty`, run `em`; otherwise destructure into
+      `head` and `tail` and apply the function `cs` to `head` and then to `tail`. `cs` is
+      therefore a *curried two-argument function* (e.g. `fn (fn body)`). -/
+  | elim (v em cs : Prog)
+  /-- `while_ init body`: evaluate `init` to the starting accumulator; `body` must evaluate
+      to a one-argument function which is applied to the current accumulator on each
+      iteration until the halting condition holds. -/
+  | while_ (init body : Prog)
+  /-- Abstraction / closure in one variable. -/
+  | fn (body : Prog)
+  /-- Function application. -/
+  | app (fn arg : Prog)
+deriving Repr
+
+/-- Runtime values produced by `ProgSem`. A value is either first-order `Data` or a
+`closure` capturing the environment in force at its creation together with the body of an
+`fn`. Closures are not representable as `Data`, hence the dedicated value space. -/
+inductive Value where
+  /-- A first-order rose-tree value. -/
+  | data (d : Data)
+  /-- A closure: the environment `env` captured when the enclosing `fn` was evaluated,
+      paired with the abstraction's `body`. -/
+  | closure (env : List Value) (body : Prog)
+deriving Repr
+
+/-- Size (encoding length) of a value. Mirrors `Data.size` on first-order data; a closure
+costs a small constant plus the sizes of its captured environment (the body is treated as a
+constant-size code pointer and not counted). -/
+def Value.size : Value → ℕ
+  | .data d => d.size
+  | .closure env _ => 2 + (env.map Value.size).sum
+
+/-- The empty first-order value. -/
+abbrev Value.empty : Value := .data (Data.l [])
+
+@[simp]
+lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size]
+
+@[simp]
+lemma Value.size_empty : Value.empty.size = 2 := by simp
+
+mutual
+/-- Semantics of `Prog` including time and space resource bounds.
+`ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value
+`x` and uses `t` time and `s` space. The environment holds `Value`s so that closures (the
+results of `fn`) can be bound to variables and passed as arguments. -/
+inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop
+  | var :
+      ProgSem σ (.var (i : ℕ)) (σ[i]?.getD Value.empty)
+        (σ[i]?.getD Value.empty).size (σ[i]?.getD Value.empty).size
+  | empty : ProgSem σ .empty Value.empty 2 2
+  | cons (h₁ : ProgSem σ head (.data hd) hd_t hd_s) (h₂ : ProgSem σ tail (.data tl) tl_t tl_s) :
+      ProgSem σ (.cons head tail) (.data (Data.l (hd :: tl.asList))) (hd_t + tl_t) (hd_s + tl_s)
+  /-- `elim`, empty branch: `v` is the empty list, so run `em` in the current environment. -/
+  | elim_nil
+      (h₁ : ProgSem σ val (.data (Data.l [])) t_v s_v)
+      (h₂ : ProgSem σ emp r t_em s_em) :
+      ProgSem σ (.elim val emp cs) r (t_v + t_em) (max s_v s_em)
+  /-- `elim`, cons branch: `v` destructures to `hd :: tl`; evaluate the function `cs` to a
+      closure and apply it first to `hd` and then to `tl` (so `cs` is a curried
+      two-argument function). -/
+  | elim_cons
+      (h_v : ProgSem σ val (.data (Data.l (hd :: tl))) t_v s_v)
+      (h_cs : ProgSem σ cs cv t_cs s_cs)
+      (h_app₁ : AppSem cv (.data hd) cv' t₁ s₁)
+      (h_app₂ : AppSem cv' (.data (Data.l tl)) r t₂ s₂) :
+      ProgSem σ (.elim val emp cs) r (t_v + t_cs + t₁ + t₂)
+        (max (max (max s_v s_cs) s₁) s₂)
+  /-- `while_ init body`: evaluate `init` to the starting accumulator and `body` to a
+      one-argument closure, then iterate the closure via `WhileSem` until it halts. -/
+  | while_
+      (h_init : ProgSem σ init (.data acc) t_init s_init)
+      (h_body : ProgSem σ body bodyVal t_body s_body)
+      (h_while : WhileSem bodyVal acc r t_w s_w) :
+      ProgSem σ (.while_ init body) (.data r) (t_init + t_body + t_w)
+        (max (max s_init s_body) s_w)
+  /-- `fn body`: evaluate to a closure capturing the current environment `σ`. The cost is the
+      size of the resulting closure (mirroring `var`, which charges the size of the value it
+      produces). -/
+  | fn :
+      ProgSem σ (.fn body) (.closure σ body)
+        (Value.closure σ body).size (Value.closure σ body).size
+  /-- `app fn arg`: evaluate `fn` to a closure, evaluate `arg` to a value, then run the
+      closure's body in the *captured* environment extended with the argument (static
+      scoping). -/
+  | app
+      (h_fn : ProgSem σ fn fv t_f s_f)
+      (h_arg : ProgSem σ arg v t_a s_a)
+      (h_app : AppSem fv v r t_b s_b) :
+      ProgSem σ (.app fn arg) r (t_f + t_a + t_b) (max (max s_f s_a) s_b)
+
+/-- Application of a value to an argument value. `AppSem f v r t s` means that applying the
+closure `f` to the argument `v` yields `r` using `t` time and `s` space. Only closures can be
+applied; applying a first-order value has no derivation (the program is stuck). -/
+inductive AppSem : Value → Value → Value → ℕ → ℕ → Prop
+  | mk (h_body : ProgSem (σ' ++ [v]) body r t s) :
+      AppSem (.closure σ' body) v r t s
+
+/-- Iterates the closure `bodyVal` of a `while_` loop, threading the accumulator.
+`WhileSem bodyVal acc r t s` means that, starting from accumulator `acc`, repeatedly applying
+`bodyVal` to the current accumulator eventually yields result `r` using `t` time and `s` space.
+Before each iteration the halting condition is checked on the current accumulator: iteration
+terminates (with the accumulator as result) when `acc` is empty or its head is empty.
+Otherwise `bodyVal` is applied and its result becomes the new accumulator. Non-terminating
+loops simply have no derivation. -/
+inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop
+  | halt
+      (h_stop : acc.asList.head?.getD (Data.l []) = Data.l []) :
+      WhileSem bodyVal acc acc acc.size acc.size
+  | step
+      (h_cont : acc.asList.head?.getD (Data.l []) ≠ Data.l [])
+      (h_app : AppSem bodyVal (.data acc) (.data v) t_b s_b)
+      (h_rest : WhileSem bodyVal v r t_r s_r) :
+      WhileSem bodyVal acc r (t_b + t_r) (max s_b s_r)
+end
+
+/-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/
+def ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop :=
+  ProgSem [.data x] p (.data y) t s
+
+/-- The *in-place* (first-order) fragment of the functional language.
+
+`InPlace p` holds when every `fn` in `p` occurs in an immediately-consumed position — as the
+operator of an `app`, or as the (curried) branch of an `elim`/`while_`. Consequently no
+closure ever escapes: every abstraction is created and used on the spot, so all values that
+flow through the environment are first-order `Data`. This is exactly the fragment a
+defunctionalising compiler targets, and it is closed under the operational semantics.
+
+The hope is that a Turing machine can directly implement the in-place fragment without needing to
+represent closures.
+
+Concretely:
+* `elim` requires its branch to be a literal curried two-argument function `fn (fn body)`
+  (binding `head` and `tail`); a `let x = e in body` is encoded as
+  `elim (cons e empty) _ (fn (fn body))`.
+* `while_` requires its body to be a literal one-argument function `fn body`.
+* there is no rule for a bare `fn` and no rule for `app`, so `fn` only ever appears as an
+  `elim`/`while_` branch and no closure is ever applied or escapes. -/
+inductive InPlace : Prog → Prop
+  | var : InPlace (.var i)
+  | empty : InPlace .empty
+  | cons (hh : InPlace h) (ht : InPlace t) : InPlace (.cons h t)
+  /-- `elim` over an in-place value, empty branch, and a curried two-argument function
+      branch `fn (fn body)` binding `head` and `tail`. -/
+  | elim (hv : InPlace v) (hemp : InPlace emp) (hbody : InPlace body) :
+      InPlace (.elim v emp (.fn (.fn body)))
+  /-- `while_` whose body is a literal one-argument function `fn body` binding the
+      accumulator. -/
+  | while_ (hinit : InPlace init) (hbody : InPlace body) :
+      InPlace (.while_ init (.fn body))
+
+end V4
+
+end RoseTreeMachine
+
+end Turing

From 70bccd95319499b2e0df14e957d9f5aea1062184 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Mon, 8 Jun 2026 21:16:28 +0200
Subject: [PATCH 104/106] v4

---
 .../Machines/MultiTapeTuring/Basic.lean       |  34 +--
 .../RoseTreeMachine/V4/InPlaceSim.lean        | 255 ++++++++++++++++++
 .../Machines/RoseTreeMachine/V4/PB.lean       | 193 +++++++++++++
 .../Machines/RoseTreeMachine/V4/Prog.lean     |  22 +-
 .../RoseTreeMachine/V4/Simulations.lean       | 102 +++++++
 .../Machines/RoseTreeMachine/V4/StackSim.lean | 205 ++++++++++++++
 .../Machines/RoseTreeMachine/V4/Tools.lean    | 133 +++++++++
 .../RoseTreeMachine/V4/UniversalTM.lean       | 159 +++++++++++
 8 files changed, 1079 insertions(+), 24 deletions(-)
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/InPlaceSim.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/PB.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/StackSim.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/Tools.lean
 create mode 100644 Cslib/Computability/Machines/RoseTreeMachine/V4/UniversalTM.lean

diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index a5f13241f8..d04c5259b6 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -409,23 +409,23 @@ lemma configs_isSome_of_haltsAtStep
   grind [haltsAtStep]
 
 
-@[simp]
-public lemma haltsOn_of_eval_eq_some
-    {tm : MultiTapeTM k Symbol} {tapes tapes' : Fin k → BiTape Symbol}
-    (h_eval : tm.eval tapes = .some tapes') :
-  tm.HaltsOn tapes := by
-  simp only [eval, Part.eq_some_iff, Part.mem_mk_iff] at h_eval
-  exact h_eval.1
-
-/-- Execute the Turing machine `tm` that always halts on initial tapes `tapes` and
-return the resulting tapes. -/
-@[expose, simp]
-public def eval_tot
-    (tm : MultiTapeTM k Symbol)
-    (h_alwaysHalts : ∀ tapes, tm.HaltsOn tapes)
-    (tapes : Fin k → BiTape Symbol) :
-    Fin k → BiTape Symbol :=
-  (tm.eval tapes).get (h_alwaysHalts tapes)
+-- @[simp]
+-- public lemma haltsOn_of_eval_eq_some
+--     {tm : MultiTapeTM k Symbol} {tapes tapes' : Fin k → BiTape Symbol}
+--     (h_eval : tm.eval tapes = .some tapes') :
+--   tm.HaltsOn tapes := by
+--   simp only [eval, Part.eq_some_iff, Part.mem_mk_iff] at h_eval
+--   exact h_eval.1
+
+-- /-- Execute the Turing machine `tm` that always halts on initial tapes `tapes` and
+-- return the resulting tapes. -/
+-- @[expose, simp]
+-- public def eval_tot
+--     (tm : MultiTapeTM k Symbol)
+--     (h_alwaysHalts : ∀ tapes, tm.HaltsOn tapes)
+--     (tapes : Fin k → BiTape Symbol) :
+--     Fin k → BiTape Symbol :=
+--   (tm.eval tapes).get (h_alwaysHalts tapes)
 
 end MultiTapeTM
 
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/InPlaceSim.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/InPlaceSim.lean
new file mode 100644
index 0000000000..51f41f4b42
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/InPlaceSim.lean
@@ -0,0 +1,255 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Prog
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.PB
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Tools
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+
+/-! # Simulating a Prog in an InPlace Prog
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+section InPlaceSim
+
+open PB
+
+
+/- ===================== derived data/value combinators ===================== -/
+def el0 := PB.head
+def el1 (s : PB) : PB := PB.head (PB.tail s)
+def el2 (s : PB) : PB := PB.head (PB.tail (PB.tail s))
+def el3 (s : PB) : PB := PB.head (PB.tail (PB.tail (PB.tail s)))
+def wrap (a : PB) : PB := PB.cons a PB.empty
+def triT (a b c : PB) : PB := PB.cons a (PB.cons b (PB.cons c PB.empty))
+/-- Build a quadruple of values. -/
+def quad (a b c e : PB) : PB := PB.cons a (.cons b (.cons c (.cons e .empty)))
+def isNilT (x a b : PB) : PB := iteT x PB.empty a b                  -- x = [] ? a : b
+def litT : Data → PB | .l xs => xs.foldr (fun x acc => PB.cons (litT x) acc) PB.empty
+
+def tagT (t : Nat) (x : PB) : PB := PB.toPair (natT t) x               -- tagged = [tag, payload]
+def tagOf (v : PB) : PB := el0 v
+def payOf (v : PB) : PB := el1 v
+
+/-- Variables are encoded in unary to make environment access easier. -/
+def encodeUnary : ℕ → Data
+  | 0 => .l []
+  | k + 1 => .l [encodeUnary k]
+
+def unarySucc : PB → PB := wrap
+def unaryPred : PB → PB := .head
+
+/-- Computes `list.getElem?[index]` where `index` is encoded in unary. -/
+def getElemUnary (list index : PB) : PB := .snd (PB.while_ (PB.toPair index list)
+  (fun st => PB.elim st .empty (fun index list =>
+    .ifEq index (.constant (encodeUnary 0))
+       (.head list)
+       (.toPair (unaryPred index) (PB.tail list)))))
+
+/- ===================== encodings ===================== -/
+def MODE_EVAL : Nat := 0
+def MODE_APPLY : Nat := 1
+-- value tags
+def dvPay (v : PB) : PB := payOf v                                -- the underlying list
+def cloBody (v : PB) : PB := el0 (payOf v)
+def cloEnv  (v : PB) : PB := el1 (payOf v)
+
+-- frame tags
+def FPB.cons:Nat:=0  def FConsH:Nat:=1  def FElim:Nat:=2  def FIfY:Nat:=3
+def FIfC:Nat:=4    def FAppF:Nat:=5   def FAppA:Nat:=6  -- FFold:=7, FWhile:=8 (SKETCH)
+def frPB.cons (t e : PB) := tagT FPB.cons (PB.toPair t e)
+def frConsH (h : PB)   := tagT FConsH (wrap h)
+def frElim (em cs e : PB) := tagT FElim (triT em cs e)
+def frIfY (y t e ev : PB) := tagT FIfY (quadT y t e ev)
+def frIfC (xv t e ev : PB) := tagT FIfC (quadT xv t e ev)
+def frAppF (a ev : PB) := tagT FAppF (PB.toPair a ev)
+def frAppA (clo : PB)  := tagT FAppA (wrap clo)
+
+-- tags for encoding the inductive type
+def tagVar : ℕ := 0
+def tagEmpty : ℕ := 1
+def tagCons : ℕ := 2
+def tagElim : ℕ := 3
+def tagWhile : ℕ := 4
+def tagFn : ℕ := 5
+def tagApp : ℕ := 6
+
+def encodeProg : Prog → Data
+  | .var i => .l [DataEncode.encode tagVar, encodeUnary i]
+  | .empty => .l [DataEncode.encode tagEmpty]
+  | .cons h t => .l [DataEncode.encode tagCons, encodeProg h, encodeProg t]
+  | .elim v e c => .l [DataEncode.encode tagElim, encodeProg v, encodeProg e, encodeProg c]
+  | .while_ i b => .l [DataEncode.encode tagWhile, encodeProg i, encodeProg b]
+  | .fn b => .l [DataEncode.encode tagFn, encodeProg b]
+  | .app f a => .l [DataEncode.encode tagApp, encodeProg f, encodeProg a]
+
+
+instance : DataEncode Prog where
+  encode := encodeProg
+  h_inj := by sorry
+
+def tagData : ℕ := 0
+def tagClosure : ℕ := 1
+def encodeValue : Value → Data
+  | .data d => .l [DataEncode.encode tagData, d]
+  | .closure env body =>
+      .l [DataEncode.encode tagClosure, Data.l (env.map encodeValue), encodeProg body]
+
+instance : DataEncode Value where
+  encode := encodeValue
+  h_inj := by sorry
+
+def mkValueData (x : PB) : PB := .cons (.constantEnc tagData) x
+def mkValueClosure (body env : PB) : PB := .cons (.constantEnc tagClosure) (.toPair body env)
+
+inductive Op
+  | eval (p : Prog) (env : List Values)
+  | cons
+  | elim
+  | while_
+  | fn
+  | app
+
+structure State where
+   ops : List Op
+   values : List Value
+   env : List Value
+
+def simulate (s : State) : State :=
+  match (s.ops, s.values) with
+  | (.eval p env :: rops, values) => sorry
+  | (.cons :: rops, (.data hd) :: (.data tl) :: values) =>
+      ⟨rops, (.data (Data.l (hd :: tl.asList))) :: values, s.env⟩
+  | (.elim :: rops, (.data v) :: (.closure em emEnv) :: (.closure cs csEnv :: values)) =>
+       match v with
+        | Data.l [] => ⟨(.eval em emEnv) :: rops, values, s.env⟩
+        | Data.l (hd :: tl) =>
+            let cEnv := [Value.data hd, Value.data (Data.l tl)] ++ s.env
+            match cs with
+             | .closure cEnv' cBody =>
+                 ⟨rops, Value.empty :: values, cEnv ++ cEnv'⟩
+             | _ => ⟨rops, Value.empty :: values, s.env⟩
+        | _ => ⟨rops, Value.empty :: values, s.env⟩
+  match s.prog with
+   | .var i => (ops, (env[(i : ℕ)]?.getD (Value.data (.l []))) :: values)
+   | .empty => (ops, (.data (Data.l [])) :: values)
+   | .cons h t => Data.l [simulate h env, simulate t env]
+   | .elim v e c =>
+       match simulate v env with
+        | Data.l [] => simulate e env
+        | Data.l (hd :: tl) =>
+            let cVal := simulate c env
+            match cVal with
+             | Value.closure cEnv cBody =>
+                 simulate cBody (Value.data hd :: Value.data (Data.l tl) :: cEnv)
+             | _ => Value.empty
+
+/-- Evaluate a program into a stack element. -/
+def modeEval : ℕ := 0
+/-- Apply the operation on the top of the stack. -/
+def modeApply : ℕ := 1
+
+/- ===================== machine ===================== -/
+def mkState (m : ℕ) (prog env stack : PB) : PB :=
+    quad (PB.constantEnc m) prog env stack
+def evalS (cv env stk : PB) := mkState modeEval cv env stk
+def pushApply (v stack : PB) := mkState modeApply v PB.empty stack          -- env unused in APPLY
+def push (f stk : PB) : PB := PB.cons f stk
+
+def cases (n : PB) (caseList : List (Nat × PB)) (default : PB) : PB := match caseList with
+  | [] => default
+  | (tag, f) :: rest => PB.ifEq
+      n (PB.constantEnc tag) f (cases n rest default)
+
+/-- Flatten the program into the operation stack. -/
+def flatten (prog env stack : PB) : PB :=
+  cases (.head prog) [
+     (tagVar,
+  ] (.empty)
+
+def evalStep (prog env stack : PB) : PB :=
+  cases (.head prog) [
+    (tagVar, pushApply stack (getElemUnary env (.tail prog))),
+    (tagEmpty, pushApply (mkValueData PB.empty) stack),
+    (Ncons,  letT (payOf cv) (fun p =>                                  -- p = [h, t]
+               evalS (el0 p) env (push (frPB.cons (el1 p) env) stk))),
+    (Nelim,  letT (payOf cv) (fun p =>                                  -- p = [v, em, cs]
+               evalS (el0 p) env (push (frElim (el1 p) (el2 p) env) stk))),
+    (NifEq,  letT (payOf cv) (fun p =>                                  -- p = [x, y, t, e]
+               evalS (el0 p) env (push (frIfY (el1 p) (el2 p) (el3 p) env) stk))),
+    (Nfn,    pushApply (mkValueClosure (payOf prog) env) stack),                          -- capture (copy) env
+    (Napply, letT (payOf cv) (fun p =>                                  -- p = [f, a]
+               evalS (el0 p) env (push (frAppF (el1 p) env) stk)))
+    -- (Nfold, Nwhile): SKETCH — push frFold [body, remaining, acc, env] / frWhile [body, env]
+    --   and iterate exactly like a fold/while frame; same pattern as below, see notes.
+  ] (pushApply prog PB.empty)                                                  -- stuck ⇒ halt
+
+/-- APPLY mode: `v` flows into the top stack frame. -/
+def applyStep (v stk : PB) : PB :=
+  letT (PB.head stk) (fun f => letT (PB.tail stk) (fun rest =>
+    caseTag f [
+      (FPB.cons, letT (payOf f) (fun p =>                                 -- p = [t, env']
+                 evalS (el0 p) (el1 p) (push (frConsH v) rest))),
+      (FConsH, letT (payOf f) (fun p =>                                 -- p = [hv]; v = tail value
+                 applyS (dvT (PB.cons (el0 p) (dvPay v))) rest)),
+      (FElim,  letT (payOf f) (fun p =>                                 -- p = [em, cs, env']; v = scrut
+                 letT (dvPay v) (fun xs =>
+                   isNilT xs
+                     (evalS (el0 p) (el2 p) rest)                       -- nil ⇒ em
+                     (evalS (el1 p)                                     -- cons ⇒ cs, env' + [hd, tl]
+                        (PB.cons (PB.head xs) (PB.cons (dvT (PB.tail xs)) (el2 p))) rest)))),
+      (FIfY,   letT (payOf f) (fun p =>                                 -- p = [y, t, e, env']; v = x
+                 evalS (el0 p) (el3 p) (push (frIfC v (el1 p) (el2 p) (el3 p)) rest))),
+      (FIfC,   letT (payOf f) (fun p =>                                 -- p = [xv, t, e, env']; v = y
+                 iteT (el0 p) v (evalS (el1 p) (el3 p) rest)
+                                 (evalS (el2 p) (el3 p) rest))),
+      (FAppF,  letT (payOf f) (fun p =>                                 -- p = [a, env']; v = closure
+                 evalS (el0 p) (el1 p) (push (frAppA v) rest))),
+      (FAppA,  letT (payOf f) (fun p =>                                 -- p = [clo]; v = arg value
+                 evalS (cloBody (el0 p)) (PB.cons v (cloEnv (el0 p))) rest)) -- enter body, arg::cenv
+      -- (FFold, FWhile): SKETCH — step the loop, re-push or fall through.
+    ] (applyS v PB.empty)))                                               -- stuck ⇒ halt
+
+/-- final = APPLY mode with empty stack. -/
+def isFinalThen (s a b : PB) : PB :=
+  iteT (el0 s) (natT MODE_APPLY) (isNilT (el3 s) a b) b
+
+def step (s : PB) : PB :=
+  letT (el0 s) (fun mode => letT (el1 s) (fun cv => letT (el2 s) (fun env => letT (el3 s) (fun stk =>
+    iteT mode (natT MODE_EVAL) (evalStep cv env stk) (applyStep cv stk)))))
+
+/- ===================== boundary passes (SKETCH) ===================== -/
+-- raw input Data ⟶ tagged value (wrap every node as `dvT`); a tree traversal using the
+-- same stack-machine pattern as above. Placeholder shown; replace with the traversal.
+def wrapVal (x : PB) : PB := mkValueData x          -- SKETCH: only correct for flat lists of nils
+def unwrapVal (v : PB) : PB := dvPay v       -- SKETCH: inverse traversal
+
+/- ===================== top-level interpreter ===================== -/
+/-- `interpFor p : Prog` runs FProg `p` (baked in as a Data literal) on the input (var 0).
+    For a *universal* interpreter, read `p` from the input instead of `litT p`. -/
+def interpFor (p : FProg) : Prog :=
+  ( letT (evalS (litT (enc p)) (oneT (wrapVal (V 0))) PB.empty) (fun s0 =>
+      letT (whileT s0 (fun s => isFinalThen s PB.empty (step s))) (fun fin =>
+        unwrapVal (el1 fin))) ) 1
+
+end RTM
+
+end InPlaceSim
+
+end V4
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/PB.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/PB.lean
new file mode 100644
index 0000000000..eee36cf745
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/PB.lean
@@ -0,0 +1,193 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Prog
+
+/-! # RoseTreeMachine V4 — PB (program builder)
+
+A thin builder layer over the de-Bruijn-levelled `Prog`. Because V4 has a single binder
+(`fn`), the builder needs exactly one HOAS combinator, `PB.fn`; every other construct is a
+trivial structural lift. The env-extending binders `elim`/`while_` keep the *same ergonomic
+HOAS signatures* as in the first-order development, but now emit the in-place functional form
+(`fn`/`fn (fn …)`), so existing program-construction code ports almost verbatim while
+compiling to the functional language.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+/-- A program builder: given the current binder depth (the size of `env` at the point of
+insertion), produce a `Prog`. -/
+abbrev PB := ℕ → Prog
+
+namespace PB
+
+/-- Reference the variable at (absolute) de Bruijn level `i`. -/
+def var (i : ℕ) : PB := fun _ => .var i
+/-- The empty rose tree. -/
+def empty : PB := fun _ => .empty
+/-- Prepend `h` to the list `t`. -/
+def cons (h t : PB) : PB := fun n => .cons (h n) (t n)
+/-- The single HOAS binder: build an abstraction whose bound variable is supplied to `body`.
+The bound variable lives at the current depth `n`; the body is built at depth `n + 1`. -/
+def fn (body : PB → PB) : PB := fun n => .fn (body (var n) (n + 1))
+/-- Function application. -/
+def app (f a : PB) : PB := fun n => .app (f n) (a n)
+/-- `elim v em cs`: eliminate the list value of `v`; on `[]` run `em`, otherwise bind the
+`head` and `tail` and run `cs head tail`. The branch is emitted as the in-place curried
+function `fn (fn …)`. -/
+def elim (v em : PB) (cs : PB → PB → PB) : PB := fun n =>
+  .elim (v n) (em n) (.fn (.fn (cs (var n) (var (n + 1)) (n + 2))))
+/-- `while_ init body`: iterate `body` over the accumulator. The body is emitted as the
+in-place one-argument function `fn …`. -/
+def while_ (init : PB) (body : PB → PB) : PB := fun n =>
+  .while_ (init n) (.fn (body (var n) (n + 1)))
+
+/-- Close a builder into a concrete `Prog`. -/
+def build (p : PB) : Prog := p 0
+
+end PB
+
+/-! ### Resource-erased (`ProgSem`-based) semantics for program builders
+
+`PB.computes env impl out` says that, under any outer extension `ext`, the builder unfolded at
+the current variable depth `(env ++ ext).length` evaluates (via `ProgSem`) to the first-order
+value `out` for *some* time and space. The first-order environment `env : List Data` is lifted
+into the value space via `Value.data`. The `∀ ext` quantifier lets a builder be plugged into a
+binder body where the environment later grows. -/
+
+/-- Resource-erased relational semantics of a program builder. -/
+def PB.computes (env : List Data) (impl : PB) (out : Data) : Prop :=
+  ∀ ext : List Data,
+    ∃ t s, ProgSem ((env ++ ext).map Value.data) (impl (env.length + ext.length))
+      (.data out) t s
+
+/-- The basic per-env consequence, instantiating `ext := []`. -/
+lemma PB.computes.here {env : List Data} {impl : PB} {out : Data}
+    (h : PB.computes env impl out) :
+    ∃ t s, ProgSem (env.map Value.data) (impl env.length) (.data out) t s := by
+  simpa using h []
+
+/-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/
+@[simp]
+lemma PB.var_computes {env : List Data} {i : ℕ} (h : i < env.length) :
+    PB.computes env (PB.var i) env[i] := by
+  intro ext
+  simp only [PB.var]
+  have hval : ((env ++ ext).map Value.data)[i]?.getD Value.empty = Value.data env[i] := by
+    rw [List.getElem?_map, List.getElem?_append_left h, List.getElem?_eq_getElem h]
+    rfl
+  exact ⟨_, _, hval ▸ ProgSem.var⟩
+
+@[simp]
+lemma PB.empty_computes {env : List Data} :
+    PB.computes env PB.empty (Data.l []) := by
+  intro ext
+  exact ⟨2, 2, ProgSem.empty⟩
+
+@[simp]
+lemma PB.cons_computes {env : List Data} {h t : PB} {dh dt : Data}
+    (hh : PB.computes env h dh) (ht : PB.computes env t dt) :
+    PB.computes env (PB.cons h t) (Data.l (dh :: dt.asList)) := by
+  intro ext
+  obtain ⟨th, sh, hh'⟩ := hh ext
+  obtain ⟨tt, st, ht'⟩ := ht ext
+  exact ⟨_, _, ProgSem.cons hh' ht'⟩
+
+/-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`. -/
+@[simp]
+lemma PB.var_computesFun {env binds : List Data} {j : ℕ} (ext : List Data) :
+    ∃ t s, ProgSem ((env ++ ext ++ binds).map Value.data)
+      (.var (env.length + ext.length + j)) (.data (binds[j]?.getD (Data.l []))) t s := by
+  have hval : ((env ++ ext ++ binds).map Value.data)[env.length + ext.length + j]?.getD Value.empty
+      = Value.data (binds[j]?.getD (Data.l [])) := by
+    rw [List.getElem?_map]
+    have e1 : env.length + ext.length + j = (env ++ ext).length + j := by
+      simp [List.length_append]
+    rw [e1, List.getElem?_append_right (Nat.le_add_right _ _), Nat.add_sub_cancel_left]
+    cases binds[j]? <;> rfl
+  exact ⟨_, _, hval ▸ ProgSem.var⟩
+
+/-- The code in `body` computes a function of two arguments `x`, `y` and returns `out`. -/
+def PB.computesFun₂ (env : List Data) (x y : Data) (body : PB → PB → PB) (out : Data) : Prop :=
+  ∀ ext : List Data, ∃ t s, ProgSem ((env ++ ext ++ [x, y]).map Value.data)
+    (body (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))
+      (env.length + ext.length + 2))
+    (.data out) t s
+
+/-- The code in `body` computes a function of one argument `x` and returns `out`. -/
+def PB.computesFun₁ (env : List Data) (x : Data) (body : PB → PB) (out : Data) : Prop :=
+  ∀ ext : List Data, ∃ t s, ProgSem ((env ++ ext ++ [x]).map Value.data)
+    (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1))
+    (.data out) t s
+
+/-- `elim`, nil branch: `v` computes `[]`, so the empty branch `em` runs. -/
+@[simp]
+lemma PB.elim_nil_computes {env : List Data} {v em : PB} {cs : PB → PB → PB} {out : Data}
+    (hv : PB.computes env v (Data.l []))
+    (hem : PB.computes env em out) :
+    PB.computes env (PB.elim v em cs) out := by
+  intro ext
+  obtain ⟨tv, sv, hv'⟩ := hv ext
+  obtain ⟨tem, sem, hem'⟩ := hem ext
+  simp only [PB.elim]
+  exact ⟨_, _, ProgSem.elim_nil hv' hem'⟩
+
+/-- `elim`, cons branch: `v` computes `head :: tail`, so the curried branch `cs` is applied to
+`head` and then to `tail` (each application running an `fn` body in the extended environment). -/
+@[simp]
+lemma PB.elim_cons_computes {env : List Data} {v em : PB} {cs : PB → PB → PB}
+    {head : Data} {tail : List Data} {out : Data}
+    (hv : PB.computes env v (Data.l (head :: tail)))
+    (hcs : PB.computesFun₂ env head (Data.l tail) cs out) :
+    PB.computes env (PB.elim v em cs) out := by
+  intro ext
+  obtain ⟨tv, sv, hv'⟩ := hv ext
+  obtain ⟨tr, sr, hb⟩ := hcs ext
+  simp only [PB.elim]
+  have hmap : ((env ++ ext).map Value.data ++ [Value.data head]) ++ [Value.data (Data.l tail)]
+      = (env ++ ext ++ [head, Data.l tail]).map Value.data := by
+    simp
+  have hb' : ProgSem
+      (((env ++ ext).map Value.data ++ [Value.data head]) ++ [Value.data (Data.l tail)])
+      (cs (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1))
+        (env.length + ext.length + 2))
+      (.data out) tr sr := by
+    rw [hmap]; exact hb
+  exact ⟨_, _, ProgSem.elim_cons hv' ProgSem.fn (AppSem.mk ProgSem.fn) (AppSem.mk hb')⟩
+
+/-- In-place application of a literal abstraction (a `let` binding): if `arg` computes `dx`
+and `body` computes `out` with its parameter bound to `dx`, then `app (fn body) arg` computes
+`out`. -/
+lemma PB.app_fn_computes {env : List Data} {body : PB → PB} {arg : PB} {dx out : Data}
+    (harg : PB.computes env arg dx)
+    (hbody : PB.computesFun₁ env dx body out) :
+    PB.computes env (PB.app (PB.fn body) arg) out := by
+  intro ext
+  obtain ⟨ta, sa, ha⟩ := harg ext
+  obtain ⟨tb, sb, hb⟩ := hbody ext
+  simp only [PB.app, PB.fn]
+  have hmap : (env ++ ext).map Value.data ++ [Value.data dx]
+      = (env ++ ext ++ [dx]).map Value.data := by
+    simp
+  have hb' : ProgSem ((env ++ ext).map Value.data ++ [Value.data dx])
+      (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1))
+      (.data out) tb sb := by
+    rw [hmap]; exact hb
+  exact ⟨_, _, ProgSem.app ProgSem.fn ha (AppSem.mk hb')⟩
+
+end V4
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
index e8b70afb3b..e5e66b7be8 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
@@ -7,6 +7,7 @@ Authors: Christian Reitwiessner
 module
 
 public import Cslib.Computability.Machines.RoseTreeMachine.V3.Data
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
 
 @[expose] public section
 
@@ -59,7 +60,7 @@ inductive Value where
   | data (d : Data)
   /-- A closure: the environment `env` captured when the enclosing `fn` was evaluated,
       paired with the abstraction's `body`. -/
-  | closure (env : List Value) (body : Prog)
+  | closure (body : Prog) (env : List Value)
 deriving Repr
 
 /-- Size (encoding length) of a value. Mirrors `Data.size` on first-order data; a closure
@@ -67,7 +68,7 @@ costs a small constant plus the sizes of its captured environment (the body is t
 constant-size code pointer and not counted). -/
 def Value.size : Value → ℕ
   | .data d => d.size
-  | .closure env _ => 2 + (env.map Value.size).sum
+  | .closure _ env => 2 + (env.map Value.size).sum
 
 /-- The empty first-order value. -/
 abbrev Value.empty : Value := .data (Data.l [])
@@ -115,10 +116,12 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop
         (max (max s_init s_body) s_w)
   /-- `fn body`: evaluate to a closure capturing the current environment `σ`. The cost is the
       size of the resulting closure (mirroring `var`, which charges the size of the value it
-      produces). -/
+      produces).
+      TODO: We could charge only the size of the referenced variables, which would make it
+      more or less free to create a non-capturing closure. -/
   | fn :
-      ProgSem σ (.fn body) (.closure σ body)
-        (Value.closure σ body).size (Value.closure σ body).size
+      ProgSem σ (.fn body) (.closure body σ)
+        (Value.closure body σ).size (Value.closure body σ).size
   /-- `app fn arg`: evaluate `fn` to a closure, evaluate `arg` to a value, then run the
       closure's body in the *captured* environment extended with the argument (static
       scoping). -/
@@ -133,7 +136,7 @@ closure `f` to the argument `v` yields `r` using `t` time and `s` space. Only cl
 applied; applying a first-order value has no derivation (the program is stuck). -/
 inductive AppSem : Value → Value → Value → ℕ → ℕ → Prop
   | mk (h_body : ProgSem (σ' ++ [v]) body r t s) :
-      AppSem (.closure σ' body) v r t s
+      AppSem (.closure body σ') v r t s
 
 /-- Iterates the closure `bodyVal` of a `while_` loop, threading the accumulator.
 `WhileSem bodyVal acc r t s` means that, starting from accumulator `acc`, repeatedly applying
@@ -154,9 +157,14 @@ inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop
 end
 
 /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/
-def ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop :=
+def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop :=
   ProgSem [.data x] p (.data y) t s
 
+def Prog.ComputesBoolFunInTimeAndSpace
+  (p : Prog) (f : List Bool → List Bool) (t : ℕ → ℕ) (s : ℕ → ℕ) : Prop :=
+  ∀ x, ∃ t' ≤ t x.length, ∃ s' ≤ s x.length,
+  Prog.ComputesInTimeAndSpace p (DataEncode.encode x) (DataEncode.encode (f x)) t' s'
+
 /-- The *in-place* (first-order) fragment of the functional language.
 
 `InPlace p` holds when every `fn` in `p` occurs in an immediately-consumed position — as the
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
new file mode 100644
index 0000000000..d44b848c1e
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
@@ -0,0 +1,102 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Prog
+public import Cslib.Computability.Machines.MultiTapeTuring.Basic
+
+
+/-! # RoseTreeMachine V4 — simulation theorems (statements only)
+
+This file collects the cross-model simulation statements relating the functional language
+`Prog`, its first-order fragment `InPlace`, and multi-tape Turing machines. All statements are
+currently `sorry`-ed; they record the intended theorems and their resource overheads.
+
+Each statement is phrased with the `…ComputableInTimeAndSpace` predicates, so the only remaining
+quantifier is the existentially quantified constant `a` carrying the (constant-factor or
+provisional polynomial) overhead.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+/-- A boolean function is computable by some multi-tape Turing machine within the given time and
+space bounds. -/
+def TMComputableInTimeAndSpace (f : List Bool → List Bool) (t s : ℕ → ℕ) : Prop :=
+  ∃ (k : ℕ) (tm : MultiTapeTM k Bool), tm.ComputesFunInTimeAndSpace f t s
+
+/-- A boolean function is computable by some `Prog` within the given time and space bounds. -/
+def ProgComputableInTimeAndSpace (f : List Bool → List Bool) (t s : ℕ → ℕ) : Prop :=
+  ∃ (p : Prog), p.ComputesBoolFunInTimeAndSpace f t s
+
+/-- A boolean function is computable by some *in-place* `Prog` within the given time and space
+bounds. -/
+def InPlaceProgComputableInTimeAndSpace (f : List Bool → List Bool) (t s : ℕ → ℕ) : Prop :=
+  ∃ (p : Prog), InPlace p ∧ p.ComputesBoolFunInTimeAndSpace f t s
+
+/-- **In-place `Prog` → Turing machine.** An in-place program is implemented by a multi-tape
+Turing machine with only constant-factor time and space overhead.
+
+The linear *space* bound `a * s` reflects a constant-factor tape encoding of the rose-tree data.
+The linear *time* bound `a * t` is the strong part of the statement: the `Prog` cost model
+charges nothing for environment manipulation (variable access is charged by value size, binding
+`σ ++ [v]` is free), so achieving a *linear* — rather than e.g. `a * (t * s)` — time overhead
+relies on the tape encoding supporting O(1)-amortized variable addressing and environment
+extension. -/
+lemma inPlace_prog_to_tm
+    (f : List Bool → List Bool) (t s : ℕ → ℕ)
+    (h_comp : InPlaceProgComputableInTimeAndSpace f t s) :
+    ∃ (a : ℕ), TMComputableInTimeAndSpace f (fun n => a * t n) (fun n => a * s n) := by
+  sorry
+
+/-- **`Prog` → in-place `Prog`.** Every program is simulated by an in-place program computing the
+same function (defunctionalisation: the explicit-stack machine of `StackSim` realised as a single
+`while_` loop).
+
+Provisional overhead: making environment threading explicit multiplies time by (at most) the
+space, hence `a * (t * s)`; the space bound `a * s` assumes a shared-environment encoding that
+avoids duplicating the environment into every stack frame. -/
+lemma prog_to_inPlace
+    (f : List Bool → List Bool) (t s : ℕ → ℕ)
+    (h_comp : ProgComputableInTimeAndSpace f t s) :
+    ∃ (a : ℕ),
+      InPlaceProgComputableInTimeAndSpace f (fun n => a * (t n * s n)) (fun n => a * s n) := by
+  sorry
+
+/-- **`Prog` → Turing machine.** Corollary of `prog_to_inPlace` followed by `inPlace_prog_to_tm`:
+every program is implemented by a multi-tape Turing machine. The overhead is inherited from the
+`Prog → InPlace` step. -/
+lemma prog_to_tm
+    (f : List Bool → List Bool) (t s : ℕ → ℕ)
+    (h_comp : ProgComputableInTimeAndSpace f t s) :
+    ∃ (a : ℕ), TMComputableInTimeAndSpace f (fun n => a * (t n * s n)) (fun n => a * s n) := by
+  sorry
+
+/-- **Turing machine → in-place `Prog`.** The reverse direction (the universal-machine
+construction of `UniversalTM`): every multi-tape Turing machine is simulated by an in-place
+program.
+
+Provisional overhead: each Turing-machine step is realised by scanning the encoded tape
+configuration, costing time proportional to the space, hence `a * (t * s)`; space stays within a
+constant factor, `a * s`. -/
+lemma tm_to_inPlace_prog
+    (f : List Bool → List Bool) (t s : ℕ → ℕ)
+    (h_comp : TMComputableInTimeAndSpace f t s) :
+    ∃ (a : ℕ),
+      InPlaceProgComputableInTimeAndSpace f (fun n => a * (t n * s n)) (fun n => a * s n) := by
+  sorry
+
+end V4
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/StackSim.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/StackSim.lean
new file mode 100644
index 0000000000..1c76e22ea0
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/StackSim.lean
@@ -0,0 +1,205 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Prog
+
+/-! # RoseTreeMachine V4 — an iterative, defunctionalized simulator (no proofs)
+
+This file gives a Lean evaluator for `Prog` whose **inner step is a single non-recursive
+transition** over explicit stacks. It is a defunctionalized abstract machine in the style of a
+CEK machine: continuations are reified as a first-order list of `Instruction`s (the *control
+stack*), intermediate results live on a *value stack*, and environments are carried inside the
+`eval` instructions.
+
+The point of the exercise is that the source language's only control-flow constructs — recursion
+through `app`/`elim` and iteration through `while_` — are all expressed by *pushing further
+instructions onto the control stack*. The single `step` function never calls itself. The only
+loop is the outer driver `iterate`, which simply applies `step` until the control stack is
+empty; that loop is the analogue of an in-place `while_`.
+
+Because the source language is Turing-complete, the driver need not terminate, so it is given a
+`noncomputable` definition via classical choice (it selects the least number of steps after
+which the machine has halted, if such a number exists).
+
+No correctness statements are proved here; this is the explicit Lean model that a later
+translation into an in-place `Prog` (a single `while_` over this `step`) can target.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+namespace StackSim
+
+/-- Extract first-order data from a runtime value. Closures are not first-order; since a
+well-formed program never inspects a closure as data, they are mapped to the empty list. -/
+def valueToData : Value → Data
+  | .data d => d
+  | .closure _ _ => Data.l []
+
+/-! ### The instruction set (defunctionalized continuations)
+
+Each constructor is one kind of pending work. Evaluating a compound term never recurses: it
+simply pushes the sub-evaluations followed by the instruction that combines their results. -/
+
+/-- A single unit of pending work on the control stack. -/
+inductive Instruction where
+  /-- Evaluate `program` under `env`, pushing the resulting value. -/
+  | eval (env : List Value) (program : Prog)
+  /-- Combine the top two values (`tail` then `head`) into a `cons`. -/
+  | buildCons
+  /-- The scrutinee of an `elim` is on top of the value stack; choose the empty or the
+      cons branch, evaluating the corresponding sub-program under `env`. -/
+  | chooseElimBranch (env : List Value) (emptyBranch : Prog) (consBranch : Prog)
+  /-- Push a known value onto the value stack. Used to place the (already-evaluated)
+      arguments of an `elim` cons branch so that a uniform `apply` can consume them. -/
+  | pushValue (value : Value)
+  /-- Apply a function to an argument: the argument is on top of the value stack and the
+      function value directly below it. This single instruction serves `app`, the two
+      applications of an `elim` cons branch, and each iteration of a `while_`. -/
+  | apply
+  /-- Begin a `while_` loop: the body closure is on top of the value stack and the initial
+      accumulator below it. -/
+  | startWhile
+  /-- One halting check of a `while_` loop carrying its body closure; the current accumulator
+      is on top of the value stack. -/
+  | whileStep (bodyClosure : Value)
+
+/-- The machine state: a control stack of pending instructions and a value stack of results. -/
+structure MachineState where
+  /-- Instructions still to be executed, innermost first. -/
+  control : List Instruction
+  /-- Intermediate values produced so far, most recent first. -/
+  values : List Value
+
+/-! ### The non-recursive transition function
+
+`step` pattern-matches on the top instruction and either pushes sub-instructions or consumes
+values and pushes a result. It never calls itself. Malformed configurations (an out-of-range
+variable, applying a non-closure, an empty stack where a value is expected) fall back to safe
+defaults rather than getting stuck, which keeps the function total. -/
+
+/-- One transition of the abstract machine. This function is deliberately non-recursive: every
+form of control flow in the source language is realised by pushing further instructions. -/
+def step (state : MachineState) : MachineState :=
+  match state.control with
+  | [] => state
+  | instruction :: remainingControl =>
+    match instruction with
+    | .eval env program =>
+      match program with
+      | .var index =>
+        let lookupIndex : ℕ := index
+        { control := remainingControl,
+          values := (env[lookupIndex]?.getD Value.empty) :: state.values }
+      | .empty =>
+        { control := remainingControl, values := Value.empty :: state.values }
+      | .cons head tail =>
+        { control := .eval env head :: .eval env tail :: .buildCons :: remainingControl,
+          values := state.values }
+      | .elim scrutinee emptyBranch consBranch =>
+        { control := .eval env scrutinee ::
+            .chooseElimBranch env emptyBranch consBranch :: remainingControl,
+          values := state.values }
+      | .while_ initial body =>
+        { control := .eval env initial :: .eval env body :: .startWhile :: remainingControl,
+          values := state.values }
+      | .fn body =>
+        { control := remainingControl, values := Value.closure body env :: state.values }
+      | .app function argument =>
+        { control := .eval env function :: .eval env argument :: .apply :: remainingControl,
+          values := state.values }
+    | .buildCons =>
+      match state.values with
+      | tailValue :: headValue :: remainingValues =>
+        { control := remainingControl,
+          values := Value.data (Data.l (valueToData headValue :: (valueToData tailValue).asList)) ::
+            remainingValues }
+      | _ => { control := remainingControl, values := state.values }
+    | .chooseElimBranch env emptyBranch consBranch =>
+      match state.values with
+      | scrutineeValue :: remainingValues =>
+        match (valueToData scrutineeValue).asList with
+        | [] =>
+          { control := .eval env emptyBranch :: remainingControl, values := remainingValues }
+        | head :: tail =>
+          { control := .eval env consBranch :: .pushValue (Value.data head) :: .apply ::
+              .pushValue (Value.data (Data.l tail)) :: .apply :: remainingControl,
+            values := remainingValues }
+      | _ => { control := remainingControl, values := state.values }
+    | .pushValue value =>
+      { control := remainingControl, values := value :: state.values }
+    | .apply =>
+      match state.values with
+      | argumentValue :: functionValue :: remainingValues =>
+        match functionValue with
+        | .closure body capturedEnv =>
+          { control := .eval (capturedEnv ++ [argumentValue]) body :: remainingControl,
+            values := remainingValues }
+        | .data _ => { control := remainingControl, values := remainingValues }
+      | _ => { control := remainingControl, values := state.values }
+    | .startWhile =>
+      match state.values with
+      | bodyClosure :: accumulator :: remainingValues =>
+        { control := .whileStep bodyClosure :: remainingControl,
+          values := accumulator :: remainingValues }
+      | _ => { control := remainingControl, values := state.values }
+    | .whileStep bodyClosure =>
+      match state.values with
+      | accumulator :: remainingValues =>
+        if (valueToData accumulator).asList.head?.getD (Data.l []) = Data.l [] then
+          { control := remainingControl, values := accumulator :: remainingValues }
+        else
+          { control := .apply :: .whileStep bodyClosure :: remainingControl,
+            values := accumulator :: bodyClosure :: remainingValues }
+      | _ => { control := remainingControl, values := state.values }
+
+/-! ### The driver
+
+The initial state evaluates `program` in the singleton env holding the `input`, exactly
+as `ComputesInTimeAndSpace` does. The machine has halted once its control stack is empty. -/
+
+/-- Build the initial machine state for running `program` on `input`. -/
+def initialState (program : Prog) (input : Data) : MachineState :=
+  { control := [.eval [Value.data input] program], values := [] }
+
+/-- The machine has finished when there is no more pending work. -/
+def isHalted (state : MachineState) : Prop := state.control = []
+
+open Classical in
+/-- Run the machine to completion. Since the source language is Turing-complete this need not
+terminate, so the definition is `noncomputable`: it iterates `step` for some number of steps
+after which the machine has halted (and returns the unmodified start state if it never halts,
+which cannot happen for a converging program). Halted states are fixed points of `step`, so any
+such step count yields the same final state. -/
+noncomputable def runToHalt (start : MachineState) : MachineState :=
+  if existence : ∃ stepCount, isHalted (Nat.iterate step stepCount start) then
+    Nat.iterate step (Classical.choose existence) start
+  else
+    start
+
+/-- Evaluate `program` on `input`, returning the resulting runtime value (the empty value if the
+machine never halts or leaves no result). -/
+noncomputable def evaluateValue (program : Prog) (input : Data) : Value :=
+  (runToHalt (initialState program input)).values.headD Value.empty
+
+/-- Evaluate `program` on `input`, returning the resulting first-order data. -/
+noncomputable def evaluate (program : Prog) (input : Data) : Data :=
+  valueToData (evaluateValue program input)
+
+end StackSim
+
+end V4
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Tools.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Tools.lean
new file mode 100644
index 0000000000..e3acd82c19
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Tools.lean
@@ -0,0 +1,133 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.PB
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+
+/-! # RoseTreeMachine V4 — Tools
+
+Derived program-builder combinators. Because the V4 builder keeps the same HOAS `elim`
+signature as the first-order development, these definitions are identical to their
+counterparts there; only the underlying semantics (functional `elim`/`while_`) differs.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+/-- Returns the tail of a list-valued builder (`[]` when empty). -/
+def PB.tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl)
+
+/-- Returns the head of a list-valued builder (`Data.l []` when empty). -/
+def PB.head (x : PB) : PB := .elim x .empty (fun hd _tl => hd)
+
+@[simp]
+lemma PB.tail_computes {env : List Data} {x : PB} {dx : Data} (hx : PB.computes env x dx) :
+    PB.computes env (.tail x) (Data.l dx.asList.tail) := by
+  obtain ⟨dx⟩ := dx
+  cases dx with
+  | nil => simpa [PB.tail] using PB.elim_nil_computes hx PB.empty_computes
+  | cons hd tl =>
+    refine PB.elim_cons_computes hx ?_
+    intro ext
+    simpa [PB.computesFun₂, PB.var] using PB.var_computesFun (binds := [hd, Data.l tl]) (j := 1) ext
+
+@[simp]
+lemma PB.head_computes {env : List Data} {x : PB} {dx : Data} (hx : PB.computes env x dx) :
+    PB.computes env (PB.head x) (dx.asList.headD (Data.l [])) := by
+  obtain ⟨dx⟩ := dx
+  cases dx with
+  | nil => simpa [PB.head] using PB.elim_nil_computes hx PB.empty_computes
+  | cons hd tl =>
+    refine PB.elim_cons_computes hx ?_
+    intro ext
+    simpa [PB.computesFun₂, PB.var] using PB.var_computesFun (binds := [hd, Data.l tl]) (j := 0) ext
+
+/-! ### Further derived combinators (definitions only)
+
+These mirror the first-order development. `letIn`/`fold`/`ifEq` are *derived* in V4 from the
+in-place `elim`/`while_` builders, so they stay inside the first-order fragment. -/
+
+/-- First projection (`head`). -/
+def PB.fst (x : PB) : PB := PB.head x
+
+/-- Second projection (`head` of `tail`). -/
+def PB.snd (x : PB) : PB := PB.head (PB.tail x)
+
+/-- `Option.some` as a singleton list. -/
+def PB.some (x : PB) : PB := PB.cons x PB.empty
+
+/-- Eliminate an `Option`: on `none` (empty) run `noneCase`, on `some v` run `someCase v`. -/
+def PB.optionElim (x noneCase : PB) (someCase : PB → PB) : PB :=
+  PB.elim x noneCase (fun v _ => someCase v)
+
+/-- Build the two-element list `[a, b]` (used as an encoded pair). -/
+def PB.toPair (a b : PB) : PB := PB.cons a (PB.cons b PB.empty)
+
+/-- A `let` binding `let x := val; body x`, encoded in the first-order fragment via `elim`:
+`val` is wrapped into the singleton `[val]`, whose `cons` branch binds `x := val`. -/
+def PB.letIn (val : PB) (body : PB → PB) : PB :=
+  PB.elim (PB.cons val PB.empty) PB.empty (fun x _ => body x)
+
+/-- Program that evaluates to the constant `a`. -/
+def PB.constant (a : Data) : PB := match a with
+  | Data.l [] => .empty
+  | Data.l (x :: xs) => .cons (constant x) (constant (Data.l xs))
+
+def PB.constantEnc {α : Type} [DataEncode α] (a : α) : PB := PB.constant (DataEncode.encode a)
+
+/-- `fold body init list`: left fold of `body` (taking `acc` then `el`) over `list`.
+
+Implemented with `while_` over a `[remaining, acc]` pair: the loop halts once `remaining`
+(the *head* of the accumulator, which is what `while_` inspects) becomes empty; otherwise it
+splits off the first element `el`, updates the accumulator to `[rest, body acc el]`, and
+continues. The fold's result is the final `acc` (the second component). -/
+def PB.fold (body : PB → PB → PB) (init list : PB) : PB :=
+  PB.snd (PB.while_ (PB.toPair list init)
+    (fun st => PB.elim (PB.fst st) PB.empty
+      (fun el rest => PB.toPair rest (body (PB.snd st) el))))
+
+/-- Structural equality of two rose trees, returning the `true` sentinel `[[]]` (nonempty) or
+the `false` sentinel `[]` (empty).
+
+Implemented with a `while_` over a worklist of pairs still to compare, threaded together with
+a boolean result in a `[worklist, result]` accumulator. Each iteration pops a pair `[x, y]`
+and compares one level: matching empties continue; matching conses push the head-pair and
+tail-pair back onto the worklist; any mismatch empties the worklist (forcing the loop to halt)
+and sets the result to `false`. The loop also halts naturally once the worklist is exhausted,
+leaving the result `true`. -/
+def PB.eq (a b : PB) : PB :=
+  PB.snd (PB.while_
+    (PB.toPair (PB.cons (PB.toPair a b) PB.empty) (PB.some PB.empty))
+    (fun acc =>
+      PB.elim (PB.fst acc) PB.empty (fun pair rest =>
+        PB.elim (PB.fst pair)
+          (PB.elim (PB.snd pair)
+            (PB.toPair rest (PB.snd acc))
+            (fun _ _ => PB.toPair PB.empty PB.empty))
+          (fun xh xt =>
+            PB.elim (PB.snd pair)
+              (PB.toPair PB.empty PB.empty)
+              (fun yh yt =>
+                PB.toPair
+                  (PB.cons (PB.toPair xh yh) (PB.cons (PB.toPair xt yt) rest))
+                  (PB.snd acc))))))
+
+/-- If `a` and `b` are structurally equal, run `then_`, otherwise `else_`. -/
+def PB.ifEq (a b then_ else_ : PB) : PB :=
+  PB.elim (PB.eq a b) else_ (fun _ _ => then_)
+
+end V4
+
+end RoseTreeMachine
+
+end Turing
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/UniversalTM.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/UniversalTM.lean
new file mode 100644
index 0000000000..92c2de988f
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/UniversalTM.lean
@@ -0,0 +1,159 @@
+/-
+Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Christian Reitwiessner
+-/
+
+module
+
+public import Cslib.Computability.Machines.RoseTreeMachine.V4.Tools
+public import Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+public import Cslib.Foundations.Data.BiTape
+
+/-! # RoseTreeMachine V4 — UniversalTM (definitions only)
+
+A port of the universal single-tape Turing machine to the functional V4 language. This file
+contains only the program-builder *definitions* (no correctness or resource proofs); the
+removed first-order primitives `fold`/`ifEq`/`let`/`constant` are now the derived combinators
+from `V4.Tools`, so the whole construction lives in the in-place fragment.
+-/
+
+@[expose] public section
+
+namespace Turing
+
+namespace RoseTreeMachine
+
+namespace V4
+
+/-- Encoding of a direction, reusing the `Bool` encoding. -/
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => DataEncode.encode true
+    | Dir.right => DataEncode.encode false
+  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
+
+/-- Overwrite the symbol under the head of an encoded bitape. -/
+def bitape_write (t v : PB) : PB := PB.cons v t.tail
+
+/-- Prepend an optional symbol to an encoded stack tape, collapsing leading blanks. -/
+def stackTape_cons (x st : PB) : PB :=
+  PB.optionElim x
+    (PB.elim st
+      PB.empty
+      (fun _ _ => PB.cons x st))
+    (fun _ => PB.cons x st)
+
+/-- The head component of an encoded bitape. -/
+def bitape_head (t : PB) : PB := t.fst
+/-- The left component of an encoded bitape. -/
+def bitape_left (t : PB) : PB := t.snd.fst
+/-- The right component of an encoded bitape. -/
+def bitape_right (t : PB) : PB := t.snd.snd
+
+/-- Move an encoded bitape one cell to the left. -/
+def bitape_move_left (t : PB) : PB :=
+  toPair (bitape_left t).head
+    (toPair
+      (bitape_left t).tail
+      (stackTape_cons (bitape_head t) (bitape_right t)))
+
+/-- Move an encoded bitape one cell to the right. -/
+def bitape_move_right (t : PB) : PB :=
+  toPair (bitape_right t).head
+    (toPair
+      (stackTape_cons (bitape_head t) (bitape_left t))
+      (bitape_right t).tail)
+
+/-- Move an encoded bitape in the encoded direction `dir`. -/
+def bitape_move (tape dir : PB) : PB :=
+  PB.ifEq dir (constant (DataEncode.encode Dir.left))
+    (bitape_move_left tape)
+    (bitape_move_right tape)
+
+/-- Optionally move an encoded bitape, or leave it unchanged on `none`. -/
+def bitape_optionMove (t dir : PB) : PB :=
+  PB.optionElim dir
+    t
+    (fun d => bitape_move t d)
+
+/-- Evaluate a function given as a graph (list of `(x, y)` pairs) at `arg`: returns `some y`
+for the first pair whose first component equals `arg`, otherwise `none`. -/
+def eval_fun_graph (graph : PB) (arg : PB) : PB :=
+  PB.fold
+    (fun acc x =>
+      PB.optionElim acc
+        (PB.ifEq x.fst arg (PB.some x.snd) PB.empty)
+        fun _ => acc)
+    PB.empty graph
+
+/-- The state component of an encoded configuration. -/
+def cfg_state (cfg : PB) : PB := cfg.fst
+/-- The bitape component of an encoded configuration. -/
+def cfg_bitape (cfg : PB) : PB := cfg.snd
+
+/-- Evaluate the transition function (given as a nested graph) at state `q` and symbol `c`,
+returning `((write, dir), q')`. -/
+def eval_tr (tr : PB) (q c : PB) : PB :=
+  (eval_fun_graph (eval_fun_graph tr q).head c).head
+
+/-- One step of the simulated single-tape TM, given the transition graph `tr` and an encoded
+configuration `cfg`. Returns an encoded `Option Cfg` (`none`/empty signals halting). -/
+def singleTapeTM_step (tr : PB) (cfg : PB) : PB :=
+  PB.optionElim (cfg_state cfg)
+    PB.empty
+    (fun q' => PB.letIn (cfg_bitape cfg) (fun tape =>
+      PB.letIn (eval_tr tr q' tape.head) (fun tr_val =>
+        .some (toPair
+          tr_val.snd
+          (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd)))))
+
+/-- The main loop: iterate `singleTapeTM_step` until it returns `none` (halting), keeping the
+final configuration as the fixed point. -/
+def tm_main_loop (tr : PB) (cfg : PB) : PB :=
+  PB.while_ cfg
+    (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next))
+
+/-- Reverse an encoded list. -/
+def reverse (x : PB) : PB :=
+  PB.fold (fun acc el => PB.cons el acc) PB.empty x
+
+/-- Map `f` over an encoded list. -/
+def list_map (x : PB) (f : PB → PB) : PB :=
+  reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x)
+
+/-- Discard the `none` elements of an encoded list of options. -/
+def list_reduceOption (x : PB) : PB :=
+  reverse (PB.fold
+    (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc))
+    PB.empty x)
+
+/-- The head of an encoded list as an `Option`. -/
+def list_head_option (input : PB) : PB :=
+  PB.elim input PB.empty (fun hd _tl => PB.some hd)
+
+/-- Turn an encoded input string into the initial encoded bitape. -/
+def string_to_tape (input : PB) : PB :=
+  toPair (list_head_option input) (toPair .empty (list_map input.tail PB.some))
+
+/-- The initial encoded configuration for start state `q₀` and `input`. -/
+def initial_config (q₀ : PB) (input : PB) : PB :=
+  toPair (PB.some q₀) (string_to_tape input)
+
+/-- Turn the final configuration into the output, taking the head and right part of the tape
+and discarding the blank (`none`) cells. -/
+def final_config_to_output (cfg : PB) : PB :=
+  list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))
+
+/-- A universal single-tape TM. The input is expected to be `((initialState,
+transitionFunction), input)`; if it terminates, the output is the tape contents under and to
+the right of the head. -/
+def universal_tm (input : PB) : PB :=
+  final_config_to_output
+    (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd))
+
+end V4
+
+end RoseTreeMachine
+
+end Turing

From 5bf7d076e3667eb5c2e26960ef3829c53a6830d0 Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Wed, 10 Jun 2026 12:58:28 +0200
Subject: [PATCH 105/106] generic machine simulations.

---
 .../RoseTreeMachine/V4/Simulations.lean       | 203 ++++++++++++++++++
 1 file changed, 203 insertions(+)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
index d44b848c1e..b51cfad175 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
@@ -8,6 +8,9 @@ module
 
 public import Cslib.Computability.Machines.RoseTreeMachine.V4.Prog
 public import Cslib.Computability.Machines.MultiTapeTuring.Basic
+public import Mathlib.Data.Fintype.Option
+public import Mathlib.Data.Fintype.Prod
+public import Mathlib.Data.Fintype.Pi
 
 
 /-! # RoseTreeMachine V4 — simulation theorems (statements only)
@@ -29,6 +32,12 @@ namespace RoseTreeMachine
 
 namespace V4
 
+open Classical in
+/-- The indicator function of a language. -/
+noncomputable def indicator (L : Language Bool) : List Bool → List Bool
+  | x => if x ∈ L then [true] else [false]
+
+
 /-- A boolean function is computable by some multi-tape Turing machine within the given time and
 space bounds. -/
 def TMComputableInTimeAndSpace (f : List Bool → List Bool) (t s : ℕ → ℕ) : Prop :=
@@ -95,6 +104,200 @@ lemma tm_to_inPlace_prog
       InPlaceProgComputableInTimeAndSpace f (fun n => a * (t n * s n)) (fun n => a * s n) := by
   sorry
 
+/-! ## Encoding multi-tape Turing machines and their configurations into `Data`
+
+To phrase a *single, universal* simulator program we have to feed both the machine and its
+configuration to the `Prog` as `Data`. The following `DataEncode` instances reify every component
+of a multi-tape Turing machine — directions, tapes, transition outputs, configurations — and the
+machine itself (its transition function reified as a finite lookup table). -/
+
+/-- A `Fin n`-indexed tuple is encoded through its `List.ofFn` representation. -/
+instance {n : ℕ} {α : Type} [DataEncode α] : DataEncode (Fin n → α) where
+  encode f := DataEncode.encode (List.ofFn f)
+  h_inj := by
+    intro f g h
+    have : List.ofFn f = List.ofFn g := DataEncode.h_inj h
+    exact List.ofFn_inj.mp this
+
+/-- Encoding of a direction, reusing the `Bool` encoding. -/
+instance : DataEncode Dir where
+  encode := fun
+    | Dir.left => DataEncode.encode true
+    | Dir.right => DataEncode.encode false
+  h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode]
+
+/-- A stack tape is encoded through its underlying list. -/
+instance {Symbol : Type} [DataEncode Symbol] : DataEncode (Turing.StackTape Symbol) where
+  encode t := DataEncode.encode t.toList
+  h_inj := by intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h; grind [DataEncode.h_inj h]
+
+/-- A bidirectional tape is encoded by its head symbol and its two stacks. -/
+instance {Symbol : Type} [DataEncode Symbol] : DataEncode (Turing.BiTape Symbol) where
+  encode t := DataEncode.encode (t.head, t.left, t.right)
+  h_inj := by intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h; grind [DataEncode.h_inj h]
+
+/-- A transition output is encoded by tupling its four fields. -/
+instance {k : ℕ} {State : Type} [DataEncode State] :
+    DataEncode (TransitionOut k Bool State) where
+  encode o := DataEncode.encode (o.inputMove, o.stmts, o.outS, o.q')
+  h_inj := by
+    intro ⟨i₁, s₁, o₁, q₁⟩ ⟨i₂, s₂, o₂, q₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp only [Prod.mk.injEq] at heq
+    obtain ⟨ha, hb, hc, hd⟩ := heq
+    subst ha; subst hb; subst hc; subst hd; rfl
+
+/-- A configuration is encoded by tupling its fields; the input head position is encoded by its
+underlying natural number (the input list, also part of the tuple, recovers its `Fin` type). -/
+instance {k : ℕ} {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol]
+    (tm : MultiTapeTM k Symbol) [DataEncode tm.State] : DataEncode tm.Cfg where
+  encode cfg :=
+    DataEncode.encode (cfg.state, cfg.input, (cfg.inputPos.val : ℕ), cfg.workTapes, cfg.output)
+  h_inj := by
+    intro ⟨s₁, inp₁, pos₁, w₁, out₁⟩ ⟨s₂, inp₂, pos₂, w₂, out₂⟩ h
+    have heq := DataEncode.h_inj h
+    simp only [Prod.mk.injEq] at heq
+    obtain ⟨hs, hinp, hpos, hw, hout⟩ := heq
+    subst hs; subst hinp; subst hw; subst hout
+    have : pos₁ = pos₂ := Fin.ext hpos
+    subst this; rfl
+
+/-- Encode a multi-tape Turing machine over `Bool` as `Data`: its initial state together with its
+transition function reified as a finite lookup table over the (finite) domain of state, input
+symbol and tuple of work-tape head symbols. -/
+noncomputable def encodeMachine {k : ℕ} (tm : MultiTapeTM k Bool) [DataEncode tm.State] : Data :=
+  letI : Fintype tm.State := tm.stateFintype
+  letI : Fintype (tm.State × Option Bool × (Fin k → Option Bool)) := inferInstance
+  DataEncode.encode
+    (tm.q₀,
+      (Finset.univ : Finset (tm.State × Option Bool × (Fin k → Option Bool))).toList.map
+        (fun d => (d, tm.tr d.1 d.2.1 d.2.2)))
+
+/-- **Universal step simulator.** There is a single `Prog` that, given the encoding of *any*
+multi-tape Turing machine over `Bool`, an input word and a step count `t`, outputs the encoding of
+the machine's configuration after exactly `t` steps (`none` once the machine has halted) together
+with the amount of space it has used up to that step. -/
+theorem exists_universal_step_simulator :
+    ∃ (sim : Prog),
+      ∀ {k : ℕ} (tm : MultiTapeTM k Bool) [DataEncode tm.State]
+        (input : List Bool) (t : ℕ),
+        ∃ (time space : ℕ),
+          sim.ComputesInTimeAndSpace
+            (Data.l [encodeMachine tm, DataEncode.encode input, DataEncode.encode t])
+            (DataEncode.encode
+              (tm.configs (tm.initCfg input) t, tm.spaceUsed (tm.initCfg input) t))
+            time space := by
+  sorry
+
+/-- **State-set normalisation.** Every multi-tape Turing machine is equivalent to one whose state
+set is a canonical `Fin s`: there is a machine using `Fin s` as its state set that computes the
+same functions within exactly the same time and space bounds. (Take `s` to be the cardinality of
+the original state set and transport the transition function along the resulting equivalence.) -/
+theorem exists_fin_state_tm {k : ℕ} {Symbol : Type} [Inhabited Symbol] [Fintype Symbol]
+    (tm : MultiTapeTM k Symbol) :
+    ∃ (s : ℕ) (tm' : MultiTapeTM k Symbol), tm'.State = Fin s ∧
+      ∀ (f : List Symbol → List Symbol) (t sp : ℕ → ℕ),
+        tm.ComputesFunInTimeAndSpace f t sp ↔ tm'.ComputesFunInTimeAndSpace f t sp := by
+  sorry
+
+
+def SpaceConstructible (s : ℕ → ℕ) : Prop :=
+  ∃ t a, TMComputableInTimeAndSpace (fun x => List.replicate x.length true) t (fun n => a * (s n))
+
+def LittleO (f g : ℕ → ℕ) : Prop :=
+  ∀ c > 0, ∃ N, ∀ n ≥ N, c * f n < g n
+
+def DSpace (s : ℕ → ℕ) : Set (Language Bool) :=
+    { L | ∃ t, TMComputableInTimeAndSpace (indicator L) t s}
+
+/-! ### Abstracting away the encoding: enumerations and a budgeted evaluator
+
+For the diagonalization it is cleaner to forget the concrete machine encoding and work with an
+abstract *enumeration* of string functions indexed by bit strings, together with a single
+budgeted *evaluator* that simulates the index on its input within an `s`-bounded budget. Both are
+realised by the concrete `encodeMachine` / `exists_bounded_simulator` machinery above, but the
+hierarchy theorem only needs the two abstract facts below. -/
+
+/-- An enumeration of string functions indexed by bit strings: `enum i` is the (total) function
+computed by the machine encoded by `i`, taking the fixed value `[]` on inputs where that machine
+diverges. -/
+abbrev Enumeration := List Bool → List Bool → List Bool
+
+/-- An enumeration is *complete with infinite repetition* if every Turing-computable string
+function appears as `enum i` for indices `i` of unbounded length (equivalently, infinitely often).
+Padding the machine encoding provides the arbitrarily long indices. -/
+def CompleteWithInfiniteIndices (enum : Enumeration) : Prop :=
+  ∀ (f : List Bool → List Bool) (t s : ℕ → ℕ),
+    TMComputableInTimeAndSpace f t s →
+    ∀ N, ∃ i, N ≤ i.length ∧ enum i = f
+
+/-- **Effective enumeration.** There is an enumeration of string functions in which every
+Turing-computable function appears at arbitrarily long indices. -/
+theorem exists_complete_enumeration :
+    ∃ (enum : Enumeration), CompleteWithInfiniteIndices enum := by
+  sorry
+
+/-- **Budgeted universal evaluator.** For a space-constructible `s` and any enumeration `enum`,
+there is an evaluator `eval` such that
+
+* its diagonal `i ↦ eval i i` is computable in space `O(s)` (so flipping it stays in `DSpace s`),
+  and
+* `eval i x = enum i x` whenever the machine `i` runs on `x` within the `2 ^ s(|i|)` time and
+  `s(|i|)` space budget — i.e. whenever the enumerated function's own bounds fit the budget at that
+  input (otherwise `eval` may fall back to a fixed value).
+
+This is the abstract repackaging of `exists_bounded_simulator`. -/
+theorem exists_bounded_evaluator (s : ℕ → ℕ) (hs : SpaceConstructible s) (enum : Enumeration) :
+    ∃ (eval : Enumeration) (a : ℕ) (t : ℕ → ℕ),
+      TMComputableInTimeAndSpace (fun i => eval i i) t (fun n => a * s n + a) ∧
+      ∀ (i x : List Bool) (t' s' : ℕ → ℕ),
+        TMComputableInTimeAndSpace (enum i) t' s' →
+        t' x.length ≤ 2 ^ s i.length → s' x.length ≤ s i.length →
+        eval i x = enum i x := by
+  sorry
+
+open Classical in
+/-- The intended output of the bounded simulator on machine `tm`, input `input` and threshold `σ`:
+the machine's output if it halts within `2 ^ σ` steps while staying within `σ` space, and the
+fixed datum `Data.l []` otherwise. -/
+noncomputable def boundedSimResult {k : ℕ} (tm : MultiTapeTM k Bool) (input : List Bool)
+    (σ : ℕ) : Data :=
+  if h : ∃ (output : List Bool) (τ s' : ℕ),
+      τ ≤ 2 ^ σ ∧ s' ≤ σ ∧ tm.ComputesInTimeAndSpace input output τ s' then
+    DataEncode.encode h.choose
+  else
+    Data.l []
+
+/-- **Bounded universal simulator.** If `s` is space-constructible then there is a single `Prog`
+that, on input `(x, y)` with `x` the encoding of any multi-tape Turing machine over `Bool` and `y`
+an input word, simulates the machine for at most `2 ^ s(|x|)` steps while tracking its space: if
+the machine exceeds `s(|x|)` space or fails to halt within the step budget it returns the fixed
+output `Data.l []`, otherwise it returns the machine's result. The simulator itself runs in space
+`O(s(|x|))`.
+
+This is provable from `exists_universal_step_simulator` together with space-constructibility of
+`s` (used to materialise the `s(|x|)` thresholds) and the configuration-counting bound
+`steps ≤ 2 ^ O(space)`. -/
+theorem exists_bounded_simulator (s : ℕ → ℕ) (hs : SpaceConstructible s) :
+    ∃ (bounded : Prog) (a : ℕ),
+      ∀ {k : ℕ} (tm : MultiTapeTM k Bool) [DataEncode tm.State] (input : List Bool),
+        ∃ (t' s' : ℕ),
+          s' ≤ a * s (encodeMachine tm).size + a ∧
+          bounded.ComputesInTimeAndSpace
+            (Data.l [encodeMachine tm, DataEncode.encode input])
+            (boundedSimResult tm input (s (encodeMachine tm).size))
+            t' s' := by
+  sorry
+
+theorem space_hierarchy
+   (s₁ : ℕ → ℕ)
+   (h_s₁ : SpaceConstructible s₁)
+   (h_ge : ∀ n, s₁ n ≥ n) -- TODO our restriction restriction, usually log
+   (s₂ : ℕ → ℕ)
+   (h_s₂ : SpaceConstructible s₂)
+   (h_lo : LittleO s₂ s₁) :
+   ∃ L, L ∈ (DSpace s₁) ∧ L ∉ DSpace s₂ := by
+  sorry
 end V4
 
 end RoseTreeMachine

From 55d9f058e23047276f43bf083d328a02c88e4ebb Mon Sep 17 00:00:00 2001
From: crei <crei.github@gmail.com>
Date: Wed, 10 Jun 2026 15:16:02 +0200
Subject: [PATCH 106/106] simulations

---
 .../RoseTreeMachine/V4/Simulations.lean       | 77 +++++++++++++++++--
 1 file changed, 72 insertions(+), 5 deletions(-)

diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
index b51cfad175..b08329993b 100644
--- a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
@@ -240,16 +240,16 @@ theorem exists_complete_enumeration :
 /-- **Budgeted universal evaluator.** For a space-constructible `s` and any enumeration `enum`,
 there is an evaluator `eval` such that
 
-* its diagonal `i ↦ eval i i` is computable in space `O(s)` (so flipping it stays in `DSpace s`),
-  and
+* its diagonal `i ↦ eval i i` is computable in space `s` (constant factors absorbed by tape
+  compression, so flipping it stays in `DSpace s`), and
 * `eval i x = enum i x` whenever the machine `i` runs on `x` within the `2 ^ s(|i|)` time and
   `s(|i|)` space budget — i.e. whenever the enumerated function's own bounds fit the budget at that
   input (otherwise `eval` may fall back to a fixed value).
 
 This is the abstract repackaging of `exists_bounded_simulator`. -/
 theorem exists_bounded_evaluator (s : ℕ → ℕ) (hs : SpaceConstructible s) (enum : Enumeration) :
-    ∃ (eval : Enumeration) (a : ℕ) (t : ℕ → ℕ),
-      TMComputableInTimeAndSpace (fun i => eval i i) t (fun n => a * s n + a) ∧
+    ∃ (eval : Enumeration) (t : ℕ → ℕ),
+      TMComputableInTimeAndSpace (fun i => eval i i) t s ∧
       ∀ (i x : List Bool) (t' s' : ℕ → ℕ),
         TMComputableInTimeAndSpace (enum i) t' s' →
         t' x.length ≤ 2 ^ s i.length → s' x.length ≤ s i.length →
@@ -289,6 +289,23 @@ theorem exists_bounded_simulator (s : ℕ → ℕ) (hs : SpaceConstructible s) :
             t' s' := by
   sorry
 
+/-- **Post-processing a decision.** Flipping the `[true]`/`[false]` decision read off a space-`s`
+computation stays in space `s` (the flip inspects only whether the output is `[true]`, costing
+`O(1)` extra space, absorbed by tape compression). -/
+lemma flip_decision_in_space {g : List Bool → List Bool} {t s : ℕ → ℕ}
+    (hg : TMComputableInTimeAndSpace g t s) :
+    ∃ t', TMComputableInTimeAndSpace
+      (fun x => if g x = [true] then [false] else [true]) t' s := by
+  sorry
+
+/-- **Configuration counting.** A computation that always halts within space `s` also halts within
+`2 ^ (a * s + a)` steps for some constant `a`: a halting machine cannot repeat a configuration, and
+there are at most `2 ^ O(space)` configurations. -/
+lemma time_le_exp_space {f : List Bool → List Bool} {t s : ℕ → ℕ}
+    (h : TMComputableInTimeAndSpace f t s) :
+    ∃ (a : ℕ), TMComputableInTimeAndSpace f (fun n => 2 ^ (a * s n + a)) s := by
+  sorry
+
 theorem space_hierarchy
    (s₁ : ℕ → ℕ)
    (h_s₁ : SpaceConstructible s₁)
@@ -297,7 +314,57 @@ theorem space_hierarchy
    (h_s₂ : SpaceConstructible s₂)
    (h_lo : LittleO s₂ s₁) :
    ∃ L, L ∈ (DSpace s₁) ∧ L ∉ DSpace s₂ := by
-  sorry
+  -- An enumeration in which every TM-computable function occurs at arbitrarily long indices, and a
+  -- budgeted evaluator whose diagonal lives in `DSpace s₁`.
+  obtain ⟨enum, h_complete⟩ := exists_complete_enumeration
+  obtain ⟨eval, t_diag, h_diag_space, h_faithful⟩ := exists_bounded_evaluator s₁ h_s₁ enum
+  -- The diagonalizer flips the simulated self-application, and its language `L_D`.
+  set D : List Bool → List Bool := fun x => if eval x x = [true] then [false] else [true]
+    with hD_def
+  set L_D : Language Bool := {x | eval x x ≠ [true]} with hL_def
+  have h_ind : indicator L_D = D := by
+    funext x
+    simp only [indicator, hD_def, hL_def, Set.mem_setOf_eq]
+    by_cases hx : eval x x = [true] <;> simp [hx]
+  refine ⟨L_D, ?_, ?_⟩
+  · -- `L_D ∈ DSpace s₁`: the flipped diagonal is computable in space `s₁`.
+    obtain ⟨t', ht'⟩ := flip_decision_in_space h_diag_space
+    exact ⟨t', by rw [h_ind, hD_def]; exact ht'⟩
+  · -- `L_D ∉ DSpace s₂`: otherwise diagonalization contradicts itself.
+    rintro ⟨t₂, h₂⟩
+    rw [h_ind] at h₂
+    -- Replace the given time bound by the exponential-in-space one (config counting).
+    obtain ⟨a, hexp⟩ := time_le_exp_space h₂
+    -- `s₂ = o(s₁)` with slack `a + 1` provides the budget, for inputs at least `N` long.
+    obtain ⟨N, hN⟩ := h_lo (a + 1) (Nat.succ_pos a)
+    -- A long enough index `i` with `enum i = D`.
+    obtain ⟨i, hi_len, hi_enum⟩ :=
+      h_complete D (fun n => 2 ^ (a * s₂ n + a)) s₂ hexp (max N (a * a + a))
+    have hmN : N ≤ i.length := le_trans (le_max_left _ _) hi_len
+    have hmaa : a * a + a ≤ i.length := le_trans (le_max_right _ _) hi_len
+    have hstrict : (a + 1) * s₂ i.length < s₁ i.length := hN i.length hmN
+    have e : (a + 1) * s₂ i.length = s₂ i.length + a * s₂ i.length := by ring
+    -- The space budget fits.
+    have hspace : s₂ i.length ≤ s₁ i.length := by omega
+    -- The time budget fits.
+    have htime_exp : a * s₂ i.length + a ≤ s₁ i.length := by
+      rcases le_or_lt a (s₂ i.length) with hle | hlt
+      · omega
+      · have hmul : a * s₂ i.length ≤ a * a := Nat.mul_le_mul (le_refl a) (le_of_lt hlt)
+        have hge : i.length ≤ s₁ i.length := h_ge i.length
+        omega
+    have htime : (2 : ℕ) ^ (a * s₂ i.length + a) ≤ 2 ^ s₁ i.length :=
+      Nat.pow_le_pow_right (by norm_num) htime_exp
+    -- Faithfulness: the evaluator reproduces `enum i i = D i`.
+    have hfaith : eval i i = enum i i :=
+      h_faithful i i (fun n => 2 ^ (a * s₂ n + a)) s₂ (by rw [hi_enum]; exact hexp) htime hspace
+    rw [hi_enum] at hfaith
+    -- `D i = if eval i i = [true] then [false] else [true]`, but `eval i i = D i`: contradiction.
+    have hDi : D i = if eval i i = [true] then [false] else [true] := by simp only [hD_def]
+    rw [hfaith] at hDi
+    by_cases hc : D i = [true]
+    · rw [if_pos hc, hc] at hDi; exact absurd hDi (by decide)
+    · rw [if_neg hc] at hDi; exact hc hDi
 end V4
 
 end RoseTreeMachine