From 37c2dd25c1b93c6362b88209507506247b003b33 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 21:21:16 +0300
Subject: [PATCH 01/25] feat(MultiTapeTM): input shortening
---
Cslib.lean | 1 +
.../Turing/MultiTape/Deterministic.lean | 7 +
.../Turing/MultiTape/InputShortening.lean | 569 ++++++++++++++++++
.../Machines/Turing/MultiTape/TapeLemmas.lean | 23 +
4 files changed, 600 insertions(+)
create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
diff --git a/Cslib.lean b/Cslib.lean
index 6c20dd086..74355b55d 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -59,6 +59,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Cslib.Computability.Machines.Turing.MultiTape.Configuration
public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic
public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic
+public import Cslib.Computability.Machines.Turing.MultiTape.InputShortening
public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic
public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas
public import Cslib.Computability.Machines.Turing.SingleTape.Defs
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 602953c79..9b303fa91 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -191,6 +191,13 @@ lemma runFrom_of_halt (cfg : Cfg k Symbol State input) (h : cfg.state = none) {n
tm.runFrom cfg n = cfg :=
Function.iterate_fixed (step_of_halt h) n
+/-- A run stays at the configuration in which it halts. -/
+lemma runFrom_eq_of_halt {cfg : Cfg k Symbol State input} {T t : ℕ} (hle : T ≤ t)
+ (hhalt : (tm.runFrom cfg T).Halted) :
+ tm.runFrom cfg t = tm.runFrom cfg T := by
+ obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hle
+ rw [runFrom_add, runFrom_of_halt _ hhalt]
+
@[simp]
lemma outputSymbol_of_halt {cfg : Cfg k Symbol State input} (h_halt : cfg.state = none) :
tm.outputSymbol cfg = none := by
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
new file mode 100644
index 000000000..5924db730
--- /dev/null
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -0,0 +1,569 @@
+/-
+Copyright (c) 2026 Aviv Bar Natan. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Aviv Bar Natan
+-/
+module
+
+public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
+public import Mathlib.Combinatorics.Pigeonhole
+public import Mathlib.Data.Finset.Sort
+public import Mathlib.Data.List.OfFn
+
+/-!
+# Input shortening for multi-tape Turing machines
+
+A visit sequence records the storages seen at a fixed input position during a finite run.
+For a halting deterministic machine these storages are distinct: repeating a core would repeat
+the rest of the computation, regardless of the write-only output.
+
+The input-shortening argument follows Gadi Aleksandrowicz's account at
+.
+-/
+
+@[expose] public section
+
+namespace Turing.MultiTapeTM
+
+variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
+variable {tm : MultiTapeTM k Symbol State}
+
+/-- Runs starting with the same core keep the same core. -/
+lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
+ (h : c₁.core = c₂.core) (t : ℕ) :
+ (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
+ induction t with
+ | zero => exact h
+ | succ t ih =>
+ simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
+
+/-- The cores up to and including the first halt are pairwise distinct. -/
+lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
+ have hle : ∀ a b, a ≤ b → b ≤ T →
+ (tm.runFrom cfg a).core = (tm.runFrom cfg b).core → a = b := by
+ intro a b hab hb heq
+ by_contra hne
+ have hlt : a < b := by omega
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ have hs := congrArg (fun c => c.2.state) heq'
+ exact hfirst (a + (T - b)) (by omega) (hs.trans hhalt)
+ intro a ha b hb hab
+ rcases le_total a b with h | h
+ · exact hle a b h hb hab
+ · exact (hle b a h ha hab.symm).symm
+
+/-- Times up to `T` at which the input head is at `p`. -/
+def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
+ (Finset.range (T + 1)).filter fun t => (tm.runFrom cfg t).inputPos.val = p
+
+@[simp]
+lemma mem_visitTimes {cfg : Cfg k Symbol State input} {T p t : ℕ} :
+ t ∈ tm.visitTimes cfg T p ↔ t ≤ T ∧ (tm.runFrom cfg t).inputPos.val = p := by
+ simp [visitTimes]
+
+/-- The chronological list of storages encountered at input position `p` through time `T`. -/
+def visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) : List (Storage Symbol State k) :=
+ ((tm.visitTimes cfg T p).sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage
+
+@[simp]
+lemma length_visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) :
+ (tm.visitSequence cfg T p).length = (tm.visitTimes cfg T p).card := by
+ simp [visitSequence]
+
+/-- No storage occurs twice at one input position before the first halt. -/
+lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) (p : ℕ) :
+ (tm.visitSequence cfg T p).Nodup := by
+ classical
+ apply List.Nodup.map_on _ (Finset.sort_nodup _ _)
+ intro a ha b hb h
+ have ha' := tm.mem_visitTimes.mp (by simpa using ha)
+ have hb' := tm.mem_visitTimes.mp (by simpa using hb)
+ apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
+ exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
+
+/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
+lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
+ (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
+ tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
+ calc tm.spaceUsed cfg T
+ _ ≤ ∑ _ : Fin k, (window R).card := by
+ apply Finset.sum_le_sum
+ intro i _
+ apply Finset.card_le_card
+ intro z hz
+ obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
+ exact mem_window.mpr (h t (by omega) i)
+ _ = k * (2 * R + 1) := by simp
+
+private lemma step_congr_storage {input' : List Symbol}
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
+ (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
+ (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
+ (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
+ (tm.step c).storage = (tm.step c').storage ∧
+ r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
+ simp only [Cfg.storage, Storage.mk.injEq] at hstore
+ obtain ⟨hstate, htapes, hpos⟩ := hstore
+ have hwork : c.workTapeSymbols = c'.workTapeSymbols := by
+ funext i
+ simp [Cfg.workTapeSymbols, htapes, hpos]
+ simp only [step, hstate, hsym, hwork]
+ cases hs : c'.state with
+ | none => exact ⟨by simp_all [Cfg.storage], hp⟩
+ | some q =>
+ exact ⟨by simp [Cfg.storage, Action.apply, htapes, hpos], hm _⟩
+
+private lemma moveInputPos_val {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
+ (moveInputPos p m).val = min (n + 1) ((p.val : ℤ) + (m.cast : ℤ)).toNat := by
+ simp only [moveInputPos]
+ split <;> simp_all <;> omega
+
+private lemma moveInputPos_bounds {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
+ (moveInputPos p m).val ≤ p.val + 1 ∧ p.val ≤ (moveInputPos p m).val + 1 := by
+ rw [moveInputPos_val]
+ have := p.isLt
+ cases m <;> simp [SignType.cast] <;> omega
+
+/-- The input head moves by at most one cell at each step. -/
+lemma inputPos_step_bounds (cfg : Cfg k Symbol State input) :
+ (tm.step cfg).inputPos.val ≤ cfg.inputPos.val + 1 ∧
+ cfg.inputPos.val ≤ (tm.step cfg).inputPos.val + 1 := by
+ unfold step
+ cases cfg.state with
+ | none => simp
+ | some q => exact moveInputPos_bounds _ _
+
+private lemma moveInputPos_same {n n' : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp : p.val = p'.val) (hn : p.val ≤ n) (hn' : p'.val ≤ n') (m : SignType) :
+ (moveInputPos p m).val = (moveInputPos p' m).val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ cases m <;> simp [SignType.cast] <;> omega
+
+private lemma moveInputPos_shift {n n' d : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp : p'.val + d = p.val) (hn : n' + d = n) (hp' : 0 < p'.val) (m : SignType) :
+ (moveInputPos p' m).val + d = (moveInputPos p m).val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ have := p.isLt
+ have := p'.isLt
+ cases m <;> simp [SignType.cast] <;> omega
+
+private lemma inputSymbol_eq_getElem? (cfg : Cfg k Symbol State input) :
+ cfg.inputSymbol = if cfg.inputPos.val = 0 then none else input[cfg.inputPos.val - 1]? := by
+ by_cases h₀ : cfg.inputPos = 0
+ · simp [Cfg.inputSymbol, h₀]
+ · have h₀' : cfg.inputPos.val ≠ 0 := fun h => h₀ (Fin.ext h)
+ rw [Cfg.inputSymbol, dite_eq_right h₀, ite_eq_right h₀']
+ split_ifs with hend
+ · simp [hend]
+ · have hi : cfg.inputPos.val - 1 < input.length := by have := cfg.inputPos.isLt; omega
+ simp [List.getElem?_eq_getElem hi]
+
+private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
+ (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State (input.take a ++ input.drop b))
+ (hc : c.inputPos.val ≤ a) (hp : c'.inputPos.val = c.inputPos.val) :
+ c.inputSymbol = c'.inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hp]
+ split_ifs with h
+ · rfl
+ · have hi : c.inputPos.val - 1 < a := by omega
+ simp [List.getElem?_append, ha, hi]
+
+private lemma inputSymbol_cut_right {a b : ℕ}
+ (ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
+ (hsym : input[a - 1]? = input[b - 1]?)
+ (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State (input.take a ++ input.drop b))
+ (hc : b ≤ c.inputPos.val) (hp : c'.inputPos.val + (b - a) = c.inputPos.val) :
+ c.inputSymbol = c'.inputSymbol := by
+ have hp₀ : c.inputPos.val ≠ 0 := by omega
+ have hp'₀ : c'.inputPos.val ≠ 0 := by omega
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀,
+ ite_eq_right hp'₀]
+ have htake : (input.take a).length = a := by simp; omega
+ by_cases heq : c.inputPos.val = b
+ · have hpa : c'.inputPos.val = a := by omega
+ simp [hpa, heq, List.getElem?_append, htake,
+ show a - 1 < a by omega, ← hsym]
+ · have hi : a ≤ c'.inputPos.val - 1 := by omega
+ have he : b + (c'.inputPos.val - 1 - a) = c.inputPos.val - 1 := by omega
+ simp [List.getElem?_append, htake, not_lt.mpr hi, he]
+
+private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
+ (hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
+ have h : ∀ d, u + d ≤ v → P (u + d) := by
+ intro d
+ induction d with
+ | zero => simpa using fun _ : u ≤ v => hu
+ | succ d ih =>
+ intro hd
+ exact hstep (u + d) (by omega) (by omega) (ih (by omega))
+ have hv : u + (v - u) = v := by omega
+ simpa [hv] using h (v - u) (by omega)
+
+private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
+ (hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
+ (hu : p u ≤ a) (hu' : p (u + 1) ≤ a)
+ (hno : ∀ t, u < t → t < v → p t ≠ a) :
+ ∀ t, u ≤ t → t ≤ v → p t ≤ a := by
+ intro t hut htv
+ apply propagate hut hu
+ intro r hur hrt hr
+ by_cases heq : r = u
+ · simpa [heq] using hu'
+ · have := hstep r hur (by omega)
+ have := hno r (by omega) (by omega)
+ omega
+
+private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
+ (hstep : ∀ t, u ≤ t → t < v → p t ≤ p (t + 1) + 1)
+ (hu : b ≤ p u) (hu' : b ≤ p (u + 1))
+ (hno : ∀ t, u < t → t < v → p t ≠ b) :
+ ∀ t, u ≤ t → t ≤ v → b ≤ p t := by
+ intro t hut htv
+ apply propagate hut hu
+ intro r hur hrt hr
+ by_cases heq : r = u
+ · simpa [heq] using hu'
+ · have := hstep r hur (by omega)
+ have := hno r (by omega) (by omega)
+ omega
+
+-- Gluing uses only the ordered visits and the fact that the head moves by at most one cell.
+-- `R` describes reachability after the cells between `a` and `b` have been removed.
+private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m : ℕ}
+ (hab : a < b) (hp₀ : p 0 ≤ a)
+ (hstep : ∀ t < T, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
+ (A B : Fin m ↪o ℕ)
+ (hA : ∀ i, A i ≤ T ∧ p (A i) = a)
+ (hB : ∀ i, B i ≤ T ∧ p (B i) = b)
+ (hAc : ∀ t ≤ T, p t = a → ∃ i, A i = t)
+ (hBc : ∀ t ≤ T, p t = b → ∃ i, B i = t)
+ (hq : ∀ i, q (A i) = q (B i))
+ (hmove : ∀ i, p (A i + 1) + b = p (B i + 1) + a)
+ (R : ℕ → S → Prop) (hR₀ : R (p 0) (q 0))
+ (hleft : ∀ t < T, p t ≤ a → p (t + 1) ≤ a →
+ R (p t) (q t) → R (p (t + 1)) (q (t + 1)))
+ (hright : ∀ t < T, b ≤ p t → b ≤ p (t + 1) →
+ R (p t - (b - a)) (q t) → R (p (t + 1) - (b - a)) (q (t + 1))) :
+ ∀ t ≤ T, p t ≤ a ∨ b ≤ p t →
+ R (if p t ≤ a then p t else p t - (b - a)) (q t) := by
+ have hba : b - (b - a) = a := by omega
+ have boundary : ∀ i, R a (q (A i)) := by
+ intro i
+ induction hi : i.val using Nat.strong_induction_on generalizing i with
+ | h n ih =>
+ by_cases hn : n = 0
+ · have hno : ∀ t < A i, p t ≠ a := by
+ intro t ht hpt
+ obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA i).1) hpt
+ have hij : i ≤ j := by change i.val ≤ j.val; omega
+ exact (not_lt_of_ge (A.monotone hij)) ht
+ have hside : ∀ t ≤ A i, p t ≤ a := by
+ intro t ht
+ apply propagate (Nat.zero_le t) hp₀
+ intro r _ hrt hr
+ have := (hstep r (by have := (hA i).1; omega)).1
+ have := hno r (by omega)
+ omega
+ have hr := propagate (Nat.zero_le (A i)) hR₀ fun t _ ht =>
+ hleft t (ht.trans_le (hA i).1) (hside t ht.le) (hside (t + 1) ht)
+ simpa [(hA i).2] using hr
+ · let j : Fin m := ⟨n - 1, by have := i.isLt; omega⟩
+ have hj : R a (q (A j)) := ih (n - 1) (by omega) j rfl
+ have hji : j < i := by change j.val < i.val; simp only [j]; omega
+ have hAj : A j < A i := A.strictMono hji
+ have hBj : B j < B i := B.strictMono hji
+ have hnoA : ∀ t, A j < t → t < A i → p t ≠ a := by
+ intro t hjt hti hpt
+ obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i).1) hpt
+ have hjr := A.lt_iff_lt.mp hjt
+ have hri := A.lt_iff_lt.mp hti
+ change j.val < r.val at hjr
+ change r.val < i.val at hri
+ simp only [j] at hjr
+ omega
+ have hnoB : ∀ t, B j < t → t < B i → p t ≠ b := by
+ intro t hjt hti hpt
+ obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i).1) hpt
+ have hjr := B.lt_iff_lt.mp hjt
+ have hri := B.lt_iff_lt.mp hti
+ change j.val < r.val at hjr
+ change r.val < i.val at hri
+ simp only [j] at hjr
+ omega
+ by_cases hdir : p (A j + 1) ≤ a
+ · have hside := walk_left
+ (fun t (_ : A j ≤ t) (ht : t < A i) =>
+ (hstep t (ht.trans_le (hA i).1)).1)
+ (le_of_eq (hA j).2) hdir hnoA
+ have hr := propagate hAj.le (show R (p (A j)) (q (A j)) by
+ simpa [(hA j).2] using hj) fun t hjt hti =>
+ hleft t (hti.trans_le (hA i).1)
+ (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
+ simpa [(hA i).2] using hr
+ · have hdir' : b ≤ p (B j + 1) := by have := hmove j; omega
+ have hside := walk_right
+ (fun t (_ : B j ≤ t) (ht : t < B i) =>
+ (hstep t (ht.trans_le (hB i).1)).2)
+ (ge_of_eq (hB j).2) hdir' hnoB
+ have hr := propagate hBj.le
+ (show R (p (B j) - (b - a)) (q (B j)) by
+ simpa [(hB j).2, hba, ← hq j] using hj) fun t hjt hti =>
+ hright t (hti.trans_le (hB i).1)
+ (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
+ simpa [(hB i).2, hba, ← hq i] using hr
+ intro t
+ induction t with
+ | zero => intro _ _; simpa [hp₀] using hR₀
+ | succ t ih =>
+ intro ht hside
+ have hst := hstep t (by omega)
+ by_cases hl : p (t + 1) ≤ a
+ · rw [ite_eq_left hl]
+ by_cases heq : p (t + 1) = a
+ · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
+ simpa [hi, heq] using boundary i
+ · have hprev : p t ≤ a := by omega
+ exact hleft t (by omega) hprev hl (by
+ simpa [hprev] using ih (by omega) (Or.inl hprev))
+ · rw [ite_eq_right hl]
+ have hr : b ≤ p (t + 1) := hside.resolve_left hl
+ by_cases heq : p (t + 1) = b
+ · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
+ simpa [hq i, hi, heq, hba] using boundary i
+ · have hprev : b ≤ p t := by omega
+ have hprev' : ¬ p t ≤ a := by omega
+ exact hright t (by omega) hprev hr (by
+ simpa [hprev'] using ih (by omega) (Or.inr hprev))
+
+private lemma moveInputPos_interior {n n' : ℕ}
+ (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
+ (m : SignType) :
+ (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ cases m <;> simp [SignType.cast] <;> omega
+
+private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
+ (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
+ (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
+ (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
+ simp [visitSequence, Finset.orderEmbOfFin_apply]
+
+/-- Deleting the cells after `a` through `b` preserves every storage reached outside the deleted
+interval, provided the symbols and visit sequences at `a` and `b` agree. Input positions are
+one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
+theorem exists_storage_cut {a b T : ℕ}
+ (ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
+ (hsym : input[a - 1]? = input[b - 1]?)
+ (hseq : tm.visitSequence (tm.initCfg input) T a =
+ tm.visitSequence (tm.initCfg input) T b)
+ {t : ℕ} (ht : t ≤ T)
+ (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ a ∨
+ b ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
+ ∃ u, (tm.runFrom (tm.initCfg (input.take a ++ input.drop b)) u).storage =
+ (tm.runFrom (tm.initCfg input) t).storage := by
+ let c := tm.runFrom (tm.initCfg input)
+ let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
+ let m := (tm.visitTimes (tm.initCfg input) T a).card
+ have hcard : (tm.visitTimes (tm.initCfg input) T b).card = m := by
+ simpa [m] using (congrArg List.length hseq).symm
+ let A := (tm.visitTimes (tm.initCfg input) T a).orderEmbOfFin rfl
+ let B := (tm.visitTimes (tm.initCfg input) T b).orderEmbOfFin hcard
+ have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
+ tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
+ tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
+ intro u hu hpu
+ have hmem := tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ have : u ∈ Set.range A := by
+ rw [Finset.range_orderEmbOfFin]
+ exact hmem
+ exact this
+ have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
+ intro u hu hpu
+ have hmem := tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ have : u ∈ Set.range B := by
+ rw [Finset.range_orderEmbOfFin]
+ exact hmem
+ exact this
+ have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
+ intro i
+ have heq := List.getElem_of_eq hseq (i := i.val)
+ (by rw [length_visitSequence]; exact i.isLt)
+ exact (visitSequence_get rfl i).symm.trans (heq.trans (visitSequence_get hcard i))
+ have hmove : ∀ i,
+ (c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
+ intro i
+ have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
+ simpa [Nat.ne_of_gt ha, show b ≠ 0 by omega] using hsym
+ have hcong := step_congr_storage (tm := tm) (hq i) hsy
+ (fun p p' => p + b = p' + a)
+ (by rw [(hA i).2, (hB i).2]; omega) (fun dir => by
+ have hm := moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
+ (by rw [(hA i).2]; exact ha) (by rw [(hA i).2]; omega)
+ (by rw [(hB i).2]; omega) (by rw [(hB i).2]; exact hb) dir
+ have := (hA i).2
+ have := (hB i).2
+ omega)
+ simpa only [c, runFrom_succ_eq_step'] using hcong.2
+ let R := fun p s => ∃ u, (c' u).inputPos.val = p ∧ (c' u).storage = s
+ have hR₀ : R (c 0).inputPos.val (c 0).storage := by
+ refine ⟨0, ?_, ?_⟩ <;> simp [c, c', Cfg.storage]
+ have hlen : (input.take a ++ input.drop b).length + (b - a) = input.length := by
+ simp only [List.length_append, List.length_take, List.length_drop]
+ omega
+ have hleft : ∀ u < T, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
+ R (c u).inputPos.val (c u).storage → R (c (u + 1)).inputPos.val (c (u + 1)).storage := by
+ rintro u _ hpu _ ⟨v, hpv, hsv⟩
+ have hsy := inputSymbol_cut_left (by omega : a ≤ input.length) (c u) (c' v) hpu hpv
+ have hcong := step_congr_storage (tm := tm) hsv.symm hsy Eq hpv.symm
+ (fun dir => moveInputPos_same (c u).inputPos (c' v).inputPos hpv.symm
+ (by omega) (by omega) dir)
+ refine ⟨v + 1, ?_, ?_⟩
+ · simpa only [c, c', runFrom_succ_eq_step'] using hcong.2.symm
+ · simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
+ have hright : ∀ u < T, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
+ R ((c u).inputPos.val - (b - a)) (c u).storage →
+ R ((c (u + 1)).inputPos.val - (b - a)) (c (u + 1)).storage := by
+ rintro u _ hpu _ ⟨v, hpv, hsv⟩
+ have hpv' : (c' v).inputPos.val + (b - a) = (c u).inputPos.val := by omega
+ have hsy := inputSymbol_cut_right ha hab hb hsym (c u) (c' v) hpu hpv'
+ have hcong := step_congr_storage (tm := tm) hsv.symm hsy
+ (fun p p' => p' + (b - a) = p) hpv'
+ (fun dir => moveInputPos_shift (c u).inputPos (c' v).inputPos hpv' hlen (by omega) dir)
+ refine ⟨v + 1, ?_, ?_⟩
+ · have hpos : (c' (v + 1)).inputPos.val + (b - a) = (c (u + 1)).inputPos.val := by
+ simpa only [c, c', runFrom_succ_eq_step'] using hcong.2
+ omega
+ · simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
+ have hglue := glue_visits (fun u => (c u).inputPos.val) (fun u => (c u).storage)
+ hab (by simp [c]; omega)
+ (fun u _ => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
+ A B hA hB hAc hBc hq hmove R hR₀ hleft hright t ht hp
+ obtain ⟨u, _, hstore⟩ := hglue
+ exact ⟨u, hstore⟩
+
+/-- Every entry of a visit sequence is a storage reached by the run. -/
+lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {T p : ℕ}
+ {s : Storage Symbol State k} (h : s ∈ tm.visitSequence cfg T p) :
+ s ∈ Set.range (fun t => (tm.runFrom cfg t).storage) := by
+ obtain ⟨t, _, rfl⟩ := List.mem_map.mp h
+ exact ⟨t, rfl⟩
+
+/-- A visit sequence of a halting space-bounded run has length at most the storage bound. -/
+lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {T s : ℕ}
+ (hhalt : (tm.runFrom (tm.initCfg input) T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom (tm.initCfg input) t).Halted)
+ (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) (p : ℕ) :
+ (tm.visitSequence (tm.initCfg input) T p).length ≤ storageBound Symbol State k s := by
+ classical
+ have hn := tm.visitSequence_nodup hhalt hfirst p
+ have hsub : ((tm.visitSequence (tm.initCfg input) T p).toFinset : Set _) ⊆
+ Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage) := by
+ intro x hx
+ exact tm.mem_range_of_mem_visitSequence (List.mem_toFinset.mp hx)
+ have hle := (Set.encard_le_encard hsub).trans (tm.encard_storages_le hs)
+ rw [Set.encard_coe_eq_coe_finsetCard, List.toFinset_card_of_nodup hn] at hle
+ exact_mod_cast hle
+
+/-- A sufficiently long input to a halting space-bounded machine can be shortened while
+preserving any designated storage reached through its first halt. -/
+theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {T s : ℕ}
+ (hhalt : (tm.runFrom (tm.initCfg input) T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom (tm.initCfg input) t).Halted)
+ (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
+ (hlen : 2 * Fintype.card Symbol *
+ (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s < input.length)
+ {t : ℕ} (ht : t ≤ T) :
+ ∃ input' : List Symbol, input'.length < input.length ∧
+ ∃ u, (tm.runFrom (tm.initCfg input') u).storage =
+ (tm.runFrom (tm.initCfg input) t).storage := by
+ classical
+ let B := storageBound Symbol State k s
+ let S := Set.range (fun u => (tm.runFrom (tm.initCfg input) u).storage)
+ have hbound : S.encard ≤ B := tm.encard_storages_le hs
+ let : Fintype S := (Set.finite_of_encard_le_coe hbound).fintype
+ have hcard : Fintype.card S ≤ B := by
+ have h := hbound
+ rw [← Set.coe_fintypeCard] at h
+ exact_mod_cast h
+ let seq := tm.visitSequence (tm.initCfg input) T
+ let enc (p : ℕ) : List S := (seq p).attachWith S
+ (fun _ h => tm.mem_range_of_mem_visitSequence h)
+ have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
+ List.attachWith_map_subtype_val _
+ have hlength (p : ℕ) : (enc p).length ≤ B := by
+ have he := congrArg List.length (henc p)
+ simp only [List.length_map] at he
+ rw [he]
+ exact tm.length_visitSequence_le hhalt hfirst hs p
+ let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
+ (input[i], fun j => (enc (i.val + 1))[j.val]?)
+ have heq {i j : Fin input.length} (h : f i = f j) :
+ input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1) := by
+ refine ⟨congrArg Prod.fst h, ?_⟩
+ have hh : enc (i.val + 1) = enc (j.val + 1) := by
+ apply List.ext_getElem?
+ intro r
+ by_cases hr : r < B
+ · exact congrFun (congrArg Prod.snd h) ⟨r, hr⟩
+ · rw [List.getElem?_eq_none (by have := hlength (i.val + 1); omega),
+ List.getElem?_eq_none (by have := hlength (j.val + 1); omega)]
+ simpa only [henc] using congrArg (List.map Subtype.val) hh
+ have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
+ Fintype.card Symbol * (B + 1) ^ B := by
+ simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
+ gcongr
+ omega
+ obtain ⟨v, hv⟩ := Fintype.exists_lt_card_fiber_of_mul_lt_card f (n := 2) (by
+ rw [Fintype.card_fin]
+ change 2 * Fintype.card Symbol * (B + 1) ^ B < input.length at hlen
+ calc Fintype.card (Symbol × (Fin B → Option S)) * 2
+ _ ≤ (Fintype.card Symbol * (B + 1) ^ B) * 2 := Nat.mul_le_mul_right 2 hsig
+ _ = 2 * Fintype.card Symbol * (B + 1) ^ B := by ring
+ _ < input.length := hlen)
+ let e := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
+ (show 3 ≤ (Finset.univ.filter (fun i => f i = v)).card by omega)
+ have he (i : Fin 3) : f (e i) = v := by
+ have hmem : e i ∈ Finset.univ.filter (fun i => f i = v) :=
+ Finset.orderEmbOfCardLe_mem _ _ i
+ exact (Finset.mem_filter.mp hmem).2
+ have hab : (e 0).val + 1 < (e 1).val + 1 := by
+ have := e.strictMono (show (0 : Fin 3) < 1 by decide)
+ exact Nat.add_lt_add_right this 1
+ have hbc : (e 1).val + 1 < (e 2).val + 1 := by
+ have := e.strictMono (show (1 : Fin 3) < 2 by decide)
+ exact Nat.add_lt_add_right this 1
+ have hab' := heq ((he 0).trans (he 1).symm)
+ have hbc' := heq ((he 1).trans (he 2).symm)
+ have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
+ (hij' : input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1))
+ (hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ i.val + 1 ∨
+ j.val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
+ ∃ input' : List Symbol, input'.length < input.length ∧
+ ∃ u, (tm.runFrom (tm.initCfg input') u).storage =
+ (tm.runFrom (tm.initCfg input) t).storage := by
+ refine ⟨input.take (i.val + 1) ++ input.drop (j.val + 1), ?_, ?_⟩
+ · simp only [List.length_append, List.length_take, List.length_drop]
+ have := i.isLt
+ have := j.isLt
+ omega
+ · exact tm.exists_storage_cut (by omega) hij (by have := j.isLt; omega)
+ (by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
+ hij'.2 ht hpos
+ by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
+ (e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
+ · exact cut hab hab' hpos
+ · exact cut hbc hbc' (Or.inl (by omega))
+
+end Turing.MultiTapeTM
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
index fcf67a3d0..08bf275c3 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
@@ -171,4 +171,27 @@ lemma exists_spaceUsedByTape_max (cfg : Cfg k Symbol State input) {s : ℕ}
exact ⟨Finset.univ.sup T, fun t i =>
(hT i t).trans (tm.spaceUsedByTape_mono cfg i (Finset.le_sup (Finset.mem_univ i)))⟩
+/-- No further work-tape cells are visited after a machine halts. -/
+lemma spaceUsed_eq_of_halt {cfg : Cfg k Symbol State input} {T t : ℕ} (hle : T ≤ t)
+ (hhalt : (tm.runFrom cfg T).Halted) :
+ tm.spaceUsed cfg t = tm.spaceUsed cfg T := by
+ apply le_antisymm ?_ (tm.spaceUsed_mono cfg hle)
+ apply Finset.sum_le_sum
+ intro i _
+ apply Finset.card_le_card
+ intro z hz
+ obtain ⟨u, hu, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
+ by_cases huT : u ≤ T
+ · exact tm.mem_visitedByTapeHead.mpr ⟨u, by omega, rfl⟩
+ · rw [tm.runFrom_eq_of_halt (by omega : T ≤ u) hhalt]
+ exact tm.mem_visitedByTapeHead_self cfg T i
+
+/-- A bound on space at a halting time bounds space throughout the run. -/
+lemma spaceUsed_le_of_halt {cfg : Cfg k Symbol State input} {T s : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted) (hs : tm.spaceUsed cfg T ≤ s) (t : ℕ) :
+ tm.spaceUsed cfg t ≤ s := by
+ rcases le_total t T with ht | ht
+ · exact (tm.spaceUsed_mono cfg ht).trans hs
+ · rwa [tm.spaceUsed_eq_of_halt ht hhalt]
+
end Turing.MultiTapeTM
From 0dd8203f85128d060e2c13265f626219aa39ef21 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 21:53:56 +0300
Subject: [PATCH 02/25] refactor(MultiTapeTM): simplify input shortening
---
.../Turing/MultiTape/Deterministic.lean | 5 +-
.../Turing/MultiTape/InputShortening.lean | 201 ++++++++----------
2 files changed, 89 insertions(+), 117 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 9b303fa91..45692a15e 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -279,9 +279,8 @@ lemma runFrom_output_eq_of_halt
(tm : MultiTapeTM k Symbol State)
(cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t)
(hhalt : (tm.runFrom cfg τ).state = none) :
- (tm.runFrom cfg t).output = (tm.runFrom cfg τ).output := by
- conv_lhs => rw [← Nat.sub_add_cancel hle, Nat.add_comm]
- rw [runFrom_add, runFrom_of_halt _ hhalt]
+ (tm.runFrom cfg t).output = (tm.runFrom cfg τ).output :=
+ congrArg Cfg.output (tm.runFrom_eq_of_halt hle hhalt)
/-- A proof that the Turing machine `tm` on input `input` outputs `output` in at most `t` steps
and uses exactly `s` space.
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 5924db730..316639aca 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -8,14 +8,13 @@ module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Finset.Sort
-public import Mathlib.Data.List.OfFn
/-!
# Input shortening for multi-tape Turing machines
A visit sequence records the storages seen at a fixed input position during a finite run.
-For a halting deterministic machine these storages are distinct: repeating a core would repeat
-the rest of the computation, regardless of the write-only output.
+Up to the first halt, these storages are distinct: repeating a core would repeat the rest of the
+computation, regardless of the write-only output.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -42,19 +41,14 @@ lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
(hhalt : (tm.runFrom cfg T).Halted)
(hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
- have hle : ∀ a b, a ≤ b → b ≤ T →
- (tm.runFrom cfg a).core = (tm.runFrom cfg b).core → a = b := by
- intro a b hab hb heq
- by_contra hne
- have hlt : a < b := by omega
- have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
- have hs := congrArg (fun c => c.2.state) heq'
- exact hfirst (a + (T - b)) (by omega) (hs.trans hhalt)
- intro a ha b hb hab
- rcases le_total a b with h | h
- · exact hle a b h hb hab
- · exact (hle b a h ha hab.symm).symm
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ by_contra hne
+ change b ≤ T at hb
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
/-- Times up to `T` at which the input head is at `p`. -/
def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
@@ -108,16 +102,17 @@ private lemma step_congr_storage {input' : List Symbol}
(hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
(tm.step c).storage = (tm.step c').storage ∧
r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
+ rcases c with ⟨state, pos, tapes, heads, out⟩
+ rcases c' with ⟨state', pos', tapes', heads', out'⟩
simp only [Cfg.storage, Storage.mk.injEq] at hstore
- obtain ⟨hstate, htapes, hpos⟩ := hstore
- have hwork : c.workTapeSymbols = c'.workTapeSymbols := by
- funext i
- simp [Cfg.workTapeSymbols, htapes, hpos]
- simp only [step, hstate, hsym, hwork]
- cases hs : c'.state with
- | none => exact ⟨by simp_all [Cfg.storage], hp⟩
- | some q =>
- exact ⟨by simp [Cfg.storage, Action.apply, htapes, hpos], hm _⟩
+ rcases hstore with ⟨rfl, rfl, rfl⟩
+ cases state with
+ | none => exact ⟨rfl, hp⟩
+ | some state =>
+ dsimp only [step]
+ unfold Cfg.workTapeSymbols
+ rw [hsym]
+ exact ⟨rfl, hm _⟩
private lemma moveInputPos_val {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
(moveInputPos p m).val = min (n + 1) ((p.val : ℤ) + (m.cast : ℤ)).toNat := by
@@ -153,6 +148,14 @@ private lemma moveInputPos_shift {n n' d : ℕ} (p : Fin (n + 2)) (p' : Fin (n'
have := p'.isLt
cases m <;> simp [SignType.cast] <;> omega
+private lemma moveInputPos_interior {n n' : ℕ}
+ (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
+ (m : SignType) :
+ (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ cases m <;> simp [SignType.cast] <;> omega
+
private lemma inputSymbol_eq_getElem? (cfg : Cfg k Symbol State input) :
cfg.inputSymbol = if cfg.inputPos.val = 0 then none else input[cfg.inputPos.val - 1]? := by
by_cases h₀ : cfg.inputPos = 0
@@ -197,15 +200,10 @@ private lemma inputSymbol_cut_right {a b : ℕ}
private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
(hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
- have h : ∀ d, u + d ≤ v → P (u + d) := by
- intro d
- induction d with
- | zero => simpa using fun _ : u ≤ v => hu
- | succ d ih =>
- intro hd
- exact hstep (u + d) (by omega) (by omega) (ih (by omega))
- have hv : u + (v - u) = v := by omega
- simpa [hv] using h (v - u) (by omega)
+ induction v, huv using Nat.le_induction with
+ | base => exact hu
+ | succ v huv ih =>
+ exact hstep v huv (Nat.lt_succ_self _) (ih fun t hut htv => hstep t hut (by omega))
private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
(hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
@@ -256,69 +254,61 @@ private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m
R (if p t ≤ a then p t else p t - (b - a)) (q t) := by
have hba : b - (b - a) = a := by omega
have boundary : ∀ i, R a (q (A i)) := by
- intro i
- induction hi : i.val using Nat.strong_induction_on generalizing i with
- | h n ih =>
- by_cases hn : n = 0
- · have hno : ∀ t < A i, p t ≠ a := by
+ cases m with
+ | zero => exact fun i => Fin.elim0 i
+ | succ m =>
+ intro i
+ induction i using Fin.induction with
+ | zero =>
+ have hno : ∀ t < A 0, p t ≠ a := by
intro t ht hpt
- obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA i).1) hpt
- have hij : i ≤ j := by change i.val ≤ j.val; omega
- exact (not_lt_of_ge (A.monotone hij)) ht
- have hside : ∀ t ≤ A i, p t ≤ a := by
+ obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA 0).1) hpt
+ exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) ht
+ have hside : ∀ t ≤ A 0, p t ≤ a := by
intro t ht
apply propagate (Nat.zero_le t) hp₀
intro r _ hrt hr
- have := (hstep r (by have := (hA i).1; omega)).1
+ have := (hstep r (by have := (hA 0).1; omega)).1
have := hno r (by omega)
omega
- have hr := propagate (Nat.zero_le (A i)) hR₀ fun t _ ht =>
- hleft t (ht.trans_le (hA i).1) (hside t ht.le) (hside (t + 1) ht)
- simpa [(hA i).2] using hr
- · let j : Fin m := ⟨n - 1, by have := i.isLt; omega⟩
- have hj : R a (q (A j)) := ih (n - 1) (by omega) j rfl
- have hji : j < i := by change j.val < i.val; simp only [j]; omega
- have hAj : A j < A i := A.strictMono hji
- have hBj : B j < B i := B.strictMono hji
- have hnoA : ∀ t, A j < t → t < A i → p t ≠ a := by
+ have hr := propagate (Nat.zero_le (A 0)) hR₀ fun t _ ht =>
+ hleft t (ht.trans_le (hA 0).1) (hside t ht.le) (hside (t + 1) ht)
+ simpa [(hA 0).2] using hr
+ | succ i ih =>
+ have hAj := A.strictMono i.castSucc_lt_succ
+ have hBj := B.strictMono i.castSucc_lt_succ
+ have hnoA : ∀ t, A i.castSucc < t → t < A i.succ → p t ≠ a := by
intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i).1) hpt
- have hjr := A.lt_iff_lt.mp hjt
- have hri := A.lt_iff_lt.mp hti
- change j.val < r.val at hjr
- change r.val < i.val at hri
- simp only [j] at hjr
- omega
- have hnoB : ∀ t, B j < t → t < B i → p t ≠ b := by
+ obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i.succ).1) hpt
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hti)))
+ (A.lt_iff_lt.mp hjt)
+ have hnoB : ∀ t, B i.castSucc < t → t < B i.succ → p t ≠ b := by
intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i).1) hpt
- have hjr := B.lt_iff_lt.mp hjt
- have hri := B.lt_iff_lt.mp hti
- change j.val < r.val at hjr
- change r.val < i.val at hri
- simp only [j] at hjr
- omega
- by_cases hdir : p (A j + 1) ≤ a
+ obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i.succ).1) hpt
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hti)))
+ (B.lt_iff_lt.mp hjt)
+ by_cases hdir : p (A i.castSucc + 1) ≤ a
· have hside := walk_left
- (fun t (_ : A j ≤ t) (ht : t < A i) =>
- (hstep t (ht.trans_le (hA i).1)).1)
- (le_of_eq (hA j).2) hdir hnoA
- have hr := propagate hAj.le (show R (p (A j)) (q (A j)) by
- simpa [(hA j).2] using hj) fun t hjt hti =>
- hleft t (hti.trans_le (hA i).1)
- (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hA i).2] using hr
- · have hdir' : b ≤ p (B j + 1) := by have := hmove j; omega
+ (fun t (_ : A i.castSucc ≤ t) (ht : t < A i.succ) =>
+ (hstep t (ht.trans_le (hA i.succ).1)).1)
+ (le_of_eq (hA i.castSucc).2) hdir hnoA
+ have hr := propagate hAj.le
+ (show R (p (A i.castSucc)) (q (A i.castSucc)) by
+ simpa [(hA i.castSucc).2] using ih) fun t hjt hti =>
+ hleft t (hti.trans_le (hA i.succ).1)
+ (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
+ simpa [(hA i.succ).2] using hr
+ · have hdir' : b ≤ p (B i.castSucc + 1) := by have := hmove i.castSucc; omega
have hside := walk_right
- (fun t (_ : B j ≤ t) (ht : t < B i) =>
- (hstep t (ht.trans_le (hB i).1)).2)
- (ge_of_eq (hB j).2) hdir' hnoB
+ (fun t (_ : B i.castSucc ≤ t) (ht : t < B i.succ) =>
+ (hstep t (ht.trans_le (hB i.succ).1)).2)
+ (ge_of_eq (hB i.castSucc).2) hdir' hnoB
have hr := propagate hBj.le
- (show R (p (B j) - (b - a)) (q (B j)) by
- simpa [(hB j).2, hba, ← hq j] using hj) fun t hjt hti =>
- hright t (hti.trans_le (hB i).1)
+ (show R (p (B i.castSucc) - (b - a)) (q (B i.castSucc)) by
+ simpa [(hB i.castSucc).2, hba, ← hq i.castSucc] using ih) fun t hjt hti =>
+ hright t (hti.trans_le (hB i.succ).1)
(hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hB i).2, hba, ← hq i] using hr
+ simpa [(hB i.succ).2, hba, ← hq i.succ] using hr
intro t
induction t with
| zero => intro _ _; simpa [hp₀] using hR₀
@@ -343,14 +333,6 @@ private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m
exact hright t (by omega) hprev hr (by
simpa [hprev'] using ih (by omega) (Or.inr hprev))
-private lemma moveInputPos_interior {n n' : ℕ}
- (p : Fin (n + 2)) (p' : Fin (n' + 2))
- (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
- (m : SignType) :
- (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
- rw [moveInputPos_val, moveInputPos_val]
- cases m <;> simp [SignType.cast] <;> omega
-
private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
(h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
(tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
@@ -383,18 +365,14 @@ theorem exists_storage_cut {a b T : ℕ}
tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
intro u hu hpu
- have hmem := tm.mem_visitTimes.mpr ⟨hu, hpu⟩
- have : u ∈ Set.range A := by
- rw [Finset.range_orderEmbOfFin]
- exact hmem
- exact this
+ change u ∈ Set.range A
+ simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
+ tm.mem_visitTimes.mpr ⟨hu, hpu⟩
have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
intro u hu hpu
- have hmem := tm.mem_visitTimes.mpr ⟨hu, hpu⟩
- have : u ∈ Set.range B := by
- rw [Finset.range_orderEmbOfFin]
- exact hmem
- exact this
+ change u ∈ Set.range B
+ simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
+ tm.mem_visitTimes.mpr ⟨hu, hpu⟩
have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
intro i
have heq := List.getElem_of_eq hseq (i := i.val)
@@ -498,15 +476,12 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {T s : ℕ
rw [← Set.coe_fintypeCard] at h
exact_mod_cast h
let seq := tm.visitSequence (tm.initCfg input) T
- let enc (p : ℕ) : List S := (seq p).attachWith S
+ let enc (p : ℕ) : List S := (seq p).attachWith (· ∈ S)
(fun _ h => tm.mem_range_of_mem_visitSequence h)
have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
List.attachWith_map_subtype_val _
have hlength (p : ℕ) : (enc p).length ≤ B := by
- have he := congrArg List.length (henc p)
- simp only [List.length_map] at he
- rw [he]
- exact tm.length_visitSequence_le hhalt hfirst hs p
+ simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hhalt hfirst hs p
let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
(input[i], fun j => (enc (i.val + 1))[j.val]?)
have heq {i j : Fin input.length} (h : f i = f j) :
@@ -538,12 +513,10 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {T s : ℕ
have hmem : e i ∈ Finset.univ.filter (fun i => f i = v) :=
Finset.orderEmbOfCardLe_mem _ _ i
exact (Finset.mem_filter.mp hmem).2
- have hab : (e 0).val + 1 < (e 1).val + 1 := by
- have := e.strictMono (show (0 : Fin 3) < 1 by decide)
- exact Nat.add_lt_add_right this 1
- have hbc : (e 1).val + 1 < (e 2).val + 1 := by
- have := e.strictMono (show (1 : Fin 3) < 2 by decide)
- exact Nat.add_lt_add_right this 1
+ have hab : (e 0).val + 1 < (e 1).val + 1 :=
+ Nat.add_lt_add_right (e.strictMono (by decide)) 1
+ have hbc : (e 1).val + 1 < (e 2).val + 1 :=
+ Nat.add_lt_add_right (e.strictMono (by decide)) 1
have hab' := heq ((he 0).trans (he 1).symm)
have hbc' := heq ((he 1).trans (he 2).symm)
have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
From 3e04db7d12a6cf87fe38cd97c9699997bfda81c9 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 22:16:01 +0300
Subject: [PATCH 03/25] refactor(MultiTapeTM): simplify shortening hypotheses
---
.../Machines/Turing/MultiTape/InputShortening.lean | 14 ++++++++------
1 file changed, 8 insertions(+), 6 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 316639aca..858e11f7f 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -455,18 +455,20 @@ lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {T s : ℕ}
exact_mod_cast hle
/-- A sufficiently long input to a halting space-bounded machine can be shortened while
-preserving any designated storage reached through its first halt. -/
-theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {T s : ℕ}
- (hhalt : (tm.runFrom (tm.initCfg input) T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom (tm.initCfg input) t).Halted)
+preserving any designated storage reached by the run. -/
+theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
+ (hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
(hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
(hlen : 2 * Fintype.card Symbol *
(storageBound Symbol State k s + 1) ^ storageBound Symbol State k s < input.length)
- {t : ℕ} (ht : t ≤ T) :
+ (t : ℕ) :
∃ input' : List Symbol, input'.length < input.length ∧
∃ u, (tm.runFrom (tm.initCfg input') u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
classical
+ obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
+ wlog ht : t ≤ T generalizing t
+ · simpa only [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] using this T le_rfl
let B := storageBound Symbol State k s
let S := Set.range (fun u => (tm.runFrom (tm.initCfg input) u).storage)
have hbound : S.encard ≤ B := tm.encard_storages_le hs
@@ -481,7 +483,7 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {T s : ℕ
have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
List.attachWith_map_subtype_val _
have hlength (p : ℕ) : (enc p).length ≤ B := by
- simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hhalt hfirst hs p
+ simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hT hfirst hs p
let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
(input[i], fun j => (enc (i.val + 1))[j.val]?)
have heq {i j : Fin input.length} (h : f i = f j) :
From 596746cedd932ca4cd73a0b14b7b89440578ff92 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 22:21:12 +0300
Subject: [PATCH 04/25] refactor(MultiTapeTM): organize shortening lemmas
---
.../Turing/MultiTape/ConfigBound.lean | 62 ++++++++-
.../Turing/MultiTape/Configuration.lean | 51 ++++++++
.../Turing/MultiTape/Deterministic.lean | 9 ++
.../Turing/MultiTape/InputShortening.lean | 120 ++----------------
4 files changed, 129 insertions(+), 113 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
index 81db2e280..bc1d681ee 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
@@ -1,7 +1,7 @@
/-
Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner
+Authors: Christian Reitwiessner, Aviv Bar Natan
-/
module
@@ -273,13 +273,71 @@ lemma core_step_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input} (h : c₁.c
simp only [Cfg.core, Cfg.storage, MultiTapeTM.step, hstate, hsym, hws]
cases c₂.state <;> simp [hpos, hstate, hwt, hwp]
+namespace MultiTapeTM
+
+/-- Runs starting with the same core keep the same core. -/
+lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
+ (h : c₁.core = c₂.core) (t : ℕ) :
+ (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
+ induction t with
+ | zero => exact h
+ | succ t ih =>
+ simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
+
+/-- The cores up to and including the first halt are pairwise distinct. -/
+lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ by_contra hne
+ change b ≤ T at hb
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
+
+/-- Equal storage and input symbols give equal storage after one step. A relation `r` between
+the input positions is also preserved if it holds initially and after every common head move. -/
+lemma step_congr_storage {input' : List Symbol}
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
+ (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
+ (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
+ (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
+ (tm.step c).storage = (tm.step c').storage ∧
+ r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
+ rcases c with ⟨state, pos, tapes, heads, out⟩
+ rcases c' with ⟨state', pos', tapes', heads', out'⟩
+ simp only [Cfg.storage, Storage.mk.injEq] at hstore
+ rcases hstore with ⟨rfl, rfl, rfl⟩
+ cases state with
+ | none => exact ⟨rfl, hp⟩
+ | some state =>
+ dsimp only [step]
+ unfold Cfg.workTapeSymbols
+ rw [hsym]
+ exact ⟨rfl, hm _⟩
+
/-! ## The storages and cores of a space-bounded run
These are the main results giving upper bounds on the number of storages and configuration cores
reachable in bounded space.
-/
-namespace MultiTapeTM
+/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
+lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
+ (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
+ tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
+ calc tm.spaceUsed cfg T
+ _ ≤ ∑ _ : Fin k, (window R).card := by
+ apply Finset.sum_le_sum
+ intro i _
+ apply Finset.card_le_card
+ intro z hz
+ obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
+ exact mem_window.mpr (h t (by omega) i)
+ _ = k * (2 * R + 1) := by simp
/-- The storage reached after `t` steps fits in the windows given by the per-tape space usage up
to step `t`. -/
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
index 78237a5b5..d8c9c9a03 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
@@ -136,6 +136,45 @@ lemma moveInputPos_pos_of_ne_right {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n
· simp
omega
+/-- Moving the input head adds the direction and clamps the result to the two endmarkers. -/
+lemma moveInputPos_val {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
+ (moveInputPos p m).val = min (n + 1) ((p.val : ℤ) + (m.cast : ℤ)).toNat := by
+ simp only [moveInputPos]
+ split <;> simp_all <;> omega
+
+/-- An input-head move changes the position by at most one cell. -/
+lemma moveInputPos_bounds {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
+ (moveInputPos p m).val ≤ p.val + 1 ∧ p.val ≤ (moveInputPos p m).val + 1 := by
+ rw [moveInputPos_val]
+ have := p.isLt
+ cases m <;> simp [SignType.cast] <;> omega
+
+/-- Equal input positions below the right endmarkers remain equal after the same move. -/
+lemma moveInputPos_same {n n' : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp : p.val = p'.val) (hn : p.val ≤ n) (hn' : p'.val ≤ n') (m : SignType) :
+ (moveInputPos p m).val = (moveInputPos p' m).val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ cases m <;> simp [SignType.cast] <;> omega
+
+/-- Shifting a position and the right endmarker by the same amount commutes with a move,
+provided the smaller position is not the left endmarker. -/
+lemma moveInputPos_shift {n n' d : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp : p'.val + d = p.val) (hn : n' + d = n) (hp' : 0 < p'.val) (m : SignType) :
+ (moveInputPos p' m).val + d = (moveInputPos p m).val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ have := p.isLt
+ have := p'.isLt
+ cases m <;> simp [SignType.cast] <;> omega
+
+/-- The same move gives the same displacement at any two positions inside the input. -/
+lemma moveInputPos_interior {n n' : ℕ}
+ (p : Fin (n + 2)) (p' : Fin (n' + 2))
+ (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
+ (m : SignType) :
+ (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
+ rw [moveInputPos_val, moveInputPos_val]
+ cases m <;> simp [SignType.cast] <;> omega
+
/-- The symbol currently under the input tape head. -/
def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol :=
if h₁ : cfg.inputPos = 0 then none
@@ -149,6 +188,18 @@ lemma inputSymbolInner {cfg : Cfg k Symbol State input} (p : ℕ)
cfg.inputSymbol = some input[p] := by
grind [Cfg.inputSymbol]
+/-- Read the input by zero-based optional indexing, returning `none` at either endmarker. -/
+lemma inputSymbol_eq_getElem? (cfg : Cfg k Symbol State input) :
+ cfg.inputSymbol = if cfg.inputPos.val = 0 then none else input[cfg.inputPos.val - 1]? := by
+ by_cases h₀ : cfg.inputPos = 0
+ · simp [Cfg.inputSymbol, h₀]
+ · have h₀' : cfg.inputPos.val ≠ 0 := fun h => h₀ (Fin.ext h)
+ rw [Cfg.inputSymbol, dite_eq_right h₀, ite_eq_right h₀']
+ split_ifs with hend
+ · simp [hend]
+ · have hi : cfg.inputPos.val - 1 < input.length := by have := cfg.inputPos.isLt; omega
+ simp [List.getElem?_eq_getElem hi]
+
/-- The symbol read by work tape `i`. -/
def Cfg.workTapeSymbols (cfg : Cfg k Symbol State input) (i : Fin k) : Option Symbol :=
cfg.workTapes i (cfg.workTapePos i)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 45692a15e..ad0bfc7f4 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -203,6 +203,15 @@ lemma outputSymbol_of_halt {cfg : Cfg k Symbol State input} (h_halt : cfg.state
tm.outputSymbol cfg = none := by
simp [outputSymbol, h_halt]
+/-- The input head moves by at most one cell at each step. -/
+lemma inputPos_step_bounds (cfg : Cfg k Symbol State input) :
+ (tm.step cfg).inputPos.val ≤ cfg.inputPos.val + 1 ∧
+ cfg.inputPos.val ≤ (tm.step cfg).inputPos.val + 1 := by
+ unfold step
+ cases cfg.state with
+ | none => simp
+ | some q => exact moveInputPos_bounds _ _
+
/-- The work-tape head moves by at most one cell in a single step. -/
lemma workTapePos_step_le (c : Cfg k Symbol State input) (i : Fin k) :
|(tm.step c).workTapePos i - c.workTapePos i| ≤ 1 := by
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 858e11f7f..c3d96cd83 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -27,29 +27,6 @@ namespace Turing.MultiTapeTM
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
-/-- Runs starting with the same core keep the same core. -/
-lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
- (h : c₁.core = c₂.core) (t : ℕ) :
- (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
- induction t with
- | zero => exact h
- | succ t ih =>
- simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
-
-/-- The cores up to and including the first halt are pairwise distinct. -/
-lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
- Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
- intro a ha b hb heq
- wlog hab : a ≤ b generalizing a b
- · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
- by_contra hne
- change b ≤ T at hb
- have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
- exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-
/-- Times up to `T` at which the input head is at `p`. -/
def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
(Finset.range (T + 1)).filter fun t => (tm.runFrom cfg t).inputPos.val = p
@@ -81,92 +58,7 @@ lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
-/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
-lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
- (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
- tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
- calc tm.spaceUsed cfg T
- _ ≤ ∑ _ : Fin k, (window R).card := by
- apply Finset.sum_le_sum
- intro i _
- apply Finset.card_le_card
- intro z hz
- obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
- exact mem_window.mpr (h t (by omega) i)
- _ = k * (2 * R + 1) := by simp
-
-private lemma step_congr_storage {input' : List Symbol}
- {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
- (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
- (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
- (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
- (tm.step c).storage = (tm.step c').storage ∧
- r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
- rcases c with ⟨state, pos, tapes, heads, out⟩
- rcases c' with ⟨state', pos', tapes', heads', out'⟩
- simp only [Cfg.storage, Storage.mk.injEq] at hstore
- rcases hstore with ⟨rfl, rfl, rfl⟩
- cases state with
- | none => exact ⟨rfl, hp⟩
- | some state =>
- dsimp only [step]
- unfold Cfg.workTapeSymbols
- rw [hsym]
- exact ⟨rfl, hm _⟩
-
-private lemma moveInputPos_val {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
- (moveInputPos p m).val = min (n + 1) ((p.val : ℤ) + (m.cast : ℤ)).toNat := by
- simp only [moveInputPos]
- split <;> simp_all <;> omega
-
-private lemma moveInputPos_bounds {n : ℕ} (p : Fin (n + 2)) (m : SignType) :
- (moveInputPos p m).val ≤ p.val + 1 ∧ p.val ≤ (moveInputPos p m).val + 1 := by
- rw [moveInputPos_val]
- have := p.isLt
- cases m <;> simp [SignType.cast] <;> omega
-
-/-- The input head moves by at most one cell at each step. -/
-lemma inputPos_step_bounds (cfg : Cfg k Symbol State input) :
- (tm.step cfg).inputPos.val ≤ cfg.inputPos.val + 1 ∧
- cfg.inputPos.val ≤ (tm.step cfg).inputPos.val + 1 := by
- unfold step
- cases cfg.state with
- | none => simp
- | some q => exact moveInputPos_bounds _ _
-
-private lemma moveInputPos_same {n n' : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
- (hp : p.val = p'.val) (hn : p.val ≤ n) (hn' : p'.val ≤ n') (m : SignType) :
- (moveInputPos p m).val = (moveInputPos p' m).val := by
- rw [moveInputPos_val, moveInputPos_val]
- cases m <;> simp [SignType.cast] <;> omega
-
-private lemma moveInputPos_shift {n n' d : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
- (hp : p'.val + d = p.val) (hn : n' + d = n) (hp' : 0 < p'.val) (m : SignType) :
- (moveInputPos p' m).val + d = (moveInputPos p m).val := by
- rw [moveInputPos_val, moveInputPos_val]
- have := p.isLt
- have := p'.isLt
- cases m <;> simp [SignType.cast] <;> omega
-
-private lemma moveInputPos_interior {n n' : ℕ}
- (p : Fin (n + 2)) (p' : Fin (n' + 2))
- (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
- (m : SignType) :
- (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
- rw [moveInputPos_val, moveInputPos_val]
- cases m <;> simp [SignType.cast] <;> omega
-
-private lemma inputSymbol_eq_getElem? (cfg : Cfg k Symbol State input) :
- cfg.inputSymbol = if cfg.inputPos.val = 0 then none else input[cfg.inputPos.val - 1]? := by
- by_cases h₀ : cfg.inputPos = 0
- · simp [Cfg.inputSymbol, h₀]
- · have h₀' : cfg.inputPos.val ≠ 0 := fun h => h₀ (Fin.ext h)
- rw [Cfg.inputSymbol, dite_eq_right h₀, ite_eq_right h₀']
- split_ifs with hend
- · simp [hend]
- · have hi : cfg.inputPos.val - 1 < input.length := by have := cfg.inputPos.isLt; omega
- simp [List.getElem?_eq_getElem hi]
-
+/-- Deleting the cells after `a` through `b` preserves symbols at positions at most `a`. -/
private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
(c : Cfg k Symbol State input)
(c' : Cfg k Symbol State (input.take a ++ input.drop b))
@@ -178,6 +70,8 @@ private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
· have hi : c.inputPos.val - 1 < a := by omega
simp [List.getElem?_append, ha, hi]
+/-- After deleting the cells after `a` through `b`, symbols at positions at least `b`
+are preserved by shifting left by `b - a`, provided the symbols at `a` and `b` agree. -/
private lemma inputSymbol_cut_right {a b : ℕ}
(ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
(hsym : input[a - 1]? = input[b - 1]?)
@@ -198,6 +92,7 @@ private lemma inputSymbol_cut_right {a b : ℕ}
have he : b + (c'.inputPos.val - 1 - a) = c.inputPos.val - 1 := by omega
simp [List.getElem?_append, htake, not_lt.mpr hi, he]
+/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
(hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
induction v, huv using Nat.le_induction with
@@ -205,6 +100,7 @@ private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u
| succ v huv ih =>
exact hstep v huv (Nat.lt_succ_self _) (ih fun t hut htv => hstep t hut (by omega))
+/-- After staying left of `a` for one step, a walk cannot cross `a` without revisiting it. -/
private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
(hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
(hu : p u ≤ a) (hu' : p (u + 1) ≤ a)
@@ -219,6 +115,7 @@ private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
have := hno r (by omega) (by omega)
omega
+/-- After staying right of `b` for one step, a walk cannot cross `b` without revisiting it. -/
private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
(hstep : ∀ t, u ≤ t → t < v → p t ≤ p (t + 1) + 1)
(hu : b ≤ p u) (hu' : b ≤ p (u + 1))
@@ -233,8 +130,8 @@ private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
have := hno r (by omega) (by omega)
omega
--- Gluing uses only the ordered visits and the fact that the head moves by at most one cell.
--- `R` describes reachability after the cells between `a` and `b` have been removed.
+/-- Matching ordered visits at `a` and `b` allow the portions of a walk outside `(a, b)`
+to be joined. Any predicate `R` preserved along those portions holds throughout the joined walk. -/
private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m : ℕ}
(hab : a < b) (hp₀ : p 0 ≤ a)
(hstep : ∀ t < T, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
@@ -333,6 +230,7 @@ private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m
exact hright t (by omega) hprev hr (by
simpa [hprev'] using ih (by omega) (Or.inr hprev))
+/-- The entry at index `i` is the storage at the `i`th visit time. -/
private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
(h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
(tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
From d9a3f737fac4e0402190b12d57e102eb5e188ac6 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 22:30:15 +0300
Subject: [PATCH 05/25] refactor(MultiTapeTM): define visits over whole runs
---
.../Turing/MultiTape/InputShortening.lean | 203 ++++++++++++------
1 file changed, 134 insertions(+), 69 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index c3d96cd83..77a550e2e 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -7,14 +7,17 @@ module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
-public import Mathlib.Data.Finset.Sort
+public import Mathlib.Data.Nat.Nth
+public import Mathlib.Data.Seq.Basic
/-!
# Input shortening for multi-tape Turing machines
-A visit sequence records the storages seen at a fixed input position during a finite run.
-Up to the first halt, these storages are distinct: repeating a core would repeat the rest of the
-computation, regardless of the write-only output.
+A visit sequence records the storages seen at a fixed input position during a run. It is defined
+for every run and may be infinite. Visits include the first halted configuration but exclude the
+stationary continuation after halting. For a halting run, the sequence is finite and its storages
+are distinct: repeating a core would repeat the rest of the computation, regardless of the
+write-only output.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -27,36 +30,88 @@ namespace Turing.MultiTapeTM
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
-/-- Times up to `T` at which the input head is at `p`. -/
-def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
- (Finset.range (T + 1)).filter fun t => (tm.runFrom cfg t).inputPos.val = p
+/-- Times when the input head is at `p`, with no earlier halted configuration.
+The final configuration is counted once; the stationary continuation after halting is excluded. -/
+def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
+ {t | (tm.runFrom cfg t).inputPos.val = p ∧ ∀ u < t, ¬ (tm.runFrom cfg u).Halted}
@[simp]
-lemma mem_visitTimes {cfg : Cfg k Symbol State input} {T p t : ℕ} :
- t ∈ tm.visitTimes cfg T p ↔ t ≤ T ∧ (tm.runFrom cfg t).inputPos.val = p := by
- simp [visitTimes]
+lemma mem_visitTimes {cfg : Cfg k Symbol State input} {p t : ℕ} :
+ t ∈ tm.visitTimes cfg p ↔
+ (tm.runFrom cfg t).inputPos.val = p ∧ ∀ u < t, ¬ (tm.runFrom cfg u).Halted := Iff.rfl
-/-- The chronological list of storages encountered at input position `p` through time `T`. -/
-def visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) : List (Storage Symbol State k) :=
- ((tm.visitTimes cfg T p).sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage
-
-@[simp]
-lemma length_visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) :
- (tm.visitSequence cfg T p).length = (tm.visitTimes cfg T p).card := by
- simp [visitSequence]
+/-- The chronological, possibly infinite sequence of storages encountered at input position `p`. -/
+noncomputable def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
+ Stream'.Seq (Storage Symbol State k) := by
+ classical
+ exact if h : (tm.visitTimes cfg p).Finite then
+ .ofList ((h.toFinset.sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage)
+ else
+ .ofStream (fun n => (tm.runFrom cfg (Nat.nth (· ∈ tm.visitTimes cfg p) n)).storage)
-/-- No storage occurs twice at one input position before the first halt. -/
-lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
+/-- On a run whose first halt is at `T`, visits are exactly the head positions through `T`. -/
+lemma visitTimes_eq_of_first_halt {cfg : Cfg k Symbol State input} {T : ℕ}
(hhalt : (tm.runFrom cfg T).Halted)
(hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) (p : ℕ) :
- (tm.visitSequence cfg T p).Nodup := by
+ tm.visitTimes cfg p = {t | t ≤ T ∧ (tm.runFrom cfg t).inputPos.val = p} := by
+ ext t
+ constructor
+ · rintro ⟨hp, h⟩
+ exact ⟨le_of_not_gt (fun ht => h T ht hhalt), hp⟩
+ · rintro ⟨ht, hp⟩
+ exact ⟨hp, fun u hu => hfirst u (hu.trans_le ht)⟩
+
+/-- A halting run has finitely many visits to each input position. -/
+lemma visitTimes_finite_of_halt {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) : (tm.visitTimes cfg p).Finite := by
+ obtain ⟨T, hT⟩ := hhalt
+ exact (Set.finite_Iic T).subset fun t ht => le_of_not_gt (fun h => ht.2 T h hT)
+
+/-- When there are finitely many visits, the sequence is the sorted list of their storages. -/
+lemma visitSequence_eq_of_finite {cfg : Cfg k Symbol State input} {p : ℕ}
+ (h : (tm.visitTimes cfg p).Finite) :
+ tm.visitSequence cfg p = Stream'.Seq.ofList
+ ((h.toFinset.sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage) := by
+ classical
+ exact dite_eq_left h
+
+/-- The visit sequence of a halting run is finite. -/
+lemma visitSequence_terminates_of_halt {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
+ (tm.visitSequence cfg p).Terminates := by
+ rw [tm.visitSequence_eq_of_finite (tm.visitTimes_finite_of_halt hhalt p)]
+ exact Stream'.Seq.terminates_ofList _
+
+/-- Converting a halting run's visit sequence to a list enumerates the visits in time order. -/
+lemma visitSequence_toList {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
+ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p) =
+ (((tm.visitTimes_finite_of_halt hhalt p).toFinset).sort (· ≤ ·)).map
+ (fun t => (tm.runFrom cfg t).storage) := by
+ apply Stream'.Seq.ofList_injective
+ rw [Stream'.Seq.ofList_toList, tm.visitSequence_eq_of_finite]
+
+/-- The finite visit sequence has one entry for each visit time. -/
+lemma length_visitSequence {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
+ ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)).length =
+ (tm.visitTimes_finite_of_halt hhalt p).toFinset.card := by
+ simp [tm.visitSequence_toList hhalt p]
+
+/-- No storage occurs twice in a halting run's visit sequence. -/
+lemma visitSequence_nodup {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
+ ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)).Nodup := by
classical
+ rw [tm.visitSequence_toList hhalt p]
apply List.Nodup.map_on _ (Finset.sort_nodup _ _)
intro a ha b hb h
- have ha' := tm.mem_visitTimes.mp (by simpa using ha)
- have hb' := tm.mem_visitTimes.mp (by simpa using hb)
- apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
- exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
+ have ha' : a ∈ tm.visitTimes cfg p := by simpa using ha
+ have hb' : b ∈ tm.visitTimes cfg p := by simpa using hb
+ obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
+ apply tm.core_runFrom_injOn hT hfirst
+ (le_of_not_gt (fun ht => ha'.2 T ht hT)) (le_of_not_gt (fun ht => hb'.2 T ht hT))
+ exact Prod.ext (Fin.ext (ha'.1.trans hb'.1.symm)) h
/-- Deleting the cells after `a` through `b` preserves symbols at positions at most `a`. -/
private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
@@ -230,52 +285,60 @@ private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m
exact hright t (by omega) hprev hr (by
simpa [hprev'] using ih (by omega) (Or.inr hprev))
-/-- The entry at index `i` is the storage at the `i`th visit time. -/
-private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
- (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
- (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
- (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
- simp [visitSequence, Finset.orderEmbOfFin_apply]
-
-/-- Deleting the cells after `a` through `b` preserves every storage reached outside the deleted
-interval, provided the symbols and visit sequences at `a` and `b` agree. Input positions are
-one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
-theorem exists_storage_cut {a b T : ℕ}
+/-- For a halting run, deleting the cells after `a` through `b` preserves every storage reached
+outside the deleted interval, provided the symbols and visit sequences at `a` and `b` agree.
+Input positions are one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
+theorem exists_storage_cut
+ (hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted) {a b : ℕ}
(ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
(hsym : input[a - 1]? = input[b - 1]?)
- (hseq : tm.visitSequence (tm.initCfg input) T a =
- tm.visitSequence (tm.initCfg input) T b)
- {t : ℕ} (ht : t ≤ T)
+ (hseq : tm.visitSequence (tm.initCfg input) a =
+ tm.visitSequence (tm.initCfg input) b)
+ {t : ℕ}
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ a ∨
b ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ u, (tm.runFrom (tm.initCfg (input.take a ++ input.drop b)) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
+ classical
+ obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
+ wlog ht : t ≤ T generalizing t
+ · rw [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] at hp ⊢
+ exact this hp le_rfl
let c := tm.runFrom (tm.initCfg input)
let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
- let m := (tm.visitTimes (tm.initCfg input) T a).card
- have hcard : (tm.visitTimes (tm.initCfg input) T b).card = m := by
- simpa [m] using (congrArg List.length hseq).symm
- let A := (tm.visitTimes (tm.initCfg input) T a).orderEmbOfFin rfl
- let B := (tm.visitTimes (tm.initCfg input) T b).orderEmbOfFin hcard
+ let times := fun p => (tm.visitTimes_finite_of_halt hhalt p).toFinset
+ let seq := fun p => (tm.visitSequence (tm.initCfg input) p).toList
+ (tm.visitSequence_terminates_of_halt hhalt p)
+ have hmem (p u : ℕ) : u ∈ times p ↔ u ≤ T ∧ (c u).inputPos.val = p := by
+ simp only [times, Set.Finite.mem_toFinset, tm.visitTimes_eq_of_first_halt hT hfirst,
+ Set.mem_ofPred_eq, c]
+ have hseq' : seq a = seq b := by simp only [seq, hseq]
+ let m := (times a).card
+ have hcard : (times b).card = m := by
+ simpa only [seq, tm.length_visitSequence hhalt, times, m] using
+ (congrArg List.length hseq').symm
+ let A := (times a).orderEmbOfFin rfl
+ let B := (times b).orderEmbOfFin hcard
have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
- tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ (hmem a _).mp (Finset.orderEmbOfFin_mem _ _ i)
have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
- tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ (hmem b _).mp (Finset.orderEmbOfFin_mem _ _ i)
have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
intro u hu hpu
change u ∈ Set.range A
simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ (hmem a u).mpr ⟨hu, hpu⟩
have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
intro u hu hpu
change u ∈ Set.range B
simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ (hmem b u).mpr ⟨hu, hpu⟩
have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
intro i
- have heq := List.getElem_of_eq hseq (i := i.val)
- (by rw [length_visitSequence]; exact i.isLt)
- exact (visitSequence_get rfl i).symm.trans (heq.trans (visitSequence_get hcard i))
+ have heq := List.getElem_of_eq hseq' (i := i.val)
+ (by simpa only [seq, tm.length_visitSequence hhalt] using i.isLt)
+ simpa only [seq, tm.visitSequence_toList hhalt, List.getElem_map, A, B,
+ Finset.orderEmbOfFin_apply, Fin.getElem_fin, times, c] using heq
have hmove : ∀ i,
(c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
intro i
@@ -329,25 +392,28 @@ theorem exists_storage_cut {a b T : ℕ}
obtain ⟨u, _, hstore⟩ := hglue
exact ⟨u, hstore⟩
-/-- Every entry of a visit sequence is a storage reached by the run. -/
-lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {T p : ℕ}
- {s : Storage Symbol State k} (h : s ∈ tm.visitSequence cfg T p) :
+/-- Every entry of a finite visit sequence is a storage reached by the run. -/
+lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) {p : ℕ} {s : Storage Symbol State k}
+ (h : s ∈ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)) :
s ∈ Set.range (fun t => (tm.runFrom cfg t).storage) := by
+ rw [tm.visitSequence_toList hhalt p] at h
obtain ⟨t, _, rfl⟩ := List.mem_map.mp h
exact ⟨t, rfl⟩
/-- A visit sequence of a halting space-bounded run has length at most the storage bound. -/
-lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {T s : ℕ}
- (hhalt : (tm.runFrom (tm.initCfg input) T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom (tm.initCfg input) t).Halted)
+lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {s : ℕ}
+ (hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
(hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) (p : ℕ) :
- (tm.visitSequence (tm.initCfg input) T p).length ≤ storageBound Symbol State k s := by
+ ((tm.visitSequence (tm.initCfg input) p).toList
+ (tm.visitSequence_terminates_of_halt hhalt p)).length ≤ storageBound Symbol State k s := by
classical
- have hn := tm.visitSequence_nodup hhalt hfirst p
- have hsub : ((tm.visitSequence (tm.initCfg input) T p).toFinset : Set _) ⊆
+ have hn := tm.visitSequence_nodup hhalt p
+ have hsub : (((tm.visitSequence (tm.initCfg input) p).toList
+ (tm.visitSequence_terminates_of_halt hhalt p)).toFinset : Set _) ⊆
Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage) := by
intro x hx
- exact tm.mem_range_of_mem_visitSequence (List.mem_toFinset.mp hx)
+ exact tm.mem_range_of_mem_visitSequence hhalt (List.mem_toFinset.mp hx)
have hle := (Set.encard_le_encard hsub).trans (tm.encard_storages_le hs)
rw [Set.encard_coe_eq_coe_finsetCard, List.toFinset_card_of_nodup hn] at hle
exact_mod_cast hle
@@ -364,9 +430,6 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
∃ u, (tm.runFrom (tm.initCfg input') u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
classical
- obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
- wlog ht : t ≤ T generalizing t
- · simpa only [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] using this T le_rfl
let B := storageBound Symbol State k s
let S := Set.range (fun u => (tm.runFrom (tm.initCfg input) u).storage)
have hbound : S.encard ≤ B := tm.encard_storages_le hs
@@ -375,13 +438,14 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have h := hbound
rw [← Set.coe_fintypeCard] at h
exact_mod_cast h
- let seq := tm.visitSequence (tm.initCfg input) T
+ let seq := fun p => (tm.visitSequence (tm.initCfg input) p).toList
+ (tm.visitSequence_terminates_of_halt hhalt p)
let enc (p : ℕ) : List S := (seq p).attachWith (· ∈ S)
- (fun _ h => tm.mem_range_of_mem_visitSequence h)
+ (fun _ h => tm.mem_range_of_mem_visitSequence hhalt h)
have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
List.attachWith_map_subtype_val _
have hlength (p : ℕ) : (enc p).length ≤ B := by
- simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hT hfirst hs p
+ simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hhalt hs p
let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
(input[i], fun j => (enc (i.val + 1))[j.val]?)
have heq {i j : Fin input.length} (h : f i = f j) :
@@ -431,9 +495,10 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have := i.isLt
have := j.isLt
omega
- · exact tm.exists_storage_cut (by omega) hij (by have := j.isLt; omega)
+ · apply tm.exists_storage_cut hhalt (by omega) hij (by have := j.isLt; omega)
(by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
- hij'.2 ht hpos
+ ?_ hpos
+ simpa only [seq, Stream'.Seq.ofList_toList] using congrArg Stream'.Seq.ofList hij'.2
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
(e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
· exact cut hab hab' hpos
From c071d415c199a4e527b3bf0aa6fd6c5fdabda5e8 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 22:44:54 +0300
Subject: [PATCH 06/25] refactor(MultiTapeTM): restore lemma placement
---
.../Turing/MultiTape/ConfigBound.lean | 62 +------------------
.../Turing/MultiTape/Configuration.lean | 2 +-
.../Turing/MultiTape/InputShortening.lean | 58 +++++++++++++++++
3 files changed, 61 insertions(+), 61 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
index bc1d681ee..81db2e280 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
@@ -1,7 +1,7 @@
/-
Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner, Aviv Bar Natan
+Authors: Christian Reitwiessner
-/
module
@@ -273,71 +273,13 @@ lemma core_step_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input} (h : c₁.c
simp only [Cfg.core, Cfg.storage, MultiTapeTM.step, hstate, hsym, hws]
cases c₂.state <;> simp [hpos, hstate, hwt, hwp]
-namespace MultiTapeTM
-
-/-- Runs starting with the same core keep the same core. -/
-lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
- (h : c₁.core = c₂.core) (t : ℕ) :
- (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
- induction t with
- | zero => exact h
- | succ t ih =>
- simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
-
-/-- The cores up to and including the first halt are pairwise distinct. -/
-lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
- Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
- intro a ha b hb heq
- wlog hab : a ≤ b generalizing a b
- · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
- by_contra hne
- change b ≤ T at hb
- have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
- exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-
-/-- Equal storage and input symbols give equal storage after one step. A relation `r` between
-the input positions is also preserved if it holds initially and after every common head move. -/
-lemma step_congr_storage {input' : List Symbol}
- {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
- (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
- (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
- (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
- (tm.step c).storage = (tm.step c').storage ∧
- r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
- rcases c with ⟨state, pos, tapes, heads, out⟩
- rcases c' with ⟨state', pos', tapes', heads', out'⟩
- simp only [Cfg.storage, Storage.mk.injEq] at hstore
- rcases hstore with ⟨rfl, rfl, rfl⟩
- cases state with
- | none => exact ⟨rfl, hp⟩
- | some state =>
- dsimp only [step]
- unfold Cfg.workTapeSymbols
- rw [hsym]
- exact ⟨rfl, hm _⟩
-
/-! ## The storages and cores of a space-bounded run
These are the main results giving upper bounds on the number of storages and configuration cores
reachable in bounded space.
-/
-/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
-lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
- (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
- tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
- calc tm.spaceUsed cfg T
- _ ≤ ∑ _ : Fin k, (window R).card := by
- apply Finset.sum_le_sum
- intro i _
- apply Finset.card_le_card
- intro z hz
- obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
- exact mem_window.mpr (h t (by omega) i)
- _ = k * (2 * R + 1) := by simp
+namespace MultiTapeTM
/-- The storage reached after `t` steps fits in the windows given by the per-tape space usage up
to step `t`. -/
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
index d8c9c9a03..75398d14e 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
@@ -1,7 +1,7 @@
/-
Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner, Aviv Bar Natan
+Authors: Christian Reitwiessner
-/
module
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 77a550e2e..be470067f 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -30,6 +30,29 @@ namespace Turing.MultiTapeTM
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
+/-- Runs starting with the same core keep the same core. -/
+lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
+ (h : c₁.core = c₂.core) (t : ℕ) :
+ (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
+ induction t with
+ | zero => exact h
+ | succ t ih =>
+ simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
+
+/-- The cores up to and including the first halt are pairwise distinct. -/
+lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ by_contra hne
+ change b ≤ T at hb
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
+
/-- Times when the input head is at `p`, with no earlier halted configuration.
The final configuration is counted once; the stationary continuation after halting is excluded. -/
def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
@@ -113,6 +136,41 @@ lemma visitSequence_nodup {cfg : Cfg k Symbol State input}
(le_of_not_gt (fun ht => ha'.2 T ht hT)) (le_of_not_gt (fun ht => hb'.2 T ht hT))
exact Prod.ext (Fin.ext (ha'.1.trans hb'.1.symm)) h
+/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
+lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
+ (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
+ tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
+ calc tm.spaceUsed cfg T
+ _ ≤ ∑ _ : Fin k, (window R).card := by
+ apply Finset.sum_le_sum
+ intro i _
+ apply Finset.card_le_card
+ intro z hz
+ obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
+ exact mem_window.mpr (h t (by omega) i)
+ _ = k * (2 * R + 1) := by simp
+
+/-- Equal storage and input symbols give equal storage after one step. A relation `r` between
+the input positions is also preserved if it holds initially and after every common head move. -/
+lemma step_congr_storage {input' : List Symbol}
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
+ (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
+ (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
+ (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
+ (tm.step c).storage = (tm.step c').storage ∧
+ r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
+ rcases c with ⟨state, pos, tapes, heads, out⟩
+ rcases c' with ⟨state', pos', tapes', heads', out'⟩
+ simp only [Cfg.storage, Storage.mk.injEq] at hstore
+ rcases hstore with ⟨rfl, rfl, rfl⟩
+ cases state with
+ | none => exact ⟨rfl, hp⟩
+ | some state =>
+ dsimp only [step]
+ unfold Cfg.workTapeSymbols
+ rw [hsym]
+ exact ⟨rfl, hm _⟩
+
/-- Deleting the cells after `a` through `b` preserves symbols at positions at most `a`. -/
private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
(c : Cfg k Symbol State input)
From 13f10033b0ccb79845ceacca7aed733f59c5ea21 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 23:09:50 +0300
Subject: [PATCH 07/25] refactor(MultiTapeTM): include all visit times
---
.../Turing/MultiTape/InputShortening.lean | 272 +++++++++++-------
1 file changed, 163 insertions(+), 109 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index be470067f..27c335010 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -9,15 +9,16 @@ public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Nat.Nth
public import Mathlib.Data.Seq.Basic
+public import Mathlib.Order.Interval.Set.Infinite
/-!
# Input shortening for multi-tape Turing machines
-A visit sequence records the storages seen at a fixed input position during a run. It is defined
-for every run and may be infinite. Visits include the first halted configuration but exclude the
-stationary continuation after halting. For a halting run, the sequence is finite and its storages
-are distinct: repeating a core would repeat the rest of the computation, regardless of the
-write-only output.
+A visit sequence records the storages seen at a fixed input position over the entire run. Both
+visits and their chronological sequence are defined independently of halting. On a halting run,
+the final input position has infinitely many visits, with a constant storage after halting. At
+every other position, the visit sequence is finite and its storages are distinct. The counting
+argument omits the final position.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -53,15 +54,13 @@ lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-/-- Times when the input head is at `p`, with no earlier halted configuration.
-The final configuration is counted once; the stationary continuation after halting is excluded. -/
+/-- All times when the input head is at position `p`. -/
def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
- {t | (tm.runFrom cfg t).inputPos.val = p ∧ ∀ u < t, ¬ (tm.runFrom cfg u).Halted}
+ {t | (tm.runFrom cfg t).inputPos.val = p}
@[simp]
lemma mem_visitTimes {cfg : Cfg k Symbol State input} {p t : ℕ} :
- t ∈ tm.visitTimes cfg p ↔
- (tm.runFrom cfg t).inputPos.val = p ∧ ∀ u < t, ¬ (tm.runFrom cfg u).Halted := Iff.rfl
+ t ∈ tm.visitTimes cfg p ↔ (tm.runFrom cfg t).inputPos.val = p := Iff.rfl
/-- The chronological, possibly infinite sequence of storages encountered at input position `p`. -/
noncomputable def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
@@ -72,23 +71,33 @@ noncomputable def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
else
.ofStream (fun n => (tm.runFrom cfg (Nat.nth (· ∈ tm.visitTimes cfg p) n)).storage)
-/-- On a run whose first halt is at `T`, visits are exactly the head positions through `T`. -/
-lemma visitTimes_eq_of_first_halt {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) (p : ℕ) :
- tm.visitTimes cfg p = {t | t ≤ T ∧ (tm.runFrom cfg t).inputPos.val = p} := by
- ext t
+/-- The final input position has infinitely many visits, since the halted configuration repeats. -/
+lemma visitTimes_infinite_of_halt {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted) :
+ (tm.visitTimes cfg (tm.runFrom cfg T).inputPos.val).Infinite := by
+ apply Set.Infinite.mono ?_ (Set.Ici_infinite T)
+ intro t ht
+ exact congrArg (fun c => c.inputPos.val) (tm.runFrom_eq_of_halt ht hhalt)
+
+/-- Visits to any other input position occur strictly before a halting time. -/
+lemma visitTimes_subset_Iio_of_halt {cfg : Cfg k Symbol State input} {T p : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted) (hp : p ≠ (tm.runFrom cfg T).inputPos.val) :
+ tm.visitTimes cfg p ⊆ Set.Iio T := by
+ intro t ht
+ change t < T
+ by_contra! h
+ exact hp (ht.symm.trans (congrArg (fun c => c.inputPos.val)
+ (tm.runFrom_eq_of_halt h hhalt)))
+
+/-- On a halting run, the visit set is finite exactly away from the final input position. -/
+lemma visitTimes_finite_iff_of_halt {cfg : Cfg k Symbol State input} {T p : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted) :
+ (tm.visitTimes cfg p).Finite ↔ p ≠ (tm.runFrom cfg T).inputPos.val := by
constructor
- · rintro ⟨hp, h⟩
- exact ⟨le_of_not_gt (fun ht => h T ht hhalt), hp⟩
- · rintro ⟨ht, hp⟩
- exact ⟨hp, fun u hu => hfirst u (hu.trans_le ht)⟩
-
-/-- A halting run has finitely many visits to each input position. -/
-lemma visitTimes_finite_of_halt {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) : (tm.visitTimes cfg p).Finite := by
- obtain ⟨T, hT⟩ := hhalt
- exact (Set.finite_Iic T).subset fun t ht => le_of_not_gt (fun h => ht.2 T h hT)
+ · intro hf hp
+ exact tm.visitTimes_infinite_of_halt hhalt (hp ▸ hf)
+ · intro hp
+ exact (Set.finite_Iio T).subset (tm.visitTimes_subset_Iio_of_halt hhalt hp)
/-- When there are finitely many visits, the sequence is the sorted list of their storages. -/
lemma visitSequence_eq_of_finite {cfg : Cfg k Symbol State input} {p : ℕ}
@@ -98,43 +107,53 @@ lemma visitSequence_eq_of_finite {cfg : Cfg k Symbol State input} {p : ℕ}
classical
exact dite_eq_left h
-/-- The visit sequence of a halting run is finite. -/
-lemma visitSequence_terminates_of_halt {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
- (tm.visitSequence cfg p).Terminates := by
- rw [tm.visitSequence_eq_of_finite (tm.visitTimes_finite_of_halt hhalt p)]
- exact Stream'.Seq.terminates_ofList _
-
-/-- Converting a halting run's visit sequence to a list enumerates the visits in time order. -/
-lemma visitSequence_toList {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
- (tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p) =
- (((tm.visitTimes_finite_of_halt hhalt p).toFinset).sort (· ≤ ·)).map
- (fun t => (tm.runFrom cfg t).storage) := by
+/-- A visit sequence terminates exactly when its set of visit times is finite. -/
+@[simp]
+lemma visitSequence_terminates_iff {cfg : Cfg k Symbol State input} {p : ℕ} :
+ (tm.visitSequence cfg p).Terminates ↔ (tm.visitTimes cfg p).Finite := by
+ classical
+ unfold visitSequence
+ split_ifs with h
+ · exact iff_of_true (Stream'.Seq.terminates_ofList _) h
+ · simp only [h, iff_false]
+ exact Stream'.Seq.not_terminates_iff.mpr (fun _ => rfl)
+
+/-- Finitely many visit times give a terminating visit sequence. -/
+lemma visitSequence_terminates {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hf : (tm.visitTimes cfg p).Finite) : (tm.visitSequence cfg p).Terminates :=
+ tm.visitSequence_terminates_iff.mpr hf
+
+/-- Converting a finite visit sequence to a list enumerates its visits in time order. -/
+lemma visitSequence_toList {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hf : (tm.visitTimes cfg p).Finite) :
+ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf) =
+ (hf.toFinset.sort (· ≤ ·)).map (fun t => (tm.runFrom cfg t).storage) := by
apply Stream'.Seq.ofList_injective
rw [Stream'.Seq.ofList_toList, tm.visitSequence_eq_of_finite]
/-- The finite visit sequence has one entry for each visit time. -/
-lemma length_visitSequence {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
- ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)).length =
- (tm.visitTimes_finite_of_halt hhalt p).toFinset.card := by
- simp [tm.visitSequence_toList hhalt p]
-
-/-- No storage occurs twice in a halting run's visit sequence. -/
-lemma visitSequence_nodup {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (p : ℕ) :
- ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)).Nodup := by
+lemma length_visitSequence {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hf : (tm.visitTimes cfg p).Finite) :
+ ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)).length =
+ hf.toFinset.card := by
+ simp [tm.visitSequence_toList hf]
+
+/-- No storage occurs twice in a finite visit sequence of a halting run. -/
+lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (hf : (tm.visitTimes cfg p).Finite) :
+ ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)).Nodup := by
classical
- rw [tm.visitSequence_toList hhalt p]
+ rw [tm.visitSequence_toList hf]
apply List.Nodup.map_on _ (Finset.sort_nodup _ _)
intro a ha b hb h
have ha' : a ∈ tm.visitTimes cfg p := by simpa using ha
have hb' : b ∈ tm.visitTimes cfg p := by simpa using hb
obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
+ have hbefore := tm.visitTimes_subset_Iio_of_halt hT
+ (tm.visitTimes_finite_iff_of_halt hT |>.mp hf)
apply tm.core_runFrom_injOn hT hfirst
- (le_of_not_gt (fun ht => ha'.2 T ht hT)) (le_of_not_gt (fun ht => hb'.2 T ht hT))
- exact Prod.ext (Fin.ext (ha'.1.trans hb'.1.symm)) h
+ (show a ≤ T from (hbefore ha').le) (show b ≤ T from (hbefore hb').le)
+ exact Prod.ext (Fin.ext (ha'.trans hb'.symm)) h
/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
@@ -362,41 +381,53 @@ theorem exists_storage_cut
wlog ht : t ≤ T generalizing t
· rw [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] at hp ⊢
exact this hp le_rfl
+ have hfa : (tm.visitTimes (tm.initCfg input) a).Finite := by
+ by_cases hpa : a = (tm.runFrom (tm.initCfg input) T).inputPos.val
+ · have hfb := (tm.visitTimes_finite_iff_of_halt hT).mpr
+ (show b ≠ (tm.runFrom (tm.initCfg input) T).inputPos.val by omega)
+ have hterm := tm.visitSequence_terminates hfb
+ rw [← hseq] at hterm
+ exact tm.visitSequence_terminates_iff.mp hterm
+ · exact (tm.visitTimes_finite_iff_of_halt hT).mpr hpa
+ have hfb : (tm.visitTimes (tm.initCfg input) b).Finite :=
+ tm.visitSequence_terminates_iff.mp (hseq ▸ tm.visitSequence_terminates hfa)
let c := tm.runFrom (tm.initCfg input)
let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
- let times := fun p => (tm.visitTimes_finite_of_halt hhalt p).toFinset
- let seq := fun p => (tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates_of_halt hhalt p)
- have hmem (p u : ℕ) : u ∈ times p ↔ u ≤ T ∧ (c u).inputPos.val = p := by
- simp only [times, Set.Finite.mem_toFinset, tm.visitTimes_eq_of_first_halt hT hfirst,
- Set.mem_ofPred_eq, c]
- have hseq' : seq a = seq b := by simp only [seq, hseq]
- let m := (times a).card
- have hcard : (times b).card = m := by
- simpa only [seq, tm.length_visitSequence hhalt, times, m] using
+ let seqA := (tm.visitSequence (tm.initCfg input) a).toList (tm.visitSequence_terminates hfa)
+ let seqB := (tm.visitSequence (tm.initCfg input) b).toList (tm.visitSequence_terminates hfb)
+ have hmem {p : ℕ} (hf : (tm.visitTimes (tm.initCfg input) p).Finite) (u : ℕ) :
+ u ∈ hf.toFinset ↔ u ≤ T ∧ (c u).inputPos.val = p := by
+ rw [Set.Finite.mem_toFinset]
+ exact ⟨fun hu => ⟨(tm.visitTimes_subset_Iio_of_halt hT
+ (tm.visitTimes_finite_iff_of_halt hT |>.mp hf) hu).le, hu⟩, And.right⟩
+ have hseq' : seqA = seqB := by simp only [seqA, seqB, hseq]
+ let m := hfa.toFinset.card
+ have hcard : hfb.toFinset.card = m := by
+ simpa only [seqA, seqB, tm.length_visitSequence hfa, tm.length_visitSequence hfb, m] using
(congrArg List.length hseq').symm
- let A := (times a).orderEmbOfFin rfl
- let B := (times b).orderEmbOfFin hcard
+ let A := hfa.toFinset.orderEmbOfFin rfl
+ let B := hfb.toFinset.orderEmbOfFin hcard
have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
- (hmem a _).mp (Finset.orderEmbOfFin_mem _ _ i)
+ (hmem hfa _).mp (Finset.orderEmbOfFin_mem _ _ i)
have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
- (hmem b _).mp (Finset.orderEmbOfFin_mem _ _ i)
+ (hmem hfb _).mp (Finset.orderEmbOfFin_mem _ _ i)
have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
intro u hu hpu
change u ∈ Set.range A
simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- (hmem a u).mpr ⟨hu, hpu⟩
+ (hmem hfa u).mpr ⟨hu, hpu⟩
have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
intro u hu hpu
change u ∈ Set.range B
simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- (hmem b u).mpr ⟨hu, hpu⟩
+ (hmem hfb u).mpr ⟨hu, hpu⟩
have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
intro i
have heq := List.getElem_of_eq hseq' (i := i.val)
- (by simpa only [seq, tm.length_visitSequence hhalt] using i.isLt)
- simpa only [seq, tm.visitSequence_toList hhalt, List.getElem_map, A, B,
- Finset.orderEmbOfFin_apply, Fin.getElem_fin, times, c] using heq
+ (by simpa only [seqA, tm.length_visitSequence hfa] using i.isLt)
+ simpa only [seqA, seqB, tm.visitSequence_toList hfa, tm.visitSequence_toList hfb,
+ List.getElem_map, A, B,
+ Finset.orderEmbOfFin_apply, Fin.getElem_fin, c] using heq
have hmove : ∀ i,
(c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
intro i
@@ -451,38 +482,40 @@ theorem exists_storage_cut
exact ⟨u, hstore⟩
/-- Every entry of a finite visit sequence is a storage reached by the run. -/
-lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) {p : ℕ} {s : Storage Symbol State k}
- (h : s ∈ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates_of_halt hhalt p)) :
+lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hf : (tm.visitTimes cfg p).Finite) {s : Storage Symbol State k}
+ (h : s ∈ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)) :
s ∈ Set.range (fun t => (tm.runFrom cfg t).storage) := by
- rw [tm.visitSequence_toList hhalt p] at h
+ rw [tm.visitSequence_toList hf] at h
obtain ⟨t, _, rfl⟩ := List.mem_map.mp h
exact ⟨t, rfl⟩
-/-- A visit sequence of a halting space-bounded run has length at most the storage bound. -/
-lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {s : ℕ}
+/-- A finite visit sequence of a halting space-bounded run has length at most the storage bound. -/
+lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {s p : ℕ}
(hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
- (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) (p : ℕ) :
+ (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
+ (hf : (tm.visitTimes (tm.initCfg input) p).Finite) :
((tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates_of_halt hhalt p)).length ≤ storageBound Symbol State k s := by
+ (tm.visitSequence_terminates hf)).length ≤ storageBound Symbol State k s := by
classical
- have hn := tm.visitSequence_nodup hhalt p
+ have hn := tm.visitSequence_nodup hhalt hf
have hsub : (((tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates_of_halt hhalt p)).toFinset : Set _) ⊆
+ (tm.visitSequence_terminates hf)).toFinset : Set _) ⊆
Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage) := by
intro x hx
- exact tm.mem_range_of_mem_visitSequence hhalt (List.mem_toFinset.mp hx)
+ exact tm.mem_range_of_mem_visitSequence hf (List.mem_toFinset.mp hx)
have hle := (Set.encard_le_encard hsub).trans (tm.encard_storages_le hs)
rw [Set.encard_coe_eq_coe_finsetCard, List.toFinset_card_of_nodup hn] at hle
exact_mod_cast hle
/-- A sufficiently long input to a halting space-bounded machine can be shortened while
-preserving any designated storage reached by the run. -/
+preserving any designated storage reached by the run. The extra `1` in the length threshold
+accounts for omitting the final input position from the counting argument. -/
theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
(hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
(hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
(hlen : 2 * Fintype.card Symbol *
- (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s < input.length)
+ (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s + 1 < input.length)
(t : ℕ) :
∃ input' : List Symbol, input'.length < input.length ∧
∃ u, (tm.runFrom (tm.initCfg input') u).storage =
@@ -496,43 +529,64 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have h := hbound
rw [← Set.coe_fintypeCard] at h
exact_mod_cast h
- let seq := fun p => (tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates_of_halt hhalt p)
- let enc (p : ℕ) : List S := (seq p).attachWith (· ∈ S)
- (fun _ h => tm.mem_range_of_mem_visitSequence hhalt h)
- have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
+ obtain ⟨T, hT⟩ := hhalt
+ let D := {i : Fin input.length //
+ i.val + 1 ≠ (tm.runFrom (tm.initCfg input) T).inputPos.val}
+ have hsize : input.length - 1 ≤ Fintype.card D := by
+ have hbad : Fintype.card {i : Fin input.length //
+ i.val + 1 = (tm.runFrom (tm.initCfg input) T).inputPos.val} ≤ 1 := by
+ apply Fintype.card_le_one_iff.mpr
+ intro i j
+ apply Subtype.ext
+ apply Fin.ext
+ have := i.property
+ have := j.property
+ omega
+ dsimp only [D]
+ rw [Fintype.card_subtype_compl, Fintype.card_fin]
+ omega
+ have hfinite (i : D) : (tm.visitTimes (tm.initCfg input) (i.val.val + 1)).Finite :=
+ (tm.visitTimes_finite_iff_of_halt hT).mpr i.property
+ let seq := fun i : D => (tm.visitSequence (tm.initCfg input) (i.val.val + 1)).toList
+ (tm.visitSequence_terminates (hfinite i))
+ let enc (i : D) : List S := (seq i).attachWith (· ∈ S)
+ (fun _ h => tm.mem_range_of_mem_visitSequence (hfinite i) h)
+ have henc (i : D) : (enc i).map Subtype.val = seq i :=
List.attachWith_map_subtype_val _
- have hlength (p : ℕ) : (enc p).length ≤ B := by
- simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hhalt hs p
- let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
- (input[i], fun j => (enc (i.val + 1))[j.val]?)
- have heq {i j : Fin input.length} (h : f i = f j) :
- input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1) := by
+ have hlength (i : D) : (enc i).length ≤ B := by
+ simpa only [enc, List.length_attachWith] using
+ tm.length_visitSequence_le ⟨T, hT⟩ hs (hfinite i)
+ let f (i : D) : Symbol × (Fin B → Option S) :=
+ (input[i.val], fun j => (enc i)[j.val]?)
+ have heq {i j : D} (h : f i = f j) :
+ input[i.val] = input[j.val] ∧ tm.visitSequence (tm.initCfg input) (i.val.val + 1) =
+ tm.visitSequence (tm.initCfg input) (j.val.val + 1) := by
refine ⟨congrArg Prod.fst h, ?_⟩
- have hh : enc (i.val + 1) = enc (j.val + 1) := by
+ have hh : enc i = enc j := by
apply List.ext_getElem?
intro r
by_cases hr : r < B
· exact congrFun (congrArg Prod.snd h) ⟨r, hr⟩
- · rw [List.getElem?_eq_none (by have := hlength (i.val + 1); omega),
- List.getElem?_eq_none (by have := hlength (j.val + 1); omega)]
- simpa only [henc] using congrArg (List.map Subtype.val) hh
+ · rw [List.getElem?_eq_none (by have := hlength i; omega),
+ List.getElem?_eq_none (by have := hlength j; omega)]
+ have hseq : seq i = seq j := by simpa only [henc] using congrArg (List.map Subtype.val) hh
+ simpa only [seq, Stream'.Seq.ofList_toList] using congrArg Stream'.Seq.ofList hseq
have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
Fintype.card Symbol * (B + 1) ^ B := by
simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
gcongr
omega
obtain ⟨v, hv⟩ := Fintype.exists_lt_card_fiber_of_mul_lt_card f (n := 2) (by
- rw [Fintype.card_fin]
- change 2 * Fintype.card Symbol * (B + 1) ^ B < input.length at hlen
+ change 2 * Fintype.card Symbol * (B + 1) ^ B + 1 < input.length at hlen
calc Fintype.card (Symbol × (Fin B → Option S)) * 2
_ ≤ (Fintype.card Symbol * (B + 1) ^ B) * 2 := Nat.mul_le_mul_right 2 hsig
_ = 2 * Fintype.card Symbol * (B + 1) ^ B := by ring
- _ < input.length := hlen)
- let e := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
+ _ < Fintype.card D := by omega)
+ let eD := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
(show 3 ≤ (Finset.univ.filter (fun i => f i = v)).card by omega)
- have he (i : Fin 3) : f (e i) = v := by
- have hmem : e i ∈ Finset.univ.filter (fun i => f i = v) :=
+ let e : Fin 3 ↪o Fin input.length := eD.trans (OrderEmbedding.subtype _)
+ have he (i : Fin 3) : f (eD i) = v := by
+ have hmem : eD i ∈ Finset.univ.filter (fun i => f i = v) :=
Finset.orderEmbOfCardLe_mem _ _ i
exact (Finset.mem_filter.mp hmem).2
have hab : (e 0).val + 1 < (e 1).val + 1 :=
@@ -542,7 +596,8 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have hab' := heq ((he 0).trans (he 1).symm)
have hbc' := heq ((he 1).trans (he 2).symm)
have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
- (hij' : input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1))
+ (hij' : input[i] = input[j] ∧ tm.visitSequence (tm.initCfg input) (i.val + 1) =
+ tm.visitSequence (tm.initCfg input) (j.val + 1))
(hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ i.val + 1 ∨
j.val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ input' : List Symbol, input'.length < input.length ∧
@@ -553,10 +608,9 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have := i.isLt
have := j.isLt
omega
- · apply tm.exists_storage_cut hhalt (by omega) hij (by have := j.isLt; omega)
+ · exact tm.exists_storage_cut ⟨T, hT⟩ (by omega) hij (by have := j.isLt; omega)
(by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
- ?_ hpos
- simpa only [seq, Stream'.Seq.ofList_toList] using congrArg Stream'.Seq.ofList hij'.2
+ hij'.2 hpos
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
(e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
· exact cut hab hab' hpos
From 3022d4cdbbc12ecfc8b7ae6106261ed080d1eeb1 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 23:25:46 +0300
Subject: [PATCH 08/25] refactor(MultiTapeTM): computable visit sequences
---
.../Turing/MultiTape/InputShortening.lean | 489 ++++++++----------
1 file changed, 204 insertions(+), 285 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 27c335010..3fa64d000 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -7,18 +7,21 @@ module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
-public import Mathlib.Data.Nat.Nth
-public import Mathlib.Data.Seq.Basic
+public import Mathlib.Data.Finset.Sort
+public import Mathlib.Data.Nat.Count
+public import Mathlib.Data.Part
public import Mathlib.Order.Interval.Set.Infinite
/-!
# Input shortening for multi-tape Turing machines
-A visit sequence records the storages seen at a fixed input position over the entire run. Both
-visits and their chronological sequence are defined independently of halting. On a halting run,
-the final input position has infinitely many visits, with a constant storage after halting. At
-every other position, the visit sequence is finite and its storages are distinct. The counting
-argument omits the final position.
+A visit sequence records the storages seen at a fixed input position over the entire run.
+Its entries are partial values (`Part`): searching for the `n`th visit returns its storage if that
+visit occurs. Both definitions are computable and independent of halting.
+
+Equal visit sequences allow an interval of the input to be deleted. Finite visit sets have distinct
+storages, so their cardinalities are bounded by the storage bound. On a halting run only the final
+input position has infinitely many visits; the counting argument omits that position.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -40,20 +43,6 @@ lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
| succ t ih =>
simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
-/-- The cores up to and including the first halt are pairwise distinct. -/
-lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
- Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
- intro a ha b hb heq
- wlog hab : a ≤ b generalizing a b
- · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
- by_contra hne
- change b ≤ T at hb
- have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
- exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-
/-- All times when the input head is at position `p`. -/
def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
{t | (tm.runFrom cfg t).inputPos.val = p}
@@ -62,14 +51,56 @@ def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
lemma mem_visitTimes {cfg : Cfg k Symbol State input} {p t : ℕ} :
t ∈ tm.visitTimes cfg p ↔ (tm.runFrom cfg t).inputPos.val = p := Iff.rfl
-/-- The chronological, possibly infinite sequence of storages encountered at input position `p`. -/
-noncomputable def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
- Stream'.Seq (Storage Symbol State k) := by
- classical
- exact if h : (tm.visitTimes cfg p).Finite then
- .ofList ((h.toFinset.sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage)
- else
- .ofStream (fun n => (tm.runFrom cfg (Nat.nth (· ∈ tm.visitTimes cfg p) n)).storage)
+instance {cfg : Cfg k Symbol State input} {p : ℕ} :
+ DecidablePred (· ∈ tm.visitTimes cfg p) := fun _ =>
+ inferInstanceAs (Decidable ((_ : ℕ) = p))
+
+/-- The storage at the `n`th visit to `p`, obtained by searching the run in time order.
+An entry is undefined if that visit never occurs. No halting assumption is needed. -/
+def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
+ ℕ → Part (Storage Symbol State k) := fun n =>
+ ⟨∃ t ∈ tm.visitTimes cfg p, Nat.count (· ∈ tm.visitTimes cfg p) t = n,
+ fun h => (tm.runFrom cfg (Nat.find h)).storage⟩
+
+/-- An entry records the storage at the visit with exactly `n` earlier visits. -/
+lemma mem_visitSequence {cfg : Cfg k Symbol State input} {p n : ℕ}
+ {s : Storage Symbol State k} :
+ s ∈ tm.visitSequence cfg p n ↔ ∃ t ∈ tm.visitTimes cfg p,
+ Nat.count (· ∈ tm.visitTimes cfg p) t = n ∧ (tm.runFrom cfg t).storage = s := by
+ constructor
+ · rintro ⟨h, hs⟩
+ exact ⟨Nat.find h, (Nat.find_spec h).1, (Nat.find_spec h).2, hs⟩
+ · rintro ⟨t, ht, hn, rfl⟩
+ let h : ∃ u ∈ tm.visitTimes cfg p, Nat.count (· ∈ tm.visitTimes cfg p) u = n :=
+ ⟨t, ht, hn⟩
+ exact ⟨h, congrArg (fun u => (tm.runFrom cfg u).storage)
+ (Nat.count_injective (Nat.find_spec h).1 ht ((Nat.find_spec h).2.trans hn.symm))⟩
+
+/-- Equal visit sequences match visit times in order and preserve their storages. -/
+lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {a b : ℕ}
+ (hseq : tm.visitSequence cfg a = tm.visitSequence cfg b) :
+ ∃ e : tm.visitTimes cfg a ≃o tm.visitTimes cfg b,
+ ∀ t : tm.visitTimes cfg a,
+ (tm.runFrom cfg t).storage = (tm.runFrom cfg (e t)).storage := by
+ have hmatch (t : tm.visitTimes cfg a) : ∃ u : tm.visitTimes cfg b,
+ Nat.count (· ∈ tm.visitTimes cfg a) t = Nat.count (· ∈ tm.visitTimes cfg b) u ∧
+ (tm.runFrom cfg t).storage = (tm.runFrom cfg u).storage := by
+ have h := tm.mem_visitSequence.mpr ⟨t, t.property, rfl, rfl⟩
+ rw [hseq] at h
+ obtain ⟨u, hu, hn, hs⟩ := tm.mem_visitSequence.mp h
+ exact ⟨⟨u, hu⟩, hn.symm, hs.symm⟩
+ choose f hf hs using hmatch
+ have hmono : StrictMono f := fun t u h => Nat.lt_of_count_lt_count (by
+ rw [← hf t, ← hf u]
+ exact Nat.count_strict_mono t.property h)
+ have hsurj : Function.Surjective f := by
+ intro u
+ have h := tm.mem_visitSequence.mpr ⟨u, u.property, rfl, rfl⟩
+ rw [← hseq] at h
+ obtain ⟨t, ht, hn, _⟩ := tm.mem_visitSequence.mp h
+ exact ⟨⟨t, ht⟩, Subtype.ext (Nat.count_injective (f ⟨t, ht⟩).property u.property
+ ((hf ⟨t, ht⟩).symm.trans hn))⟩
+ exact ⟨OrderIso.ofSurjective (OrderEmbedding.ofStrictMono f hmono) hsurj, hs⟩
/-- The final input position has infinitely many visits, since the halted configuration repeats. -/
lemma visitTimes_infinite_of_halt {cfg : Cfg k Symbol State input} {T : ℕ}
@@ -99,62 +130,6 @@ lemma visitTimes_finite_iff_of_halt {cfg : Cfg k Symbol State input} {T p : ℕ}
· intro hp
exact (Set.finite_Iio T).subset (tm.visitTimes_subset_Iio_of_halt hhalt hp)
-/-- When there are finitely many visits, the sequence is the sorted list of their storages. -/
-lemma visitSequence_eq_of_finite {cfg : Cfg k Symbol State input} {p : ℕ}
- (h : (tm.visitTimes cfg p).Finite) :
- tm.visitSequence cfg p = Stream'.Seq.ofList
- ((h.toFinset.sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage) := by
- classical
- exact dite_eq_left h
-
-/-- A visit sequence terminates exactly when its set of visit times is finite. -/
-@[simp]
-lemma visitSequence_terminates_iff {cfg : Cfg k Symbol State input} {p : ℕ} :
- (tm.visitSequence cfg p).Terminates ↔ (tm.visitTimes cfg p).Finite := by
- classical
- unfold visitSequence
- split_ifs with h
- · exact iff_of_true (Stream'.Seq.terminates_ofList _) h
- · simp only [h, iff_false]
- exact Stream'.Seq.not_terminates_iff.mpr (fun _ => rfl)
-
-/-- Finitely many visit times give a terminating visit sequence. -/
-lemma visitSequence_terminates {cfg : Cfg k Symbol State input} {p : ℕ}
- (hf : (tm.visitTimes cfg p).Finite) : (tm.visitSequence cfg p).Terminates :=
- tm.visitSequence_terminates_iff.mpr hf
-
-/-- Converting a finite visit sequence to a list enumerates its visits in time order. -/
-lemma visitSequence_toList {cfg : Cfg k Symbol State input} {p : ℕ}
- (hf : (tm.visitTimes cfg p).Finite) :
- (tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf) =
- (hf.toFinset.sort (· ≤ ·)).map (fun t => (tm.runFrom cfg t).storage) := by
- apply Stream'.Seq.ofList_injective
- rw [Stream'.Seq.ofList_toList, tm.visitSequence_eq_of_finite]
-
-/-- The finite visit sequence has one entry for each visit time. -/
-lemma length_visitSequence {cfg : Cfg k Symbol State input} {p : ℕ}
- (hf : (tm.visitTimes cfg p).Finite) :
- ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)).length =
- hf.toFinset.card := by
- simp [tm.visitSequence_toList hf]
-
-/-- No storage occurs twice in a finite visit sequence of a halting run. -/
-lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {p : ℕ}
- (hhalt : ∃ T, (tm.runFrom cfg T).Halted) (hf : (tm.visitTimes cfg p).Finite) :
- ((tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)).Nodup := by
- classical
- rw [tm.visitSequence_toList hf]
- apply List.Nodup.map_on _ (Finset.sort_nodup _ _)
- intro a ha b hb h
- have ha' : a ∈ tm.visitTimes cfg p := by simpa using ha
- have hb' : b ∈ tm.visitTimes cfg p := by simpa using hb
- obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
- have hbefore := tm.visitTimes_subset_Iio_of_halt hT
- (tm.visitTimes_finite_iff_of_halt hT |>.mp hf)
- apply tm.core_runFrom_injOn hT hfirst
- (show a ≤ T from (hbefore ha').le) (show b ≤ T from (hbefore hb').le)
- exact Prod.ext (Fin.ext (ha'.trans hb'.symm)) h
-
/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
(h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
@@ -170,11 +145,11 @@ lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T
_ = k * (2 * R + 1) := by simp
/-- Equal storage and input symbols give equal storage after one step. A relation `r` between
-the input positions is also preserved if it holds initially and after every common head move. -/
+the input positions is also preserved if it holds after every common head move. -/
lemma step_congr_storage {input' : List Symbol}
{c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
(hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
- (r : ℕ → ℕ → Prop) (hp : r c.inputPos.val c'.inputPos.val)
+ (r : ℕ → ℕ → Prop)
(hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
(tm.step c).storage = (tm.step c').storage ∧
r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
@@ -183,7 +158,7 @@ lemma step_congr_storage {input' : List Symbol}
simp only [Cfg.storage, Storage.mk.injEq] at hstore
rcases hstore with ⟨rfl, rfl, rfl⟩
cases state with
- | none => exact ⟨rfl, hp⟩
+ | none => exact ⟨rfl, by simpa only [moveInputPos_zero, step] using hm 0⟩
| some state =>
dsimp only [step]
unfold Cfg.workTapeSymbols
@@ -264,109 +239,95 @@ private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
/-- Matching ordered visits at `a` and `b` allow the portions of a walk outside `(a, b)`
to be joined. Any predicate `R` preserved along those portions holds throughout the joined walk. -/
-private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m : ℕ}
+private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {a b : ℕ}
(hab : a < b) (hp₀ : p 0 ≤ a)
- (hstep : ∀ t < T, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
- (A B : Fin m ↪o ℕ)
- (hA : ∀ i, A i ≤ T ∧ p (A i) = a)
- (hB : ∀ i, B i ≤ T ∧ p (B i) = b)
- (hAc : ∀ t ≤ T, p t = a → ∃ i, A i = t)
- (hBc : ∀ t ≤ T, p t = b → ∃ i, B i = t)
- (hq : ∀ i, q (A i) = q (B i))
- (hmove : ∀ i, p (A i + 1) + b = p (B i + 1) + a)
+ (hstep : ∀ t, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
+ (e : {t // p t = a} ≃o {t // p t = b})
+ (hq : ∀ t : {t // p t = a}, q t = q (e t))
+ (hmove : ∀ t : {t // p t = a}, p (t + 1) + b = p (e t + 1) + a)
(R : ℕ → S → Prop) (hR₀ : R (p 0) (q 0))
- (hleft : ∀ t < T, p t ≤ a → p (t + 1) ≤ a →
+ (hleft : ∀ t, p t ≤ a → p (t + 1) ≤ a →
R (p t) (q t) → R (p (t + 1)) (q (t + 1)))
- (hright : ∀ t < T, b ≤ p t → b ≤ p (t + 1) →
+ (hright : ∀ t, b ≤ p t → b ≤ p (t + 1) →
R (p t - (b - a)) (q t) → R (p (t + 1) - (b - a)) (q (t + 1))) :
- ∀ t ≤ T, p t ≤ a ∨ b ≤ p t →
+ ∀ t, p t ≤ a ∨ b ≤ p t →
R (if p t ≤ a then p t else p t - (b - a)) (q t) := by
+ classical
have hba : b - (b - a) = a := by omega
- have boundary : ∀ i, R a (q (A i)) := by
- cases m with
- | zero => exact fun i => Fin.elim0 i
- | succ m =>
- intro i
- induction i using Fin.induction with
- | zero =>
- have hno : ∀ t < A 0, p t ≠ a := by
- intro t ht hpt
- obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA 0).1) hpt
- exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) ht
- have hside : ∀ t ≤ A 0, p t ≤ a := by
- intro t ht
- apply propagate (Nat.zero_le t) hp₀
- intro r _ hrt hr
- have := (hstep r (by have := (hA 0).1; omega)).1
- have := hno r (by omega)
+ have boundary : ∀ t, p t = a → R a (q t) := by
+ intro t
+ induction t using Nat.strong_induction_on with
+ | h t ih =>
+ intro ht
+ by_cases hex : ∃ u < t, p u = a
+ · obtain ⟨u, hut, hu, hno⟩ :
+ ∃ u < t, p u = a ∧ ∀ v, u < v → v < t → p v ≠ a := by
+ obtain ⟨v, hvt, hv⟩ := hex
+ refine ⟨Nat.findGreatest (fun u => p u = a) (t - 1),
+ lt_of_le_of_lt (Nat.findGreatest_le _) (by omega),
+ Nat.findGreatest_spec (P := fun u => p u = a) (by omega) hv, ?_⟩
+ exact fun w huw hwt hw => (not_le_of_gt huw)
+ (Nat.le_findGreatest (P := fun u => p u = a) (by omega) hw)
+ let i : {t // p t = a} := ⟨u, hu⟩
+ let j : {t // p t = a} := ⟨t, ht⟩
+ by_cases hdir : p (u + 1) ≤ a
+ · have hside := walk_left (fun v _ _ => (hstep v).1) hu.le hdir hno
+ have hr := propagate hut.le (show R (p u) (q u) from hu ▸ ih u hut hu)
+ fun v huv hvt => hleft v (hside v huv hvt.le) (hside (v + 1) (by omega) hvt)
+ simpa [ht] using hr
+ · have hdir' : b ≤ p (e i + 1) := by
+ have h := hmove i
+ change p (u + 1) + b = p (e i + 1) + a at h
+ omega
+ have hno' : ∀ v, (e i).val < v → v < (e j).val → p v ≠ b := by
+ intro v hiv hvj hv
+ let w : {t // p t = b} := ⟨v, hv⟩
+ exact hno (e.symm w)
+ (show i < e.symm w from e.lt_symm_apply.mpr (show e i < w from hiv))
+ (show e.symm w < j from e.symm_apply_lt.mpr (show w < e j from hvj))
+ (e.symm w).property
+ have hside := walk_right (fun v _ _ => (hstep v).2) (e i).property.ge hdir' hno'
+ have hr := propagate (e.strictMono hut).le
+ (show R (p (e i) - (b - a)) (q (e i)) by
+ simpa only [(e i).property, hba, ← hq i] using ih u hut hu)
+ fun v huv hvt => hright v (hside v huv hvt.le) (hside (v + 1) (by omega) hvt)
+ simpa only [(e j).property, hba, ← hq j] using hr
+ · have hside : ∀ u ≤ t, p u ≤ a := by
+ intro u hut
+ apply propagate (Nat.zero_le u) hp₀
+ intro v _ hvu hv
+ have := (hstep v).1
+ have : p v ≠ a := fun h => hex ⟨v, by omega, h⟩
omega
- have hr := propagate (Nat.zero_le (A 0)) hR₀ fun t _ ht =>
- hleft t (ht.trans_le (hA 0).1) (hside t ht.le) (hside (t + 1) ht)
- simpa [(hA 0).2] using hr
- | succ i ih =>
- have hAj := A.strictMono i.castSucc_lt_succ
- have hBj := B.strictMono i.castSucc_lt_succ
- have hnoA : ∀ t, A i.castSucc < t → t < A i.succ → p t ≠ a := by
- intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i.succ).1) hpt
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hti)))
- (A.lt_iff_lt.mp hjt)
- have hnoB : ∀ t, B i.castSucc < t → t < B i.succ → p t ≠ b := by
- intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i.succ).1) hpt
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hti)))
- (B.lt_iff_lt.mp hjt)
- by_cases hdir : p (A i.castSucc + 1) ≤ a
- · have hside := walk_left
- (fun t (_ : A i.castSucc ≤ t) (ht : t < A i.succ) =>
- (hstep t (ht.trans_le (hA i.succ).1)).1)
- (le_of_eq (hA i.castSucc).2) hdir hnoA
- have hr := propagate hAj.le
- (show R (p (A i.castSucc)) (q (A i.castSucc)) by
- simpa [(hA i.castSucc).2] using ih) fun t hjt hti =>
- hleft t (hti.trans_le (hA i.succ).1)
- (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hA i.succ).2] using hr
- · have hdir' : b ≤ p (B i.castSucc + 1) := by have := hmove i.castSucc; omega
- have hside := walk_right
- (fun t (_ : B i.castSucc ≤ t) (ht : t < B i.succ) =>
- (hstep t (ht.trans_le (hB i.succ).1)).2)
- (ge_of_eq (hB i.castSucc).2) hdir' hnoB
- have hr := propagate hBj.le
- (show R (p (B i.castSucc) - (b - a)) (q (B i.castSucc)) by
- simpa [(hB i.castSucc).2, hba, ← hq i.castSucc] using ih) fun t hjt hti =>
- hright t (hti.trans_le (hB i.succ).1)
- (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hB i.succ).2, hba, ← hq i.succ] using hr
+ have hr := propagate (Nat.zero_le t) hR₀ fun u _ hut =>
+ hleft u (hside u hut.le) (hside (u + 1) hut)
+ simpa [ht] using hr
intro t
induction t with
- | zero => intro _ _; simpa [hp₀] using hR₀
+ | zero => intro _; simpa [hp₀] using hR₀
| succ t ih =>
- intro ht hside
- have hst := hstep t (by omega)
+ intro hside
+ have hst := hstep t
by_cases hl : p (t + 1) ≤ a
· rw [ite_eq_left hl]
by_cases heq : p (t + 1) = a
- · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
- simpa [hi, heq] using boundary i
+ · simpa [heq] using boundary (t + 1) heq
· have hprev : p t ≤ a := by omega
- exact hleft t (by omega) hprev hl (by
- simpa [hprev] using ih (by omega) (Or.inl hprev))
+ exact hleft t hprev hl (by simpa [hprev] using ih (Or.inl hprev))
· rw [ite_eq_right hl]
have hr : b ≤ p (t + 1) := hside.resolve_left hl
by_cases heq : p (t + 1) = b
- · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
- simpa [hq i, hi, heq, hba] using boundary i
+ · let j : {t // p t = b} := ⟨t + 1, heq⟩
+ simpa only [hq (e.symm j), e.apply_symm_apply, heq, hba] using
+ boundary (e.symm j) (e.symm j).property
· have hprev : b ≤ p t := by omega
have hprev' : ¬ p t ≤ a := by omega
- exact hright t (by omega) hprev hr (by
- simpa [hprev'] using ih (by omega) (Or.inr hprev))
+ exact hright t hprev hr (by simpa [hprev'] using ih (Or.inr hprev))
-/-- For a halting run, deleting the cells after `a` through `b` preserves every storage reached
-outside the deleted interval, provided the symbols and visit sequences at `a` and `b` agree.
+/-- Deleting the cells after `a` through `b` preserves every storage reached outside the deleted
+interval, provided the symbols and visit sequences at `a` and `b` agree.
Input positions are one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
-theorem exists_storage_cut
- (hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted) {a b : ℕ}
+theorem exists_storage_cut {a b : ℕ}
(ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
(hsym : input[a - 1]? = input[b - 1]?)
(hseq : tm.visitSequence (tm.initCfg input) a =
@@ -377,71 +338,24 @@ theorem exists_storage_cut
∃ u, (tm.runFrom (tm.initCfg (input.take a ++ input.drop b)) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
classical
- obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
- wlog ht : t ≤ T generalizing t
- · rw [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] at hp ⊢
- exact this hp le_rfl
- have hfa : (tm.visitTimes (tm.initCfg input) a).Finite := by
- by_cases hpa : a = (tm.runFrom (tm.initCfg input) T).inputPos.val
- · have hfb := (tm.visitTimes_finite_iff_of_halt hT).mpr
- (show b ≠ (tm.runFrom (tm.initCfg input) T).inputPos.val by omega)
- have hterm := tm.visitSequence_terminates hfb
- rw [← hseq] at hterm
- exact tm.visitSequence_terminates_iff.mp hterm
- · exact (tm.visitTimes_finite_iff_of_halt hT).mpr hpa
- have hfb : (tm.visitTimes (tm.initCfg input) b).Finite :=
- tm.visitSequence_terminates_iff.mp (hseq ▸ tm.visitSequence_terminates hfa)
+ obtain ⟨e, hq⟩ := tm.exists_visitTimes_orderIso hseq
let c := tm.runFrom (tm.initCfg input)
let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
- let seqA := (tm.visitSequence (tm.initCfg input) a).toList (tm.visitSequence_terminates hfa)
- let seqB := (tm.visitSequence (tm.initCfg input) b).toList (tm.visitSequence_terminates hfb)
- have hmem {p : ℕ} (hf : (tm.visitTimes (tm.initCfg input) p).Finite) (u : ℕ) :
- u ∈ hf.toFinset ↔ u ≤ T ∧ (c u).inputPos.val = p := by
- rw [Set.Finite.mem_toFinset]
- exact ⟨fun hu => ⟨(tm.visitTimes_subset_Iio_of_halt hT
- (tm.visitTimes_finite_iff_of_halt hT |>.mp hf) hu).le, hu⟩, And.right⟩
- have hseq' : seqA = seqB := by simp only [seqA, seqB, hseq]
- let m := hfa.toFinset.card
- have hcard : hfb.toFinset.card = m := by
- simpa only [seqA, seqB, tm.length_visitSequence hfa, tm.length_visitSequence hfb, m] using
- (congrArg List.length hseq').symm
- let A := hfa.toFinset.orderEmbOfFin rfl
- let B := hfb.toFinset.orderEmbOfFin hcard
- have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
- (hmem hfa _).mp (Finset.orderEmbOfFin_mem _ _ i)
- have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
- (hmem hfb _).mp (Finset.orderEmbOfFin_mem _ _ i)
- have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
- intro u hu hpu
- change u ∈ Set.range A
- simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- (hmem hfa u).mpr ⟨hu, hpu⟩
- have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
- intro u hu hpu
- change u ∈ Set.range B
- simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- (hmem hfb u).mpr ⟨hu, hpu⟩
- have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
- intro i
- have heq := List.getElem_of_eq hseq' (i := i.val)
- (by simpa only [seqA, tm.length_visitSequence hfa] using i.isLt)
- simpa only [seqA, seqB, tm.visitSequence_toList hfa, tm.visitSequence_toList hfb,
- List.getElem_map, A, B,
- Finset.orderEmbOfFin_apply, Fin.getElem_fin, c] using heq
- have hmove : ∀ i,
- (c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
- intro i
- have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
+ have hA (i : tm.visitTimes (tm.initCfg input) a) : (c i).inputPos.val = a := i.property
+ have hB (i : tm.visitTimes (tm.initCfg input) a) : (c (e i)).inputPos.val = b := (e i).property
+ have hmove (i : tm.visitTimes (tm.initCfg input) a) :
+ (c (i.val + 1)).inputPos.val + b = (c (e i + 1)).inputPos.val + a := by
+ have hsy : (c i).inputSymbol = (c (e i)).inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hA i, hB i]
simpa [Nat.ne_of_gt ha, show b ≠ 0 by omega] using hsym
- have hcong := step_congr_storage (tm := tm) (hq i) hsy
- (fun p p' => p + b = p' + a)
- (by rw [(hA i).2, (hB i).2]; omega) (fun dir => by
- have hm := moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
- (by rw [(hA i).2]; exact ha) (by rw [(hA i).2]; omega)
- (by rw [(hB i).2]; omega) (by rw [(hB i).2]; exact hb) dir
- have := (hA i).2
- have := (hB i).2
+ have hcong := step_congr_storage (tm := tm)
+ (show (c i).storage = (c (e i)).storage from hq i) hsy
+ (fun p p' => p + b = p' + a) (fun dir => by
+ have hm := moveInputPos_interior (c i).inputPos (c (e i)).inputPos
+ (by rw [hA i]; exact ha) (by rw [hA i]; omega)
+ (by rw [hB i]; omega) (by rw [hB i]; exact hb) dir
+ have := hA i
+ have := hB i
omega)
simpa only [c, runFrom_succ_eq_step'] using hcong.2
let R := fun p s => ∃ u, (c' u).inputPos.val = p ∧ (c' u).storage = s
@@ -450,24 +364,24 @@ theorem exists_storage_cut
have hlen : (input.take a ++ input.drop b).length + (b - a) = input.length := by
simp only [List.length_append, List.length_take, List.length_drop]
omega
- have hleft : ∀ u < T, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
+ have hleft : ∀ u, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
R (c u).inputPos.val (c u).storage → R (c (u + 1)).inputPos.val (c (u + 1)).storage := by
- rintro u _ hpu _ ⟨v, hpv, hsv⟩
+ rintro u hpu _ ⟨v, hpv, hsv⟩
have hsy := inputSymbol_cut_left (by omega : a ≤ input.length) (c u) (c' v) hpu hpv
- have hcong := step_congr_storage (tm := tm) hsv.symm hsy Eq hpv.symm
+ have hcong := step_congr_storage (tm := tm) hsv.symm hsy Eq
(fun dir => moveInputPos_same (c u).inputPos (c' v).inputPos hpv.symm
(by omega) (by omega) dir)
refine ⟨v + 1, ?_, ?_⟩
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.2.symm
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
- have hright : ∀ u < T, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
+ have hright : ∀ u, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
R ((c u).inputPos.val - (b - a)) (c u).storage →
R ((c (u + 1)).inputPos.val - (b - a)) (c (u + 1)).storage := by
- rintro u _ hpu _ ⟨v, hpv, hsv⟩
+ rintro u hpu _ ⟨v, hpv, hsv⟩
have hpv' : (c' v).inputPos.val + (b - a) = (c u).inputPos.val := by omega
have hsy := inputSymbol_cut_right ha hab hb hsym (c u) (c' v) hpu hpv'
have hcong := step_congr_storage (tm := tm) hsv.symm hsy
- (fun p p' => p' + (b - a) = p) hpv'
+ (fun p p' => p' + (b - a) = p)
(fun dir => moveInputPos_shift (c u).inputPos (c' v).inputPos hpv' hlen (by omega) dir)
refine ⟨v + 1, ?_, ?_⟩
· have hpos : (c' (v + 1)).inputPos.val + (b - a) = (c (u + 1)).inputPos.val := by
@@ -476,37 +390,38 @@ theorem exists_storage_cut
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
have hglue := glue_visits (fun u => (c u).inputPos.val) (fun u => (c u).storage)
hab (by simp [c]; omega)
- (fun u _ => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
- A B hA hB hAc hBc hq hmove R hR₀ hleft hright t ht hp
+ (fun u => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
+ e hq hmove R hR₀ hleft hright t hp
obtain ⟨u, _, hstore⟩ := hglue
exact ⟨u, hstore⟩
-/-- Every entry of a finite visit sequence is a storage reached by the run. -/
-lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {p : ℕ}
- (hf : (tm.visitTimes cfg p).Finite) {s : Storage Symbol State k}
- (h : s ∈ (tm.visitSequence cfg p).toList (tm.visitSequence_terminates hf)) :
- s ∈ Set.range (fun t => (tm.runFrom cfg t).storage) := by
- rw [tm.visitSequence_toList hf] at h
- obtain ⟨t, _, rfl⟩ := List.mem_map.mp h
- exact ⟨t, rfl⟩
-
-/-- A finite visit sequence of a halting space-bounded run has length at most the storage bound. -/
-lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {s p : ℕ}
- (hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
+/-- A finite set of visits has distinct storages: a repeated core would force another visit
+strictly after the last one. -/
+lemma storage_runFrom_injOn_visitTimes {cfg : Cfg k Symbol State input} {p : ℕ}
+ (hf : (tm.visitTimes cfg p).Finite) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).storage) (tm.visitTimes cfg p) := by
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ obtain ⟨T, hT, hmax⟩ := hf.toFinset.exists_max_image id ⟨a, hf.mem_toFinset.mpr ha⟩
+ have haT : a ≤ T := hmax a (hf.mem_toFinset.mpr ha)
+ have hcore := tm.core_runFrom_eq_of_core_eq
+ (Prod.ext (Fin.ext (ha.trans hb.symm)) heq) (T - a)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le haT] at hcore
+ have hvisit : b + (T - a) ∈ tm.visitTimes cfg p :=
+ (congrArg Fin.val (congrArg Prod.fst hcore)).symm.trans (hf.mem_toFinset.mp hT)
+ have := hmax _ (hf.mem_toFinset.mpr hvisit)
+ dsimp only [id] at this
+ omega
+
+/-- A finite visit set of a space-bounded run has cardinality at most the storage bound. -/
+lemma encard_visitTimes_le [Fintype Symbol] [Fintype State] {s p : ℕ}
(hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
(hf : (tm.visitTimes (tm.initCfg input) p).Finite) :
- ((tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates hf)).length ≤ storageBound Symbol State k s := by
- classical
- have hn := tm.visitSequence_nodup hhalt hf
- have hsub : (((tm.visitSequence (tm.initCfg input) p).toList
- (tm.visitSequence_terminates hf)).toFinset : Set _) ⊆
- Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage) := by
- intro x hx
- exact tm.mem_range_of_mem_visitSequence hf (List.mem_toFinset.mp hx)
- have hle := (Set.encard_le_encard hsub).trans (tm.encard_storages_le hs)
- rw [Set.encard_coe_eq_coe_finsetCard, List.toFinset_card_of_nodup hn] at hle
- exact_mod_cast hle
+ (tm.visitTimes (tm.initCfg input) p).encard ≤ storageBound Symbol State k s :=
+ (Set.encard_le_encard_of_injOn
+ (t := Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage)) (fun t _ => ⟨t, rfl⟩)
+ (tm.storage_runFrom_injOn_visitTimes hf)).trans (tm.encard_storages_le hs)
/-- A sufficiently long input to a halting space-bounded machine can be shortened while
preserving any designated storage reached by the run. The extra `1` in the length threshold
@@ -547,30 +462,34 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
omega
have hfinite (i : D) : (tm.visitTimes (tm.initCfg input) (i.val.val + 1)).Finite :=
(tm.visitTimes_finite_iff_of_halt hT).mpr i.property
- let seq := fun i : D => (tm.visitSequence (tm.initCfg input) (i.val.val + 1)).toList
- (tm.visitSequence_terminates (hfinite i))
- let enc (i : D) : List S := (seq i).attachWith (· ∈ S)
- (fun _ h => tm.mem_range_of_mem_visitSequence (hfinite i) h)
- have henc (i : D) : (enc i).map Subtype.val = seq i :=
- List.attachWith_map_subtype_val _
- have hlength (i : D) : (enc i).length ≤ B := by
- simpa only [enc, List.length_attachWith] using
- tm.length_visitSequence_le ⟨T, hT⟩ hs (hfinite i)
+ let enc (p n : ℕ) : Option S :=
+ if h : (tm.visitSequence (tm.initCfg input) p n).Dom then
+ some ⟨(tm.visitSequence (tm.initCfg input) p n).get h, by
+ obtain ⟨u, _, _, hu⟩ := tm.mem_visitSequence.mp (Part.get_mem h)
+ exact ⟨u, hu⟩⟩
+ else none
+ have henc (p n : ℕ) : (enc p n).map Subtype.val =
+ (tm.visitSequence (tm.initCfg input) p n).toOption := by
+ dsimp only [enc, Part.toOption]
+ split_ifs <;> rfl
+ have hindex (i : D) {n : ℕ} (hn : (tm.visitSequence (tm.initCfg input) (i.val.val + 1) n).Dom) :
+ n < B := by
+ obtain ⟨u, hu, rfl⟩ := hn
+ have hbound := tm.encard_visitTimes_le hs (hfinite i)
+ rw [← Set.Finite.coe_toFinset (hfinite i), Set.encard_coe_eq_coe_finsetCard] at hbound
+ exact (Nat.count_lt_card (hfinite i) hu).trans_le (by exact_mod_cast hbound)
let f (i : D) : Symbol × (Fin B → Option S) :=
- (input[i.val], fun j => (enc i)[j.val]?)
+ (input[i.val], fun j => enc (i.val.val + 1) j)
have heq {i j : D} (h : f i = f j) :
input[i.val] = input[j.val] ∧ tm.visitSequence (tm.initCfg input) (i.val.val + 1) =
tm.visitSequence (tm.initCfg input) (j.val.val + 1) := by
- refine ⟨congrArg Prod.fst h, ?_⟩
- have hh : enc i = enc j := by
- apply List.ext_getElem?
- intro r
- by_cases hr : r < B
- · exact congrFun (congrArg Prod.snd h) ⟨r, hr⟩
- · rw [List.getElem?_eq_none (by have := hlength i; omega),
- List.getElem?_eq_none (by have := hlength j; omega)]
- have hseq : seq i = seq j := by simpa only [henc] using congrArg (List.map Subtype.val) hh
- simpa only [seq, Stream'.Seq.ofList_toList] using congrArg Stream'.Seq.ofList hseq
+ refine ⟨congrArg Prod.fst h, funext fun n => ?_⟩
+ by_cases hn : n < B
+ · have he := congrArg (Option.map Subtype.val) (congrFun (congrArg Prod.snd h) ⟨n, hn⟩)
+ change (enc (i.val.val + 1) n).map Subtype.val = (enc (j.val.val + 1) n).map Subtype.val at he
+ simpa only [henc, Part.of_toOption] using congrArg Part.ofOption he
+ · rw [Part.eq_none_iff'.mpr (fun hd => hn (hindex i hd)),
+ Part.eq_none_iff'.mpr (fun hd => hn (hindex j hd))]
have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
Fintype.card Symbol * (B + 1) ^ B := by
simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
@@ -608,7 +527,7 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have := i.isLt
have := j.isLt
omega
- · exact tm.exists_storage_cut ⟨T, hT⟩ (by omega) hij (by have := j.isLt; omega)
+ · exact tm.exists_storage_cut (by omega) hij (by have := j.isLt; omega)
(by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
hij'.2 hpos
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
From 2fc6be8c35c31c544fd96991cf1d12468381f78d Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 23:50:40 +0300
Subject: [PATCH 09/25] refactor(MultiTapeTM): use weak visit sequences
---
Cslib.lean | 1 +
.../Turing/MultiTape/InputShortening.lean | 128 +++++++-------
Cslib/Foundations/Data/WSeq.lean | 157 ++++++++++++++++++
3 files changed, 226 insertions(+), 60 deletions(-)
create mode 100644 Cslib/Foundations/Data/WSeq.lean
diff --git a/Cslib.lean b/Cslib.lean
index 74355b55d..941a4d4f3 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -105,6 +105,7 @@ public import Cslib.Foundations.Data.PFunctor.Free
public import Cslib.Foundations.Data.RelatesInSteps
public import Cslib.Foundations.Data.Set.Saturation
public import Cslib.Foundations.Data.StackTape
+public import Cslib.Foundations.Data.WSeq
public import Cslib.Foundations.Lint.Basic
public import Cslib.Foundations.Logic.InferenceSystem
public import Cslib.Foundations.Logic.LogicalEquivalence
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 3fa64d000..81bb9ea80 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -6,22 +6,22 @@ Authors: Aviv Bar Natan
module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
+public import Cslib.Foundations.Data.WSeq
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Finset.Sort
-public import Mathlib.Data.Nat.Count
-public import Mathlib.Data.Part
+public import Mathlib.Data.WSeq.Relation
public import Mathlib.Order.Interval.Set.Infinite
/-!
# Input shortening for multi-tape Turing machines
A visit sequence records the storages seen at a fixed input position over the entire run.
-Its entries are partial values (`Part`): searching for the `n`th visit returns its storage if that
-visit occurs. Both definitions are computable and independent of halting.
+It is a computable weak sequence (`Stream'.WSeq`), obtained by filtering the run. Steps when the
+head is elsewhere contribute waiting steps. Both definitions are independent of halting.
-Equal visit sequences allow an interval of the input to be deleted. Finite visit sets have distinct
-storages, so their cardinalities are bounded by the storage bound. On a halting run only the final
-input position has infinitely many visits; the counting argument omits that position.
+Equivalent visit sequences allow an interval of the input to be deleted. Finite visit sets have
+distinct storages, so their cardinalities are bounded by the storage bound. On a halting run only
+the final input position has infinitely many visits; the counting argument omits that position.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -31,6 +31,8 @@ The input-shortening argument follows Gadi Aleksandrowicz's account at
namespace Turing.MultiTapeTM
+open Stream'.WSeq (Equiv)
+
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
@@ -55,49 +57,48 @@ instance {cfg : Cfg k Symbol State input} {p : ℕ} :
DecidablePred (· ∈ tm.visitTimes cfg p) := fun _ =>
inferInstanceAs (Decidable ((_ : ℕ) = p))
-/-- The storage at the `n`th visit to `p`, obtained by searching the run in time order.
-An entry is undefined if that visit never occurs. No halting assumption is needed. -/
+/-- The chronological sequence of storages seen at `p`, with waiting steps between visits. -/
def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
- ℕ → Part (Storage Symbol State k) := fun n =>
- ⟨∃ t ∈ tm.visitTimes cfg p, Nat.count (· ∈ tm.visitTimes cfg p) t = n,
- fun h => (tm.runFrom cfg (Nat.find h)).storage⟩
-
-/-- An entry records the storage at the visit with exactly `n` earlier visits. -/
-lemma mem_visitSequence {cfg : Cfg k Symbol State input} {p n : ℕ}
- {s : Storage Symbol State k} :
- s ∈ tm.visitSequence cfg p n ↔ ∃ t ∈ tm.visitTimes cfg p,
- Nat.count (· ∈ tm.visitTimes cfg p) t = n ∧ (tm.runFrom cfg t).storage = s := by
- constructor
- · rintro ⟨h, hs⟩
- exact ⟨Nat.find h, (Nat.find_spec h).1, (Nat.find_spec h).2, hs⟩
- · rintro ⟨t, ht, hn, rfl⟩
- let h : ∃ u ∈ tm.visitTimes cfg p, Nat.count (· ∈ tm.visitTimes cfg p) u = n :=
- ⟨t, ht, hn⟩
- exact ⟨h, congrArg (fun u => (tm.runFrom cfg u).storage)
- (Nat.count_injective (Nat.find_spec h).1 ht ((Nat.find_spec h).2.trans hn.symm))⟩
-
-/-- Equal visit sequences match visit times in order and preserve their storages. -/
+ Stream'.WSeq (Storage Symbol State k) :=
+ (Stream'.WSeq.ofStream (Stream'.iterate tm.step cfg)).filterMap fun c =>
+ if c.inputPos.val = p then some c.storage else none
+
+/-- A lookup returns the storage at the visit with exactly `n` earlier visits. -/
+lemma mem_get?_visitSequence {cfg : Cfg k Symbol State input} {p n : ℕ}
+ {o : Option (Storage Symbol State k)} :
+ o ∈ (tm.visitSequence cfg p).get? n ↔ ∃ t ∈ tm.visitTimes cfg p,
+ Nat.count (· ∈ tm.visitTimes cfg p) t = n ∧ o = some (tm.runFrom cfg t).storage := by
+ rw [visitSequence, Stream'.WSeq.mem_get?_filterMap_ofStream]
+ have hrun (t : ℕ) : (Stream'.iterate tm.step cfg).get t = tm.runFrom cfg t := by
+ induction t with
+ | zero => rfl
+ | succ t ih =>
+ simpa only [Stream'.get_succ_iterate', runFrom_succ_eq_step'] using congrArg tm.step ih
+ simp [hrun, visitTimes, ite_eq_iff, and_assoc]
+ rfl
+
+/-- Equivalent visit sequences match visit times in order and preserve their storages. -/
lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {a b : ℕ}
- (hseq : tm.visitSequence cfg a = tm.visitSequence cfg b) :
+ (hseq : Equiv (tm.visitSequence cfg a) (tm.visitSequence cfg b)) :
∃ e : tm.visitTimes cfg a ≃o tm.visitTimes cfg b,
∀ t : tm.visitTimes cfg a,
(tm.runFrom cfg t).storage = (tm.runFrom cfg (e t)).storage := by
have hmatch (t : tm.visitTimes cfg a) : ∃ u : tm.visitTimes cfg b,
Nat.count (· ∈ tm.visitTimes cfg a) t = Nat.count (· ∈ tm.visitTimes cfg b) u ∧
(tm.runFrom cfg t).storage = (tm.runFrom cfg u).storage := by
- have h := tm.mem_visitSequence.mpr ⟨t, t.property, rfl, rfl⟩
- rw [hseq] at h
- obtain ⟨u, hu, hn, hs⟩ := tm.mem_visitSequence.mp h
- exact ⟨⟨u, hu⟩, hn.symm, hs.symm⟩
+ have h := tm.mem_get?_visitSequence.mpr ⟨t, t.property, rfl, rfl⟩
+ have h := (Stream'.WSeq.get?_congr hseq _ _).mp h
+ obtain ⟨u, hu, hn, hs⟩ := tm.mem_get?_visitSequence.mp h
+ exact ⟨⟨u, hu⟩, hn.symm, Option.some.inj hs⟩
choose f hf hs using hmatch
have hmono : StrictMono f := fun t u h => Nat.lt_of_count_lt_count (by
rw [← hf t, ← hf u]
exact Nat.count_strict_mono t.property h)
have hsurj : Function.Surjective f := by
intro u
- have h := tm.mem_visitSequence.mpr ⟨u, u.property, rfl, rfl⟩
- rw [← hseq] at h
- obtain ⟨t, ht, hn, _⟩ := tm.mem_visitSequence.mp h
+ have h := tm.mem_get?_visitSequence.mpr ⟨u, u.property, rfl, rfl⟩
+ have h := (Stream'.WSeq.get?_congr hseq _ _).mpr h
+ obtain ⟨t, ht, hn, _⟩ := tm.mem_get?_visitSequence.mp h
exact ⟨⟨t, ht⟩, Subtype.ext (Nat.count_injective (f ⟨t, ht⟩).property u.property
((hf ⟨t, ht⟩).symm.trans hn))⟩
exact ⟨OrderIso.ofSurjective (OrderEmbedding.ofStrictMono f hmono) hsurj, hs⟩
@@ -330,8 +331,8 @@ Input positions are one-based, as in `Cfg.inputPos`; neither cut position is an
theorem exists_storage_cut {a b : ℕ}
(ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
(hsym : input[a - 1]? = input[b - 1]?)
- (hseq : tm.visitSequence (tm.initCfg input) a =
- tm.visitSequence (tm.initCfg input) b)
+ (hseq : Equiv (tm.visitSequence (tm.initCfg input) a)
+ (tm.visitSequence (tm.initCfg input) b))
{t : ℕ}
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ a ∨
b ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
@@ -463,33 +464,40 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have hfinite (i : D) : (tm.visitTimes (tm.initCfg input) (i.val.val + 1)).Finite :=
(tm.visitTimes_finite_iff_of_halt hT).mpr i.property
let enc (p n : ℕ) : Option S :=
- if h : (tm.visitSequence (tm.initCfg input) p n).Dom then
- some ⟨(tm.visitSequence (tm.initCfg input) p n).get h, by
- obtain ⟨u, _, _, hu⟩ := tm.mem_visitSequence.mp (Part.get_mem h)
- exact ⟨u, hu⟩⟩
+ if h : ∃ s, some s ∈ (tm.visitSequence (tm.initCfg input) p).get? n then
+ some ⟨h.choose, by
+ obtain ⟨u, _, _, hu⟩ := tm.mem_get?_visitSequence.mp h.choose_spec
+ exact ⟨u, (Option.some.inj hu).symm⟩⟩
else none
- have henc (p n : ℕ) : (enc p n).map Subtype.val =
- (tm.visitSequence (tm.initCfg input) p n).toOption := by
- dsimp only [enc, Part.toOption]
- split_ifs <;> rfl
- have hindex (i : D) {n : ℕ} (hn : (tm.visitSequence (tm.initCfg input) (i.val.val + 1) n).Dom) :
- n < B := by
- obtain ⟨u, hu, rfl⟩ := hn
+ have henc (p n : ℕ) (s : Storage Symbol State k) :
+ s ∈ (enc p n).map Subtype.val ↔ some s ∈ (tm.visitSequence (tm.initCfg input) p).get? n := by
+ dsimp only [enc]
+ split_ifs with h
+ · simp only [Option.map_some, Option.mem_some_iff]
+ exact ⟨fun hs => hs ▸ h.choose_spec,
+ fun hs => Option.some.inj (Computation.mem_unique h.choose_spec hs)⟩
+ · simp only [Option.map_none, Option.not_mem_none, false_iff]
+ exact fun hs => h ⟨s, hs⟩
+ have hindex (i : D) {n : ℕ} {s : Storage Symbol State k}
+ (hn : some s ∈ (tm.visitSequence (tm.initCfg input) (i.val.val + 1)).get? n) : n < B := by
+ obtain ⟨u, hu, rfl, _⟩ := tm.mem_get?_visitSequence.mp hn
have hbound := tm.encard_visitTimes_le hs (hfinite i)
rw [← Set.Finite.coe_toFinset (hfinite i), Set.encard_coe_eq_coe_finsetCard] at hbound
exact (Nat.count_lt_card (hfinite i) hu).trans_le (by exact_mod_cast hbound)
let f (i : D) : Symbol × (Fin B → Option S) :=
(input[i.val], fun j => enc (i.val.val + 1) j)
have heq {i j : D} (h : f i = f j) :
- input[i.val] = input[j.val] ∧ tm.visitSequence (tm.initCfg input) (i.val.val + 1) =
- tm.visitSequence (tm.initCfg input) (j.val.val + 1) := by
- refine ⟨congrArg Prod.fst h, funext fun n => ?_⟩
- by_cases hn : n < B
- · have he := congrArg (Option.map Subtype.val) (congrFun (congrArg Prod.snd h) ⟨n, hn⟩)
- change (enc (i.val.val + 1) n).map Subtype.val = (enc (j.val.val + 1) n).map Subtype.val at he
- simpa only [henc, Part.of_toOption] using congrArg Part.ofOption he
- · rw [Part.eq_none_iff'.mpr (fun hd => hn (hindex i hd)),
- Part.eq_none_iff'.mpr (fun hd => hn (hindex j hd))]
+ input[i.val] = input[j.val] ∧ Equiv (tm.visitSequence (tm.initCfg input) (i.val.val + 1))
+ (tm.visitSequence (tm.initCfg input) (j.val.val + 1)) := by
+ refine ⟨congrArg Prod.fst h, Stream'.WSeq.Equiv.ext fun n o => ?_⟩
+ cases o with
+ | none => simp [tm.mem_get?_visitSequence]
+ | some s =>
+ by_cases hn : n < B
+ · rw [← henc, ← henc]
+ exact Iff.of_eq (congrArg (fun o => s ∈ o.map Subtype.val)
+ (congrFun (congrArg Prod.snd h) ⟨n, hn⟩))
+ · exact iff_of_false (fun hd => hn (hindex i hd)) (fun hd => hn (hindex j hd))
have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
Fintype.card Symbol * (B + 1) ^ B := by
simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
@@ -515,8 +523,8 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have hab' := heq ((he 0).trans (he 1).symm)
have hbc' := heq ((he 1).trans (he 2).symm)
have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
- (hij' : input[i] = input[j] ∧ tm.visitSequence (tm.initCfg input) (i.val + 1) =
- tm.visitSequence (tm.initCfg input) (j.val + 1))
+ (hij' : input[i] = input[j] ∧ Equiv (tm.visitSequence (tm.initCfg input) (i.val + 1))
+ (tm.visitSequence (tm.initCfg input) (j.val + 1)))
(hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ i.val + 1 ∨
j.val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ input' : List Symbol, input'.length < input.length ∧
diff --git a/Cslib/Foundations/Data/WSeq.lean b/Cslib/Foundations/Data/WSeq.lean
new file mode 100644
index 000000000..bf61f1229
--- /dev/null
+++ b/Cslib/Foundations/Data/WSeq.lean
@@ -0,0 +1,157 @@
+/-
+Copyright (c) 2026 Aviv Bar Natan. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Aviv Bar Natan
+-/
+module
+
+public import Cslib.Init
+public import Mathlib.Data.Nat.Count
+public import Mathlib.Data.WSeq.Defs
+
+/-!
+# Filtering streams into weak sequences
+
+Filtering a stream produces a computable weak sequence, with a waiting step for each omitted
+value. These lemmas describe `filterMap` and identify each emitted entry by counting earlier
+outputs, without assuming that another output exists.
+-/
+
+@[expose] public section
+
+namespace Stream'.WSeq
+
+variable {α β : Type*}
+
+/-- Filtering a weak sequence maps its output steps and preserves its waiting steps. -/
+lemma filterMap_eq_map (f : α → Option β) (s : WSeq α) :
+ filterMap f s = Seq.map (fun o => o.bind f) s := by
+ unfold filterMap
+ dsimp only [WSeq] at *
+ apply Seq.coinduction2 s
+ intro s
+ rw [Seq.corec_eq]
+ induction s using Seq.recOn with
+ | nil => simp only [Seq.destruct_nil, Seq.map_nil, Seq.BisimO, Seq.omap]
+ | cons a s =>
+ cases a <;> simp only [Seq.destruct_cons, Seq.map_cons, Seq.BisimO, Option.bind]
+ all_goals exact ⟨rfl, s, rfl, rfl⟩
+
+/-- Filtering a stream produces one output or waiting step per stream element. -/
+lemma filterMap_ofStream (f : α → Option β) (s : Stream' α) :
+ filterMap f (ofStream s) = Seq.ofStream (s.map f) := by
+ rw [filterMap_eq_map]
+ rfl
+
+/-- A waiting step delays every lookup by one computation step. -/
+@[simp]
+lemma get?_think (s : WSeq α) (n : ℕ) : get? (think s) n = (get? s n).think := by
+ rw [get?, dropn_think, head_think]
+ rfl
+
+/-- The first entry of a sequence with an output at its head is available immediately. -/
+@[simp]
+lemma get?_cons_zero (a : α) (s : WSeq α) : get? (cons a s) 0 = Computation.pure (some a) := by
+ rw [get?, drop, head_cons]
+
+/-- Looking past an output at the head reduces the lookup index by one. -/
+@[simp]
+lemma get?_cons_succ (a : α) (s : WSeq α) (n : ℕ) : get? (cons a s) (n + 1) = get? s n := by
+ rw [get?, dropn_cons]
+ rfl
+
+/-- Expose one computation step of a stream of optional outputs. -/
+private lemma ofStream_unfold (f : Stream' (Option α)) :
+ (Seq.ofStream f : WSeq α) = match f.head with
+ | none => think (Seq.ofStream f.tail)
+ | some a => cons a (Seq.ofStream f.tail) := by
+ conv_lhs => rw [← Stream'.eta f, Seq.ofStream_cons]
+ cases f.head <;> rfl
+
+/-- A lookup either waits, returns the head, or continues with the remaining outputs. -/
+private lemma get?_ofStream_eq (f : Stream' (Option α)) (n : ℕ) :
+ get? (Seq.ofStream f : WSeq α) n = match f.head with
+ | none => (get? (Seq.ofStream f.tail : WSeq α) n).think
+ | some a => match n with
+ | 0 => Computation.pure (some a)
+ | n + 1 => get? (Seq.ofStream f.tail : WSeq α) n := by
+ rw [ofStream_unfold]
+ cases f.head with
+ | none => exact get?_think _ _
+ | some a =>
+ cases n with
+ | zero => exact get?_cons_zero _ _
+ | succ n => exact get?_cons_succ _ _ _
+
+/-- A result of looking up an entry comes from the corresponding output of the stream. -/
+private lemma get?_ofStream_sound (f : Stream' (Option α)) (n m : ℕ) {o : Option α}
+ (h : (get? (Seq.ofStream f : WSeq α) n).val.get m = some o) :
+ ∃ t a, f.get t = some a ∧ Nat.count (fun t => (f.get t).isSome) t = n ∧ o = some a := by
+ rw [get?_ofStream_eq] at h
+ cases hf : f.head with
+ | none =>
+ simp only [hf] at h
+ cases m with
+ | zero => cases h
+ | succ m =>
+ obtain ⟨t, a, ht, hn, rfl⟩ := get?_ofStream_sound f.tail n m h
+ refine ⟨t + 1, a, ht, ?_, rfl⟩
+ rw [Nat.count_succ']
+ change Nat.count (fun t => (f.tail.get t).isSome) t +
+ (if f.head.isSome then 1 else 0) = n
+ simpa [hf] using hn
+ | some a =>
+ cases n with
+ | zero =>
+ simp only [hf] at h
+ change some (some a) = some o at h
+ have ho : o = some a := (Option.some.inj h).symm
+ exact ⟨0, a, hf, Nat.count_zero _, ho⟩
+ | succ n =>
+ simp only [hf] at h
+ obtain ⟨t, b, ht, hn, rfl⟩ := get?_ofStream_sound f.tail n m h
+ refine ⟨t + 1, b, ht, ?_, rfl⟩
+ rw [Nat.count_succ']
+ change Nat.count (fun t => (f.tail.get t).isSome) t +
+ (if f.head.isSome then 1 else 0) = n + 1
+ simp only [hf, Option.isSome_some, ite_true, hn]
+termination_by n + m
+
+/-- Every output of the stream occurs at the index counting its earlier outputs. -/
+private lemma get?_ofStream_complete (f : Stream' (Option α)) {t : ℕ} {a : α}
+ (h : f.get t = some a) :
+ some a ∈ get? (Seq.ofStream f : WSeq α)
+ (Nat.count (fun t => (f.get t).isSome) t) := by
+ induction t generalizing f with
+ | zero =>
+ rw [get?_ofStream_eq, Nat.count_zero]
+ change some a ∈ (match f.get 0 with
+ | none => _
+ | some a => Computation.pure (some a))
+ rw [h]
+ exact Computation.ret_mem _
+ | succ t ih =>
+ have hc : Nat.count (fun t => (f.get t).isSome) (t + 1) =
+ Nat.count (fun t => (f.tail.get t).isSome) t + if f.head.isSome then 1 else 0 :=
+ Nat.count_succ' _ t
+ rw [hc, get?_ofStream_eq]
+ cases hf : f.head with
+ | none =>
+ simpa only [hf, Option.isSome_none, Bool.false_eq_true, ite_false, Nat.add_zero] using
+ Computation.think_mem (ih f.tail h)
+ | some b =>
+ simpa only [hf, Option.isSome_some, ite_true] using
+ ih f.tail h
+
+/-- Looking up a filtered stream skips omitted values and preserves the order of its outputs. -/
+lemma mem_get?_filterMap_ofStream {f : α → Option β} {s : Stream' α} {n : ℕ} {o : Option β} :
+ o ∈ get? (filterMap f (ofStream s)) n ↔ ∃ t a, f (s.get t) = some a ∧
+ Nat.count (fun t => (f (s.get t)).isSome) t = n ∧ o = some a := by
+ rw [filterMap_ofStream]
+ constructor
+ · rintro ⟨m, hm⟩
+ exact get?_ofStream_sound (s.map f) n m hm.symm
+ · rintro ⟨t, a, ht, rfl, rfl⟩
+ exact get?_ofStream_complete (s.map f) ht
+
+end Stream'.WSeq
From e98ba6f65f9470cdcfbbb2fbc72c20f32c6960fb Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sat, 12 Sep 2026 23:56:05 +0300
Subject: [PATCH 10/25] refactor(MultiTapeTM): restore bounded visit sequences
---
Cslib.lean | 1 -
.../Turing/MultiTape/InputShortening.lean | 507 ++++++++----------
Cslib/Foundations/Data/WSeq.lean | 157 ------
3 files changed, 230 insertions(+), 435 deletions(-)
delete mode 100644 Cslib/Foundations/Data/WSeq.lean
diff --git a/Cslib.lean b/Cslib.lean
index 941a4d4f3..74355b55d 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -105,7 +105,6 @@ public import Cslib.Foundations.Data.PFunctor.Free
public import Cslib.Foundations.Data.RelatesInSteps
public import Cslib.Foundations.Data.Set.Saturation
public import Cslib.Foundations.Data.StackTape
-public import Cslib.Foundations.Data.WSeq
public import Cslib.Foundations.Lint.Basic
public import Cslib.Foundations.Logic.InferenceSystem
public import Cslib.Foundations.Logic.LogicalEquivalence
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 81bb9ea80..e2b166479 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -6,22 +6,15 @@ Authors: Aviv Bar Natan
module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
-public import Cslib.Foundations.Data.WSeq
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Finset.Sort
-public import Mathlib.Data.WSeq.Relation
-public import Mathlib.Order.Interval.Set.Infinite
/-!
# Input shortening for multi-tape Turing machines
-A visit sequence records the storages seen at a fixed input position over the entire run.
-It is a computable weak sequence (`Stream'.WSeq`), obtained by filtering the run. Steps when the
-head is elsewhere contribute waiting steps. Both definitions are independent of halting.
-
-Equivalent visit sequences allow an interval of the input to be deleted. Finite visit sets have
-distinct storages, so their cardinalities are bounded by the storage bound. On a halting run only
-the final input position has infinitely many visits; the counting argument omits that position.
+A visit sequence records the storages seen at a fixed input position during a finite run.
+Up to the first halt, these storages are distinct: repeating a core would repeat the rest of the
+computation, regardless of the write-only output.
The input-shortening argument follows Gadi Aleksandrowicz's account at
.
@@ -31,8 +24,6 @@ The input-shortening argument follows Gadi Aleksandrowicz's account at
namespace Turing.MultiTapeTM
-open Stream'.WSeq (Equiv)
-
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
@@ -45,91 +36,50 @@ lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
| succ t ih =>
simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
-/-- All times when the input head is at position `p`. -/
-def visitTimes (cfg : Cfg k Symbol State input) (p : ℕ) : Set ℕ :=
- {t | (tm.runFrom cfg t).inputPos.val = p}
-
-@[simp]
-lemma mem_visitTimes {cfg : Cfg k Symbol State input} {p t : ℕ} :
- t ∈ tm.visitTimes cfg p ↔ (tm.runFrom cfg t).inputPos.val = p := Iff.rfl
-
-instance {cfg : Cfg k Symbol State input} {p : ℕ} :
- DecidablePred (· ∈ tm.visitTimes cfg p) := fun _ =>
- inferInstanceAs (Decidable ((_ : ℕ) = p))
-
-/-- The chronological sequence of storages seen at `p`, with waiting steps between visits. -/
-def visitSequence (cfg : Cfg k Symbol State input) (p : ℕ) :
- Stream'.WSeq (Storage Symbol State k) :=
- (Stream'.WSeq.ofStream (Stream'.iterate tm.step cfg)).filterMap fun c =>
- if c.inputPos.val = p then some c.storage else none
-
-/-- A lookup returns the storage at the visit with exactly `n` earlier visits. -/
-lemma mem_get?_visitSequence {cfg : Cfg k Symbol State input} {p n : ℕ}
- {o : Option (Storage Symbol State k)} :
- o ∈ (tm.visitSequence cfg p).get? n ↔ ∃ t ∈ tm.visitTimes cfg p,
- Nat.count (· ∈ tm.visitTimes cfg p) t = n ∧ o = some (tm.runFrom cfg t).storage := by
- rw [visitSequence, Stream'.WSeq.mem_get?_filterMap_ofStream]
- have hrun (t : ℕ) : (Stream'.iterate tm.step cfg).get t = tm.runFrom cfg t := by
- induction t with
- | zero => rfl
- | succ t ih =>
- simpa only [Stream'.get_succ_iterate', runFrom_succ_eq_step'] using congrArg tm.step ih
- simp [hrun, visitTimes, ite_eq_iff, and_assoc]
- rfl
+/-- The cores up to and including the first halt are pairwise distinct. -/
+lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ by_contra hne
+ change b ≤ T at hb
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-/-- Equivalent visit sequences match visit times in order and preserve their storages. -/
-lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {a b : ℕ}
- (hseq : Equiv (tm.visitSequence cfg a) (tm.visitSequence cfg b)) :
- ∃ e : tm.visitTimes cfg a ≃o tm.visitTimes cfg b,
- ∀ t : tm.visitTimes cfg a,
- (tm.runFrom cfg t).storage = (tm.runFrom cfg (e t)).storage := by
- have hmatch (t : tm.visitTimes cfg a) : ∃ u : tm.visitTimes cfg b,
- Nat.count (· ∈ tm.visitTimes cfg a) t = Nat.count (· ∈ tm.visitTimes cfg b) u ∧
- (tm.runFrom cfg t).storage = (tm.runFrom cfg u).storage := by
- have h := tm.mem_get?_visitSequence.mpr ⟨t, t.property, rfl, rfl⟩
- have h := (Stream'.WSeq.get?_congr hseq _ _).mp h
- obtain ⟨u, hu, hn, hs⟩ := tm.mem_get?_visitSequence.mp h
- exact ⟨⟨u, hu⟩, hn.symm, Option.some.inj hs⟩
- choose f hf hs using hmatch
- have hmono : StrictMono f := fun t u h => Nat.lt_of_count_lt_count (by
- rw [← hf t, ← hf u]
- exact Nat.count_strict_mono t.property h)
- have hsurj : Function.Surjective f := by
- intro u
- have h := tm.mem_get?_visitSequence.mpr ⟨u, u.property, rfl, rfl⟩
- have h := (Stream'.WSeq.get?_congr hseq _ _).mpr h
- obtain ⟨t, ht, hn, _⟩ := tm.mem_get?_visitSequence.mp h
- exact ⟨⟨t, ht⟩, Subtype.ext (Nat.count_injective (f ⟨t, ht⟩).property u.property
- ((hf ⟨t, ht⟩).symm.trans hn))⟩
- exact ⟨OrderIso.ofSurjective (OrderEmbedding.ofStrictMono f hmono) hsurj, hs⟩
+/-- Times up to `T` at which the input head is at `p`. -/
+def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
+ (Finset.range (T + 1)).filter fun t => (tm.runFrom cfg t).inputPos.val = p
-/-- The final input position has infinitely many visits, since the halted configuration repeats. -/
-lemma visitTimes_infinite_of_halt {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted) :
- (tm.visitTimes cfg (tm.runFrom cfg T).inputPos.val).Infinite := by
- apply Set.Infinite.mono ?_ (Set.Ici_infinite T)
- intro t ht
- exact congrArg (fun c => c.inputPos.val) (tm.runFrom_eq_of_halt ht hhalt)
+@[simp]
+lemma mem_visitTimes {cfg : Cfg k Symbol State input} {T p t : ℕ} :
+ t ∈ tm.visitTimes cfg T p ↔ t ≤ T ∧ (tm.runFrom cfg t).inputPos.val = p := by
+ simp [visitTimes]
-/-- Visits to any other input position occur strictly before a halting time. -/
-lemma visitTimes_subset_Iio_of_halt {cfg : Cfg k Symbol State input} {T p : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted) (hp : p ≠ (tm.runFrom cfg T).inputPos.val) :
- tm.visitTimes cfg p ⊆ Set.Iio T := by
- intro t ht
- change t < T
- by_contra! h
- exact hp (ht.symm.trans (congrArg (fun c => c.inputPos.val)
- (tm.runFrom_eq_of_halt h hhalt)))
+/-- The chronological list of storages encountered at input position `p` through time `T`. -/
+def visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) : List (Storage Symbol State k) :=
+ ((tm.visitTimes cfg T p).sort (· ≤ ·)).map fun t => (tm.runFrom cfg t).storage
-/-- On a halting run, the visit set is finite exactly away from the final input position. -/
-lemma visitTimes_finite_iff_of_halt {cfg : Cfg k Symbol State input} {T p : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted) :
- (tm.visitTimes cfg p).Finite ↔ p ≠ (tm.runFrom cfg T).inputPos.val := by
- constructor
- · intro hf hp
- exact tm.visitTimes_infinite_of_halt hhalt (hp ▸ hf)
- · intro hp
- exact (Set.finite_Iio T).subset (tm.visitTimes_subset_Iio_of_halt hhalt hp)
+@[simp]
+lemma length_visitSequence (cfg : Cfg k Symbol State input) (T p : ℕ) :
+ (tm.visitSequence cfg T p).length = (tm.visitTimes cfg T p).card := by
+ simp [visitSequence]
+
+/-- No storage occurs twice at one input position before the first halt. -/
+lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) (p : ℕ) :
+ (tm.visitSequence cfg T p).Nodup := by
+ classical
+ apply List.Nodup.map_on _ (Finset.sort_nodup _ _)
+ intro a ha b hb h
+ have ha' := tm.mem_visitTimes.mp (by simpa using ha)
+ have hb' := tm.mem_visitTimes.mp (by simpa using hb)
+ apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
+ exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
@@ -240,123 +190,163 @@ private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
/-- Matching ordered visits at `a` and `b` allow the portions of a walk outside `(a, b)`
to be joined. Any predicate `R` preserved along those portions holds throughout the joined walk. -/
-private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {a b : ℕ}
+private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m : ℕ}
(hab : a < b) (hp₀ : p 0 ≤ a)
- (hstep : ∀ t, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
- (e : {t // p t = a} ≃o {t // p t = b})
- (hq : ∀ t : {t // p t = a}, q t = q (e t))
- (hmove : ∀ t : {t // p t = a}, p (t + 1) + b = p (e t + 1) + a)
+ (hstep : ∀ t < T, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
+ (A B : Fin m ↪o ℕ)
+ (hA : ∀ i, A i ≤ T ∧ p (A i) = a)
+ (hB : ∀ i, B i ≤ T ∧ p (B i) = b)
+ (hAc : ∀ t ≤ T, p t = a → ∃ i, A i = t)
+ (hBc : ∀ t ≤ T, p t = b → ∃ i, B i = t)
+ (hq : ∀ i, q (A i) = q (B i))
+ (hmove : ∀ i, p (A i + 1) + b = p (B i + 1) + a)
(R : ℕ → S → Prop) (hR₀ : R (p 0) (q 0))
- (hleft : ∀ t, p t ≤ a → p (t + 1) ≤ a →
+ (hleft : ∀ t < T, p t ≤ a → p (t + 1) ≤ a →
R (p t) (q t) → R (p (t + 1)) (q (t + 1)))
- (hright : ∀ t, b ≤ p t → b ≤ p (t + 1) →
+ (hright : ∀ t < T, b ≤ p t → b ≤ p (t + 1) →
R (p t - (b - a)) (q t) → R (p (t + 1) - (b - a)) (q (t + 1))) :
- ∀ t, p t ≤ a ∨ b ≤ p t →
+ ∀ t ≤ T, p t ≤ a ∨ b ≤ p t →
R (if p t ≤ a then p t else p t - (b - a)) (q t) := by
- classical
have hba : b - (b - a) = a := by omega
- have boundary : ∀ t, p t = a → R a (q t) := by
- intro t
- induction t using Nat.strong_induction_on with
- | h t ih =>
- intro ht
- by_cases hex : ∃ u < t, p u = a
- · obtain ⟨u, hut, hu, hno⟩ :
- ∃ u < t, p u = a ∧ ∀ v, u < v → v < t → p v ≠ a := by
- obtain ⟨v, hvt, hv⟩ := hex
- refine ⟨Nat.findGreatest (fun u => p u = a) (t - 1),
- lt_of_le_of_lt (Nat.findGreatest_le _) (by omega),
- Nat.findGreatest_spec (P := fun u => p u = a) (by omega) hv, ?_⟩
- exact fun w huw hwt hw => (not_le_of_gt huw)
- (Nat.le_findGreatest (P := fun u => p u = a) (by omega) hw)
- let i : {t // p t = a} := ⟨u, hu⟩
- let j : {t // p t = a} := ⟨t, ht⟩
- by_cases hdir : p (u + 1) ≤ a
- · have hside := walk_left (fun v _ _ => (hstep v).1) hu.le hdir hno
- have hr := propagate hut.le (show R (p u) (q u) from hu ▸ ih u hut hu)
- fun v huv hvt => hleft v (hside v huv hvt.le) (hside (v + 1) (by omega) hvt)
- simpa [ht] using hr
- · have hdir' : b ≤ p (e i + 1) := by
- have h := hmove i
- change p (u + 1) + b = p (e i + 1) + a at h
- omega
- have hno' : ∀ v, (e i).val < v → v < (e j).val → p v ≠ b := by
- intro v hiv hvj hv
- let w : {t // p t = b} := ⟨v, hv⟩
- exact hno (e.symm w)
- (show i < e.symm w from e.lt_symm_apply.mpr (show e i < w from hiv))
- (show e.symm w < j from e.symm_apply_lt.mpr (show w < e j from hvj))
- (e.symm w).property
- have hside := walk_right (fun v _ _ => (hstep v).2) (e i).property.ge hdir' hno'
- have hr := propagate (e.strictMono hut).le
- (show R (p (e i) - (b - a)) (q (e i)) by
- simpa only [(e i).property, hba, ← hq i] using ih u hut hu)
- fun v huv hvt => hright v (hside v huv hvt.le) (hside (v + 1) (by omega) hvt)
- simpa only [(e j).property, hba, ← hq j] using hr
- · have hside : ∀ u ≤ t, p u ≤ a := by
- intro u hut
- apply propagate (Nat.zero_le u) hp₀
- intro v _ hvu hv
- have := (hstep v).1
- have : p v ≠ a := fun h => hex ⟨v, by omega, h⟩
+ have boundary : ∀ i, R a (q (A i)) := by
+ cases m with
+ | zero => exact fun i => Fin.elim0 i
+ | succ m =>
+ intro i
+ induction i using Fin.induction with
+ | zero =>
+ have hno : ∀ t < A 0, p t ≠ a := by
+ intro t ht hpt
+ obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA 0).1) hpt
+ exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) ht
+ have hside : ∀ t ≤ A 0, p t ≤ a := by
+ intro t ht
+ apply propagate (Nat.zero_le t) hp₀
+ intro r _ hrt hr
+ have := (hstep r (by have := (hA 0).1; omega)).1
+ have := hno r (by omega)
omega
- have hr := propagate (Nat.zero_le t) hR₀ fun u _ hut =>
- hleft u (hside u hut.le) (hside (u + 1) hut)
- simpa [ht] using hr
+ have hr := propagate (Nat.zero_le (A 0)) hR₀ fun t _ ht =>
+ hleft t (ht.trans_le (hA 0).1) (hside t ht.le) (hside (t + 1) ht)
+ simpa [(hA 0).2] using hr
+ | succ i ih =>
+ have hAj := A.strictMono i.castSucc_lt_succ
+ have hBj := B.strictMono i.castSucc_lt_succ
+ have hnoA : ∀ t, A i.castSucc < t → t < A i.succ → p t ≠ a := by
+ intro t hjt hti hpt
+ obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i.succ).1) hpt
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hti)))
+ (A.lt_iff_lt.mp hjt)
+ have hnoB : ∀ t, B i.castSucc < t → t < B i.succ → p t ≠ b := by
+ intro t hjt hti hpt
+ obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i.succ).1) hpt
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hti)))
+ (B.lt_iff_lt.mp hjt)
+ by_cases hdir : p (A i.castSucc + 1) ≤ a
+ · have hside := walk_left
+ (fun t (_ : A i.castSucc ≤ t) (ht : t < A i.succ) =>
+ (hstep t (ht.trans_le (hA i.succ).1)).1)
+ (le_of_eq (hA i.castSucc).2) hdir hnoA
+ have hr := propagate hAj.le
+ (show R (p (A i.castSucc)) (q (A i.castSucc)) by
+ simpa [(hA i.castSucc).2] using ih) fun t hjt hti =>
+ hleft t (hti.trans_le (hA i.succ).1)
+ (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
+ simpa [(hA i.succ).2] using hr
+ · have hdir' : b ≤ p (B i.castSucc + 1) := by have := hmove i.castSucc; omega
+ have hside := walk_right
+ (fun t (_ : B i.castSucc ≤ t) (ht : t < B i.succ) =>
+ (hstep t (ht.trans_le (hB i.succ).1)).2)
+ (ge_of_eq (hB i.castSucc).2) hdir' hnoB
+ have hr := propagate hBj.le
+ (show R (p (B i.castSucc) - (b - a)) (q (B i.castSucc)) by
+ simpa [(hB i.castSucc).2, hba, ← hq i.castSucc] using ih) fun t hjt hti =>
+ hright t (hti.trans_le (hB i.succ).1)
+ (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
+ simpa [(hB i.succ).2, hba, ← hq i.succ] using hr
intro t
induction t with
- | zero => intro _; simpa [hp₀] using hR₀
+ | zero => intro _ _; simpa [hp₀] using hR₀
| succ t ih =>
- intro hside
- have hst := hstep t
+ intro ht hside
+ have hst := hstep t (by omega)
by_cases hl : p (t + 1) ≤ a
· rw [ite_eq_left hl]
by_cases heq : p (t + 1) = a
- · simpa [heq] using boundary (t + 1) heq
+ · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
+ simpa [hi, heq] using boundary i
· have hprev : p t ≤ a := by omega
- exact hleft t hprev hl (by simpa [hprev] using ih (Or.inl hprev))
+ exact hleft t (by omega) hprev hl (by
+ simpa [hprev] using ih (by omega) (Or.inl hprev))
· rw [ite_eq_right hl]
have hr : b ≤ p (t + 1) := hside.resolve_left hl
by_cases heq : p (t + 1) = b
- · let j : {t // p t = b} := ⟨t + 1, heq⟩
- simpa only [hq (e.symm j), e.apply_symm_apply, heq, hba] using
- boundary (e.symm j) (e.symm j).property
+ · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
+ simpa [hq i, hi, heq, hba] using boundary i
· have hprev : b ≤ p t := by omega
have hprev' : ¬ p t ≤ a := by omega
- exact hright t hprev hr (by simpa [hprev'] using ih (Or.inr hprev))
+ exact hright t (by omega) hprev hr (by
+ simpa [hprev'] using ih (by omega) (Or.inr hprev))
+
+/-- The entry at index `i` is the storage at the `i`th visit time. -/
+private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
+ (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
+ (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
+ (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
+ simp [visitSequence, Finset.orderEmbOfFin_apply]
/-- Deleting the cells after `a` through `b` preserves every storage reached outside the deleted
-interval, provided the symbols and visit sequences at `a` and `b` agree.
-Input positions are one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
-theorem exists_storage_cut {a b : ℕ}
+interval, provided the symbols and visit sequences at `a` and `b` agree. Input positions are
+one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
+theorem exists_storage_cut {a b T : ℕ}
(ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
(hsym : input[a - 1]? = input[b - 1]?)
- (hseq : Equiv (tm.visitSequence (tm.initCfg input) a)
- (tm.visitSequence (tm.initCfg input) b))
- {t : ℕ}
+ (hseq : tm.visitSequence (tm.initCfg input) T a =
+ tm.visitSequence (tm.initCfg input) T b)
+ {t : ℕ} (ht : t ≤ T)
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ a ∨
b ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ u, (tm.runFrom (tm.initCfg (input.take a ++ input.drop b)) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
- classical
- obtain ⟨e, hq⟩ := tm.exists_visitTimes_orderIso hseq
let c := tm.runFrom (tm.initCfg input)
let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
- have hA (i : tm.visitTimes (tm.initCfg input) a) : (c i).inputPos.val = a := i.property
- have hB (i : tm.visitTimes (tm.initCfg input) a) : (c (e i)).inputPos.val = b := (e i).property
- have hmove (i : tm.visitTimes (tm.initCfg input) a) :
- (c (i.val + 1)).inputPos.val + b = (c (e i + 1)).inputPos.val + a := by
- have hsy : (c i).inputSymbol = (c (e i)).inputSymbol := by
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hA i, hB i]
+ let m := (tm.visitTimes (tm.initCfg input) T a).card
+ have hcard : (tm.visitTimes (tm.initCfg input) T b).card = m := by
+ simpa [m] using (congrArg List.length hseq).symm
+ let A := (tm.visitTimes (tm.initCfg input) T a).orderEmbOfFin rfl
+ let B := (tm.visitTimes (tm.initCfg input) T b).orderEmbOfFin hcard
+ have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
+ tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
+ tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
+ have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
+ intro u hu hpu
+ change u ∈ Set.range A
+ simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
+ tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
+ intro u hu hpu
+ change u ∈ Set.range B
+ simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
+ tm.mem_visitTimes.mpr ⟨hu, hpu⟩
+ have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
+ intro i
+ have heq := List.getElem_of_eq hseq (i := i.val)
+ (by rw [length_visitSequence]; exact i.isLt)
+ exact (visitSequence_get rfl i).symm.trans (heq.trans (visitSequence_get hcard i))
+ have hmove : ∀ i,
+ (c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
+ intro i
+ have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
simpa [Nat.ne_of_gt ha, show b ≠ 0 by omega] using hsym
- have hcong := step_congr_storage (tm := tm)
- (show (c i).storage = (c (e i)).storage from hq i) hsy
+ have hcong := step_congr_storage (tm := tm) (hq i) hsy
(fun p p' => p + b = p' + a) (fun dir => by
- have hm := moveInputPos_interior (c i).inputPos (c (e i)).inputPos
- (by rw [hA i]; exact ha) (by rw [hA i]; omega)
- (by rw [hB i]; omega) (by rw [hB i]; exact hb) dir
- have := hA i
- have := hB i
+ have hm := moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
+ (by rw [(hA i).2]; exact ha) (by rw [(hA i).2]; omega)
+ (by rw [(hB i).2]; omega) (by rw [(hB i).2]; exact hb) dir
+ have := (hA i).2
+ have := (hB i).2
omega)
simpa only [c, runFrom_succ_eq_step'] using hcong.2
let R := fun p s => ∃ u, (c' u).inputPos.val = p ∧ (c' u).storage = s
@@ -365,9 +355,9 @@ theorem exists_storage_cut {a b : ℕ}
have hlen : (input.take a ++ input.drop b).length + (b - a) = input.length := by
simp only [List.length_append, List.length_take, List.length_drop]
omega
- have hleft : ∀ u, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
+ have hleft : ∀ u < T, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
R (c u).inputPos.val (c u).storage → R (c (u + 1)).inputPos.val (c (u + 1)).storage := by
- rintro u hpu _ ⟨v, hpv, hsv⟩
+ rintro u _ hpu _ ⟨v, hpv, hsv⟩
have hsy := inputSymbol_cut_left (by omega : a ≤ input.length) (c u) (c' v) hpu hpv
have hcong := step_congr_storage (tm := tm) hsv.symm hsy Eq
(fun dir => moveInputPos_same (c u).inputPos (c' v).inputPos hpv.symm
@@ -375,10 +365,10 @@ theorem exists_storage_cut {a b : ℕ}
refine ⟨v + 1, ?_, ?_⟩
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.2.symm
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
- have hright : ∀ u, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
+ have hright : ∀ u < T, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
R ((c u).inputPos.val - (b - a)) (c u).storage →
R ((c (u + 1)).inputPos.val - (b - a)) (c (u + 1)).storage := by
- rintro u hpu _ ⟨v, hpv, hsv⟩
+ rintro u _ hpu _ ⟨v, hpv, hsv⟩
have hpv' : (c' v).inputPos.val + (b - a) = (c u).inputPos.val := by omega
have hsy := inputSymbol_cut_right ha hab hb hsym (c u) (c' v) hpu hpv'
have hcong := step_congr_storage (tm := tm) hsv.symm hsy
@@ -391,52 +381,49 @@ theorem exists_storage_cut {a b : ℕ}
· simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
have hglue := glue_visits (fun u => (c u).inputPos.val) (fun u => (c u).storage)
hab (by simp [c]; omega)
- (fun u => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
- e hq hmove R hR₀ hleft hright t hp
+ (fun u _ => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
+ A B hA hB hAc hBc hq hmove R hR₀ hleft hright t ht hp
obtain ⟨u, _, hstore⟩ := hglue
exact ⟨u, hstore⟩
-/-- A finite set of visits has distinct storages: a repeated core would force another visit
-strictly after the last one. -/
-lemma storage_runFrom_injOn_visitTimes {cfg : Cfg k Symbol State input} {p : ℕ}
- (hf : (tm.visitTimes cfg p).Finite) :
- Set.InjOn (fun t => (tm.runFrom cfg t).storage) (tm.visitTimes cfg p) := by
- intro a ha b hb heq
- wlog hab : a ≤ b generalizing a b
- · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
- obtain ⟨T, hT, hmax⟩ := hf.toFinset.exists_max_image id ⟨a, hf.mem_toFinset.mpr ha⟩
- have haT : a ≤ T := hmax a (hf.mem_toFinset.mpr ha)
- have hcore := tm.core_runFrom_eq_of_core_eq
- (Prod.ext (Fin.ext (ha.trans hb.symm)) heq) (T - a)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le haT] at hcore
- have hvisit : b + (T - a) ∈ tm.visitTimes cfg p :=
- (congrArg Fin.val (congrArg Prod.fst hcore)).symm.trans (hf.mem_toFinset.mp hT)
- have := hmax _ (hf.mem_toFinset.mpr hvisit)
- dsimp only [id] at this
- omega
-
-/-- A finite visit set of a space-bounded run has cardinality at most the storage bound. -/
-lemma encard_visitTimes_le [Fintype Symbol] [Fintype State] {s p : ℕ}
- (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
- (hf : (tm.visitTimes (tm.initCfg input) p).Finite) :
- (tm.visitTimes (tm.initCfg input) p).encard ≤ storageBound Symbol State k s :=
- (Set.encard_le_encard_of_injOn
- (t := Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage)) (fun t _ => ⟨t, rfl⟩)
- (tm.storage_runFrom_injOn_visitTimes hf)).trans (tm.encard_storages_le hs)
+/-- Every entry of a visit sequence is a storage reached by the run. -/
+lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {T p : ℕ}
+ {s : Storage Symbol State k} (h : s ∈ tm.visitSequence cfg T p) :
+ s ∈ Set.range (fun t => (tm.runFrom cfg t).storage) := by
+ obtain ⟨t, _, rfl⟩ := List.mem_map.mp h
+ exact ⟨t, rfl⟩
+
+/-- A visit sequence of a halting space-bounded run has length at most the storage bound. -/
+lemma length_visitSequence_le [Fintype Symbol] [Fintype State] {T s : ℕ}
+ (hhalt : (tm.runFrom (tm.initCfg input) T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom (tm.initCfg input) t).Halted)
+ (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) (p : ℕ) :
+ (tm.visitSequence (tm.initCfg input) T p).length ≤ storageBound Symbol State k s := by
+ classical
+ have hn := tm.visitSequence_nodup hhalt hfirst p
+ have hsub : ((tm.visitSequence (tm.initCfg input) T p).toFinset : Set _) ⊆
+ Set.range (fun t => (tm.runFrom (tm.initCfg input) t).storage) := by
+ intro x hx
+ exact tm.mem_range_of_mem_visitSequence (List.mem_toFinset.mp hx)
+ have hle := (Set.encard_le_encard hsub).trans (tm.encard_storages_le hs)
+ rw [Set.encard_coe_eq_coe_finsetCard, List.toFinset_card_of_nodup hn] at hle
+ exact_mod_cast hle
/-- A sufficiently long input to a halting space-bounded machine can be shortened while
-preserving any designated storage reached by the run. The extra `1` in the length threshold
-accounts for omitting the final input position from the counting argument. -/
+preserving any designated storage reached by the run. -/
theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
(hhalt : ∃ T, (tm.runFrom (tm.initCfg input) T).Halted)
(hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s)
(hlen : 2 * Fintype.card Symbol *
- (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s + 1 < input.length)
+ (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s < input.length)
(t : ℕ) :
∃ input' : List Symbol, input'.length < input.length ∧
∃ u, (tm.runFrom (tm.initCfg input') u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
classical
+ obtain ⟨T, hT, hfirst⟩ := Nat.findX hhalt
+ wlog ht : t ≤ T generalizing t
+ · simpa only [tm.runFrom_eq_of_halt (Nat.le_of_not_ge ht) hT] using this T le_rfl
let B := storageBound Symbol State k s
let S := Set.range (fun u => (tm.runFrom (tm.initCfg input) u).storage)
have hbound : S.encard ≤ B := tm.encard_storages_le hs
@@ -445,75 +432,42 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have h := hbound
rw [← Set.coe_fintypeCard] at h
exact_mod_cast h
- obtain ⟨T, hT⟩ := hhalt
- let D := {i : Fin input.length //
- i.val + 1 ≠ (tm.runFrom (tm.initCfg input) T).inputPos.val}
- have hsize : input.length - 1 ≤ Fintype.card D := by
- have hbad : Fintype.card {i : Fin input.length //
- i.val + 1 = (tm.runFrom (tm.initCfg input) T).inputPos.val} ≤ 1 := by
- apply Fintype.card_le_one_iff.mpr
- intro i j
- apply Subtype.ext
- apply Fin.ext
- have := i.property
- have := j.property
- omega
- dsimp only [D]
- rw [Fintype.card_subtype_compl, Fintype.card_fin]
- omega
- have hfinite (i : D) : (tm.visitTimes (tm.initCfg input) (i.val.val + 1)).Finite :=
- (tm.visitTimes_finite_iff_of_halt hT).mpr i.property
- let enc (p n : ℕ) : Option S :=
- if h : ∃ s, some s ∈ (tm.visitSequence (tm.initCfg input) p).get? n then
- some ⟨h.choose, by
- obtain ⟨u, _, _, hu⟩ := tm.mem_get?_visitSequence.mp h.choose_spec
- exact ⟨u, (Option.some.inj hu).symm⟩⟩
- else none
- have henc (p n : ℕ) (s : Storage Symbol State k) :
- s ∈ (enc p n).map Subtype.val ↔ some s ∈ (tm.visitSequence (tm.initCfg input) p).get? n := by
- dsimp only [enc]
- split_ifs with h
- · simp only [Option.map_some, Option.mem_some_iff]
- exact ⟨fun hs => hs ▸ h.choose_spec,
- fun hs => Option.some.inj (Computation.mem_unique h.choose_spec hs)⟩
- · simp only [Option.map_none, Option.not_mem_none, false_iff]
- exact fun hs => h ⟨s, hs⟩
- have hindex (i : D) {n : ℕ} {s : Storage Symbol State k}
- (hn : some s ∈ (tm.visitSequence (tm.initCfg input) (i.val.val + 1)).get? n) : n < B := by
- obtain ⟨u, hu, rfl, _⟩ := tm.mem_get?_visitSequence.mp hn
- have hbound := tm.encard_visitTimes_le hs (hfinite i)
- rw [← Set.Finite.coe_toFinset (hfinite i), Set.encard_coe_eq_coe_finsetCard] at hbound
- exact (Nat.count_lt_card (hfinite i) hu).trans_le (by exact_mod_cast hbound)
- let f (i : D) : Symbol × (Fin B → Option S) :=
- (input[i.val], fun j => enc (i.val.val + 1) j)
- have heq {i j : D} (h : f i = f j) :
- input[i.val] = input[j.val] ∧ Equiv (tm.visitSequence (tm.initCfg input) (i.val.val + 1))
- (tm.visitSequence (tm.initCfg input) (j.val.val + 1)) := by
- refine ⟨congrArg Prod.fst h, Stream'.WSeq.Equiv.ext fun n o => ?_⟩
- cases o with
- | none => simp [tm.mem_get?_visitSequence]
- | some s =>
- by_cases hn : n < B
- · rw [← henc, ← henc]
- exact Iff.of_eq (congrArg (fun o => s ∈ o.map Subtype.val)
- (congrFun (congrArg Prod.snd h) ⟨n, hn⟩))
- · exact iff_of_false (fun hd => hn (hindex i hd)) (fun hd => hn (hindex j hd))
+ let seq := tm.visitSequence (tm.initCfg input) T
+ let enc (p : ℕ) : List S := (seq p).attachWith (· ∈ S)
+ (fun _ h => tm.mem_range_of_mem_visitSequence h)
+ have henc (p : ℕ) : (enc p).map Subtype.val = seq p :=
+ List.attachWith_map_subtype_val _
+ have hlength (p : ℕ) : (enc p).length ≤ B := by
+ simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hT hfirst hs p
+ let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
+ (input[i], fun j => (enc (i.val + 1))[j.val]?)
+ have heq {i j : Fin input.length} (h : f i = f j) :
+ input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1) := by
+ refine ⟨congrArg Prod.fst h, ?_⟩
+ have hh : enc (i.val + 1) = enc (j.val + 1) := by
+ apply List.ext_getElem?
+ intro r
+ by_cases hr : r < B
+ · exact congrFun (congrArg Prod.snd h) ⟨r, hr⟩
+ · rw [List.getElem?_eq_none (by have := hlength (i.val + 1); omega),
+ List.getElem?_eq_none (by have := hlength (j.val + 1); omega)]
+ simpa only [henc] using congrArg (List.map Subtype.val) hh
have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
Fintype.card Symbol * (B + 1) ^ B := by
simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
gcongr
omega
obtain ⟨v, hv⟩ := Fintype.exists_lt_card_fiber_of_mul_lt_card f (n := 2) (by
- change 2 * Fintype.card Symbol * (B + 1) ^ B + 1 < input.length at hlen
+ rw [Fintype.card_fin]
+ change 2 * Fintype.card Symbol * (B + 1) ^ B < input.length at hlen
calc Fintype.card (Symbol × (Fin B → Option S)) * 2
_ ≤ (Fintype.card Symbol * (B + 1) ^ B) * 2 := Nat.mul_le_mul_right 2 hsig
_ = 2 * Fintype.card Symbol * (B + 1) ^ B := by ring
- _ < Fintype.card D := by omega)
- let eD := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
+ _ < input.length := hlen)
+ let e := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
(show 3 ≤ (Finset.univ.filter (fun i => f i = v)).card by omega)
- let e : Fin 3 ↪o Fin input.length := eD.trans (OrderEmbedding.subtype _)
- have he (i : Fin 3) : f (eD i) = v := by
- have hmem : eD i ∈ Finset.univ.filter (fun i => f i = v) :=
+ have he (i : Fin 3) : f (e i) = v := by
+ have hmem : e i ∈ Finset.univ.filter (fun i => f i = v) :=
Finset.orderEmbOfCardLe_mem _ _ i
exact (Finset.mem_filter.mp hmem).2
have hab : (e 0).val + 1 < (e 1).val + 1 :=
@@ -523,8 +477,7 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have hab' := heq ((he 0).trans (he 1).symm)
have hbc' := heq ((he 1).trans (he 2).symm)
have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
- (hij' : input[i] = input[j] ∧ Equiv (tm.visitSequence (tm.initCfg input) (i.val + 1))
- (tm.visitSequence (tm.initCfg input) (j.val + 1)))
+ (hij' : input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1))
(hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ i.val + 1 ∨
j.val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ input' : List Symbol, input'.length < input.length ∧
@@ -537,7 +490,7 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
omega
· exact tm.exists_storage_cut (by omega) hij (by have := j.isLt; omega)
(by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
- hij'.2 hpos
+ hij'.2 ht hpos
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
(e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
· exact cut hab hab' hpos
diff --git a/Cslib/Foundations/Data/WSeq.lean b/Cslib/Foundations/Data/WSeq.lean
deleted file mode 100644
index bf61f1229..000000000
--- a/Cslib/Foundations/Data/WSeq.lean
+++ /dev/null
@@ -1,157 +0,0 @@
-/-
-Copyright (c) 2026 Aviv Bar Natan. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Aviv Bar Natan
--/
-module
-
-public import Cslib.Init
-public import Mathlib.Data.Nat.Count
-public import Mathlib.Data.WSeq.Defs
-
-/-!
-# Filtering streams into weak sequences
-
-Filtering a stream produces a computable weak sequence, with a waiting step for each omitted
-value. These lemmas describe `filterMap` and identify each emitted entry by counting earlier
-outputs, without assuming that another output exists.
--/
-
-@[expose] public section
-
-namespace Stream'.WSeq
-
-variable {α β : Type*}
-
-/-- Filtering a weak sequence maps its output steps and preserves its waiting steps. -/
-lemma filterMap_eq_map (f : α → Option β) (s : WSeq α) :
- filterMap f s = Seq.map (fun o => o.bind f) s := by
- unfold filterMap
- dsimp only [WSeq] at *
- apply Seq.coinduction2 s
- intro s
- rw [Seq.corec_eq]
- induction s using Seq.recOn with
- | nil => simp only [Seq.destruct_nil, Seq.map_nil, Seq.BisimO, Seq.omap]
- | cons a s =>
- cases a <;> simp only [Seq.destruct_cons, Seq.map_cons, Seq.BisimO, Option.bind]
- all_goals exact ⟨rfl, s, rfl, rfl⟩
-
-/-- Filtering a stream produces one output or waiting step per stream element. -/
-lemma filterMap_ofStream (f : α → Option β) (s : Stream' α) :
- filterMap f (ofStream s) = Seq.ofStream (s.map f) := by
- rw [filterMap_eq_map]
- rfl
-
-/-- A waiting step delays every lookup by one computation step. -/
-@[simp]
-lemma get?_think (s : WSeq α) (n : ℕ) : get? (think s) n = (get? s n).think := by
- rw [get?, dropn_think, head_think]
- rfl
-
-/-- The first entry of a sequence with an output at its head is available immediately. -/
-@[simp]
-lemma get?_cons_zero (a : α) (s : WSeq α) : get? (cons a s) 0 = Computation.pure (some a) := by
- rw [get?, drop, head_cons]
-
-/-- Looking past an output at the head reduces the lookup index by one. -/
-@[simp]
-lemma get?_cons_succ (a : α) (s : WSeq α) (n : ℕ) : get? (cons a s) (n + 1) = get? s n := by
- rw [get?, dropn_cons]
- rfl
-
-/-- Expose one computation step of a stream of optional outputs. -/
-private lemma ofStream_unfold (f : Stream' (Option α)) :
- (Seq.ofStream f : WSeq α) = match f.head with
- | none => think (Seq.ofStream f.tail)
- | some a => cons a (Seq.ofStream f.tail) := by
- conv_lhs => rw [← Stream'.eta f, Seq.ofStream_cons]
- cases f.head <;> rfl
-
-/-- A lookup either waits, returns the head, or continues with the remaining outputs. -/
-private lemma get?_ofStream_eq (f : Stream' (Option α)) (n : ℕ) :
- get? (Seq.ofStream f : WSeq α) n = match f.head with
- | none => (get? (Seq.ofStream f.tail : WSeq α) n).think
- | some a => match n with
- | 0 => Computation.pure (some a)
- | n + 1 => get? (Seq.ofStream f.tail : WSeq α) n := by
- rw [ofStream_unfold]
- cases f.head with
- | none => exact get?_think _ _
- | some a =>
- cases n with
- | zero => exact get?_cons_zero _ _
- | succ n => exact get?_cons_succ _ _ _
-
-/-- A result of looking up an entry comes from the corresponding output of the stream. -/
-private lemma get?_ofStream_sound (f : Stream' (Option α)) (n m : ℕ) {o : Option α}
- (h : (get? (Seq.ofStream f : WSeq α) n).val.get m = some o) :
- ∃ t a, f.get t = some a ∧ Nat.count (fun t => (f.get t).isSome) t = n ∧ o = some a := by
- rw [get?_ofStream_eq] at h
- cases hf : f.head with
- | none =>
- simp only [hf] at h
- cases m with
- | zero => cases h
- | succ m =>
- obtain ⟨t, a, ht, hn, rfl⟩ := get?_ofStream_sound f.tail n m h
- refine ⟨t + 1, a, ht, ?_, rfl⟩
- rw [Nat.count_succ']
- change Nat.count (fun t => (f.tail.get t).isSome) t +
- (if f.head.isSome then 1 else 0) = n
- simpa [hf] using hn
- | some a =>
- cases n with
- | zero =>
- simp only [hf] at h
- change some (some a) = some o at h
- have ho : o = some a := (Option.some.inj h).symm
- exact ⟨0, a, hf, Nat.count_zero _, ho⟩
- | succ n =>
- simp only [hf] at h
- obtain ⟨t, b, ht, hn, rfl⟩ := get?_ofStream_sound f.tail n m h
- refine ⟨t + 1, b, ht, ?_, rfl⟩
- rw [Nat.count_succ']
- change Nat.count (fun t => (f.tail.get t).isSome) t +
- (if f.head.isSome then 1 else 0) = n + 1
- simp only [hf, Option.isSome_some, ite_true, hn]
-termination_by n + m
-
-/-- Every output of the stream occurs at the index counting its earlier outputs. -/
-private lemma get?_ofStream_complete (f : Stream' (Option α)) {t : ℕ} {a : α}
- (h : f.get t = some a) :
- some a ∈ get? (Seq.ofStream f : WSeq α)
- (Nat.count (fun t => (f.get t).isSome) t) := by
- induction t generalizing f with
- | zero =>
- rw [get?_ofStream_eq, Nat.count_zero]
- change some a ∈ (match f.get 0 with
- | none => _
- | some a => Computation.pure (some a))
- rw [h]
- exact Computation.ret_mem _
- | succ t ih =>
- have hc : Nat.count (fun t => (f.get t).isSome) (t + 1) =
- Nat.count (fun t => (f.tail.get t).isSome) t + if f.head.isSome then 1 else 0 :=
- Nat.count_succ' _ t
- rw [hc, get?_ofStream_eq]
- cases hf : f.head with
- | none =>
- simpa only [hf, Option.isSome_none, Bool.false_eq_true, ite_false, Nat.add_zero] using
- Computation.think_mem (ih f.tail h)
- | some b =>
- simpa only [hf, Option.isSome_some, ite_true] using
- ih f.tail h
-
-/-- Looking up a filtered stream skips omitted values and preserves the order of its outputs. -/
-lemma mem_get?_filterMap_ofStream {f : α → Option β} {s : Stream' α} {n : ℕ} {o : Option β} :
- o ∈ get? (filterMap f (ofStream s)) n ↔ ∃ t a, f (s.get t) = some a ∧
- Nat.count (fun t => (f (s.get t)).isSome) t = n ∧ o = some a := by
- rw [filterMap_ofStream]
- constructor
- · rintro ⟨m, hm⟩
- exact get?_ofStream_sound (s.map f) n m hm.symm
- · rintro ⟨t, a, ht, rfl, rfl⟩
- exact get?_ofStream_complete (s.map f) ht
-
-end Stream'.WSeq
From ae6fbac4e2845367411bf4a4e8ad7aab96d61663 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 00:13:16 +0300
Subject: [PATCH 11/25] refactor(MultiTapeTM): encapsulate input cuts
---
.../Turing/MultiTape/Configuration.lean | 2 +-
.../Turing/MultiTape/InputShortening.lean | 468 ++++++++++--------
2 files changed, 261 insertions(+), 209 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
index 75398d14e..d8c9c9a03 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
@@ -1,7 +1,7 @@
/-
Copyright (c) 2026 Christian Reitwiessner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Christian Reitwiessner
+Authors: Christian Reitwiessner, Aviv Bar Natan
-/
module
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index e2b166479..49c8c61f4 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -16,8 +16,8 @@ A visit sequence records the storages seen at a fixed input position during a fi
Up to the first halt, these storages are distinct: repeating a core would repeat the rest of the
computation, regardless of the write-only output.
-The input-shortening argument follows Gadi Aleksandrowicz's account at
-.
+`InputCut` describes a deletion between matching symbols. Its position map relates configurations
+on the original and shortened inputs, allowing the run segments on either side to be joined.
-/
@[expose] public section
@@ -95,60 +95,152 @@ lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T
exact mem_window.mpr (h t (by omega) i)
_ = k * (2 * R + 1) := by simp
-/-- Equal storage and input symbols give equal storage after one step. A relation `r` between
-the input positions is also preserved if it holds after every common head move. -/
-lemma step_congr_storage {input' : List Symbol}
+/-- Equal storages and scanned input symbols give equal next storages, and both input heads
+execute the same move. For halted configurations, this is the stationary move. -/
+lemma exists_step_move_of_storage_eq {input' : List Symbol}
{c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
- (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol)
- (r : ℕ → ℕ → Prop)
- (hm : ∀ m, r (moveInputPos c.inputPos m).val (moveInputPos c'.inputPos m).val) :
- (tm.step c).storage = (tm.step c').storage ∧
- r (tm.step c).inputPos.val (tm.step c').inputPos.val := by
+ (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol) :
+ ∃ m, (tm.step c).storage = (tm.step c').storage ∧
+ (tm.step c).inputPos = moveInputPos c.inputPos m ∧
+ (tm.step c').inputPos = moveInputPos c'.inputPos m := by
rcases c with ⟨state, pos, tapes, heads, out⟩
rcases c' with ⟨state', pos', tapes', heads', out'⟩
simp only [Cfg.storage, Storage.mk.injEq] at hstore
rcases hstore with ⟨rfl, rfl, rfl⟩
cases state with
- | none => exact ⟨rfl, by simpa only [moveInputPos_zero, step] using hm 0⟩
+ | none => exact ⟨0, rfl, (moveInputPos_zero _).symm, (moveInputPos_zero _).symm⟩
| some state =>
dsimp only [step]
unfold Cfg.workTapeSymbols
rw [hsym]
- exact ⟨rfl, hm _⟩
+ exact ⟨_, rfl, rfl, rfl⟩
-/-- Deleting the cells after `a` through `b` preserves symbols at positions at most `a`. -/
-private lemma inputSymbol_cut_left {a b : ℕ} (ha : a ≤ input.length)
- (c : Cfg k Symbol State input)
- (c' : Cfg k Symbol State (input.take a ++ input.drop b))
- (hc : c.inputPos.val ≤ a) (hp : c'.inputPos.val = c.inputPos.val) :
+/-- Two internal input positions with the same symbol. Cutting after `left` through `right`
+identifies these positions and deletes the intervening input. Positions are one-based. -/
+structure InputCut (input : List Symbol) where
+ /-- The position retained at the cut. -/
+ left : ℕ
+ /-- The last position deleted. -/
+ right : ℕ
+ /-- The left endpoint is past the left endmarker. -/
+ left_pos : 0 < left
+ /-- The cut deletes at least one cell. -/
+ lt : left < right
+ /-- The right endpoint is before the right endmarker. -/
+ right_le : right ≤ input.length
+ /-- The identified positions carry the same symbol. -/
+ symbol_eq : input[left - 1]? = input[right - 1]?
+
+/-- The input obtained by deleting the cells after `left` through `right`. -/
+def InputCut.shortened (cut : InputCut input) : List Symbol :=
+ input.take cut.left ++ input.drop cut.right
+
+/-- Collapse the deleted interval to its left endpoint and shift subsequent positions left. -/
+def InputCut.position (cut : InputCut input) (p : ℕ) : ℕ :=
+ min p cut.left + (p - cut.right)
+
+/-- Corresponding configurations have equal storage and input positions related by the cut. -/
+def InputCut.Matches (cut : InputCut input) (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State cut.shortened) : Prop :=
+ c'.inputPos.val = cut.position c.inputPos.val ∧ c'.storage = c.storage
+
+/-- A corresponding configuration is reachable on the shortened input. -/
+def InputCut.Reachable (cut : InputCut input) (tm : MultiTapeTM k Symbol State)
+ (c : Cfg k Symbol State input) : Prop :=
+ ∃ t, cut.Matches c (tm.runFrom (tm.initCfg cut.shortened) t)
+
+namespace InputCut
+
+variable (cut : InputCut input)
+
+/-- Adding back the deleted cells recovers the original input length. -/
+private lemma length_shortened_add :
+ cut.shortened.length + (cut.right - cut.left) = input.length := by
+ simp only [InputCut.shortened, List.length_append, List.length_take, List.length_drop]
+ have := cut.lt
+ have := cut.right_le
+ omega
+
+/-- Positions at or left of the cut do not move. -/
+private lemma position_left {p : ℕ} (hp : p ≤ cut.left) : cut.position p = p := by
+ unfold position
+ have := cut.lt
+ omega
+
+/-- Positions at or right of the cut shift by the number of deleted cells. -/
+private lemma position_right {p : ℕ} (hp : cut.right ≤ p) :
+ cut.position p = p - (cut.right - cut.left) := by
+ unfold position
+ have := cut.lt
+ omega
+
+/-- Corresponding input positions on the left read the same symbol. -/
+private lemma inputSymbol_left (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State cut.shortened)
+ (hc : c.inputPos.val ≤ cut.left) (hp : c'.inputPos.val = c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hp]
split_ifs with h
· rfl
- · have hi : c.inputPos.val - 1 < a := by omega
- simp [List.getElem?_append, ha, hi]
-
-/-- After deleting the cells after `a` through `b`, symbols at positions at least `b`
-are preserved by shifting left by `b - a`, provided the symbols at `a` and `b` agree. -/
-private lemma inputSymbol_cut_right {a b : ℕ}
- (ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
- (hsym : input[a - 1]? = input[b - 1]?)
- (c : Cfg k Symbol State input)
- (c' : Cfg k Symbol State (input.take a ++ input.drop b))
- (hc : b ≤ c.inputPos.val) (hp : c'.inputPos.val + (b - a) = c.inputPos.val) :
+ · have hi : c.inputPos.val - 1 < cut.left := by omega
+ have hle : cut.left ≤ input.length := cut.lt.le.trans cut.right_le
+ simp [InputCut.shortened, List.getElem?_append, hle, hi]
+
+/-- Corresponding input positions on the right read the same symbol, including at the cut. -/
+private lemma inputSymbol_right (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State cut.shortened)
+ (hc : cut.right ≤ c.inputPos.val)
+ (hp : c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
+ have ha := cut.left_pos
+ have hab := cut.lt
+ have hb := cut.right_le
have hp₀ : c.inputPos.val ≠ 0 := by omega
have hp'₀ : c'.inputPos.val ≠ 0 := by omega
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀,
ite_eq_right hp'₀]
- have htake : (input.take a).length = a := by simp; omega
- by_cases heq : c.inputPos.val = b
- · have hpa : c'.inputPos.val = a := by omega
- simp [hpa, heq, List.getElem?_append, htake,
- show a - 1 < a by omega, ← hsym]
- · have hi : a ≤ c'.inputPos.val - 1 := by omega
- have he : b + (c'.inputPos.val - 1 - a) = c.inputPos.val - 1 := by omega
- simp [List.getElem?_append, htake, not_lt.mpr hi, he]
+ have htake : (input.take cut.left).length = cut.left := by simp; omega
+ by_cases heq : c.inputPos.val = cut.right
+ · have hpa : c'.inputPos.val = cut.left := by omega
+ simp [InputCut.shortened, hpa, heq, List.getElem?_append, htake,
+ show cut.left - 1 < cut.left by omega, ← cut.symbol_eq]
+ · have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
+ have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
+ simp [InputCut.shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
+
+/-- A step staying on the left preserves reachability on the shortened input. -/
+private lemma reachable_step_left {c : Cfg k Symbol State input}
+ (hc : c.inputPos.val ≤ cut.left) (hc' : (tm.step c).inputPos.val ≤ cut.left)
+ (h : cut.Reachable tm c) : cut.Reachable tm (tm.step c) := by
+ obtain ⟨u, hp, hs⟩ := h
+ rw [cut.position_left hc] at hp
+ obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
+ (cut.inputSymbol_left _ _ hc hp)
+ refine ⟨u + 1, ?_, ?_⟩
+ · rw [runFrom_succ_eq_step', hm', cut.position_left hc', hm]
+ exact (moveInputPos_same _ _ hp.symm (hc.trans (cut.lt.le.trans cut.right_le))
+ (by have := cut.length_shortened_add; have := cut.right_le; have := cut.lt; omega) m).symm
+ · simpa only [runFrom_succ_eq_step'] using hs'.symm
+
+/-- A step staying on the right preserves reachability on the shortened input. -/
+private lemma reachable_step_right {c : Cfg k Symbol State input}
+ (hc : cut.right ≤ c.inputPos.val) (hc' : cut.right ≤ (tm.step c).inputPos.val)
+ (h : cut.Reachable tm c) : cut.Reachable tm (tm.step c) := by
+ obtain ⟨u, hp, hs⟩ := h
+ rw [cut.position_right hc] at hp
+ have hpos : (tm.runFrom (tm.initCfg cut.shortened) u).inputPos.val +
+ (cut.right - cut.left) = c.inputPos.val := by have := cut.lt; omega
+ obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
+ (cut.inputSymbol_right _ _ hc hpos)
+ refine ⟨u + 1, ?_, ?_⟩
+ · rw [runFrom_succ_eq_step', hm', cut.position_right hc', hm]
+ have he := moveInputPos_shift c.inputPos
+ (tm.runFrom (tm.initCfg cut.shortened) u).inputPos hpos cut.length_shortened_add
+ (by have := cut.left_pos; have := cut.lt; omega) m
+ omega
+ · simpa only [runFrom_succ_eq_step'] using hs'.symm
+
+end InputCut
/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
@@ -188,106 +280,6 @@ private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
have := hno r (by omega) (by omega)
omega
-/-- Matching ordered visits at `a` and `b` allow the portions of a walk outside `(a, b)`
-to be joined. Any predicate `R` preserved along those portions holds throughout the joined walk. -/
-private lemma glue_visits {S : Type*} (p : ℕ → ℕ) (q : ℕ → S) {T a b m : ℕ}
- (hab : a < b) (hp₀ : p 0 ≤ a)
- (hstep : ∀ t < T, p (t + 1) ≤ p t + 1 ∧ p t ≤ p (t + 1) + 1)
- (A B : Fin m ↪o ℕ)
- (hA : ∀ i, A i ≤ T ∧ p (A i) = a)
- (hB : ∀ i, B i ≤ T ∧ p (B i) = b)
- (hAc : ∀ t ≤ T, p t = a → ∃ i, A i = t)
- (hBc : ∀ t ≤ T, p t = b → ∃ i, B i = t)
- (hq : ∀ i, q (A i) = q (B i))
- (hmove : ∀ i, p (A i + 1) + b = p (B i + 1) + a)
- (R : ℕ → S → Prop) (hR₀ : R (p 0) (q 0))
- (hleft : ∀ t < T, p t ≤ a → p (t + 1) ≤ a →
- R (p t) (q t) → R (p (t + 1)) (q (t + 1)))
- (hright : ∀ t < T, b ≤ p t → b ≤ p (t + 1) →
- R (p t - (b - a)) (q t) → R (p (t + 1) - (b - a)) (q (t + 1))) :
- ∀ t ≤ T, p t ≤ a ∨ b ≤ p t →
- R (if p t ≤ a then p t else p t - (b - a)) (q t) := by
- have hba : b - (b - a) = a := by omega
- have boundary : ∀ i, R a (q (A i)) := by
- cases m with
- | zero => exact fun i => Fin.elim0 i
- | succ m =>
- intro i
- induction i using Fin.induction with
- | zero =>
- have hno : ∀ t < A 0, p t ≠ a := by
- intro t ht hpt
- obtain ⟨j, rfl⟩ := hAc t (ht.le.trans (hA 0).1) hpt
- exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) ht
- have hside : ∀ t ≤ A 0, p t ≤ a := by
- intro t ht
- apply propagate (Nat.zero_le t) hp₀
- intro r _ hrt hr
- have := (hstep r (by have := (hA 0).1; omega)).1
- have := hno r (by omega)
- omega
- have hr := propagate (Nat.zero_le (A 0)) hR₀ fun t _ ht =>
- hleft t (ht.trans_le (hA 0).1) (hside t ht.le) (hside (t + 1) ht)
- simpa [(hA 0).2] using hr
- | succ i ih =>
- have hAj := A.strictMono i.castSucc_lt_succ
- have hBj := B.strictMono i.castSucc_lt_succ
- have hnoA : ∀ t, A i.castSucc < t → t < A i.succ → p t ≠ a := by
- intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hAc t (hti.le.trans (hA i.succ).1) hpt
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hti)))
- (A.lt_iff_lt.mp hjt)
- have hnoB : ∀ t, B i.castSucc < t → t < B i.succ → p t ≠ b := by
- intro t hjt hti hpt
- obtain ⟨r, rfl⟩ := hBc t (hti.le.trans (hB i.succ).1) hpt
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hti)))
- (B.lt_iff_lt.mp hjt)
- by_cases hdir : p (A i.castSucc + 1) ≤ a
- · have hside := walk_left
- (fun t (_ : A i.castSucc ≤ t) (ht : t < A i.succ) =>
- (hstep t (ht.trans_le (hA i.succ).1)).1)
- (le_of_eq (hA i.castSucc).2) hdir hnoA
- have hr := propagate hAj.le
- (show R (p (A i.castSucc)) (q (A i.castSucc)) by
- simpa [(hA i.castSucc).2] using ih) fun t hjt hti =>
- hleft t (hti.trans_le (hA i.succ).1)
- (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hA i.succ).2] using hr
- · have hdir' : b ≤ p (B i.castSucc + 1) := by have := hmove i.castSucc; omega
- have hside := walk_right
- (fun t (_ : B i.castSucc ≤ t) (ht : t < B i.succ) =>
- (hstep t (ht.trans_le (hB i.succ).1)).2)
- (ge_of_eq (hB i.castSucc).2) hdir' hnoB
- have hr := propagate hBj.le
- (show R (p (B i.castSucc) - (b - a)) (q (B i.castSucc)) by
- simpa [(hB i.castSucc).2, hba, ← hq i.castSucc] using ih) fun t hjt hti =>
- hright t (hti.trans_le (hB i.succ).1)
- (hside t hjt hti.le) (hside (t + 1) (by omega) hti)
- simpa [(hB i.succ).2, hba, ← hq i.succ] using hr
- intro t
- induction t with
- | zero => intro _ _; simpa [hp₀] using hR₀
- | succ t ih =>
- intro ht hside
- have hst := hstep t (by omega)
- by_cases hl : p (t + 1) ≤ a
- · rw [ite_eq_left hl]
- by_cases heq : p (t + 1) = a
- · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
- simpa [hi, heq] using boundary i
- · have hprev : p t ≤ a := by omega
- exact hleft t (by omega) hprev hl (by
- simpa [hprev] using ih (by omega) (Or.inl hprev))
- · rw [ite_eq_right hl]
- have hr : b ≤ p (t + 1) := hside.resolve_left hl
- by_cases heq : p (t + 1) = b
- · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
- simpa [hq i, hi, heq, hba] using boundary i
- · have hprev : b ≤ p t := by omega
- have hprev' : ¬ p t ≤ a := by omega
- exact hright t (by omega) hprev hr (by
- simpa [hprev'] using ih (by omega) (Or.inr hprev))
-
/-- The entry at index `i` is the storage at the `i`th visit time. -/
private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
(h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
@@ -295,36 +287,33 @@ private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
(tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
simp [visitSequence, Finset.orderEmbOfFin_apply]
-/-- Deleting the cells after `a` through `b` preserves every storage reached outside the deleted
-interval, provided the symbols and visit sequences at `a` and `b` agree. Input positions are
-one-based, as in `Cfg.inputPos`; neither cut position is an endmarker. -/
-theorem exists_storage_cut {a b T : ℕ}
- (ha : 0 < a) (hab : a < b) (hb : b ≤ input.length)
- (hsym : input[a - 1]? = input[b - 1]?)
- (hseq : tm.visitSequence (tm.initCfg input) T a =
- tm.visitSequence (tm.initCfg input) T b)
+/-- Equal visit sequences allow the run segments on either side of the cut to be joined.
+Every configuration outside the cut through time `T` has a reachable counterpart. -/
+private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T : ℕ}
+ (hseq : tm.visitSequence (tm.initCfg input) T cut.left =
+ tm.visitSequence (tm.initCfg input) T cut.right)
{t : ℕ} (ht : t ≤ T)
- (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ a ∨
- b ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
- ∃ u, (tm.runFrom (tm.initCfg (input.take a ++ input.drop b)) u).storage =
- (tm.runFrom (tm.initCfg input) t).storage := by
+ (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
+ cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
+ cut.Reachable tm (tm.runFrom (tm.initCfg input) t) := by
let c := tm.runFrom (tm.initCfg input)
- let c' := tm.runFrom (tm.initCfg (input.take a ++ input.drop b))
- let m := (tm.visitTimes (tm.initCfg input) T a).card
- have hcard : (tm.visitTimes (tm.initCfg input) T b).card = m := by
+ let p := fun u => (c u).inputPos.val
+ have hc (u) : c (u + 1) = tm.step (c u) := runFrom_succ_eq_step'
+ let m := (tm.visitTimes (tm.initCfg input) T cut.left).card
+ have hcard : (tm.visitTimes (tm.initCfg input) T cut.right).card = m := by
simpa [m] using (congrArg List.length hseq).symm
- let A := (tm.visitTimes (tm.initCfg input) T a).orderEmbOfFin rfl
- let B := (tm.visitTimes (tm.initCfg input) T b).orderEmbOfFin hcard
- have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = a := fun i =>
+ let A : Fin m ↪o ℕ := (tm.visitTimes (tm.initCfg input) T cut.left).orderEmbOfFin rfl
+ let B := (tm.visitTimes (tm.initCfg input) T cut.right).orderEmbOfFin hcard
+ have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = cut.left := fun i =>
tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
- have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = b := fun i =>
+ have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = cut.right := fun i =>
tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
- have hAc : ∀ u ≤ T, (c u).inputPos.val = a → ∃ i, A i = u := by
+ have hAc : ∀ u ≤ T, p u = cut.left → ∃ i, A i = u := by
intro u hu hpu
change u ∈ Set.range A
simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
tm.mem_visitTimes.mpr ⟨hu, hpu⟩
- have hBc : ∀ u ≤ T, (c u).inputPos.val = b → ∃ i, B i = u := by
+ have hBc : ∀ u ≤ T, p u = cut.right → ∃ i, B i = u := by
intro u hu hpu
change u ∈ Set.range B
simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
@@ -334,57 +323,119 @@ theorem exists_storage_cut {a b T : ℕ}
have heq := List.getElem_of_eq hseq (i := i.val)
(by rw [length_visitSequence]; exact i.isLt)
exact (visitSequence_get rfl i).symm.trans (heq.trans (visitSequence_get hcard i))
- have hmove : ∀ i,
- (c (A i + 1)).inputPos.val + b = (c (B i + 1)).inputPos.val + a := by
- intro i
+ have hmove (i) : p (A i + 1) + cut.right = p (B i + 1) + cut.left := by
have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
- simpa [Nat.ne_of_gt ha, show b ≠ 0 by omega] using hsym
- have hcong := step_congr_storage (tm := tm) (hq i) hsy
- (fun p p' => p + b = p' + a) (fun dir => by
- have hm := moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
- (by rw [(hA i).2]; exact ha) (by rw [(hA i).2]; omega)
- (by rw [(hB i).2]; omega) (by rw [(hB i).2]; exact hb) dir
- have := (hA i).2
- have := (hB i).2
- omega)
- simpa only [c, runFrom_succ_eq_step'] using hcong.2
- let R := fun p s => ∃ u, (c' u).inputPos.val = p ∧ (c' u).storage = s
- have hR₀ : R (c 0).inputPos.val (c 0).storage := by
- refine ⟨0, ?_, ?_⟩ <;> simp [c, c', Cfg.storage]
- have hlen : (input.take a ++ input.drop b).length + (b - a) = input.length := by
- simp only [List.length_append, List.length_take, List.length_drop]
- omega
- have hleft : ∀ u < T, (c u).inputPos.val ≤ a → (c (u + 1)).inputPos.val ≤ a →
- R (c u).inputPos.val (c u).storage → R (c (u + 1)).inputPos.val (c (u + 1)).storage := by
- rintro u _ hpu _ ⟨v, hpv, hsv⟩
- have hsy := inputSymbol_cut_left (by omega : a ≤ input.length) (c u) (c' v) hpu hpv
- have hcong := step_congr_storage (tm := tm) hsv.symm hsy Eq
- (fun dir => moveInputPos_same (c u).inputPos (c' v).inputPos hpv.symm
- (by omega) (by omega) dir)
- refine ⟨v + 1, ?_, ?_⟩
- · simpa only [c, c', runFrom_succ_eq_step'] using hcong.2.symm
- · simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
- have hright : ∀ u < T, b ≤ (c u).inputPos.val → b ≤ (c (u + 1)).inputPos.val →
- R ((c u).inputPos.val - (b - a)) (c u).storage →
- R ((c (u + 1)).inputPos.val - (b - a)) (c (u + 1)).storage := by
- rintro u _ hpu _ ⟨v, hpv, hsv⟩
- have hpv' : (c' v).inputPos.val + (b - a) = (c u).inputPos.val := by omega
- have hsy := inputSymbol_cut_right ha hab hb hsym (c u) (c' v) hpu hpv'
- have hcong := step_congr_storage (tm := tm) hsv.symm hsy
- (fun p p' => p' + (b - a) = p)
- (fun dir => moveInputPos_shift (c u).inputPos (c' v).inputPos hpv' hlen (by omega) dir)
- refine ⟨v + 1, ?_, ?_⟩
- · have hpos : (c' (v + 1)).inputPos.val + (b - a) = (c (u + 1)).inputPos.val := by
- simpa only [c, c', runFrom_succ_eq_step'] using hcong.2
- omega
- · simpa only [c, c', runFrom_succ_eq_step'] using hcong.1.symm
- have hglue := glue_visits (fun u => (c u).inputPos.val) (fun u => (c u).storage)
- hab (by simp [c]; omega)
- (fun u _ => by simpa only [c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u))
- A B hA hB hAc hBc hq hmove R hR₀ hleft hright t ht hp
- obtain ⟨u, _, hstore⟩ := hglue
- exact ⟨u, hstore⟩
+ simpa [Nat.ne_of_gt cut.left_pos, show cut.right ≠ 0 by have := cut.lt; omega] using
+ cut.symbol_eq
+ obtain ⟨dir, _, hleft, hright⟩ := tm.exists_step_move_of_storage_eq (hq i) hsy
+ change (c (A i + 1)).inputPos.val + cut.right =
+ (c (B i + 1)).inputPos.val + cut.left
+ rw [hc, hc, hleft, hright]
+ simpa only [(hA i).2, (hB i).2] using
+ moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
+ (by rw [(hA i).2]; exact cut.left_pos)
+ (by rw [(hA i).2]; exact cut.lt.le.trans cut.right_le)
+ (by rw [(hB i).2]; have := cut.left_pos; have := cut.lt; omega)
+ (by rw [(hB i).2]; exact cut.right_le) dir
+ have hmatch (i) : cut.Reachable tm (c (A i)) ↔ cut.Reachable tm (c (B i)) := by
+ have hba : cut.right - (cut.right - cut.left) = cut.left := by have := cut.lt; omega
+ simp only [InputCut.Reachable, InputCut.Matches, (hA i).2, (hB i).2,
+ cut.position_left le_rfl, cut.position_right le_rfl, hba, hq i]
+ have hstep (u) : p (u + 1) ≤ p u + 1 ∧ p u ≤ p (u + 1) + 1 := by
+ simpa only [p, c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u)
+ have hleft {u} (hu : p u ≤ cut.left) (hu' : p (u + 1) ≤ cut.left) :
+ cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
+ rw [hc]
+ exact cut.reachable_step_left hu (by simpa only [p, hc] using hu')
+ have hright {u} (hu : cut.right ≤ p u) (hu' : cut.right ≤ p (u + 1)) :
+ cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
+ rw [hc]
+ exact cut.reachable_step_right hu (by simpa only [p, hc] using hu')
+ have hp₀ : p 0 ≤ cut.left := by simpa [p, c] using (Nat.succ_le_iff.mpr cut.left_pos)
+ have hinit : cut.Reachable tm (c 0) := by
+ refine ⟨0, ?_, ?_⟩
+ · rw [cut.position_left hp₀]
+ rfl
+ · rfl
+ have boundary : ∀ i, cut.Reachable tm (c (A i)) := by
+ clear_value A B m
+ cases m with
+ | zero => exact fun i => Fin.elim0 i
+ | succ m =>
+ intro i
+ induction i using Fin.induction with
+ | zero =>
+ have hno : ∀ u < A 0, p u ≠ cut.left := by
+ intro u hu hpu
+ obtain ⟨j, rfl⟩ := hAc u (hu.le.trans (hA 0).1) hpu
+ exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) hu
+ have hside : ∀ u ≤ A 0, p u ≤ cut.left := by
+ intro u hu
+ apply propagate (Nat.zero_le u) hp₀
+ intro r _ hru hr
+ have := (hstep r).1
+ have := hno r (by omega)
+ omega
+ exact propagate (P := fun u => cut.Reachable tm (c u)) (Nat.zero_le (A 0)) hinit
+ fun u _ hu => hleft (hside u hu.le) (hside (u + 1) hu)
+ | succ i ih =>
+ have hAj := A.strictMono i.castSucc_lt_succ
+ have hBj := B.strictMono i.castSucc_lt_succ
+ have hnoA : ∀ u, A i.castSucc < u → u < A i.succ → p u ≠ cut.left := by
+ intro u hju hui hpu
+ obtain ⟨r, rfl⟩ := hAc u (hui.le.trans (hA i.succ).1) hpu
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hui)))
+ (A.lt_iff_lt.mp hju)
+ have hnoB : ∀ u, B i.castSucc < u → u < B i.succ → p u ≠ cut.right := by
+ intro u hju hui hpu
+ obtain ⟨r, rfl⟩ := hBc u (hui.le.trans (hB i.succ).1) hpu
+ exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hui)))
+ (B.lt_iff_lt.mp hju)
+ by_cases hdir : p (A i.castSucc + 1) ≤ cut.left
+ · have hside := walk_left (fun u _ _ => (hstep u).1)
+ (le_of_eq (hA i.castSucc).2) hdir hnoA
+ exact propagate (P := fun u => cut.Reachable tm (c u)) hAj.le ih fun u hju hui =>
+ hleft (hside u hju hui.le) (hside (u + 1) (by omega) hui)
+ · have hdir' : cut.right ≤ p (B i.castSucc + 1) := by
+ have := hmove i.castSucc
+ omega
+ have hside := walk_right (fun u _ _ => (hstep u).2)
+ (ge_of_eq (hB i.castSucc).2) hdir' hnoB
+ apply (hmatch i.succ).mpr
+ exact propagate (P := fun u => cut.Reachable tm (c u)) hBj.le
+ ((hmatch i.castSucc).mp ih) fun u hju hui =>
+ hright (hside u hju hui.le) (hside (u + 1) (by omega) hui)
+ change cut.Reachable tm (c t)
+ induction t with
+ | zero => exact hinit
+ | succ t ih =>
+ have hst := hstep t
+ by_cases hl : p (t + 1) ≤ cut.left
+ · by_cases heq : p (t + 1) = cut.left
+ · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
+ simpa only [hi] using boundary i
+ · have hprev : p t ≤ cut.left := by omega
+ exact hleft hprev hl (ih (by omega) (Or.inl hprev))
+ · have hr : cut.right ≤ p (t + 1) := hp.resolve_left hl
+ by_cases heq : p (t + 1) = cut.right
+ · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
+ simpa only [hi] using (hmatch i).mp (boundary i)
+ · have hprev : cut.right ≤ p t := by omega
+ exact hright hprev hr (ih (by omega) (Or.inr hprev))
+
+/-- Equal visit sequences at the endpoints of an input cut preserve every storage reached
+outside the deleted interval through time `T`. -/
+theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
+ (hseq : tm.visitSequence (tm.initCfg input) T cut.left =
+ tm.visitSequence (tm.initCfg input) T cut.right)
+ {t : ℕ} (ht : t ≤ T)
+ (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
+ cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
+ ∃ u, (tm.runFrom (tm.initCfg cut.shortened) u).storage =
+ (tm.runFrom (tm.initCfg input) t).storage := by
+ obtain ⟨u, _, hs⟩ := cut.reachable_of_visitSequence_eq hseq ht hp
+ exact ⟨u, hs⟩
/-- Every entry of a visit sequence is a storage reached by the run. -/
lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {T p : ℕ}
@@ -488,8 +539,9 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have := i.isLt
have := j.isLt
omega
- · exact tm.exists_storage_cut (by omega) hij (by have := j.isLt; omega)
- (by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1)
+ · exact tm.exists_storage_cut
+ ⟨i.val + 1, j.val + 1, by omega, hij, by have := j.isLt; omega,
+ by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1⟩
hij'.2 ht hpos
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
(e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
From 12268a3644bf6cc9a0938cafbad8b55d52f38ee5 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 00:23:44 +0300
Subject: [PATCH 12/25] refactor(MultiTapeTM): use intervals for input cuts
---
.../Turing/MultiTape/InputShortening.lean | 97 +++++++++++--------
1 file changed, 54 insertions(+), 43 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 49c8c61f4..6801a4952 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -8,6 +8,7 @@ module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Finset.Sort
+public import Mathlib.Order.Interval.Basic
/-!
# Input shortening for multi-tape Turing machines
@@ -16,8 +17,9 @@ A visit sequence records the storages seen at a fixed input position during a fi
Up to the first halt, these storages are distinct: repeating a core would repeat the rest of the
computation, regardless of the write-only output.
-`InputCut` describes a deletion between matching symbols. Its position map relates configurations
-on the original and shortened inputs, allowing the run segments on either side to be joined.
+`InputCut` describes a deletion between input-symbol indices. Its position map relates
+configurations on the original and shortened inputs, allowing the run segments on either side
+to be joined.
-/
@[expose] public section
@@ -115,21 +117,15 @@ lemma exists_step_move_of_storage_eq {input' : List Symbol}
rw [hsym]
exact ⟨_, rfl, rfl, rfl⟩
-/-- Two internal input positions with the same symbol. Cutting after `left` through `right`
-identifies these positions and deletes the intervening input. Positions are one-based. -/
-structure InputCut (input : List Symbol) where
- /-- The position retained at the cut. -/
- left : ℕ
- /-- The last position deleted. -/
- right : ℕ
- /-- The left endpoint is past the left endmarker. -/
- left_pos : 0 < left
- /-- The cut deletes at least one cell. -/
- lt : left < right
- /-- The right endpoint is before the right endmarker. -/
- right_le : right ≤ input.length
- /-- The identified positions carry the same symbol. -/
- symbol_eq : input[left - 1]? = input[right - 1]?
+/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
+through the second; equal endpoints give an empty deletion. -/
+abbrev InputCut (input : List Symbol) := NonemptyInterval (Fin input.length)
+
+/-- The one-based input-head position of the retained endpoint. -/
+def InputCut.left (cut : InputCut input) : ℕ := cut.fst.val + 1
+
+/-- The one-based input-head position of the last deleted endpoint. -/
+def InputCut.right (cut : InputCut input) : ℕ := cut.snd.val + 1
/-- The input obtained by deleting the cells after `left` through `right`. -/
def InputCut.shortened (cut : InputCut input) : List Symbol :=
@@ -153,25 +149,35 @@ namespace InputCut
variable (cut : InputCut input)
+/-- A symbol index lies past the left endmarker. -/
+private lemma left_pos : 0 < cut.left := Nat.succ_pos _
+
+/-- The order of symbol indices also orders their input-head positions. -/
+private lemma left_le_right : cut.left ≤ cut.right :=
+ Nat.add_le_add_right cut.fst_le_snd 1
+
+/-- A symbol index lies before the right endmarker. -/
+private lemma right_le : cut.right ≤ input.length := cut.snd.isLt
+
/-- Adding back the deleted cells recovers the original input length. -/
private lemma length_shortened_add :
cut.shortened.length + (cut.right - cut.left) = input.length := by
simp only [InputCut.shortened, List.length_append, List.length_take, List.length_drop]
- have := cut.lt
+ have := cut.left_le_right
have := cut.right_le
omega
/-- Positions at or left of the cut do not move. -/
private lemma position_left {p : ℕ} (hp : p ≤ cut.left) : cut.position p = p := by
unfold position
- have := cut.lt
+ have := cut.left_le_right
omega
/-- Positions at or right of the cut shift by the number of deleted cells. -/
private lemma position_right {p : ℕ} (hp : cut.right ≤ p) :
cut.position p = p - (cut.right - cut.left) := by
unfold position
- have := cut.lt
+ have := cut.left_le_right
omega
/-- Corresponding input positions on the left read the same symbol. -/
@@ -183,17 +189,18 @@ private lemma inputSymbol_left (c : Cfg k Symbol State input)
split_ifs with h
· rfl
· have hi : c.inputPos.val - 1 < cut.left := by omega
- have hle : cut.left ≤ input.length := cut.lt.le.trans cut.right_le
+ have hle : cut.left ≤ input.length := cut.fst.isLt
simp [InputCut.shortened, List.getElem?_append, hle, hi]
/-- Corresponding input positions on the right read the same symbol, including at the cut. -/
-private lemma inputSymbol_right (c : Cfg k Symbol State input)
+private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
+ (c : Cfg k Symbol State input)
(c' : Cfg k Symbol State cut.shortened)
(hc : cut.right ≤ c.inputPos.val)
(hp : c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
have ha := cut.left_pos
- have hab := cut.lt
+ have hab := cut.left_le_right
have hb := cut.right_le
have hp₀ : c.inputPos.val ≠ 0 := by omega
have hp'₀ : c'.inputPos.val ≠ 0 := by omega
@@ -202,8 +209,8 @@ private lemma inputSymbol_right (c : Cfg k Symbol State input)
have htake : (input.take cut.left).length = cut.left := by simp; omega
by_cases heq : c.inputPos.val = cut.right
· have hpa : c'.inputPos.val = cut.left := by omega
- simp [InputCut.shortened, hpa, heq, List.getElem?_append, htake,
- show cut.left - 1 < cut.left by omega, ← cut.symbol_eq]
+ simpa [InputCut.shortened, hpa, heq, List.getElem?_append,
+ InputCut.left, InputCut.right, Fin.getElem_fin] using hsym.symm
· have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
simp [InputCut.shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
@@ -218,25 +225,30 @@ private lemma reachable_step_left {c : Cfg k Symbol State input}
(cut.inputSymbol_left _ _ hc hp)
refine ⟨u + 1, ?_, ?_⟩
· rw [runFrom_succ_eq_step', hm', cut.position_left hc', hm]
- exact (moveInputPos_same _ _ hp.symm (hc.trans (cut.lt.le.trans cut.right_le))
- (by have := cut.length_shortened_add; have := cut.right_le; have := cut.lt; omega) m).symm
+ exact (moveInputPos_same _ _ hp.symm (hc.trans cut.fst.isLt)
+ (by
+ have := cut.length_shortened_add
+ have := cut.right_le
+ have := cut.left_le_right
+ omega) m).symm
· simpa only [runFrom_succ_eq_step'] using hs'.symm
/-- A step staying on the right preserves reachability on the shortened input. -/
-private lemma reachable_step_right {c : Cfg k Symbol State input}
+private lemma reachable_step_right (hsym : input[cut.fst] = input[cut.snd])
+ {c : Cfg k Symbol State input}
(hc : cut.right ≤ c.inputPos.val) (hc' : cut.right ≤ (tm.step c).inputPos.val)
(h : cut.Reachable tm c) : cut.Reachable tm (tm.step c) := by
obtain ⟨u, hp, hs⟩ := h
rw [cut.position_right hc] at hp
have hpos : (tm.runFrom (tm.initCfg cut.shortened) u).inputPos.val +
- (cut.right - cut.left) = c.inputPos.val := by have := cut.lt; omega
+ (cut.right - cut.left) = c.inputPos.val := by have := cut.left_le_right; omega
obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
- (cut.inputSymbol_right _ _ hc hpos)
+ (cut.inputSymbol_right hsym _ _ hc hpos)
refine ⟨u + 1, ?_, ?_⟩
· rw [runFrom_succ_eq_step', hm', cut.position_right hc', hm]
have he := moveInputPos_shift c.inputPos
(tm.runFrom (tm.initCfg cut.shortened) u).inputPos hpos cut.length_shortened_add
- (by have := cut.left_pos; have := cut.lt; omega) m
+ (by have := cut.left_pos; have := cut.left_le_right; omega) m
omega
· simpa only [runFrom_succ_eq_step'] using hs'.symm
@@ -290,6 +302,7 @@ private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
/-- Equal visit sequences allow the run segments on either side of the cut to be joined.
Every configuration outside the cut through time `T` has a reachable counterpart. -/
private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T : ℕ}
+ (hsym : input[cut.fst] = input[cut.snd])
(hseq : tm.visitSequence (tm.initCfg input) T cut.left =
tm.visitSequence (tm.initCfg input) T cut.right)
{t : ℕ} (ht : t ≤ T)
@@ -326,8 +339,7 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
have hmove (i) : p (A i + 1) + cut.right = p (B i + 1) + cut.left := by
have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
- simpa [Nat.ne_of_gt cut.left_pos, show cut.right ≠ 0 by have := cut.lt; omega] using
- cut.symbol_eq
+ simpa [InputCut.left, InputCut.right, Fin.getElem_fin] using hsym
obtain ⟨dir, _, hleft, hright⟩ := tm.exists_step_move_of_storage_eq (hq i) hsy
change (c (A i + 1)).inputPos.val + cut.right =
(c (B i + 1)).inputPos.val + cut.left
@@ -335,11 +347,11 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
simpa only [(hA i).2, (hB i).2] using
moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
(by rw [(hA i).2]; exact cut.left_pos)
- (by rw [(hA i).2]; exact cut.lt.le.trans cut.right_le)
- (by rw [(hB i).2]; have := cut.left_pos; have := cut.lt; omega)
+ (by rw [(hA i).2]; exact cut.fst.isLt)
+ (by rw [(hB i).2]; exact Nat.succ_pos _)
(by rw [(hB i).2]; exact cut.right_le) dir
have hmatch (i) : cut.Reachable tm (c (A i)) ↔ cut.Reachable tm (c (B i)) := by
- have hba : cut.right - (cut.right - cut.left) = cut.left := by have := cut.lt; omega
+ have hba : cut.right - (cut.right - cut.left) = cut.left := by have := cut.left_le_right; omega
simp only [InputCut.Reachable, InputCut.Matches, (hA i).2, (hB i).2,
cut.position_left le_rfl, cut.position_right le_rfl, hba, hq i]
have hstep (u) : p (u + 1) ≤ p u + 1 ∧ p u ≤ p (u + 1) + 1 := by
@@ -351,7 +363,7 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
have hright {u} (hu : cut.right ≤ p u) (hu' : cut.right ≤ p (u + 1)) :
cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
rw [hc]
- exact cut.reachable_step_right hu (by simpa only [p, hc] using hu')
+ exact cut.reachable_step_right hsym hu (by simpa only [p, hc] using hu')
have hp₀ : p 0 ≤ cut.left := by simpa [p, c] using (Nat.succ_le_iff.mpr cut.left_pos)
have hinit : cut.Reachable tm (c 0) := by
refine ⟨0, ?_, ?_⟩
@@ -424,9 +436,10 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
· have hprev : cut.right ≤ p t := by omega
exact hright hprev hr (ih (by omega) (Or.inr hprev))
-/-- Equal visit sequences at the endpoints of an input cut preserve every storage reached
+/-- Equal symbols and visit sequences at the endpoints of a cut preserve every storage reached
outside the deleted interval through time `T`. -/
theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
+ (hsym : input[cut.fst] = input[cut.snd])
(hseq : tm.visitSequence (tm.initCfg input) T cut.left =
tm.visitSequence (tm.initCfg input) T cut.right)
{t : ℕ} (ht : t ≤ T)
@@ -434,7 +447,7 @@ theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ u, (tm.runFrom (tm.initCfg cut.shortened) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
- obtain ⟨u, _, hs⟩ := cut.reachable_of_visitSequence_eq hseq ht hp
+ obtain ⟨u, _, hs⟩ := cut.reachable_of_visitSequence_eq hsym hseq ht hp
exact ⟨u, hs⟩
/-- Every entry of a visit sequence is a storage reached by the run. -/
@@ -539,10 +552,8 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have := i.isLt
have := j.isLt
omega
- · exact tm.exists_storage_cut
- ⟨i.val + 1, j.val + 1, by omega, hij, by have := j.isLt; omega,
- by simpa [List.getElem?_eq_getElem i.isLt, List.getElem?_eq_getElem j.isLt] using hij'.1⟩
- hij'.2 ht hpos
+ · exact tm.exists_storage_cut ⟨⟨i, j⟩, by change i.val ≤ j.val; omega⟩
+ hij'.1 hij'.2 ht hpos
by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
(e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
· exact cut hab hab' hpos
From a1bf684d0e4c1eae13351649efe70e5081ad7759 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 00:33:23 +0300
Subject: [PATCH 13/25] refactor(MultiTapeTM): simplify cut namespace
---
.../Turing/MultiTape/InputShortening.lean | 177 +++++++++---------
1 file changed, 84 insertions(+), 93 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 6801a4952..f732cd1b7 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -117,67 +117,102 @@ lemma exists_step_move_of_storage_eq {input' : List Symbol}
rw [hsym]
exact ⟨_, rfl, rfl, rfl⟩
+/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
+private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
+ (hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
+ induction v, huv using Nat.le_induction with
+ | base => exact hu
+ | succ v huv ih =>
+ exact hstep v huv (Nat.lt_succ_self _) (ih fun t hut htv => hstep t hut (by omega))
+
+/-- After staying left of `a` for one step, a walk cannot cross `a` without revisiting it. -/
+private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
+ (hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
+ (hu : p u ≤ a) (hu' : p (u + 1) ≤ a)
+ (hno : ∀ t, u < t → t < v → p t ≠ a) :
+ ∀ t, u ≤ t → t ≤ v → p t ≤ a := by
+ intro t hut htv
+ apply propagate hut hu
+ intro r hur hrt hr
+ by_cases heq : r = u
+ · simpa [heq] using hu'
+ · have := hstep r hur (by omega)
+ have := hno r (by omega) (by omega)
+ omega
+
+/-- After staying right of `b` for one step, a walk cannot cross `b` without revisiting it. -/
+private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
+ (hstep : ∀ t, u ≤ t → t < v → p t ≤ p (t + 1) + 1)
+ (hu : b ≤ p u) (hu' : b ≤ p (u + 1))
+ (hno : ∀ t, u < t → t < v → p t ≠ b) :
+ ∀ t, u ≤ t → t ≤ v → b ≤ p t := by
+ intro t hut htv
+ apply propagate hut hu
+ intro r hur hrt hr
+ by_cases heq : r = u
+ · simpa [heq] using hu'
+ · have := hstep r hur (by omega)
+ have := hno r (by omega) (by omega)
+ omega
+
+/-- The entry at index `i` is the storage at the `i`th visit time. -/
+private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
+ (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
+ (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
+ (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
+ simp [visitSequence, Finset.orderEmbOfFin_apply]
+
/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
through the second; equal endpoints give an empty deletion. -/
abbrev InputCut (input : List Symbol) := NonemptyInterval (Fin input.length)
+namespace InputCut
+
+variable (cut : InputCut input)
+
/-- The one-based input-head position of the retained endpoint. -/
-def InputCut.left (cut : InputCut input) : ℕ := cut.fst.val + 1
+def left : ℕ := cut.fst.val + 1
-/-- The one-based input-head position of the last deleted endpoint. -/
-def InputCut.right (cut : InputCut input) : ℕ := cut.snd.val + 1
+/-- The one-based input-head position of the right endpoint. -/
+def right : ℕ := cut.snd.val + 1
/-- The input obtained by deleting the cells after `left` through `right`. -/
-def InputCut.shortened (cut : InputCut input) : List Symbol :=
+def shortened : List Symbol :=
input.take cut.left ++ input.drop cut.right
/-- Collapse the deleted interval to its left endpoint and shift subsequent positions left. -/
-def InputCut.position (cut : InputCut input) (p : ℕ) : ℕ :=
+def position (p : ℕ) : ℕ :=
min p cut.left + (p - cut.right)
/-- Corresponding configurations have equal storage and input positions related by the cut. -/
-def InputCut.Matches (cut : InputCut input) (c : Cfg k Symbol State input)
+def Matches (c : Cfg k Symbol State input)
(c' : Cfg k Symbol State cut.shortened) : Prop :=
c'.inputPos.val = cut.position c.inputPos.val ∧ c'.storage = c.storage
/-- A corresponding configuration is reachable on the shortened input. -/
-def InputCut.Reachable (cut : InputCut input) (tm : MultiTapeTM k Symbol State)
+def Reachable (tm : MultiTapeTM k Symbol State)
(c : Cfg k Symbol State input) : Prop :=
∃ t, cut.Matches c (tm.runFrom (tm.initCfg cut.shortened) t)
-namespace InputCut
-
-variable (cut : InputCut input)
-
-/-- A symbol index lies past the left endmarker. -/
-private lemma left_pos : 0 < cut.left := Nat.succ_pos _
-
-/-- The order of symbol indices also orders their input-head positions. -/
-private lemma left_le_right : cut.left ≤ cut.right :=
- Nat.add_le_add_right cut.fst_le_snd 1
-
-/-- A symbol index lies before the right endmarker. -/
-private lemma right_le : cut.right ≤ input.length := cut.snd.isLt
-
/-- Adding back the deleted cells recovers the original input length. -/
private lemma length_shortened_add :
cut.shortened.length + (cut.right - cut.left) = input.length := by
- simp only [InputCut.shortened, List.length_append, List.length_take, List.length_drop]
- have := cut.left_le_right
- have := cut.right_le
+ simp only [shortened, List.length_append, List.length_take, List.length_drop]
+ dsimp only [left, right]
+ have := cut.fst_le_snd
omega
/-- Positions at or left of the cut do not move. -/
private lemma position_left {p : ℕ} (hp : p ≤ cut.left) : cut.position p = p := by
- unfold position
- have := cut.left_le_right
+ simp only [position, left, right] at *
+ have := cut.fst_le_snd
omega
/-- Positions at or right of the cut shift by the number of deleted cells. -/
private lemma position_right {p : ℕ} (hp : cut.right ≤ p) :
cut.position p = p - (cut.right - cut.left) := by
- unfold position
- have := cut.left_le_right
+ simp only [position, left, right] at *
+ have := cut.fst_le_snd
omega
/-- Corresponding input positions on the left read the same symbol. -/
@@ -190,7 +225,7 @@ private lemma inputSymbol_left (c : Cfg k Symbol State input)
· rfl
· have hi : c.inputPos.val - 1 < cut.left := by omega
have hle : cut.left ≤ input.length := cut.fst.isLt
- simp [InputCut.shortened, List.getElem?_append, hle, hi]
+ simp [shortened, List.getElem?_append, hle, hi]
/-- Corresponding input positions on the right read the same symbol, including at the cut. -/
private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
@@ -199,9 +234,9 @@ private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
(hc : cut.right ≤ c.inputPos.val)
(hp : c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
- have ha := cut.left_pos
- have hab := cut.left_le_right
- have hb := cut.right_le
+ have ha : 0 < cut.left := Nat.succ_pos _
+ have hab : cut.left ≤ cut.right := Nat.add_le_add_right cut.fst_le_snd 1
+ have hb : cut.right ≤ input.length := cut.snd.isLt
have hp₀ : c.inputPos.val ≠ 0 := by omega
have hp'₀ : c'.inputPos.val ≠ 0 := by omega
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀,
@@ -209,11 +244,11 @@ private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
have htake : (input.take cut.left).length = cut.left := by simp; omega
by_cases heq : c.inputPos.val = cut.right
· have hpa : c'.inputPos.val = cut.left := by omega
- simpa [InputCut.shortened, hpa, heq, List.getElem?_append,
- InputCut.left, InputCut.right, Fin.getElem_fin] using hsym.symm
+ simpa [shortened, hpa, heq, List.getElem?_append,
+ left, right, Fin.getElem_fin] using hsym.symm
· have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
- simp [InputCut.shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
+ simp [shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
/-- A step staying on the left preserves reachability on the shortened input. -/
private lemma reachable_step_left {c : Cfg k Symbol State input}
@@ -228,8 +263,8 @@ private lemma reachable_step_left {c : Cfg k Symbol State input}
exact (moveInputPos_same _ _ hp.symm (hc.trans cut.fst.isLt)
(by
have := cut.length_shortened_add
- have := cut.right_le
- have := cut.left_le_right
+ dsimp only [left, right] at *
+ have := cut.fst_le_snd
omega) m).symm
· simpa only [runFrom_succ_eq_step'] using hs'.symm
@@ -241,67 +276,20 @@ private lemma reachable_step_right (hsym : input[cut.fst] = input[cut.snd])
obtain ⟨u, hp, hs⟩ := h
rw [cut.position_right hc] at hp
have hpos : (tm.runFrom (tm.initCfg cut.shortened) u).inputPos.val +
- (cut.right - cut.left) = c.inputPos.val := by have := cut.left_le_right; omega
+ (cut.right - cut.left) = c.inputPos.val := by omega
obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
(cut.inputSymbol_right hsym _ _ hc hpos)
refine ⟨u + 1, ?_, ?_⟩
· rw [runFrom_succ_eq_step', hm', cut.position_right hc', hm]
have he := moveInputPos_shift c.inputPos
(tm.runFrom (tm.initCfg cut.shortened) u).inputPos hpos cut.length_shortened_add
- (by have := cut.left_pos; have := cut.left_le_right; omega) m
+ (by dsimp only [left, right] at *; omega) m
omega
· simpa only [runFrom_succ_eq_step'] using hs'.symm
-end InputCut
-
-/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
-private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
- (hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
- induction v, huv using Nat.le_induction with
- | base => exact hu
- | succ v huv ih =>
- exact hstep v huv (Nat.lt_succ_self _) (ih fun t hut htv => hstep t hut (by omega))
-
-/-- After staying left of `a` for one step, a walk cannot cross `a` without revisiting it. -/
-private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
- (hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
- (hu : p u ≤ a) (hu' : p (u + 1) ≤ a)
- (hno : ∀ t, u < t → t < v → p t ≠ a) :
- ∀ t, u ≤ t → t ≤ v → p t ≤ a := by
- intro t hut htv
- apply propagate hut hu
- intro r hur hrt hr
- by_cases heq : r = u
- · simpa [heq] using hu'
- · have := hstep r hur (by omega)
- have := hno r (by omega) (by omega)
- omega
-
-/-- After staying right of `b` for one step, a walk cannot cross `b` without revisiting it. -/
-private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
- (hstep : ∀ t, u ≤ t → t < v → p t ≤ p (t + 1) + 1)
- (hu : b ≤ p u) (hu' : b ≤ p (u + 1))
- (hno : ∀ t, u < t → t < v → p t ≠ b) :
- ∀ t, u ≤ t → t ≤ v → b ≤ p t := by
- intro t hut htv
- apply propagate hut hu
- intro r hur hrt hr
- by_cases heq : r = u
- · simpa [heq] using hu'
- · have := hstep r hur (by omega)
- have := hno r (by omega) (by omega)
- omega
-
-/-- The entry at index `i` is the storage at the `i`th visit time. -/
-private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
- (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
- (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
- (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
- simp [visitSequence, Finset.orderEmbOfFin_apply]
-
/-- Equal visit sequences allow the run segments on either side of the cut to be joined.
Every configuration outside the cut through time `T` has a reachable counterpart. -/
-private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T : ℕ}
+private lemma reachable_of_visitSequence_eq {T : ℕ}
(hsym : input[cut.fst] = input[cut.snd])
(hseq : tm.visitSequence (tm.initCfg input) T cut.left =
tm.visitSequence (tm.initCfg input) T cut.right)
@@ -339,20 +327,21 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
have hmove (i) : p (A i + 1) + cut.right = p (B i + 1) + cut.left := by
have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
- simpa [InputCut.left, InputCut.right, Fin.getElem_fin] using hsym
+ simpa [left, right, Fin.getElem_fin] using hsym
obtain ⟨dir, _, hleft, hright⟩ := tm.exists_step_move_of_storage_eq (hq i) hsy
change (c (A i + 1)).inputPos.val + cut.right =
(c (B i + 1)).inputPos.val + cut.left
rw [hc, hc, hleft, hright]
simpa only [(hA i).2, (hB i).2] using
moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
- (by rw [(hA i).2]; exact cut.left_pos)
+ (by rw [(hA i).2]; exact Nat.succ_pos _)
(by rw [(hA i).2]; exact cut.fst.isLt)
(by rw [(hB i).2]; exact Nat.succ_pos _)
- (by rw [(hB i).2]; exact cut.right_le) dir
+ (by rw [(hB i).2]; exact cut.snd.isLt) dir
have hmatch (i) : cut.Reachable tm (c (A i)) ↔ cut.Reachable tm (c (B i)) := by
- have hba : cut.right - (cut.right - cut.left) = cut.left := by have := cut.left_le_right; omega
- simp only [InputCut.Reachable, InputCut.Matches, (hA i).2, (hB i).2,
+ have hba : cut.right - (cut.right - cut.left) = cut.left :=
+ Nat.sub_sub_self (Nat.add_le_add_right cut.fst_le_snd 1)
+ simp only [Reachable, Matches, (hA i).2, (hB i).2,
cut.position_left le_rfl, cut.position_right le_rfl, hba, hq i]
have hstep (u) : p (u + 1) ≤ p u + 1 ∧ p u ≤ p (u + 1) + 1 := by
simpa only [p, c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u)
@@ -364,7 +353,7 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
rw [hc]
exact cut.reachable_step_right hsym hu (by simpa only [p, hc] using hu')
- have hp₀ : p 0 ≤ cut.left := by simpa [p, c] using (Nat.succ_le_iff.mpr cut.left_pos)
+ have hp₀ : p 0 ≤ cut.left := by simp [p, c, left]
have hinit : cut.Reachable tm (c 0) := by
refine ⟨0, ?_, ?_⟩
· rw [cut.position_left hp₀]
@@ -436,6 +425,8 @@ private lemma InputCut.reachable_of_visitSequence_eq (cut : InputCut input) {T :
· have hprev : cut.right ≤ p t := by omega
exact hright hprev hr (ih (by omega) (Or.inr hprev))
+end InputCut
+
/-- Equal symbols and visit sequences at the endpoints of a cut preserve every storage reached
outside the deleted interval through time `T`. -/
theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
From ea6d72e457b4a4f40413da1629a2b4dce1f1e9fe Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 00:50:39 +0300
Subject: [PATCH 14/25] refactor(MultiTapeTM): simplify visit gluing
---
.../Turing/MultiTape/Deterministic.lean | 14 +
.../Turing/MultiTape/InputShortening.lean | 353 +++++++++---------
2 files changed, 200 insertions(+), 167 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index ad0bfc7f4..7bc32830f 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -376,6 +376,20 @@ lemma relatesInSteps_iff_runFrom_eq
use tm.step^[t] cfg₁
grind
+/-- Reachability by zero or more transitions of the machine. -/
+abbrev Reaches (c₁ c₂ : Cfg k Symbol State input) : Prop :=
+ Relation.ReflTransGen tm.TransitionRelation c₁ c₂
+
+/-- Reachability is equivalent to appearing in the run from the starting configuration. -/
+lemma reaches_iff_exists_runFrom {c₁ c₂ : Cfg k Symbol State input} :
+ tm.Reaches c₁ c₂ ↔ ∃ t, tm.runFrom c₁ t = c₂ := by
+ constructor
+ · intro h
+ obtain ⟨t, ht⟩ := h.relatesInSteps
+ exact ⟨t, (tm.relatesInSteps_iff_runFrom_eq _ _ _).mp ht⟩
+ · rintro ⟨t, ht⟩
+ exact ((tm.relatesInSteps_iff_runFrom_eq _ _ _).mpr ht).reflTransGen
+
/-- The Turing machine `tm` halts after exactly `t` steps on input `input`
if its state is `none` at step `t` and non-none at step `t - 1`.
Note that every Turing machine hast to perform at least one step to halt. -/
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index f732cd1b7..3327c7a5e 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -8,6 +8,7 @@ module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
public import Mathlib.Combinatorics.Pigeonhole
public import Mathlib.Data.Finset.Sort
+public import Mathlib.Order.Cover
public import Mathlib.Order.Interval.Basic
/-!
@@ -155,12 +156,40 @@ private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
have := hno r (by omega) (by omega)
omega
-/-- The entry at index `i` is the storage at the `i`th visit time. -/
-private lemma visitSequence_get {cfg : Cfg k Symbol State input} {T p m : ℕ}
- (h : (tm.visitTimes cfg T p).card = m) (i : Fin m) :
- (tm.visitSequence cfg T p)[i.val]'(by rw [length_visitSequence, h]; exact i.isLt) =
- (tm.runFrom cfg ((tm.visitTimes cfg T p).orderEmbOfFin h i)).storage := by
- simp [visitSequence, Finset.orderEmbOfFin_apply]
+/-- Equal visit sequences pair the visit times in order, with equal storage at each pair. -/
+lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {T p q : ℕ}
+ (hseq : tm.visitSequence cfg T p = tm.visitSequence cfg T q) :
+ ∃ e : tm.visitTimes cfg T p ≃o tm.visitTimes cfg T q,
+ ∀ t : tm.visitTimes cfg T p,
+ (tm.runFrom cfg t).storage = (tm.runFrom cfg (e t)).storage := by
+ have hcard : (tm.visitTimes cfg T q).card = (tm.visitTimes cfg T p).card := by
+ simpa using (congrArg List.length hseq).symm
+ let A := (tm.visitTimes cfg T p).orderIsoOfFin rfl
+ let B := (tm.visitTimes cfg T q).orderIsoOfFin hcard
+ refine ⟨A.symm.trans B, ?_⟩
+ intro t
+ obtain ⟨i, rfl⟩ := A.surjective t
+ have heq := List.getElem_of_eq hseq (i := i.val)
+ (by rw [length_visitSequence]; exact i.isLt)
+ simpa only [visitSequence, List.getElem_map, OrderIso.trans_apply,
+ OrderIso.symm_apply_apply, A, B, Finset.coe_orderIsoOfFin_apply,
+ Finset.orderEmbOfFin_apply, Fin.getElem_fin] using heq
+
+/-- No earlier time visits the position of a minimal visit. -/
+private lemma not_visit_before {cfg : Cfg k Symbol State input} {T p t : ℕ}
+ {u : tm.visitTimes cfg T p} (hu : IsMin u) (ht : t < u.val) :
+ (tm.runFrom cfg t).inputPos.val ≠ p := by
+ intro hp
+ have hT := (tm.mem_visitTimes.mp u.property).1
+ exact ht.not_ge (hu (b := ⟨t, tm.mem_visitTimes.mpr ⟨ht.le.trans hT, hp⟩⟩) ht.le)
+
+/-- The covering relation on visit times means that no visit occurs strictly between them. -/
+private lemma not_visit_between {cfg : Cfg k Symbol State input} {T p t : ℕ}
+ {u v : tm.visitTimes cfg T p} (h : u ⋖ v) (hlo : u.val < t) (hhi : t < v.val) :
+ (tm.runFrom cfg t).inputPos.val ≠ p := by
+ intro hp
+ have hT := (tm.mem_visitTimes.mp v.property).1
+ exact h.2 (c := ⟨t, tm.mem_visitTimes.mpr ⟨hhi.le.trans hT, hp⟩⟩) hlo hhi
/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
through the second; equal endpoints give an empty deletion. -/
@@ -189,10 +218,9 @@ def Matches (c : Cfg k Symbol State input)
(c' : Cfg k Symbol State cut.shortened) : Prop :=
c'.inputPos.val = cut.position c.inputPos.val ∧ c'.storage = c.storage
-/-- A corresponding configuration is reachable on the shortened input. -/
-def Reachable (tm : MultiTapeTM k Symbol State)
- (c : Cfg k Symbol State input) : Prop :=
- ∃ t, cut.Matches c (tm.runFrom (tm.initCfg cut.shortened) t)
+/-- Two input positions lie on the same retained side of the cut. -/
+def SameSide (p q : ℕ) : Prop :=
+ (p ≤ cut.left ∧ q ≤ cut.left) ∨ (cut.right ≤ p ∧ cut.right ≤ q)
/-- Adding back the deleted cells recovers the original input length. -/
private lemma length_shortened_add :
@@ -250,180 +278,170 @@ private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
simp [shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
-/-- A step staying on the left preserves reachability on the shortened input. -/
-private lemma reachable_step_left {c : Cfg k Symbol State input}
- (hc : c.inputPos.val ≤ cut.left) (hc' : (tm.step c).inputPos.val ≤ cut.left)
- (h : cut.Reachable tm c) : cut.Reachable tm (tm.step c) := by
- obtain ⟨u, hp, hs⟩ := h
- rw [cut.position_left hc] at hp
- obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
- (cut.inputSymbol_left _ _ hc hp)
- refine ⟨u + 1, ?_, ?_⟩
- · rw [runFrom_succ_eq_step', hm', cut.position_left hc', hm]
+variable {cut} in
+/-- A step whose endpoints lie on the same retained side preserves matching configurations. -/
+lemma Matches.step (hsym : input[cut.fst] = input[cut.snd])
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
+ (h : cut.Matches c c') (hside : cut.SameSide c.inputPos.val (tm.step c).inputPos.val) :
+ cut.Matches (tm.step c) (tm.step c') := by
+ obtain ⟨hp, hs⟩ := h
+ have hsym' : c.inputSymbol = c'.inputSymbol := by
+ rcases hside with ⟨hc, _⟩ | ⟨hc, _⟩
+ · exact cut.inputSymbol_left _ _ hc (hp.trans (cut.position_left hc))
+ · rw [cut.position_right hc] at hp
+ exact cut.inputSymbol_right hsym _ _ hc (by omega)
+ obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm hsym'
+ refine ⟨?_, hs'.symm⟩
+ rcases hside with ⟨hc, hn⟩ | ⟨hc, hn⟩
+ · rw [cut.position_left hc] at hp
+ rw [hm', cut.position_left hn, hm]
exact (moveInputPos_same _ _ hp.symm (hc.trans cut.fst.isLt)
(by
have := cut.length_shortened_add
dsimp only [left, right] at *
have := cut.fst_le_snd
omega) m).symm
- · simpa only [runFrom_succ_eq_step'] using hs'.symm
-
-/-- A step staying on the right preserves reachability on the shortened input. -/
-private lemma reachable_step_right (hsym : input[cut.fst] = input[cut.snd])
- {c : Cfg k Symbol State input}
- (hc : cut.right ≤ c.inputPos.val) (hc' : cut.right ≤ (tm.step c).inputPos.val)
- (h : cut.Reachable tm c) : cut.Reachable tm (tm.step c) := by
- obtain ⟨u, hp, hs⟩ := h
- rw [cut.position_right hc] at hp
- have hpos : (tm.runFrom (tm.initCfg cut.shortened) u).inputPos.val +
- (cut.right - cut.left) = c.inputPos.val := by omega
- obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm
- (cut.inputSymbol_right hsym _ _ hc hpos)
- refine ⟨u + 1, ?_, ?_⟩
- · rw [runFrom_succ_eq_step', hm', cut.position_right hc', hm]
- have he := moveInputPos_shift c.inputPos
- (tm.runFrom (tm.initCfg cut.shortened) u).inputPos hpos cut.length_shortened_add
- (by dsimp only [left, right] at *; omega) m
+ · rw [cut.position_right hc] at hp
+ rw [hm', cut.position_right hn, hm]
+ have he := moveInputPos_shift c.inputPos c'.inputPos (by omega)
+ cut.length_shortened_add (by dsimp only [left, right] at *; omega) m
omega
- · simpa only [runFrom_succ_eq_step'] using hs'.symm
-/-- Equal visit sequences allow the run segments on either side of the cut to be joined.
-Every configuration outside the cut through time `T` has a reachable counterpart. -/
-private lemma reachable_of_visitSequence_eq {T : ℕ}
+variable {cut} in
+/-- Simulate a run segment in which every step stays on a retained side of the cut. -/
+lemma Matches.reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
+ {cfg : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened} {u v : ℕ}
+ (h : cut.Matches (tm.runFrom cfg u) c') (huv : u ≤ v)
+ (hside : ∀ t, u ≤ t → t < v →
+ cut.SameSide (tm.runFrom cfg t).inputPos.val (tm.runFrom cfg (t + 1)).inputPos.val) :
+ ∃ d, tm.Reaches c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
+ apply propagate (P := fun t => ∃ d, tm.Reaches c' d ∧ cut.Matches (tm.runFrom cfg t) d)
+ huv ⟨c', .refl, h⟩
+ rintro t hut htv ⟨d, hd, hm⟩
+ refine ⟨tm.step d, hd.tail rfl, ?_⟩
+ rw [runFrom_succ_eq_step']
+ exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside t hut htv)
+
+/-- The initial configurations match because the cut retains the first input symbol. -/
+lemma matches_init : cut.Matches (tm.initCfg input) (tm.initCfg cut.shortened) := by
+ constructor
+ · exact (cut.position_left (p := 1) (Nat.succ_le_succ (Nat.zero_le _))).symm
+ · rfl
+
+/-- Equal storages at the two boundary positions match the same shortened configurations. -/
+private lemma matches_boundary_iff
+ {c₁ c₂ : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
+ (h₁ : c₁.inputPos.val = cut.left) (h₂ : c₂.inputPos.val = cut.right)
+ (hs : c₁.storage = c₂.storage) : cut.Matches c₁ c' ↔ cut.Matches c₂ c' := by
+ have hba : cut.right - (cut.right - cut.left) = cut.left :=
+ Nat.sub_sub_self (Nat.add_le_add_right cut.fst_le_snd 1)
+ simp only [Matches, h₁, h₂, cut.position_left le_rfl, cut.position_right le_rfl,
+ hba, hs]
+
+/-- Of two boundary configurations with equal storage, at least one steps into a retained side. -/
+private lemma step_boundary_sides (hsym : input[cut.fst] = input[cut.snd])
+ {c₁ c₂ : Cfg k Symbol State input}
+ (h₁ : c₁.inputPos.val = cut.left) (h₂ : c₂.inputPos.val = cut.right)
+ (hs : c₁.storage = c₂.storage) :
+ (tm.step c₁).inputPos.val ≤ cut.left ∨ cut.right ≤ (tm.step c₂).inputPos.val := by
+ have hsy : c₁.inputSymbol = c₂.inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, h₁, h₂]
+ simpa [left, right, Fin.getElem_fin] using hsym
+ obtain ⟨dir, _, hm₁, hm₂⟩ := tm.exists_step_move_of_storage_eq hs hsy
+ have hm := moveInputPos_interior c₁.inputPos c₂.inputPos
+ (by rw [h₁]; exact Nat.succ_pos _) (by rw [h₁]; exact cut.fst.isLt)
+ (by rw [h₂]; exact Nat.succ_pos _) (by rw [h₂]; exact cut.snd.isLt) dir
+ rw [← hm₁, ← hm₂, h₁, h₂] at hm
+ omega
+
+/-- Paired boundary visits have reachable matching configurations: at each pair, follow the
+next excursion on whichever side its first step retains. -/
+private lemma exists_matches_visit {T : ℕ}
(hsym : input[cut.fst] = input[cut.snd])
(hseq : tm.visitSequence (tm.initCfg input) T cut.left =
tm.visitSequence (tm.initCfg input) T cut.right)
{t : ℕ} (ht : t ≤ T)
- (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
- cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
- cut.Reachable tm (tm.runFrom (tm.initCfg input) t) := by
+ (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val = cut.left ∨
+ (tm.runFrom (tm.initCfg input) t).inputPos.val = cut.right) :
+ ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧
+ cut.Matches (tm.runFrom (tm.initCfg input) t) c' := by
let c := tm.runFrom (tm.initCfg input)
let p := fun u => (c u).inputPos.val
- have hc (u) : c (u + 1) = tm.step (c u) := runFrom_succ_eq_step'
- let m := (tm.visitTimes (tm.initCfg input) T cut.left).card
- have hcard : (tm.visitTimes (tm.initCfg input) T cut.right).card = m := by
- simpa [m] using (congrArg List.length hseq).symm
- let A : Fin m ↪o ℕ := (tm.visitTimes (tm.initCfg input) T cut.left).orderEmbOfFin rfl
- let B := (tm.visitTimes (tm.initCfg input) T cut.right).orderEmbOfFin hcard
- have hA : ∀ i, A i ≤ T ∧ (c (A i)).inputPos.val = cut.left := fun i =>
- tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
- have hB : ∀ i, B i ≤ T ∧ (c (B i)).inputPos.val = cut.right := fun i =>
- tm.mem_visitTimes.mp (Finset.orderEmbOfFin_mem _ _ i)
- have hAc : ∀ u ≤ T, p u = cut.left → ∃ i, A i = u := by
- intro u hu hpu
- change u ∈ Set.range A
- simpa only [A, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- tm.mem_visitTimes.mpr ⟨hu, hpu⟩
- have hBc : ∀ u ≤ T, p u = cut.right → ∃ i, B i = u := by
- intro u hu hpu
- change u ∈ Set.range B
- simpa only [B, Finset.range_orderEmbOfFin, Finset.mem_coe] using
- tm.mem_visitTimes.mpr ⟨hu, hpu⟩
- have hq : ∀ i, (c (A i)).storage = (c (B i)).storage := by
- intro i
- have heq := List.getElem_of_eq hseq (i := i.val)
- (by rw [length_visitSequence]; exact i.isLt)
- exact (visitSequence_get rfl i).symm.trans (heq.trans (visitSequence_get hcard i))
- have hmove (i) : p (A i + 1) + cut.right = p (B i + 1) + cut.left := by
- have hsy : (c (A i)).inputSymbol = (c (B i)).inputSymbol := by
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, (hA i).2, (hB i).2]
- simpa [left, right, Fin.getElem_fin] using hsym
- obtain ⟨dir, _, hleft, hright⟩ := tm.exists_step_move_of_storage_eq (hq i) hsy
- change (c (A i + 1)).inputPos.val + cut.right =
- (c (B i + 1)).inputPos.val + cut.left
- rw [hc, hc, hleft, hright]
- simpa only [(hA i).2, (hB i).2] using
- moveInputPos_interior (c (A i)).inputPos (c (B i)).inputPos
- (by rw [(hA i).2]; exact Nat.succ_pos _)
- (by rw [(hA i).2]; exact cut.fst.isLt)
- (by rw [(hB i).2]; exact Nat.succ_pos _)
- (by rw [(hB i).2]; exact cut.snd.isLt) dir
- have hmatch (i) : cut.Reachable tm (c (A i)) ↔ cut.Reachable tm (c (B i)) := by
- have hba : cut.right - (cut.right - cut.left) = cut.left :=
- Nat.sub_sub_self (Nat.add_le_add_right cut.fst_le_snd 1)
- simp only [Reachable, Matches, (hA i).2, (hB i).2,
- cut.position_left le_rfl, cut.position_right le_rfl, hba, hq i]
+ let P := fun u => ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧ cut.Matches (c u) c'
+ obtain ⟨e, hstore⟩ := tm.exists_visitTimes_orderIso hseq
+ have hleft (u : tm.visitTimes (tm.initCfg input) T cut.left) :=
+ (tm.mem_visitTimes.mp u.property).2
+ have hright (u : tm.visitTimes (tm.initCfg input) T cut.right) :=
+ (tm.mem_visitTimes.mp u.property).2
+ have hmatch (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u ↔ P (e u) :=
+ exists_congr fun c' => and_congr_right fun _ =>
+ cut.matches_boundary_iff (hleft u) (hright (e u)) (hstore u)
have hstep (u) : p (u + 1) ≤ p u + 1 ∧ p u ≤ p (u + 1) + 1 := by
simpa only [p, c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u)
- have hleft {u} (hu : p u ≤ cut.left) (hu' : p (u + 1) ≤ cut.left) :
- cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
- rw [hc]
- exact cut.reachable_step_left hu (by simpa only [p, hc] using hu')
- have hright {u} (hu : cut.right ≤ p u) (hu' : cut.right ≤ p (u + 1)) :
- cut.Reachable tm (c u) → cut.Reachable tm (c (u + 1)) := by
- rw [hc]
- exact cut.reachable_step_right hsym hu (by simpa only [p, hc] using hu')
- have hp₀ : p 0 ≤ cut.left := by simp [p, c, left]
- have hinit : cut.Reachable tm (c 0) := by
- refine ⟨0, ?_, ?_⟩
- · rw [cut.position_left hp₀]
- rfl
- · rfl
- have boundary : ∀ i, cut.Reachable tm (c (A i)) := by
- clear_value A B m
- cases m with
- | zero => exact fun i => Fin.elim0 i
- | succ m =>
- intro i
- induction i using Fin.induction with
- | zero =>
- have hno : ∀ u < A 0, p u ≠ cut.left := by
- intro u hu hpu
- obtain ⟨j, rfl⟩ := hAc u (hu.le.trans (hA 0).1) hpu
- exact (not_lt_of_ge (A.monotone (Fin.zero_le j))) hu
- have hside : ∀ u ≤ A 0, p u ≤ cut.left := by
- intro u hu
- apply propagate (Nat.zero_le u) hp₀
- intro r _ hru hr
- have := (hstep r).1
- have := hno r (by omega)
- omega
- exact propagate (P := fun u => cut.Reachable tm (c u)) (Nat.zero_le (A 0)) hinit
- fun u _ hu => hleft (hside u hu.le) (hside (u + 1) hu)
- | succ i ih =>
- have hAj := A.strictMono i.castSucc_lt_succ
- have hBj := B.strictMono i.castSucc_lt_succ
- have hnoA : ∀ u, A i.castSucc < u → u < A i.succ → p u ≠ cut.left := by
- intro u hju hui hpu
- obtain ⟨r, rfl⟩ := hAc u (hui.le.trans (hA i.succ).1) hpu
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (A.lt_iff_lt.mp hui)))
- (A.lt_iff_lt.mp hju)
- have hnoB : ∀ u, B i.castSucc < u → u < B i.succ → p u ≠ cut.right := by
- intro u hju hui hpu
- obtain ⟨r, rfl⟩ := hBc u (hui.le.trans (hB i.succ).1) hpu
- exact (not_lt_of_ge (Fin.le_castSucc_iff.mpr (B.lt_iff_lt.mp hui)))
- (B.lt_iff_lt.mp hju)
- by_cases hdir : p (A i.castSucc + 1) ≤ cut.left
- · have hside := walk_left (fun u _ _ => (hstep u).1)
- (le_of_eq (hA i.castSucc).2) hdir hnoA
- exact propagate (P := fun u => cut.Reachable tm (c u)) hAj.le ih fun u hju hui =>
- hleft (hside u hju hui.le) (hside (u + 1) (by omega) hui)
- · have hdir' : cut.right ≤ p (B i.castSucc + 1) := by
- have := hmove i.castSucc
- omega
- have hside := walk_right (fun u _ _ => (hstep u).2)
- (ge_of_eq (hB i.castSucc).2) hdir' hnoB
- apply (hmatch i.succ).mpr
- exact propagate (P := fun u => cut.Reachable tm (c u)) hBj.le
- ((hmatch i.castSucc).mp ih) fun u hju hui =>
- hright (hside u hju hui.le) (hside (u + 1) (by omega) hui)
- change cut.Reachable tm (c t)
+ have follow {u v} (huv : u ≤ v) (hu : P u)
+ (hside : ∀ r, u ≤ r → r < v → cut.SameSide (p r) (p (r + 1))) : P v := by
+ obtain ⟨c', hr, hm⟩ := hu
+ obtain ⟨d, hd, hm'⟩ := hm.reaches_runFrom hsym huv hside
+ exact ⟨d, hr.trans hd, hm'⟩
+ have boundary (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u := by
+ induction u using WellFoundedLT.induction with | ind u ih =>
+ by_cases hu : IsMin u
+ · have hside : ∀ v ≤ u.val, p v ≤ cut.left := by
+ intro v hv
+ apply propagate (Nat.zero_le v) (show p 0 ≤ cut.left by simp [p, c, left])
+ intro r _ hrv hr
+ have := (hstep r).1
+ have := not_visit_before hu (show r < u.val by omega)
+ change p r ≠ cut.left at this
+ omega
+ exact follow (Nat.zero_le _) ⟨_, .refl, cut.matches_init⟩ fun v _ hv =>
+ Or.inl ⟨hside v hv.le, hside (v + 1) hv⟩
+ · obtain ⟨v, hvu⟩ := exists_covBy_of_wellFoundedGT hu
+ have hdir := cut.step_boundary_sides hsym (tm := tm) (hleft v) (hright (e v))
+ (hstore v)
+ simp only [← runFrom_succ_eq_step'] at hdir
+ rcases hdir with hdir | hdir
+ · have hside := walk_left (fun r _ _ => (hstep r).1) (le_of_eq (hleft v))
+ hdir (fun _ => not_visit_between hvu)
+ exact follow hvu.le (ih v hvu.lt) fun r hlo hhi =>
+ Or.inl ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩
+ · have he := (apply_covBy_apply_iff e).mpr hvu
+ have hside := walk_right (fun r _ _ => (hstep r).2) (ge_of_eq (hright (e v)))
+ hdir (fun _ => not_visit_between he)
+ exact (hmatch u).mpr (follow he.le ((hmatch v).mp (ih v hvu.lt)) fun r hlo hhi =>
+ Or.inr ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩)
+ rcases hp with hp | hp
+ · exact boundary ⟨t, tm.mem_visitTimes.mpr ⟨ht, hp⟩⟩
+ · let u : tm.visitTimes (tm.initCfg input) T cut.right := ⟨t, tm.mem_visitTimes.mpr ⟨ht, hp⟩⟩
+ simpa only [e.apply_symm_apply] using (hmatch (e.symm u)).mp (boundary (e.symm u))
+
+/-- Equal boundary visit sequences give every configuration outside the cut a reachable
+matching configuration on the shortened input. -/
+theorem exists_matches_of_visitSequence_eq {T : ℕ}
+ (hsym : input[cut.fst] = input[cut.snd])
+ (hseq : tm.visitSequence (tm.initCfg input) T cut.left =
+ tm.visitSequence (tm.initCfg input) T cut.right)
+ {t : ℕ} (ht : t ≤ T)
+ (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
+ cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
+ ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧
+ cut.Matches (tm.runFrom (tm.initCfg input) t) c' := by
induction t with
- | zero => exact hinit
+ | zero => exact ⟨_, .refl, cut.matches_init⟩
| succ t ih =>
- have hst := hstep t
- by_cases hl : p (t + 1) ≤ cut.left
- · by_cases heq : p (t + 1) = cut.left
- · obtain ⟨i, hi⟩ := hAc (t + 1) ht heq
- simpa only [hi] using boundary i
- · have hprev : p t ≤ cut.left := by omega
- exact hleft hprev hl (ih (by omega) (Or.inl hprev))
- · have hr : cut.right ≤ p (t + 1) := hp.resolve_left hl
- by_cases heq : p (t + 1) = cut.right
- · obtain ⟨i, hi⟩ := hBc (t + 1) ht heq
- simpa only [hi] using (hmatch i).mp (boundary i)
- · have hprev : cut.right ≤ p t := by omega
- exact hright hprev hr (ih (by omega) (Or.inr hprev))
+ by_cases hb : (tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val = cut.left ∨
+ (tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val = cut.right
+ · exact cut.exists_matches_visit hsym hseq ht hb
+ have hbounds := tm.inputPos_step_bounds (tm.runFrom (tm.initCfg input) t)
+ have hside : cut.SameSide (tm.runFrom (tm.initCfg input) t).inputPos.val
+ (tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val := by
+ dsimp only [SameSide]
+ rw [← runFrom_succ_eq_step'] at hbounds
+ omega
+ obtain ⟨c', hr, hm⟩ := ih (by omega) (hside.imp And.left And.left)
+ refine ⟨tm.step c', hr.tail rfl, ?_⟩
+ rw [runFrom_succ_eq_step']
+ exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside)
end InputCut
@@ -438,7 +456,8 @@ theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ u, (tm.runFrom (tm.initCfg cut.shortened) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
- obtain ⟨u, _, hs⟩ := cut.reachable_of_visitSequence_eq hsym hseq ht hp
+ obtain ⟨c', hr, _, hs⟩ := cut.exists_matches_of_visitSequence_eq hsym hseq ht hp
+ obtain ⟨u, rfl⟩ := tm.reaches_iff_exists_runFrom.mp hr
exact ⟨u, hs⟩
/-- Every entry of a visit sequence is a storage reached by the run. -/
From 77d01ea1aab602bdb831932003adaf0363c39600 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 00:55:55 +0300
Subject: [PATCH 15/25] refactor(MultiTapeTM): group storage and core lemmas
---
.../Turing/MultiTape/ConfigBound.lean | 59 ++++++++++++++++++-
.../Turing/MultiTape/InputShortening.lean | 57 ------------------
2 files changed, 58 insertions(+), 58 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
index 81db2e280..700a1d23c 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
@@ -273,13 +273,70 @@ lemma core_step_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input} (h : c₁.c
simp only [Cfg.core, Cfg.storage, MultiTapeTM.step, hstate, hsym, hws]
cases c₂.state <;> simp [hpos, hstate, hwt, hwp]
+namespace MultiTapeTM
+
+/-- Equal storages and scanned input symbols give equal next storages, and both input heads
+execute the same move. For halted configurations, this is the stationary move. -/
+lemma exists_step_move_of_storage_eq {input' : List Symbol}
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
+ (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol) :
+ ∃ m, (tm.step c).storage = (tm.step c').storage ∧
+ (tm.step c).inputPos = moveInputPos c.inputPos m ∧
+ (tm.step c').inputPos = moveInputPos c'.inputPos m := by
+ rcases c with ⟨state, pos, tapes, heads, out⟩
+ rcases c' with ⟨state', pos', tapes', heads', out'⟩
+ simp only [Cfg.storage, Storage.mk.injEq] at hstore
+ rcases hstore with ⟨rfl, rfl, rfl⟩
+ cases state with
+ | none => exact ⟨0, rfl, (moveInputPos_zero _).symm, (moveInputPos_zero _).symm⟩
+ | some state =>
+ dsimp only [step]
+ unfold Cfg.workTapeSymbols
+ rw [hsym]
+ exact ⟨_, rfl, rfl, rfl⟩
+
+/-- Runs starting with the same core keep the same core. -/
+lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
+ (h : c₁.core = c₂.core) (t : ℕ) :
+ (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
+ induction t with
+ | zero => exact h
+ | succ t ih =>
+ simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
+
+/-- The cores up to and including the first halt are pairwise distinct. -/
+lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
+ (hhalt : (tm.runFrom cfg T).Halted)
+ (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
+ Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
+ intro a ha b hb heq
+ wlog hab : a ≤ b generalizing a b
+ · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
+ by_contra hne
+ change b ≤ T at hb
+ have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
+ rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
+ exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
+
/-! ## The storages and cores of a space-bounded run
These are the main results giving upper bounds on the number of storages and configuration cores
reachable in bounded space.
-/
-namespace MultiTapeTM
+/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
+lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
+ (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
+ tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
+ calc tm.spaceUsed cfg T
+ _ ≤ ∑ _ : Fin k, (window R).card := by
+ apply Finset.sum_le_sum
+ intro i _
+ apply Finset.card_le_card
+ intro z hz
+ obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
+ exact mem_window.mpr (h t (by omega) i)
+ _ = k * (2 * R + 1) := by simp
/-- The storage reached after `t` steps fits in the windows given by the per-tape space usage up
to step `t`. -/
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 3327c7a5e..066301a60 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -30,29 +30,6 @@ namespace Turing.MultiTapeTM
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
-/-- Runs starting with the same core keep the same core. -/
-lemma core_runFrom_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input}
- (h : c₁.core = c₂.core) (t : ℕ) :
- (tm.runFrom c₁ t).core = (tm.runFrom c₂ t).core := by
- induction t with
- | zero => exact h
- | succ t ih =>
- simpa only [runFrom_succ_eq_step'] using core_step_eq_of_core_eq (tm := tm) ih
-
-/-- The cores up to and including the first halt are pairwise distinct. -/
-lemma core_runFrom_injOn {cfg : Cfg k Symbol State input} {T : ℕ}
- (hhalt : (tm.runFrom cfg T).Halted)
- (hfirst : ∀ t < T, ¬ (tm.runFrom cfg t).Halted) :
- Set.InjOn (fun t => (tm.runFrom cfg t).core) (Set.Iic T) := by
- intro a ha b hb heq
- wlog hab : a ≤ b generalizing a b
- · exact (this hb ha heq.symm (le_of_not_ge hab)).symm
- by_contra hne
- change b ≤ T at hb
- have heq' := tm.core_runFrom_eq_of_core_eq heq (T - b)
- rw [← runFrom_add, ← runFrom_add, Nat.add_sub_of_le hb] at heq'
- exact hfirst (a + (T - b)) (by omega) ((congrArg (fun c => c.2.state) heq').trans hhalt)
-
/-- Times up to `T` at which the input head is at `p`. -/
def visitTimes (cfg : Cfg k Symbol State input) (T p : ℕ) : Finset ℕ :=
(Finset.range (T + 1)).filter fun t => (tm.runFrom cfg t).inputPos.val = p
@@ -84,40 +61,6 @@ lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
-/-- If every work head stays in `[-R, R]`, the run visits at most `k * (2 * R + 1)` cells. -/
-lemma spaceUsed_le_of_workTapePos_natAbs_le (cfg : Cfg k Symbol State input) (T R : ℕ)
- (h : ∀ t ≤ T, ∀ i, ((tm.runFrom cfg t).workTapePos i).natAbs ≤ R) :
- tm.spaceUsed cfg T ≤ k * (2 * R + 1) := by
- calc tm.spaceUsed cfg T
- _ ≤ ∑ _ : Fin k, (window R).card := by
- apply Finset.sum_le_sum
- intro i _
- apply Finset.card_le_card
- intro z hz
- obtain ⟨t, ht, rfl⟩ := tm.mem_visitedByTapeHead.mp hz
- exact mem_window.mpr (h t (by omega) i)
- _ = k * (2 * R + 1) := by simp
-
-/-- Equal storages and scanned input symbols give equal next storages, and both input heads
-execute the same move. For halted configurations, this is the stationary move. -/
-lemma exists_step_move_of_storage_eq {input' : List Symbol}
- {c : Cfg k Symbol State input} {c' : Cfg k Symbol State input'}
- (hstore : c.storage = c'.storage) (hsym : c.inputSymbol = c'.inputSymbol) :
- ∃ m, (tm.step c).storage = (tm.step c').storage ∧
- (tm.step c).inputPos = moveInputPos c.inputPos m ∧
- (tm.step c').inputPos = moveInputPos c'.inputPos m := by
- rcases c with ⟨state, pos, tapes, heads, out⟩
- rcases c' with ⟨state', pos', tapes', heads', out'⟩
- simp only [Cfg.storage, Storage.mk.injEq] at hstore
- rcases hstore with ⟨rfl, rfl, rfl⟩
- cases state with
- | none => exact ⟨0, rfl, (moveInputPos_zero _).symm, (moveInputPos_zero _).symm⟩
- | some state =>
- dsimp only [step]
- unfold Cfg.workTapeSymbols
- rw [hsym]
- exact ⟨_, rfl, rfl, rfl⟩
-
/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
(hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
From 13a0c127b21a4b7f79329a8b5890698bca8136bf Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 01:01:22 +0300
Subject: [PATCH 16/25] refactor(MultiTapeTM): use tape head bounds
---
.../Turing/MultiTape/InputShortening.lean | 93 +++++++------------
.../Machines/Turing/MultiTape/TapeLemmas.lean | 33 ++++++-
2 files changed, 67 insertions(+), 59 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 066301a60..c7f5dbc3b 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -61,44 +61,6 @@ lemma visitSequence_nodup {cfg : Cfg k Symbol State input} {T : ℕ}
apply tm.core_runFrom_injOn hhalt hfirst ha'.1 hb'.1
exact Prod.ext (Fin.ext (ha'.2.trans hb'.2.symm)) h
-/-- Propagate a predicate from `u` to `v` using steps within `[u, v]`. -/
-private lemma propagate {P : ℕ → Prop} {u v : ℕ} (huv : u ≤ v) (hu : P u)
- (hstep : ∀ t, u ≤ t → t < v → P t → P (t + 1)) : P v := by
- induction v, huv using Nat.le_induction with
- | base => exact hu
- | succ v huv ih =>
- exact hstep v huv (Nat.lt_succ_self _) (ih fun t hut htv => hstep t hut (by omega))
-
-/-- After staying left of `a` for one step, a walk cannot cross `a` without revisiting it. -/
-private lemma walk_left {p : ℕ → ℕ} {u v a : ℕ}
- (hstep : ∀ t, u ≤ t → t < v → p (t + 1) ≤ p t + 1)
- (hu : p u ≤ a) (hu' : p (u + 1) ≤ a)
- (hno : ∀ t, u < t → t < v → p t ≠ a) :
- ∀ t, u ≤ t → t ≤ v → p t ≤ a := by
- intro t hut htv
- apply propagate hut hu
- intro r hur hrt hr
- by_cases heq : r = u
- · simpa [heq] using hu'
- · have := hstep r hur (by omega)
- have := hno r (by omega) (by omega)
- omega
-
-/-- After staying right of `b` for one step, a walk cannot cross `b` without revisiting it. -/
-private lemma walk_right {p : ℕ → ℕ} {u v b : ℕ}
- (hstep : ∀ t, u ≤ t → t < v → p t ≤ p (t + 1) + 1)
- (hu : b ≤ p u) (hu' : b ≤ p (u + 1))
- (hno : ∀ t, u < t → t < v → p t ≠ b) :
- ∀ t, u ≤ t → t ≤ v → b ≤ p t := by
- intro t hut htv
- apply propagate hut hu
- intro r hur hrt hr
- by_cases heq : r = u
- · simpa [heq] using hu'
- · have := hstep r hur (by omega)
- have := hno r (by omega) (by omega)
- omega
-
/-- Equal visit sequences pair the visit times in order, with equal storage at each pair. -/
lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {T p q : ℕ}
(hseq : tm.visitSequence cfg T p = tm.visitSequence cfg T q) :
@@ -134,6 +96,28 @@ private lemma not_visit_between {cfg : Cfg k Symbol State input} {T p t : ℕ}
have hT := (tm.mem_visitTimes.mp v.property).1
exact h.2 (c := ⟨t, tm.mem_visitTimes.mpr ⟨hhi.le.trans hT, hp⟩⟩) hlo hhi
+/-- Between consecutive visits, a first step to the left keeps the input head on the left. -/
+private lemma inputPos_le_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
+ {u v : tm.visitTimes cfg T p} (h : u ⋖ v)
+ (hdir : (tm.runFrom cfg (u.val + 1)).inputPos.val ≤ p) :
+ ∀ t, u.val ≤ t → t ≤ v.val → (tm.runFrom cfg t).inputPos.val ≤ p := by
+ intro t hut htv
+ rcases eq_or_lt_of_le hut with rfl | hut
+ · exact (tm.mem_visitTimes.mp u.property).2.le
+ · exact tm.inputPos_le_of_forall_ne hut hdir fun r hur hrt =>
+ not_visit_between h (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
+
+/-- Between consecutive visits, a first step to the right keeps the input head on the right. -/
+private lemma le_inputPos_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
+ {u v : tm.visitTimes cfg T p} (h : u ⋖ v)
+ (hdir : p ≤ (tm.runFrom cfg (u.val + 1)).inputPos.val) :
+ ∀ t, u.val ≤ t → t ≤ v.val → p ≤ (tm.runFrom cfg t).inputPos.val := by
+ intro t hut htv
+ rcases eq_or_lt_of_le hut with rfl | hut
+ · exact (tm.mem_visitTimes.mp u.property).2.ge
+ · exact tm.le_inputPos_of_forall_ne hut hdir fun r hur hrt =>
+ not_visit_between h (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
+
/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
through the second; equal endpoints give an empty deletion. -/
abbrev InputCut (input : List Symbol) := NonemptyInterval (Fin input.length)
@@ -258,12 +242,13 @@ lemma Matches.reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
(hside : ∀ t, u ≤ t → t < v →
cut.SameSide (tm.runFrom cfg t).inputPos.val (tm.runFrom cfg (t + 1)).inputPos.val) :
∃ d, tm.Reaches c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
- apply propagate (P := fun t => ∃ d, tm.Reaches c' d ∧ cut.Matches (tm.runFrom cfg t) d)
- huv ⟨c', .refl, h⟩
- rintro t hut htv ⟨d, hd, hm⟩
- refine ⟨tm.step d, hd.tail rfl, ?_⟩
- rw [runFrom_succ_eq_step']
- exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside t hut htv)
+ induction v, huv using Nat.le_induction with
+ | base => exact ⟨c', .refl, h⟩
+ | succ v huv ih =>
+ obtain ⟨d, hd, hm⟩ := ih fun t hut htv => hside t hut (by omega)
+ refine ⟨tm.step d, hd.tail rfl, ?_⟩
+ rw [runFrom_succ_eq_step']
+ exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside v huv (by omega))
/-- The initial configurations match because the cut retains the first input symbol. -/
lemma matches_init : cut.Matches (tm.initCfg input) (tm.initCfg cut.shortened) := by
@@ -319,8 +304,6 @@ private lemma exists_matches_visit {T : ℕ}
have hmatch (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u ↔ P (e u) :=
exists_congr fun c' => and_congr_right fun _ =>
cut.matches_boundary_iff (hleft u) (hright (e u)) (hstore u)
- have hstep (u) : p (u + 1) ≤ p u + 1 ∧ p u ≤ p (u + 1) + 1 := by
- simpa only [p, c, runFrom_succ_eq_step'] using tm.inputPos_step_bounds (c u)
have follow {u v} (huv : u ≤ v) (hu : P u)
(hside : ∀ r, u ≤ r → r < v → cut.SameSide (p r) (p (r + 1))) : P v := by
obtain ⟨c', hr, hm⟩ := hu
@@ -329,14 +312,10 @@ private lemma exists_matches_visit {T : ℕ}
have boundary (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u := by
induction u using WellFoundedLT.induction with | ind u ih =>
by_cases hu : IsMin u
- · have hside : ∀ v ≤ u.val, p v ≤ cut.left := by
- intro v hv
- apply propagate (Nat.zero_le v) (show p 0 ≤ cut.left by simp [p, c, left])
- intro r _ hrv hr
- have := (hstep r).1
- have := not_visit_before hu (show r < u.val by omega)
- change p r ≠ cut.left at this
- omega
+ · have hside (v) (hv : v ≤ u.val) : p v ≤ cut.left := by
+ apply tm.inputPos_le_of_forall_ne (Nat.zero_le v) (by simp [left])
+ intro r _ hrv
+ exact not_visit_before hu (hrv.trans_le hv)
exact follow (Nat.zero_le _) ⟨_, .refl, cut.matches_init⟩ fun v _ hv =>
Or.inl ⟨hside v hv.le, hside (v + 1) hv⟩
· obtain ⟨v, hvu⟩ := exists_covBy_of_wellFoundedGT hu
@@ -344,13 +323,11 @@ private lemma exists_matches_visit {T : ℕ}
(hstore v)
simp only [← runFrom_succ_eq_step'] at hdir
rcases hdir with hdir | hdir
- · have hside := walk_left (fun r _ _ => (hstep r).1) (le_of_eq (hleft v))
- hdir (fun _ => not_visit_between hvu)
+ · have hside := inputPos_le_of_covBy hvu hdir
exact follow hvu.le (ih v hvu.lt) fun r hlo hhi =>
Or.inl ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩
· have he := (apply_covBy_apply_iff e).mpr hvu
- have hside := walk_right (fun r _ _ => (hstep r).2) (ge_of_eq (hright (e v)))
- hdir (fun _ => not_visit_between he)
+ have hside := le_inputPos_of_covBy he hdir
exact (hmatch u).mpr (follow he.le ((hmatch v).mp (ih v hvu.lt)) fun r hlo hhi =>
Or.inr ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩)
rcases hp with hp | hp
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
index 08bf275c3..d84923cd5 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
@@ -13,7 +13,8 @@ public import Mathlib.Order.Lattice.Nat
/-!
# Tape head visitation and space-usage lemmas
-This file collects lemmas about the set of positions visited by a work-tape head
+The input head cannot cross a cell without visiting it.
+This file also collects lemmas about the set of positions visited by a work-tape head
(`MultiTapeTM.visitedByTapeHead`) and the resulting space-usage measures
(`MultiTapeTM.spaceUsedByTape`, `MultiTapeTM.spaceUsed`) and how the tape head positions
influence the cells that are modified on a tape.
@@ -34,6 +35,36 @@ variable {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
variable {cfg : Cfg k Symbol State input}
+/-- An input head at or left of `p` at time `u` is still at or left of `p` at time `v`
+if it does not visit `p` during `[u, v)`. -/
+lemma inputPos_le_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
+ (hu : (tm.runFrom cfg u).inputPos.val ≤ p)
+ (hno : ∀ t, u ≤ t → t < v → (tm.runFrom cfg t).inputPos.val ≠ p) :
+ (tm.runFrom cfg v).inputPos.val ≤ p := by
+ induction v, huv using Nat.le_induction with
+ | base => exact hu
+ | succ v huv ih =>
+ have hprev := ih fun t hut htv => hno t hut (by omega)
+ have := hno v huv (Nat.lt_succ_self _)
+ have hstep := (tm.inputPos_step_bounds (tm.runFrom cfg v)).1
+ rw [← runFrom_succ_eq_step'] at hstep
+ omega
+
+/-- An input head at or right of `p` at time `u` is still at or right of `p` at time `v`
+if it does not visit `p` during `[u, v)`. -/
+lemma le_inputPos_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
+ (hu : p ≤ (tm.runFrom cfg u).inputPos.val)
+ (hno : ∀ t, u ≤ t → t < v → (tm.runFrom cfg t).inputPos.val ≠ p) :
+ p ≤ (tm.runFrom cfg v).inputPos.val := by
+ induction v, huv using Nat.le_induction with
+ | base => exact hu
+ | succ v huv ih =>
+ have hprev := ih fun t hut htv => hno t hut (by omega)
+ have := hno v huv (Nat.lt_succ_self _)
+ have hstep := (tm.inputPos_step_bounds (tm.runFrom cfg v)).2
+ rw [← runFrom_succ_eq_step'] at hstep
+ omega
+
/-- If the work tape head is not at position `z`, then the tape does not change there. -/
lemma step_workTapes_eq_of_ne
(cfg : Cfg k Symbol State input)
From 03abf9a254c73372bdd185da0f16f66b0a8d9e09 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 01:14:50 +0300
Subject: [PATCH 17/25] refactor(MultiTapeTM): simplify cut API
---
.../Turing/MultiTape/Deterministic.lean | 14 --
.../Turing/MultiTape/InputShortening.lean | 125 ++++++++++--------
.../Machines/Turing/MultiTape/TapeLemmas.lean | 34 ++---
3 files changed, 85 insertions(+), 88 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 7bc32830f..ad0bfc7f4 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -376,20 +376,6 @@ lemma relatesInSteps_iff_runFrom_eq
use tm.step^[t] cfg₁
grind
-/-- Reachability by zero or more transitions of the machine. -/
-abbrev Reaches (c₁ c₂ : Cfg k Symbol State input) : Prop :=
- Relation.ReflTransGen tm.TransitionRelation c₁ c₂
-
-/-- Reachability is equivalent to appearing in the run from the starting configuration. -/
-lemma reaches_iff_exists_runFrom {c₁ c₂ : Cfg k Symbol State input} :
- tm.Reaches c₁ c₂ ↔ ∃ t, tm.runFrom c₁ t = c₂ := by
- constructor
- · intro h
- obtain ⟨t, ht⟩ := h.relatesInSteps
- exact ⟨t, (tm.relatesInSteps_iff_runFrom_eq _ _ _).mp ht⟩
- · rintro ⟨t, ht⟩
- exact ((tm.relatesInSteps_iff_runFrom_eq _ _ _).mpr ht).reflTransGen
-
/-- The Turing machine `tm` halts after exactly `t` steps on input `input`
if its state is `none` at step `t` and non-none at step `t - 1`.
Note that every Turing machine hast to perform at least one step to halt. -/
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index c7f5dbc3b..6ca084ff0 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -27,6 +27,8 @@ to be joined.
namespace Turing.MultiTapeTM
+open Relation
+
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
@@ -126,10 +128,10 @@ namespace InputCut
variable (cut : InputCut input)
-/-- The one-based input-head position of the retained endpoint. -/
+/-- The head position of the retained endpoint: position `0` is the left endmarker. -/
def left : ℕ := cut.fst.val + 1
-/-- The one-based input-head position of the right endpoint. -/
+/-- The head position of the right endpoint: input symbol `i` is read at position `i + 1`. -/
def right : ℕ := cut.snd.val + 1
/-- The input obtained by deleting the cells after `left` through `right`. -/
@@ -170,57 +172,63 @@ private lemma position_right {p : ℕ} (hp : cut.right ≤ p) :
have := cut.fst_le_snd
omega
-/-- Corresponding input positions on the left read the same symbol. -/
-private lemma inputSymbol_left (c : Cfg k Symbol State input)
- (c' : Cfg k Symbol State cut.shortened)
- (hc : c.inputPos.val ≤ cut.left) (hp : c'.inputPos.val = c.inputPos.val) :
- c.inputSymbol = c'.inputSymbol := by
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hp]
- split_ifs with h
- · rfl
- · have hi : c.inputPos.val - 1 < cut.left := by omega
- have hle : cut.left ≤ input.length := cut.fst.isLt
- simp [shortened, List.getElem?_append, hle, hi]
-
-/-- Corresponding input positions on the right read the same symbol, including at the cut. -/
-private lemma inputSymbol_right (hsym : input[cut.fst] = input[cut.snd])
- (c : Cfg k Symbol State input)
- (c' : Cfg k Symbol State cut.shortened)
- (hc : cut.right ≤ c.inputPos.val)
- (hp : c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val) :
+namespace Matches
+
+variable {cut}
+
+/-- Matching positions on the left of the cut are equal. -/
+lemma inputPos_left {c : Cfg k Symbol State input}
+ {c' : Cfg k Symbol State cut.shortened} (h : cut.Matches c c')
+ (hp : c.inputPos.val ≤ cut.left) : c'.inputPos.val = c.inputPos.val :=
+ h.1.trans (cut.position_left hp)
+
+/-- Matching positions on the right differ by the number of deleted cells. -/
+lemma inputPos_right {c : Cfg k Symbol State input}
+ {c' : Cfg k Symbol State cut.shortened} (h : cut.Matches c c')
+ (hp : cut.right ≤ c.inputPos.val) :
+ c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val := by
+ rw [h.1, cut.position_right hp]
+ exact Nat.sub_add_cancel ((Nat.sub_le ..).trans hp)
+
+/-- Matching configurations outside the cut scan the same symbol when its endpoints agree. -/
+lemma inputSymbol (hsym : input[cut.fst] = input[cut.snd])
+ {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
+ (h : cut.Matches c c') (hp : c.inputPos.val ≤ cut.left ∨ cut.right ≤ c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
- have ha : 0 < cut.left := Nat.succ_pos _
- have hab : cut.left ≤ cut.right := Nat.add_le_add_right cut.fst_le_snd 1
- have hb : cut.right ≤ input.length := cut.snd.isLt
- have hp₀ : c.inputPos.val ≠ 0 := by omega
- have hp'₀ : c'.inputPos.val ≠ 0 := by omega
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀,
- ite_eq_right hp'₀]
- have htake : (input.take cut.left).length = cut.left := by simp; omega
- by_cases heq : c.inputPos.val = cut.right
- · have hpa : c'.inputPos.val = cut.left := by omega
- simpa [shortened, hpa, heq, List.getElem?_append,
- left, right, Fin.getElem_fin] using hsym.symm
- · have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
- have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
- simp [shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
-
-variable {cut} in
+ rcases hp with hp | hp
+ · rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, h.inputPos_left hp]
+ split_ifs with h₀
+ · rfl
+ · have hi : c.inputPos.val - 1 < cut.left := by omega
+ have hle : cut.left ≤ input.length := cut.fst.isLt
+ simp [shortened, List.getElem?_append, hle, hi]
+ · have hpos := h.inputPos_right hp
+ have ha : 0 < cut.left := Nat.succ_pos _
+ have hab : cut.left ≤ cut.right := Nat.add_le_add_right cut.fst_le_snd 1
+ have hp₀ : c.inputPos.val ≠ 0 := by omega
+ have hp'₀ : c'.inputPos.val ≠ 0 := by omega
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀, ite_eq_right hp'₀]
+ have htake : (input.take cut.left).length = cut.left := by
+ rw [List.length_take]
+ exact Nat.min_eq_left cut.fst.isLt
+ by_cases heq : c.inputPos.val = cut.right
+ · have hpa : c'.inputPos.val = cut.left := by omega
+ simpa [shortened, hpa, heq, List.getElem?_append,
+ left, right, Fin.getElem_fin] using hsym.symm
+ · have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
+ have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
+ simp [shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
+
/-- A step whose endpoints lie on the same retained side preserves matching configurations. -/
-lemma Matches.step (hsym : input[cut.fst] = input[cut.snd])
+lemma step (hsym : input[cut.fst] = input[cut.snd])
{c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
(h : cut.Matches c c') (hside : cut.SameSide c.inputPos.val (tm.step c).inputPos.val) :
cut.Matches (tm.step c) (tm.step c') := by
- obtain ⟨hp, hs⟩ := h
- have hsym' : c.inputSymbol = c'.inputSymbol := by
- rcases hside with ⟨hc, _⟩ | ⟨hc, _⟩
- · exact cut.inputSymbol_left _ _ hc (hp.trans (cut.position_left hc))
- · rw [cut.position_right hc] at hp
- exact cut.inputSymbol_right hsym _ _ hc (by omega)
- obtain ⟨m, hs', hm, hm'⟩ := tm.exists_step_move_of_storage_eq hs.symm hsym'
- refine ⟨?_, hs'.symm⟩
+ obtain ⟨m, hs, hm, hm'⟩ := tm.exists_step_move_of_storage_eq h.2.symm
+ (h.inputSymbol hsym (hside.imp And.left And.left))
+ refine ⟨?_, hs.symm⟩
rcases hside with ⟨hc, hn⟩ | ⟨hc, hn⟩
- · rw [cut.position_left hc] at hp
+ · have hp := h.inputPos_left hc
rw [hm', cut.position_left hn, hm]
exact (moveInputPos_same _ _ hp.symm (hc.trans cut.fst.isLt)
(by
@@ -228,20 +236,19 @@ lemma Matches.step (hsym : input[cut.fst] = input[cut.snd])
dsimp only [left, right] at *
have := cut.fst_le_snd
omega) m).symm
- · rw [cut.position_right hc] at hp
+ · have hp := h.inputPos_right hc
rw [hm', cut.position_right hn, hm]
- have he := moveInputPos_shift c.inputPos c'.inputPos (by omega)
+ have he := moveInputPos_shift c.inputPos c'.inputPos hp
cut.length_shortened_add (by dsimp only [left, right] at *; omega) m
omega
-variable {cut} in
/-- Simulate a run segment in which every step stays on a retained side of the cut. -/
-lemma Matches.reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
+lemma reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
{cfg : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened} {u v : ℕ}
(h : cut.Matches (tm.runFrom cfg u) c') (huv : u ≤ v)
(hside : ∀ t, u ≤ t → t < v →
cut.SameSide (tm.runFrom cfg t).inputPos.val (tm.runFrom cfg (t + 1)).inputPos.val) :
- ∃ d, tm.Reaches c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
+ ∃ d, ReflTransGen tm.TransitionRelation c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
induction v, huv using Nat.le_induction with
| base => exact ⟨c', .refl, h⟩
| succ v huv ih =>
@@ -250,6 +257,8 @@ lemma Matches.reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
rw [runFrom_succ_eq_step']
exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside v huv (by omega))
+end Matches
+
/-- The initial configurations match because the cut retains the first input symbol. -/
lemma matches_init : cut.Matches (tm.initCfg input) (tm.initCfg cut.shortened) := by
constructor
@@ -291,11 +300,12 @@ private lemma exists_matches_visit {T : ℕ}
{t : ℕ} (ht : t ≤ T)
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val = cut.left ∨
(tm.runFrom (tm.initCfg input) t).inputPos.val = cut.right) :
- ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧
+ ∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
cut.Matches (tm.runFrom (tm.initCfg input) t) c' := by
let c := tm.runFrom (tm.initCfg input)
let p := fun u => (c u).inputPos.val
- let P := fun u => ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧ cut.Matches (c u) c'
+ let P := fun u => ∃ c',
+ ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧ cut.Matches (c u) c'
obtain ⟨e, hstore⟩ := tm.exists_visitTimes_orderIso hseq
have hleft (u : tm.visitTimes (tm.initCfg input) T cut.left) :=
(tm.mem_visitTimes.mp u.property).2
@@ -344,7 +354,7 @@ theorem exists_matches_of_visitSequence_eq {T : ℕ}
{t : ℕ} (ht : t ≤ T)
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
- ∃ c', tm.Reaches (tm.initCfg cut.shortened) c' ∧
+ ∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
cut.Matches (tm.runFrom (tm.initCfg input) t) c' := by
induction t with
| zero => exact ⟨_, .refl, cut.matches_init⟩
@@ -377,8 +387,9 @@ theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
∃ u, (tm.runFrom (tm.initCfg cut.shortened) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
obtain ⟨c', hr, _, hs⟩ := cut.exists_matches_of_visitSequence_eq hsym hseq ht hp
- obtain ⟨u, rfl⟩ := tm.reaches_iff_exists_runFrom.mp hr
- exact ⟨u, hs⟩
+ obtain ⟨u, hu⟩ := hr.relatesInSteps
+ refine ⟨u, ?_⟩
+ rwa [(tm.relatesInSteps_iff_runFrom_eq _ _ _).mp hu]
/-- Every entry of a visit sequence is a storage reached by the run. -/
lemma mem_range_of_mem_visitSequence {cfg : Cfg k Symbol State input} {T p : ℕ}
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
index d84923cd5..838ec5218 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean
@@ -35,35 +35,35 @@ variable {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
variable {cfg : Cfg k Symbol State input}
-/-- An input head at or left of `p` at time `u` is still at or left of `p` at time `v`
-if it does not visit `p` during `[u, v)`. -/
-lemma inputPos_le_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
- (hu : (tm.runFrom cfg u).inputPos.val ≤ p)
+/-- Avoiding a cell preserves both possible bounds relative to that cell. -/
+private lemma inputPos_bounds_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
(hno : ∀ t, u ≤ t → t < v → (tm.runFrom cfg t).inputPos.val ≠ p) :
- (tm.runFrom cfg v).inputPos.val ≤ p := by
+ ((tm.runFrom cfg u).inputPos.val ≤ p → (tm.runFrom cfg v).inputPos.val ≤ p) ∧
+ (p ≤ (tm.runFrom cfg u).inputPos.val → p ≤ (tm.runFrom cfg v).inputPos.val) := by
induction v, huv using Nat.le_induction with
- | base => exact hu
+ | base => exact ⟨id, id⟩
| succ v huv ih =>
have hprev := ih fun t hut htv => hno t hut (by omega)
have := hno v huv (Nat.lt_succ_self _)
- have hstep := (tm.inputPos_step_bounds (tm.runFrom cfg v)).1
+ have hstep := tm.inputPos_step_bounds (tm.runFrom cfg v)
rw [← runFrom_succ_eq_step'] at hstep
- omega
+ constructor <;> intro h <;> omega
+
+/-- An input head at or left of `p` at time `u` is still at or left of `p` at time `v`
+if it does not visit `p` during `[u, v)`. -/
+lemma inputPos_le_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
+ (hu : (tm.runFrom cfg u).inputPos.val ≤ p)
+ (hno : ∀ t, u ≤ t → t < v → (tm.runFrom cfg t).inputPos.val ≠ p) :
+ (tm.runFrom cfg v).inputPos.val ≤ p :=
+ (inputPos_bounds_of_forall_ne huv hno).1 hu
/-- An input head at or right of `p` at time `u` is still at or right of `p` at time `v`
if it does not visit `p` during `[u, v)`. -/
lemma le_inputPos_of_forall_ne {u v p : ℕ} (huv : u ≤ v)
(hu : p ≤ (tm.runFrom cfg u).inputPos.val)
(hno : ∀ t, u ≤ t → t < v → (tm.runFrom cfg t).inputPos.val ≠ p) :
- p ≤ (tm.runFrom cfg v).inputPos.val := by
- induction v, huv using Nat.le_induction with
- | base => exact hu
- | succ v huv ih =>
- have hprev := ih fun t hut htv => hno t hut (by omega)
- have := hno v huv (Nat.lt_succ_self _)
- have hstep := (tm.inputPos_step_bounds (tm.runFrom cfg v)).2
- rw [← runFrom_succ_eq_step'] at hstep
- omega
+ p ≤ (tm.runFrom cfg v).inputPos.val :=
+ (inputPos_bounds_of_forall_ne huv hno).2 hu
/-- If the work tape head is not at position `z`, then the tape does not change there. -/
lemma step_workTapes_eq_of_ne
From 68618a9078a4fd93568ab0d98109e025090fd695 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 01:27:09 +0300
Subject: [PATCH 18/25] refactor(MultiTapeTM): separate cut properties
---
.../Turing/MultiTape/InputShortening.lean | 126 ++++++++++--------
1 file changed, 69 insertions(+), 57 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 6ca084ff0..6b7f4c520 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -121,7 +121,9 @@ private lemma le_inputPos_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
not_visit_between h (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
-through the second; equal endpoints give an empty deletion. -/
+through the second; equal endpoints give an empty deletion.
+`fst` and `snd` are zero-based list indices; `left` and `right` are the corresponding
+input-head positions, offset by one because position `0` is the left endmarker. -/
abbrev InputCut (input : List Symbol) := NonemptyInterval (Fin input.length)
namespace InputCut
@@ -142,11 +144,6 @@ def shortened : List Symbol :=
def position (p : ℕ) : ℕ :=
min p cut.left + (p - cut.right)
-/-- Corresponding configurations have equal storage and input positions related by the cut. -/
-def Matches (c : Cfg k Symbol State input)
- (c' : Cfg k Symbol State cut.shortened) : Prop :=
- c'.inputPos.val = cut.position c.inputPos.val ∧ c'.storage = c.storage
-
/-- Two input positions lie on the same retained side of the cut. -/
def SameSide (p q : ℕ) : Prop :=
(p ≤ cut.left ∧ q ≤ cut.left) ∨ (cut.right ≤ p ∧ cut.right ≤ q)
@@ -172,52 +169,78 @@ private lemma position_right {p : ℕ} (hp : cut.right ≤ p) :
have := cut.fst_le_snd
omega
-namespace Matches
+/-- The cut preserves the left endmarker and maps positive positions to positive positions. -/
+@[simp]
+lemma position_eq_zero {p : ℕ} : cut.position p = 0 ↔ p = 0 := by
+ simp only [position, left, right]
+ omega
-variable {cut}
+/-- Indexing the retained prefix is unchanged. -/
+lemma getElem?_left {i : ℕ} (hi : i < cut.left) : cut.shortened[i]? = input[i]? := by
+ have hle : cut.left ≤ input.length := cut.fst.isLt
+ simp [shortened, List.getElem?_append, hle, hi]
+
+/-- Indexing the retained suffix shifts by the number of deleted symbols. -/
+lemma getElem?_right (i : ℕ) :
+ cut.shortened[cut.left + i]? = input[cut.right + i]? := by
+ have hle : cut.left ≤ input.length := cut.fst.isLt
+ simp [shortened, List.getElem?_append, hle]
+
+/-- The removed right endpoint is represented by the retained left endpoint. -/
+lemma getElem?_boundary (hsym : input[cut.fst] = input[cut.snd]) :
+ cut.shortened[cut.left - 1]? = input[cut.right - 1]? := by
+ rw [cut.getElem?_left (Nat.sub_lt (Nat.succ_pos _) (by decide))]
+ simpa [left, right, Fin.getElem_fin] using congrArg some hsym
+
+/-- Outside the deleted interval, the position map preserves the indexed symbol. -/
+lemma getElem?_position (hsym : input[cut.fst] = input[cut.snd]) {p : ℕ}
+ (hp : p ≤ cut.left ∨ cut.right ≤ p) :
+ cut.shortened[cut.position p - 1]? = input[p - 1]? := by
+ have ha : 0 < cut.left := Nat.succ_pos _
+ have hab : cut.left ≤ cut.right := Nat.add_le_add_right cut.fst_le_snd 1
+ rcases hp with hp | hp
+ · rw [cut.position_left hp]
+ exact cut.getElem?_left (by omega)
+ · rw [cut.position_right hp]
+ by_cases heq : p = cut.right
+ · subst p
+ rw [Nat.sub_sub_self hab]
+ exact cut.getElem?_boundary hsym
+ · convert cut.getElem?_right (p - cut.right - 1) using 2 <;> omega
+
+/-- On either retained side, mapping positions commutes with an input-head move. -/
+lemma position_moveInputPos {p : Fin (input.length + 2)}
+ {p' : Fin (cut.shortened.length + 2)} (hp : p'.val = cut.position p.val) (m : SignType)
+ (hside : cut.SameSide p.val (moveInputPos p m).val) :
+ cut.position (moveInputPos p m).val = (moveInputPos p' m).val := by
+ have hlen := cut.length_shortened_add
+ have hbounds : 0 < cut.left ∧ cut.left ≤ cut.right ∧ cut.right ≤ input.length :=
+ ⟨Nat.succ_pos _, Nat.add_le_add_right cut.fst_le_snd 1, cut.snd.isLt⟩
+ rcases hside with ⟨hc, hn⟩ | ⟨hc, hn⟩
+ · rw [cut.position_left hc] at hp
+ rw [cut.position_left hn]
+ exact moveInputPos_same _ _ hp.symm (by omega) (by omega) m
+ · rw [cut.position_right hc] at hp
+ rw [cut.position_right hn]
+ have he := moveInputPos_shift p p' (by omega) hlen (by omega) m
+ omega
-/-- Matching positions on the left of the cut are equal. -/
-lemma inputPos_left {c : Cfg k Symbol State input}
- {c' : Cfg k Symbol State cut.shortened} (h : cut.Matches c c')
- (hp : c.inputPos.val ≤ cut.left) : c'.inputPos.val = c.inputPos.val :=
- h.1.trans (cut.position_left hp)
+/-- Corresponding configurations have equal storage and input positions related by the cut. -/
+def Matches (c : Cfg k Symbol State input)
+ (c' : Cfg k Symbol State cut.shortened) : Prop :=
+ c'.inputPos.val = cut.position c.inputPos.val ∧ c'.storage = c.storage
-/-- Matching positions on the right differ by the number of deleted cells. -/
-lemma inputPos_right {c : Cfg k Symbol State input}
- {c' : Cfg k Symbol State cut.shortened} (h : cut.Matches c c')
- (hp : cut.right ≤ c.inputPos.val) :
- c'.inputPos.val + (cut.right - cut.left) = c.inputPos.val := by
- rw [h.1, cut.position_right hp]
- exact Nat.sub_add_cancel ((Nat.sub_le ..).trans hp)
+namespace Matches
+
+variable {cut}
/-- Matching configurations outside the cut scan the same symbol when its endpoints agree. -/
lemma inputSymbol (hsym : input[cut.fst] = input[cut.snd])
{c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
(h : cut.Matches c c') (hp : c.inputPos.val ≤ cut.left ∨ cut.right ≤ c.inputPos.val) :
c.inputSymbol = c'.inputSymbol := by
- rcases hp with hp | hp
- · rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, h.inputPos_left hp]
- split_ifs with h₀
- · rfl
- · have hi : c.inputPos.val - 1 < cut.left := by omega
- have hle : cut.left ≤ input.length := cut.fst.isLt
- simp [shortened, List.getElem?_append, hle, hi]
- · have hpos := h.inputPos_right hp
- have ha : 0 < cut.left := Nat.succ_pos _
- have hab : cut.left ≤ cut.right := Nat.add_le_add_right cut.fst_le_snd 1
- have hp₀ : c.inputPos.val ≠ 0 := by omega
- have hp'₀ : c'.inputPos.val ≠ 0 := by omega
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, ite_eq_right hp₀, ite_eq_right hp'₀]
- have htake : (input.take cut.left).length = cut.left := by
- rw [List.length_take]
- exact Nat.min_eq_left cut.fst.isLt
- by_cases heq : c.inputPos.val = cut.right
- · have hpa : c'.inputPos.val = cut.left := by omega
- simpa [shortened, hpa, heq, List.getElem?_append,
- left, right, Fin.getElem_fin] using hsym.symm
- · have hi : cut.left ≤ c'.inputPos.val - 1 := by omega
- have he : cut.right + (c'.inputPos.val - 1 - cut.left) = c.inputPos.val - 1 := by omega
- simp [shortened, List.getElem?_append, htake, not_lt.mpr hi, he]
+ simp only [inputSymbol_eq_getElem?, h.1, cut.position_eq_zero,
+ cut.getElem?_position hsym hp]
/-- A step whose endpoints lie on the same retained side preserves matching configurations. -/
lemma step (hsym : input[cut.fst] = input[cut.snd])
@@ -226,21 +249,10 @@ lemma step (hsym : input[cut.fst] = input[cut.snd])
cut.Matches (tm.step c) (tm.step c') := by
obtain ⟨m, hs, hm, hm'⟩ := tm.exists_step_move_of_storage_eq h.2.symm
(h.inputSymbol hsym (hside.imp And.left And.left))
+ rw [hm] at hside
refine ⟨?_, hs.symm⟩
- rcases hside with ⟨hc, hn⟩ | ⟨hc, hn⟩
- · have hp := h.inputPos_left hc
- rw [hm', cut.position_left hn, hm]
- exact (moveInputPos_same _ _ hp.symm (hc.trans cut.fst.isLt)
- (by
- have := cut.length_shortened_add
- dsimp only [left, right] at *
- have := cut.fst_le_snd
- omega) m).symm
- · have hp := h.inputPos_right hc
- rw [hm', cut.position_right hn, hm]
- have he := moveInputPos_shift c.inputPos c'.inputPos hp
- cut.length_shortened_add (by dsimp only [left, right] at *; omega) m
- omega
+ rw [hm, hm']
+ exact (cut.position_moveInputPos h.1 m hside).symm
/-- Simulate a run segment in which every step stays on a retained side of the cut. -/
lemma reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
From fbe4e080c7fdf0b2dd2338a79e28fc06089339f8 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 01:44:07 +0300
Subject: [PATCH 19/25] refactor(MultiTapeTM): pair boundary visits
---
.../Turing/MultiTape/Configuration.lean | 9 -
.../Turing/MultiTape/InputShortening.lean | 248 +++++++++++-------
2 files changed, 152 insertions(+), 105 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
index d8c9c9a03..49e35c0d6 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean
@@ -166,15 +166,6 @@ lemma moveInputPos_shift {n n' d : ℕ} (p : Fin (n + 2)) (p' : Fin (n' + 2))
have := p'.isLt
cases m <;> simp [SignType.cast] <;> omega
-/-- The same move gives the same displacement at any two positions inside the input. -/
-lemma moveInputPos_interior {n n' : ℕ}
- (p : Fin (n + 2)) (p' : Fin (n' + 2))
- (hp₀ : 0 < p.val) (hp : p.val ≤ n) (hp'₀ : 0 < p'.val) (hp' : p'.val ≤ n')
- (m : SignType) :
- (moveInputPos p m).val + p'.val = (moveInputPos p' m).val + p.val := by
- rw [moveInputPos_val, moveInputPos_val]
- cases m <;> simp [SignType.cast] <;> omega
-
/-- The symbol currently under the input tape head. -/
def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol :=
if h₁ : cfg.inputPos = 0 then none
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 6b7f4c520..33ce1ea88 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -21,6 +21,11 @@ computation, regardless of the write-only output.
`InputCut` describes a deletion between input-symbol indices. Its position map relates
configurations on the original and shortened inputs, allowing the run segments on either side
to be joined.
+
+`InputCut.VisitPairing` pairs boundary visits in order with equal symbols and storages.
+The shortened run first follows the retained prefix. Between consecutive pairs, the common
+head move selects an excursion on a retained side. Induction over the pairs reaches every
+boundary visit; subsequent retained steps reach every configuration outside the cut.
-/
@[expose] public section
@@ -148,6 +153,13 @@ def position (p : ℕ) : ℕ :=
def SameSide (p q : ℕ) : Prop :=
(p ≤ cut.left ∧ q ≤ cut.left) ∨ (cut.right ≤ p ∧ cut.right ≤ q)
+/-- A one-cell move ending outside the cut, away from its boundaries, stays on a retained side. -/
+lemma sameSide_of_not_boundary {p q : ℕ} (hstep : q ≤ p + 1 ∧ p ≤ q + 1)
+ (hq : q ≤ cut.left ∨ cut.right ≤ q) (hne : ¬ (q = cut.left ∨ q = cut.right)) :
+ cut.SameSide p q := by
+ dsimp only [SameSide]
+ omega
+
/-- Adding back the deleted cells recovers the original input length. -/
private lemma length_shortened_add :
cut.shortened.length + (cut.right - cut.left) = input.length := by
@@ -242,13 +254,21 @@ lemma inputSymbol (hsym : input[cut.fst] = input[cut.snd])
simp only [inputSymbol_eq_getElem?, h.1, cut.position_eq_zero,
cut.getElem?_position hsym hp]
-/-- A step whose endpoints lie on the same retained side preserves matching configurations. -/
-lemma step (hsym : input[cut.fst] = input[cut.snd])
- {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
- (h : cut.Matches c c') (hside : cut.SameSide c.inputPos.val (tm.step c).inputPos.val) :
+/-- Matching configurations on the retained prefix scan the same symbol. -/
+lemma inputSymbol_left {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
+ (h : cut.Matches c c') (hp : c.inputPos.val ≤ cut.left) :
+ c.inputSymbol = c'.inputSymbol := by
+ have hi : c.inputPos.val - 1 < cut.left := by
+ have : 0 < cut.left := Nat.succ_pos _
+ omega
+ simp only [inputSymbol_eq_getElem?, h.1, cut.position_left hp, cut.getElem?_left hi]
+
+/-- Matching configurations scanning the same symbol stay matched across a retained step. -/
+lemma step {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
+ (h : cut.Matches c c') (hsym : c.inputSymbol = c'.inputSymbol)
+ (hside : cut.SameSide c.inputPos.val (tm.step c).inputPos.val) :
cut.Matches (tm.step c) (tm.step c') := by
- obtain ⟨m, hs, hm, hm'⟩ := tm.exists_step_move_of_storage_eq h.2.symm
- (h.inputSymbol hsym (hside.imp And.left And.left))
+ obtain ⟨m, hs, hm, hm'⟩ := tm.exists_step_move_of_storage_eq h.2.symm hsym
rw [hm] at hside
refine ⟨?_, hs.symm⟩
rw [hm, hm']
@@ -267,7 +287,25 @@ lemma reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
obtain ⟨d, hd, hm⟩ := ih fun t hut htv => hside t hut (by omega)
refine ⟨tm.step d, hd.tail rfl, ?_⟩
rw [runFrom_succ_eq_step']
- exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside v huv (by omega))
+ have hv := hside v huv (by omega)
+ exact hm.step (hm.inputSymbol hsym (hv.imp And.left And.left))
+ (by simpa only [runFrom_succ_eq_step'] using hv)
+
+/-- Simulate a segment in the retained prefix, without any assumption on the boundary symbols. -/
+lemma reaches_runFrom_left
+ {cfg : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened} {u v : ℕ}
+ (h : cut.Matches (tm.runFrom cfg u) c') (huv : u ≤ v)
+ (hside : ∀ t, u ≤ t → t ≤ v → (tm.runFrom cfg t).inputPos.val ≤ cut.left) :
+ ∃ d, ReflTransGen tm.TransitionRelation c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
+ induction v, huv using Nat.le_induction with
+ | base => exact ⟨c', .refl, h⟩
+ | succ v huv ih =>
+ obtain ⟨d, hd, hm⟩ := ih fun t hut htv => hside t hut (htv.trans (Nat.le_succ _))
+ have hv := hside v huv (Nat.le_succ _)
+ refine ⟨tm.step d, hd.tail rfl, ?_⟩
+ rw [runFrom_succ_eq_step']
+ exact hm.step (hm.inputSymbol_left hv) (.inl ⟨hv, by
+ simpa only [runFrom_succ_eq_step'] using hside (v + 1) (by omega) le_rfl⟩)
end Matches
@@ -277,93 +315,107 @@ lemma matches_init : cut.Matches (tm.initCfg input) (tm.initCfg cut.shortened) :
· exact (cut.position_left (p := 1) (Nat.succ_le_succ (Nat.zero_le _))).symm
· rfl
-/-- Equal storages at the two boundary positions match the same shortened configurations. -/
-private lemma matches_boundary_iff
- {c₁ c₂ : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened}
- (h₁ : c₁.inputPos.val = cut.left) (h₂ : c₂.inputPos.val = cut.right)
- (hs : c₁.storage = c₂.storage) : cut.Matches c₁ c' ↔ cut.Matches c₂ c' := by
+/-- An order-preserving pairing of boundary visits with equal symbols and storages. -/
+structure VisitPairing (tm : MultiTapeTM k Symbol State) (T : ℕ) where
+ /-- The paired boundary positions carry the same input symbol. -/
+ symbol_eq : input[cut.fst] = input[cut.snd]
+ /-- The visits to the two boundaries correspond in chronological order. -/
+ orderIso : tm.visitTimes (tm.initCfg input) T cut.left ≃o
+ tm.visitTimes (tm.initCfg input) T cut.right
+ /-- Corresponding visits have the same storage. -/
+ storage_eq (u : tm.visitTimes (tm.initCfg input) T cut.left) :
+ (tm.runFrom (tm.initCfg input) u).storage =
+ (tm.runFrom (tm.initCfg input) (orderIso u)).storage
+
+/-- The retained prefix reaches the first visit to the left boundary. -/
+private lemma exists_matches_first_visit {T : ℕ}
+ {u : tm.visitTimes (tm.initCfg input) T cut.left} (hu : IsMin u) :
+ ∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
+ cut.Matches (tm.runFrom (tm.initCfg input) u) c' := by
+ have hside (v) (hv : v ≤ u.val) :
+ (tm.runFrom (tm.initCfg input) v).inputPos.val ≤ cut.left := by
+ apply tm.inputPos_le_of_forall_ne (Nat.zero_le v) (by simp [left])
+ exact fun r _ hrv => not_visit_before hu (hrv.trans_le hv)
+ exact cut.matches_init.reaches_runFrom_left (cfg := tm.initCfg input) (u := 0)
+ (Nat.zero_le _) fun v _ hv => hside v hv
+
+namespace VisitPairing
+
+variable {cut} {T : ℕ} (pairing : cut.VisitPairing tm T)
+
+include pairing
+
+/-- Paired visits represent the same storage at the collapsed boundary. -/
+private lemma matches_iff (u : tm.visitTimes (tm.initCfg input) T cut.left)
+ {c' : Cfg k Symbol State cut.shortened} :
+ cut.Matches (tm.runFrom (tm.initCfg input) u) c' ↔
+ cut.Matches (tm.runFrom (tm.initCfg input) (pairing.orderIso u)) c' := by
+ have hleft := (tm.mem_visitTimes.mp u.property).2
+ have hright := (tm.mem_visitTimes.mp (pairing.orderIso u).property).2
have hba : cut.right - (cut.right - cut.left) = cut.left :=
Nat.sub_sub_self (Nat.add_le_add_right cut.fst_le_snd 1)
- simp only [Matches, h₁, h₂, cut.position_left le_rfl, cut.position_right le_rfl,
- hba, hs]
-
-/-- Of two boundary configurations with equal storage, at least one steps into a retained side. -/
-private lemma step_boundary_sides (hsym : input[cut.fst] = input[cut.snd])
- {c₁ c₂ : Cfg k Symbol State input}
- (h₁ : c₁.inputPos.val = cut.left) (h₂ : c₂.inputPos.val = cut.right)
- (hs : c₁.storage = c₂.storage) :
- (tm.step c₁).inputPos.val ≤ cut.left ∨ cut.right ≤ (tm.step c₂).inputPos.val := by
- have hsy : c₁.inputSymbol = c₂.inputSymbol := by
- rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, h₁, h₂]
- simpa [left, right, Fin.getElem_fin] using hsym
- obtain ⟨dir, _, hm₁, hm₂⟩ := tm.exists_step_move_of_storage_eq hs hsy
- have hm := moveInputPos_interior c₁.inputPos c₂.inputPos
- (by rw [h₁]; exact Nat.succ_pos _) (by rw [h₁]; exact cut.fst.isLt)
- (by rw [h₂]; exact Nat.succ_pos _) (by rw [h₂]; exact cut.snd.isLt) dir
- rw [← hm₁, ← hm₂, h₁, h₂] at hm
- omega
-
-/-- Paired boundary visits have reachable matching configurations: at each pair, follow the
-next excursion on whichever side its first step retains. -/
-private lemma exists_matches_visit {T : ℕ}
- (hsym : input[cut.fst] = input[cut.snd])
- (hseq : tm.visitSequence (tm.initCfg input) T cut.left =
- tm.visitSequence (tm.initCfg input) T cut.right)
- {t : ℕ} (ht : t ≤ T)
- (hp : (tm.runFrom (tm.initCfg input) t).inputPos.val = cut.left ∨
- (tm.runFrom (tm.initCfg input) t).inputPos.val = cut.right) :
+ simp only [Matches, hleft, hright, cut.position_left le_rfl,
+ cut.position_right le_rfl, hba, pairing.storage_eq u]
+
+/-- At a paired visit, at least one of the two next steps enters a retained side. -/
+private lemma step_sides (u : tm.visitTimes (tm.initCfg input) T cut.left) :
+ (tm.runFrom (tm.initCfg input) (u.val + 1)).inputPos.val ≤ cut.left ∨
+ cut.right ≤ (tm.runFrom (tm.initCfg input) ((pairing.orderIso u).val + 1)).inputPos.val := by
+ have hleft := (tm.mem_visitTimes.mp u.property).2
+ have hright := (tm.mem_visitTimes.mp (pairing.orderIso u).property).2
+ have hsym : (tm.runFrom (tm.initCfg input) u).inputSymbol =
+ (tm.runFrom (tm.initCfg input) (pairing.orderIso u)).inputSymbol := by
+ rw [inputSymbol_eq_getElem?, inputSymbol_eq_getElem?, hleft, hright]
+ simpa [left, right, Fin.getElem_fin] using pairing.symbol_eq
+ obtain ⟨m, _, hm, hm'⟩ := tm.exists_step_move_of_storage_eq (pairing.storage_eq u) hsym
+ rw [runFrom_succ_eq_step', runFrom_succ_eq_step', hm, hm',
+ moveInputPos_val, moveInputPos_val, hleft, hright]
+ have hb : cut.right ≤ input.length := cut.snd.isLt
+ cases m <;> simp [SignType.cast]; omega
+
+/-- Between consecutive paired visits, follow the excursion on a retained side. -/
+private lemma reaches_next_visit {u v : tm.visitTimes (tm.initCfg input) T cut.left}
+ (huv : u ⋖ v) {c' : Cfg k Symbol State cut.shortened}
+ (h : cut.Matches (tm.runFrom (tm.initCfg input) u) c') :
+ ∃ d, ReflTransGen tm.TransitionRelation c' d ∧
+ cut.Matches (tm.runFrom (tm.initCfg input) v) d := by
+ rcases pairing.step_sides u with hleft | hright
+ · exact h.reaches_runFrom_left huv.le (inputPos_le_of_covBy huv hleft)
+ · have he := (apply_covBy_apply_iff pairing.orderIso).mpr huv
+ have hside := le_inputPos_of_covBy he hright
+ obtain ⟨d, hd, hm⟩ := ((pairing.matches_iff u).mp h).reaches_runFrom
+ pairing.symbol_eq he.le fun r hlo hhi =>
+ Or.inr ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩
+ exact ⟨d, hd, (pairing.matches_iff v).mpr hm⟩
+
+/-- Induct over the paired visits, starting with the retained prefix. -/
+private lemma exists_matches_left_visit (u : tm.visitTimes (tm.initCfg input) T cut.left) :
∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
- cut.Matches (tm.runFrom (tm.initCfg input) t) c' := by
- let c := tm.runFrom (tm.initCfg input)
- let p := fun u => (c u).inputPos.val
- let P := fun u => ∃ c',
- ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧ cut.Matches (c u) c'
- obtain ⟨e, hstore⟩ := tm.exists_visitTimes_orderIso hseq
- have hleft (u : tm.visitTimes (tm.initCfg input) T cut.left) :=
- (tm.mem_visitTimes.mp u.property).2
- have hright (u : tm.visitTimes (tm.initCfg input) T cut.right) :=
- (tm.mem_visitTimes.mp u.property).2
- have hmatch (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u ↔ P (e u) :=
- exists_congr fun c' => and_congr_right fun _ =>
- cut.matches_boundary_iff (hleft u) (hright (e u)) (hstore u)
- have follow {u v} (huv : u ≤ v) (hu : P u)
- (hside : ∀ r, u ≤ r → r < v → cut.SameSide (p r) (p (r + 1))) : P v := by
- obtain ⟨c', hr, hm⟩ := hu
- obtain ⟨d, hd, hm'⟩ := hm.reaches_runFrom hsym huv hside
+ cut.Matches (tm.runFrom (tm.initCfg input) u) c' := by
+ induction u using WellFoundedLT.induction with | ind u ih =>
+ by_cases hu : IsMin u
+ · exact cut.exists_matches_first_visit hu
+ · obtain ⟨v, hvu⟩ := exists_covBy_of_wellFoundedGT hu
+ obtain ⟨c', hr, hm⟩ := ih v hvu.lt
+ obtain ⟨d, hd, hm'⟩ := pairing.reaches_next_visit hvu hm
exact ⟨d, hr.trans hd, hm'⟩
- have boundary (u : tm.visitTimes (tm.initCfg input) T cut.left) : P u := by
- induction u using WellFoundedLT.induction with | ind u ih =>
- by_cases hu : IsMin u
- · have hside (v) (hv : v ≤ u.val) : p v ≤ cut.left := by
- apply tm.inputPos_le_of_forall_ne (Nat.zero_le v) (by simp [left])
- intro r _ hrv
- exact not_visit_before hu (hrv.trans_le hv)
- exact follow (Nat.zero_le _) ⟨_, .refl, cut.matches_init⟩ fun v _ hv =>
- Or.inl ⟨hside v hv.le, hside (v + 1) hv⟩
- · obtain ⟨v, hvu⟩ := exists_covBy_of_wellFoundedGT hu
- have hdir := cut.step_boundary_sides hsym (tm := tm) (hleft v) (hright (e v))
- (hstore v)
- simp only [← runFrom_succ_eq_step'] at hdir
- rcases hdir with hdir | hdir
- · have hside := inputPos_le_of_covBy hvu hdir
- exact follow hvu.le (ih v hvu.lt) fun r hlo hhi =>
- Or.inl ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩
- · have he := (apply_covBy_apply_iff e).mpr hvu
- have hside := le_inputPos_of_covBy he hdir
- exact (hmatch u).mpr (follow he.le ((hmatch v).mp (ih v hvu.lt)) fun r hlo hhi =>
- Or.inr ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩)
- rcases hp with hp | hp
- · exact boundary ⟨t, tm.mem_visitTimes.mpr ⟨ht, hp⟩⟩
- · let u : tm.visitTimes (tm.initCfg input) T cut.right := ⟨t, tm.mem_visitTimes.mpr ⟨ht, hp⟩⟩
- simpa only [e.apply_symm_apply] using (hmatch (e.symm u)).mp (boundary (e.symm u))
-/-- Equal boundary visit sequences give every configuration outside the cut a reachable
+/-- Every boundary visit has a reachable matching configuration on the shortened input. -/
+lemma exists_matches_visit
+ (u : (tm.visitTimes (tm.initCfg input) T cut.left ∪
+ tm.visitTimes (tm.initCfg input) T cut.right : Finset ℕ)) :
+ ∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
+ cut.Matches (tm.runFrom (tm.initCfg input) u) c' := by
+ rcases Finset.mem_union.mp u.property with hu | hu
+ · exact pairing.exists_matches_left_visit ⟨u.val, hu⟩
+ · let v := pairing.orderIso.symm ⟨u.val, hu⟩
+ obtain ⟨c', hr, hm⟩ := pairing.exists_matches_left_visit v
+ exact ⟨c', hr, by
+ simpa only [v, pairing.orderIso.apply_symm_apply] using (pairing.matches_iff v).mp hm⟩
+
+/-- A pairing of boundary visits gives every configuration outside the cut a reachable
matching configuration on the shortened input. -/
-theorem exists_matches_of_visitSequence_eq {T : ℕ}
- (hsym : input[cut.fst] = input[cut.snd])
- (hseq : tm.visitSequence (tm.initCfg input) T cut.left =
- tm.visitSequence (tm.initCfg input) T cut.right)
- {t : ℕ} (ht : t ≤ T)
+theorem exists_matches {t : ℕ} (ht : t ≤ T)
(hp : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ cut.left ∨
cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
@@ -373,17 +425,19 @@ theorem exists_matches_of_visitSequence_eq {T : ℕ}
| succ t ih =>
by_cases hb : (tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val = cut.left ∨
(tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val = cut.right
- · exact cut.exists_matches_visit hsym hseq ht hb
+ · exact pairing.exists_matches_visit ⟨t + 1, by
+ simp only [Finset.mem_union, tm.mem_visitTimes]
+ exact hb.imp (fun h => ⟨ht, h⟩) (fun h => ⟨ht, h⟩)⟩
have hbounds := tm.inputPos_step_bounds (tm.runFrom (tm.initCfg input) t)
- have hside : cut.SameSide (tm.runFrom (tm.initCfg input) t).inputPos.val
- (tm.runFrom (tm.initCfg input) (t + 1)).inputPos.val := by
- dsimp only [SameSide]
- rw [← runFrom_succ_eq_step'] at hbounds
- omega
+ rw [← runFrom_succ_eq_step'] at hbounds
+ have hside := cut.sameSide_of_not_boundary hbounds hp hb
obtain ⟨c', hr, hm⟩ := ih (by omega) (hside.imp And.left And.left)
refine ⟨tm.step c', hr.tail rfl, ?_⟩
rw [runFrom_succ_eq_step']
- exact hm.step hsym (by simpa only [runFrom_succ_eq_step'] using hside)
+ exact hm.step (hm.inputSymbol pairing.symbol_eq (hside.imp And.left And.left))
+ (by simpa only [runFrom_succ_eq_step'] using hside)
+
+end VisitPairing
end InputCut
@@ -398,7 +452,9 @@ theorem exists_storage_cut (cut : InputCut input) {T : ℕ}
cut.right ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
∃ u, (tm.runFrom (tm.initCfg cut.shortened) u).storage =
(tm.runFrom (tm.initCfg input) t).storage := by
- obtain ⟨c', hr, _, hs⟩ := cut.exists_matches_of_visitSequence_eq hsym hseq ht hp
+ obtain ⟨e, hstore⟩ := tm.exists_visitTimes_orderIso hseq
+ let pairing : cut.VisitPairing tm T := ⟨hsym, e, hstore⟩
+ obtain ⟨c', hr, _, hs⟩ := pairing.exists_matches ht hp
obtain ⟨u, hu⟩ := hr.relatesInSteps
refine ⟨u, ?_⟩
rwa [(tm.relatesInSteps_iff_runFrom_eq _ _ _).mp hu]
From b3ca72cf8a363253c81d54cbfd34829633734159 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 01:55:46 +0300
Subject: [PATCH 20/25] refactor(MultiTapeTM): use interval API
---
.../Turing/MultiTape/InputShortening.lean | 93 ++++++++-----------
1 file changed, 40 insertions(+), 53 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 33ce1ea88..29a646fd0 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -32,7 +32,7 @@ boundary visit; subsequent retained steps reach every configuration outside the
namespace Turing.MultiTapeTM
-open Relation
+open Relation Set
variable {k : ℕ} {Symbol State : Type*} {input : List Symbol}
variable {tm : MultiTapeTM k Symbol State}
@@ -87,43 +87,33 @@ lemma exists_visitTimes_orderIso {cfg : Cfg k Symbol State input} {T p q : ℕ}
OrderIso.symm_apply_apply, A, B, Finset.coe_orderIsoOfFin_apply,
Finset.orderEmbOfFin_apply, Fin.getElem_fin] using heq
-/-- No earlier time visits the position of a minimal visit. -/
-private lemma not_visit_before {cfg : Cfg k Symbol State input} {T p t : ℕ}
- {u : tm.visitTimes cfg T p} (hu : IsMin u) (ht : t < u.val) :
- (tm.runFrom cfg t).inputPos.val ≠ p := by
- intro hp
- have hT := (tm.mem_visitTimes.mp u.property).1
- exact ht.not_ge (hu (b := ⟨t, tm.mem_visitTimes.mpr ⟨ht.le.trans hT, hp⟩⟩) ht.le)
-
-/-- The covering relation on visit times means that no visit occurs strictly between them. -/
-private lemma not_visit_between {cfg : Cfg k Symbol State input} {T p t : ℕ}
- {u v : tm.visitTimes cfg T p} (h : u ⋖ v) (hlo : u.val < t) (hhi : t < v.val) :
- (tm.runFrom cfg t).inputPos.val ≠ p := by
- intro hp
- have hT := (tm.mem_visitTimes.mp v.property).1
- exact h.2 (c := ⟨t, tm.mem_visitTimes.mpr ⟨hhi.le.trans hT, hp⟩⟩) hlo hhi
-
/-- Between consecutive visits, a first step to the left keeps the input head on the left. -/
-private lemma inputPos_le_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
+private lemma inputPos_mapsTo_Iic_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
{u v : tm.visitTimes cfg T p} (h : u ⋖ v)
(hdir : (tm.runFrom cfg (u.val + 1)).inputPos.val ≤ p) :
- ∀ t, u.val ≤ t → t ≤ v.val → (tm.runFrom cfg t).inputPos.val ≤ p := by
- intro t hut htv
+ MapsTo (fun t => (tm.runFrom cfg t).inputPos.val) (Icc u.val v.val) (Iic p) := by
+ have hT := (tm.mem_visitTimes.mp v.property).1
+ rintro t ⟨hut, htv⟩
rcases eq_or_lt_of_le hut with rfl | hut
· exact (tm.mem_visitTimes.mp u.property).2.le
- · exact tm.inputPos_le_of_forall_ne hut hdir fun r hur hrt =>
- not_visit_between h (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
+ · apply tm.inputPos_le_of_forall_ne hut hdir
+ intro r hur hrt hp
+ exact h.2 (c := ⟨r, tm.mem_visitTimes.mpr ⟨by omega, hp⟩⟩)
+ (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
/-- Between consecutive visits, a first step to the right keeps the input head on the right. -/
-private lemma le_inputPos_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
+private lemma inputPos_mapsTo_Ici_of_covBy {cfg : Cfg k Symbol State input} {T p : ℕ}
{u v : tm.visitTimes cfg T p} (h : u ⋖ v)
(hdir : p ≤ (tm.runFrom cfg (u.val + 1)).inputPos.val) :
- ∀ t, u.val ≤ t → t ≤ v.val → p ≤ (tm.runFrom cfg t).inputPos.val := by
- intro t hut htv
+ MapsTo (fun t => (tm.runFrom cfg t).inputPos.val) (Icc u.val v.val) (Ici p) := by
+ have hT := (tm.mem_visitTimes.mp v.property).1
+ rintro t ⟨hut, htv⟩
rcases eq_or_lt_of_le hut with rfl | hut
· exact (tm.mem_visitTimes.mp u.property).2.ge
- · exact tm.le_inputPos_of_forall_ne hut hdir fun r hur hrt =>
- not_visit_between h (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
+ · apply tm.le_inputPos_of_forall_ne hut hdir
+ intro r hur hrt hp
+ exact h.2 (c := ⟨r, tm.mem_visitTimes.mpr ⟨by omega, hp⟩⟩)
+ (Nat.lt_of_succ_le hur) (hrt.trans_le htv)
/-- An ordered pair of input-symbol indices. The cut deletes the symbols after the first
through the second; equal endpoints give an empty deletion.
@@ -274,38 +264,37 @@ lemma step {c : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened
rw [hm, hm']
exact (cut.position_moveInputPos h.1 m hside).symm
-/-- Simulate a run segment in which every step stays on a retained side of the cut. -/
-lemma reaches_runFrom (hsym : input[cut.fst] = input[cut.snd])
+/-- Simulate a segment in the retained prefix, without any assumption on the boundary symbols. -/
+lemma reaches_runFrom_left
{cfg : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened} {u v : ℕ}
(h : cut.Matches (tm.runFrom cfg u) c') (huv : u ≤ v)
- (hside : ∀ t, u ≤ t → t < v →
- cut.SameSide (tm.runFrom cfg t).inputPos.val (tm.runFrom cfg (t + 1)).inputPos.val) :
+ (hside : MapsTo (fun t => (tm.runFrom cfg t).inputPos.val) (Icc u v) (Iic cut.left)) :
∃ d, ReflTransGen tm.TransitionRelation c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
induction v, huv using Nat.le_induction with
| base => exact ⟨c', .refl, h⟩
| succ v huv ih =>
- obtain ⟨d, hd, hm⟩ := ih fun t hut htv => hside t hut (by omega)
+ obtain ⟨d, hd, hm⟩ := ih (hside.mono_left (Icc_subset_Icc_right (Nat.le_succ _)))
+ have hv := hside ⟨huv, Nat.le_succ _⟩
refine ⟨tm.step d, hd.tail rfl, ?_⟩
rw [runFrom_succ_eq_step']
- have hv := hside v huv (by omega)
- exact hm.step (hm.inputSymbol hsym (hv.imp And.left And.left))
- (by simpa only [runFrom_succ_eq_step'] using hv)
+ exact hm.step (hm.inputSymbol_left hv) (.inl ⟨hv, by
+ simpa only [mem_Iic, runFrom_succ_eq_step'] using hside ⟨by omega, le_rfl⟩⟩)
-/-- Simulate a segment in the retained prefix, without any assumption on the boundary symbols. -/
-lemma reaches_runFrom_left
+/-- Simulate a segment in the retained suffix when the boundary symbols agree. -/
+lemma reaches_runFrom_right (hsym : input[cut.fst] = input[cut.snd])
{cfg : Cfg k Symbol State input} {c' : Cfg k Symbol State cut.shortened} {u v : ℕ}
(h : cut.Matches (tm.runFrom cfg u) c') (huv : u ≤ v)
- (hside : ∀ t, u ≤ t → t ≤ v → (tm.runFrom cfg t).inputPos.val ≤ cut.left) :
+ (hside : MapsTo (fun t => (tm.runFrom cfg t).inputPos.val) (Icc u v) (Ici cut.right)) :
∃ d, ReflTransGen tm.TransitionRelation c' d ∧ cut.Matches (tm.runFrom cfg v) d := by
induction v, huv using Nat.le_induction with
| base => exact ⟨c', .refl, h⟩
| succ v huv ih =>
- obtain ⟨d, hd, hm⟩ := ih fun t hut htv => hside t hut (htv.trans (Nat.le_succ _))
- have hv := hside v huv (Nat.le_succ _)
+ obtain ⟨d, hd, hm⟩ := ih (hside.mono_left (Icc_subset_Icc_right (Nat.le_succ _)))
+ have hv := hside ⟨huv, Nat.le_succ _⟩
refine ⟨tm.step d, hd.tail rfl, ?_⟩
rw [runFrom_succ_eq_step']
- exact hm.step (hm.inputSymbol_left hv) (.inl ⟨hv, by
- simpa only [runFrom_succ_eq_step'] using hside (v + 1) (by omega) le_rfl⟩)
+ exact hm.step (hm.inputSymbol hsym (.inr hv)) (.inr ⟨hv, by
+ simpa only [mem_Ici, runFrom_succ_eq_step'] using hside ⟨by omega, le_rfl⟩⟩)
end Matches
@@ -332,12 +321,12 @@ private lemma exists_matches_first_visit {T : ℕ}
{u : tm.visitTimes (tm.initCfg input) T cut.left} (hu : IsMin u) :
∃ c', ReflTransGen tm.TransitionRelation (tm.initCfg cut.shortened) c' ∧
cut.Matches (tm.runFrom (tm.initCfg input) u) c' := by
- have hside (v) (hv : v ≤ u.val) :
- (tm.runFrom (tm.initCfg input) v).inputPos.val ≤ cut.left := by
- apply tm.inputPos_le_of_forall_ne (Nat.zero_le v) (by simp [left])
- exact fun r _ hrv => not_visit_before hu (hrv.trans_le hv)
- exact cut.matches_init.reaches_runFrom_left (cfg := tm.initCfg input) (u := 0)
- (Nat.zero_le _) fun v _ hv => hside v hv
+ apply cut.matches_init.reaches_runFrom_left (cfg := tm.initCfg input) (u := 0) (Nat.zero_le _)
+ have hT := (tm.mem_visitTimes.mp u.property).1
+ rintro v ⟨_, hv⟩
+ apply tm.inputPos_le_of_forall_ne (Nat.zero_le v) (by simp [left])
+ intro r _ hrv hp
+ exact hu.not_lt (b := ⟨r, tm.mem_visitTimes.mpr ⟨by omega, hp⟩⟩) (hrv.trans_le hv)
namespace VisitPairing
@@ -380,12 +369,10 @@ private lemma reaches_next_visit {u v : tm.visitTimes (tm.initCfg input) T cut.l
∃ d, ReflTransGen tm.TransitionRelation c' d ∧
cut.Matches (tm.runFrom (tm.initCfg input) v) d := by
rcases pairing.step_sides u with hleft | hright
- · exact h.reaches_runFrom_left huv.le (inputPos_le_of_covBy huv hleft)
+ · exact h.reaches_runFrom_left huv.le (inputPos_mapsTo_Iic_of_covBy huv hleft)
· have he := (apply_covBy_apply_iff pairing.orderIso).mpr huv
- have hside := le_inputPos_of_covBy he hright
- obtain ⟨d, hd, hm⟩ := ((pairing.matches_iff u).mp h).reaches_runFrom
- pairing.symbol_eq he.le fun r hlo hhi =>
- Or.inr ⟨hside r hlo hhi.le, hside (r + 1) (hlo.trans (Nat.le_succ _)) hhi⟩
+ obtain ⟨d, hd, hm⟩ := ((pairing.matches_iff u).mp h).reaches_runFrom_right
+ pairing.symbol_eq he.le (inputPos_mapsTo_Ici_of_covBy he hright)
exact ⟨d, hd, (pairing.matches_iff v).mpr hm⟩
/-- Induct over the paired visits, starting with the retained prefix. -/
From 271ea18333b8082d4145c56d10fb9b2b690c5983 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 02:04:23 +0300
Subject: [PATCH 21/25] feat: add exponential bounds
---
Cslib.lean | 1 +
.../Turing/MultiTape/ConfigBound.lean | 27 +++++++++++++
Cslib/Foundations/Analysis/Asymptotics.lean | 38 +++++++++++++++++++
3 files changed, 66 insertions(+)
create mode 100644 Cslib/Foundations/Analysis/Asymptotics.lean
diff --git a/Cslib.lean b/Cslib.lean
index 74355b55d..174a43f89 100644
--- a/Cslib.lean
+++ b/Cslib.lean
@@ -82,6 +82,7 @@ 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.Analysis.Asymptotics
public import Cslib.Foundations.Combinatorics.InfiniteGraphRamsey
public import Cslib.Foundations.Control.Monad.Free
public import Cslib.Foundations.Control.Monad.Free.Effects
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
index 700a1d23c..9e727eab1 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean
@@ -244,6 +244,33 @@ lemma storageBound_le_pow [Fintype Symbol] [Fintype State] :
∃ a c : ℕ, ∀ s : ℕ, storageBound Symbol State k s ≤ a * 2 ^ (c * s) :=
⟨_, _, storageBound_le_base_mul_pow⟩
+/-- A fixed multiple of `(storageBound + 1) ^ storageBound` grows at most doubly exponentially
+in the space. -/
+lemma storageBound_pow_le_pow_pow [Fintype Symbol] [Fintype State] (m : ℕ) :
+ ∃ a c : ℕ, ∀ s : ℕ,
+ m * (storageBound Symbol State k s + 1) ^ storageBound Symbol State k s
+ ≤ 2 ^ (2 ^ (a + c * s)) := by
+ obtain ⟨a, c, hbound⟩ := storageBound_le_pow (Symbol := Symbol) (State := State) (k := k)
+ refine ⟨m + 2 * a + 1, 2 * c, fun s => ?_⟩
+ let B := storageBound Symbol State k s
+ let E := m + 2 * a + 2 * c * s
+ have hB : B ≤ 2 ^ (a + c * s) := by
+ rw [pow_add]
+ exact (hbound s).trans (by gcongr; exact Nat.lt_two_pow_self.le)
+ have hsum : m + B * B ≤ 2 ^ (E + 1) := by
+ calc m + B * B
+ _ ≤ 2 ^ m + 2 ^ (a + c * s) * 2 ^ (a + c * s) := by
+ gcongr; exact Nat.lt_two_pow_self.le
+ _ = 2 ^ m + 2 ^ (2 * a + 2 * c * s) := by ring
+ _ ≤ 2 ^ E + 2 ^ E := by gcongr <;> omega
+ _ = 2 ^ (E + 1) := by ring
+ calc m * (B + 1) ^ B
+ _ ≤ 2 ^ m * (2 ^ B) ^ B := by
+ exact Nat.mul_le_mul Nat.lt_two_pow_self.le (Nat.pow_le_pow_left Nat.lt_two_pow_self B)
+ _ = 2 ^ (m + B * B) := by ring
+ _ ≤ 2 ^ (2 ^ (E + 1)) := by gcongr; omega
+ _ = _ := by dsimp [E]; ring
+
/-! ## The storage and the core of a configuration
Now we relate `Cfg` and `Storage` by giving the projection.
diff --git a/Cslib/Foundations/Analysis/Asymptotics.lean b/Cslib/Foundations/Analysis/Asymptotics.lean
new file mode 100644
index 000000000..12685d05e
--- /dev/null
+++ b/Cslib/Foundations/Analysis/Asymptotics.lean
@@ -0,0 +1,38 @@
+/-
+Copyright (c) 2026 Aviv Bar Natan. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Aviv Bar Natan
+-/
+
+module
+
+public import Cslib.Init
+public import Mathlib.Analysis.Asymptotics.AsymptoticEquivalent
+public import Mathlib.Analysis.SpecialFunctions.Log.Basic
+
+/-!
+# Asymptotic bounds for exponentials
+
+A natural exponent negligible compared with `log g` gives a power negligible compared with `g`.
+This can be applied repeatedly to bound iterated exponentials.
+-/
+
+@[expose] public section
+
+open Filter Asymptotics
+
+/-- If `f = o(log g)` and `g` tends to infinity, then `b ^ f = o(g)` for a fixed positive base. -/
+lemma Asymptotics.IsLittleO.natCast_const_pow {α : Type*} {l : Filter α}
+ {f : α → ℕ} {g : α → ℝ}
+ (h : (fun x => (f x : ℝ)) =o[l] (fun x => Real.log (g x)))
+ (hg : Tendsto g l atTop) {b : ℕ} (hb : 0 < b) :
+ (fun x => ((b ^ f x : ℕ) : ℝ)) =o[l] g := by
+ have hb' : (0 : ℝ) < b := by exact_mod_cast hb
+ have hexp : (fun x => Real.exp (Real.log b * (f x : ℝ))) =o[l]
+ (fun x => Real.exp (Real.log (g x))) := by
+ rw [Real.isLittleO_exp_comp_exp_comp]
+ exact (IsEquivalent.refl.sub_isLittleO (h.const_mul_left (Real.log b))).symm.tendsto_atTop
+ (Real.tendsto_log_atTop.comp hg)
+ exact hexp.congr'
+ (Eventually.of_forall fun x => by simp [mul_comm, Real.exp_nat_mul, Real.exp_log hb'])
+ ((hg.eventually_gt_atTop 0).mono fun x hx => Real.exp_log hx)
From 614dd00293434907f5b80a63e5a5140158821845 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 02:09:58 +0300
Subject: [PATCH 22/25] feat(MultiTapeTM): space-bounded decidability
---
.../Machines/Turing/MultiTape/Deterministic.lean | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index ad0bfc7f4..842a72cee 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -10,6 +10,7 @@ public import Mathlib.Algebra.Order.Group.Abs
public import Mathlib.Algebra.Order.Group.Int
public import Mathlib.Algebra.Order.BigOperators.Group.Finset
public import Mathlib.Basic.Sign.Defs
+public import Mathlib.Computability.Language
public import Cslib.Foundations.Data.RelatesInSteps
public import Cslib.Computability.Machines.Turing.MultiTape.Configuration
@@ -76,6 +77,7 @@ We define a number of structures and concepts related to multi-tape Turing machi
* `ComputableInTimeAndSpaceOfLength`: the specialization to bounds on encoded input length.
* `DecidableInTimeAndSpace`: a proof that a TM decides a language within a certain time
and space bound.
+* `DecidableInSpace`: a binary language is decidable within a bound on space by input length.
There are two ways to talk about the behaviour of a multi-tape Turing machine, and they are
proven to be equivalent.
@@ -357,6 +359,11 @@ def DecidableInTimeAndSpace {α : Type*} (L : Set α) (enc : α ↪ List Bool)
(t s : α → ℕ) : Prop :=
ComputableInTimeAndSpace (indicator L) enc ⟨fun b => [b], by intro a b h; simpa using h⟩ t s
+/-- A binary language is decidable using at most `s n` work-tape cells on inputs of length `n`,
+with no restriction on time. -/
+def DecidableInSpace (L : Language Bool) (s : ℕ → ℕ) : Prop :=
+ ∃ t, DecidableInTimeAndSpace L (Function.Embedding.refl _) t (s ∘ List.length)
+
/-- 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 =]
From 10eef2ed7cfaa2a1bd57b96f55de3249c5a1fdf4 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 02:17:03 +0300
Subject: [PATCH 23/25] refactor(MultiTapeTM): use the native alphabet for
space
---
.../Machines/Turing/MultiTape/Deterministic.lean | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 842a72cee..00fe577c1 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -77,7 +77,7 @@ We define a number of structures and concepts related to multi-tape Turing machi
* `ComputableInTimeAndSpaceOfLength`: the specialization to bounds on encoded input length.
* `DecidableInTimeAndSpace`: a proof that a TM decides a language within a certain time
and space bound.
-* `DecidableInSpace`: a binary language is decidable within a bound on space by input length.
+* `DecidableInSpace`: a language is decidable within a bound on space by input length.
There are two ways to talk about the behaviour of a multi-tape Turing machine, and they are
proven to be equivalent.
@@ -359,10 +359,15 @@ def DecidableInTimeAndSpace {α : Type*} (L : Set α) (enc : α ↪ List Bool)
(t s : α → ℕ) : Prop :=
ComputableInTimeAndSpace (indicator L) enc ⟨fun b => [b], by intro a b h; simpa using h⟩ t s
-/-- A binary language is decidable using at most `s n` work-tape cells on inputs of length `n`,
-with no restriction on time. -/
-def DecidableInSpace (L : Language Bool) (s : ℕ → ℕ) : Prop :=
- ∃ t, DecidableInTimeAndSpace L (Function.Embedding.refl _) t (s ∘ List.length)
+/-- A language over a finite alphabet is decidable using at most `s n` work-tape cells on inputs
+of length `n`. The last state before halting records the decision: `.inr true` accepts and
+`.inr false` rejects. -/
+def DecidableInSpace {Symbol : Type*} [Finite Symbol] (L : Language Symbol) (s : ℕ → ℕ) : Prop :=
+ ∃ (k : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol (State ⊕ Bool)),
+ ∀ input, ∃ t,
+ (tm.runFrom (tm.initCfg input) t).state = some (.inr (indicator L input)) ∧
+ (tm.runFrom (tm.initCfg input) (t + 1)).Halted ∧
+ tm.spaceUsed (tm.initCfg input) (t + 1) ≤ s input.length
/-- 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. -/
From 5a9a80259a8aabb55d0bbde25a591e8c4a772bf9 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 02:17:03 +0300
Subject: [PATCH 24/25] refactor(MultiTapeTM): shorten the pigeonhole proof
---
.../Turing/MultiTape/InputShortening.lean | 89 +++++++------------
1 file changed, 31 insertions(+), 58 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
index 29a646fd0..7e713cb39 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/InputShortening.lean
@@ -6,7 +6,7 @@ Authors: Aviv Bar Natan
module
public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound
-public import Mathlib.Combinatorics.Pigeonhole
+public import Mathlib.Data.Fintype.Pigeonhole
public import Mathlib.Data.Finset.Sort
public import Mathlib.Order.Cover
public import Mathlib.Order.Interval.Basic
@@ -489,9 +489,7 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
have hbound : S.encard ≤ B := tm.encard_storages_le hs
let : Fintype S := (Set.finite_of_encard_le_coe hbound).fintype
have hcard : Fintype.card S ≤ B := by
- have h := hbound
- rw [← Set.coe_fintypeCard] at h
- exact_mod_cast h
+ exact_mod_cast (Set.coe_fintypeCard (s := S)).le.trans hbound
let seq := tm.visitSequence (tm.initCfg input) T
let enc (p : ℕ) : List S := (seq p).attachWith (· ∈ S)
(fun _ h => tm.mem_range_of_mem_visitSequence h)
@@ -499,60 +497,35 @@ theorem exists_shorter_input_storage [Fintype Symbol] [Fintype State] {s : ℕ}
List.attachWith_map_subtype_val _
have hlength (p : ℕ) : (enc p).length ≤ B := by
simpa only [enc, List.length_attachWith] using tm.length_visitSequence_le hT hfirst hs p
- let f (i : Fin input.length) : Symbol × (Fin B → Option S) :=
- (input[i], fun j => (enc (i.val + 1))[j.val]?)
- have heq {i j : Fin input.length} (h : f i = f j) :
- input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1) := by
- refine ⟨congrArg Prod.fst h, ?_⟩
- have hh : enc (i.val + 1) = enc (j.val + 1) := by
- apply List.ext_getElem?
- intro r
- by_cases hr : r < B
- · exact congrFun (congrArg Prod.snd h) ⟨r, hr⟩
- · rw [List.getElem?_eq_none (by have := hlength (i.val + 1); omega),
- List.getElem?_eq_none (by have := hlength (j.val + 1); omega)]
- simpa only [henc] using congrArg (List.map Subtype.val) hh
- have hsig : Fintype.card (Symbol × (Fin B → Option S)) ≤
- Fintype.card Symbol * (B + 1) ^ B := by
- simp only [Fintype.card_prod, Fintype.card_fun, Fintype.card_fin, Fintype.card_option]
- gcongr
+ let p := (tm.runFrom (tm.initCfg input) t).inputPos.val
+ -- Matching positions on the same side of `p` give a cut that avoids `p`.
+ let f (i : Fin input.length) : Bool × Symbol × (Fin B → Option S) :=
+ (decide (i.val + 1 < p), input[i], fun j => (enc (i.val + 1))[j.val]?)
+ have hsig : Fintype.card (Bool × Symbol × (Fin B → Option S)) < input.length := by
+ calc
+ _ = 2 * Fintype.card Symbol * (Fintype.card S + 1) ^ B := by
+ simp [mul_assoc]
+ _ ≤ 2 * Fintype.card Symbol * (B + 1) ^ B := by gcongr; omega
+ _ < input.length := hlen
+ obtain ⟨i, j, hij, hf⟩ : ∃ i j, i < j ∧ f i = f j := by
+ obtain ⟨i, j, hne, hf⟩ := Fintype.exists_ne_map_eq_of_card_lt f (by simpa using hsig)
+ grind
+ obtain ⟨hside, hsym, hseq⟩ := (by simpa only [f, Prod.mk.injEq, decide_eq_decide] using hf)
+ have hseq' : enc (i.val + 1) = enc (j.val + 1) := by
+ apply List.ext_getElem?
+ intro r
+ by_cases hr : r < B
+ · exact congrFun hseq ⟨r, hr⟩
+ · rw [List.getElem?_eq_none (by have := hlength (i.val + 1); omega),
+ List.getElem?_eq_none (by have := hlength (j.val + 1); omega)]
+ let cut : InputCut input := ⟨⟨i, j⟩, hij.le⟩
+ refine ⟨cut.shortened, ?_, tm.exists_storage_cut cut hsym ?_ ht ?_⟩
+ · have := cut.length_shortened_add
+ change cut.shortened.length + (j.val + 1 - (i.val + 1)) = input.length at this
+ omega
+ · change seq (i.val + 1) = seq (j.val + 1)
+ simpa only [henc] using congrArg (List.map Subtype.val) hseq'
+ · change p ≤ i.val + 1 ∨ j.val + 1 ≤ p
omega
- obtain ⟨v, hv⟩ := Fintype.exists_lt_card_fiber_of_mul_lt_card f (n := 2) (by
- rw [Fintype.card_fin]
- change 2 * Fintype.card Symbol * (B + 1) ^ B < input.length at hlen
- calc Fintype.card (Symbol × (Fin B → Option S)) * 2
- _ ≤ (Fintype.card Symbol * (B + 1) ^ B) * 2 := Nat.mul_le_mul_right 2 hsig
- _ = 2 * Fintype.card Symbol * (B + 1) ^ B := by ring
- _ < input.length := hlen)
- let e := (Finset.univ.filter (fun i => f i = v)).orderEmbOfCardLe
- (show 3 ≤ (Finset.univ.filter (fun i => f i = v)).card by omega)
- have he (i : Fin 3) : f (e i) = v := by
- have hmem : e i ∈ Finset.univ.filter (fun i => f i = v) :=
- Finset.orderEmbOfCardLe_mem _ _ i
- exact (Finset.mem_filter.mp hmem).2
- have hab : (e 0).val + 1 < (e 1).val + 1 :=
- Nat.add_lt_add_right (e.strictMono (by decide)) 1
- have hbc : (e 1).val + 1 < (e 2).val + 1 :=
- Nat.add_lt_add_right (e.strictMono (by decide)) 1
- have hab' := heq ((he 0).trans (he 1).symm)
- have hbc' := heq ((he 1).trans (he 2).symm)
- have cut {i j : Fin input.length} (hij : i.val + 1 < j.val + 1)
- (hij' : input[i] = input[j] ∧ seq (i.val + 1) = seq (j.val + 1))
- (hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ i.val + 1 ∨
- j.val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val) :
- ∃ input' : List Symbol, input'.length < input.length ∧
- ∃ u, (tm.runFrom (tm.initCfg input') u).storage =
- (tm.runFrom (tm.initCfg input) t).storage := by
- refine ⟨input.take (i.val + 1) ++ input.drop (j.val + 1), ?_, ?_⟩
- · simp only [List.length_append, List.length_take, List.length_drop]
- have := i.isLt
- have := j.isLt
- omega
- · exact tm.exists_storage_cut ⟨⟨i, j⟩, by change i.val ≤ j.val; omega⟩
- hij'.1 hij'.2 ht hpos
- by_cases hpos : (tm.runFrom (tm.initCfg input) t).inputPos.val ≤ (e 0).val + 1 ∨
- (e 1).val + 1 ≤ (tm.runFrom (tm.initCfg input) t).inputPos.val
- · exact cut hab hab' hpos
- · exact cut hbc hbc' (Or.inl (by omega))
end Turing.MultiTapeTM
From 626903eb923cd853e27bf8c31a1202d20b871cc2 Mon Sep 17 00:00:00 2001
From: Aviv Bar Natan <46134216+barni120400@users.noreply.github.com>
Date: Sun, 13 Sep 2026 02:20:41 +0300
Subject: [PATCH 25/25] refactor(MultiTapeTM): require finiteness in the
theorem
---
.../Machines/Turing/MultiTape/Deterministic.lean | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
index 00fe577c1..b46b9e6f1 100644
--- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
+++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean
@@ -359,10 +359,10 @@ def DecidableInTimeAndSpace {α : Type*} (L : Set α) (enc : α ↪ List Bool)
(t s : α → ℕ) : Prop :=
ComputableInTimeAndSpace (indicator L) enc ⟨fun b => [b], by intro a b h; simpa using h⟩ t s
-/-- A language over a finite alphabet is decidable using at most `s n` work-tape cells on inputs
-of length `n`. The last state before halting records the decision: `.inr true` accepts and
+/-- A language is decidable using at most `s n` work-tape cells on inputs of length `n`.
+The last state before halting records the decision: `.inr true` accepts and
`.inr false` rejects. -/
-def DecidableInSpace {Symbol : Type*} [Finite Symbol] (L : Language Symbol) (s : ℕ → ℕ) : Prop :=
+def DecidableInSpace {Symbol : Type*} (L : Language Symbol) (s : ℕ → ℕ) : Prop :=
∃ (k : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol (State ⊕ Bool)),
∀ input, ∃ t,
(tm.runFrom (tm.initCfg input) t).state = some (.inr (indicator L input)) ∧