diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml
index 7037c3c3b4..7e4702638e 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@e6128ab22cb03b509075ae46c33727e3952ffab7 # 2026-05-12
         with:
           mode: check
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/.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
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.
diff --git a/Cslib.lean b/Cslib.lean
index 5b3cef9dd5..bca1187fb2 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
@@ -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
@@ -69,6 +71,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.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.V2.WhileBounds
+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
@@ -82,7 +95,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
@@ -153,6 +169,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
@@ -169,5 +186,12 @@ 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
+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/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/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 0b2c10d3e7..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
@@ -138,20 +145,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 +173,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
@@ -177,7 +184,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/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 9aa7432c4c..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
 
@@ -167,14 +172,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/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/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/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/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean
index 48e60cb611..9f837fd73f 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`
@@ -140,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
@@ -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 7e03b8cfd5..19f637161e 100644
--- a/Cslib/Computability/Languages/ExampleEventuallyZero.lean
+++ b/Cslib/Computability/Languages/ExampleEventuallyZero.lean
@@ -26,22 +26,23 @@ 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
+set_option linter.tacticAnalysis.verifyGrindOnly false in
+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
@@ -49,7 +50,9 @@ theorem eventually_zero_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
@@ -61,27 +64,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 +95,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_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))
     constructor
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/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/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/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
index 87c5a9db3f..d04c5259b6 100644
--- a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
+++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean
@@ -6,62 +6,55 @@ 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
-import Mathlib.Order.Interval.Finset.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
 
 /-!
 # 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
 
 -/
 
+@[expose] public section
+
 open Cslib Relation
 
 namespace Turing
@@ -72,20 +65,32 @@ 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 → (Option (Option Symbol)) × (Option Dir)
+  /-- 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).
 -/
-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)
+  State : Type
   /-- finiteness of the state type -/
   [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 → (SingleTapeTM.Stmt Symbol)) × Option State))
+  q₀ : 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
 
@@ -101,153 +106,208 @@ 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 (SingleTapeTM.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]
-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 -/
-  tapes : Fin k → 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
 
+/-- 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)
 
-/-- The transition function output for a given configuration. -/
-@[expose]
-public abbrev transition (cfg : tm.Cfg) :
-  Option ((Fin k → SingleTapeTM.Stmt Symbol) × Option tm.State) := match cfg with
-| ⟨none, _⟩ =>
-  -- no transition from the halting state.
-  none
-| ⟨some q, tapes⟩ =>
-  -- If in state q, perform look up in the transition function
-  some (tm.tr q (fun i => (tapes i).head))
-
-/-- The head movements following a given configuration. -/
-@[expose]
-public abbrev headMovement (cfg : tm.Cfg) (i : Fin k) : Option Dir := do
-  ((← tm.transition cfg).1 i).movement
-
-/-- The symbols to write following a given configuration. -/
-@[expose]
-public abbrev symbolToWrite (cfg : tm.Cfg) (i : Fin k) : Option Symbol := do
-  ((← tm.transition cfg).1 i).symbol
-
-/-- The successor state of a given configuration. -/
-@[expose]
-public abbrev successorState (cfg : tm.Cfg) : Option tm.State := do
-  (←  tm.transition cfg).2
+@[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`. -/
-public 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 :=
+  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 := 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]
+    }
 
 /-- 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 : ℕ) :
-    (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = 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 => simp [step]
-  | succ n ih =>
-    simp only [Function.iterate_succ_apply', ih]
-    simp [step]
+  | zero => simp [step, h_halt]
+  | 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
-  | ⟨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]
-public def initCfg (s : List Symbol) : tm.Cfg :=
-  ⟨some tm.q₀, firstTape s⟩
+def initCfg (s : List Symbol) : tm.Cfg :=
+  ⟨some tm.q₀, s, 1, default, []⟩
 
-/-- Create an initial configuration given a tuple of tapes. -/
-@[simp]
-public 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
 
-/-- 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 :=
-  ⟨none, firstTape s⟩
+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']
 
-/-- The final configuration of a Turing machine given a tuple of tapes. -/
-@[simp]
-public def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg :=
-  ⟨none, tapes⟩
+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']
 
-/-- 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 :=
-  (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes)
+end Cfg
 
-/-- Turn a movement into an integer, where rightwards movement is positive. -/
-public def movement_to_int : Option Dir → ℤ
- | none => 0
- | some .left => -1
- | some .right => 1
+section Space
+/-! Now we define space usage and add some helper lemmas. -/
 
-/-- The position of a head relative to the initial position of zero. -/
-public def headPosition (tapes : Fin k → BiTape Symbol) (t : ℕ) (i : Fin k) : ℤ :=
-  ∑ t' : Fin (t + 1), movement_to_int ((tm.configs tapes t').bind fun cfg => tm.headMovement cfg i)
+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 movements of the work tape heads after configuration `cfg`. -/
+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 |>.2)
+
+/-- 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)
 
--- TODO shouldn't this be spaceUsed? (If yes, also change it in SingleTapeTM)
+/--
+The number of work tape cells touched by the head of tape `i` in the computation starting from
+configuration `cfg` up to step `t`.
+-/
+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 space used by a configuration is the sum of the space used by its tapes.
+The number of work tape cells touched by a computation starting from configuration
+`cfg` up to step `t`.
 -/
-public def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used
+def spaceUsed (cfg : tm.Cfg) (t : ℕ) : ℕ := ∑ i, tm.spaceUsedByTape cfg t i
+
+/-- 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]
+
+/--
+Inserting one new point `a`, adjacent to an existing point `q` of `s`, widens the spanned
+interval `max' - min'` by at most one cell.
+-/
+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
+  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.
 -/
-public 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
 
@@ -259,54 +319,46 @@ 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
-    (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. -/
-public 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 :=
-  ∃ 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
-    (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. -/
-public 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. -/
 @[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 : ℕ) :
@@ -317,7 +369,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
@@ -325,20 +377,19 @@ public lemma relatesInSteps_iff_step_iter_eq_some
         use cfg'
         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 :=
-  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. -/
-public lemma halting_step_unique
+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
@@ -346,79 +397,35 @@ public 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`. -/
-public 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
+lemma configs_isSome_of_haltsAtStep
+    {tm : MultiTapeTM k Symbol} {input : List Symbol} {t : ℕ}
+    (h_halts : tm.haltsAtStep input t) :
+    (tm.configs (tm.initCfg input) t).isSome := by
   grind [haltsAtStep]
 
-/-- The Turing machine `tm` eventually halts starting from any initial tape configuration. -/
-@[expose]
-public def HaltsOn (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : Prop :=
-  ∃ t, tm.haltsAtStep tapes t
-
-/-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes
-if it eventually halts. -/
-@[expose]
-public 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 =]
-public 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
-    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
-  · 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]
 
-@[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/V2.lean b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
new file mode 100644
index 0000000000..a327ad0a9b
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2.lean
@@ -0,0 +1,27 @@
+/-
+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 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
+
+/-!
+# RoseTreeMachine V2
+
+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 development culminates in `universal_tm`, a `PB` simulating an arbitrary
+`SingleTapeTM`, and the theorem `universal_tm_simulates_iff`.
+
+This file is just a re-export of the modules in `V2/`.
+-/
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..fcbdb11cc5
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/PB.lean
@@ -0,0 +1,492 @@
+/-
+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)
+
+
+/-! ### 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
+
+-- 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) :
+    (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_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])
+      (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
+
+@[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
+  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) :
+    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)
+
+@[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)
+      (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, 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] :=
+  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]
+
+@[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`. -/
+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
+
+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) :
+    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..4d2a39fc3d
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Prog.lean
@@ -0,0 +1,621 @@
+/-
+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`. -/
+  -- 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]`. -/
+  | 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
+    -- 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
+    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`.
+-/
+
+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..b56f16a65c
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/Tools.lean
@@ -0,0 +1,194 @@
+/-
+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_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)
+
+@[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..460beeec4e
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V2/UniversalTM.lean
@@ -0,0 +1,1161 @@
+/-
+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
+
+-- 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
+    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]
+
+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)
+
+@[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 :=
+--   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)))
+
+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_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)))))
+
+-- 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_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/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
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
new file mode 100644
index 0000000000..3a9f7141d6
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/ComputesAttr.lean
@@ -0,0 +1,52 @@
+/-
+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` 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
+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 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.
+
+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 `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 `simp only [..., computes_simp]` preprocessing step. -/
+register_simp_attr computes_simp
+
+end
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..2309d14c69
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/PB.lean
@@ -0,0 +1,346 @@
+/-
+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.ComputesAttr
+
+/-! # 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
+
+/-- 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 ., 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
+  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 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`. -/
+@[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 ., 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) :
+    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 ., 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)))
+    (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/Prog.lean b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
new file mode 100644
index 0000000000..e754278be2
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Prog.lean
@@ -0,0 +1,127 @@
+/-
+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)
+  -- 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. -/
+  | 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.
+
+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 : (List Data) → Prog → Data → ℕ → ℕ → Prop
+  | 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 + 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 + 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)
+      (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 σ p_a a t_a s_a)
+      (h_b : ProgSem σ p_b b t_b s_b)
+      (h_neq : a ≠ b)
+      (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
+
+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..3fcf6f9296
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/Tools.lean
@@ -0,0 +1,198 @@
+/-
+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)
+
+@[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
+  cases dx with
+  | nil => grind [PB.tail]
+  | cons hd tl =>
+    refine PB.elim_cons_computes hx ?_
+    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
+  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)
+
+@[computes]
+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
+
+@[computes]
+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)
+
+@[computes]
+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..162b0b5e8e
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V3/UniversalTM.lean
@@ -0,0 +1,1148 @@
+/-
+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]
+
+@[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)
+    (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)
+
+@[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)
+    (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)
+      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
+    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)
+
+@[computes]
+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
+
+@[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 :=
+  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]
+
+@[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
+  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)))
+
+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
+  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) :
+    (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
+      · 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
+
+-- 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
+  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
+    | 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
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
new file mode 100644
index 0000000000..e5e66b7be8
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Prog.lean
@@ -0,0 +1,203 @@
+/-
+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 Cslib.Computability.Machines.RoseTreeMachine.V3.DataEncode
+
+@[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 (body : Prog) (env : List Value)
+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).
+      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
+  /-- `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 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
+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
diff --git a/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
new file mode 100644
index 0000000000..b08329993b
--- /dev/null
+++ b/Cslib/Computability/Machines/RoseTreeMachine/V4/Simulations.lean
@@ -0,0 +1,372 @@
+/-
+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
+public import Mathlib.Data.Fintype.Option
+public import Mathlib.Data.Fintype.Prod
+public import Mathlib.Data.Fintype.Pi
+
+
+/-! # 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
+
+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 :=
+  ∃ (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
+
+/-! ## 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 `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) (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 →
+        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
+
+/-- **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₁)
+   (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
+  -- 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
+
+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
diff --git a/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean b/Cslib/Computability/Machines/SingleTapeTuring/Basic.lean
index 477ab60b14..debad7d43f 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
 
@@ -384,23 +384,21 @@ 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
   /-- 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 +417,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)
@@ -470,15 +468,13 @@ 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
   /-- 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 +489,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/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 bde52823e9..f8c0d2e382 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
@@ -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 ℕ) :
@@ -100,27 +103,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/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..bd0de00d3b
--- /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/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean
index 0fe0805218..90b2fea4c0 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,32 @@ 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]
+  rw [lift, FreeM.liftM]
+  simp
 
 @[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 +279,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 +288,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..65ab32302e 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 :=
@@ -461,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/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/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean
index 3274d2fcaa..12844774fa 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
@@ -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,161 +72,161 @@ 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 :=
-  { head := l.head?, left := ∅, right := StackTape.map_some l.tail }
+  { head := l.head?, left := ∅, right := StackTape.mapSome l.tail }
 
-/-- Construct a BiTape from the left (reversed) and right part. -/
-def mk₂ (l r : List Symbol) : BiTape Symbol :=
-  ⟨r.head?, StackTape.map_some l, StackTape.map_some r.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
 positive numbers are right of the head and negative are left of the head. -/
+@[scoped grind]
 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
+
+lemma get_succ (t : BiTape Symbol) (p : ℕ) : t.get (p + 1) = t.right.toList[p]?.getD none := by
+  grind [get]
 
 /-- 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
+tapes as functions `ℤ → Option Symbol` and composes better across moves. -/
+@[ext]
+lemma ext_get (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) : t₁ = t₂ := by
+  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)
-  simp only [h_head, h_left, h_right]
+  · apply StackTape.ext_get
+    intro p
+    simpa [get_succ] 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.
 -/
-def move_left (t : BiTape Symbol) : BiTape Symbol :=
+@[scoped grind =]
+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 :=
+@[scoped grind =]
+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.
 -/
+@[scoped grind =]
 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`.
 -/
+@[simp, scoped grind =]
 def optionMove : BiTape Symbol → Option Dir → BiTape Symbol
   | t, none => t
   | 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]
-
-@[simp]
-lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := by
-  simp [move_left, move_right]
-
-@[simp]
-lemma move_left_move_right_iterate (t : BiTape Symbol) (n : ℕ) :
-    (move_left^[n] (move_right^[n] t)) = t := by
-  exact Function.LeftInverse.iterate BiTape.move_right_move_left _ _
-
-@[simp]
-lemma move_right_move_left_iterate (t : BiTape Symbol) (n : ℕ) :
-    (move_right^[n] (move_left^[n] t)) = t := by
-  exact Function.LeftInverse.iterate BiTape.move_left_move_right _ _
+lemma moveLeft_moveRight (t : BiTape Symbol) : t.moveLeft.moveRight = t := by
+  simp [moveRight, moveLeft]
 
--- TODO clean up (ai)
 @[simp]
-lemma head_iterate_move_right_mk₁ (l : List Symbol) (n : ℕ) :
-    (move_right^[n] (mk₁ l)).head = l[n]? := by
-  suffices ∀ (t : BiTape Symbol) (r : List Symbol),
-      t.head = r.head? → t.right = StackTape.map_some r.tail →
-      ∀ m, (move_right^[m] t).head = r[m]? from
-    this (mk₁ l) l (by simp [mk₁, List.head?_eq_getElem?])
-      (by simp [mk₁]) n
-  intro t r h_head h_right m
-  induction m generalizing t r with
-  | zero => simpa [List.head?_eq_getElem?] using h_head
-  | succ m ih =>
-    simp only [Function.iterate_succ, Function.comp_apply, move_right]
-    cases r with
-    | nil => simp [h_right, ih _ []]
-    | cons h' t' => apply ih <;> simp [h_right]
+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
 
-@[simp]
-lemma move_left_get (t : BiTape Symbol) (p : ℤ) :
-    (t.move_left).get p = t.get (p - 1) := by
-  unfold move_left get
+@[simp, scoped grind =]
+lemma get_moveLeft (t : BiTape Symbol) (p : ℤ) : t.moveLeft.get p = t.get (p - 1) := by
+  unfold moveLeft 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) from by grind]
+    rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) by lia]
     simp
   | Int.negSucc n => simp
 
-@[simp]
-lemma move_right_get (t : BiTape Symbol) (p : ℤ) :
-    (t.move_right).get p = t.get (p + 1) := by
-  unfold move_right get
+@[simp, scoped grind =]
+lemma get_moveRight (t : BiTape Symbol) (p : ℤ) : t.moveRight.get p = t.get (p + 1) := by
+  unfold moveRight 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) =>
     rw [show Int.negSucc (n + 1) + 1 = Int.negSucc n from rfl]
     simp
 
-@[simp]
-lemma optionMove_get (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, scoped grind =]
+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]
-lemma move_right_iterate_get (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
-    (move_right^[n] t).get p = t.get (p + n):= by
+@[simp, scoped grind =]
+lemma get_moveRight_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
+    (moveRight^[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 move_left_iterate_get (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
-    (move_left^[n] t).get p = t.get (p - n):= by
+@[simp, scoped grind =]
+lemma get_moveLeft_iterate (t : BiTape Symbol) (n : ℕ) (p : ℤ) :
+    (moveLeft^[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
+    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
+    .moveRight^[Δ.toNat] t
+  else
+    .moveLeft^[(-Δ).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 head_moveInt (t : BiTape Symbol) (Δ : ℤ) :
+  (moveInt t Δ).head = t.get Δ := by
+  rw [show (moveInt t Δ).head = (moveInt t Δ).get 0 from rfl]
+  grind [moveInt]
+
 end Move
 
 /--
@@ -236,14 +234,14 @@ 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 write_get (t : BiTape Symbol) (a : Option Symbol) :
+@[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
   funext p
   match p with
   | Int.ofNat 0 => simp
-  | Int.ofNat (n + 1) => simp; grind
+  | Int.ofNat (n + 1) => grind
   | Int.negSucc n => simp
 
 /--
@@ -251,22 +249,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, StackTape.length_nil]
-  | cons h t => simp [mk₁, space_used, StackTape.length_nil, StackTape.length_map_some]; omega
+  | nil => simp [mk₁, spaceUsed, 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..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 HasFresh.of_infinite (α : 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/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 743e2f22df..262ccbbd8c 100644
--- a/Cslib/Foundations/Data/Relation.lean
+++ b/Cslib/Foundations/Data/Relation.lean
@@ -8,21 +8,26 @@ 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
+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]
@@ -37,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
@@ -69,6 +146,240 @@ 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 `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_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
+  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_cod 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_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
+
+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
+
+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
+
+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)
+
+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
+
+variable [Std.Symm r]
+
+open RightEuclidean LeftEuclidean in
+private theorem symm_equivalents : [RightEuclidean r, LeftEuclidean r, IsTrans α r].TFAE := by
+  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 :=
+  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
+
+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
 
@@ -148,6 +459,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`, i.e. `Relator.LeftTotal`. -/
+class Serial (r : α → α → Prop) where
+  serial : Relator.LeftTotal r
+
+@[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
 
@@ -176,26 +497,24 @@ 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. -/
 @[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) :
@@ -203,38 +522,92 @@ 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)
+
+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
+
+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 :=
-  ⟨ofTransGen, toTransGen⟩
+theorem Terminating.iff_transGen : Terminating (TransGen r) ↔ Terminating r := by
+  simp_rw [iff_forall_sn, SN.iff_transGen]
 
-theorem Terminating.subrelation {r' : α → α → Prop} (hr : Terminating r) (h : Subrelation r' r) :
+theorem Terminating.iff_isEmpty_chain :
+    Terminating r ↔ IsEmpty {f : ℕ → α // ∀ n, r (f n) (f (n + 1))} :=
+  wellFounded_iff_isEmpty_descending_chain
+
+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
@@ -393,7 +766,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₂⟩
@@ -472,10 +845,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 4bff37a325..05f7945719 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,36 +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
+    (h_get_eq : ∀ p : ℕ, t₁.toList[p]?.getD none = t₂.toList[p]?.getD 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
+  apply List.ext_getElem?
   grind
 
-@[simp]
-lemma nil_head : (nil : StackTape Symbol).head = none := by simp [head, nil_toList]
-
-@[simp]
-lemma nil_tail : (nil : StackTape Symbol).tail = nil := by simp [tail]
-
 @[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
@@ -182,22 +169,22 @@ 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⟩
 
 @[simp]
-lemma map_some_toList (l : List Symbol) : (map_some l).toList = l.map some := rfl
+lemma mapSome_toList (l : List Symbol) : (mapSome l).toList = l.map some := rfl
 
 @[simp]
-lemma map_some_head (l : List Symbol) : (map_some l).head = l.head? >>= some := by
+lemma mapSome_head (l : List Symbol) : (mapSome l).head = l.head? >>= some := by
   cases l with
-  | nil => simp [map_some, head]
-  | cons h t => simp [map_some, head]
+  | nil => simp [mapSome, head]
+  | cons h t => simp [mapSome, head]
 
 @[simp]
-lemma map_some_tail (l : List Symbol) : (map_some l).tail = map_some l.tail := by
+lemma mapSome_tail (l : List Symbol) : (mapSome l).tail = mapSome l.tail := by
   cases l with
-  | nil => simp [map_some, tail, nil]
-  | cons h t => simp [map_some, tail]
+  | nil => simp [mapSome, tail, nil]
+  | cons h t => simp [mapSome, tail]
 
 section Length
 
@@ -226,7 +213,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/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/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/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 5907d35b9f..2980aa9261 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,48 +62,53 @@ 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]
 
+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 (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]
+  induction h
+  · grind
+  · grind only [totalize]
 
 /-- In `totalize`, the transitions between non-sink states correspond exactly to
 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 =>
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/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
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..e777ed0ea7 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,23 +65,24 @@ 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]
 
+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₂
@@ -96,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
@@ -106,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
@@ -117,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
@@ -125,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
@@ -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 4f0635f5e8..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₁
@@ -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..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) :
@@ -124,29 +130,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]
 
@@ -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 423312304e..c24a0ab669 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. -/
@@ -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
 
@@ -176,7 +177,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 +186,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/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 e9fd87fee6..8496ba8b9e 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,47 +56,50 @@ 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 τ₂ }
 
+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 _
       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,15 +114,15 @@ 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
     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)
+  apply (soundness der [] (by grind) entailsContext_empty)
 
 end LambdaCalculus.LocallyNameless.Stlc
 
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/FullBeta.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBeta.lean
index 1b90ff1e6d..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
 
@@ -98,13 +99,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_fresh_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/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..989142ac67 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
@@ -77,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 9907b11a2f..ee2ee01d1c 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
@@ -52,31 +60,33 @@ 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]
 
 /-- 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_fresh_preserve_not_fvar]
+    grind [open_preserve_not_fvar]
   | _ => grind
 
 /-- Substitution of a fresh variable preserves an η-reduction step. -/
 @[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 5a6529c1e7..72fce48957 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. -/
@@ -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. -/
@@ -72,6 +74,19 @@ 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
+
+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
@@ -81,7 +96,19 @@ 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]
+  infer_instance
 
 /- Opening for some term at i-th bound variable increments `LcAt` by one -/
 lemma lcAt_openRec_lcAt (M N : Term Var) (i : ℕ) :
@@ -94,4 +121,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/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/MultiSubst.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/MultiSubst.lean
index 05db5bab3d..4cf0657415 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 -/
@@ -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 -/
@@ -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/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/Properties.lean
index aedd0be0b3..54b3b6c9ab 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. -/
@@ -52,41 +47,40 @@ 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
+@[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
 
-/-- 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
+/-- 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
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- 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
-  induction m generalizing k <;> grind
+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 with
+  | app => grind only [= openRec, = fv]
+  | _ => grind
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- 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
-  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
+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 with
+  | app => grind only [fv, = subst_app, = Finset.mem_union, = Finset.mem_erase]
+  | _ => 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
+lemma subst_refl (m : Term Var) (x : Var) : m[x := fvar x] = m := by
+  induction m <;> grind
 
 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. -/
@@ -134,27 +128,23 @@ 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_fresh_preserve_not_fvar, close_preserve_not_fvar, 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. -/
 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
 
diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
index 2c5f2e7dc6..6a0163c97a 100644
--- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
+++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StrongNorm.lean
@@ -24,59 +24,53 @@ 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'
 
+set_option linter.tacticAnalysis.verifyGrindOnly false in
 /-- 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 +81,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
 
@@ -99,18 +93,21 @@ 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 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]
+  | app => grind only [→ neutral_steps, sn_app]
+  | _ =>
+    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 +120,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
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..887d8f549d 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,12 +175,12 @@ 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
 
 /-- 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 +188,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 +206,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 +228,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 +247,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) :
@@ -263,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). -/
@@ -303,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)⟩
@@ -326,7 +327,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 +395,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 +418,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 +443,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 +472,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 +590,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 +641,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/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..98e825014c
--- /dev/null
+++ b/Cslib/Logics/Modal/Cube.lean
@@ -0,0 +1,140 @@
+/-
+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. -/
+@[scoped grind =]
+def K World Atom := logic (Set.univ (α := Model World Atom))
+
+/-- The modal logic T. -/
+@[scoped grind =]
+def T World Atom := logic {m : Model World Atom | Std.Refl m.r}
+
+/-- The modal logic B. -/
+@[scoped grind =]
+def B World Atom := logic {m : Model World Atom | Std.Symm m.r}
+
+/-- The modal logic 4. -/
+@[scoped grind =]
+def Four World Atom := logic {m : Model World Atom | IsTrans World m.r}
+
+/-- The modal logic 5. -/
+@[scoped grind =]
+def Five World Atom := logic {m : Model World Atom | Relation.RightEuclidean m.r}
+
+/-- The modal logic K45. -/
+@[scoped grind =]
+def K45 World Atom := (K World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
+
+/-- The modal logic D. -/
+@[scoped grind =]
+def D World Atom := logic {m : Model World Atom | Relation.Serial m.r}
+
+/-- The modal logic D4. -/
+@[scoped grind =]
+def D4 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom)
+
+/-- The modal logic D5. -/
+@[scoped grind =]
+def D5 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Five World Atom)
+
+/-- The modal logic D45. -/
+@[scoped grind =]
+def D45 World Atom := (K World Atom) ∪ (D World Atom) ∪ (Four World Atom) ∪ (Five World Atom)
+
+/-- The modal logic DB. -/
+@[scoped grind =]
+def DB World Atom := (K World Atom) ∪ (D World Atom) ∪ (B World Atom)
+
+/-- The modal logic TB. -/
+@[scoped grind =]
+def TB World Atom := (K World Atom) ∪ (T World Atom) ∪ (B World Atom)
+
+/-- The modal logic KB5. -/
+@[scoped grind =]
+def KB5 World Atom := (K World Atom) ∪ (B World Atom) ∪ (Five World Atom)
+
+/-- The modal logic S4. -/
+@[scoped grind =]
+def S4 World Atom := (K World Atom) ∪ (T World Atom) ∪ (Four World Atom)
+
+/-- The modal logic S5. -/
+@[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
+open Set
+
+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
+  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
+  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
+  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
+  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/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/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/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
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/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/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/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/CslibTests/FreeMonad.lean b/CslibTests/FreeMonad.lean
index 947fa9ff5f..6e6ce0359a 100644
--- a/CslibTests/FreeMonad.lean
+++ b/CslibTests/FreeMonad.lean
@@ -264,9 +264,9 @@ 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 liftBind _ op _ ih =>
+  · case lift_bind _ op _ ih =>
     cases op
     · case inl s => cases s <;> exact ih _ h
     · case inr s =>
@@ -285,9 +285,9 @@ 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 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
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.
diff --git a/lake-manifest.json b/lake-manifest.json
index b16de692da..16cc306345 100644
--- a/lake-manifest.json
+++ b/lake-manifest.json
@@ -5,17 +5,17 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "672768680fb7e4eff7dac7ceca12bc3889fd60fd",
+   "rev": "d568c8c09630de097a046763c17b9ea99f95f950",
    "name": "mathlib",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "672768680fb7e4eff7dac7ceca12bc3889fd60fd",
+   "inputRev": "d568c8c09630de097a046763c17b9ea99f95f950",
    "inherited": false,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/plausible",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "293af9b2a383eed4d04d66b898d608d0a44b750f",
+   "rev": "d575be693add4fe9cb996968968ce42ce75c5ccd",
    "name": "plausible",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -35,7 +35,7 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "cdab3938ccabbdb044be6896e251b5814bec932e",
+   "rev": "6db47de43aa7f516708053ae2fdadd29dd9baaaa",
    "name": "importGraph",
    "manifestFile": "lake-manifest.json",
    "inputRev": "main",
@@ -45,50 +45,50 @@
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "2db6054a44326f8c0230ee0570e2ddb894816511",
+   "rev": "85bb7e7637e84a7d9803be7d954579fdae42c64b",
    "name": "proofwidgets",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v0.0.98",
+   "inputRev": "v0.0.100",
    "inherited": true,
    "configFile": "lakefile.lean"},
   {"url": "https://github.com/leanprover-community/aesop",
    "type": "git",
    "subDir": null,
    "scope": "leanprover-community",
-   "rev": "f0c6e183ea26531e82773feb4b73ab6595ca17a5",
+   "rev": "fafca80479ff95e041d84373dda7122adf1295f2",
    "name": "aesop",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "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": "1cc7e819b9b9bc1e87c9edcccb62e0269e00a809",
+   "rev": "8d33324ee877e9735d2829bc6f1f439e60cf98b1",
    "name": "Qq",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "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": "5c57f3857ba81924a88b2cdf4f062e34ec04ff11",
+   "rev": "708b057842c4cd0845fba132bd94b08493f6fc42",
    "name": "batteries",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"},
   {"url": "https://github.com/leanprover/lean4-cli",
    "type": "git",
    "subDir": null,
    "scope": "leanprover",
-   "rev": "13567aed1ac4f12aea9484178e07e51f8c9f7658",
+   "rev": "48bdcff4c5fa27e09028f9f330e59baa0d4640cf",
    "name": "Cli",
    "manifestFile": "lake-manifest.json",
-   "inputRev": "v4.30.0-rc2",
+   "inputRev": "v4.31.0-rc1",
    "inherited": true,
    "configFile": "lakefile.toml"}],
  "name": "cslib",
diff --git a/lakefile.toml b/lakefile.toml
index 6f836bf81b..4168dea38a 100644
--- a/lakefile.toml
+++ b/lakefile.toml
@@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false
 [[require]]
 name = "mathlib"
 scope = "leanprover-community"
-rev = "672768680fb7e4eff7dac7ceca12bc3889fd60fd"
+rev = "d568c8c09630de097a046763c17b9ea99f95f950"
 
 [[lean_lib]]
 name = "Cslib"
diff --git a/lean-toolchain b/lean-toolchain
index 6c7e31fffe..8c7e931aab 100644
--- a/lean-toolchain
+++ b/lean-toolchain
@@ -1 +1 @@
-leanprover/lean4:v4.30.0-rc2
+leanprover/lean4:v4.31.0-rc1
diff --git a/references.bib b/references.bib
index 1f8c0dc518..b2d78518f8 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},
@@ -28,6 +39,28 @@ @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}
+}
+
+@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},
@@ -80,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},
@@ -107,6 +158,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},
@@ -133,6 +196,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},
@@ -275,6 +351,56 @@ @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}
+}
+
+@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},
@@ -287,3 +413,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}
+}
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"