From 6ac633eb40003ff1b13176c7a502470d50aae3ea Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 10:21:46 +0000 Subject: [PATCH 01/93] feat(MultiTapeTM): machines as transformers of tape words MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The interface through which the combinators will use machines: a machine reads words from its work tapes and leaves words on them, never touching the output. Configurations are described by equalities. `listTape` (due to Samuel Schlesinger, #872 — kept name-identical so the copies dedupe when that lands) turns a word into the tape holding exactly it; `wordsCfg` is the configuration whose tapes hold given words, heads at the start; and the postcondition of `TransformsTapes` is a single configuration equality `runFrom … τ = wordsCfg input none ws' out`, which packages halting, word-holding tapes, the rewound input head and the untouched output in one rewritable equation. Specifications then compose by rewriting rather than by per-tape case analyses. `exists_transformsTapes_nop` — halt in one step, every word unchanged, one visited cell per tape — is the first machine through the interface and the check that the format is inhabited exactly as intended. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../MultiTape/Plumbing/TransformsTapes.lean | 160 ++++++++++++++++++ 2 files changed, 161 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean diff --git a/Cslib.lean b/Cslib.lean index 8cfe47e01..b0fa38398 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -58,6 +58,7 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas public import Cslib.Computability.Machines.Turing.SingleTape.Defs public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean new file mode 100644 index 000000000..2bb4c717f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Machines as transformers of tape words + +The interface through which combinators use machines: a machine reads words from its work tapes +and leaves words on them, and never touches the output. A combinator composing such machines talks +about words only — never about individual cells, head positions or the set of tapes a machine has +touched. + +Configurations are described by *equalities*: `wordsCfg input q ws out` is the configuration whose +work tape `i` holds exactly the word `ws i` — contents `listTape (ws i)`, head at the start — with +the input head at the start of the input and output `out`. A specification +`TransformsTapes tm P Q t s` says: started on word-holding tapes satisfying `P`, the machine halts +within `t` steps *in a configuration of the same shape* — work tapes again holding words, input +head back at the start, output untouched — with the new words related to the old ones by `Q`, and +using at most `s` work-tape cells. Because the postcondition is a single configuration equality, +specifications compose by rewriting: which tapes survived a step is read off the equation instead +of being proved cell by cell. + +The description of a tape's contents as a function, `listTape`, is due to Samuel Schlesinger +(leanprover/cslib#872). + +## Main definitions + +* `Turing.MultiTapeTM.listTape`: the tape holding exactly a given word. +* `Turing.MultiTapeTM.wordsCfg`: the configuration whose tapes hold given words. +* `Turing.MultiTapeTM.TransformsTapes`: the specification format described above. + +## Main results + +* `Turing.MultiTapeTM.TransformsTapes.imp`: strengthen the precondition, weaken the postcondition + and raise the bounds. +* `Turing.MultiTapeTM.exists_transformsTapes_nop`: the machine that does nothing, the first + machine of the interface and the check that the format is inhabited as intended. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- A tape containing exactly the symbols of `xs` at positions `0, ..., xs.length - 1`. -/ +@[expose] public def listTape (xs : List Symbol) : ℤ → Option Symbol + | .ofNat n => xs[n]? + | .negSucc _ => none + +@[simp] +public lemma listTape_ofNat (xs : List Symbol) (n : ℕ) : listTape xs n = xs[n]? := rfl + +@[simp] +public lemma listTape_negSucc (xs : List Symbol) (n : ℕ) : listTape xs (.negSucc n) = none := rfl + +/-- Appending one symbol writes precisely the cell after the existing word. -/ +public lemma listTape_append_single (xs : List Symbol) (x : Symbol) : + listTape (xs ++ [x]) = Function.update (listTape xs) (xs.length : ℤ) (some x) := by + funext z + cases z with + | negSucc n => simp [listTape] + | ofNat n => grind [listTape] + +/-- The blank tape holds the empty word. -/ +@[simp] +public lemma listTape_nil : listTape ([] : List Symbol) = fun _ => none := by + funext z + cases z <;> simp + +/-- The configuration whose work tape `i` holds exactly the word `ws i` with its head at the +start, whose input head is at the start of the input, in state `q` with output `out`. -/ +@[expose, simps] +public def wordsCfg (input : List Symbol) (q : Option State) + (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := + ⟨q, 1, fun i => listTape (ws i), fun _ => 0, out⟩ + +/-- The initial configuration is the word configuration with blank tapes and no output. -/ +public lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : + tm.initCfg input = wordsCfg input (some tm.q₀) (fun _ => []) [] := by + refine Cfg.ext rfl rfl ?_ rfl rfl + funext i + simp [Cfg.init, wordsCfg] + +/-- `TransformsTapes tm P Q t s`: started in its initial state on tapes holding words `ws` that +satisfy the precondition `P`, the machine halts after at most `t` steps in the configuration whose +tapes hold words `ws'` with `Q input ws ws'`, with the input head back at the start and the output +unchanged, having used at most `s` work-tape cells. + +The postcondition is a single configuration equality, so a machine satisfying it has re-normalised +everything: heads at the start, tapes blank outside their words, nothing written to the output. +The bounds are numbers; a specification whose bounds depend on the data is a *family* +`∀ j, TransformsTapes tm (P j) (Q j) (t j) (s j)` over one fixed machine. -/ +public def TransformsTapes (tm : MultiTapeTM k Symbol State) + (P : (input : List Symbol) → (Fin k → List Symbol) → Prop) + (Q : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop) + (t s : ℕ) : Prop := + ∀ (input : List Symbol) (ws : Fin k → List Symbol) (out : List Symbol), P input ws → + ∃ τ ≤ t, ∃ ws', + tm.runFrom (wordsCfg input (some tm.q₀) ws out) τ = wordsCfg input none ws' out ∧ + Q input ws ws' ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) τ ≤ s + +/-- A `TransformsTapes` statement can be read with a stronger precondition, a weaker postcondition +and larger bounds. -/ +public theorem TransformsTapes.imp {tm : MultiTapeTM k Symbol State} + {P P' : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q Q' : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t s t' s' : ℕ} (h : TransformsTapes tm P Q t s) + (hP : ∀ input ws, P' input ws → P input ws) + (hQ : ∀ input ws ws', P' input ws → Q input ws ws' → Q' input ws ws') + (ht : t ≤ t') (hs : s ≤ s') : + TransformsTapes tm P' Q' t' s' := by + intro input ws out hP' + obtain ⟨τ, hτ, ws', hrun, hQ', hspace⟩ := h input ws out (hP input ws hP') + exact ⟨τ, hτ.trans ht, ws', hrun, hQ input ws ws' hP' hQ', hspace.trans hs⟩ + +section Nop + +/-- The machine that does nothing: it halts on its first step, leaving the configuration +unchanged. -/ +private def nop (k : ℕ) (Symbol : Type*) : MultiTapeTM k Symbol Unit where + q₀ := () + tr _ _ _ := { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + +private lemma step_nop (ws : Fin k → List Symbol) (out : List Symbol) : + (nop k Symbol).step (wordsCfg input (some ()) ws out) = wordsCfg input none ws out := by + refine Cfg.ext rfl ?_ ?_ ?_ ?_ <;> + simp [step, nop, Action.apply, wordsCfg, SignType.cast] + +/-- **The machine that does nothing.** It halts in one step, leaving every word as it was. Its +heads never move, so it visits one cell per tape. This is the first machine of the interface: it +checks that the specification format is inhabited exactly as intended. -/ +public theorem exists_transformsTapes_nop (k : ℕ) (Symbol : Type*) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + TransformsTapes tm (fun _ _ => True) (fun _ ws ws' => ws' = ws) 1 k := by + refine ⟨Unit, inferInstance, nop k Symbol, fun input ws out _ => ?_⟩ + have hrun : (nop k Symbol).runFrom (wordsCfg input (some ()) ws out) 1 = + wordsCfg input none ws out := by + rw [runFrom_succ_eq_step', runFrom_zero, step_nop] + refine ⟨1, le_rfl, ws, hrun, rfl, ?_⟩ + -- the heads never move, so each tape's visited set is contained in the single cell `0` + have hsub : ∀ i, (nop k Symbol).visitedByTapeHead (wordsCfg input (some ()) ws out) 1 i + ⊆ {0} := by + intro i z hz + obtain ⟨t', ht', rfl⟩ := mem_visitedByTapeHead.mp hz + rcases (by omega : t' = 0 ∨ t' = 1) with rfl | rfl + · simp + · simp [hrun] + refine le_trans ?_ (le_of_eq (by simp : (∑ _i : Fin k, 1) = k)) + exact Finset.sum_le_sum fun i _ => + (Finset.card_le_card (hsub i)).trans_eq (Finset.card_singleton 0) + +end Nop + +end Turing.MultiTapeTM From e3c67fb6edd97217691dd5066f8fdf4114f04cae Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 10:40:38 +0000 Subject: [PATCH 02/93] feat(MultiTapeTM): a machine that clears a work tape Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../Turing/MultiTape/Plumbing/Clear.lean | 340 ++++++++++++++++++ 2 files changed, 341 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean diff --git a/Cslib.lean b/Cslib.lean index b0fa38398..ae802d302 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -58,6 +58,7 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas public import Cslib.Computability.Machines.Turing.SingleTape.Defs diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean new file mode 100644 index 000000000..a31ad5c90 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +import all Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# A machine that clears a work tape + +A two-state machine that erases the word on one designated work tape `i` and returns the head to +the start; every other tape is never written and its head never moves. In its first state the +machine scans right over the word until it reads the first blank, one cell past the word. In its +second state it sweeps back left, blanking every cell it reads. On the way down the cells to the +left of the head still hold their symbols, so the first blank read while sweeping is the cell at +position `-1`; the halting transition moves the head right, back to position `0`. + +On a word of length `L` the run takes `2 * L + 2` steps and visits the cells `-1, …, L` of tape +`i` and only the cell `0` of every other tape, so the machine runs in time `3 * (L + 1)` and space +`L + 1 + k`. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_clear`: the machine that replaces the word on tape + `i` by the empty word and leaves every other tape unchanged. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The clearing machine for tape `i`. In state `false` it scans right over the word on tape `i`; +on the first blank it turns around into state `true`. In state `true` it sweeps left, blanking +every cell it reads; on the first blank — the cell at position `-1` — it moves right and halts. +No other tape is ever written or moved, and the input head never moves. -/ +def clearTape (i : Fin k) : MultiTapeTM k Symbol Bool where + q₀ := false + tr q _ work := + match q, work i with + | false, some _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := some false } + | false, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some true } + | true, some _ => + { inputTape := 0, + workTapes := fun l => (if l = i then some none else none, if l = i then -1 else 0), + output := none, state := some true } + | true, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := none } + +namespace Clear + +variable {i : Fin k} {w : List Symbol} {ws : Fin k → List Symbol} {out : List Symbol} + {T : ℤ → Option Symbol} {p : ℤ} + +/-- A configuration of the clearing machine: state `q`, tape `i` holding `T` with its head at `p`, +every other tape `l` holding the word `ws l` with its head at `0`, the input head at the start and +output `out`. -/ +def cfg (input : List Symbol) (i : Fin k) (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ) + (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol Bool input := + ⟨q, 1, fun l => if l = i then T else listTape (ws l), fun l => if l = i then p else 0, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as the tape-`i` contents and head position +agree. -/ +lemma cfg_congr {q : Option Bool} {T T' : ℤ → Option Symbol} {p p' : ℤ} (hT : T = T') + (hp : p = p') : cfg input i q T p ws out = cfg input i q T' p' ws out := by + rw [hT, hp] + +/-- The head of tape `i` is at `p`. -/ +lemma cfg_workTapePos_self (q : Option Bool) : + (cfg input i q T p ws out).workTapePos i = p := by + simp [cfg] + +/-- The head of every other tape is at `0`. -/ +lemma cfg_workTapePos_ne {l : Fin k} (h : l ≠ i) (q : Option Bool) : + (cfg input i q T p ws out).workTapePos l = 0 := by + simp [cfg, h] + +/-- A word configuration is a `cfg` whose tape `i` holds the word `ws i`. -/ +lemma wordsCfg_eq_cfg (q : Option Bool) (hws : ws i = w) : + wordsCfg input q ws out = cfg input i q (listTape w) 0 ws out := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases eq_or_ne l i with rfl | h + · simp [wordsCfg, cfg, hws] + · simp [wordsCfg, cfg, h] + · funext l + simp [wordsCfg, cfg] + +/-- The halting `cfg` with a blank tape `i` is the word configuration in which the word on tape +`i` has been replaced by the empty word. -/ +lemma cfg_halt_eq_wordsCfg : + cfg input i none (fun _ => none) 0 ws out = + wordsCfg input none (Function.update ws i []) out := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases eq_or_ne l i with rfl | h + · simp [wordsCfg, cfg] + · simp [wordsCfg, cfg, h] + · funext l + simp [wordsCfg, cfg] + +/-- Scanning right in state `false`: over a symbol the head moves right and nothing is written. -/ +lemma step_scan {s : Symbol} (hT : T p = some s) : + (clearTape i).step (cfg input i (some false) T p ws out) = + cfg input i (some false) T (p + 1) ws out := by + have hsym : (cfg input i (some false) T p ws out).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Turning around: on the blank one cell past the word, state `false` moves left and enters +state `true`. -/ +lemma step_turn (hT : T p = none) : + (clearTape i).step (cfg input i (some false) T p ws out) = + cfg input i (some true) T (p - 1) ws out := by + have hsym : (cfg input i (some false) T p ws out).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Sweeping left in state `true`: over a symbol the cell is blanked and the head moves left. -/ +lemma step_sweep {s : Symbol} (hT : T p = some s) : + (clearTape i).step (cfg input i (some true) T p ws out) = + cfg input i (some true) (Function.update T p none) (p - 1) ws out := by + have hsym : (cfg input i (some true) T p ws out).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Halting: on the blank at position `-1`, state `true` moves right and halts. -/ +lemma step_halt (hT : T p = none) : + (clearTape i).step (cfg input i (some true) T p ws out) = + cfg input i none T (p + 1) ws out := by + have hsym : (cfg input i (some true) T p ws out).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Blanking the cell just past the end of a word shortens the word by one symbol. -/ +lemma update_listTape_eq_listTape_take (w : List Symbol) (p : ℕ) : + Function.update (listTape (w.take (p + 1))) (p : ℤ) none = listTape (w.take p) := by + funext z + rcases eq_or_ne z (p : ℤ) with rfl | hz + · rw [Function.update_self, listTape_ofNat] + exact (List.getElem?_eq_none (by simp)).symm + · rw [Function.update_of_ne hz] + cases z with + | negSucc n => simp + | ofNat n => + change (w.take (p + 1))[n]? = (w.take p)[n]? + have hn : n ≠ p := by rintro rfl; exact hz rfl + rcases Nat.lt_or_ge n p with h | h + · rw [List.getElem?_take_of_lt (by omega), List.getElem?_take_of_lt h] + · have h' : p < n := by omega + rw [List.getElem?_eq_none (by simp; omega), List.getElem?_eq_none (by simp; omega)] + +/-- After `n ≤ w.length` steps the machine is still scanning: the tape holds `w` untouched and +the head is at position `n`. -/ +lemma runFrom_scan (w : List Symbol) (n : ℕ) (hn : n ≤ w.length) : + (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) n = + cfg input i (some false) (listTape w) n ws out := by + induction n with + | zero => simp + | succ n ih => + have hsym : listTape w (n : ℤ) = some (w[n]'(by omega)) := by + rw [listTape_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_scan hsym] + exact cfg_congr rfl (by omega) + +/-- After `w.length + 1 + m` steps, for `m ≤ w.length`, the machine is sweeping: the last `m` +cells of the word have been blanked and the head is at position `w.length - 1 - m`. -/ +lemma runFrom_sweep (w : List Symbol) (m : ℕ) (hm : m ≤ w.length) : + (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) + (w.length + 1 + m) = + cfg input i (some true) (listTape (w.take (w.length - m))) + ((w.length : ℤ) - 1 - m) ws out := by + induction m with + | zero => + have hsym : listTape w ((w.length : ℕ) : ℤ) = none := by simp + rw [Nat.add_zero, runFrom_succ_eq_step', runFrom_scan w w.length le_rfl, step_turn hsym] + exact cfg_congr (by simp) (by omega) + | succ m ih => + have hidx : (w.length : ℤ) - 1 - m = ((w.length - 1 - m : ℕ) : ℤ) := by omega + have hsym : listTape (w.take (w.length - m)) ((w.length - 1 - m : ℕ) : ℤ) = + some (w[w.length - 1 - m]'(by omega)) := by + rw [listTape_ofNat, List.getElem?_take_of_lt (by omega)] + exact List.getElem?_eq_getElem (by omega) + rw [show w.length + 1 + (m + 1) = w.length + 1 + m + 1 from rfl, runFrom_succ_eq_step', + ih (by omega), hidx, step_sweep hsym] + refine cfg_congr ?_ (by omega) + rw [show w.length - m = (w.length - 1 - m) + 1 from by omega, + update_listTape_eq_listTape_take, + show w.length - 1 - m = w.length - (m + 1) from by omega] + +/-- The complete run: after `2 * w.length + 2` steps the machine has halted with tape `i` blank +and its head back at `0`. -/ +lemma runFrom_full (w : List Symbol) : + (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) + (2 * w.length + 2) = + cfg input i none (fun _ => none) 0 ws out := by + rw [show 2 * w.length + 2 = w.length + 1 + w.length + 1 from by omega, runFrom_succ_eq_step', + runFrom_sweep w w.length le_rfl, step_halt (by simp)] + exact cfg_congr (by simp) (by omega) + +/-- At every step of the run the configuration has the shape `cfg`, with the head of tape `i` +between the positions `-1` and `w.length`. -/ +lemma runFrom_shape (w : List Symbol) (t : ℕ) (ht : t ≤ 2 * w.length + 2) : + ∃ (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ), -1 ≤ p ∧ p ≤ w.length ∧ + (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) t = + cfg input i q T p ws out := by + by_cases h : t ≤ w.length + · exact ⟨some false, listTape w, t, by omega, by omega, runFrom_scan w t h⟩ + by_cases h2 : t ≤ 2 * w.length + 1 + · obtain ⟨m, hm, rfl⟩ : ∃ m, m ≤ w.length ∧ t = w.length + 1 + m := + ⟨t - (w.length + 1), by omega, by omega⟩ + exact ⟨some true, listTape (w.take (w.length - m)), (w.length : ℤ) - 1 - m, by omega, + by omega, runFrom_sweep w m hm⟩ + rw [show t = 2 * w.length + 2 from by omega] + exact ⟨none, fun _ => none, 0, by omega, by omega, runFrom_full w⟩ + +/-- The run visits the cells `-1, …, w.length` of tape `i` and only the cell `0` of every other +tape, so it uses at most `w.length + 1 + k` cells in total. -/ +lemma spaceUsed_le (w : List Symbol) : + (clearTape i).spaceUsed (cfg input i (some false) (listTape w) 0 ws out) + (2 * w.length + 2) ≤ w.length + 1 + k := by + set c₀ := cfg input i (some false) (listTape w) 0 ws out + set τ := 2 * w.length + 2 + have hi : (clearTape i).spaceUsedByTape c₀ τ i ≤ w.length + 2 := by + have hsub : (clearTape i).visitedByTapeHead c₀ τ i ⊆ + Finset.Icc (-1 : ℤ) (w.length : ℤ) := by + intro z hz + obtain ⟨t, ht, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q, T, p, hp₁, hp₂, heq⟩ := runFrom_shape w t (by omega) + rw [heq, cfg_workTapePos_self] + exact Finset.mem_Icc.mpr ⟨hp₁, hp₂⟩ + refine (Finset.card_le_card hsub).trans_eq ?_ + rw [Int.card_Icc] + omega + have hne : ∀ l, l ≠ i → (clearTape i).spaceUsedByTape c₀ τ l ≤ 1 := by + intro l hl + have hsub : (clearTape i).visitedByTapeHead c₀ τ l ⊆ {0} := by + intro z hz + obtain ⟨t, ht, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q, T, p, _, _, heq⟩ := runFrom_shape w t (by omega) + rw [heq, cfg_workTapePos_ne hl] + simp + exact (Finset.card_le_card hsub).trans_eq (Finset.card_singleton 0) + have hsplit : (clearTape i).spaceUsed c₀ τ = (clearTape i).spaceUsedByTape c₀ τ i + + ∑ l ∈ Finset.univ.erase i, (clearTape i).spaceUsedByTape c₀ τ l := + (Finset.add_sum_erase Finset.univ _ (Finset.mem_univ i)).symm + have hsum : ∑ l ∈ Finset.univ.erase i, (clearTape i).spaceUsedByTape c₀ τ l ≤ k - 1 := by + have := Finset.sum_le_card_nsmul (Finset.univ.erase i) + (fun l => (clearTape i).spaceUsedByTape c₀ τ l) 1 + (fun l hl => hne l (Finset.mem_erase.mp hl).1) + simpa [Finset.card_erase_of_mem] using this + have hk : 0 < k := i.pos + omega + +end Clear + +/-- **The machine that clears a work tape.** One machine per tape index `i` (uniform over the +words `w`): it replaces the word on tape `i` by the empty word and leaves every other tape +unchanged, in at most `3 * (w.length + 1)` steps and `w.length + 1 + k` cells. -/ +public theorem exists_transformsTapes_clear {Symbol : Type*} {k : ℕ} (i : Fin k) : + ∃ (c : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + ∀ w : List Symbol, + TransformsTapes tm (fun _ ws => ws i = w) + (fun _ ws ws' => ws' = Function.update ws i []) + (c * (w.length + 1)) (w.length + 1 + k) := by + refine ⟨3, Bool, inferInstance, clearTape i, fun w input ws out hws => ?_⟩ + have hstart : wordsCfg input (some (clearTape i : MultiTapeTM k Symbol Bool).q₀) ws out = + Clear.cfg input i (some false) (listTape w) 0 ws out := + Clear.wordsCfg_eq_cfg _ hws + refine ⟨2 * w.length + 2, by omega, Function.update ws i [], ?_, rfl, ?_⟩ + · rw [hstart, Clear.runFrom_full, Clear.cfg_halt_eq_wordsCfg] + · rw [hstart] + exact Clear.spaceUsed_le w + +end Turing.MultiTapeTM From 381156c778af8478bf702fb2ff8978e75d23b211 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 10:41:50 +0000 Subject: [PATCH 03/93] fix(MultiTapeTM): expose TransformsTapes Building the first real machine against the interface caught this: a `public def` without `@[expose]` cannot be unfolded by importing modules, so a `TransformsTapes` goal cannot even be `intro`d downstream, and Clear.lean needed a white-box `import all` as a workaround. The specification is exactly the kind of definition its consumers unfold, so it is exposed and the workaround dropped. Co-Authored-By: Claude Opus 5 (1M context) --- .../Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean | 1 - .../Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean index a31ad5c90..134e2c04e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean @@ -7,7 +7,6 @@ Authors: Christian Reitwiessner module public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes -import all Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes /-! # A machine that clears a work tape diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index 2bb4c717f..20a8e2d71 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -95,7 +95,7 @@ The postcondition is a single configuration equality, so a machine satisfying it everything: heads at the start, tapes blank outside their words, nothing written to the output. The bounds are numbers; a specification whose bounds depend on the data is a *family* `∀ j, TransformsTapes tm (P j) (Q j) (t j) (s j)` over one fixed machine. -/ -public def TransformsTapes (tm : MultiTapeTM k Symbol State) +@[expose] public def TransformsTapes (tm : MultiTapeTM k Symbol State) (P : (input : List Symbol) → (Fin k → List Symbol) → Prop) (Q : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop) (t s : ℕ) : Prop := From 745cd0e1ac9a00cf5a62c3967fe5d152bd945f9c Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 10:42:09 +0000 Subject: [PATCH 04/93] refactor(MultiTapeTM): rename listTape to tapeOfList Mathlib's naming convention for a constructor of an X from a Y. The name now differs from #872's `listTape`; the credit note says so. Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/Plumbing/Clear.lean | 44 +++++++++---------- .../MultiTape/Plumbing/TransformsTapes.lean | 26 +++++------ 2 files changed, 35 insertions(+), 35 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean index 134e2c04e..18be715b5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean @@ -64,7 +64,7 @@ every other tape `l` holding the word `ws l` with its head at `0`, the input hea output `out`. -/ def cfg (input : List Symbol) (i : Fin k) (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ) (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol Bool input := - ⟨q, 1, fun l => if l = i then T else listTape (ws l), fun l => if l = i then p else 0, out⟩ + ⟨q, 1, fun l => if l = i then T else tapeOfList (ws l), fun l => if l = i then p else 0, out⟩ /-- Configurations of the shape `cfg` are equal as soon as the tape-`i` contents and head position agree. -/ @@ -84,7 +84,7 @@ lemma cfg_workTapePos_ne {l : Fin k} (h : l ≠ i) (q : Option Bool) : /-- A word configuration is a `cfg` whose tape `i` holds the word `ws i`. -/ lemma wordsCfg_eq_cfg (q : Option Bool) (hws : ws i = w) : - wordsCfg input q ws out = cfg input i q (listTape w) 0 ws out := by + wordsCfg input q ws out = cfg input i q (tapeOfList w) 0 ws out := by refine Cfg.ext rfl rfl ?_ ?_ rfl · funext l rcases eq_or_ne l i with rfl | h @@ -196,11 +196,11 @@ lemma step_halt (hT : T p = none) : · simp /-- Blanking the cell just past the end of a word shortens the word by one symbol. -/ -lemma update_listTape_eq_listTape_take (w : List Symbol) (p : ℕ) : - Function.update (listTape (w.take (p + 1))) (p : ℤ) none = listTape (w.take p) := by +lemma update_tapeOfList_eq_tapeOfList_take (w : List Symbol) (p : ℕ) : + Function.update (tapeOfList (w.take (p + 1))) (p : ℤ) none = tapeOfList (w.take p) := by funext z rcases eq_or_ne z (p : ℤ) with rfl | hz - · rw [Function.update_self, listTape_ofNat] + · rw [Function.update_self, tapeOfList_ofNat] exact (List.getElem?_eq_none (by simp)).symm · rw [Function.update_of_ne hz] cases z with @@ -216,13 +216,13 @@ lemma update_listTape_eq_listTape_take (w : List Symbol) (p : ℕ) : /-- After `n ≤ w.length` steps the machine is still scanning: the tape holds `w` untouched and the head is at position `n`. -/ lemma runFrom_scan (w : List Symbol) (n : ℕ) (hn : n ≤ w.length) : - (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) n = - cfg input i (some false) (listTape w) n ws out := by + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) n = + cfg input i (some false) (tapeOfList w) n ws out := by induction n with | zero => simp | succ n ih => - have hsym : listTape w (n : ℤ) = some (w[n]'(by omega)) := by - rw [listTape_ofNat] + have hsym : tapeOfList w (n : ℤ) = some (w[n]'(by omega)) := by + rw [tapeOfList_ofNat] exact List.getElem?_eq_getElem (by omega) rw [runFrom_succ_eq_step', ih (by omega), step_scan hsym] exact cfg_congr rfl (by omega) @@ -230,32 +230,32 @@ lemma runFrom_scan (w : List Symbol) (n : ℕ) (hn : n ≤ w.length) : /-- After `w.length + 1 + m` steps, for `m ≤ w.length`, the machine is sweeping: the last `m` cells of the word have been blanked and the head is at position `w.length - 1 - m`. -/ lemma runFrom_sweep (w : List Symbol) (m : ℕ) (hm : m ≤ w.length) : - (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) (w.length + 1 + m) = - cfg input i (some true) (listTape (w.take (w.length - m))) + cfg input i (some true) (tapeOfList (w.take (w.length - m))) ((w.length : ℤ) - 1 - m) ws out := by induction m with | zero => - have hsym : listTape w ((w.length : ℕ) : ℤ) = none := by simp + have hsym : tapeOfList w ((w.length : ℕ) : ℤ) = none := by simp rw [Nat.add_zero, runFrom_succ_eq_step', runFrom_scan w w.length le_rfl, step_turn hsym] exact cfg_congr (by simp) (by omega) | succ m ih => have hidx : (w.length : ℤ) - 1 - m = ((w.length - 1 - m : ℕ) : ℤ) := by omega - have hsym : listTape (w.take (w.length - m)) ((w.length - 1 - m : ℕ) : ℤ) = + have hsym : tapeOfList (w.take (w.length - m)) ((w.length - 1 - m : ℕ) : ℤ) = some (w[w.length - 1 - m]'(by omega)) := by - rw [listTape_ofNat, List.getElem?_take_of_lt (by omega)] + rw [tapeOfList_ofNat, List.getElem?_take_of_lt (by omega)] exact List.getElem?_eq_getElem (by omega) rw [show w.length + 1 + (m + 1) = w.length + 1 + m + 1 from rfl, runFrom_succ_eq_step', ih (by omega), hidx, step_sweep hsym] refine cfg_congr ?_ (by omega) rw [show w.length - m = (w.length - 1 - m) + 1 from by omega, - update_listTape_eq_listTape_take, + update_tapeOfList_eq_tapeOfList_take, show w.length - 1 - m = w.length - (m + 1) from by omega] /-- The complete run: after `2 * w.length + 2` steps the machine has halted with tape `i` blank and its head back at `0`. -/ lemma runFrom_full (w : List Symbol) : - (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) (2 * w.length + 2) = cfg input i none (fun _ => none) 0 ws out := by rw [show 2 * w.length + 2 = w.length + 1 + w.length + 1 from by omega, runFrom_succ_eq_step', @@ -266,14 +266,14 @@ lemma runFrom_full (w : List Symbol) : between the positions `-1` and `w.length`. -/ lemma runFrom_shape (w : List Symbol) (t : ℕ) (ht : t ≤ 2 * w.length + 2) : ∃ (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ), -1 ≤ p ∧ p ≤ w.length ∧ - (clearTape i).runFrom (cfg input i (some false) (listTape w) 0 ws out) t = + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) t = cfg input i q T p ws out := by by_cases h : t ≤ w.length - · exact ⟨some false, listTape w, t, by omega, by omega, runFrom_scan w t h⟩ + · exact ⟨some false, tapeOfList w, t, by omega, by omega, runFrom_scan w t h⟩ by_cases h2 : t ≤ 2 * w.length + 1 · obtain ⟨m, hm, rfl⟩ : ∃ m, m ≤ w.length ∧ t = w.length + 1 + m := ⟨t - (w.length + 1), by omega, by omega⟩ - exact ⟨some true, listTape (w.take (w.length - m)), (w.length : ℤ) - 1 - m, by omega, + exact ⟨some true, tapeOfList (w.take (w.length - m)), (w.length : ℤ) - 1 - m, by omega, by omega, runFrom_sweep w m hm⟩ rw [show t = 2 * w.length + 2 from by omega] exact ⟨none, fun _ => none, 0, by omega, by omega, runFrom_full w⟩ @@ -281,9 +281,9 @@ lemma runFrom_shape (w : List Symbol) (t : ℕ) (ht : t ≤ 2 * w.length + 2) : /-- The run visits the cells `-1, …, w.length` of tape `i` and only the cell `0` of every other tape, so it uses at most `w.length + 1 + k` cells in total. -/ lemma spaceUsed_le (w : List Symbol) : - (clearTape i).spaceUsed (cfg input i (some false) (listTape w) 0 ws out) + (clearTape i).spaceUsed (cfg input i (some false) (tapeOfList w) 0 ws out) (2 * w.length + 2) ≤ w.length + 1 + k := by - set c₀ := cfg input i (some false) (listTape w) 0 ws out + set c₀ := cfg input i (some false) (tapeOfList w) 0 ws out set τ := 2 * w.length + 2 have hi : (clearTape i).spaceUsedByTape c₀ τ i ≤ w.length + 2 := by have hsub : (clearTape i).visitedByTapeHead c₀ τ i ⊆ @@ -329,7 +329,7 @@ public theorem exists_transformsTapes_clear {Symbol : Type*} {k : ℕ} (i : Fin (c * (w.length + 1)) (w.length + 1 + k) := by refine ⟨3, Bool, inferInstance, clearTape i, fun w input ws out hws => ?_⟩ have hstart : wordsCfg input (some (clearTape i : MultiTapeTM k Symbol Bool).q₀) ws out = - Clear.cfg input i (some false) (listTape w) 0 ws out := + Clear.cfg input i (some false) (tapeOfList w) 0 ws out := Clear.wordsCfg_eq_cfg _ hws refine ⟨2 * w.length + 2, by omega, Function.update ws i [], ?_, rfl, ?_⟩ · rw [hstart, Clear.runFrom_full, Clear.cfg_halt_eq_wordsCfg] diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index 20a8e2d71..96214c911 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -17,7 +17,7 @@ about words only — never about individual cells, head positions or the set of touched. Configurations are described by *equalities*: `wordsCfg input q ws out` is the configuration whose -work tape `i` holds exactly the word `ws i` — contents `listTape (ws i)`, head at the start — with +work tape `i` holds exactly the word `ws i` — contents `tapeOfList (ws i)`, head at the start — with the input head at the start of the input and output `out`. A specification `TransformsTapes tm P Q t s` says: started on word-holding tapes satisfying `P`, the machine halts within `t` steps *in a configuration of the same shape* — work tapes again holding words, input @@ -26,12 +26,12 @@ using at most `s` work-tape cells. Because the postcondition is a single configu specifications compose by rewriting: which tapes survived a step is read off the equation instead of being proved cell by cell. -The description of a tape's contents as a function, `listTape`, is due to Samuel Schlesinger -(leanprover/cslib#872). +The description of a tape's contents as a function, `tapeOfList`, is due to Samuel Schlesinger +(as `listTape` in leanprover/cslib#872). ## Main definitions -* `Turing.MultiTapeTM.listTape`: the tape holding exactly a given word. +* `Turing.MultiTapeTM.tapeOfList`: the tape holding exactly a given word. * `Turing.MultiTapeTM.wordsCfg`: the configuration whose tapes hold given words. * `Turing.MultiTapeTM.TransformsTapes`: the specification format described above. @@ -48,27 +48,27 @@ namespace Turing.MultiTapeTM variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} /-- A tape containing exactly the symbols of `xs` at positions `0, ..., xs.length - 1`. -/ -@[expose] public def listTape (xs : List Symbol) : ℤ → Option Symbol +@[expose] public def tapeOfList (xs : List Symbol) : ℤ → Option Symbol | .ofNat n => xs[n]? | .negSucc _ => none @[simp] -public lemma listTape_ofNat (xs : List Symbol) (n : ℕ) : listTape xs n = xs[n]? := rfl +public lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl @[simp] -public lemma listTape_negSucc (xs : List Symbol) (n : ℕ) : listTape xs (.negSucc n) = none := rfl +public lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : tapeOfList xs (.negSucc n) = none := rfl /-- Appending one symbol writes precisely the cell after the existing word. -/ -public lemma listTape_append_single (xs : List Symbol) (x : Symbol) : - listTape (xs ++ [x]) = Function.update (listTape xs) (xs.length : ℤ) (some x) := by +public lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : + tapeOfList (xs ++ [x]) = Function.update (tapeOfList xs) (xs.length : ℤ) (some x) := by funext z cases z with - | negSucc n => simp [listTape] - | ofNat n => grind [listTape] + | negSucc n => simp [tapeOfList] + | ofNat n => grind [tapeOfList] /-- The blank tape holds the empty word. -/ @[simp] -public lemma listTape_nil : listTape ([] : List Symbol) = fun _ => none := by +public lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := by funext z cases z <;> simp @@ -77,7 +77,7 @@ start, whose input head is at the start of the input, in state `q` with output ` @[expose, simps] public def wordsCfg (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := - ⟨q, 1, fun i => listTape (ws i), fun _ => 0, out⟩ + ⟨q, 1, fun i => tapeOfList (ws i), fun _ => 0, out⟩ /-- The initial configuration is the word configuration with blank tapes and no output. -/ public lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : From fa83806e16ecdbd0314f344ec7a05e038acf0814 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 10:49:52 +0000 Subject: [PATCH 05/93] feat(MultiTapeTM): sequential composition of tape transformations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `seq tm₀ tm₁` behaves like `tm₀` until it would halt and then continues as `tm₁`. The design is due to Samuel Schlesinger (#872): the state space is the sum, and the halting transition of the first phase is mapped to the initial state of the second, so the handoff costs no step. `transformsTapes_seq` composes two transformations with the bounds adding, and is where the interface's single-equality postcondition pays off: the first machine halts in a full `wordsCfg`, which is on the nose a starting configuration for the second. The proof splits the run at the first machine's minimal halting time (`exists_minimal_halting_time`, new in Deterministic.lean along with `runFrom_eq_of_halt`), mirrors phase one through the left embedding (a bounded induction — the embedding commutes with `step` only while the first machine is live), and phase two through the right embedding, which is a genuine step-semiconjugation, so its run lemma is one application of `runFrom_comm_of_step` from #878 (cherry-picked; this branch now builds on that PR). Space adds via `spaceUsed_add_le`/`spaceUsed_eq_of_workTapePos`, new in TapeLemmas.lean: space depends only on head positions, which both embeddings preserve. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../Turing/MultiTape/Deterministic.lean | 20 +++ .../Turing/MultiTape/Plumbing/Sequential.lean | 170 ++++++++++++++++++ .../MultiTape/Plumbing/TransformsTapes.lean | 3 +- .../Machines/Turing/MultiTape/TapeLemmas.lean | 37 ++++ 5 files changed, 230 insertions(+), 1 deletion(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean diff --git a/Cslib.lean b/Cslib.lean index ae802d302..17c986913 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -59,6 +59,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes 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..543b630f0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -267,6 +267,26 @@ lemma step_output (cfg : Cfg k Symbol State input) : unfold step outputSymbol Action.apply cases cfg.state <;> simp +/-- Nothing changes after the machine has halted. -/ +lemma runFrom_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 = tm.runFrom cfg τ := by + conv_lhs => rw [← Nat.sub_add_cancel hle, Nat.add_comm] + rw [runFrom_add, runFrom_of_halt _ hhalt] + +/-- Every halted run has a first halting time no later than the supplied one. -/ +lemma exists_minimal_halting_time + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) + (hhalt : (tm.runFrom cfg t).state = none) : + ∃ u ≤ t, (tm.runFrom cfg u).state = none ∧ ∀ s < u, (tm.runFrom cfg s).state ≠ none := by + classical + have hex : ∃ n, (tm.runFrom cfg n).state = none := ⟨t, hhalt⟩ + exact ⟨Nat.find hex, Nat.find_min' hex hhalt, Nat.find_spec hex, + fun s hs => Nat.find_min hex hs⟩ + /-- The output does not change after the machine has halted. -/ lemma runFrom_output_eq_of_halt (tm : MultiTapeTM k Symbol State) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean new file mode 100644 index 000000000..7f659b80d --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Sequential composition of machines on shared tapes + +`seq tm₀ tm₁` behaves like `tm₀` until `tm₀` would halt, at which point it continues as `tm₁`, +started in its initial state on the tapes as `tm₀` left them. The design is due to Samuel +Schlesinger (leanprover/cslib#872): the state space is `State₀ ⊕ State₁`, and the *halting +transition* of the first phase is mapped to the initial state of the second, so the handoff costs +no extra step. + +At the specification level this is `transformsTapes_seq`: transformations compose, with the time +and space bounds adding. The postcondition of `TransformsTapes` is what makes the proof direct — +the first machine halts in a full `wordsCfg`, which is exactly a starting configuration for the +second. + +## Main results + +* `Turing.MultiTapeTM.seq`: the composed machine. +* `Turing.MultiTapeTM.transformsTapes_seq`: transformations compose, bounds adding. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State₀ State₁ : Type*} {input : List Symbol} + +/-- The sequential composition of `tm₀` and `tm₁`: it behaves like `tm₀` until `tm₀` would halt, +at which point it switches to the initial state of `tm₁` and behaves like `tm₁`. The switch is +folded into the halting transition of `tm₀`, so it costs no step. -/ +@[expose] public def seq (tm₀ : MultiTapeTM k Symbol State₀) (tm₁ : MultiTapeTM k Symbol State₁) : + MultiTapeTM k Symbol (State₀ ⊕ State₁) where + q₀ := .inl tm₀.q₀ + tr q inp work := + match q with + | .inl q₀ => + let a := tm₀.tr q₀ inp work + { a with state := some (a.state.elim (.inr tm₁.q₀) .inl) } + | .inr q₁ => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map .inr } + +variable {tm₀ : MultiTapeTM k Symbol State₀} {tm₁ : MultiTapeTM k Symbol State₁} + +namespace Sequential + +/-- A configuration of the first phase: a configuration of `tm₀`, with a halted state mapped to +the initial state of the second phase. Under this map, the whole first phase of `seq` mirrors the +run of `tm₀`, *including* its halting step. -/ +def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := + ⟨some (cfg.state.elim (.inr tm₁.q₀) .inl), cfg.inputPos, cfg.workTapes, cfg.workTapePos, + cfg.output⟩ + +/-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the +run of `tm₁`. -/ +def rightCfg (cfg : Cfg k Symbol State₁ input) : Cfg k Symbol (State₀ ⊕ State₁) input := + ⟨cfg.state.map .inr, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + +lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : + (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h + have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by + simp [leftCfg, hq] + simp only [step, h1, hq] + rfl + +lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : + (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + have h1 : (rightCfg (State₀ := State₀) cfg).state = none := by simp [rightCfg, hq] + simp only [step, h1, hq] + | some q => + have h1 : (rightCfg (State₀ := State₀) cfg).state = some (Sum.inr q : State₀ ⊕ State₁) := by + simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +/-- The second phase of `seq` mirrors the run of `tm₁`. -/ +lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : + (tm₀.seq tm₁).runFrom (rightCfg cfg) n = rightCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-- While `tm₀` is running, `seq` mirrors it. -/ +lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) + (h : ∀ m < n, (tm₀.runFrom cfg m).state ≠ none) : + (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) n = leftCfg tm₁ (tm₀.runFrom cfg n) := by + induction n with + | zero => rfl + | succ n ih => + rw [runFrom_succ_eq_step', runFrom_succ_eq_step', ih fun m hm => h m (by omega), + step_leftCfg _ (h n (by omega))] + +@[simp] +lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : + leftCfg tm₁ (wordsCfg input (some q) ws out) = + wordsCfg input (some (Sum.inl q : State₀ ⊕ State₁)) ws out := rfl + +@[simp] +lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : + rightCfg (State₀ := State₀) (wordsCfg input q ws out) = + wordsCfg input (q.map Sum.inr) ws out := rfl + +@[simp] +lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : + (leftCfg tm₁ cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : + (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl + +end Sequential + +open Sequential in +/-- **Sequential composition of transformations.** If the postcondition of the first +transformation implies the precondition of the second, the composed machine performs the two +transformations one after the other, with the time and space bounds adding. -/ +public theorem transformsTapes_seq + {P₀ P₁ : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q₀ Q₁ : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t₀ s₀ t₁ s₁ : ℕ} + (h₀ : TransformsTapes tm₀ P₀ Q₀ t₀ s₀) (h₁ : TransformsTapes tm₁ P₁ Q₁ t₁ s₁) + (hmid : ∀ input ws ws', P₀ input ws → Q₀ input ws ws' → P₁ input ws') : + TransformsTapes (tm₀.seq tm₁) P₀ + (fun input ws ws'' => ∃ ws', Q₀ input ws ws' ∧ Q₁ input ws' ws'') + (t₀ + t₁) (s₀ + s₁) := by + intro input ws out hP₀ + obtain ⟨τ₀, hτ₀, ws', hrun₀, hQ₀, hspace₀⟩ := h₀ input ws out hP₀ + obtain ⟨τ₁, hτ₁, ws'', hrun₁, hQ₁, hspace₁⟩ := h₁ input ws' out (hmid input ws ws' hP₀ hQ₀) + -- the first halting time of the first machine + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm₀ + (wordsCfg input (some tm₀.q₀) ws out) τ₀ (by simp [hrun₀]) + have hu_run : tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) u = + wordsCfg input none ws' out := by + rw [← runFrom_eq_of_halt tm₀ _ hu huhalt, hrun₀] + -- the first phase mirrors the first machine, ending in the handoff configuration + have hleft : ∀ m ≤ u, (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) m + = leftCfg tm₁ (tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) m) := by + intro m hm + have : wordsCfg (State := State₀ ⊕ State₁) input (some (tm₀.seq tm₁).q₀) ws out = + leftCfg tm₁ (wordsCfg input (some tm₀.q₀) ws out) := rfl + rw [this, runFrom_leftCfg _ m fun r hr => + huactive r (by omega)] + -- the handoff configuration is the second machine's start, seen through the right embedding + have hhandoff : leftCfg tm₁ (tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) u) = + rightCfg (wordsCfg input (some tm₁.q₀) ws' out) := by + rw [hu_run] + rfl + refine ⟨u + τ₁, by omega, ws'', ?_, ⟨ws', hQ₀, hQ₁⟩, ?_⟩ + · rw [runFrom_add, hleft u le_rfl, hhandoff, runFrom_rightCfg, hrun₁] + rfl + · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · -- the first phase visits what the first machine visits + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u fun m hm => ?_)) + (le_trans (spaceUsed_mono tm₀ _ hu) hspace₀) + rw [hleft m hm, workTapePos_leftCfg] + · -- the second phase visits what the second machine visits + rw [hleft u le_rfl, hhandoff] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ τ₁ fun m hm => ?_)) hspace₁ + rw [runFrom_rightCfg, workTapePos_rightCfg] + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index 96214c911..ae5a3236c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -56,7 +56,8 @@ variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} public lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl @[simp] -public lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : tapeOfList xs (.negSucc n) = none := rfl +public lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : + tapeOfList xs (.negSucc n) = none := rfl /-- Appending one symbol writes precisely the cell after the existing word. -/ public lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index b6a2574d3..fc87f31af 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -148,4 +148,41 @@ lemma spaceUsed_mono (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State intro t t' h exact Finset.sum_le_sum (fun i _ => spaceUsedByTape_mono tm cfg i h) + +/-- The cells a run visits are the ones visited by its two halves. -/ +lemma visitedByTapeHead_add (cfg : Cfg k Symbol State input) (a b : ℕ) (i : Fin k) : + tm.visitedByTapeHead cfg (a + b) i = + tm.visitedByTapeHead cfg a i ∪ tm.visitedByTapeHead (tm.runFrom cfg a) b i := by + ext z + simp only [mem_visitedByTapeHead, Finset.mem_union] + constructor + · rintro ⟨r, hr, rfl⟩ + rcases Nat.lt_or_ge r (a + 1) with h | h + · exact Or.inl ⟨r, h, rfl⟩ + · exact Or.inr ⟨r - a, by omega, + by rw [← runFrom_add, show a + (r - a) = r from by omega]⟩ + · rintro (⟨r, hr, rfl⟩ | ⟨r, hr, rfl⟩) + · exact ⟨r, by omega, rfl⟩ + · exact ⟨a + r, by omega, by rw [runFrom_add]⟩ + +/-- Splitting a run into two phases can only overcount the cells it visits, since the two phases +may revisit each other's cells. -/ +lemma spaceUsed_add_le (cfg : Cfg k Symbol State input) (a b : ℕ) : + tm.spaceUsed cfg (a + b) ≤ tm.spaceUsed cfg a + tm.spaceUsed (tm.runFrom cfg a) b := by + rw [spaceUsed, spaceUsed, spaceUsed, ← Finset.sum_add_distrib] + refine Finset.sum_le_sum fun i _ => ?_ + rw [spaceUsedByTape, visitedByTapeHead_add] + exact Finset.card_union_le _ _ + +/-- Space usage only depends on where the work-tape heads are at each step, so two runs whose head +positions agree use the same space. This is what lets a machine be replaced by a simulation of +it. -/ +lemma spaceUsed_eq_of_workTapePos {State' : Type*} {input' : List Symbol} + {tm' : MultiTapeTM k Symbol State'} (cfg : Cfg k Symbol State input) + (cfg' : Cfg k Symbol State' input') (t : ℕ) + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos = (tm'.runFrom cfg' m).workTapePos) : + tm.spaceUsed cfg t = tm'.spaceUsed cfg' t := by + refine Finset.sum_congr rfl fun i _ => congrArg Finset.card (Finset.image_congr fun m hm => ?_) + exact congrFun (h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm))) i + end Turing.MultiTapeTM From 5ccdd95dec0b1be2c56fc3a472cdb6858cc89fa6 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 11:58:09 +0000 Subject: [PATCH 06/93] feat(MultiTapeTM): the tidy normal form, and the raw sequential layer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `TidyComputes`: the machine computes its function and halts in the fully normalised configuration — which is exactly a `wordsCfg`, unifying initial configurations, tidy halting configurations and the endpoints of `TransformsTapes` in one description. Tidiness is what the word-transformer interface needs of a machine before it can be run on redirected tapes: a tidy machine ends where the next one can begin. Groundwork for the normal-form construction, whose phases pass through dirty configurations and therefore chain below the `TransformsTapes` level: `Cfg.withState`, and the raw face of sequential composition — `Sequential.leftCfg`/`rightCfg` with their step and run lemmas made public, plus `Sequential.runFrom_seq`, the run of a composite split at the first machine's first halting time. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../Turing/MultiTape/NormalForms/Tidy.lean | 59 +++++++++++++++++++ .../Turing/MultiTape/Plumbing/Sequential.lean | 36 +++++++---- .../MultiTape/Plumbing/TransformsTapes.lean | 5 ++ 4 files changed, 91 insertions(+), 10 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean diff --git a/Cslib.lean b/Cslib.lean index 17c986913..8e135dd6c 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -58,6 +58,7 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean new file mode 100644 index 000000000..7e71ff1c0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# The tidy normal form + +A machine given by `ComputesFunInTimeAndSpace` promises nothing about the configuration it halts +in: its work tapes hold garbage — possibly with blanks embedded, so that no scan can find its +extent — and its heads are wherever the run left them. A *tidy* machine halts in the fully +normalised configuration: work tapes blank, all heads back at the start, the input head rewound — +which is exactly a `Turing.MultiTapeTM.wordsCfg`. Tidiness is what the word-transformer interface +(`Turing.MultiTapeTM.TransformsTapes`) needs of a machine before it can be run on redirected +tapes: a tidy machine ends where the next one can begin. + +The normal-form theorem — every computable function has a tidy machine, at a constant-factor cost +in time and space — is the deep result of this directory. Its construction instruments the given +machine with one *footprint* tape per work tape, marking every visited cell in lockstep (the +footprint is contiguous because a head path is connected, restoring the scannability that garbage +lacks) with a distinguished anchor mark at cell `0`, and afterwards sweeps each pair clean, +outside-in towards the anchor. + +## Main definitions + +* `Turing.MultiTapeTM.TidyComputes`: the machine computes the function and halts tidily. +-/ + +namespace Turing.MultiTapeTM + +variable {α β : Type*} {k : ℕ} {Symbol State : Type*} + +/-- The machine computes `f` between the given encodings within the given bounds, and halts in the +fully normalised configuration: work tapes blank with heads at the start, input head rewound, the +encoded result as the output. -/ +@[expose] public def TidyComputes (tm : MultiTapeTM k Symbol State) + (encIn : α ↪ List Symbol) (encOut : β ↪ List Symbol) + (f : α → β) (t s : α → ℕ) : Prop := + ∀ a, ∃ τ ≤ t a, + tm.runFrom (tm.initCfg (encIn a)) τ = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + tm.spaceUsed (tm.initCfg (encIn a)) τ ≤ s a + +/-- A tidy machine computes its function in the ordinary sense: tidiness only adds constraints on +the halting configuration. -/ +public theorem TidyComputes.computesFunInTimeAndSpace + {tm : MultiTapeTM k Symbol State} {encIn : α ↪ List Symbol} {encOut : β ↪ List Symbol} + {f : α → β} {t s : α → ℕ} (h : TidyComputes tm encIn encOut f t s) : + ComputesFunInTimeAndSpace tm encIn encOut f t s := by + intro a + obtain ⟨τ, hτ, hrun, hspace⟩ := h a + exact ⟨τ, hτ, _, hspace, by rw [hrun]; rfl, by rw [hrun]; rfl, rfl⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean index 7f659b80d..fb326316b 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -54,17 +54,18 @@ namespace Sequential /-- A configuration of the first phase: a configuration of `tm₀`, with a halted state mapped to the initial state of the second phase. Under this map, the whole first phase of `seq` mirrors the run of `tm₀`, *including* its halting step. -/ -def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : +@[expose] public def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : Cfg k Symbol (State₀ ⊕ State₁) input := ⟨some (cfg.state.elim (.inr tm₁.q₀) .inl), cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ /-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the run of `tm₁`. -/ -def rightCfg (cfg : Cfg k Symbol State₁ input) : Cfg k Symbol (State₀ ⊕ State₁) input := +@[expose] public def rightCfg (cfg : Cfg k Symbol State₁ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := ⟨cfg.state.map .inr, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ -lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : +public lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by @@ -72,7 +73,7 @@ lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) simp only [step, h1, hq] rfl -lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : +public lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by cases hq : cfg.state with | none => @@ -85,12 +86,12 @@ lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : rfl /-- The second phase of `seq` mirrors the run of `tm₁`. -/ -lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : +public lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : (tm₀.seq tm₁).runFrom (rightCfg cfg) n = rightCfg (tm₁.runFrom cfg n) := runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n /-- While `tm₀` is running, `seq` mirrors it. -/ -lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) +public lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) (h : ∀ m < n, (tm₀.runFrom cfg m).state ≠ none) : (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) n = leftCfg tm₁ (tm₀.runFrom cfg n) := by induction n with @@ -100,23 +101,38 @@ lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) step_leftCfg _ (h n (by omega))] @[simp] -lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : +public lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : leftCfg tm₁ (wordsCfg input (some q) ws out) = wordsCfg input (some (Sum.inl q : State₀ ⊕ State₁)) ws out := rfl @[simp] -lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : +public lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : rightCfg (State₀ := State₀) (wordsCfg input q ws out) = wordsCfg input (q.map Sum.inr) ws out := rfl @[simp] -lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : +public lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : (leftCfg tm₁ cfg).workTapePos = cfg.workTapePos := rfl @[simp] -lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : +public lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl +/-- **The run of `seq`, raw form.** Once the first machine has halted (at its first halting +time), the composite continues as the second machine from the handoff configuration. This is the +form used to chain phases whose intermediate configurations are not normalised; the +`TransformsTapes`-level composition is `transformsTapes_seq`. -/ +public lemma runFrom_seq (cfg : Cfg k Symbol State₀ input) (u v : ℕ) + (hhalt : (tm₀.runFrom cfg u).state = none) + (hactive : ∀ m < u, (tm₀.runFrom cfg m).state ≠ none) : + (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) (u + v) = + rightCfg (tm₁.runFrom ((tm₀.runFrom cfg u).withState (some tm₁.q₀)) v) := by + rw [runFrom_add, runFrom_leftCfg _ u hactive] + have h : leftCfg tm₁ (tm₀.runFrom cfg u) = + rightCfg ((tm₀.runFrom cfg u).withState (some tm₁.q₀)) := by + simp [leftCfg, rightCfg, Cfg.withState, hhalt] + rw [h, runFrom_rightCfg] + end Sequential open Sequential in diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index ae5a3236c..0f6d6cb6e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -73,6 +73,11 @@ public lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := b funext z cases z <;> simp +/-- The same configuration in a different control state, possibly of a different state type. -/ +@[expose, simps] public def _root_.Turing.Cfg.withState (cfg : Cfg k Symbol State input) + {State' : Type*} (q : Option State') : Cfg k Symbol State' input := + ⟨q, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + /-- The configuration whose work tape `i` holds exactly the word `ws i` with its head at the start, whose input head is at the start of the input, in state `q` with output `out`. -/ @[expose, simps] From ba825ac6409b631a8e9d38f3633b86eec1076edf Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 12:41:49 +0000 Subject: [PATCH 07/93] feat(MultiTapeTM): a machine that rewinds the input head Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../MultiTape/Plumbing/RewindInput.lean | 312 ++++++++++++++++++ 2 files changed, 313 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean diff --git a/Cslib.lean b/Cslib.lean index 8e135dd6c..d43b6dd36 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -60,6 +60,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNonde public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean new file mode 100644 index 000000000..22b8fe561 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean @@ -0,0 +1,312 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# A machine that rewinds the input head + +A three-state machine that returns the input head to position `1` — the first input symbol — from +an arbitrary starting configuration and halts there. It never writes to a work tape, never moves a +work-tape head and never outputs, so a combinator can run it between two phases of a computation +to re-normalise the input head without disturbing anything else. + +In its initial state `probe` the machine reads the cell under the input head. A symbol means the +head is inside the input (positions `1, …, input.length`) and the machine starts walking left. A +blank means the head is at one of the two boundary positions `0` and `input.length + 1`, and one +more probe a cell to the left disambiguates: in state `probe2`, a symbol identifies the right +boundary of a nonempty input and the machine walks left, while a blank means the head started at +the left boundary or the input is empty, so moving right lands on position `1` and the machine +halts. In state `walk` the machine moves left over symbols; the first blank is the cell at +position `0`, and the halting transition moves right, onto position `1`. + +From any starting position the run halts within `input.length + 2` steps. + +## Main results + +* `Turing.MultiTapeTM.exists_rewindInput`: the machine that rewinds the input head. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The control states of the rewinding machine: `probe` reads the starting cell, `probe2` reads +the cell to its left when the first read was blank, and `walk` moves left towards the input +boundary. -/ +inductive RewindState : Type + | probe + | probe2 + | walk + +instance : Finite RewindState := + Finite.of_injective + (fun q => match q with + | .probe => (0 : Fin 3) + | .probe2 => 1 + | .walk => 2) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The rewinding machine. Reading a symbol, every state turns to `walk` and moves the input head +left; reading a blank, `probe` moves left into `probe2` while `probe2` and `walk` move right and +halt. No work tape is ever written or moved and nothing is output. -/ +def rewindInput (k : ℕ) (Symbol : Type*) : MultiTapeTM k Symbol RewindState where + q₀ := .probe + tr q inp _ := + match q, inp with + | .probe, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .probe, none => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .probe2 } + | .probe2, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .probe2, none => + { inputTape := .pos, workTapes := fun _ => (none, 0), output := none, + state := none } + | .walk, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .walk, none => + { inputTape := .pos, workTapes := fun _ => (none, 0), output := none, + state := none } + +namespace Rewind + +variable {w : Fin k → ℤ → Option Symbol} {wp : Fin k → ℤ} {out : List Symbol} + {p : Fin (input.length + 2)} + +/-- The value of the input position after a left move: truncated subtraction in `ℕ` captures the +clamping at the left boundary. -/ +lemma val_moveInputPos_neg {n : ℕ} (p : Fin (n + 2)) : + (moveInputPos p .neg).val = p.val - 1 := by + rcases eq_or_ne p 0 with rfl | h + · simp + · rw [moveInputPos_neg_of_ne_left p h] + +/-- The value of the input position after a right move away from the right boundary. -/ +lemma val_moveInputPos_pos {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n + 1) : + (moveInputPos p .pos).val = p.val + 1 := by + rw [moveInputPos_pos_of_ne_right p h] + +/-- Configurations that differ only in provably equal input positions are equal. -/ +lemma cfg_congr {q : Option RewindState} {p p' : Fin (input.length + 2)} (h : p.val = p'.val) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input) = ⟨q, p', w, wp, out⟩ := by + rw [Fin.ext h] + +/-- The symbol read with the input head inside the input. -/ +lemma inputSymbol_mk_eq_some {q : Option RewindState} (h1 : p.val ≠ 0) + (h2 : p.val ≠ input.length + 1) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = + some (input[p.val - 1]'(by have := p.isLt; omega)) := + inputSymbolInner (p.val - 1) (show p.val = 1 + (p.val - 1) by omega) + (by have := p.isLt; omega) + +/-- The blank read at the left boundary. -/ +lemma inputSymbol_mk_eq_none_left {q : Option RewindState} (h : p = 0) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none := by + subst h + simp [Cfg.inputSymbol] + +/-- The blank read at the right boundary. -/ +lemma inputSymbol_mk_eq_none_right {q : Option RewindState} (h : p.val = input.length + 1) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none := by + grind [Cfg.inputSymbol] + +/-- No action of the rewinding machine writes to a work tape or moves a work head. -/ +lemma tr_workTapes (q : RewindState) (inp : Option Symbol) (work : Fin k → Option Symbol) + (i : Fin k) : ((rewindInput k Symbol).tr q inp work).workTapes i = (none, 0) := by + cases q <;> cases inp <;> rfl + +/-- The rewinding machine never outputs. -/ +lemma tr_output (q : RewindState) (inp : Option Symbol) (work : Fin k → Option Symbol) : + ((rewindInput k Symbol).tr q inp work).output = none := by + cases q <;> cases inp <;> rfl + +/-- Applying an action that writes nothing, moves no work head and outputs nothing changes only +the state and the input position. -/ +lemma apply_action (a : Action k Symbol RewindState) + (ha1 : ∀ i, a.workTapes i = (none, 0)) (ha2 : a.output = none) + (c : Cfg k Symbol RewindState input) : + a.apply c = + ⟨a.state, moveInputPos c.inputPos a.inputTape, c.workTapes, c.workTapePos, c.output⟩ := by + refine Cfg.ext rfl rfl (funext fun i => ?_) (funext fun i => ?_) ?_ <;> + simp [ha1, ha2, SignType.cast] + +/-- One step from a live state applies the transition to the symbols read. -/ +lemma step_mk (q : RewindState) : + (rewindInput k Symbol).step ⟨some q, p, w, wp, out⟩ = + ((rewindInput k Symbol).tr q + (Cfg.inputSymbol ⟨some q, p, w, wp, out⟩) + (Cfg.workTapeSymbols ⟨some q, p, w, wp, out⟩)).apply + ⟨some q, p, w, wp, out⟩ := rfl + +/-- Reading a symbol, every state turns to `walk` and moves the input head left. -/ +lemma step_read (q : RewindState) {s : Symbol} + (hs : (⟨some q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = some s) : + (rewindInput k Symbol).step ⟨some q, p, w, wp, out⟩ = + ⟨some .walk, moveInputPos p .neg, w, wp, out⟩ := by + rw [step_mk, hs] + cases q <;> exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `probe`, the machine moves left and probes again. -/ +lemma step_probe_none + (hs : (⟨some .probe, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .probe, p, w, wp, out⟩ = + ⟨some .probe2, moveInputPos p .neg, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `probe2`, the head started at the left boundary or the input is empty: +the machine moves right, onto position `1`, and halts. -/ +lemma step_probe2_none + (hs : (⟨some .probe2, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .probe2, p, w, wp, out⟩ = + ⟨none, moveInputPos p .pos, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `walk`, the head is at position `0`: the machine moves right, onto +position `1`, and halts. -/ +lemma step_walk_none + (hs : (⟨some .walk, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .walk, p, w, wp, out⟩ = + ⟨none, moveInputPos p .pos, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- One step never changes the work tapes, the work heads or the output. -/ +lemma step_frame (c : Cfg k Symbol RewindState input) : + ((rewindInput k Symbol).step c).workTapes = c.workTapes ∧ + ((rewindInput k Symbol).step c).workTapePos = c.workTapePos ∧ + ((rewindInput k Symbol).step c).output = c.output := by + obtain ⟨q, p, w, wp, out⟩ := c + cases q with + | none => exact ⟨rfl, rfl, rfl⟩ + | some q => + rw [step_mk, apply_action _ (fun i => tr_workTapes q _ _ i) (tr_output q _ _)] + exact ⟨rfl, rfl, rfl⟩ + +/-- The run never changes the work tapes, the work heads or the output. -/ +lemma runFrom_frame (c : Cfg k Symbol RewindState input) (m : ℕ) : + ((rewindInput k Symbol).runFrom c m).workTapes = c.workTapes ∧ + ((rewindInput k Symbol).runFrom c m).workTapePos = c.workTapePos ∧ + ((rewindInput k Symbol).runFrom c m).output = c.output := by + induction m with + | zero => exact ⟨rfl, rfl, rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((rewindInput k Symbol).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, h3.trans ih.2.2⟩ + +/-- One step of the run, as an equation on `runFrom`. -/ +lemma runFrom_one (c : Cfg k Symbol RewindState input) : + (rewindInput k Symbol).runFrom c 1 = (rewindInput k Symbol).step c := rfl + +/-- Two steps of the run, as an equation on `runFrom`. -/ +lemma runFrom_two (c : Cfg k Symbol RewindState input) : + (rewindInput k Symbol).runFrom c 2 = + (rewindInput k Symbol).step ((rewindInput k Symbol).step c) := rfl + +/-- From `walk` at position `j ≤ input.length` the machine reaches the halting configuration with +the input head at position `1` in `j + 1` steps. -/ +lemma runFrom_walk (j : ℕ) : + ∀ p : Fin (input.length + 2), p.val = j → j ≤ input.length → + (rewindInput k Symbol).runFrom ⟨some .walk, p, w, wp, out⟩ (j + 1) = + ⟨none, 1, w, wp, out⟩ := by + induction j with + | zero => + intro p hp _ + obtain rfl : p = 0 := Fin.ext (by simpa using hp) + rw [runFrom_succ_eq_step', runFrom_zero, step_walk_none (inputSymbol_mk_eq_none_left rfl)] + refine cfg_congr ?_ + rw [val_moveInputPos_pos 0 (by simp)] + simp + | succ j ih => + intro p hp hj + rw [runFrom_succ_eq_step, step_read _ (inputSymbol_mk_eq_some (by omega) (by omega))] + exact ih (moveInputPos p .neg) (by rw [val_moveInputPos_neg]; omega) (by omega) + +end Rewind + +/-- **The machine that rewinds the input head.** From any configuration in its initial state it +halts, within `input.length + 3` steps, with the input head at position `1` — the first input +symbol — and with the work tapes, the work-tape head positions and the output unchanged at every +step of the run. Before the halting step the machine is live, so runs chain sequentially. -/ +public theorem exists_rewindInput (k : ℕ) (Symbol : Type*) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + ∀ (input : List Symbol) (c : Cfg k Symbol State input), c.state = some tm.q₀ → + ∃ u ≤ input.length + 3, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, 1, c.workTapes, c.workTapePos, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).workTapes = c.workTapes ∧ + (tm.runFrom c m).workTapePos = c.workTapePos ∧ + (tm.runFrom c m).output = c.output := by + refine ⟨RewindState, inferInstance, rewindInput k Symbol, fun input c hc => ?_⟩ + obtain ⟨q, p, w, wp, out⟩ := c + obtain rfl : q = some RewindState.probe := hc + -- the run halts at position `1` after at most `input.length + 3` steps + obtain ⟨u₀, hu₀, hrun⟩ : ∃ u₀ ≤ input.length + 3, + (rewindInput k Symbol).runFrom ⟨some .probe, p, w, wp, out⟩ u₀ = + ⟨none, 1, w, wp, out⟩ := by + rcases Nat.eq_zero_or_pos p.val with hp0 | hp1 + · -- started at the left boundary: probe, probe again, halt + refine ⟨2, by omega, ?_⟩ + obtain rfl : p = 0 := Fin.ext (by simpa using hp0) + rw [Rewind.runFrom_two, Rewind.step_probe_none (Rewind.inputSymbol_mk_eq_none_left rfl), + show moveInputPos (0 : Fin (input.length + 2)) .neg = 0 from + Fin.ext (by rw [Rewind.val_moveInputPos_neg]; simp), + Rewind.step_probe2_none (Rewind.inputSymbol_mk_eq_none_left rfl)] + refine Rewind.cfg_congr ?_ + rw [Rewind.val_moveInputPos_pos 0 (by simp)] + simp + rcases Nat.lt_or_ge p.val (input.length + 1) with hplt | hpge + · -- started inside the input: one probe, then walk to the boundary + refine ⟨p.val + 1, by omega, ?_⟩ + have hw := Rewind.runFrom_walk (k := k) (w := w) (wp := wp) (out := out) (p.val - 1) + (moveInputPos p .neg) (by rw [Rewind.val_moveInputPos_neg]) (by omega) + rw [show p.val - 1 + 1 = p.val from by omega] at hw + rw [runFrom_succ_eq_step, + Rewind.step_read _ (Rewind.inputSymbol_mk_eq_some (by omega) (by omega))] + exact hw + · -- started at the right boundary + have hpv : p.val = input.length + 1 := by have := p.isLt; omega + have hs1 := Rewind.inputSymbol_mk_eq_none_right (q := some .probe) (w := w) (wp := wp) + (out := out) hpv + rcases Nat.eq_zero_or_pos input.length with hlen | hlen + · -- empty input: two probes and halt + refine ⟨2, by omega, ?_⟩ + rw [Rewind.runFrom_two, Rewind.step_probe_none hs1, + show moveInputPos p .neg = 0 from + Fin.ext (by rw [Rewind.val_moveInputPos_neg, Fin.val_zero]; omega), + Rewind.step_probe2_none (Rewind.inputSymbol_mk_eq_none_left rfl)] + refine Rewind.cfg_congr ?_ + rw [Rewind.val_moveInputPos_pos 0 (by simp)] + simp + · -- nonempty input: one probe, the second probe finds a symbol, then walk + refine ⟨1 + (1 + (input.length - 1 + 1)), by omega, ?_⟩ + have hmv : (moveInputPos p .neg).val = input.length := by + rw [Rewind.val_moveInputPos_neg]; omega + rw [runFrom_add, Rewind.runFrom_one, Rewind.step_probe_none hs1, + runFrom_add, Rewind.runFrom_one, + Rewind.step_read _ (Rewind.inputSymbol_mk_eq_some (by omega) (by omega))] + exact Rewind.runFrom_walk (input.length - 1) _ + (by rw [Rewind.val_moveInputPos_neg, hmv]) (by omega) + -- take the first halting time; the frame holds at every step + obtain ⟨u, hu, hhalt, hactive⟩ := + exists_minimal_halting_time (rewindInput k Symbol) _ u₀ (by rw [hrun]) + have hfin : (rewindInput k Symbol).runFrom ⟨some RewindState.probe, p, w, wp, out⟩ u = + ⟨none, 1, w, wp, out⟩ := by + have h := runFrom_eq_of_halt (rewindInput k Symbol) _ hu hhalt + rw [hrun] at h + exact h.symm + exact ⟨u, le_trans hu hu₀, hactive, hfin, fun m _ => Rewind.runFrom_frame _ m⟩ + +end Turing.MultiTapeTM From e7eee985063745fc5a039ebd40f4df2660ad3421 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 12:51:05 +0000 Subject: [PATCH 08/93] feat(MultiTapeTM): instrumenting a machine with footprint tapes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `instrument tm mark` runs `tm` unchanged while pairing each work tape with a footprint tape whose head moves in lockstep and marks every blank cell it stands on, leaving nonblank cells — in particular an anchor at cell 0 — alone. A head path is connected, so the marked region is an interval: the footprint restores, next to a tape whose garbage may contain embedded blanks, the scannability that the garbage lacks. This is the run phase of the tidy normal form; the sweep phase will erase each pair by walking the footprint towards the anchor. The relation to `tm` splits in two, and the split carries the proof: * everything except the footprints is a projection — `projCfg` forgets the footprint tapes and commutes with `step` unconditionally, so the instrumented run mirrors the original by `runFrom_comm_of_step`, with no induction; * the footprint contents are a function of the run's history, not of its current configuration, so they get their own run invariant (`workTapes_addNat_instrument`): after `τ` live steps a footprint holds `mark` exactly on the cells its partner's head occupied at an earlier time, on top of what it held initially, which is never overwritten. Head alignment (`workTapePos_addNat_instrument`) rides along. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../MultiTape/NormalForms/Instrument.lean | 229 ++++++++++++++++++ 2 files changed, 230 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean diff --git a/Cslib.lean b/Cslib.lean index d43b6dd36..ec2cfcad6 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -58,6 +58,7 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean new file mode 100644 index 000000000..0c2e4c14a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Instrumenting a machine with footprint tapes + +`instrument tm mark` runs `tm` unchanged while pairing each of its `k` work tapes with a +*footprint* tape: the footprint head moves in lockstep with its partner, and every cell it stands +on gets the symbol `mark` — unless the cell is already nonblank, which is what preserves a +distinguished anchor placed at cell `0` beforehand. A head path is connected, so the marked region +of a footprint is an interval: the footprint restores, next to a tape whose garbage may contain +embedded blanks, the scannability that the garbage lacks. This is the run phase of the tidy +normal form (`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy`); the sweep phase +erases each pair by walking the footprint towards the anchor. + +The instrumented machine relates to `tm` in two ways, and the split matters: + +* everything except the footprints is a *projection*: `projCfg` forgets the footprint tapes, and + `step` commutes with it unconditionally, so the instrumented run mirrors the original run by + `Turing.MultiTapeTM.runFrom_comm_of_step` — no induction; +* the footprint contents are a function of the run's *history*, not of its current configuration, + so they get their own run invariant: after `τ` live steps, footprint `j` carries `mark` exactly + on the cells its partner's head occupied before time `τ`, on top of what it held initially. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- `tm`, with each work tape `j` paired with the footprint tape `k + j`: the footprint head +mirrors the moves of head `j` and writes `mark` on every blank cell it stands on, leaving nonblank +cells (in particular an anchor at cell `0`) alone. -/ +@[expose] public def instrument (tm : MultiTapeTM k Symbol State) (mark : Symbol) : + MultiTapeTM (k + k) Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work (j.castAdd k) + { inputTape := a.inputTape + workTapes := Fin.addCases (fun j => a.workTapes j) + (fun j => (match work (j.natAdd k) with + | none => some (some mark) + | some _ => none, (a.workTapes j).2)) + output := a.output + state := a.state } + +/-- Forgetting the footprint tapes of an instrumented configuration. -/ +@[expose, simps] public def projCfg (c : Cfg (k + k) Symbol State input) : + Cfg k Symbol State input := + ⟨c.state, c.inputPos, fun j => c.workTapes (j.castAdd k), fun j => c.workTapePos (j.castAdd k), + c.output⟩ + +@[simp] +public lemma projCfg_inputSymbol (c : Cfg (k + k) Symbol State input) : + (projCfg c).inputSymbol = c.inputSymbol := rfl + +@[simp] +public lemma projCfg_workTapeSymbols (c : Cfg (k + k) Symbol State input) (j : Fin k) : + (projCfg c).workTapeSymbols j = c.workTapeSymbols (j.castAdd k) := rfl + +/-- The projection is a step-semiconjugation: the instrumented machine acts on everything except +the footprints exactly as the original does. -/ +public lemma step_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) : + tm.step (projCfg c) = projCfg ((tm.instrument mark).step c) := by + cases hq : c.state with + | none => + have h1 : (projCfg c).state = none := hq + simp only [step, h1, hq] + | some q => + have h1 : (projCfg c).state = some q := hq + have hsym : (projCfg c).workTapeSymbols = fun j => c.workTapeSymbols (j.castAdd k) := rfl + simp only [step, h1, hq, projCfg_inputSymbol, hsym] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext j z + simp [Action.apply, instrument, Fin.addCases_left, projCfg] + · funext j + simp [Action.apply, instrument, Fin.addCases_left, projCfg] + +/-- The instrumented run mirrors the original run, footprints aside. -/ +public lemma runFrom_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) (n : ℕ) : + tm.runFrom (projCfg c) n = projCfg ((tm.instrument mark).runFrom c n) := + runFrom_comm_of_step projCfg (fun c => step_projCfg tm mark c) c n + +section Footprint + +variable {tm : MultiTapeTM k Symbol State} {mark : Symbol} + +/-- `Fin.addCases_right`, in the `addNat` spelling that `simp` normalises to. -/ +private lemma addCases_addNat {γ : Sort*} (f : Fin k → γ) (g : Fin k → γ) (j : Fin k) : + Fin.addCases (motive := fun _ => γ) f g (j.addNat k) = g j := by + rw [← Fin.natAdd_eq_addNat] + exact Fin.addCases_right j + +/-- The action of the instrumented machine moves a footprint head exactly as it moves the +partner head. -/ +private lemma instrument_move (q : State) (inp : Option Symbol) + (work : Fin (k + k) → Option Symbol) (j : Fin k) : + (((tm.instrument mark).tr q inp work).workTapes (j.addNat k)).2 = + (((tm.instrument mark).tr q inp work).workTapes (j.castAdd k)).2 := by + simp [instrument, Fin.addCases_left, addCases_addNat] + +/-- What the instrumented machine writes on a footprint: `mark` if the cell under the head is +blank, nothing otherwise. -/ +private lemma instrument_write (q : State) (inp : Option Symbol) + (work : Fin (k + k) → Option Symbol) (j : Fin k) : + (((tm.instrument mark).tr q inp work).workTapes (j.addNat k)).1 = + match work (j.addNat k) with + | none => some (some mark) + | some _ => none := by + simp [instrument, addCases_addNat] + +/-- A live step moves each head by the amount its action prescribes. -/ +private lemma step_workTapePos_of_state {C : Cfg (k + k) Symbol State input} {q : State} + (hq : C.state = some q) (l : Fin (k + k)) : + ((tm.instrument mark).step C).workTapePos l = + C.workTapePos l + + (((tm.instrument mark).tr q C.inputSymbol C.workTapeSymbols).workTapes l).2 := by + simp [step, hq, Action.apply] + +/-- Footprint heads stay aligned with their partners throughout a live run. -/ +public lemma workTapePos_addNat_instrument (c : Cfg (k + k) Symbol State input) (j : Fin k) + (halign : c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) (τ : ℕ) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + ((tm.instrument mark).runFrom c τ).workTapePos (j.addNat k) = + ((tm.instrument mark).runFrom c τ).workTapePos (j.castAdd k) := by + induction τ with + | zero => exact halign + | succ τ ih => + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp (hlive τ (by omega)) + rw [runFrom_succ_eq_step', step_workTapePos_of_state hq, step_workTapePos_of_state hq, + instrument_move, ih fun m hm => hlive m (by omega)] + +/-- **The footprint invariant.** After `τ` live steps, footprint `j` holds `mark` on every cell +its partner's head occupied at an earlier time, on top of what it held initially — which is never +overwritten, so an anchor placed before the run survives it. -/ +public lemma workTapes_addNat_instrument (c : Cfg (k + k) Symbol State input) (j : Fin k) + (halign : c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) (τ : ℕ) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + ((tm.instrument mark).runFrom c τ).workTapes (j.addNat k) = fun z => + match c.workTapes (j.addNat k) z with + | some s => some s + | none => + if z ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) then + some mark + else none := by + induction τ with + | zero => + funext z + rcases h : c.workTapes (j.addNat k) z with _ | s <;> simp [h] + | succ τ ih => + have hlive' : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none := + fun m hm => hlive m (by omega) + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp (hlive τ (by omega)) + set Cτ := (tm.instrument mark).runFrom c τ with hCτ + -- the footprint head stands on the partner's position + have hpos : Cτ.workTapePos (j.addNat k) = Cτ.workTapePos (j.castAdd k) := + workTapePos_addNat_instrument c j halign τ hlive' + have hstep : ((tm.instrument mark).runFrom c (τ + 1)).workTapes (j.addNat k) = + match (((tm.instrument mark).tr q Cτ.inputSymbol Cτ.workTapeSymbols).workTapes + (j.addNat k)).1 with + | none => Cτ.workTapes (j.addNat k) + | some s => + Function.update (Cτ.workTapes (j.addNat k)) (Cτ.workTapePos (j.addNat k)) s := by + rw [runFrom_succ_eq_step', ← hCτ] + simp only [step, hq, Action.apply] + rfl + rw [hstep, instrument_write] + have hmarks : (Finset.range (τ + 1)).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) = + insert (Cτ.workTapePos (j.castAdd k)) ((Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k))) := by + rw [Finset.range_add_one, Finset.image_insert, hCτ] + -- the current footprint cell, read through the invariant at time `τ` + have hread : Cτ.workTapeSymbols (j.addNat k) = + match c.workTapes (j.addNat k) (Cτ.workTapePos (j.castAdd k)) with + | some s => some s + | none => + if Cτ.workTapePos (j.castAdd k) ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) then + some mark + else none := by + simp only [Cfg.workTapeSymbols, hpos, ih hlive'] + rw [hread] + funext z + rcases hinit : c.workTapes (j.addNat k) (Cτ.workTapePos (j.castAdd k)) with _ | s + · -- the cell under the head was initially blank + by_cases hmem : Cτ.workTapePos (j.castAdd k) ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) + · -- already marked: nothing written, and the new mark set adds nothing at this cell + simp only [hmem, ite_true] + rw [ih hlive', hmarks] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp only [hz, Finset.mem_insert] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp; simp [hmem] + · simp [hzp] + · simp [hz] + · -- unmarked: the machine writes `mark` at the head position + simp only [hmem, ite_false] + rw [hpos, ih hlive', hmarks] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp + simp [Function.update_self, hinit] + · rw [Function.update_of_ne hzp] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp [hzp] + · simp + · -- the cell under the head was initially nonblank: nothing written + rw [ih hlive', hmarks] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp only [hz, Finset.mem_insert] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp; simp_all + · simp [hzp] + · simp [hz] + +end Footprint + +end Turing.MultiTapeTM From 692692386209e37b331296e0730b2464f57e504c Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 14:02:56 +0000 Subject: [PATCH 09/93] feat(MultiTapeTM): anchors and the space of an instrumented run MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `exists_markAnchors`: the one-step machine that writes the anchor on every footprint tape — all footprints in the same step, so it costs one step regardless of the tape count. `spaceUsed_instrument`: an instrumented run uses exactly twice the space of the original, because each footprint head visits exactly the cells its partner visits — head alignment turns each visited-set equality into an image congruence. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Instrument.lean | 76 +++++++++++++++++++ 1 file changed, 76 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean index 0c2e4c14a..f46241f80 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean @@ -226,4 +226,80 @@ public lemma workTapes_addNat_instrument (c : Cfg (k + k) Symbol State input) (j end Footprint +section MarkAnchors + +/-- The one-step machine that writes `mark` on every footprint tape at its head — placing the +anchors before an instrumented run — and halts. Everything else is untouched. -/ +private def markAnchors (k : ℕ) (Symbol : Type*) (mark : Symbol) : + MultiTapeTM (k + k) Symbol Unit where + q₀ := () + tr _ _ _ := + { inputTape := 0 + workTapes := Fin.addCases (fun _ => (none, 0)) (fun _ => (some (some mark), 0)) + output := none + state := none } + +/-- One step of `markAnchors`: anchors written at the footprint heads, nothing else changed. -/ +public theorem exists_markAnchors (k : ℕ) (Symbol : Type*) (mark : Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM (k + k) Symbol State), + ∀ (input : List Symbol) (c : Cfg (k + k) Symbol State input), c.state = some tm.q₀ → + (tm.runFrom c 1).state = none ∧ + (tm.runFrom c 1).inputPos = c.inputPos ∧ + (tm.runFrom c 1).output = c.output ∧ + (tm.runFrom c 1).workTapePos = c.workTapePos ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.castAdd k) = c.workTapes (j.castAdd k)) ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.addNat k) = + Function.update (c.workTapes (j.addNat k)) (c.workTapePos (j.addNat k)) (some mark)) := by + refine ⟨Unit, inferInstance, markAnchors k Symbol mark, fun input c hq => ?_⟩ + have hstep : (markAnchors k Symbol mark).runFrom c 1 = (markAnchors k Symbol mark).step c := by + rw [runFrom_succ_eq_step', runFrom_zero] + rw [hstep] + refine ⟨?_, ?_, ?_, ?_, fun j => ?_, fun j => ?_⟩ + · simp [step, hq, Action.apply, markAnchors] + · simp [step, hq, Action.apply, markAnchors] + · simp [step, hq, Action.apply, markAnchors] + · funext l + induction l using Fin.addCases with + | left j => simp [step, hq, Action.apply, markAnchors, Fin.addCases_left] + | right j => simp [step, hq, Action.apply, markAnchors, addCases_addNat] + · simp [step, hq, Action.apply, markAnchors, Fin.addCases_left] + · simp [step, hq, Action.apply, markAnchors, addCases_addNat] + +end MarkAnchors + +section Space + +/-- An instrumented run uses exactly twice the space of the original: each footprint head visits +exactly the cells its partner visits. -/ +public lemma spaceUsed_instrument (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) (τ : ℕ) + (halign : ∀ j : Fin k, c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + (tm.instrument mark).spaceUsed c τ = 2 * tm.spaceUsed (projCfg c) τ := by + have hcast : ∀ (j : Fin k), + (tm.instrument mark).visitedByTapeHead c τ (j.castAdd k) = + tm.visitedByTapeHead (projCfg c) τ j := by + intro j + refine Finset.image_congr fun m hm => ?_ + rw [runFrom_projCfg tm mark] + rfl + have hnat : ∀ (j : Fin k), + (tm.instrument mark).visitedByTapeHead c τ (j.addNat k) = + tm.visitedByTapeHead (projCfg c) τ j := by + intro j + refine Finset.image_congr fun m hm => ?_ + have hm' : m ≤ τ := Nat.lt_succ_iff.mp (Finset.mem_range.mp hm) + rw [workTapePos_addNat_instrument c j (halign j) m fun r hr => hlive r (by omega), + runFrom_projCfg tm mark] + rfl + rw [spaceUsed, spaceUsed, Fin.sum_univ_add, two_mul] + congr 1 + · exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + · refine Finset.sum_congr rfl fun j _ => congrArg Finset.card ?_ + -- natAdd vs addNat spelling + rw [Fin.natAdd_eq_addNat] + exact hnat j +end Space + + end Turing.MultiTapeTM From 96ac00e25c87924786e64d965515a63e73de2e55 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:05:40 +0000 Subject: [PATCH 10/93] feat(MultiTapeTM): the sweep that erases a footprinted tape pair MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The machine that makes garbage erasable: a tape written by an arbitrary computation may contain blanks inside its garbage, so no scan of the tape itself can find the garbage's extent — but the footprint laid down by `instrument` is contiguous with a distinguished anchor at cell 0, and the sweep erases the pair guided by it, outside-in towards the anchor, consuming the anchor last: goRight over the marks to the right end; sweep left erasing both tapes down to the anchor, which is kept while the garbage under it goes; continue sweeping to the left end; walk right over the now-blank cells — the first mark is the anchor, i.e. cell 0 — erase it and halt. Both heads move in lockstep and home together at 0. Time is linear in the footprint interval (`4 * (r - l).toNat + 8`); the heads never leave the interval widened by one cell, so the sweep's space is the instrumented run's own plus a constant (`2 * (r - l).toNat + 4 + K`). The proof is the Clear pattern scaled to four phases: a generic step lemma against a two-tape configuration descriptor (with an `applyWrite` helper — a `match` in the conclusion would be dependent on the transition hypothesis and block reduction), one trajectory induction per phase, the endpoint chain, and a per-moment shape lemma feeding activity and the space bound. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../Turing/MultiTape/NormalForms/Sweep.lean | 674 ++++++++++++++++++ 2 files changed, 675 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean diff --git a/Cslib.lean b/Cslib.lean index ec2cfcad6..3b2cb781c 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -59,6 +59,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean new file mode 100644 index 000000000..069b06305 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean @@ -0,0 +1,674 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Sweeping a footprinted tape pair clean + +The machine of this file erases one work tape whose garbage may contain embedded blanks — so no +scan of the tape itself can find its extent — guided by the *footprint* tape produced by +`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument`: a contiguous block of +marks over the visited interval, with a distinguished anchor at cell `0`. + +The protocol erases outside-in towards the anchor and consumes it last, which is what lets both +heads end at cell `0` with everything blank, without any counting: + +1. `goRight`: walk right over the marks to the right end of the footprint; +2. `toAnchor`: sweep left, erasing garbage and marks, until the anchor — which is kept, while the + garbage under it is erased; +3. `sweepLeft`: continue sweeping left over the remaining marks to the left end; +4. `seek`: walk right over the now-blank cells; the first nonblank cell is the anchor, i.e. + cell `0`: erase it and halt. + +Both heads move in lockstep throughout, so they home together, and the excursion never leaves the +footprint interval widened by one cell on each side — which is what bounds the sweep's space by +the instrumented run's own. +-/ + +namespace Turing.MultiTapeTM + +namespace Sweep + +/-- The four phases of the sweep. -/ +private inductive SweepState | goRight | toAnchor | sweepLeft | seek +deriving DecidableEq + +private instance : Finite SweepState := + Finite.of_injective + (fun s => match s with + | .goRight => (0 : Fin 4) | .toAnchor => 1 | .sweepLeft => 2 | .seek => 3) + (fun a b h => by cases a <;> cases b <;> simp_all) + +variable {K : ℕ} (i fp : Fin K) + +/-- An action of the sweep: optional writes on the pair, the same move for both heads, everything +else untouched. -/ +private def act (wi wf : Option (Option Bool)) (m : SignType) (q : Option SweepState) : + Action K Bool SweepState where + inputTape := 0 + workTapes l := if l = i then (wi, m) else if l = fp then (wf, m) else (none, 0) + output := none + state := q + +/-- The sweep machine. It reads only the footprint tape. -/ +private def sweep : MultiTapeTM K Bool SweepState where + q₀ := .goRight + tr q _ work := + match q, work fp with + | .goRight, some _ => act i fp none none 1 (some .goRight) + | .goRight, none => act i fp none none (-1) (some .toAnchor) + | .toAnchor, some false => act i fp (some none) (some none) (-1) (some .toAnchor) + | .toAnchor, some true => act i fp (some none) none (-1) (some .sweepLeft) + | .toAnchor, none => act i fp none none 0 none + | .sweepLeft, some _ => act i fp (some none) (some none) (-1) (some .sweepLeft) + | .sweepLeft, none => act i fp none none 1 (some .seek) + | .seek, none => act i fp none none 1 (some .seek) + | .seek, some _ => act i fp none (some none) 0 none + +variable {input : List Bool} + +/-- The configurations the sweep passes through: both heads at `p`, the pair holding `Ti` and +`Tf`, everything else frozen from `base`. -/ +private def cfg (base : Cfg K Bool SweepState input) (q : Option SweepState) (p : ℤ) + (Ti Tf : ℤ → Option Bool) : Cfg K Bool SweepState input := + ⟨q, base.inputPos, + Function.update (Function.update base.workTapes i Ti) fp Tf, + Function.update (Function.update base.workTapePos i p) fp p, + base.output⟩ + +variable {i fp} (hifp : i ≠ fp) + +private lemma cfg_workTapes_fp (base : Cfg K Bool SweepState input) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapes fp = Tf := by + simp [cfg] + +private lemma cfg_workTapePos_fp (base : Cfg K Bool SweepState input) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos fp = p := by + simp [cfg] + +/-- The effect of an optional write at position `p`. -/ +private def applyWrite (T : ℤ → Option Bool) (p : ℤ) : Option (Option Bool) → ℤ → Option Bool + | none => T + | some s => Function.update T p s + +@[simp] private lemma applyWrite_none (T : ℤ → Option Bool) (p : ℤ) : + applyWrite T p none = T := rfl + +@[simp] private lemma applyWrite_some (T : ℤ → Option Bool) (p : ℤ) (s : Option Bool) : + applyWrite T p (some s) = Function.update T p s := rfl + +include hifp in +/-- One step of the sweep from a sweep configuration, given what the transition does. -/ +private lemma step_cfg (base : Cfg K Bool SweepState input) (q : SweepState) (p : ℤ) + (Ti Tf : ℤ → Option Bool) (wi wf : Option (Option Bool)) (m : SignType) + (q' : Option SweepState) + (htr : ∀ inp work, work fp = Tf p → + (sweep i fp).tr q inp work = act i fp wi wf m q') : + (sweep i fp).step (cfg i fp base (some q) p Ti Tf) = + cfg i fp base q' (p + m) (applyWrite Ti p wi) (applyWrite Tf p wf) := by + have hq : (cfg i fp base (some q) p Ti Tf).state = some q := rfl + have hwork : (cfg i fp base (some q) p Ti Tf).workTapeSymbols fp = Tf p := by + simp [Cfg.workTapeSymbols, cfg_workTapes_fp, cfg_workTapePos_fp] + simp only [step, hq] + rw [htr _ _ hwork] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp [Action.apply, act, cfg] + · funext l z + by_cases hl : l = fp + · subst hl + rcases wf with _ | s <;> + simp [Action.apply, act, cfg, Ne.symm hifp, applyWrite] + · by_cases hli : l = i + · subst hli + rcases wi with _ | s <;> + simp [Action.apply, act, cfg, hifp, applyWrite] + · simp [Action.apply, act, cfg, hl, hli] + · funext l + by_cases hl : l = fp + · subst hl + simp [Action.apply, act, cfg, Ne.symm hifp] + · by_cases hli : l = i + · subst hli + simp [Action.apply, act, cfg, hifp] + · simp [Action.apply, act, cfg, hl, hli] + · simp [Action.apply, act, cfg] + +section Run + +variable (l r : ℤ) + +/-- The footprint over the interval `[l, r]`: the anchor at `0`, marks elsewhere. -/ +private def F : ℤ → Option Bool := fun z => + if z = 0 then some true else if l ≤ z ∧ z ≤ r then some false else none + +/-- A tape erased strictly above `q`. -/ +private def eraseAbove (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => + if q < z then none else T z + +/-- A tape erased at `q` and above. -/ +private def eraseFrom (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => + if q ≤ z then none else T z + +/-- The footprint after the left sweep has reached position `q`: everything at `q + 1` and above +erased except the anchor. -/ +private def eraseKeepAnchor (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => + if q < z ∧ z ≠ 0 then none else T z + +variable (base : Cfg K Bool SweepState input) (G : ℤ → Option Bool) + +private lemma cast_one : ((1 : SignType) : ℤ) = 1 := rfl +private lemma cast_neg_one : ((-1 : SignType) : ℤ) = -1 := rfl +private lemma cast_zero : ((0 : SignType) : ℤ) = 0 := rfl + +include hifp in +/-- Phase 1: walk right over the marks. -/ +private lemma run_goRight (p : ℤ) (hlp : l ≤ p) (d : ℕ) (hd : p + d ≤ r + 1) : + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) d = + cfg i fp base (some .goRight) (p + d) G (F l r) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hbound : l ≤ p + (d : ℤ) ∧ p + (d : ℤ) ≤ r := by omega + have hread : F l r (p + d) ≠ none := by + simp only [F] + by_cases h0 : p + (d : ℤ) = 0 <;> simp [h0, hbound] + obtain ⟨b, hb⟩ := Option.ne_none_iff_exists'.mp hread + rw [step_cfg hifp base .goRight (p + d) G (F l r) none none 1 (some .goRight) + (fun inp work hw => by simp only [sweep]; rw [hw, hb])] + rw [show p + (d : ℤ) + ((1 : SignType) : ℤ) = p + ((d + 1 : ℕ) : ℤ) from by + rw [cast_one]; omega] + simp + +include hifp in +/-- The turn at the right end of the footprint. -/ +private lemma step_turn (hl0 : l ≤ 0) (hr : 0 ≤ r) : + (sweep i fp).step (cfg i fp base (some .goRight) (r + 1) G (F l r)) = + cfg i fp base (some .toAnchor) r G (F l r) := by + have hread : F l r (r + 1) = none := by + have h1 : ¬ (r + 1 = 0) := by omega + have h2 : ¬ (l ≤ r + 1 ∧ r + 1 ≤ r) := by omega + simp [F, h1, h2] + rw [step_cfg hifp base .goRight (r + 1) G (F l r) none none (-1) (some .toAnchor) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show r + 1 + ((-1 : SignType) : ℤ) = r from by rw [cast_neg_one]; omega] + simp + +/-- Blanking the boundary cell of an erased-above tape pushes the boundary down. -/ +private lemma update_eraseAbove (T : ℤ → Option Bool) (q : ℤ) : + Function.update (eraseAbove T q) q none = eraseAbove T (q - 1) := by + funext z + by_cases hz : z = q + · subst hz; simp [eraseAbove] + · rw [Function.update_of_ne hz] + have h : q - 1 < z ↔ q < z := by omega + simp [eraseAbove, h] + +/-- The same, one side of the anchor. -/ +private lemma update_eraseKeepAnchor (T : ℤ → Option Bool) (q : ℤ) (hq : q ≠ 0) : + Function.update (eraseKeepAnchor T q) q none = eraseKeepAnchor T (q - 1) := by + funext z + by_cases hz : z = q + · subst hz; simp [eraseKeepAnchor, hq] + · rw [Function.update_of_ne hz] + have h : (q - 1 < z ∧ z ≠ 0) ↔ (q < z ∧ z ≠ 0) ∨ z = q ∧ z ≠ 0 := by omega + by_cases h0 : z = 0 + · simp [eraseKeepAnchor, h0] + · simp only [eraseKeepAnchor, h0, and_true, ne_eq, not_false_iff] + have : (q - 1 < z) ↔ (q < z) := by omega + simp [this] + +/-- After erasing down to the anchor, the footprint is the anchor-keeping erasure from `-1`. -/ +private lemma eraseAbove_zero_eq (T : ℤ → Option Bool) : + eraseAbove T 0 = eraseKeepAnchor T (-1) := by + funext z + rcases lt_trichotomy z 0 with h | h | h + · have h1 : ¬ (0 < z) := by omega + have h2 : ¬ (-1 < z ∧ z ≠ 0) := by omega + simp [eraseAbove, eraseKeepAnchor, h1, h2] + · subst h + simp [eraseAbove, eraseKeepAnchor] + · have h1 : 0 < z := h + have h2 : -1 < z ∧ z ≠ 0 := by omega + simp [eraseAbove, eraseKeepAnchor, h1, h2] + +include hifp in +/-- Phase 2: sweep left from the right end down to the anchor, erasing both tapes. -/ +private lemma run_toAnchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ r) : + (sweep i fp).runFrom + (cfg i fp base (some .toAnchor) r (eraseAbove G r) (eraseAbove (F l r) r)) d = + cfg i fp base (some .toAnchor) (r - d) (eraseAbove G (r - d)) + (eraseAbove (F l r) (r - d)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hq : (1 : ℤ) ≤ r - d := by omega + have hread : eraseAbove (F l r) (r - d) (r - d) = some false := by + have h0 : ¬ (r - (d : ℤ) = 0) := by omega + have hin : l ≤ r - (d : ℤ) ∧ r - (d : ℤ) ≤ r := by omega + simp [eraseAbove, F, h0, hin] + rw [step_cfg hifp base .toAnchor (r - d) (eraseAbove G (r - d)) (eraseAbove (F l r) (r - d)) + (some none) (some none) (-1) (some .toAnchor) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show r - (d : ℤ) + ((-1 : SignType) : ℤ) = r - ((d + 1 : ℕ) : ℤ) from by + rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_some, update_eraseAbove, update_eraseAbove, + show r - (d : ℤ) - 1 = r - ((d + 1 : ℕ) : ℤ) from by omega] + +include hifp in +/-- The anchor step: erase the garbage under the anchor, keep the anchor, turn left. -/ +private lemma step_anchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) : + (sweep i fp).step + (cfg i fp base (some .toAnchor) 0 (eraseAbove G 0) (eraseAbove (F l r) 0)) = + cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1)) := by + have hread : eraseAbove (F l r) 0 0 = some true := by simp [eraseAbove, F] + rw [step_cfg hifp base .toAnchor 0 (eraseAbove G 0) (eraseAbove (F l r) 0) + (some none) none (-1) (some .sweepLeft) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (0 : ℤ) + ((-1 : SignType) : ℤ) = -1 from by rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_none, + show Function.update (eraseAbove G 0) 0 none = eraseAbove G (-1) from by + have h := update_eraseAbove G 0 + simpa using h, + eraseAbove_zero_eq (F l r)] + +include hifp in +/-- Phase 3: sweep left below the anchor, erasing both tapes. -/ +private lemma run_sweepLeft (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ -l) : + (sweep i fp).runFrom + (cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1))) d = + cfg i fp base (some .sweepLeft) (-1 - d) (eraseAbove G (-1 - d)) + (eraseKeepAnchor (F l r) (-1 - d)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hq : l ≤ -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≤ -1 := by omega + have hread : eraseKeepAnchor (F l r) (-1 - d) (-1 - d) = some false := by + have h0 : ¬ (-1 - (d : ℤ) = 0) := by omega + have hc : ¬ (-1 - (d : ℤ) < -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≠ 0) := by omega + have hin : l ≤ -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≤ r := by omega + simp [eraseKeepAnchor, F, h0, hc, hin] + rw [step_cfg hifp base .sweepLeft (-1 - d) (eraseAbove G (-1 - d)) + (eraseKeepAnchor (F l r) (-1 - d)) (some none) (some none) (-1) (some .sweepLeft) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (-1 : ℤ) - (d : ℤ) + ((-1 : SignType) : ℤ) = -1 - ((d + 1 : ℕ) : ℤ) from by + rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_some, update_eraseAbove, + update_eraseKeepAnchor (F l r) _ (by omega), + show (-1 : ℤ) - (d : ℤ) - 1 = -1 - ((d + 1 : ℕ) : ℤ) from by omega] + +include hifp in +/-- The turn at the left end of the footprint. -/ +private lemma step_turnLeft (hl0 : l ≤ 0) : + (sweep i fp).step + (cfg i fp base (some .sweepLeft) (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) := by + have hread : eraseKeepAnchor (F l r) (l - 1) (l - 1) = none := by + have hc : ¬ (l - 1 < l - 1 ∧ l - 1 ≠ 0) := by omega + have h0 : ¬ (l - 1 = 0) := by omega + have hin : ¬ (l ≤ l - 1 ∧ l - 1 ≤ r) := by omega + simp [eraseKeepAnchor, F, hc, h0, hin] + rw [step_cfg hifp base .sweepLeft (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none none 1 (some .seek) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show l - 1 + ((1 : SignType) : ℤ) = l from by rw [cast_one]; omega] + simp + +include hifp in +/-- Phase 4: walk right over the erased cells towards the anchor. -/ +private lemma run_seek (hl0 : l ≤ 0) (d : ℕ) (hd : (d : ℤ) ≤ -l) : + (sweep i fp).runFrom + (cfg i fp base (some .seek) l (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) d = + cfg i fp base (some .seek) (l + d) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hread : eraseKeepAnchor (F l r) (l - 1) (l + d) = none := by + have hc : l - 1 < l + (d : ℤ) ∧ l + (d : ℤ) ≠ 0 := by omega + simp [eraseKeepAnchor, hc] + rw [step_cfg hifp base .seek (l + d) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none none 1 (some .seek) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show l + (d : ℤ) + ((1 : SignType) : ℤ) = l + ((d + 1 : ℕ) : ℤ) from by + rw [cast_one]; omega] + simp + +include hifp in +/-- The halting step: erase the anchor, stay at `0`. -/ +private lemma step_final (hl0 : l ≤ 0) : + (sweep i fp).step + (cfg i fp base (some .seek) 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) = + cfg i fp base none 0 (eraseAbove G (l - 1)) + (Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none) := by + have hread : eraseKeepAnchor (F l r) (l - 1) 0 = some true := by + have hc : ¬ (l - 1 < (0 : ℤ) ∧ (0 : ℤ) ≠ 0) := by omega + simp [eraseKeepAnchor, hc, F] + rw [step_cfg hifp base .seek 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none (some none) 0 none + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (0 : ℤ) + ((0 : SignType) : ℤ) = 0 from by rw [cast_zero]; omega] + simp + +/-- After the sweep, the garbage tape is blank. -/ +private lemma eraseAbove_final (hG : ∀ z, z < l ∨ r < z → G z = none) : + eraseAbove G (l - 1) = fun _ => none := by + funext z + by_cases h : l - 1 < z + · simp [eraseAbove, h] + · simp [eraseAbove, h, hG z (Or.inl (by omega))] + +/-- After the sweep, the footprint is blank. -/ +private lemma eraseKeepAnchor_final (hl0 : l ≤ 0) : + Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none = fun _ => none := by + funext z + by_cases h0 : z = 0 + · subst h0; simp + · rw [Function.update_of_ne h0] + by_cases h : l - 1 < z + · simp [eraseKeepAnchor, h, h0] + · have hF : F l r z = none := by + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [F, h0, hin] + simp [eraseKeepAnchor, hF] + +/-- The number of steps of the full sweep, started at position `p`. -/ +private def steps (l r p : ℤ) : ℕ := + (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 + +include hifp in +/-- The garbage tape is blank above `r` and the footprint is exactly `F`: the sweep erases +everything and homes both heads. -/ +private lemma run_full (hl0 : l ≤ 0) (h0r : 0 ≤ r) (p : ℤ) (hlp : l ≤ p) (hpr : p ≤ r) + (hG : ∀ z, z < l ∨ r < z → G z = none) : + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) (steps l r p) = + cfg i fp base none 0 (fun _ => none) (fun _ => none) := by + have hGr : eraseAbove G r = G := by + funext z + by_cases h : r < z + · simp [eraseAbove, h, hG z (Or.inr h)] + · simp [eraseAbove, h] + have hFr : eraseAbove (F l r) r = F l r := by + funext z + by_cases h : r < z + · have h0 : ¬ (z = 0) := by omega + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [eraseAbove, F, h, h0, hin] + · simp [eraseAbove, h] + -- segment 1: to the right end + have e₁ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat) = cfg i fp base (some .goRight) (r + 1) G (F l r) := by + rw [run_goRight hifp l r base G p hlp ((r + 1 - p).toNat) (by omega), + show p + ((r + 1 - p).toNat : ℤ) = r + 1 from by omega] + -- segment 2: turn, then down to the anchor + have e₂ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat) = + cfg i fp base (some .toAnchor) 0 (eraseAbove G 0) (eraseAbove (F l r) 0) := by + rw [runFrom_add, runFrom_add, e₁, runFrom_succ_eq_step', runFrom_zero, + step_turn hifp l r base G hl0 h0r] + have h := run_toAnchor hifp l r base G hl0 h0r r.toNat (by omega) + rw [hGr, hFr, show r - (r.toNat : ℤ) = 0 from by omega] at h + exact h + -- segment 3: the anchor step, then down to the left end + have e₃ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat) = + cfg i fp base (some .sweepLeft) (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, runFrom_add, e₂, runFrom_succ_eq_step', runFrom_zero, + step_anchor hifp l r base G hl0 h0r, + run_sweepLeft hifp l r base G hl0 h0r (-l).toNat (by omega), + show (-1 : ℤ) - ((-l).toNat : ℤ) = l - 1 from by omega] + -- segment 4: turn at the left end + have e₄ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, e₃, runFrom_succ_eq_step', runFrom_zero, + step_turnLeft hifp l r base G hl0] + -- segment 5: up to the anchor + have e₅ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat) = + cfg i fp base (some .seek) 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, e₄] + have h := run_seek hifp l r base G hl0 (-l).toNat (by omega) + rw [show l + ((-l).toNat : ℤ) = 0 from by omega] at h + exact h + -- the halting step + rw [show steps l r p = (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 + from rfl, + runFrom_add, e₅, runFrom_succ_eq_step', runFrom_zero, step_final hifp l r base G hl0, + eraseAbove_final l r G hG, eraseKeepAnchor_final l r hl0] + +include hifp in +/-- The configuration at every moment of the sweep: some sweep configuration, with the heads never +leaving the footprint interval widened by one cell, and live before the last step. -/ +private lemma run_shape (hl0 : l ≤ 0) (h0r : 0 ≤ r) (p : ℤ) (hlp : l ≤ p) (hpr : p ≤ r) + (hG : ∀ z, z < l ∨ r < z → G z = none) (m : ℕ) (hm : m ≤ steps l r p) : + ∃ (q : Option SweepState) (pos : ℤ) (Ti Tf : ℤ → Option Bool), + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) m = + cfg i fp base q pos Ti Tf ∧ + l - 1 ≤ pos ∧ pos ≤ r + 1 ∧ (m < steps l r p → q ≠ none) := by + have hGr : eraseAbove G r = G := by + funext z + by_cases h : r < z + · simp [eraseAbove, h, hG z (Or.inr h)] + · simp [eraseAbove, h] + have hFr : eraseAbove (F l r) r = F l r := by + funext z + by_cases h : r < z + · have h0 : ¬ (z = 0) := by omega + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [eraseAbove, F, h, h0, hin] + · simp [eraseAbove, h] + -- the endpoints of the four walking segments + have chainA : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat) = cfg i fp base (some .goRight) (r + 1) G (F l r) := by + rw [run_goRight hifp l r base G p hlp ((r + 1 - p).toNat) (by omega), + show p + ((r + 1 - p).toNat : ℤ) = r + 1 from by omega] + have chainB : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1) = + cfg i fp base (some .toAnchor) r (eraseAbove G r) (eraseAbove (F l r) r) := by + rw [runFrom_add, chainA, runFrom_succ_eq_step', runFrom_zero, + step_turn hifp l r base G hl0 h0r, hGr, hFr] + have chainC : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1) = + cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1)) := by + rw [runFrom_add, runFrom_add, chainB, + run_toAnchor hifp l r base G hl0 h0r r.toNat (by omega), + show r - (r.toNat : ℤ) = 0 from by omega, runFrom_succ_eq_step', runFrom_zero, + step_anchor hifp l r base G hl0 h0r] + have chainD : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, runFrom_add, chainC, + run_sweepLeft hifp l r base G hl0 h0r (-l).toNat (by omega), + show (-1 : ℤ) - ((-l).toNat : ℤ) = l - 1 from by omega, runFrom_succ_eq_step', + runFrom_zero, step_turnLeft hifp l r base G hl0] + have hs : steps l r p = + (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 := rfl + -- case analysis on the segment `m` falls in + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1) with h₁ | h₁ + · -- walking right + refine ⟨some .goRight, p + (m : ℤ), G, F l r, + run_goRight hifp l r base G p hlp m (by omega), by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1 + r.toNat + 1) with h₂ | h₂ + · -- descending to the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ r ∧ m = (r + 1 - p).toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainB, run_toAnchor hifp l r base G hl0 h0r d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) with h₃ | h₃ + · -- descending below the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ -l ∧ + m = (r + 1 - p).toNat + 1 + r.toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1 + r.toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainC, run_sweepLeft hifp l r base G hl0 h0r d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m (steps l r p) with h₄ | h₄ + · -- ascending to the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ -l ∧ + m = (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainD, run_seek hifp l r base G hl0 d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + · -- the halting configuration + have hm' : m = steps l r p := by omega + subst hm' + exact ⟨none, 0, fun _ => none, fun _ => none, + run_full hifp l r base G hl0 h0r p hlp hpr hG, by omega, by omega, fun h => absurd h + (by omega)⟩ + +include hifp in +private lemma cfg_workTapePos_i (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos i = p := by + simp only [cfg] + rw [Function.update_of_ne hifp, Function.update_self] + +private lemma cfg_workTapePos_other (l' : Fin K) (hi : l' ≠ i) (hfp : l' ≠ fp) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos l' = base.workTapePos l' := by + simp only [cfg] + rw [Function.update_of_ne hfp, Function.update_of_ne hi] + +end Run + +end Sweep + +open Sweep in +/-- **Sweeping a footprinted pair clean.** Given a footprint over `[l, r]` with the anchor at `0` +on tape `fp`, and garbage confined to `[l, r]` on tape `i` — possibly with blanks inside, so that +no scan of tape `i` itself could find its extent — the sweep machine erases both tapes completely +and homes both heads to `0`, in time linear in the footprint interval and space exceeding it only +by a constant, touching nothing else. -/ +public theorem exists_sweepPair {K : ℕ} (i fp : Fin K) (hifp : i ≠ fp) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + ∀ (input : List Bool) (c : Cfg K Bool State input) (l r p : ℤ), + c.state = some tm.q₀ → l ≤ 0 → 0 ≤ r → l ≤ p → p ≤ r → + c.workTapePos i = p → c.workTapePos fp = p → + (∀ z, c.workTapes fp z = if z = 0 then some true + else if l ≤ z ∧ z ≤ r then some false else none) → + (∀ z, z < l ∨ r < z → c.workTapes i z = none) → + ∃ u ≤ 4 * (r - l).toNat + 8, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + Function.update (Function.update c.workTapes i fun _ => none) fp fun _ => none, + Function.update (Function.update c.workTapePos i 0) fp 0, + c.output⟩ ∧ + tm.spaceUsed c u ≤ 2 * (r - l).toNat + 4 + K := by + refine ⟨SweepState, inferInstance, sweep i fp, + fun input c l r p hq hl0 h0r hlp hpr hpi hpf hF hG => ?_⟩ + -- the start is a sweep configuration over the given data + have hFfun : c.workTapes fp = F l r := funext fun z => hF z + have hc : c = cfg i fp c (some .goRight) p (c.workTapes i) (F l r) := by + refine Cfg.ext hq rfl ?_ ?_ rfl + · rw [← hFfun] + simp [cfg, Function.update_eq_self] + · simp only [cfg] + funext l' + by_cases h1 : l' = fp + · subst h1; rw [Function.update_self]; exact hpf + · rw [Function.update_of_ne h1] + by_cases h2 : l' = i + · subst h2; rw [Function.update_self]; exact hpi + · rw [Function.update_of_ne h2] + -- the run, read back on `c` + have hrun : ∀ m ≤ steps l r p, ∃ (q' : Option SweepState) (pos : ℤ) + (Ti Tf : ℤ → Option Bool), + (sweep i fp).runFrom c m = cfg i fp c q' pos Ti Tf ∧ + l - 1 ≤ pos ∧ pos ≤ r + 1 ∧ (m < steps l r p → q' ≠ none) := by + intro m hm + obtain ⟨q', pos, Ti, Tf, heq, h1, h2, h3⟩ := + run_shape hifp l r c (c.workTapes i) hl0 h0r p hlp hpr hG m hm + rw [← hc] at heq + exact ⟨q', pos, Ti, Tf, heq, h1, h2, h3⟩ + have hfull : (sweep i fp).runFrom c (steps l r p) = + cfg i fp c none 0 (fun _ => none) (fun _ => none) := by + have h := run_full hifp l r c (c.workTapes i) hl0 h0r p hlp hpr hG + rwa [← hc] at h + refine ⟨steps l r p, by simp only [steps]; omega, ?_, ?_, ?_⟩ + · -- activity + intro m hm + obtain ⟨q', pos, Ti, Tf, heq, -, -, hq'⟩ := hrun m (by omega) + rw [heq] + simpa [cfg] using hq' hm + · -- the halting configuration + rw [hfull] + rfl + · -- the space bound + have hB : ∀ l' : Fin K, l' = i ∨ l' = fp → + (sweep i fp).spaceUsedByTape c (steps l r p) l' ≤ (r - l).toNat + 3 := by + intro l' hl' + have hsub : (sweep i fp).visitedByTapeHead c (steps l r p) l' ⊆ + Finset.Icc (l - 1) (r + 1) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q', pos, Ti, Tf, heq, hlo, hhi, -⟩ := hrun m (by omega) + rw [heq] + rcases hl' with rfl | rfl + · rw [cfg_workTapePos_i hifp] + exact Finset.mem_Icc.mpr ⟨hlo, hhi⟩ + · rw [cfg_workTapePos_fp] + exact Finset.mem_Icc.mpr ⟨hlo, hhi⟩ + calc (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ (Finset.Icc (l - 1) (r + 1)).card := Finset.card_le_card hsub + _ = (r + 1 + 1 - (l - 1)).toNat := Int.card_Icc _ _ + _ ≤ (r - l).toNat + 3 := by omega + have h1 : ∀ l' : Fin K, l' ≠ i → l' ≠ fp → + (sweep i fp).spaceUsedByTape c (steps l r p) l' ≤ 1 := by + intro l' hi' hfp' + have hsub : (sweep i fp).visitedByTapeHead c (steps l r p) l' ⊆ + {c.workTapePos l'} := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q', pos, Ti, Tf, heq, -, -, -⟩ := hrun m (by omega) + rw [heq, cfg_workTapePos_other c l' hi' hfp'] + exact Finset.mem_singleton_self _ + calc (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ ({c.workTapePos l'} : Finset ℤ).card := Finset.card_le_card hsub + _ = 1 := Finset.card_singleton _ + have hfpmem : fp ∈ Finset.univ.erase i := + Finset.mem_erase.mpr ⟨Ne.symm hifp, Finset.mem_univ _⟩ + have hK : 2 ≤ K := by + rcases K with _ | _ | K + · exact i.elim0 + · exact absurd (Fin.ext (by omega : i.val = fp.val)) hifp + · omega + calc (sweep i fp).spaceUsed c (steps l r p) + = (sweep i fp).spaceUsedByTape c (steps l r p) i + + ∑ l' ∈ Finset.univ.erase i, (sweep i fp).spaceUsedByTape c (steps l r p) l' := + (Finset.add_sum_erase _ _ (Finset.mem_univ i)).symm + _ = (sweep i fp).spaceUsedByTape c (steps l r p) i + + ((sweep i fp).spaceUsedByTape c (steps l r p) fp + + ∑ l' ∈ (Finset.univ.erase i).erase fp, + (sweep i fp).spaceUsedByTape c (steps l r p) l') := by + rw [Finset.add_sum_erase _ _ hfpmem] + _ ≤ ((r - l).toNat + 3) + (((r - l).toNat + 3) + (K - 2) * 1) := by + have hcard : ((Finset.univ.erase i).erase fp).card = K - 1 - 1 := by + rw [Finset.card_erase_of_mem hfpmem, Finset.card_erase_of_mem (Finset.mem_univ i)] + simp + refine Nat.add_le_add (hB i (Or.inl rfl)) (Nat.add_le_add (hB fp (Or.inr rfl)) ?_) + calc ∑ l' ∈ (Finset.univ.erase i).erase fp, + (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ ((Finset.univ.erase i).erase fp).card • 1 := + Finset.sum_le_card_nsmul _ _ 1 fun l' hl' => h1 l' + (Finset.ne_of_mem_erase (Finset.mem_of_mem_erase hl')) + (Finset.ne_of_mem_erase hl') + _ = (K - 2) * 1 := by rw [hcard]; simp; omega + _ ≤ 2 * (r - l).toNat + 4 + K := by omega + +end Turing.MultiTapeTM From 176e3fd490b98079683005d471c0dce79d383d69 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:06:55 +0000 Subject: [PATCH 11/93] chore(MultiTapeTM): silence the sweep's unused-binder lints Cslib.lean gains the Sweep module (mk_all), unused hypotheses of internal phase lemmas are underscore-prefixed, and simp argument lists trimmed per the linter. Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/NormalForms/Sweep.lean | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean index 069b06305..fb92265f3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean @@ -188,13 +188,13 @@ private lemma run_goRight (p : ℤ) (hlp : l ≤ p) (d : ℕ) (hd : p + d ≤ r include hifp in /-- The turn at the right end of the footprint. -/ -private lemma step_turn (hl0 : l ≤ 0) (hr : 0 ≤ r) : +private lemma step_turn (_hl0 : l ≤ 0) (hr : 0 ≤ r) : (sweep i fp).step (cfg i fp base (some .goRight) (r + 1) G (F l r)) = cfg i fp base (some .toAnchor) r G (F l r) := by have hread : F l r (r + 1) = none := by have h1 : ¬ (r + 1 = 0) := by omega have h2 : ¬ (l ≤ r + 1 ∧ r + 1 ≤ r) := by omega - simp [F, h1, h2] + simp [F, h1] rw [step_cfg hifp base .goRight (r + 1) G (F l r) none none (-1) (some .toAnchor) (fun inp work hw => by simp only [sweep]; rw [hw, hread])] rw [show r + 1 + ((-1 : SignType) : ℤ) = r from by rw [cast_neg_one]; omega] @@ -240,7 +240,7 @@ private lemma eraseAbove_zero_eq (T : ℤ → Option Bool) : include hifp in /-- Phase 2: sweep left from the right end down to the anchor, erasing both tapes. -/ -private lemma run_toAnchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ r) : +private lemma run_toAnchor (hl0 : l ≤ 0) (_h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ r) : (sweep i fp).runFrom (cfg i fp base (some .toAnchor) r (eraseAbove G r) (eraseAbove (F l r) r)) d = cfg i fp base (some .toAnchor) (r - d) (eraseAbove G (r - d)) @@ -264,7 +264,7 @@ private lemma run_toAnchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : include hifp in /-- The anchor step: erase the garbage under the anchor, keep the anchor, turn left. -/ -private lemma step_anchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) : +private lemma step_anchor (_hl0 : l ≤ 0) (_h0r : 0 ≤ r) : (sweep i fp).step (cfg i fp base (some .toAnchor) 0 (eraseAbove G 0) (eraseAbove (F l r) 0)) = cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) @@ -282,7 +282,7 @@ private lemma step_anchor (hl0 : l ≤ 0) (h0r : 0 ≤ r) : include hifp in /-- Phase 3: sweep left below the anchor, erasing both tapes. -/ -private lemma run_sweepLeft (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ -l) : +private lemma run_sweepLeft (_hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ -l) : (sweep i fp).runFrom (cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) (eraseKeepAnchor (F l r) (-1))) d = @@ -297,7 +297,7 @@ private lemma run_sweepLeft (hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : have h0 : ¬ (-1 - (d : ℤ) = 0) := by omega have hc : ¬ (-1 - (d : ℤ) < -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≠ 0) := by omega have hin : l ≤ -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≤ r := by omega - simp [eraseKeepAnchor, F, h0, hc, hin] + simp [eraseKeepAnchor, F, h0, hin] rw [step_cfg hifp base .sweepLeft (-1 - d) (eraseAbove G (-1 - d)) (eraseKeepAnchor (F l r) (-1 - d)) (some none) (some none) (-1) (some .sweepLeft) (fun inp work hw => by simp only [sweep]; rw [hw, hread])] @@ -318,7 +318,7 @@ private lemma step_turnLeft (hl0 : l ≤ 0) : have hc : ¬ (l - 1 < l - 1 ∧ l - 1 ≠ 0) := by omega have h0 : ¬ (l - 1 = 0) := by omega have hin : ¬ (l ≤ l - 1 ∧ l - 1 ≤ r) := by omega - simp [eraseKeepAnchor, F, hc, h0, hin] + simp [eraseKeepAnchor, F, h0] rw [step_cfg hifp base .sweepLeft (l - 1) (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) none none 1 (some .seek) (fun inp work hw => by simp only [sweep]; rw [hw, hread])] @@ -327,7 +327,7 @@ private lemma step_turnLeft (hl0 : l ≤ 0) : include hifp in /-- Phase 4: walk right over the erased cells towards the anchor. -/ -private lemma run_seek (hl0 : l ≤ 0) (d : ℕ) (hd : (d : ℤ) ≤ -l) : +private lemma run_seek (_hl0 : l ≤ 0) (d : ℕ) (hd : (d : ℤ) ≤ -l) : (sweep i fp).runFrom (cfg i fp base (some .seek) l (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1))) d = @@ -349,7 +349,7 @@ private lemma run_seek (hl0 : l ≤ 0) (d : ℕ) (hd : (d : ℤ) ≤ -l) : include hifp in /-- The halting step: erase the anchor, stay at `0`. -/ -private lemma step_final (hl0 : l ≤ 0) : +private lemma step_final (_hl0 : l ≤ 0) : (sweep i fp).step (cfg i fp base (some .seek) 0 (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1))) = @@ -357,7 +357,7 @@ private lemma step_final (hl0 : l ≤ 0) : (Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none) := by have hread : eraseKeepAnchor (F l r) (l - 1) 0 = some true := by have hc : ¬ (l - 1 < (0 : ℤ) ∧ (0 : ℤ) ≠ 0) := by omega - simp [eraseKeepAnchor, hc, F] + simp [eraseKeepAnchor, F] rw [step_cfg hifp base .seek 0 (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) none (some none) 0 none (fun inp work hw => by simp only [sweep]; rw [hw, hread])] @@ -373,7 +373,7 @@ private lemma eraseAbove_final (hG : ∀ z, z < l ∨ r < z → G z = none) : · simp [eraseAbove, h, hG z (Or.inl (by omega))] /-- After the sweep, the footprint is blank. -/ -private lemma eraseKeepAnchor_final (hl0 : l ≤ 0) : +private lemma eraseKeepAnchor_final (_hl0 : l ≤ 0) : Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none = fun _ => none := by funext z by_cases h0 : z = 0 From b5cba22b17a7d71386dc322afac459dcef4054b8 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:17:28 +0000 Subject: [PATCH 12/93] feat(MultiTapeTM): mark the cells under the footprint heads MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The footprint marks cells at pre-move positions, so a head's final cell can be an unmarked fresh extremum. `markCurrent` closes the gap in one blank-guarded step — the instrument's own write rule as a standalone machine — after which the marks cover exactly the visited cells, with the anchor safe under a head that happens to be home. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Instrument.lean | 64 +++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean index f46241f80..f6f455774 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean @@ -265,6 +265,70 @@ public theorem exists_markAnchors (k : ℕ) (Symbol : Type*) (mark : Symbol) : · simp [step, hq, Action.apply, markAnchors, Fin.addCases_left] · simp [step, hq, Action.apply, markAnchors, addCases_addNat] +/-- The one-step machine that writes `mark` on every footprint tape at its head — but only on a +blank cell, so an anchor under a head survives. Run after an instrumented machine halts, it marks +the final head positions, which the run itself never wrote: the footprint then covers exactly the +visited cells. -/ +private def markCurrent (k : ℕ) (Symbol : Type*) (mark : Symbol) : + MultiTapeTM (k + k) Symbol Unit where + q₀ := () + tr _ _ work := + { inputTape := 0 + workTapes := Fin.addCases (fun _ => (none, 0)) + (fun j => (match work (j.natAdd k) with + | none => some (some mark) + | some _ => none, 0)) + output := none + state := none } + +/-- One step of `markCurrent`: the cells under the footprint heads are marked if blank, nothing +else changes. -/ +public theorem exists_markCurrent (k : ℕ) (Symbol : Type*) (mark : Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM (k + k) Symbol State), + ∀ (input : List Symbol) (c : Cfg (k + k) Symbol State input), c.state = some tm.q₀ → + (tm.runFrom c 1).state = none ∧ + (tm.runFrom c 1).inputPos = c.inputPos ∧ + (tm.runFrom c 1).output = c.output ∧ + (tm.runFrom c 1).workTapePos = c.workTapePos ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.castAdd k) = c.workTapes (j.castAdd k)) ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.addNat k) = fun z => + match c.workTapes (j.addNat k) z with + | some s => some s + | none => + if z = c.workTapePos (j.addNat k) ∧ + c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) = none then + some mark + else none) := by + refine ⟨Unit, inferInstance, markCurrent k Symbol mark, fun input c hq => ?_⟩ + have hstep : (markCurrent k Symbol mark).runFrom c 1 = (markCurrent k Symbol mark).step c := by + rw [runFrom_succ_eq_step', runFrom_zero] + rw [hstep] + refine ⟨?_, ?_, ?_, ?_, fun j => ?_, fun j => ?_⟩ + · simp [step, hq, Action.apply, markCurrent] + · simp [step, hq, Action.apply, markCurrent] + · simp [step, hq, Action.apply, markCurrent] + · funext l + induction l using Fin.addCases with + | left j => simp [step, hq, Action.apply, markCurrent, Fin.addCases_left] + | right j => + rcases h : c.workTapeSymbols (j.natAdd k) with _ | s <;> + simp [step, hq, Action.apply, markCurrent, addCases_addNat] + · simp [step, hq, Action.apply, markCurrent, Fin.addCases_left] + · funext z + simp only [step, hq, Action.apply, markCurrent, addCases_addNat] + rw [show c.workTapeSymbols (Fin.natAdd k j) = + c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) from by + rw [Fin.natAdd_eq_addNat]; rfl] + rcases hcell : c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) with _ | s + · -- blank under the head: write the mark there + by_cases hz : z = c.workTapePos (j.addNat k) + · subst hz + simp [hcell, Function.update_self] + · rcases hzc : c.workTapes (j.addNat k) z with _ | t <;> + simp [hzc, hz] + · -- nonblank under the head: no write + rcases hzc : c.workTapes (j.addNat k) z with _ | t <;> simp [hzc] + end MarkAnchors section Space From 7a0f58b77bcd4256c6cd7ac81b82ebb5a4566e3b Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:22:01 +0000 Subject: [PATCH 13/93] feat(MultiTapeTM): support lemmas for the tidy assembly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The rewind machine's time bound is restated in terms of the starting head position (`c.inputPos.val + 2`) rather than the input length — an excursion is bounded by the time that produced it, the input length is not. New: `val_moveInputPos_le`, `inputPos_runFrom_le` (heads stray at most one position per step), and `spaceUsed_le_of_workTapePos_const` (a run that never moves a work head visits one cell per tape). Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/Configuration.lean | 11 ++++ .../Turing/MultiTape/Deterministic.lean | 18 ++++++ .../MultiTape/Plumbing/RewindInput.lean | 4 +- .../Machines/Turing/MultiTape/TapeLemmas.lean | 58 +++++++++++++++++++ 4 files changed, 89 insertions(+), 2 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 93e8aa70f..d63542796 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -128,6 +128,17 @@ lemma moveInputPos_pos_of_ne_right {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n · simp omega +/-- The input head moves by at most one position. -/ +lemma val_moveInputPos_le {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : + (moveInputPos pos m).val ≤ pos.val + 1 := by + simp only [moveInputPos] + by_cases h : (((pos.val : ℤ) + m.cast).toNat) < n + 2 + · rw [dif_pos h] + rcases m <;> simp [SignType.cast] <;> omega + · rw [dif_neg h] + have := pos.isLt + rcases m <;> simp [SignType.cast] at h <;> 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/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 543b630f0..df5c34846 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -267,6 +267,24 @@ lemma step_output (cfg : Cfg k Symbol State input) : unfold step outputSymbol Action.apply cases cfg.state <;> simp +/-- The input head strays at most `t` positions from where it started in `t` steps. -/ +lemma inputPos_runFrom_le (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) : + ((tm.runFrom cfg t).inputPos : ℕ) ≤ (cfg.inputPos : ℕ) + t := by + induction t with + | zero => simp + | succ t ih => + rw [runFrom_succ_eq_step'] + by_cases hq : (tm.runFrom cfg t).state = none + · rw [step_of_halt hq] + omega + · obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp hq + have h : ((tm.step (tm.runFrom cfg t)).inputPos : ℕ) ≤ + ((tm.runFrom cfg t).inputPos : ℕ) + 1 := by + simp only [step, hq, Action.apply] + exact val_moveInputPos_le _ _ + omega + /-- Nothing changes after the machine has halted. -/ lemma runFrom_eq_of_halt (tm : MultiTapeTM k Symbol State) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean index 22b8fe561..adb91c373 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean @@ -243,7 +243,7 @@ step of the run. Before the halting step the machine is live, so runs chain sequ public theorem exists_rewindInput (k : ℕ) (Symbol : Type*) : ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), ∀ (input : List Symbol) (c : Cfg k Symbol State input), c.state = some tm.q₀ → - ∃ u ≤ input.length + 3, + ∃ u ≤ c.inputPos.val + 2, (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ tm.runFrom c u = ⟨none, 1, c.workTapes, c.workTapePos, c.output⟩ ∧ ∀ m ≤ u, (tm.runFrom c m).workTapes = c.workTapes ∧ @@ -253,7 +253,7 @@ public theorem exists_rewindInput (k : ℕ) (Symbol : Type*) : obtain ⟨q, p, w, wp, out⟩ := c obtain rfl : q = some RewindState.probe := hc -- the run halts at position `1` after at most `input.length + 3` steps - obtain ⟨u₀, hu₀, hrun⟩ : ∃ u₀ ≤ input.length + 3, + obtain ⟨u₀, hu₀, hrun⟩ : ∃ u₀ ≤ p.val + 2, (rewindInput k Symbol).runFrom ⟨some .probe, p, w, wp, out⟩ u₀ = ⟨none, 1, w, wp, out⟩ := by rcases Nat.eq_zero_or_pos p.val with hp0 | hp1 diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index fc87f31af..23fb613b6 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -185,4 +185,62 @@ lemma spaceUsed_eq_of_workTapePos {State' : Type*} {input' : List Symbol} refine Finset.sum_congr rfl fun i _ => congrArg Finset.card (Finset.image_congr fun m hm => ?_) exact congrFun (h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm))) i +/-- The cells a head visits between two moments of one run all lie in the visited set. -/ +lemma uIcc_workTapePos_subset_visitedByTapeHead_of_le (cfg : Cfg k Symbol State input) + (i : Fin k) {t₁ t₂ t : ℕ} (h₁ : t₁ ≤ t₂) (h₂ : t₂ ≤ t) : + Finset.uIcc ((tm.runFrom cfg t₁).workTapePos i) ((tm.runFrom cfg t₂).workTapePos i) + ⊆ tm.visitedByTapeHead cfg t i := by + intro z hz + have h := tm.uIcc_workTapePos_subset_visitedByTapeHead (tm.runFrom cfg t₁) i (t₂ - t₁) + rw [← runFrom_add, show t₁ + (t₂ - t₁) = t₂ from by omega] at h + have hsub : tm.visitedByTapeHead (tm.runFrom cfg t₁) (t₂ - t₁) i + ⊆ tm.visitedByTapeHead cfg t i := by + intro y hy + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hy + rw [← runFrom_add] + exact mem_visitedByTapeHead.mpr ⟨t₁ + m, by omega, rfl⟩ + exact hsub (h hz) + +/-- **A head's visited set is an interval**: a head path is connected, so the visited cells are +exactly the integers between the leftmost and the rightmost, and the starting cell is among +them. -/ +lemma exists_visitedByTapeHead_eq_Icc (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : + ∃ l r : ℤ, l ≤ cfg.workTapePos i ∧ cfg.workTapePos i ≤ r ∧ + tm.visitedByTapeHead cfg t i = Finset.Icc l r := by + have hne : (tm.visitedByTapeHead cfg t i).Nonempty := + ⟨cfg.workTapePos i, mem_visitedByTapeHead.mpr ⟨0, by omega, rfl⟩⟩ + have hmem : cfg.workTapePos i ∈ tm.visitedByTapeHead cfg t i := + mem_visitedByTapeHead.mpr ⟨0, by omega, rfl⟩ + refine ⟨(tm.visitedByTapeHead cfg t i).min' hne, (tm.visitedByTapeHead cfg t i).max' hne, + Finset.min'_le _ _ hmem, Finset.le_max' _ _ hmem, ?_⟩ + apply Finset.Subset.antisymm + · intro z hz + exact Finset.mem_Icc.mpr ⟨Finset.min'_le _ _ hz, Finset.le_max' _ _ hz⟩ + · intro z hz + obtain ⟨t₁, ht₁, hpos₁⟩ := mem_visitedByTapeHead.mp (Finset.min'_mem _ hne) + obtain ⟨t₂, ht₂, hpos₂⟩ := mem_visitedByTapeHead.mp (Finset.max'_mem _ hne) + have hzu : z ∈ Finset.uIcc ((tm.runFrom cfg t₁).workTapePos i) + ((tm.runFrom cfg t₂).workTapePos i) := by + rw [hpos₁, hpos₂, Finset.uIcc_of_le (Finset.min'_le _ _ (Finset.max'_mem _ hne))] + exact hz + rcases Nat.le_total t₁ t₂ with h | h + · exact tm.uIcc_workTapePos_subset_visitedByTapeHead_of_le cfg i h (by omega) hzu + · rw [Finset.uIcc_comm] at hzu + exact tm.uIcc_workTapePos_subset_visitedByTapeHead_of_le cfg i h (by omega) hzu + +/-- A run that never moves a work-tape head visits one cell per tape. -/ +lemma spaceUsed_le_of_workTapePos_const (cfg : Cfg k Symbol State input) (u : ℕ) + (h : ∀ m ≤ u, (tm.runFrom cfg m).workTapePos = cfg.workTapePos) : + tm.spaceUsed cfg u ≤ k := by + have hcard : ∀ i, tm.spaceUsedByTape cfg u i ≤ 1 := by + intro i + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Finset.card_singleton + (cfg.workTapePos i))) + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [h m (by omega)] + exact Finset.mem_singleton_self _ + calc tm.spaceUsed cfg u ≤ ∑ _i : Fin k, 1 := Finset.sum_le_sum fun i _ => hcard i + _ = k := by simp + end Turing.MultiTapeTM From a863fdaa1a2d3de9a6b61d2db08ed67df271de8c Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:22:50 +0000 Subject: [PATCH 14/93] chore(MultiTapeTM): modern dite lemmas in val_moveInputPos_le Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/Configuration.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index d63542796..309c18775 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -133,11 +133,11 @@ lemma val_moveInputPos_le {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : (moveInputPos pos m).val ≤ pos.val + 1 := by simp only [moveInputPos] by_cases h : (((pos.val : ℤ) + m.cast).toNat) < n + 2 - · rw [dif_pos h] - rcases m <;> simp [SignType.cast] <;> omega - · rw [dif_neg h] + · rw [dite_eq_left h] + rcases m <;> (simp only [SignType.cast]; omega) + · rw [dite_eq_right h] have := pos.isLt - rcases m <;> simp [SignType.cast] at h <;> omega + rcases m <;> (simp only [SignType.cast] at h; omega) /-- The symbol currently under the input tape head. -/ def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol := From f4d053d452b7f0b7e0836fc5d62bf52b27703fba Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 15:50:58 +0000 Subject: [PATCH 15/93] feat(MultiTapeTM): the tidy normal form theorem MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Every computable function has a tidy machine — one halting in the fully normalised configuration, `wordsCfg (encIn a) none (fun _ => []) (encOut (f a))` — at a constant-factor cost in time and space: tidy tm₀ = markAnchors ; instrument tm₀ ; markCurrent ; rewindInput ; sweepPair 0 ; … ; sweepPair (k₀ − 1) This is the theorem that lets the word-transformer interface absorb arbitrary machines: garbage with embedded blanks cannot be found by scanning, so the run is instrumented with footprints and the sweeps erase each pair guided by them. The assembly is a telescope of abstract-configuration lemmas — each phase composite proved for *any* configuration with the right fields, so the nested `withState` handoffs never materialise as terms — chained by a bundled raw composition lemma (`seq_spec`: runs, activity and space of `tm₁.seq tm₂` from those of the parts, the handoff state being live). The sweeps fold over the pairs with `exists_sweepChain`; the footprint invariant plus one `markCurrent` step make each footprint exactly the visited interval `Finset.Icc (L j) (R j)` of its partner, which is what the sweeps require. The bounds close by counting: the run costs `t`, the rewind costs the head's excursion (≤ t, not the input length), the sweeps cost the visited intervals (≤ s each way), and every product of parameters is dominated by `(k₀+1)²·(bound+1)` with total coefficient 20. Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/NormalForms/Tidy.lean | 747 +++++++++++++++++- 1 file changed, 746 insertions(+), 1 deletion(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean index 7e71ff1c0..98985babe 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -6,7 +6,11 @@ Authors: Christian Reitwiessner module -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Mathlib.Basic.Finite.Sum +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential /-! # The tidy normal form @@ -56,4 +60,745 @@ public theorem TidyComputes.computesFunInTimeAndSpace obtain ⟨τ, hτ, hrun, hspace⟩ := h a exact ⟨τ, hτ, _, hspace, by rw [hrun]; rfl, by rw [hrun]; rfl, rfl⟩ +section Assembly + +open Sequential + +variable {K : ℕ} {S₁ S₂ : Type} {input : List Bool} + +/-- Raw sequential composition of two halting runs: the composite runs the first machine's run and +then the second's, with times and space bounds adding, and stays live throughout — the handoff +itself is a live state. -/ +private lemma seq_spec {tm₁ : MultiTapeTM K Bool S₁} {tm₂ : MultiTapeTM K Bool S₂} + {c : Cfg K Bool (S₁ ⊕ S₂) input} {c₁ : Cfg K Bool S₁ input} {c₂ : Cfg K Bool S₂ input} + {u₁ u₂ s₁' s₂' : ℕ} + (hc : c.state = some (tm₁.seq tm₂).q₀) + (h₁ : tm₁.runFrom (c.withState (some tm₁.q₀)) u₁ = c₁) + (h₁halt : c₁.state = none) + (h₁act : ∀ m < u₁, (tm₁.runFrom (c.withState (some tm₁.q₀)) m).state ≠ none) + (h₁sp : tm₁.spaceUsed (c.withState (some tm₁.q₀)) u₁ ≤ s₁') + (h₂ : tm₂.runFrom (c₁.withState (some tm₂.q₀)) u₂ = c₂) + (h₂halt : c₂.state = none) + (h₂act : ∀ m < u₂, (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m).state ≠ none) + (h₂sp : tm₂.spaceUsed (c₁.withState (some tm₂.q₀)) u₂ ≤ s₂') : + (tm₁.seq tm₂).runFrom c (u₁ + u₂) = c₂.withState (none : Option (S₁ ⊕ S₂)) ∧ + (∀ m < u₁ + u₂, ((tm₁.seq tm₂).runFrom c m).state ≠ none) ∧ + (tm₁.seq tm₂).spaceUsed c (u₁ + u₂) ≤ s₁' + s₂' := by + set cs := c.withState (some tm₁.q₀) with hcs + have hcleft : c = leftCfg tm₂ cs := by + refine Cfg.ext ?_ rfl rfl rfl rfl + rw [hc] + rfl + have hhalt₁ : (tm₁.runFrom cs u₁).state = none := by rw [h₁]; exact h₁halt + have hleft : ∀ m ≤ u₁, (tm₁.seq tm₂).runFrom c m = leftCfg tm₂ (tm₁.runFrom cs m) := by + intro m hm + rw [hcleft, runFrom_leftCfg _ m fun r hr => h₁act r (by omega)] + have hmid : (tm₁.seq tm₂).runFrom c u₁ = rightCfg (c₁.withState (some tm₂.q₀)) := by + rw [hleft u₁ le_rfl, h₁] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [leftCfg, rightCfg, Cfg.withState, h₁halt] + have hright : ∀ m, (tm₁.seq tm₂).runFrom c (u₁ + m) = + rightCfg (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m) := by + intro m + rw [runFrom_add, hmid, runFrom_rightCfg] + refine ⟨?_, ?_, ?_⟩ + · rw [hright u₂, h₂] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [rightCfg, Cfg.withState, h₂halt] + · intro m hm + rcases Nat.le_total m u₁ with h | h + · rw [hleft m h] + simp [leftCfg] + · obtain ⟨m', rfl⟩ : ∃ m', m = u₁ + m' := ⟨m - u₁, by omega⟩ + rw [hright m'] + have h := h₂act m' (by omega) + simpa only [rightCfg, ne_eq, Option.map_eq_none_iff] using h + · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₁ fun m hm => ?_)) h₁sp + rw [hleft m hm] + rfl + · rw [hmid] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₂ fun m hm => ?_)) h₂sp + rw [runFrom_rightCfg] + rfl + +/-- The machine that halts on its first step, changing nothing. -/ +private def haltTM (K : ℕ) : MultiTapeTM K Bool Unit where + q₀ := () + tr _ _ _ := { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + +private lemma haltTM_run (c : Cfg K Bool Unit input) (hc : c.state = some ()) : + (haltTM K).runFrom c 1 = c.withState (none : Option Unit) ∧ + (haltTM K).spaceUsed c 1 ≤ K := by + have hstep : (haltTM K).step c = c.withState (none : Option Unit) := by + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> simp [step, hc, Action.apply, haltTM, Cfg.withState] + have hrun : (haltTM K).runFrom c 1 = c.withState (none : Option Unit) := by + rw [runFrom_succ_eq_step', runFrom_zero, hstep] + refine ⟨hrun, spaceUsed_le_of_workTapePos_const _ _ fun m hm => ?_⟩ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rfl + · rw [hrun] + rfl + +section SweepChain + +variable {k₀ : ℕ} + +private lemma pair_ne {j j' : Fin k₀} (h : j' ≠ j) : + j'.castAdd k₀ ≠ j.castAdd k₀ ∧ j'.castAdd k₀ ≠ j.addNat k₀ ∧ + j'.addNat k₀ ≠ j.castAdd k₀ ∧ j'.addNat k₀ ≠ j.addNat k₀ := by + have hval : j'.val ≠ j.val := fun he => h (Fin.ext he) + have hj := j.isLt + have hj' := j'.isLt + refine ⟨?_, ?_, ?_, ?_⟩ <;> refine Fin.ne_of_val_ne ?_ <;> + simp only [Fin.val_castAdd, Fin.val_addNat] <;> omega + +set_option linter.style.haveILetI false in +/-- Sweeping a list of distinct footprinted pairs, one after the other. -/ +private lemma exists_sweepChain (k₀ : ℕ) (js : List (Fin k₀)) (hnd : js.Nodup) : + ∃ (S : Type) (_ : Finite S) (tm : MultiTapeTM (k₀ + k₀) Bool S), + ∀ (input : List Bool) (c : Cfg (k₀ + k₀) Bool S input) (L R P : Fin k₀ → ℤ), + c.state = some tm.q₀ → + (∀ j ∈ js, L j ≤ 0 ∧ 0 ≤ R j ∧ L j ≤ P j ∧ P j ≤ R j ∧ + c.workTapePos (j.castAdd k₀) = P j ∧ c.workTapePos (j.addNat k₀) = P j ∧ + (∀ z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) ∧ + (∀ z, z < L j ∨ R j < z → c.workTapes (j.castAdd k₀) z = none)) → + ∃ u ≤ (js.map fun j => 4 * (R j - L j).toNat + 8).sum + 1, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + js.foldl (fun w j => Function.update (Function.update w (j.castAdd k₀) + fun _ => none) (j.addNat k₀) fun _ => none) c.workTapes, + js.foldl (fun wp j => Function.update (Function.update wp (j.castAdd k₀) 0) + (j.addNat k₀) 0) c.workTapePos, + c.output⟩ ∧ + tm.spaceUsed c u ≤ + (js.map fun j => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum + (k₀ + k₀) := by + induction js with + | nil => + refine ⟨Unit, inferInstance, haltTM (k₀ + k₀), fun input c L R P hq _ => ?_⟩ + obtain ⟨hrun, hsp⟩ := haltTM_run c hq + refine ⟨1, by simp, fun m hm => ?_, ?_, by simpa using hsp⟩ + · obtain rfl : m = 0 := by omega + rw [runFrom_zero, hq] + simp + · rw [hrun] + rfl + | cons j rest ih => + obtain ⟨hjr, hndr⟩ := List.nodup_cons.mp hnd + obtain ⟨Sr, hSr, tmr, hr⟩ := ih hndr + have hne : j.castAdd k₀ ≠ j.addNat k₀ := by + refine Fin.ne_of_val_ne ?_ + simp only [Fin.val_castAdd, Fin.val_addNat] + omega + obtain ⟨Ss, hSs, tms, hs⟩ := exists_sweepPair (j.castAdd k₀) (j.addNat k₀) hne + haveI := hSr + haveI := hSs + refine ⟨Ss ⊕ Sr, inferInstance, tms.seq tmr, fun input c L R P hq hpairs => ?_⟩ + obtain ⟨h1, h2, h3, h4, h5, h6, h7, h8⟩ := hpairs j (List.mem_cons_self) + -- run the sweep for the first pair + obtain ⟨u₁, hu₁, hact₁, hrun₁, hsp₁⟩ := hs input (c.withState (some tms.q₀)) + (L j) (R j) (P j) rfl h1 h2 h3 h4 h5 h6 h7 h8 + -- the rest of the pairs are untouched by the first sweep + have hrest : ∀ j' ∈ rest, L j' ≤ 0 ∧ 0 ≤ R j' ∧ L j' ≤ P j' ∧ P j' ≤ R j' ∧ + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapePos (j'.castAdd k₀) = P j' ∧ + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapePos (j'.addNat k₀) = P j' ∧ + (∀ z, (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapes (j'.addNat k₀) z = + if z = 0 then some true + else if L j' ≤ z ∧ z ≤ R j' then some false else none) ∧ + (∀ z, z < L j' ∨ R j' < z → + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapes (j'.castAdd k₀) z = none) := by + intro j' hj' + obtain ⟨g1, g2, g3, g4, g5, g6, g7, g8⟩ := hpairs j' (List.mem_cons_of_mem _ hj') + obtain ⟨n1, n2, n3, n4⟩ := pair_ne (j := j) (j' := j') (by rintro rfl; exact hjr hj') + refine ⟨g1, g2, g3, g4, ?_, ?_, fun z => ?_, fun z hz => ?_⟩ + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapePos (j'.castAdd k₀) = + (Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0) + (j'.castAdd k₀) from rfl, + Function.update_of_ne n2, Function.update_of_ne n1] + exact g5 + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapePos (j'.addNat k₀) = + (Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0) + (j'.addNat k₀) from rfl, + Function.update_of_ne n4, Function.update_of_ne n3] + exact g6 + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapes (j'.addNat k₀) = + (Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none) (j'.addNat k₀) from rfl, + Function.update_of_ne n4, Function.update_of_ne n3] + exact g7 z + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapes (j'.castAdd k₀) = + (Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none) (j'.castAdd k₀) from rfl, + Function.update_of_ne n2, Function.update_of_ne n1] + exact g8 z hz + obtain ⟨u₂, hu₂, hact₂, hrun₂, hsp₂⟩ := + hr input ⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ L R P rfl hrest + -- glue the two runs + obtain ⟨hrunC, hactC, hspC⟩ := seq_spec (c := c) hq hrun₁ rfl hact₁ hsp₁ + hrun₂ rfl hact₂ hsp₂ + refine ⟨u₁ + u₂, ?_, hactC, ?_, ?_⟩ + · simp only [List.map_cons, List.sum_cons] + omega + · rw [hrunC] + rfl + · refine le_trans hspC ?_ + simp only [List.map_cons, List.sum_cons] + omega + +/-- Evaluating a fold of pairwise updates: a tape in one of the listed pairs got the new value, +any other keeps its old one. -/ +private lemma foldl_update_pair_eval {γ : Type*} {k₀ : ℕ} (js : List (Fin k₀)) (b : γ) + (w : Fin (k₀ + k₀) → γ) (l : Fin (k₀ + k₀)) : + js.foldl (fun w' j => Function.update (Function.update w' (j.castAdd k₀) b) + (j.addNat k₀) b) w l = + if ∃ j ∈ js, l = j.castAdd k₀ ∨ l = j.addNat k₀ then b else w l := by + induction js generalizing w with + | nil => simp + | cons j rest ih => + rw [List.foldl_cons, ih] + by_cases hmem : ∃ j' ∈ rest, l = j'.castAdd k₀ ∨ l = j'.addNat k₀ + · rw [ite_eq_left hmem, ite_eq_left ?_] + obtain ⟨j', hj', hl⟩ := hmem + exact ⟨j', List.mem_cons_of_mem _ hj', hl⟩ + · rw [ite_eq_right hmem] + by_cases h1 : l = j.addNat k₀ + · subst h1 + rw [Function.update_self, ite_eq_left ⟨j, List.mem_cons_self, Or.inr rfl⟩] + · rw [Function.update_of_ne h1] + by_cases h2 : l = j.castAdd k₀ + · subst h2 + rw [Function.update_self, ite_eq_left ⟨j, List.mem_cons_self, Or.inl rfl⟩] + · rw [Function.update_of_ne h2, ite_eq_right ?_] + rintro ⟨j', hj', hl⟩ + rcases List.mem_cons.mp hj' with rfl | hj' + · exact hl.elim h2 h1 + · exact hmem ⟨j', hj', hl⟩ + +/-- Every tape belongs to one of the pairs. -/ +private lemma exists_pair_mem {k₀ : ℕ} (l : Fin (k₀ + k₀)) : + ∃ j ∈ List.finRange k₀, l = j.castAdd k₀ ∨ l = j.addNat k₀ := by + induction l using Fin.addCases with + | left j => exact ⟨j, List.mem_finRange j, Or.inl rfl⟩ + | right j => exact ⟨j, List.mem_finRange j, Or.inr (by rw [Fin.natAdd_eq_addNat])⟩ + +end SweepChain + +set_option linter.style.haveILetI false in +/-- **The tidy normal form theorem.** Every computable function has a tidy machine, at a +constant-factor cost in time and space: anchor the footprints, run the instrumented machine, +mark the final head positions, rewind the input head, and sweep every pair clean. -/ +public theorem exists_tidy {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + {f : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace f encIn encOut t s) : + ∃ (c k : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), + TidyComputes tm encIn encOut f + (fun a => c * (t a + 1)) (fun a => c * (s a + 1) + k) := by + classical + obtain ⟨k₀, State₀, hfin₀, tm₀, hfun⟩ := h + obtain ⟨SA, hSA, tmA, hA⟩ := exists_markAnchors k₀ Bool true + obtain ⟨SC, hSC, tmC, hC⟩ := exists_markCurrent k₀ Bool false + obtain ⟨SD, hSD, tmD, hD⟩ := exists_rewindInput (k₀ + k₀) Bool + obtain ⟨SE, hSE, tmE, hE⟩ := exists_sweepChain k₀ (List.finRange k₀) (List.nodup_finRange k₀) + haveI := hfin₀; haveI := hSA; haveI := hSC; haveI := hSD; haveI := hSE + refine ⟨20 * (k₀ + 1) * (k₀ + 1), k₀ + k₀, + SA ⊕ (State₀ ⊕ (SC ⊕ (SD ⊕ SE))), inferInstance, + tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))), fun a => ?_⟩ + -- the run of the original machine, at its first halting time + obtain ⟨t', ht', s', hs', hhalt', hout', hspace'⟩ := hfun a + obtain ⟨u₀, hu₀, hhalt₀, hact₀⟩ := + exists_minimal_halting_time tm₀ (tm₀.initCfg (encIn a)) t' hhalt' + have hout₀ : (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).output = encOut (f a) := by + rw [← runFrom_eq_of_halt tm₀ (tm₀.initCfg (encIn a)) hu₀ hhalt₀] + exact hout' + have hsp₀ : tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ ≤ s a := by + have hm : tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ ≤ + tm₀.spaceUsed (tm₀.initCfg (encIn a)) t' := + spaceUsed_mono tm₀ (tm₀.initCfg (encIn a)) hu₀ + omega + -- the visited interval and final head position of each tape + choose L R hL0 h0R hIcc using + fun j => exists_visitedByTapeHead_eq_Icc (tm := tm₀) (tm₀.initCfg (encIn a)) u₀ j + set P : Fin k₀ → ℤ := fun j => (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapePos j with hP + have hPmem : ∀ j, L j ≤ P j ∧ P j ≤ R j := by + intro j + have hmem := tm₀.mem_visitedByTapeHead_self (tm₀.initCfg (encIn a)) u₀ j + rw [hIcc j] at hmem + exact Finset.mem_Icc.mp hmem + have hGconf : ∀ j z, z < L j ∨ R j < z → + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j z = none := by + intro j z hz + by_contra hne + have hmem : z ∈ tm₀.visitedByTapeHead (tm₀.initCfg (encIn a)) u₀ j := + tm₀.mem_visitedByTapeHead_of_workTapes_ne j u₀ z hne + rw [hIcc j] at hmem + have := Finset.mem_Icc.mp hmem + omega + -- phase A: place the anchors + obtain ⟨eAstate, eAip, eAout, eApos, eAcast, eAanchor⟩ := hA (encIn a) + (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) rfl + -- the interval data, in usable form + have hL0' : ∀ j, L j ≤ 0 := by + intro j + have := hL0 j + simpa [Cfg.init] using this + have h0R' : ∀ j, 0 ≤ R j := by + intro j + have := h0R j + simpa [Cfg.init] using this + -- phases D and E, from any configuration with the right fields + have hDE : ∀ (c : Cfg (k₀ + k₀) Bool (SD ⊕ SE) (encIn a)), + c.state = some (tmD.seq tmE).q₀ → + c.inputPos.val ≤ u₀ + 1 → + c.output = encOut (f a) → + (∀ j, c.workTapes (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j) → + (∀ j z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) → + (∀ j, c.workTapePos (j.castAdd k₀) = P j) → + (∀ j, c.workTapePos (j.addNat k₀) = P j) → + ∃ u ≤ (u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1), + (tmD.seq tmE).runFrom c u = wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, ((tmD.seq tmE).runFrom c m).state ≠ none) ∧ + (tmD.seq tmE).spaceUsed c u ≤ (k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀)) := by + intro c hstate hip hout hcast hfp hposc hposn + -- rewind the input head + obtain ⟨uD, huD, hactD, hrunD, hframeD⟩ := hD (encIn a) (c.withState (some tmD.q₀)) rfl + -- sweep every pair + have hpairsE : ∀ j ∈ List.finRange k₀, L j ≤ 0 ∧ 0 ≤ R j ∧ L j ≤ P j ∧ P j ≤ R j ∧ + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapePos (j.castAdd k₀) = P j ∧ + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapePos (j.addNat k₀) = P j ∧ + (∀ z, ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) ∧ + (∀ z, z < L j ∨ R j < z → ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.castAdd k₀) z = none) := by + intro j _ + refine ⟨hL0' j, h0R' j, (hPmem j).1, (hPmem j).2, hposc j, hposn j, fun z => hfp j z, + fun z hz => ?_⟩ + rw [show ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.castAdd k₀) = c.workTapes (j.castAdd k₀) from rfl, + hcast j] + exact hGconf j z hz + obtain ⟨uE, huE, hactE, hrunE, hspE⟩ := hE (encIn a) + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState (some tmE.q₀)) L R P rfl hpairsE + -- glue the two phases + obtain ⟨hrunC, hactC, hspC⟩ := seq_spec hstate hrunD rfl hactD + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => (hframeD m hm).2.1) + hrunE rfl hactE hspE + have huD' : uD ≤ c.inputPos.val + 2 := by simpa using huD + refine ⟨uD + uE, by omega, ?_, hactC, le_trans hspC (by omega)⟩ + rw [hrunC] + -- the swept configuration is the tidy one + refine Cfg.ext rfl rfl ?_ ?_ ?_ + · funext l + exact ((foldl_update_pair_eval (List.finRange k₀) (fun _ => none) + ((c.withState (some tmD.q₀)).workTapes) l).trans + (by rw [ite_eq_left (exists_pair_mem l)])).trans tapeOfList_nil.symm + · funext l + exact (foldl_update_pair_eval (List.finRange k₀) 0 + ((c.withState (some tmD.q₀)).workTapePos) l).trans + (by rw [ite_eq_left (exists_pair_mem l)]; rfl) + · exact hout + -- the marks laid down before the final step, together with the final position, are the interval + have hmarksIccT : ∀ (j : Fin k₀) (z : ℤ), + ((z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j)) ∨ z = P j) ↔ + (L j ≤ z ∧ z ≤ R j) := by + intro j z + rw [show (L j ≤ z ∧ z ≤ R j) ↔ z ∈ Finset.Icc (L j) (R j) from (Finset.mem_Icc).symm, + ← hIcc j, mem_visitedByTapeHead] + constructor + · rintro (hz | rfl) + · obtain ⟨m, hm, rfl⟩ := Finset.mem_image.mp hz + exact ⟨m, by have := Finset.mem_range.mp hm; omega, rfl⟩ + · exact ⟨u₀, by omega, rfl⟩ + · rintro ⟨m, hm, rfl⟩ + rcases Nat.lt_or_ge m u₀ with hlt | hge + · exact Or.inl (Finset.mem_image.mpr ⟨m, Finset.mem_range.mpr hlt, rfl⟩) + · right + rw [show m = u₀ from by omega] + -- phases C, D and E: mark the final positions, then rewind and sweep + have hCDE : ∀ (c : Cfg (k₀ + k₀) Bool (SC ⊕ (SD ⊕ SE)) (encIn a)), + c.state = some (tmC.seq (tmD.seq tmE)).q₀ → + c.inputPos.val ≤ u₀ + 1 → + c.output = encOut (f a) → + (∀ j, c.workTapes (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j) → + (∀ j z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) then some false + else none) → + (∀ j, c.workTapePos (j.castAdd k₀) = P j) → + (∀ j, c.workTapePos (j.addNat k₀) = P j) → + ∃ u ≤ 1 + ((u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1)), + (tmC.seq (tmD.seq tmE)).runFrom c u = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, ((tmC.seq (tmD.seq tmE)).runFrom c m).state ≠ none) ∧ + (tmC.seq (tmD.seq tmE)).spaceUsed c u ≤ (k₀ + k₀) + ((k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀))) := by + intro c hstate hip hout hcast hfp hposc hposn + obtain ⟨eCstate, eCip, eCout, eCpos, eCcast, eCmark⟩ := + hC (encIn a) (c.withState (some tmC.q₀)) rfl + -- after the mark, the footprints are exactly the intervals + have hfpC : ∀ (j : Fin k₀) (z : ℤ), + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapes (j.addNat k₀) z = + if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none := by + intro j z + have hthis := congrFun (eCmark j) z + simp only [Cfg.withState_workTapes, Cfg.withState_workTapePos] at hthis + rw [hposn j, hfp j z, hfp j (P j)] at hthis + rw [hthis] + by_cases hz : z = 0 + · subst hz + simp + · simp only [ite_eq_right hz] + by_cases hmem : z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) + · rw [ite_eq_left hmem, ite_eq_left ((hmarksIccT j z).mp (Or.inl hmem))] + · rw [ite_eq_right hmem] + by_cases hzP : z = P j + · subst hzP + rw [ite_eq_right hz, ite_eq_right hmem, ite_eq_left ⟨rfl, rfl⟩, + ite_eq_left ((hmarksIccT j (P j)).mp (Or.inr rfl))] + · have hnot : ¬ (L j ≤ z ∧ z ≤ R j) := by + intro hin + rcases (hmarksIccT j z).mpr hin with hm | hm + · exact hmem hm + · exact hzP hm + rw [ite_eq_right hnot, ite_eq_right (fun hcond => hzP hcond.1)] + -- hand over to the rewind and the sweeps + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hDE + ((tmC.runFrom (c.withState (some tmC.q₀)) 1).withState (some (tmD.seq tmE).q₀)) + rfl + ((by + rw [eCip] + simpa using hip) : + ((tmC.runFrom (c.withState (some tmC.q₀)) 1).inputPos : ℕ) ≤ u₀ + 1) + ((by + rw [eCout] + simpa using hout) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).output = encOut (f a)) + (fun j => (eCcast j).trans (hcast j)) + (fun j z => hfpC j z) + (fun j => ((by + rw [eCpos] + simpa using hposc j) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapePos (j.castAdd k₀) = P j)) + (fun j => ((by + rw [eCpos] + simpa using hposn j) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapePos (j.addNat k₀) = P j)) + obtain ⟨hrunG, hactG, hspG⟩ := seq_spec hstate rfl eCstate + (fun m hm => by + obtain rfl : m = 0 := by omega + rw [runFrom_zero] + simp) + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => by + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · exact eCpos) + hrun₂ rfl hact₂ hsp₂ + refine ⟨1 + u₂, by omega, ?_, hactG, le_trans hspG (by omega)⟩ + rw [hrunG] + rfl + -- phases B to E: the instrumented run, then the cleanup + have hBCDE : ∀ (c : Cfg (k₀ + k₀) Bool (State₀ ⊕ (SC ⊕ (SD ⊕ SE))) (encIn a)), + c.state = some ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).q₀ → + c.inputPos = 1 → + (∀ j : Fin k₀, c.workTapes (j.castAdd k₀) = fun _ => none) → + (∀ (j : Fin k₀) (z : ℤ), c.workTapes (j.addNat k₀) z = + if z = 0 then some true else none) → + (∀ l, c.workTapePos l = 0) → + c.output = [] → + ∃ u ≤ u₀ + (1 + ((u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1))), + ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).runFrom c u = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, (((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).runFrom c m).state ≠ + none) ∧ + ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).spaceUsed c u ≤ + 2 * s a + ((k₀ + k₀) + ((k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀)))) := by + intro c hstate hip hcastB hanchorB hposB houtB + -- the instrumented start projects to the original start + have hproj : projCfg (c.withState (some tm₀.q₀)) = tm₀.initCfg (encIn a) := by + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simpa using hip + · funext j z + simpa using congrFun (hcastB j) z + · funext j + simpa using hposB (j.castAdd k₀) + · simpa using houtB + have hmirror : ∀ m, tm₀.runFrom (tm₀.initCfg (encIn a)) m = + projCfg ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m) := by + intro m + rw [← hproj] + exact runFrom_projCfg tm₀ false (c.withState (some tm₀.q₀)) m + have hstateB : ∀ m, ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m).state = + (tm₀.runFrom (tm₀.initCfg (encIn a)) m).state := by + intro m + rw [hmirror m] + rfl + have hactB : ∀ m < u₀, + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m).state ≠ none := by + intro m hm + rw [hstateB] + exact hact₀ m hm + have hhaltB : ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).state = + none := by + rw [hstateB] + exact hhalt₀ + have halignB : ∀ j : Fin k₀, (c.withState (some tm₀.q₀)).workTapePos (j.addNat k₀) = + (c.withState (some tm₀.q₀)).workTapePos (j.castAdd k₀) := by + intro j + have h1 := hposB (j.addNat k₀) + have h2 := hposB (j.castAdd k₀) + simp only [Cfg.withState_workTapePos] + omega + -- hand over to the marking, the rewind and the sweeps + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hCDE + (((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).withState + (some (tmC.seq (tmD.seq tmE)).q₀)) + rfl + ((by + rw [show ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).inputPos = + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).inputPos from by rw [hmirror u₀]; rfl] + have h := inputPos_runFrom_le tm₀ (tm₀.initCfg (encIn a)) u₀ + have h2 : ((tm₀.initCfg (encIn a)).inputPos : ℕ) = 1 := rfl + omega) : + (((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).inputPos : ℕ) ≤ + u₀ + 1) + ((by + rw [show ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).output = + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).output from by rw [hmirror u₀]; rfl] + exact hout₀) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).output = encOut (f a)) + (fun j => ((by rw [hmirror u₀]; rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapes + (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j)) + (fun j z => ((by + rw [congrFun (workTapes_addNat_instrument (c.withState (some tm₀.q₀)) j (halignB j) + u₀ hactB) z] + rw [show (c.withState (some tm₀.q₀)).workTapes (j.addNat k₀) z = + c.workTapes (j.addNat k₀) z from rfl, hanchorB j z] + have himg : (Finset.range u₀).image + (fun m => ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) + m).workTapePos (j.castAdd k₀)) = + (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) := by + refine Finset.image_congr fun m _ => ?_ + rw [hmirror m] + rfl + rw [himg] + by_cases hz : z = 0 + · subst hz + simp + · simp only [ite_eq_right hz]) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapes + (j.addNat k₀) z = if z = 0 then some true + else if z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) then some false + else none)) + (fun j => ((by + simp only [hP] + rw [hmirror u₀] + rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapePos + (j.castAdd k₀) = P j)) + (fun j => ((by + rw [workTapePos_addNat_instrument (c.withState (some tm₀.q₀)) j (halignB j) u₀ hactB] + simp only [hP] + rw [hmirror u₀] + rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapePos + (j.addNat k₀) = P j)) + have hspB : (tm₀.instrument false).spaceUsed (c.withState (some tm₀.q₀)) u₀ ≤ 2 * s a := by + rw [spaceUsed_instrument tm₀ false (c.withState (some tm₀.q₀)) u₀ halignB hactB, hproj] + omega + obtain ⟨hrunG, hactG, hspG⟩ := seq_spec hstate rfl hhaltB hactB hspB hrun₂ + rfl hact₂ hsp₂ + refine ⟨u₀ + u₂, by omega, ?_, hactG, le_trans hspG (by omega)⟩ + rw [hrunG] + rfl + -- the interval sums, bounded by the original machine's space + have hcard : ∀ j, (R j - L j).toNat + 1 = + tm₀.spaceUsedByTape (tm₀.initCfg (encIn a)) u₀ j := by + intro j + rw [spaceUsedByTape, hIcc j, Int.card_Icc] + have h1 := hL0' j + have h2 := h0R' j + omega + have hsumX : (∑ j : Fin k₀, (R j - L j).toNat) + k₀ = + tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ := by + have h1 : (∑ j : Fin k₀, ((R j - L j).toNat + 1)) = + tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ := + Finset.sum_congr rfl fun j _ => hcard j + rw [Finset.sum_add_distrib] at h1 + simpa using h1 + have hsX_s : (∑ j : Fin k₀, (R j - L j).toNat) ≤ s a := by omega + have hsX_t : (∑ j : Fin k₀, (R j - L j).toNat) ≤ k₀ * u₀ := by + have hlin := spaceUsed_linear (tm := tm₀) (tm₀.initCfg (encIn a)) u₀ + omega + have hs4 : ((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum = + 4 * (∑ j : Fin k₀, (R j - L j).toNat) + 8 * k₀ := by + rw [← Fin.sum_univ_def, Finset.sum_add_distrib, ← Finset.mul_sum] + simp [mul_comm] + have hs2 : ((List.finRange k₀).map fun j => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum = + 2 * (∑ j : Fin k₀, (R j - L j).toNat) + (4 + (k₀ + k₀)) * k₀ := by + rw [← Fin.sum_univ_def, + show (fun j : Fin k₀ => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)) = + (fun j => 2 * (R j - L j).toNat + (4 + (k₀ + k₀))) from funext fun j => by omega, + Finset.sum_add_distrib, ← Finset.mul_sum] + simp [mul_comm] + -- discharge phase A and glue at the top + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hBCDE + ((tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).withState + (some ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).q₀)) + rfl + ((by rw [eAip]; rfl) : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).inputPos = 1) + (fun j => (eAcast j : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapes (j.castAdd k₀) = fun _ => none)) + (fun j z => ((by + rw [congrFun (eAanchor j) z, + show (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)).workTapePos (j.addNat k₀) = (0 : ℤ) from rfl] + by_cases hz : z = 0 + · subst hz + rw [Function.update_self] + simp + · rw [Function.update_of_ne hz, ite_eq_right hz] + rfl) : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapes (j.addNat k₀) z = + if z = 0 then some true else none)) + (fun l => (congrFun eApos l : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapePos l = 0)) + (eAout : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).output = []) + obtain ⟨hrunT, hactT, hspT⟩ := seq_spec + (c := (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + rfl rfl eAstate + (fun m hm => by + obtain rfl : m = 0 := by omega + rw [runFrom_zero] + simp) + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => by + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · exact eApos) + hrun₂ rfl hact₂ hsp₂ + -- assemble the run and the bounds + have hkk : k₀ ≤ (k₀ + 1) * (k₀ + 1) := by + have h := Nat.le_mul_of_pos_left (k₀ + 1) (show 0 < k₀ + 1 by omega) + omega + have hM : ∀ v x : ℕ, (x ≤ k₀ * v ∨ x ≤ v ∨ x ≤ k₀ * k₀ ∨ x ≤ k₀ ∨ x ≤ 1) → + x ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + intro v x hx + have h1 : k₀ * v ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := Nat.mul_le_mul hkk (by omega) + have h2 : v + 1 ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_left (v + 1) (Nat.mul_pos (by omega) (by omega)) + have h3 : k₀ * k₀ ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + have ha : k₀ * k₀ ≤ (k₀ + 1) * (k₀ + 1) := Nat.mul_le_mul (by omega) (by omega) + have hb : (k₀ + 1) * (k₀ + 1) ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_right _ (by omega) + omega + have h4 : k₀ ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + have hb : (k₀ + 1) * (k₀ + 1) ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_right _ (by omega) + omega + omega + refine ⟨1 + u₂, ?_, ?_, ?_⟩ + · -- the time bound + change 1 + u₂ ≤ 20 * (k₀ + 1) * (k₀ + 1) * (t a + 1) + rw [hs4] at hu₂ + have hb : 1 + u₂ ≤ 4 * (k₀ * u₀) + (2 * u₀ + (8 * k₀ + 6)) := by omega + have m1 := hM u₀ (k₀ * u₀) (Or.inl le_rfl) + have m2 := hM u₀ u₀ (Or.inr (Or.inl le_rfl)) + have m3 := hM u₀ k₀ (Or.inr (Or.inr (Or.inr (Or.inl le_rfl)))) + have m4 := hM u₀ 1 (Or.inr (Or.inr (Or.inr (Or.inr le_rfl)))) + have hbig : 1 + u₂ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) := by omega + have hmono : 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) ≤ + 20 * ((k₀ + 1) * (k₀ + 1) * (t a + 1)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul_left _ (by omega)) + calc 1 + u₂ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) := hbig + _ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (t a + 1)) := hmono + _ = 20 * (k₀ + 1) * (k₀ + 1) * (t a + 1) := by rw [← mul_assoc, ← mul_assoc] + · -- the halting configuration + rw [hrunT] + rfl + · -- the space bound + change (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).spaceUsed + ((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + (1 + u₂) ≤ 20 * (k₀ + 1) * (k₀ + 1) * (s a + 1) + (k₀ + k₀) + have hs2' : ((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum = + 2 * (∑ j : Fin k₀, (R j - L j).toNat) + (4 * k₀ + (k₀ * k₀ + k₀ * k₀)) := by + rw [hs2, Nat.add_mul, Nat.add_mul] + rw [hs2'] at hspT + have m1 := hM (s a) (s a) (Or.inr (Or.inl le_rfl)) + have m2 := hM (s a) (k₀ * k₀) (Or.inr (Or.inr (Or.inl le_rfl))) + have m3 := hM (s a) k₀ (Or.inr (Or.inr (Or.inr (Or.inl le_rfl)))) + have hbig : (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).spaceUsed + ((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + (1 + u₂) ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (s a + 1)) := by omega + calc _ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (s a + 1)) := hbig + _ ≤ 20 * (k₀ + 1) * (k₀ + 1) * (s a + 1) + (k₀ + k₀) := by + rw [← mul_assoc, ← mul_assoc] + omega + + +end Assembly + + + end Turing.MultiTapeTM From 2884eba5b8d1272ae6167c23a39ff9147af0d1b0 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 16:29:11 +0000 Subject: [PATCH 16/93] feat(MultiTapeTM): redirecting the output to a work tape MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `outputToTape tm` writes what tm would output onto a fresh last work tape whose head stands at the write frontier — design due to Samuel Schlesinger (#872). The frontier is the output's length, a function of the configuration, so the redirection is an unconditional step-semiconjugation: the run lemma is one `runFrom_comm_of_step`, and the space cost is exactly the written output (spaceUsed_outputToTape), via the new `length_output_mono`. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../MultiTape/Plumbing/OutputToTape.lean | 177 ++++++++++++++++++ 2 files changed, 178 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean diff --git a/Cslib.lean b/Cslib.lean index 3b2cb781c..263e5ed3e 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -62,6 +62,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrume public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean new file mode 100644 index 000000000..e6c0daef6 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Redirecting the output to a work tape + +`outputToTape tm` behaves like `tm`, except that whatever `tm` would append to the write-only +output tape is written on a fresh work tape instead, whose head always stands at the write +frontier. The design is due to Samuel Schlesinger (leanprover/cslib#872). + +Since the output is append-only, the frontier position is a *function of the configuration* — +the length of the output so far — so the redirected machine mirrors the original through the +configuration map `outCfg`, an unconditional step-semiconjugation: the run lemma is one +application of `Turing.MultiTapeTM.runFrom_comm_of_step`, with no induction. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- `tm`, with its output writes redirected onto a fresh last work tape, whose head always stands +at the write frontier. -/ +@[expose] public def outputToTape (tm : MultiTapeTM k Symbol State) : + MultiTapeTM (k + 1) Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work j.castSucc + { inputTape := a.inputTape + workTapes := Fin.lastCases + (match a.output with + | none => (none, 0) + | some s => (some (some s), 1)) + (fun j => a.workTapes j) + output := none + state := a.state } + +/-- A configuration of `tm`, as the redirected machine sees it: the output so far sits on the +last work tape with the head at its end, and the real output is empty. -/ +@[expose, simps] public def outCfg (c : Cfg k Symbol State input) : + Cfg (k + 1) Symbol State input := + ⟨c.state, c.inputPos, + Fin.lastCases (tapeOfList c.output) (fun j => c.workTapes j), + Fin.lastCases (c.output.length : ℤ) (fun j => c.workTapePos j), + []⟩ + +@[simp] +public lemma outCfg_inputSymbol (c : Cfg k Symbol State input) : + (outCfg c).inputSymbol = c.inputSymbol := rfl + +@[simp] +public lemma outCfg_workTapes_last (c : Cfg k Symbol State input) : + (outCfg c).workTapes (Fin.last k) = tapeOfList c.output := by + change Fin.lastCases (motive := fun _ => ℤ → Option Symbol) (tapeOfList c.output) + (fun j => c.workTapes j) (Fin.last k) = _ + exact Fin.lastCases_last + +@[simp] +public lemma outCfg_workTapes_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapes j.castSucc = c.workTapes j := by + change Fin.lastCases (motive := fun _ => ℤ → Option Symbol) (tapeOfList c.output) + (fun j => c.workTapes j) j.castSucc = _ + exact Fin.lastCases_castSucc j + +@[simp] +public lemma outCfg_workTapePos_last (c : Cfg k Symbol State input) : + (outCfg c).workTapePos (Fin.last k) = (c.output.length : ℤ) := by + change Fin.lastCases (motive := fun _ => ℤ) ((c.output.length : ℤ)) + (fun j => c.workTapePos j) (Fin.last k) = _ + exact Fin.lastCases_last + +@[simp] +public lemma outCfg_workTapePos_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapePos j.castSucc = c.workTapePos j := by + change Fin.lastCases (motive := fun _ => ℤ) ((c.output.length : ℤ)) + (fun j => c.workTapePos j) j.castSucc = _ + exact Fin.lastCases_castSucc j + +@[simp] +public lemma outCfg_workTapeSymbols_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapeSymbols j.castSucc = c.workTapeSymbols j := by + simp [Cfg.workTapeSymbols] + +/-- The redirection is a step-semiconjugation. -/ +public lemma step_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol State input) : + tm.outputToTape.step (outCfg c) = outCfg (tm.step c) := by + cases hq : c.state with + | none => + have h1 : (outCfg c).state = none := hq + simp only [step, h1, hq] + | some q => + have h1 : (outCfg c).state = some q := hq + have hargs : (fun j : Fin k => (outCfg c).workTapeSymbols j.castSucc) = + c.workTapeSymbols := funext fun j => outCfg_workTapeSymbols_castSucc c j + simp only [step, h1, hq, outputToTape] + rw [hargs, outCfg_inputSymbol] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + induction l using Fin.lastCases with + | last => + rcases hout : (tm.tr q c.inputSymbol c.workTapeSymbols).output with _ | sym + · simp [Action.apply, hout, Fin.lastCases_last] + · simp only [Action.apply, hout, Fin.lastCases_last, outCfg_workTapes_last, + outCfg_workTapePos_last, Option.toList_some, tapeOfList_append_single] + | cast j => + rcases hw : ((tm.tr q c.inputSymbol c.workTapeSymbols).workTapes j).1 with _ | w <;> + simp [Action.apply, hw, Fin.lastCases_castSucc] + · funext l + induction l using Fin.lastCases with + | last => + rcases hout : (tm.tr q c.inputSymbol c.workTapeSymbols).output with _ | sym <;> + simp [Action.apply, hout, Fin.lastCases_last, SignType.cast] + | cast j => + simp [Action.apply, Fin.lastCases_castSucc] + +/-- The redirected run mirrors the original. -/ +public lemma runFrom_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol State input) + (n : ℕ) : + tm.outputToTape.runFrom (outCfg c) n = outCfg (tm.runFrom c n) := + runFrom_comm_of_step outCfg (step_outCfg tm) c n + +/-- The output can only grow. -/ +public lemma length_output_mono (tm : MultiTapeTM k Symbol State) + (c : Cfg k Symbol State input) (d : ℕ) : + c.output.length ≤ (tm.runFrom c d).output.length := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + omega + +/-- Redirecting the output costs the length of the output, and nothing else: the frontier head +walks over exactly the cells of the written output. -/ +public lemma spaceUsed_outputToTape (tm : MultiTapeTM k Symbol State) + (c : Cfg k Symbol State input) (u : ℕ) : + tm.outputToTape.spaceUsed (outCfg c) u ≤ + tm.spaceUsed c u + ((tm.runFrom c u).output.length + 1) := by + have hmirror : ∀ m, tm.outputToTape.runFrom (outCfg c) m = outCfg (tm.runFrom c m) := + fun m => runFrom_outCfg tm c m + have hcast : ∀ j : Fin k, tm.outputToTape.visitedByTapeHead (outCfg c) u j.castSucc = + tm.visitedByTapeHead c u j := by + intro j + refine Finset.image_congr fun m _ => ?_ + rw [hmirror m, outCfg_workTapePos_castSucc] + have hlast : tm.outputToTape.visitedByTapeHead (outCfg c) u (Fin.last k) ⊆ + Finset.Icc (c.output.length : ℤ) ((tm.runFrom c u).output.length : ℤ) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hmirror m, outCfg_workTapePos_last] + have h1 := length_output_mono tm c m + have h2 : (tm.runFrom c m).output.length ≤ (tm.runFrom c u).output.length := by + have h := length_output_mono tm (tm.runFrom c m) (u - m) + rw [← runFrom_add, show m + (u - m) = u from by omega] at h + exact h + exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + calc tm.outputToTape.spaceUsed (outCfg c) u + = (∑ j : Fin k, tm.outputToTape.spaceUsedByTape (outCfg c) u j.castSucc) + + tm.outputToTape.spaceUsedByTape (outCfg c) u (Fin.last k) := + Fin.sum_univ_castSucc _ + _ ≤ tm.spaceUsed c u + ((tm.runFrom c u).output.length + 1) := by + refine Nat.add_le_add (le_of_eq ?_) ?_ + · exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + · calc tm.outputToTape.spaceUsedByTape (outCfg c) u (Fin.last k) + ≤ (Finset.Icc (c.output.length : ℤ) + ((tm.runFrom c u).output.length : ℤ)).card := Finset.card_le_card hlast + _ = (((tm.runFrom c u).output.length : ℤ) + 1 - (c.output.length : ℤ)).toNat := + Int.card_Icc _ _ + _ ≤ (tm.runFrom c u).output.length + 1 := by omega + +end Turing.MultiTapeTM From 92efab57cbab6d18bb30aa192aeed053f014b0a8 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 16:51:58 +0000 Subject: [PATCH 17/93] feat(MultiTapeTM): reading the input from a work tape MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `inputFromTape tm mark` reads its input from a virtual input work tape instead of the real input tape, which it never touches. Redirecting the input through a work tape is due to Samuel Schlesinger (#872); there the ambiguity between the two input boundaries — both blank, but the head clamps differently at each — is resolved by a boundary classification in the finite control. Here a flag tape carries a single mark at cell -1, in the spirit of the tidy normal form's footprint anchors, so the left boundary is recognised by reading the flag; the simulated configuration then determines the simulating one and the redirection is an unconditional step-semiconjugation. This commit establishes the machine, the embedding `inCfg`, the projections, and the three facts the semiconjugation rests on: the virtual head reads what the input head reads (`vip_read`), the flag marks exactly the left boundary (`flag_read`), and the clamped move tracks the input head (`clampMove_correct`). The clamp reasoning goes through `val_moveInputPos_eq`, a new `omega`-friendly form of the input head's post-move position as a clamped integer, added to Configuration.lean along with `inputSymbol_eq_none_of_boundary`. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../Turing/MultiTape/Configuration.lean | 22 +++ .../MultiTape/Plumbing/InputFromTape.lean | 187 ++++++++++++++++++ .../MultiTape/Plumbing/OutputToTape.lean | 2 +- 4 files changed, 211 insertions(+), 1 deletion(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean diff --git a/Cslib.lean b/Cslib.lean index 263e5ed3e..c5eca2e0b 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -62,6 +62,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrume public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 309c18775..24a44c39c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -139,12 +139,34 @@ lemma val_moveInputPos_le {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : have := pos.isLt rcases m <;> (simp only [SignType.cast] at h; omega) +/-- The value of the input head after a move, as a clamped integer. `omega`-friendly. -/ +lemma val_moveInputPos_eq {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : + ((moveInputPos pos m).val : ℤ) = min ((n : ℤ) + 1) (max 0 ((pos.val : ℤ) + (m.cast : ℤ))) := by + simp only [moveInputPos] + have hmc : (m.cast : ℤ) = -1 ∨ (m.cast : ℤ) = 0 ∨ (m.cast : ℤ) = 1 := by + rcases m with _ | _ | _ <;> simp [SignType.cast] + by_cases h : (((pos.val : ℤ) + (m.cast : ℤ)).toNat) < n + 2 + · rw [dite_eq_left (by exact h)] + have := pos.isLt + push_cast + omega + · rw [dite_eq_right (by exact h)] + have := pos.isLt + push_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 else if h₂ : cfg.inputPos = input.length + 1 then none else input[cfg.inputPos.val - 1]'(by grind) +/-- At either boundary of the input, the head reads a blank. -/ +lemma inputSymbol_eq_none_of_boundary {cfg : Cfg k Symbol State input} + (h : cfg.inputPos.val = 0 ∨ cfg.inputPos.val = input.length + 1) : + cfg.inputSymbol = none := by + grind [Cfg.inputSymbol] + @[simp] lemma inputSymbolInner {cfg : Cfg k Symbol State input} (p : ℕ) (h₁ : cfg.inputPos.val = 1 + p) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean new file mode 100644 index 000000000..f93e5ff57 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Reading the input from a work tape + +`inputFromTape tm mark` behaves like `tm`, except that it reads its input from a work tape — the +*virtual input tape* — instead of the real one, which it never touches. The virtual input head +lives at cell `p - 1` when the simulated input head is at position `p`, so the word cells +`0, …, len - 1` are the input positions `1, …, len` and the two boundary positions read the blanks +at cells `-1` and `len`. + +The one thing a blank cell cannot tell the machine is *which* boundary it is at — and it must +know, because the input head clamps there. Redirecting the input through a work tape is due to +Samuel Schlesinger (leanprover/cslib#872), who resolves the ambiguity by tracking a boundary +classification in the finite control. Here a *flag tape* is used instead, in the spirit of the +footprint anchors of the tidy normal form: a second fresh tape, whose head moves in lockstep with +the virtual input head, carries a single `mark` at cell `-1` — placed by a two-step prologue — so +the left boundary is recognised by reading the flag. Reading blank on both tapes then means the +right boundary. With the classification on a tape rather than in the control, the simulated +configuration determines the simulating one, and the redirection is an unconditional +step-semiconjugation: one `Turing.MultiTapeTM.runFrom_comm_of_step`, no bisimulation. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} + +/-- The clamped move of the virtual input head: at the left boundary (blank under the virtual +head, flag marked) left moves are blocked, at the right boundary (blank on both) right moves +are. -/ +@[expose] public def clampMove (wvip wflag : Option Symbol) (m : SignType) : SignType := + match wvip with + | some _ => m + | none => + match wflag with + | some _ => (match m with | SignType.neg => SignType.zero | _ => m) + | none => (match m with | SignType.pos => SignType.zero | _ => m) + +/-- `tm`, reading its input from the virtual input tape `⟨k, _⟩`, with the flag tape `⟨k + 1, _⟩` +marking the cell left of the input. The real input tape is never read and never moved. -/ +@[expose] public def inputFromTape (tm : MultiTapeTM k Symbol State) : + MultiTapeTM (k + 2) Symbol State where + q₀ := tm.q₀ + tr q _ work := + let a := tm.tr q (work ⟨k, by omega⟩) fun j => work (j.castAdd 2) + let m := clampMove (work ⟨k, by omega⟩) (work ⟨k + 1, by omega⟩) a.inputTape + { inputTape := 0 + workTapes := fun l => + if h : l.val < k then a.workTapes ⟨l.val, h⟩ else (none, m) + output := a.output + state := a.state } + +/-- A configuration of `tm` on input `I`, as the redirecting machine sees it, over an arbitrary +ambient input: `I` sits on the virtual input tape with the head at cell `inputPos - 1`, the flag +tape carries its mark at `-1` with its head in lockstep, and the ambient input head rests at +`1`. -/ +@[expose] public def inCfg (mark : Symbol) {I : List Symbol} (c : Cfg k Symbol State I) + (outerInput : List Symbol) : Cfg (k + 2) Symbol State outerInput := + ⟨c.state, 1, + fun l => if h : l.val < k then c.workTapes ⟨l.val, h⟩ + else if l.val = k then tapeOfList I + else Function.update (fun _ => none) (-1) (some mark), + fun l => if h : l.val < k then c.workTapePos ⟨l.val, h⟩ else ((c.inputPos.val : ℤ) - 1), + c.output⟩ + +section Projections + +variable {mark : Symbol} {I : List Symbol} {outerInput : List Symbol} + +@[simp] +public lemma inCfg_workTapes_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapes (j.castAdd 2) = c.workTapes j := by + have h : (j.castAdd 2).val < k := j.isLt + change (if h : (j.castAdd 2).val < k then c.workTapes ⟨(j.castAdd 2).val, h⟩ else _) = _ + rw [dite_eq_left h] + exact congrArg _ (Fin.ext (by simp)) + +@[simp] +public lemma inCfg_workTapes_vip (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapes ⟨k, by omega⟩ = tapeOfList I := by + change (if h : k < k then _ else if (k : ℕ) = k then tapeOfList I else _) = _ + rw [dite_eq_right (by omega), ite_eq_left rfl] + +@[simp] +public lemma inCfg_workTapes_flag (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapes ⟨k + 1, by omega⟩ = + Function.update (fun _ => none) (-1) (some mark) := by + change (if h : k + 1 < k then _ else if k + 1 = k then _ else + Function.update (fun _ => none) (-1) (some mark)) = _ + rw [dite_eq_right (by omega), ite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapePos_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapePos (j.castAdd 2) = c.workTapePos j := by + have h : (j.castAdd 2).val < k := j.isLt + change (if h : (j.castAdd 2).val < k then c.workTapePos ⟨(j.castAdd 2).val, h⟩ else _) = _ + rw [dite_eq_left h] + exact congrArg _ (Fin.ext (by simp)) + +@[simp] +public lemma inCfg_workTapePos_vip (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapePos ⟨k, by omega⟩ = ((c.inputPos.val : ℤ) - 1) := by + change (if h : k < k then _ else ((c.inputPos.val : ℤ) - 1)) = _ + rw [dite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapePos_flag (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapePos ⟨k + 1, by omega⟩ = ((c.inputPos.val : ℤ) - 1) := by + change (if h : k + 1 < k then _ else ((c.inputPos.val : ℤ) - 1)) = _ + rw [dite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapeSymbols_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapeSymbols (j.castAdd 2) = c.workTapeSymbols j := by + simp [Cfg.workTapeSymbols] + +/-- The virtual input head reads exactly what the simulated input head reads: the word cells are +the input positions, the two boundary cells are blank. -/ +public lemma vip_read (c : Cfg k Symbol State I) : + tapeOfList I ((c.inputPos.val : ℤ) - 1) = c.inputSymbol := by + rcases Nat.eq_zero_or_pos c.inputPos.val with h0 | h1 + · rw [show ((c.inputPos.val : ℤ) - 1) = Int.negSucc 0 from by omega, tapeOfList_negSucc, + inputSymbol_eq_none_of_boundary (Or.inl h0)] + · rw [show ((c.inputPos.val : ℤ) - 1) = ((c.inputPos.val - 1 : ℕ) : ℤ) from by omega, + tapeOfList_ofNat] + rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge + · rw [Cfg.inputSymbol, dite_eq_right (fun he => by rw [he] at h1; simp at h1), + dite_eq_right (fun he => by + have hv : c.inputPos.val = I.length + 1 := by rw [he] + omega)] + rw [List.getElem?_eq_getElem (by omega)] + · have hv : c.inputPos.val = I.length + 1 := by have := c.inputPos.isLt; omega + rw [List.getElem?_eq_none (by omega), inputSymbol_eq_none_of_boundary (Or.inr hv)] + +/-- The flag head reads the mark exactly at the left boundary. -/ +public lemma flag_read (mark : Symbol) (c : Cfg k Symbol State I) : + Function.update (fun _ => (none : Option Symbol)) (-1) (some mark) + ((c.inputPos.val : ℤ) - 1) = if c.inputPos.val = 0 then some mark else none := by + by_cases h0 : c.inputPos.val = 0 + · rw [ite_eq_left h0, show ((c.inputPos.val : ℤ) - 1) = -1 from by omega, Function.update_self] + · rw [ite_eq_right h0, Function.update_of_ne (by omega)] + +/-- The clamped move tracks the simulated input head exactly. -/ +public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : SignType) : + ((moveInputPos c.inputPos m).val : ℤ) - 1 = + ((c.inputPos.val : ℤ) - 1) + + (clampMove c.inputSymbol (if c.inputPos.val = 0 then some mark else none) m : ℤ) := by + have hlen : c.inputPos.val ≤ I.length + 1 := by have := c.inputPos.isLt; omega + have cN : (SignType.neg.cast : ℤ) = -1 := by simp [SignType.cast] + have cZ : (SignType.zero.cast : ℤ) = 0 := by simp [SignType.cast] + have cP : (SignType.pos.cast : ℤ) = 1 := by simp [SignType.cast] + rcases Nat.eq_zero_or_pos c.inputPos.val with h0 | h1 + · -- left boundary: virtual head blank, flag marked + rw [inputSymbol_eq_none_of_boundary (Or.inl h0), ite_eq_left h0] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + split_ifs <;> omega + · rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge + · -- inside the input: virtual head nonblank + obtain ⟨b, hb⟩ : ∃ b, c.inputSymbol = some b := by + rw [Cfg.inputSymbol, dite_eq_right (fun he => by rw [he] at h1; simp at h1), + dite_eq_right (fun he => by + have hv : c.inputPos.val = I.length + 1 := by rw [he] + omega)] + exact ⟨_, rfl⟩ + rw [hb] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + split_ifs <;> omega + · -- right boundary: virtual head blank, flag unmarked + have hv : c.inputPos.val = I.length + 1 := by omega + rw [inputSymbol_eq_none_of_boundary (Or.inr hv), ite_eq_right (by omega)] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + split_ifs <;> omega + +end Projections + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean index e6c0daef6..24f32df2a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -44,7 +44,7 @@ at the write frontier. -/ /-- A configuration of `tm`, as the redirected machine sees it: the output so far sits on the last work tape with the head at its end, and the real output is empty. -/ -@[expose, simps] public def outCfg (c : Cfg k Symbol State input) : +@[expose] public def outCfg (c : Cfg k Symbol State input) : Cfg (k + 1) Symbol State input := ⟨c.state, c.inputPos, Fin.lastCases (tapeOfList c.output) (fun j => c.workTapes j), From 4c77bfdf9ae5d1e6ff682e5483ef0b8367481643 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 17:04:12 +0000 Subject: [PATCH 18/93] feat(MultiTapeTM): step-reduction and SignType/omega tooling MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Plumbing/StepLemmas.lean` collects the reductions every explicit-machine proof repeats: * `Action.apply_*` field projections, tagged `@[simp]`, so a step reduces with `simp [step, hq, ]` without naming `Action.apply` or dragging the projection debris through fields the caller ignores; `step_apply_of_state` and the per-field `step_*_of_state` give the same for a single-field rewrite, leaving `tm.tr q _ _` folded until the caller computes it. * `SignType.cast_neg_one`/`cast_zero_int`/`cast_one_int`, tagged `@[simp]`. These, with `Turing.val_moveInputPos_eq` (the omega-native clamped move added earlier), are what let head-position goals over the clamping input head close by `simp only [val_moveInputPos_eq, min_def, max_def, SignType.cast_*]; split_ifs <;> omega` instead of by a hand `SignType` case analysis — the pattern that had cost the most in the redirection machines. `clampMove_correct` is refactored onto them as the first customer, dropping its local cast lemmas. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../MultiTape/Plumbing/InputFromTape.lean | 13 +-- .../Turing/MultiTape/Plumbing/StepLemmas.lean | 101 ++++++++++++++++++ 3 files changed, 109 insertions(+), 6 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean diff --git a/Cslib.lean b/Cslib.lean index c5eca2e0b..d893346dd 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -66,6 +66,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTa public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas public import Cslib.Computability.Machines.Turing.SingleTape.Defs diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean index f93e5ff57..4cf1610e0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -6,6 +6,7 @@ Authors: Christian Reitwiessner, Samuel Schlesinger module +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes /-! @@ -154,14 +155,12 @@ public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : S ((c.inputPos.val : ℤ) - 1) + (clampMove c.inputSymbol (if c.inputPos.val = 0 then some mark else none) m : ℤ) := by have hlen : c.inputPos.val ≤ I.length + 1 := by have := c.inputPos.isLt; omega - have cN : (SignType.neg.cast : ℤ) = -1 := by simp [SignType.cast] - have cZ : (SignType.zero.cast : ℤ) = 0 := by simp [SignType.cast] - have cP : (SignType.pos.cast : ℤ) = 1 := by simp [SignType.cast] rcases Nat.eq_zero_or_pos c.inputPos.val with h0 | h1 · -- left boundary: virtual head blank, flag marked rw [inputSymbol_eq_none_of_boundary (Or.inl h0), ite_eq_left h0] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, + SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> split_ifs <;> omega · rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge · -- inside the input: virtual head nonblank @@ -173,13 +172,15 @@ public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : S exact ⟨_, rfl⟩ rw [hb] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, + SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> split_ifs <;> omega · -- right boundary: virtual head blank, flag unmarked have hv : c.inputPos.val = I.length + 1 := by omega rw [inputSymbol_eq_none_of_boundary (Or.inr hv), ite_eq_right (by omega)] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, cN, cZ, cP] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, + SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> split_ifs <;> omega end Projections diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean new file mode 100644 index 000000000..ab2e1e4a5 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Reducing one step of an explicit machine + +Every explicit-machine proof — `Copy`, `Clear`, `Rewind`, `Sweep`, `instrument`, the redirections — +computes `tm.step cfg` for a configuration in a known state `some q` and reads off the fields of +the result. The `Action.apply_*` projections here are `@[simp]`, so a caller reduces a step with +`simp [step, hq, ]` without having to name `Action.apply` and without the projection +debris in the fields it does not care about; `step_apply_of_state hq` turns `step` at a live state +into an `Action.apply` for a one-field rewrite, leaving the transition `tm.tr q _ _` folded until +the caller computes it. + +Also here: reduction of `SignType` casts to `ℤ` (`SignType.cast_neg`/`zero`/`pos`). Combined with +`Turing.val_moveInputPos_eq` — the input head's post-move position as an `omega`-native clamped +integer — these are what let head-position goals over the boundary-clamping input head close by +`omega` instead of by a `SignType`-case analysis. The redirection machines are the customers. +-/ + +@[expose] public section + +namespace Turing + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +@[simp] public lemma _root_.SignType.cast_neg_one : ((SignType.neg : SignType) : ℤ) = -1 := by + simp [SignType.cast] + +@[simp] public lemma _root_.SignType.cast_zero_int : ((SignType.zero : SignType) : ℤ) = 0 := by + simp [SignType.cast] + +@[simp] public lemma _root_.SignType.cast_one_int : ((SignType.pos : SignType) : ℤ) = 1 := by + simp [SignType.cast] + +@[simp] public lemma Action.apply_state (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : (a.apply cfg).state = a.state := rfl + +@[simp] public lemma Action.apply_inputPos (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : + (a.apply cfg).inputPos = moveInputPos cfg.inputPos a.inputTape := rfl + +@[simp] public lemma Action.apply_output (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : + (a.apply cfg).output = cfg.output ++ a.output.toList := rfl + +@[simp] public lemma Action.apply_workTapePos (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) (i : Fin k) : + (a.apply cfg).workTapePos i = cfg.workTapePos i + (a.workTapes i).2 := rfl + +@[simp] public lemma Action.apply_workTapes (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) (i : Fin k) : + (a.apply cfg).workTapes i = match (a.workTapes i).1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s := rfl + +namespace MultiTapeTM + +variable {tm : MultiTapeTM k Symbol State} {cfg : Cfg k Symbol State input} {q : State} + +/-- One step at a live state is the transition's action applied to the configuration. This is the +form `simp only [step_apply_of_state hq]` uses to reduce a whole step. -/ +public lemma step_apply_of_state (h : cfg.state = some q) : + tm.step cfg = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).apply cfg := by + rw [step, h] + +/-- The state after a live step. -/ +public lemma step_state_of_state (h : cfg.state = some q) : + (tm.step cfg).state = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).state := by + rw [step_apply_of_state h, Action.apply_state] + +/-- The input head after a live step. -/ +public lemma step_inputPos_of_state (h : cfg.state = some q) : + (tm.step cfg).inputPos = + moveInputPos cfg.inputPos (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).inputTape := by + rw [step_apply_of_state h, Action.apply_inputPos] + +/-- A work tape after a live step. -/ +public lemma step_workTapes_of_state (h : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapes i = + match (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workTapes i |>.1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s := by + rw [step_apply_of_state h, Action.apply_workTapes] + +/-- A work tape head after a live step. -/ +public lemma step_workTapePos_of_state (h : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapePos i = + cfg.workTapePos i + ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workTapes i).2 := by + rw [step_apply_of_state h, Action.apply_workTapePos] + +end MultiTapeTM + +end Turing From 8bd49b9ec0625585401978ad896721fba0c70d40 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 17:05:11 +0000 Subject: [PATCH 19/93] refactor(MultiTapeTM): drop redundant SignType cast lemmas simpNF caught that Mathlib's simp already reduces SignType casts to Int and that the Action.apply_workTapes projection's LHS self-simplifies. Dropped my copies and the @[simp] on the match-form projection; clampMove closes with SignType.cast in the simp set directly. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Plumbing/InputFromTape.lean | 9 +++------ .../Turing/MultiTape/Plumbing/StepLemmas.lean | 19 +++++-------------- 2 files changed, 8 insertions(+), 20 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean index 4cf1610e0..3c854e7e6 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -159,8 +159,7 @@ public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : S · -- left boundary: virtual head blank, flag marked rw [inputSymbol_eq_none_of_boundary (Or.inl h0), ite_eq_left h0] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, - SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> split_ifs <;> omega · rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge · -- inside the input: virtual head nonblank @@ -172,15 +171,13 @@ public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : S exact ⟨_, rfl⟩ rw [hb] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, - SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> split_ifs <;> omega · -- right boundary: virtual head blank, flag unmarked have hv : c.inputPos.val = I.length + 1 := by omega rw [inputSymbol_eq_none_of_boundary (Or.inr hv), ite_eq_right (by omega)] rcases m with _ | _ | _ <;> - simp only [clampMove, val_moveInputPos_eq, min_def, max_def, - SignType.cast_neg_one, SignType.cast_zero_int, SignType.cast_one_int] <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> split_ifs <;> omega end Projections diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean index ab2e1e4a5..1c12f6afe 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean @@ -19,10 +19,10 @@ debris in the fields it does not care about; `step_apply_of_state hq` turns `ste into an `Action.apply` for a one-field rewrite, leaving the transition `tm.tr q _ _` folded until the caller computes it. -Also here: reduction of `SignType` casts to `ℤ` (`SignType.cast_neg`/`zero`/`pos`). Combined with -`Turing.val_moveInputPos_eq` — the input head's post-move position as an `omega`-native clamped -integer — these are what let head-position goals over the boundary-clamping input head close by -`omega` instead of by a `SignType`-case analysis. The redirection machines are the customers. +For head-position goals over the boundary-clamping input head, `Turing.val_moveInputPos_eq` gives +the post-move position as an `omega`-native clamped integer, so `simp only [val_moveInputPos_eq, +min_def, max_def]; split_ifs <;> omega` closes them (`SignType` casts to `ℤ` are already +`simp`-reducible in Mathlib). The redirection machines are the customers. -/ @[expose] public section @@ -31,15 +31,6 @@ namespace Turing variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} -@[simp] public lemma _root_.SignType.cast_neg_one : ((SignType.neg : SignType) : ℤ) = -1 := by - simp [SignType.cast] - -@[simp] public lemma _root_.SignType.cast_zero_int : ((SignType.zero : SignType) : ℤ) = 0 := by - simp [SignType.cast] - -@[simp] public lemma _root_.SignType.cast_one_int : ((SignType.pos : SignType) : ℤ) = 1 := by - simp [SignType.cast] - @[simp] public lemma Action.apply_state (a : Action k Symbol State) (cfg : Cfg k Symbol State input) : (a.apply cfg).state = a.state := rfl @@ -55,7 +46,7 @@ variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} (cfg : Cfg k Symbol State input) (i : Fin k) : (a.apply cfg).workTapePos i = cfg.workTapePos i + (a.workTapes i).2 := rfl -@[simp] public lemma Action.apply_workTapes (a : Action k Symbol State) +public lemma Action.apply_workTapes (a : Action k Symbol State) (cfg : Cfg k Symbol State input) (i : Fin k) : (a.apply cfg).workTapes i = match (a.workTapes i).1 with | none => cfg.workTapes i From 43612620bd5d6f0847919feae9f6602eb629a0f6 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 19:11:00 +0000 Subject: [PATCH 20/93] feat(MultiTapeTM): the input-redirection semiconjugation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `step_inCfg` / `runFrom_inCfg`: one step (hence one run) of `inputFromTape tm` mirrors one step of `tm` under the embedding `inCfg`. The work tapes split into the original tapes (which the sim carries unchanged, `a.workTapes j` on both sides), the virtual input tape and the flag tape (both written nowhere, their heads moving by the clamped amount). The two head-position boundary cases are exactly `clampMove_correct`, closed by `omega`; everything else is the `Action.apply_*` projections meeting the `inCfg_*` projections. With this, all three of the redirection's ingredients — the machine, the three read/move facts, and the run mirror — are in place, and `inputFromTape` joins `outputToTape` as an unconditional step-semiconjugation. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Plumbing/InputFromTape.lean | 90 +++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean index 3c854e7e6..eb754cf7e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -76,6 +76,10 @@ section Projections variable {mark : Symbol} {I : List Symbol} {outerInput : List Symbol} +@[simp] +public lemma inCfg_inputPos (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).inputPos = 1 := rfl + @[simp] public lemma inCfg_workTapes_castAdd (c : Cfg k Symbol State I) (j : Fin k) : (inCfg mark c outerInput).workTapes (j.castAdd 2) = c.workTapes j := by @@ -180,6 +184,92 @@ public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : S simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> split_ifs <;> omega +/-- Reading the sim machine's input argument: the virtual input head reads what the simulated +input head reads. -/ +private lemma inCfg_vip_symbol (mark : Symbol) (c : Cfg k Symbol State I) + (outerInput : List Symbol) : + (inCfg mark c outerInput).workTapeSymbols ⟨k, by omega⟩ = c.inputSymbol := by + rw [Cfg.workTapeSymbols, inCfg_workTapes_vip, inCfg_workTapePos_vip, vip_read] + +/-- Reading the sim machine's flag: marked exactly at the left boundary. -/ +private lemma inCfg_flag_symbol (mark : Symbol) (c : Cfg k Symbol State I) + (outerInput : List Symbol) : + (inCfg mark c outerInput).workTapeSymbols ⟨k + 1, by omega⟩ = + (if c.inputPos.val = 0 then some mark else none) := by + rw [Cfg.workTapeSymbols, inCfg_workTapes_flag, inCfg_workTapePos_flag, flag_read] + +/-- Decompose a tape index of the redirecting machine: an original work tape, the virtual input +tape, or the flag tape. -/ +private lemma tape_cases (l : Fin (k + 2)) : + (∃ j : Fin k, l = j.castAdd 2 ∧ l.val < k) ∨ l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ := by + rcases Nat.lt_trichotomy l.val k with h | h | h + · refine Or.inl ⟨⟨l.val, h⟩, ?_, h⟩ + apply Fin.ext + simp + · exact Or.inr (Or.inl (Fin.ext (by simp [h]))) + · have := l.isLt + exact Or.inr (Or.inr (Fin.ext (by simp; omega))) + +/-- **The redirection is a step-semiconjugation.** One step of the machine reading its input from +the virtual tape mirrors one step of the original, under the embedding `inCfg`. -/ +public lemma step_inCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) : + tm.inputFromTape.step (inCfg mark c outerInput) = + inCfg mark (tm.step c) outerInput := by + cases hq : c.state with + | none => + have h1 : (inCfg mark c outerInput).state = none := by rw [inCfg]; exact hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (inCfg mark c outerInput).state = some q := by rw [inCfg]; exact hq + have harg : tm.inputFromTape.tr q (inCfg mark c outerInput).inputSymbol + (inCfg mark c outerInput).workTapeSymbols = + (let a := tm.tr q c.inputSymbol c.workTapeSymbols + let m := clampMove c.inputSymbol + (if c.inputPos.val = 0 then some mark else none) a.inputTape + { inputTape := 0 + workTapes := fun l => if h : l.val < k then a.workTapes ⟨l.val, h⟩ else (none, m) + output := a.output + state := a.state } : Action (k + 2) Symbol State) := by + simp only [inputFromTape, inCfg_vip_symbol, inCfg_flag_symbol, + inCfg_workTapeSymbols_castAdd] + rw [step_apply_of_state h1, harg] + set a := tm.tr q c.inputSymbol c.workTapeSymbols with ha + have hstepc : tm.step c = a.apply c := step_apply_of_state hq + rw [hstepc] + have hmc := clampMove_correct (I := I) mark c a.inputTape + have hip : (a.apply c).inputPos = moveInputPos c.inputPos a.inputTape := rfl + refine Cfg.ext rfl ?_ ?_ ?_ rfl + · simp only [Action.apply_inputPos, moveInputPos_zero, inCfg] + · funext l z + rcases tape_cases l with ⟨j, rfl, hjk⟩ | rfl | rfl + · simp only [Action.apply_workTapes, Fin.val_castAdd, dite_eq_left j.isLt, Fin.eta, + inCfg_workTapes_castAdd, inCfg_workTapePos_castAdd] + · have hnk : ¬ ((⟨k, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapes, dite_eq_right hnk, inCfg_workTapes_vip] + · have hnk1 : ¬ ((⟨k + 1, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapes, dite_eq_right hnk1, inCfg_workTapes_flag] + · funext l + rcases tape_cases l with ⟨j, rfl, hjk⟩ | rfl | rfl + · simp only [Action.apply_workTapePos, Fin.val_castAdd, dite_eq_left j.isLt, Fin.eta, + inCfg_workTapePos_castAdd] + · have hnk : ¬ ((⟨k, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapePos, dite_eq_right hnk, inCfg_workTapePos_vip, + Action.apply_inputPos] + omega + · have hnk1 : ¬ ((⟨k + 1, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapePos, dite_eq_right hnk1, inCfg_workTapePos_flag, + Action.apply_inputPos] + omega + +/-- The redirected run mirrors the original. -/ +public lemma runFrom_inCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) (n : ℕ) : + tm.inputFromTape.runFrom (inCfg mark c outerInput) n = + inCfg mark (tm.runFrom c n) outerInput := + runFrom_comm_of_step (fun c => inCfg mark c outerInput) + (fun c => step_inCfg tm mark c outerInput) c n + end Projections end Turing.MultiTapeTM From 7a67bddd883b579ed8695047483c4c48f9fb90c9 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 19:30:58 +0000 Subject: [PATCH 21/93] feat(MultiTapeTM): a machine that rewinds a work-tape head Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../Turing/MultiTape/Plumbing/RewindTape.lean | 303 ++++++++++++++++++ 2 files changed, 304 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean diff --git a/Cslib.lean b/Cslib.lean index d893346dd..6f3249a0a 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -65,6 +65,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean new file mode 100644 index 000000000..993103100 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas + +/-! +# A machine that rewinds a work-tape head + +A two-state machine that returns the head of one designated work tape `i` to position `0` — the +start of the word — from the frontier just past the word, and halts there. It never writes to any +tape, never moves the input head, never moves any other work head and never outputs, so a +combinator can run it between two phases of a computation to re-normalise a work-tape head without +disturbing anything else. + +Tape `i` holds a word `w` in cells `0, …, w.length - 1` and is blank everywhere else, and the head +starts at the frontier cell `w.length`. In its initial state `start` the machine takes one +unconditional step left, into state `scan`. In state `scan` it walks left over the symbols of `w`; +the first blank it reads is the cell at position `-1`, and the halting transition moves the head +right, back onto position `0`. + +On a word of length `L` the run halts after `L + 2` steps, having read the cells `-1, …, L - 1` of +tape `i` and touched nothing else. + +## Main results + +* `Turing.MultiTapeTM.exists_rewindTape`: the machine that rewinds a work-tape head to the start of + its word. +-/ + +namespace Turing.MultiTapeTM + +variable {K : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The control states of the work-tape-rewinding machine: `start` takes one unconditional step +left, `scan` walks left towards the start of the word. -/ +inductive RewindTapeState : Type + | start + | scan + +instance : Finite RewindTapeState := + Finite.of_injective + (fun q => match q with + | .start => (0 : Fin 2) + | .scan => 1) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The work-tape-rewinding machine for tape `i`. In state `start` it moves the head of tape `i` +left, unconditionally, and enters state `scan`. In state `scan` it moves left over a symbol, +staying in `scan`; on the first blank it moves right and halts. No tape is ever written, the input +head never moves, no other work head moves and nothing is output. -/ +def rewindTape (i : Fin K) : MultiTapeTM K Symbol RewindTapeState where + q₀ := .start + tr q _ work := + match q, work i with + | .start, _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .scan } + | .scan, some _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .scan } + | .scan, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := none } + +namespace RewindTape + +variable {i : Fin K} {ip : Fin (input.length + 2)} {W : Fin K → ℤ → Option Symbol} + {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the rewinding machine: state `q`, the head of tape `i` at `p`, every other +field frozen — tape contents `W`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option RewindTapeState) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol RewindTapeState input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as the tape-`i` head positions agree. -/ +lemma cfg_congr {q : Option RewindTapeState} {p p' : ℤ} (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W WP out p' := by + rw [hp] + +/-- Moving the head of tape `i` left in state `start`, unconditionally, entering `scan`. -/ +lemma step_start : + (rewindTape i).step (cfg input i (some .start) ip W WP out p) = + cfg input i (some .scan) ip W WP out (p - 1) := by + unfold step + simp only [cfg] + simp only [rewindTape] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Walking left in state `scan`: over a symbol the head moves left and stays in `scan`. -/ +lemma step_scan_some {s : Symbol} (hs : W i p = some s) : + (rewindTape i).step (cfg input i (some .scan) ip W WP out p) = + cfg input i (some .scan) ip W WP out (p - 1) := by + have hsym : (cfg input i (some .scan) ip W WP out p).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [rewindTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Halting in state `scan`: on the first blank — the cell at position `-1` — the head moves right +and the machine halts. -/ +lemma step_scan_none (hs : W i p = none) : + (rewindTape i).step (cfg input i (some .scan) ip W WP out p) = + cfg input i none ip W WP out (p + 1) := by + have hsym : (cfg input i (some .scan) ip W WP out p).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [rewindTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- The scanning phase: from `scan` at the last cell of the word, after `n ≤ w.length` steps the +head has walked left `n` cells, over untouched symbols. -/ +lemma runFrom_scan {w : List Symbol} (hw : W i = tapeOfList w) (n : ℕ) (hn : n ≤ w.length) : + (rewindTape i).runFrom (cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1)) n = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1 - n) := by + induction n with + | zero => + rw [runFrom_zero] + exact cfg_congr (by omega) + | succ n ih => + have hpos : (w.length : ℤ) - 1 - n = ((w.length - 1 - n : ℕ) : ℤ) := by omega + have hsym : W i ((w.length : ℤ) - 1 - n) = some (w[w.length - 1 - n]'(by omega)) := by + rw [hw, hpos, tapeOfList_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_scan_some hsym] + exact cfg_congr (by omega) + +/-- The complete run: from `start` at the frontier `w.length`, after `w.length + 2` steps the +machine has halted with the head of tape `i` back at position `0`. -/ +lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : + (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) (w.length + 2) = + cfg input i none ip W WP out 0 := by + have hstep1 : (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1) := by + rw [runFrom_succ_eq_step', runFrom_zero] + exact step_start + have hscanEnd : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) (1 + w.length) = + cfg input i (some .scan) ip W WP out (-1) := by + rw [runFrom_add, hstep1, runFrom_scan hw w.length le_rfl] + exact cfg_congr (by omega) + have hnone : W i (-1 : ℤ) = none := by + rw [hw, show (-1 : ℤ) = Int.negSucc 0 from by omega, tapeOfList_negSucc] + rw [show w.length + 2 = (1 + w.length) + 1 from by omega, runFrom_succ_eq_step', hscanEnd, + step_scan_none hnone] + exact cfg_congr (by omega) + +/-- No action of the machine writes to a work tape. -/ +lemma tr_write_none (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) + (l : Fin K) : (((rewindTape i).tr q inp work).workTapes l).1 = none := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((rewindTape i).tr q inp work).inputTape = 0 := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine outputs. -/ +lemma tr_output (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((rewindTape i).tr q inp work).output = none := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((rewindTape i).tr q inp work).workTapes l).2 = 0 := by + simp only [rewindTape] + cases q <;> cases work i <;> simp [h] + +/-- One step preserves the input head, the output, every tape's contents and every work head other +than the head of tape `i`. -/ +lemma step_frame (c : Cfg K Symbol RewindTapeState input) : + ((rewindTape i).step c).inputPos = c.inputPos ∧ + ((rewindTape i).step c).output = c.output ∧ + (∀ j, ((rewindTape i).step c).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((rewindTape i).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, rfl, fun _ => rfl, fun _ _ => rfl⟩ + | some q => + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · rw [step_apply_of_state hc, Action.apply_output, tr_output]; simp + · intro j + rw [step_workTapes_of_state hc, tr_write_none q c.inputSymbol c.workTapeSymbols j] + · intro j hj + rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj] + simp + +/-- The whole run preserves the input head, the output, every tape's contents and every work head +other than the head of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol RewindTapeState input) (m : ℕ) : + ((rewindTape i).runFrom c m).inputPos = c.inputPos ∧ + ((rewindTape i).runFrom c m).output = c.output ∧ + (∀ j, ((rewindTape i).runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((rewindTape i).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, rfl, fun _ => rfl, fun _ _ => rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3, h4⟩ := step_frame ((rewindTape i).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, fun j => (h3 j).trans (ih.2.2.1 j), + fun j hj => (h4 j hj).trans (ih.2.2.2 j hj)⟩ + +end RewindTape + +open RewindTape in +/-- **The machine that rewinds a work-tape head.** One machine per tape index `i`: started with +tape `i` holding a word `w` in cells `0, …, w.length - 1` and the head at the frontier `w.length`, +it halts within `w.length + 3` steps with the head back at position `0` and every other field — +input head, output, all tape contents and all other work heads — unchanged at every step of the +run. Before the halting step the machine is live, so runs chain sequentially. -/ +public theorem exists_rewindTape {Symbol : Type*} {K : ℕ} (i : Fin K) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input) (w : List Symbol), + c.state = some tm.q₀ → + c.workTapes i = tapeOfList w → + c.workTapePos i = (w.length : ℤ) → + ∃ u ≤ w.length + 3, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, c.workTapes, + Function.update c.workTapePos i 0, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ (tm.runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapes j = c.workTapes j ∧ + (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (tm.runFrom c m).workTapes i = c.workTapes i := by + refine ⟨RewindTapeState, inferInstance, rewindTape i, fun input c w hstate hwi hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some RewindTapeState.start := hstate + have hwi' : W i = tapeOfList w := hwi + have hwp' : WP i = (w.length : ℤ) := hwp + -- the starting configuration in the shape of the descriptor `cfg` + have hc0 : (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) = + cfg input i (some .start) ip W WP out (w.length : ℤ) := by + refine Cfg.ext rfl rfl rfl ?_ rfl + change WP = Function.update WP i (w.length : ℤ) + rw [← hwp', Function.update_eq_self] + -- the run halts at position `0` after `w.length + 2` steps + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ w.length + 2, + (∀ m < u, ((rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) + m).state ≠ none) ∧ + (rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) u = + ⟨none, ip, W, Function.update WP i 0, out⟩ := by + have hrun : (rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) + (w.length + 2) = ⟨none, ip, W, Function.update WP i 0, out⟩ := by + rw [hc0, runFrom_full hwi'] + simp only [cfg] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (rewindTape i) _ (w.length + 2) (by rw [hrun]) + have heq := runFrom_eq_of_halt (rewindTape i) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m _ => ?_⟩ + obtain ⟨f1, f2, f3, f4⟩ := + runFrom_frame (⟨some RewindTapeState.start, ip, W, WP, out⟩) m + exact ⟨f1, f2, fun j hj => ⟨f3 j, f4 j hj⟩, f3 i⟩ + +end Turing.MultiTapeTM From 62392a878b5729f8e4025b6710dca967d77b3ab4 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 19:34:11 +0000 Subject: [PATCH 22/93] feat(MultiTapeTM): connection lemmas for the output-redirection adapter `Cfg.withOutput` and the commuting run `runFrom_outputToTape_withOutput`: since `outputToTape` never writes the real output tape, its run commutes with replacing that output, so the adapter can be run from a configuration whose real output is already non-empty (as `TransformsTapes` quantifies over). And `initCfg_outputToTape = outCfg (initCfg)`, the start-configuration identity that lets a tidy machine's run be transported through the redirection. Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/Plumbing/OutputToTape.lean | 1 + 1 file changed, 1 insertion(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean index 24f32df2a..cf20daa78 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -7,6 +7,7 @@ Authors: Christian Reitwiessner, Samuel Schlesinger module public import Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes /-! From c3e674d82dac25517b4ff41d8d4c202063d755b2 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 19:36:21 +0000 Subject: [PATCH 23/93] refactor(MultiTapeTM): promote seq_spec to public in Sequential MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The raw sequential-composition lemma (runs, activity and space of tm₁.seq tm₂ from those of the parts) was private in Tidy.lean; the output adapter needs it too, so it moves to Plumbing/Sequential.lean, generalised from Bool to an arbitrary symbol alphabet. Tidy.lean uses the public version. Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/NormalForms/Tidy.lean | 56 ----------------- .../Turing/MultiTape/Plumbing/Sequential.lean | 60 +++++++++++++++++++ 2 files changed, 60 insertions(+), 56 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean index 98985babe..14540c56b 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -66,62 +66,6 @@ open Sequential variable {K : ℕ} {S₁ S₂ : Type} {input : List Bool} -/-- Raw sequential composition of two halting runs: the composite runs the first machine's run and -then the second's, with times and space bounds adding, and stays live throughout — the handoff -itself is a live state. -/ -private lemma seq_spec {tm₁ : MultiTapeTM K Bool S₁} {tm₂ : MultiTapeTM K Bool S₂} - {c : Cfg K Bool (S₁ ⊕ S₂) input} {c₁ : Cfg K Bool S₁ input} {c₂ : Cfg K Bool S₂ input} - {u₁ u₂ s₁' s₂' : ℕ} - (hc : c.state = some (tm₁.seq tm₂).q₀) - (h₁ : tm₁.runFrom (c.withState (some tm₁.q₀)) u₁ = c₁) - (h₁halt : c₁.state = none) - (h₁act : ∀ m < u₁, (tm₁.runFrom (c.withState (some tm₁.q₀)) m).state ≠ none) - (h₁sp : tm₁.spaceUsed (c.withState (some tm₁.q₀)) u₁ ≤ s₁') - (h₂ : tm₂.runFrom (c₁.withState (some tm₂.q₀)) u₂ = c₂) - (h₂halt : c₂.state = none) - (h₂act : ∀ m < u₂, (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m).state ≠ none) - (h₂sp : tm₂.spaceUsed (c₁.withState (some tm₂.q₀)) u₂ ≤ s₂') : - (tm₁.seq tm₂).runFrom c (u₁ + u₂) = c₂.withState (none : Option (S₁ ⊕ S₂)) ∧ - (∀ m < u₁ + u₂, ((tm₁.seq tm₂).runFrom c m).state ≠ none) ∧ - (tm₁.seq tm₂).spaceUsed c (u₁ + u₂) ≤ s₁' + s₂' := by - set cs := c.withState (some tm₁.q₀) with hcs - have hcleft : c = leftCfg tm₂ cs := by - refine Cfg.ext ?_ rfl rfl rfl rfl - rw [hc] - rfl - have hhalt₁ : (tm₁.runFrom cs u₁).state = none := by rw [h₁]; exact h₁halt - have hleft : ∀ m ≤ u₁, (tm₁.seq tm₂).runFrom c m = leftCfg tm₂ (tm₁.runFrom cs m) := by - intro m hm - rw [hcleft, runFrom_leftCfg _ m fun r hr => h₁act r (by omega)] - have hmid : (tm₁.seq tm₂).runFrom c u₁ = rightCfg (c₁.withState (some tm₂.q₀)) := by - rw [hleft u₁ le_rfl, h₁] - refine Cfg.ext ?_ rfl rfl rfl rfl - simp [leftCfg, rightCfg, Cfg.withState, h₁halt] - have hright : ∀ m, (tm₁.seq tm₂).runFrom c (u₁ + m) = - rightCfg (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m) := by - intro m - rw [runFrom_add, hmid, runFrom_rightCfg] - refine ⟨?_, ?_, ?_⟩ - · rw [hright u₂, h₂] - refine Cfg.ext ?_ rfl rfl rfl rfl - simp [rightCfg, Cfg.withState, h₂halt] - · intro m hm - rcases Nat.le_total m u₁ with h | h - · rw [hleft m h] - simp [leftCfg] - · obtain ⟨m', rfl⟩ : ∃ m', m = u₁ + m' := ⟨m - u₁, by omega⟩ - rw [hright m'] - have h := h₂act m' (by omega) - simpa only [rightCfg, ne_eq, Option.map_eq_none_iff] using h - · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) - · refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₁ fun m hm => ?_)) h₁sp - rw [hleft m hm] - rfl - · rw [hmid] - refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₂ fun m hm => ?_)) h₂sp - rw [runFrom_rightCfg] - rfl - /-- The machine that halts on its first step, changing nothing. -/ private def haltTM (K : ℕ) : MultiTapeTM K Bool Unit where q₀ := () diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean index fb326316b..9bdfeea3e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -183,4 +183,64 @@ public theorem transformsTapes_seq refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ τ₁ fun m hm => ?_)) hspace₁ rw [runFrom_rightCfg, workTapePos_rightCfg] +section RawSeq + +variable {K : ℕ} {Sym S₁ S₂ : Type*} {inp : List Sym} + +open Sequential in +public lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sym S₂} + {c : Cfg K Sym (S₁ ⊕ S₂) inp} {c₁ : Cfg K Sym S₁ inp} {c₂ : Cfg K Sym S₂ inp} + {u₁ u₂ s₁' s₂' : ℕ} + (hc : c.state = some (tm₁.seq tm₂).q₀) + (h₁ : tm₁.runFrom (c.withState (some tm₁.q₀)) u₁ = c₁) + (h₁halt : c₁.state = none) + (h₁act : ∀ m < u₁, (tm₁.runFrom (c.withState (some tm₁.q₀)) m).state ≠ none) + (h₁sp : tm₁.spaceUsed (c.withState (some tm₁.q₀)) u₁ ≤ s₁') + (h₂ : tm₂.runFrom (c₁.withState (some tm₂.q₀)) u₂ = c₂) + (h₂halt : c₂.state = none) + (h₂act : ∀ m < u₂, (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m).state ≠ none) + (h₂sp : tm₂.spaceUsed (c₁.withState (some tm₂.q₀)) u₂ ≤ s₂') : + (tm₁.seq tm₂).runFrom c (u₁ + u₂) = c₂.withState (none : Option (S₁ ⊕ S₂)) ∧ + (∀ m < u₁ + u₂, ((tm₁.seq tm₂).runFrom c m).state ≠ none) ∧ + (tm₁.seq tm₂).spaceUsed c (u₁ + u₂) ≤ s₁' + s₂' := by + set cs := c.withState (some tm₁.q₀) with hcs + have hcleft : c = leftCfg tm₂ cs := by + refine Cfg.ext ?_ rfl rfl rfl rfl + rw [hc] + rfl + have hhalt₁ : (tm₁.runFrom cs u₁).state = none := by rw [h₁]; exact h₁halt + have hleft : ∀ m ≤ u₁, (tm₁.seq tm₂).runFrom c m = leftCfg tm₂ (tm₁.runFrom cs m) := by + intro m hm + rw [hcleft, runFrom_leftCfg _ m fun r hr => h₁act r (by omega)] + have hmid : (tm₁.seq tm₂).runFrom c u₁ = rightCfg (c₁.withState (some tm₂.q₀)) := by + rw [hleft u₁ le_rfl, h₁] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [leftCfg, rightCfg, Cfg.withState, h₁halt] + have hright : ∀ m, (tm₁.seq tm₂).runFrom c (u₁ + m) = + rightCfg (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m) := by + intro m + rw [runFrom_add, hmid, runFrom_rightCfg] + refine ⟨?_, ?_, ?_⟩ + · rw [hright u₂, h₂] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [rightCfg, Cfg.withState, h₂halt] + · intro m hm + rcases Nat.le_total m u₁ with h | h + · rw [hleft m h] + simp [leftCfg] + · obtain ⟨m', rfl⟩ : ∃ m', m = u₁ + m' := ⟨m - u₁, by omega⟩ + rw [hright m'] + have h := h₂act m' (by omega) + simpa only [rightCfg, ne_eq, Option.map_eq_none_iff] using h + · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₁ fun m hm => ?_)) h₁sp + rw [hleft m hm] + rfl + · rw [hmid] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₂ fun m hm => ?_)) h₂sp + rw [runFrom_rightCfg] + rfl + +end RawSeq + end Turing.MultiTapeTM From 54e88764e7204ce62366f8bd6ff076db1aa2d030 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 19:38:51 +0000 Subject: [PATCH 24/93] feat(MultiTapeTM): bound the rewindTape head excursion MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The output adapter's space bound needs that rewindTape moves the tape-i head only within [-1, w.length] — without it, spaceUsed_linear gives a lossy K*w.length product outside the c*(...)+k bound shape. `runFrom_pos_range` proves the head stays in that interval at every step, and the clause is threaded into `exists_rewindTape`'s per-step conclusion. Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/Plumbing/RewindTape.lean | 43 +++++++++++++++++-- 1 file changed, 40 insertions(+), 3 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean index 993103100..19818ff30 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean @@ -186,6 +186,38 @@ lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : step_scan_none hnone] exact cfg_congr (by omega) +/-- Throughout the run, the head of tape `i` stays within `[-1, w.length]`: it walks from the +frontier down to `-1` and back to `0`, never leaving that interval. -/ +lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) + (hm : m ≤ w.length + 2) : + -1 ≤ ((rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) m).workTapePos i ∧ + ((rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) m).workTapePos i ≤ + (w.length : ℤ) := by + have hstep1 : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1) := by + rw [runFrom_succ_eq_step', runFrom_zero]; exact step_start + rcases Nat.lt_or_ge m 1 with h0 | h1 + · obtain rfl : m = 0 := by omega + rw [runFrom_zero] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + rcases Nat.lt_or_ge m (w.length + 2) with hlt | hge + · -- scanning: head at `w.length - m` + obtain ⟨d, hd, rfl⟩ : ∃ d, d ≤ w.length ∧ m = 1 + d := ⟨m - 1, by omega, by omega⟩ + rw [runFrom_add, hstep1, runFrom_scan hw d hd] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + · obtain rfl : m = w.length + 2 := by omega + rw [runFrom_full hw] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + /-- No action of the machine writes to a work tape. -/ lemma tr_write_none (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) (l : Fin K) : (((rewindTape i).tr q inp work).workTapes l).1 = none := by @@ -265,7 +297,9 @@ public theorem exists_rewindTape {Symbol : Type*} {K : ℕ} (i : Fin K) : ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ (tm.runFrom c m).output = c.output ∧ (∀ j, j ≠ i → (tm.runFrom c m).workTapes j = c.workTapes j ∧ (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ - (tm.runFrom c m).workTapes i = c.workTapes i := by + (tm.runFrom c m).workTapes i = c.workTapes i ∧ + -1 ≤ (tm.runFrom c m).workTapePos i ∧ + (tm.runFrom c m).workTapePos i ≤ (w.length : ℤ) := by refine ⟨RewindTapeState, inferInstance, rewindTape i, fun input c w hstate hwi hwp => ?_⟩ obtain ⟨q, ip, W, WP, out⟩ := c obtain rfl : q = some RewindTapeState.start := hstate @@ -295,9 +329,12 @@ public theorem exists_rewindTape {Symbol : Type*} {K : ℕ} (i : Fin K) : have heq := runFrom_eq_of_halt (rewindTape i) _ hu hhaltu rw [hrun] at heq exact ⟨u, hu, hact, heq.symm⟩ - refine ⟨u, by omega, hactive, hhalt, fun m _ => ?_⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ obtain ⟨f1, f2, f3, f4⟩ := runFrom_frame (⟨some RewindTapeState.start, ip, W, WP, out⟩) m - exact ⟨f1, f2, fun j hj => ⟨f3 j, f4 j hj⟩, f3 i⟩ + obtain ⟨g1, g2⟩ := runFrom_pos_range (i := i) (input := input) (ip := ip) (W := W) (WP := WP) + (out := out) hwi' m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, fun j hj => ⟨f3 j, f4 j hj⟩, f3 i, g1, g2⟩ end Turing.MultiTapeTM From f92363df200a2cfbfa97db7ca844b0c5949f11d4 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 20:02:07 +0000 Subject: [PATCH 25/93] feat(MultiTapeTM): space bound for a run with one moving head MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `spaceUsed_le_of_one_moving`: if one head stays within an interval and every other head is fixed, the space is the interval plus one cell per other tape — the sharp bound the output adapter needs for the rewind phase (rather than the lossy K*t of spaceUsed_linear). Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/TapeLemmas.lean | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index 23fb613b6..c8df87ea2 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -243,4 +243,37 @@ lemma spaceUsed_le_of_workTapePos_const (cfg : Cfg k Symbol State input) (u : calc tm.spaceUsed cfg u ≤ ∑ _i : Fin k, 1 := Finset.sum_le_sum fun i _ => hcard i _ = k := by simp +/-- Space bound for a run in which one head stays inside an interval and every other head is +fixed: the moving tape contributes the interval, each other tape a single cell. -/ +lemma spaceUsed_le_of_one_moving (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) + (lo hi : ℤ) + (hi_move : ∀ m ≤ t, lo ≤ (tm.runFrom cfg m).workTapePos i ∧ + (tm.runFrom cfg m).workTapePos i ≤ hi) + (hfixed : ∀ m ≤ t, ∀ j, j ≠ i → (tm.runFrom cfg m).workTapePos j = cfg.workTapePos j) : + tm.spaceUsed cfg t ≤ (hi + 1 - lo).toNat + k := by + have hi_tape : tm.spaceUsedByTape cfg t i ≤ (hi + 1 - lo).toNat := by + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Int.card_Icc lo hi)) + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + exact Finset.mem_Icc.mpr (hi_move m (by omega)) + have hj_tape : ∀ j ∈ Finset.univ.erase i, tm.spaceUsedByTape cfg t j ≤ 1 := by + intro j hj + have hji : j ≠ i := Finset.ne_of_mem_erase hj + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Finset.card_singleton + (cfg.workTapePos j))) + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hfixed m (by omega) j hji] + exact Finset.mem_singleton_self _ + calc tm.spaceUsed cfg t + = tm.spaceUsedByTape cfg t i + + ∑ j ∈ Finset.univ.erase i, tm.spaceUsedByTape cfg t j := + (Finset.add_sum_erase _ _ (Finset.mem_univ i)).symm + _ ≤ (hi + 1 - lo).toNat + ∑ _j ∈ Finset.univ.erase i, 1 := + Nat.add_le_add hi_tape (Finset.sum_le_sum hj_tape) + _ ≤ (hi + 1 - lo).toNat + k := by + rw [← Finset.card_eq_sum_ones, Finset.card_erase_of_mem (Finset.mem_univ i), + Finset.card_univ, Fintype.card_fin] + omega + end Turing.MultiTapeTM From 3439c6022272d8204e482541ea485ff7a6175db3 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 20:05:46 +0000 Subject: [PATCH 26/93] fix(MultiTapeTM): actually add the output-adapter connection lemmas An earlier commit titled the same claimed these but a failed assertion had left them unwritten (only an import landed). This adds the real content: Cfg.withOutput, step_/runFrom_/spaceUsed_outputToTape_withOutput (the run and space commute with replacing the real output, since outputToTape never writes it), and initCfg_outputToTape = outCfg (initCfg). Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Plumbing/OutputToTape.lean | 60 +++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean index cf20daa78..24765f765 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -127,6 +127,66 @@ public lemma runFrom_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol tm.outputToTape.runFrom (outCfg c) n = outCfg (tm.runFrom c n) := runFrom_comm_of_step outCfg (step_outCfg tm) c n +/-- The same configuration with a different real output. `outputToTape` never writes the real +output, so its run commutes with this — the caller may run it with output already present, as +`TransformsTapes` quantifies over. -/ +@[expose, simps] public def _root_.Turing.Cfg.withOutput (c : Cfg k' Symbol State input') + (out : List Symbol) : Cfg k' Symbol State input' := + ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ + +section WithOutput +variable {k' : ℕ} + +/-- `outputToTape tm` never writes the real output, so replacing it commutes with a step. -/ +public lemma step_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) : + tm.outputToTape.step (c.withOutput out) = (tm.outputToTape.step c).withOutput out := by + cases hq : c.state with + | none => + have h1 : (c.withOutput out).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (c.withOutput out).state = some q := hq + have hin : (c.withOutput out).inputSymbol = c.inputSymbol := rfl + have hws : (c.withOutput out).workTapeSymbols = c.workTapeSymbols := rfl + have hout : (tm.outputToTape.tr q c.inputSymbol c.workTapeSymbols).output = none := by + simp [outputToTape] + rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] + refine Cfg.ext rfl rfl ?_ ?_ ?_ + · funext l z; simp [Action.apply_workTapes, Cfg.withOutput] + · funext l; simp [Action.apply_workTapePos, Cfg.withOutput] + · simp only [Action.apply_output, Cfg.withOutput_output, hout] + simp + +/-- The redirected run commutes with the real output already present. -/ +public lemma runFrom_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) (n : ℕ) : + tm.outputToTape.runFrom (c.withOutput out) n = (tm.outputToTape.runFrom c n).withOutput out := + runFrom_comm_of_step (fun c => c.withOutput out) + (fun c => step_outputToTape_withOutput tm c out) c n + +/-- `outputToTape`'s space does not depend on the real output already present. -/ +public lemma spaceUsed_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) (u : ℕ) : + tm.outputToTape.spaceUsed (c.withOutput out) u = tm.outputToTape.spaceUsed c u := by + refine spaceUsed_eq_of_workTapePos _ _ u fun m hm => ?_ + rw [runFrom_outputToTape_withOutput]; rfl + +end WithOutput + +/-- The initial configuration of the redirected machine is the original's through `outCfg`. -/ +public lemma initCfg_outputToTape (tm : MultiTapeTM k Symbol State) (input : List Symbol) : + tm.outputToTape.initCfg input = outCfg (tm.initCfg input) := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + induction l using Fin.lastCases with + | last => simp [initCfg, Cfg.init] + | cast j => simp [initCfg, Cfg.init] + · funext l + induction l using Fin.lastCases with + | last => simp [initCfg, Cfg.init] + | cast j => simp [initCfg, Cfg.init] + /-- The output can only grow. -/ public lemma length_output_mono (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol State input) (d : ℕ) : From 66ed38190c5d09c3a6f487a16bf821b581d29321 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 20:05:59 +0000 Subject: [PATCH 27/93] chore(MultiTapeTM): trim unused simp args in withOutput step Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/Plumbing/OutputToTape.lean | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean index 24765f765..3db758561 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -153,10 +153,10 @@ public lemma step_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) simp [outputToTape] rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] refine Cfg.ext rfl rfl ?_ ?_ ?_ - · funext l z; simp [Action.apply_workTapes, Cfg.withOutput] - · funext l; simp [Action.apply_workTapePos, Cfg.withOutput] - · simp only [Action.apply_output, Cfg.withOutput_output, hout] - simp + · funext l z; simp [Cfg.withOutput] + · funext l; simp [Cfg.withOutput] + · simp only [Action.apply_output, Cfg.withOutput_output, hout, Option.toList_none, + List.append_nil] /-- The redirected run commutes with the real output already present. -/ public lemma runFrom_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) From 1b6d2982e2d27ed239027f06fac645efabca48ae Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 20:08:11 +0000 Subject: [PATCH 28/93] feat(MultiTapeTM): a computable function read from the input tape, as a tape transformer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `exists_transformsTapes_ofComputableInput`: every computable function has a machine that, started with the input on the real input tape and every work tape blank, halts having written the encoded result to the last work tape in the `wordsCfg` normal form — in linear time and space linear in the result length. This is the first bridge from a computable function into the word-transformer interface, and the payoff of the whole machine layer: it is pure assembly of `exists_tidy` (make the function halt tidily), `outputToTape` (redirect the output to a fresh tape), and `rewindTape` (bring that tape's head home), composed by `seq_spec`. The proof is sectioned by phase; the time bound uses that the encoded result is produced by the original machine in ≤ t steps (so it is that short), and the space bound uses the sharp one-moving-head lemma for the rewind phase. Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../MultiTape/NormalForms/Adapters.lean | 173 ++++++++++++++++++ 2 files changed, 174 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean diff --git a/Cslib.lean b/Cslib.lean index 6f3249a0a..351082100 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -58,6 +58,7 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean new file mode 100644 index 000000000..91e252874 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape + +/-! +# From a computable function to a tape transformer + +A computable function enters the word-transformer interface +(`Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes`) by three steps: make it +*tidy* (`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy`), so it halts with its +result on the append-only output tape and everything else blank; *redirect that output to a work +tape* (`outputToTape`), which leaves the result on a fresh last tape with the head at the write +frontier; and *rewind that head* (`rewindTape`) so the tape holds a word in the normal form the +interface expects. + +`exists_transformsTapes_ofComputableInput` is the resulting adapter for a function read from the +real input tape. The output tape is the last of `k₀ + 1` work tapes, where `k₀` is the tidy +machine's tape count. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β : Type*} + +/-- **A computable function, read from the input tape, as a tape transformer.** Started with the +input on the real input tape and every work tape blank, the machine halts having written the +encoded result to the last work tape, in linear time and in space linear in the result length. -/ +public theorem exists_transformsTapes_ofComputableInput + {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ (c K : ℕ) (o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + ∀ a, TransformsTapes tm + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) (c * (s a + (encOut (g a)).length + 1) + K) := by + classical + obtain ⟨c₀, k₀, State₀, hfin, tm₀, htidy⟩ := exists_tidy h + obtain ⟨SR, hSR, tmR, hR⟩ := exists_rewindTape (Symbol := Bool) (Fin.last k₀) + have := hfin + have := hSR + -- the composed machine: run the tidy machine with its output on a fresh tape, then rewind it + refine ⟨c₀ + k₀ + 4, k₀ + 1, Fin.last k₀, State₀ ⊕ SR, inferInstance, + tm₀.outputToTape.seq tmR, fun a => ?_⟩ + intro input ws out hP + obtain ⟨hinput, hblank⟩ := hP + subst hinput + have hws : ws = fun _ => [] := funext hblank + subst hws + obtain ⟨τ, hτ, htidyrun, htidysp⟩ := htidy a + -- The encoded result is produced by the *original* machine in at most `t a` steps, so it is no + -- longer than `t a` — a fact the tidy interface alone (which only bounds by `τ`) does not give. + have hw_len : (encOut (g a)).length ≤ t a := by + obtain ⟨kk, SS, hfinSS, tmm, hcomp⟩ := h + obtain ⟨t', ht', s', hs', hhaltm, houtm, hspm⟩ := hcomp a + have hlen : ∀ d, (tmm.runFrom (tmm.initCfg (enc a)) d).output.length ≤ d := by + intro d + induction d with + | zero => rw [runFrom_zero, initCfg_eq_wordsCfg]; simp + | succ d ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + have h1 : (tmm.outputSymbol (tmm.runFrom (tmm.initCfg (enc a)) d)).toList.length ≤ 1 := by + cases tmm.outputSymbol (tmm.runFrom (tmm.initCfg (enc a)) d) <;> simp + omega + have hle := hlen t' + rw [houtm] at hle + omega + -- Abbreviations: the encoded result `w`, the tidy halting configuration `X`, and the start. + set w := encOut (g a) with hw_def + set X := wordsCfg (enc a) none (fun _ => []) w with hX_def + set cStart := wordsCfg (enc a) (some (tm₀.outputToTape.seq tmR).q₀) (fun _ => []) out + with hcStart_def + -- =================================================================================== + -- Phase 1: run the tidy machine with its output redirected onto the fresh last work tape. + -- =================================================================================== + -- The phase-1 start configuration, expressed through the output-redirection maps. + have hstart1 : cStart.withState (some tm₀.outputToTape.q₀) + = (outCfg (tm₀.initCfg (enc a))).withOutput out := by + rw [hcStart_def, ← initCfg_outputToTape, initCfg_eq_wordsCfg]; rfl + -- Running the redirected machine mirrors the tidy run, ending on `(outCfg X).withOutput out`. + have hc1_run : tm₀.outputToTape.runFrom (cStart.withState (some tm₀.outputToTape.q₀)) τ + = (outCfg X).withOutput out := by + rw [hstart1, runFrom_outputToTape_withOutput, runFrom_outCfg, htidyrun] + set c₁ := (outCfg X).withOutput out with hc1_def + have hc1_state : c₁.state = none := by rw [hc1_def, hX_def]; rfl + -- Replace `τ` by the first halting time `τ'`, which gives phase-1 activity for free. + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tm₀.outputToTape (cStart.withState (some tm₀.outputToTape.q₀)) τ + (by rw [hc1_run]; exact hc1_state) + have hc1_run' : tm₀.outputToTape.runFrom (cStart.withState (some tm₀.outputToTape.q₀)) τ' = c₁ := + (runFrom_eq_of_halt tm₀.outputToTape _ hτ'le hτ'halt).symm.trans hc1_run + -- The phase-1 space bound: the tidy space, plus one frontier walk over the written output. + have h₁sp : tm₀.outputToTape.spaceUsed (cStart.withState (some tm₀.outputToTape.q₀)) τ' + ≤ c₀ * (s a + 1) + k₀ + (w.length + 1) := by + rw [hstart1, spaceUsed_outputToTape_withOutput] + refine le_trans (spaceUsed_outputToTape tm₀ (tm₀.initCfg (enc a)) τ') ?_ + have hsp' : tm₀.spaceUsed (tm₀.initCfg (enc a)) τ' ≤ c₀ * (s a + 1) + k₀ := + le_trans (spaceUsed_mono tm₀ (tm₀.initCfg (enc a)) hτ'le) htidysp + have houtlen : (tm₀.runFrom (tm₀.initCfg (enc a)) τ').output.length ≤ w.length := by + have hτeq : τ' + (τ - τ') = τ := by omega + have hmono := length_output_mono tm₀ (tm₀.runFrom (tm₀.initCfg (enc a)) τ') (τ - τ') + rw [← runFrom_add, hτeq, htidyrun, hX_def] at hmono + simpa using hmono + omega + -- =================================================================================== + -- Phase 2: rewind the last tape's head from the frontier back to the start of the word. + -- =================================================================================== + have hcs1_state : (c₁.withState (some tmR.q₀)).state = some tmR.q₀ := rfl + have hcs1_tape : (c₁.withState (some tmR.q₀)).workTapes (Fin.last k₀) = tapeOfList w := by + change (outCfg X).workTapes (Fin.last k₀) = tapeOfList w + simp only [outCfg_workTapes_last, hX_def, wordsCfg_output] + have hcs1_pos : (c₁.withState (some tmR.q₀)).workTapePos (Fin.last k₀) = (w.length : ℤ) := by + change (outCfg X).workTapePos (Fin.last k₀) = (w.length : ℤ) + simp only [outCfg_workTapePos_last, hX_def, wordsCfg_output] + obtain ⟨u₂, hu₂, h₂act, h₂halteq, hframe⟩ := + hR (enc a) (c₁.withState (some tmR.q₀)) w hcs1_state hcs1_tape hcs1_pos + -- The phase-2 space bound: the moving head stays in `[-1, w.length]`, every other head is fixed. + have h₂sp : tmR.spaceUsed (c₁.withState (some tmR.q₀)) u₂ ≤ (w.length + 2) + (k₀ + 1) := by + refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmR.q₀)) u₂ (Fin.last k₀) + (-1) (w.length : ℤ) ?_ ?_) ?_ + · exact fun m hm => ⟨(hframe m hm).2.2.2.2.1, (hframe m hm).2.2.2.2.2⟩ + · exact fun m hm j hj => ((hframe m hm).2.2.1 j hj).2 + · have htoNat : ((w.length : ℤ) + 1 - (-1)).toNat = w.length + 2 := by omega + omega + -- =================================================================================== + -- Assemble the two phases and read off the halting configuration and the two bounds. + -- =================================================================================== + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tm₀.outputToTape) (tm₂ := tmR) (c := cStart) + (by rw [hcStart_def]; rfl) hc1_run' hc1_state hτ'act h₁sp h₂halteq rfl h₂act h₂sp + refine ⟨τ' + u₂, ?_, Function.update (fun _ => []) (Fin.last k₀) w, ?_, rfl, ?_⟩ + · -- Time: `τ' + u₂ ≤ τ + (w.length + 3)`, with `τ ≤ c₀·(t a+1)` and `w.length ≤ t a`. + have hτlin : τ ≤ c₀ * (t a + 1) := hτ + have hprod : (c₀ + k₀ + 4) * (t a + 1) = c₀ * (t a + 1) + (k₀ + 4) * (t a + 1) := by + rw [show c₀ + k₀ + 4 = c₀ + (k₀ + 4) from by omega, Nat.add_mul] + have h4 : 4 * (t a + 1) ≤ (k₀ + 4) * (t a + 1) := Nat.mul_le_mul (by omega) (le_refl _) + omega + · -- The composed run halts in the normal-form configuration `wordsCfg`. + rw [hseq_run] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp [Cfg.withState_inputPos, hc1_def, Cfg.withOutput_inputPos, hX_def, outCfg] + · funext l + induction l using Fin.lastCases with + | last => funext z; simp [hc1_def, hX_def] + | cast j => funext z; simp [hc1_def, hX_def] + · funext l + induction l using Fin.lastCases with + | last => simp [hc1_def, hX_def] + | cast j => simp [hc1_def, hX_def] + · simp [Cfg.withState_output, hc1_def, Cfg.withOutput_output] + · -- Space: `s₁' + s₂'` fits the budget `(c₀+k₀+4)·(s a + w.length + 1) + (k₀+1)`. + refine le_trans hseq_sp ?_ + have e1 : c₀ * (s a + 1) ≤ c₀ * (s a + w.length + 1) := Nat.mul_le_mul (le_refl _) (by omega) + have e2 : (k₀ + 4) * (w.length + 1) ≤ (k₀ + 4) * (s a + w.length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have e3 : (c₀ + k₀ + 4) * (s a + w.length + 1) + = c₀ * (s a + w.length + 1) + (k₀ + 4) * (s a + w.length + 1) := by + rw [show c₀ + k₀ + 4 = c₀ + (k₀ + 4) from by omega, Nat.add_mul] + have e4 : (k₀ + 4) * (w.length + 1) = (k₀ + 4) * w.length + (k₀ + 4) := by + rw [Nat.mul_add, Nat.mul_one] + have e5 : 4 * w.length ≤ (k₀ + 4) * w.length := Nat.mul_le_mul (by omega) (le_refl _) + omega + +end Turing.MultiTapeTM From ac246487fdcd5c21df771b369f12ab0e2a548078 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 20:58:08 +0000 Subject: [PATCH 29/93] feat(MultiTapeTM): reindex a machine's tapes along an embedding Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../MultiTape/Plumbing/ExtendTapes.lean | 227 ++++++++++++++++++ 2 files changed, 228 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean diff --git a/Cslib.lean b/Cslib.lean index 351082100..7aece5fda 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -63,6 +63,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrume public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean new file mode 100644 index 000000000..871e8bd09 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Data.Fintype.Inv +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Reindexing a machine's work tapes along an embedding + +`extendTapes tm e`, for an embedding `e : Fin k ↪ Fin k'`, runs `tm` inside a machine with `k'` +work tapes, using the tapes selected by `e`: work tape `e j` plays the role of `tm`'s tape `j`, +and every tape outside the range of `e` is never written and never moves. + +The construction is a step-semiconjugation. The configuration map `embed e cfg extraTapes extraPos` +places `cfg` on the tapes in the range of `e` and fills the others with fixed contents `extraTapes` +and head positions `extraPos`; `step` commutes with it unconditionally, so the reindexed run +mirrors the original by `Turing.MultiTapeTM.runFrom_comm_of_step` — no induction. Since the extra +tapes never move, the reindexed run uses the same space on the embedded tapes as `tm` does, plus at +most one cell for each of the remaining tapes. + +Both the machine and the configuration map route each target tape `l` through the computable +partial inverse `partialInv e l : Option (Fin k)`, which is `some j` exactly when `e j = l`. Since +they share this scrutinee, the semiconjugation splits tape by tape into a source tape (`some j`) or +an untouched extra tape (`none`). +-/ + +namespace Turing.MultiTapeTM + +variable {k k' : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- The computable partial inverse of the embedding `e`: `partialInv e l = some j` when `e j = l` +(such `j` is unique by injectivity), and `none` when `l` lies outside the range of `e`. -/ +@[expose] public def partialInv (e : Fin k ↪ Fin k') (l : Fin k') : Option (Fin k) := + if h : ∃ j, e j = l then + some (Fintype.choose (fun j => e j = l) + (existsUnique_of_exists_of_unique h fun _ _ ha hb => e.injective (ha.trans hb.symm))) + else none + +/-- `tm` run on the tapes selected by the embedding `e`, leaving other tapes untouched: work tape +`e j` plays the role of `tm`'s tape `j`, and any tape outside `range e` is never written and never +moves. -/ +@[expose] public def extendTapes (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') : + MultiTapeTM k' Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work (e j) + { inputTape := a.inputTape + workTapes := fun l => match partialInv e l with + | some j => a.workTapes j + | none => (none, 0) + output := a.output + state := a.state } + +/-- A configuration of `tm`, embedded: tape `j` goes to tape `e j`, the tapes outside `range e` +carry the given `extraTapes` contents and `extraPos` head positions. -/ +@[expose] public def embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) : + Cfg k' Symbol State input := + ⟨cfg.state, cfg.inputPos, + fun l => match partialInv e l with + | some j => cfg.workTapes j + | none => extraTapes l, + fun l => match partialInv e l with + | some j => cfg.workTapePos j + | none => extraPos l, + cfg.output⟩ + +variable {tm : MultiTapeTM k Symbol State} {e : Fin k ↪ Fin k'} + {cfg : Cfg k Symbol State input} {extraTapes : Fin k' → ℤ → Option Symbol} {extraPos : Fin k' → ℤ} + +/-- The partial inverse recovers the source tape of an embedded tape. -/ +@[simp] +public lemma partialInv_embed (e : Fin k ↪ Fin k') (j : Fin k) : partialInv e (e j) = some j := by + have hex : ∃ j', e j' = e j := ⟨j, rfl⟩ + have hpi : partialInv e (e j) = some (Fintype.choose (fun j' => e j' = e j) + (existsUnique_of_exists_of_unique hex fun _ _ ha hb => e.injective (ha.trans hb.symm))) := + dite_eq_left hex + rw [hpi] + congr 1 + exact e.injective (Fintype.choose_spec (fun j' => e j' = e j) _) + +/-- Outside the range of `e`, the partial inverse is undefined. -/ +public lemma partialInv_eq_none (e : Fin k ↪ Fin k') {l : Fin k'} (hl : ¬ ∃ j, e j = l) : + partialInv e l = none := + dite_eq_right hl + +@[simp] +public lemma embed_inputSymbol (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) : + (embed e cfg extraTapes extraPos).inputSymbol = cfg.inputSymbol := rfl + +@[simp] +public lemma embed_workTapes_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapes (e j) = cfg.workTapes j := by + simp only [embed, partialInv_embed] + +@[simp] +public lemma embed_workTapePos_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapePos (e j) = cfg.workTapePos j := by + simp only [embed, partialInv_embed] + +@[simp] +public lemma embed_workTapeSymbols_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapeSymbols (e j) = cfg.workTapeSymbols j := by + simp only [Cfg.workTapeSymbols, embed_workTapes_embed, embed_workTapePos_embed] + +/-- Reindexing is a step-semiconjugation: the reindexed machine acts on the embedded tapes exactly +as `tm` does, and never touches the extra tapes. -/ +public lemma step_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) : + (tm.extendTapes e).step (embed e cfg extraTapes extraPos) + = embed e (tm.step cfg) extraTapes extraPos := by + cases hq : cfg.state with + | none => + have h1 : (embed e cfg extraTapes extraPos).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (embed e cfg extraTapes extraPos).state = some q := hq + have hin : (embed e cfg extraTapes extraPos).inputSymbol = cfg.inputSymbol := rfl + have hargs : (fun j : Fin k => (embed e cfg extraTapes extraPos).workTapeSymbols (e j)) + = cfg.workTapeSymbols := + funext fun j => embed_workTapeSymbols_embed e cfg extraTapes extraPos j + rw [step_apply_of_state h1, step_apply_of_state hq] + simp only [extendTapes, hin, hargs] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + simp only [Action.apply, embed] + cases partialInv e l with + | none => rfl + | some j => rfl + · funext l + simp only [Action.apply, embed] + cases partialInv e l with + | none => simp + | some j => rfl + +/-- The reindexed run mirrors the original, with the extra tapes held fixed throughout. -/ +public lemma runFrom_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) : + (tm.extendTapes e).runFrom (embed e cfg extraTapes extraPos) n + = embed e (tm.runFrom cfg n) extraTapes extraPos := + runFrom_comm_of_step (fun c => embed e c extraTapes extraPos) + (fun c => step_embed tm e c extraTapes extraPos) cfg n + +section Space + +/-- On an embedded tape `e j`, the reindexed run's head visits exactly the cells `tm`'s head of +tape `j` visits. -/ +public lemma visitedByTapeHead_embed_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) (j : Fin k) : + (tm.extendTapes e).visitedByTapeHead (embed e cfg extraTapes extraPos) n (e j) + = tm.visitedByTapeHead cfg n j := by + refine Finset.image_congr fun m _ => ?_ + rw [runFrom_embed, embed_workTapePos_embed] + +/-- The head of a tape outside `range e` never leaves its starting position. -/ +public lemma workTapePos_embed_of_not_range (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) {l : Fin k'} (hl : ¬ ∃ j, e j = l) : + ((tm.extendTapes e).runFrom (embed e cfg extraTapes extraPos) n).workTapePos l + = extraPos l := by + rw [runFrom_embed] + simp only [embed, partialInv_eq_none e hl] + +/-- **Space bound for a reindexed run.** The embedded tapes use exactly the space `tm` uses; each +of the remaining `k' - k` tapes never moves, so it contributes at most one cell. -/ +public lemma spaceUsed_embed_le (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) : + (tm.extendTapes e).spaceUsed (embed e cfg extraTapes extraPos) n + ≤ tm.spaceUsed cfg n + (k' - k) := by + classical + -- an embedded tape `e j` uses exactly the space of `tm`'s tape `j` + have key : ∀ j : Fin k, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n (e j) + = tm.spaceUsedByTape cfg n j := + fun j => congrArg Finset.card (visitedByTapeHead_embed_embed tm e cfg extraTapes extraPos n j) + -- a tape outside `range e` never moves, so it uses at most one cell + have bound1 : ∀ l, ¬ (∃ j, e j = l) → + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l ≤ 1 := by + intro l hl + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Finset.card_singleton (extraPos l))) + intro z hz + obtain ⟨m, _, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [workTapePos_embed_of_not_range tm e cfg extraTapes extraPos m hl] + exact Finset.mem_singleton_self _ + calc (tm.extendTapes e).spaceUsed (embed e cfg extraTapes extraPos) n + = (∑ l ∈ Finset.univ \ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l) + + ∑ l ∈ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l := + (Finset.sum_sdiff (Finset.subset_univ _)).symm + _ ≤ (k' - k) + tm.spaceUsed cfg n := by + refine Nat.add_le_add ?_ (le_of_eq ?_) + · calc (∑ l ∈ Finset.univ \ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l) + ≤ ∑ _l ∈ Finset.univ \ Finset.univ.image e, 1 := by + refine Finset.sum_le_sum fun l hl => bound1 l ?_ + rw [Finset.mem_sdiff] at hl + rintro ⟨j, rfl⟩ + exact hl.2 (Finset.mem_image_of_mem e (Finset.mem_univ j)) + _ = k' - k := by + rw [Finset.sum_const, smul_eq_mul, mul_one, + Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin, Finset.card_image_of_injective _ e.injective, Finset.card_univ, + Fintype.card_fin] + · rw [Finset.sum_image fun x _ y _ h => e.injective h] + simp only [spaceUsed] + exact Finset.sum_congr rfl fun j _ => key j + _ = tm.spaceUsed cfg n + (k' - k) := Nat.add_comm _ _ + +end Space + +end Turing.MultiTapeTM From df8f12ec700dfef1a80c1d88b58a2a2421872aec Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 21:15:59 +0000 Subject: [PATCH 30/93] feat(MultiTapeTM): machines to emit a tape to the output and to set a cell Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../Turing/MultiTape/Plumbing/EmitTape.lean | 512 ++++++++++++++++++ 2 files changed, 513 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean diff --git a/Cslib.lean b/Cslib.lean index 7aece5fda..c4d1ace6d 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -63,6 +63,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrume public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean new file mode 100644 index 000000000..77262637f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean @@ -0,0 +1,512 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas + +/-! +# Machines that emit a work tape to the output and set a single cell + +Two small machines used by combinators to assemble the write-only output tape and to place or +remove markers on a work tape. + +`emitTape i` reads the word held on work tape `i` from its start and appends it, symbol by symbol, +to the real output tape, moving the tape-`i` head right over the word and halting on the first +blank. It never writes to any work tape, never moves the input head and never moves any other work +head: the only lasting effect is the appended output and the tape-`i` head resting at the frontier +`w.length`. + +`setCell i v` writes a designated symbol value `v` into cell `-1` of work tape `i` — the cell just +left of the word — and returns the head to `0`, touching nothing else. It is the primitive used to +place or clear a flag mark. The machine is specialised to the cell `-1`, the only cell the callers +need; a general version for an arbitrary cell `z` would require a head able to reach `z`, i.e. a +state count depending on `z`. + +## Main results + +* `Turing.MultiTapeTM.exists_emitTape`: the machine appending a work tape's word to the output. +* `Turing.MultiTapeTM.exists_setCell`: the machine setting cell `-1` of a work tape to a value. +-/ + +namespace Turing.MultiTapeTM + +variable {K : ℕ} {Symbol : Type*} {input : List Symbol} + +/-! ## Emitting a work tape to the output -/ + +/-- The tape-emitting machine for tape `i`. It has a single live state. Reading a symbol `s` on +tape `i` it appends `s` to the output, moves the tape-`i` head right and stays live; reading the +first blank it halts, writing nothing and moving nothing. No work tape is ever written, the input +head never moves and no other work head moves. -/ +def emitTape (i : Fin K) : MultiTapeTM K Symbol Unit where + q₀ := () + tr _ _ work := + match work i with + | some s => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := some s, state := some () } + | none => + { inputTape := 0, workTapes := fun _ => (none, 0), + output := none, state := none } + +namespace EmitTape + +variable {i : Fin K} {ip : Fin (input.length + 2)} {W : Fin K → ℤ → Option Symbol} + {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the emitting machine: state `q`, the head of tape `i` at `p`, tape contents +`W`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option Unit) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol Unit input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as their outputs and tape-`i` head +positions agree. -/ +lemma cfg_congr {q : Option Unit} {out out' : List Symbol} {p p' : ℤ} + (hout : out = out') (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W WP out' p' := by + rw [hout, hp] + +/-- Emitting one symbol: reading `s` on tape `i` appends `s` to the output and moves the head +right, staying live. -/ +lemma step_emit_some {s : Symbol} (hs : W i p = some s) : + (emitTape i).step (cfg input i (some ()) ip W WP out p) = + cfg input i (some ()) ip W WP (out ++ [s]) (p + 1) := by + have hsym : (cfg input i (some ()) ip W WP out p).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [emitTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Halting: reading the first blank on tape `i` the machine halts, writing and moving nothing. -/ +lemma step_emit_none (hs : W i p = none) : + (emitTape i).step (cfg input i (some ()) ip W WP out p) = + cfg input i none ip W WP out p := by + have hsym : (cfg input i (some ()) ip W WP out p).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [emitTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- The scanning phase: from the start of the word, after `n ≤ w.length` steps the head is at +position `n` and the first `n` symbols of `w` have been appended to the output. -/ +lemma runFrom_scan {w : List Symbol} (hw : W i = tapeOfList w) (n : ℕ) (hn : n ≤ w.length) : + (emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) n = + cfg input i (some ()) ip W WP (out ++ w.take n) (n : ℤ) := by + induction n with + | zero => + rw [runFrom_zero] + exact cfg_congr (by simp) (by simp) + | succ n ih => + have hsym : W i (n : ℤ) = some (w[n]'(by omega)) := by + rw [hw, tapeOfList_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_emit_some hsym] + refine cfg_congr ?_ (by push_cast; omega) + rw [List.append_assoc, List.take_concat_get' w n (by omega)] + +/-- The complete run: from the start of the word, after `w.length + 1` steps the machine has +halted with the full word `w` appended to the output and the head at the frontier `w.length`. -/ +lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : + (emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) (w.length + 1) = + cfg input i none ip W WP (out ++ w) (w.length : ℤ) := by + have hnone : W i (w.length : ℤ) = none := by + rw [hw, tapeOfList_ofNat] + exact List.getElem?_eq_none (by omega) + rw [runFrom_succ_eq_step', runFrom_scan hw w.length le_rfl, step_emit_none hnone] + exact cfg_congr (by rw [List.take_length]) rfl + +/-- Throughout the run the head of tape `i` stays within `[0, w.length]`: it walks right from the +start of the word to the frontier and stops. -/ +lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) + (hm : m ≤ w.length + 1) : + (0 : ℤ) ≤ ((emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) m).workTapePos i ∧ + ((emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) m).workTapePos i ≤ + (w.length : ℤ) := by + rcases Nat.lt_or_ge m (w.length + 1) with hlt | hge + · have hml : m ≤ w.length := by omega + rw [runFrom_scan hw m hml] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + · obtain rfl : m = w.length + 1 := by omega + rw [runFrom_full hw] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + +/-- No action of the machine writes to a work tape. -/ +lemma tr_write_none (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) (l : Fin K) : + (((emitTape i).tr q inp work).workTapes l).1 = none := by + simp only [emitTape] + cases work i <;> rfl + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((emitTape i).tr q inp work).inputTape = 0 := by + simp only [emitTape] + cases work i <;> rfl + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((emitTape i).tr q inp work).workTapes l).2 = 0 := by + simp only [emitTape] + cases work i <;> simp [h] + +/-- One step preserves the input head, every tape's contents and every work head other than the +head of tape `i`. (The output does change.) -/ +lemma step_frame (c : Cfg K Symbol Unit input) : + ((emitTape i).step c).inputPos = c.inputPos ∧ + (∀ j, ((emitTape i).step c).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((emitTape i).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, fun _ => rfl, fun _ _ => rfl⟩ + | some q => + refine ⟨?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · intro j + rw [step_workTapes_of_state hc, tr_write_none q c.inputSymbol c.workTapeSymbols j] + · intro j hj + rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj] + simp + +/-- The whole run preserves the input head, every tape's contents and every work head other than +the head of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol Unit input) (m : ℕ) : + ((emitTape i).runFrom c m).inputPos = c.inputPos ∧ + (∀ j, ((emitTape i).runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((emitTape i).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, fun _ => rfl, fun _ _ => rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((emitTape i).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, fun j => (h2 j).trans (ih.2.1 j), + fun j hj => (h3 j hj).trans (ih.2.2 j hj)⟩ + +end EmitTape + +open EmitTape in +/-- **The machine that appends a work tape's word to the output.** One machine per tape index `i`: +started with tape `i` holding a word `w` in cells `0, …, w.length - 1` and the head at position +`0`, it halts within `w.length + 2` steps having appended `w` to the output, with the tape-`i` +head resting at the frontier `w.length` and every other field — input head, all tape contents and +all other work heads — unchanged at every step of the run. Before the halting step the machine is +live, so runs chain sequentially. -/ +public theorem exists_emitTape {Symbol : Type*} {K : ℕ} (i : Fin K) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input) (w : List Symbol), + c.state = some tm.q₀ → + c.workTapes i = tapeOfList w → + c.workTapePos i = 0 → + ∃ u ≤ w.length + 2, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, c.workTapes, + Function.update c.workTapePos i (w.length : ℤ), c.output ++ w⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ + (∀ j, (tm.runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (0 : ℤ) ≤ (tm.runFrom c m).workTapePos i ∧ + (tm.runFrom c m).workTapePos i ≤ (w.length : ℤ) := by + refine ⟨Unit, inferInstance, emitTape i, fun input c w hstate hwi hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some () := hstate + have hwi' : W i = tapeOfList w := hwi + have hwp' : WP i = 0 := hwp + have hc0 : (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) = + cfg input i (some ()) ip W WP out 0 := by + refine Cfg.ext rfl rfl rfl ?_ rfl + change WP = Function.update WP i 0 + rw [← hwp', Function.update_eq_self] + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ w.length + 1, + (∀ m < u, ((emitTape i).runFrom + (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) m).state ≠ none) ∧ + (emitTape i).runFrom (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) u = + ⟨none, ip, W, Function.update WP i (w.length : ℤ), out ++ w⟩ := by + have hrun : (emitTape i).runFrom + (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) (w.length + 1) = + ⟨none, ip, W, Function.update WP i (w.length : ℤ), out ++ w⟩ := by + rw [hc0, runFrom_full hwi'] + simp only [cfg] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (emitTape i) _ (w.length + 1) (by rw [hrun]) + have heq := runFrom_eq_of_halt (emitTape i) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ + obtain ⟨f1, f2, f3⟩ := runFrom_frame (⟨some (), ip, W, WP, out⟩) m + obtain ⟨g1, g2⟩ := runFrom_pos_range (input := input) (i := i) (ip := ip) (W := W) (WP := WP) + (out := out) hwi' m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, f3, g1, g2⟩ + +/-! ## Setting a single work-tape cell -/ + +/-- The control states of the cell-setting machine: `go` walks the head one cell left to cell +`-1`, `write` writes the value there and returns the head to `0`. -/ +inductive SetCellState : Type + | go + | write + +instance : Finite SetCellState := + Finite.of_injective + (fun q => match q with + | .go => (0 : Fin 2) + | .write => 1) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The cell-setting machine for tape `i` and value `v`. In state `go` it moves the head of tape +`i` one cell left, into state `write`. In state `write` it writes `v` at the current cell, moves +the head right and halts. No other tape is ever written, the input head never moves, no other work +head moves and nothing is output. -/ +def setCell (i : Fin K) (v : Option Symbol) : MultiTapeTM K Symbol SetCellState where + q₀ := .go + tr q _ _ := + match q with + | .go => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .write } + | .write => + { inputTape := 0, + workTapes := fun l => (if l = i then some v else none, if l = i then 1 else 0), + output := none, state := none } + +namespace SetCell + +variable {i : Fin K} {v : Option Symbol} {ip : Fin (input.length + 2)} + {W : Fin K → ℤ → Option Symbol} {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the cell-setting machine: state `q`, tape contents `W`, the head of tape +`i` at `p`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option SetCellState) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol SetCellState input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as their tape contents and tape-`i` head +positions agree. -/ +lemma cfg_congr {q : Option SetCellState} {W W' : Fin K → ℤ → Option Symbol} {p p' : ℤ} + (hW : W = W') (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W' WP out p' := by + rw [hW, hp] + +/-- Moving the head of tape `i` left in state `go`, unconditionally, entering `write`. -/ +lemma step_go : + (setCell i v).step (cfg input i (some .go) ip W WP out p) = + cfg input i (some .write) ip W WP out (p - 1) := by + unfold step + simp only [cfg] + simp only [setCell] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Writing `v` at the current cell in state `write`, moving the head right and halting. -/ +lemma step_write : + (setCell i v).step (cfg input i (some .write) ip W WP out p) = + cfg input i none ip (Function.update W i (Function.update (W i) p v)) WP out (p + 1) := by + unfold step + simp only [cfg] + simp only [setCell] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- After one step the machine is in state `write` with the head at cell `-1`. -/ +lemma runFrom_one : + (setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) 1 = + cfg input i (some .write) ip W WP out (-1) := by + rw [runFrom_succ_eq_step', runFrom_zero, step_go] + exact cfg_congr rfl (by omega) + +/-- The complete run: after two steps the machine has written `v` at cell `-1` of tape `i` and +returned the head to `0`. -/ +lemma runFrom_two : + (setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) 2 = + cfg input i none ip (Function.update W i (Function.update (W i) (-1) v)) WP out 0 := by + rw [show (2 : ℕ) = 1 + 1 from rfl, runFrom_add, runFrom_one, runFrom_succ_eq_step', + runFrom_zero, step_write] + exact cfg_congr rfl (by omega) + +/-- Throughout the run the head of tape `i` stays within `[-1, 0]`. -/ +lemma runFrom_pos_range (m : ℕ) (hm : m ≤ 2) : + (-1 : ℤ) ≤ ((setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) m).workTapePos i ∧ + ((setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) m).workTapePos i ≤ 0 := by + rcases m with _ | _ | _ | m + · rw [runFrom_zero] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + · rw [runFrom_one] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + · rw [runFrom_two] + constructor + · simp only [cfg, Function.update_self]; omega + · simp only [cfg, Function.update_self]; omega + · exact absurd hm (by omega) + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((setCell i v).tr q inp work).inputTape = 0 := by + simp only [setCell] + cases q <;> rfl + +/-- No action of the machine outputs. -/ +lemma tr_output (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((setCell i v).tr q inp work).output = none := by + simp only [setCell] + cases q <;> rfl + +/-- No action of the machine writes to a work tape other than tape `i`. -/ +lemma tr_write_ne (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((setCell i v).tr q inp work).workTapes l).1 = none := by + simp only [setCell] + cases q <;> simp [h] + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((setCell i v).tr q inp work).workTapes l).2 = 0 := by + simp only [setCell] + cases q <;> simp [h] + +/-- One step preserves the input head, the output, and every tape's contents and work head other +than those of tape `i`. -/ +lemma step_frame (c : Cfg K Symbol SetCellState input) : + ((setCell i v).step c).inputPos = c.inputPos ∧ + ((setCell i v).step c).output = c.output ∧ + (∀ j, j ≠ i → ((setCell i v).step c).workTapes j = c.workTapes j ∧ + ((setCell i v).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, rfl, fun _ _ => ⟨rfl, rfl⟩⟩ + | some q => + refine ⟨?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · rw [step_apply_of_state hc, Action.apply_output, tr_output]; simp + · intro j hj + refine ⟨?_, ?_⟩ + · rw [step_workTapes_of_state hc, tr_write_ne q c.inputSymbol c.workTapeSymbols hj] + · rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj]; simp + +/-- The whole run preserves the input head, the output, and every tape's contents and work head +other than those of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol SetCellState input) (m : ℕ) : + ((setCell i v).runFrom c m).inputPos = c.inputPos ∧ + ((setCell i v).runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → ((setCell i v).runFrom c m).workTapes j = c.workTapes j ∧ + ((setCell i v).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, rfl, fun _ _ => ⟨rfl, rfl⟩⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((setCell i v).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, + fun j hj => ⟨(h3 j hj).1.trans (ih.2.2 j hj).1, (h3 j hj).2.trans (ih.2.2 j hj).2⟩⟩ + +end SetCell + +open SetCell in +/-- **The machine that sets cell `-1` of a work tape.** One machine per tape index `i` and value +`v`: started with the head of tape `i` at position `0`, it halts within `4` steps having written +`v` into cell `-1` of tape `i` and returned the head to `0`, with every other field — input head, +output, all other tape contents and all other work heads — unchanged at every step of the run. +Before the halting step the machine is live, so runs chain sequentially. + +This is the specialisation to the cell `z = -1` of a general "set cell `z`" primitive: it is the +only cell the callers (which mark and clear the flag cell just left of a word) need, and the +excursion is confined to `[-1, 0]`. -/ +public theorem exists_setCell {Symbol : Type*} {K : ℕ} (i : Fin K) (v : Option Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input), + c.state = some tm.q₀ → c.workTapePos i = 0 → + ∃ u ≤ 4, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + Function.update c.workTapes i (Function.update (c.workTapes i) (-1) v), + c.workTapePos, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ (tm.runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapes j = c.workTapes j ∧ + (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (-1 : ℤ) ≤ (tm.runFrom c m).workTapePos i ∧ (tm.runFrom c m).workTapePos i ≤ 0 := by + refine ⟨SetCellState, inferInstance, setCell i v, fun input c hstate hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some SetCellState.go := hstate + have hwp' : WP i = 0 := hwp + have hupdWP : Function.update WP i 0 = WP := by rw [← hwp', Function.update_eq_self] + have hc0 : (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) = + cfg input i (some .go) ip W WP out 0 := by + refine Cfg.ext rfl rfl rfl ?_ rfl + exact hupdWP.symm + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ 2, + (∀ m < u, ((setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) + m).state ≠ none) ∧ + (setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) u = + ⟨none, ip, Function.update W i (Function.update (W i) (-1) v), WP, out⟩ := by + have hrun : (setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) 2 = + ⟨none, ip, Function.update W i (Function.update (W i) (-1) v), WP, out⟩ := by + rw [hc0, runFrom_two] + unfold cfg + rw [hupdWP] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (setCell i v) _ 2 (by rw [hrun]) + have heq := runFrom_eq_of_halt (setCell i v) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ + obtain ⟨f1, f2, f3⟩ := runFrom_frame (⟨some SetCellState.go, ip, W, WP, out⟩) m + obtain ⟨g1, g2⟩ := runFrom_pos_range (input := input) (i := i) (v := v) (ip := ip) (W := W) + (WP := WP) (out := out) m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, f3, g1, g2⟩ + +end Turing.MultiTapeTM From 62366673b5ba9d14bfc77297947b08b36becb45b Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 21:19:52 +0000 Subject: [PATCH 31/93] feat(MultiTapeTM): the NeverOutputs building block MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `Cfg.withOutput` moves to Configuration.lean, and `Plumbing/NeverOutputs.lean` abstracts the recurring "the real output is inert" argument: a machine none of whose transitions emit an output symbol — every tape transformer — has its run and space usage commute with replacing the real output, and preserves it along the run. This is the uniform way to discharge the real-output quantifier that `TransformsTapes` carries, replacing the per-machine `withOutput` reasoning (outputToTape's own copies stay for now). Co-Authored-By: Claude Opus 5 (1M context) --- Cslib.lean | 1 + .../Turing/MultiTape/Configuration.lean | 5 ++ .../MultiTape/Plumbing/NeverOutputs.lean | 79 +++++++++++++++++++ .../MultiTape/Plumbing/OutputToTape.lean | 8 -- 4 files changed, 85 insertions(+), 8 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean diff --git a/Cslib.lean b/Cslib.lean index c4d1ace6d..a3774ed7e 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -66,6 +66,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.NeverOutputs public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 24a44c39c..c68eecd9d 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -181,6 +181,11 @@ def Cfg.workTapeSymbols (cfg : Cfg k Symbol State input) (i : Fin k) : Option Sy /-- A configuration is halted when it has no state to continue from. -/ abbrev Cfg.Halted (cfg : Cfg k Symbol State input) : Prop := cfg.state = none +/-- The same configuration with a different output tape. -/ +@[simps] def Cfg.withOutput (c : Cfg k Symbol State input) (out : List Symbol) : + Cfg k Symbol State input := + ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ + /-- The initial configuration for a starting state and an input string. -/ @[simp] def Cfg.init (q₀ : State) (input : List Symbol) : Cfg k Symbol State input := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean new file mode 100644 index 000000000..81b9752b2 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Machines that never write the real output + +Every tape *transformer* redirects its result onto a work tape and never touches the real output. +For such a machine the real output is inert: preserved along the whole run, and the run and space +usage commute with replacing it. This is what lets a transformer be run from a configuration whose +output is already present, as the word-transformer interface +`Turing.MultiTapeTM.TransformsTapes` quantifies over — the caller need not know the output is +empty. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- A machine none of whose transitions emit an output symbol. -/ +public def NeverOutputs (tm : MultiTapeTM k Symbol State) : Prop := + ∀ q inp work, (tm.tr q inp work).output = none + +variable {tm : MultiTapeTM k Symbol State} + +/-- Such a machine's step commutes with replacing the real output. -/ +public lemma step_withOutput_of_neverOutputs (h : NeverOutputs tm) + (cfg : Cfg k Symbol State input) (out : List Symbol) : + tm.step (cfg.withOutput out) = (tm.step cfg).withOutput out := by + cases hq : cfg.state with + | none => + have h1 : (cfg.withOutput out).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (cfg.withOutput out).state = some q := hq + have hin : (cfg.withOutput out).inputSymbol = cfg.inputSymbol := rfl + have hws : (cfg.withOutput out).workTapeSymbols = cfg.workTapeSymbols := rfl + rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] + refine Cfg.ext rfl rfl (funext fun l => funext fun z => by simp [Cfg.withOutput]) + (funext fun l => by simp [Cfg.withOutput]) ?_ + simp only [Action.apply_output, Cfg.withOutput_output, + h q cfg.inputSymbol cfg.workTapeSymbols, Option.toList_none, List.append_nil] + +/-- The run of such a machine commutes with replacing the real output. -/ +public lemma runFrom_withOutput_of_neverOutputs (h : NeverOutputs tm) + (cfg : Cfg k Symbol State input) (out : List Symbol) (n : ℕ) : + tm.runFrom (cfg.withOutput out) n = (tm.runFrom cfg n).withOutput out := + runFrom_comm_of_step (fun c => c.withOutput out) + (fun c => step_withOutput_of_neverOutputs h c out) cfg n + +/-- Such a machine's space does not depend on the real output already present. -/ +public lemma spaceUsed_withOutput_of_neverOutputs (h : NeverOutputs tm) + (cfg : Cfg k Symbol State input) (out : List Symbol) (u : ℕ) : + tm.spaceUsed (cfg.withOutput out) u = tm.spaceUsed cfg u := by + refine spaceUsed_eq_of_workTapePos _ _ u fun m _ => ?_ + rw [runFrom_withOutput_of_neverOutputs h]; rfl + +/-- The real output is unchanged along the run of such a machine. -/ +public lemma output_runFrom_of_neverOutputs (h : NeverOutputs tm) + (cfg : Cfg k Symbol State input) (n : ℕ) : + (tm.runFrom cfg n).output = cfg.output := by + induction n with + | zero => simp + | succ n ih => + rw [runFrom_succ_eq_step', step_output, ih] + rcases hs : (tm.runFrom cfg n).state with _ | q + · simp [outputSymbol, hs] + · simp [outputSymbol, hs, h q] + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean index 3db758561..ea7ffec0a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -127,15 +127,7 @@ public lemma runFrom_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol tm.outputToTape.runFrom (outCfg c) n = outCfg (tm.runFrom c n) := runFrom_comm_of_step outCfg (step_outCfg tm) c n -/-- The same configuration with a different real output. `outputToTape` never writes the real -output, so its run commutes with this — the caller may run it with output already present, as -`TransformsTapes` quantifies over. -/ -@[expose, simps] public def _root_.Turing.Cfg.withOutput (c : Cfg k' Symbol State input') - (out : List Symbol) : Cfg k' Symbol State input' := - ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ - section WithOutput -variable {k' : ℕ} /-- `outputToTape tm` never writes the real output, so replacing it commutes with a step. -/ public lemma step_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) From 7f756f255cc8bd9d7a81ee6452ff9b9b45077f71 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 21:23:40 +0000 Subject: [PATCH 32/93] feat(MultiTapeTM): space bound for the input-redirected machine MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit spaceUsed_inputFromTape: the k inner tapes visit exactly what the original does (heads agree under inCfg), and the virtual-input and flag tapes each move only with the simulated input head — which stays in [-1, I.length] by the Fin bound on the input position — so they add at most 2*(I.length+2). Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Plumbing/InputFromTape.lean | 49 +++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean index eb754cf7e..c78c36f11 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -6,6 +6,7 @@ Authors: Christian Reitwiessner, Samuel Schlesinger module +public import Mathlib.Algebra.BigOperators.Fin public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes @@ -270,6 +271,54 @@ public lemma runFrom_inCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) runFrom_comm_of_step (fun c => inCfg mark c outerInput) (fun c => step_inCfg tm mark c outerInput) c n +/-- **Space of the input-redirected machine.** The `k` inner tapes visit exactly what the original +does; the two extra tapes (virtual input, flag) each move only with the simulated input head, +which stays within `[-1, I.length]` — so they add at most `2 * (I.length + 2)`. -/ +public lemma spaceUsed_inputFromTape (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) (n : ℕ) : + tm.inputFromTape.spaceUsed (inCfg mark c outerInput) n ≤ + tm.spaceUsed c n + 2 * (I.length + 2) := by + classical + have hmir : ∀ m, tm.inputFromTape.runFrom (inCfg mark c outerInput) m = + inCfg mark (tm.runFrom c m) outerInput := fun m => runFrom_inCfg tm mark c outerInput m + -- the inner tapes: same visited set as the original (heads agree under `inCfg`) + have hcast : ∀ j : Fin k, tm.inputFromTape.visitedByTapeHead (inCfg mark c outerInput) n + (j.castAdd 2) = tm.visitedByTapeHead c n j := by + intro j + refine Finset.image_congr fun m _ => ?_ + rw [hmir m, inCfg_workTapePos_castAdd] + -- an extra tape's head lies in `[-1, I.length]` at every step + have hextra : ∀ l : Fin (k + 2), l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ → + tm.inputFromTape.visitedByTapeHead (inCfg mark c outerInput) n l ⊆ + Finset.Icc (-1 : ℤ) (I.length : ℤ) := by + intro l hl z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hmir m] + have hb := (tm.runFrom c m).inputPos.isLt + rcases hl with rfl | rfl + · rw [inCfg_workTapePos_vip]; exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + · rw [inCfg_workTapePos_flag]; exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + have hextra_card : ∀ l : Fin (k + 2), l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ → + tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n l ≤ I.length + 2 := by + intro l hl + refine le_trans (Finset.card_le_card (hextra l hl)) ?_ + rw [Int.card_Icc]; omega + -- split the tape sum: inner tapes + the two extra + rw [spaceUsed, Fin.sum_univ_add] + have hinner : ∑ j : Fin k, tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n + (j.castAdd 2) = tm.spaceUsed c n := by + rw [spaceUsed] + exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + have htwo : ∑ j : Fin 2, tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n + (j.natAdd k) ≤ 2 * (I.length + 2) := by + rw [Fin.sum_univ_two] + have e0 := hextra_card ((0 : Fin 2).natAdd k) (Or.inl (Fin.ext (by simp))) + have e1 := hextra_card ((1 : Fin 2).natAdd k) (Or.inr (Fin.ext (by simp))) + omega + rw [hinner] + exact Nat.add_le_add_left htwo _ + + end Projections end Turing.MultiTapeTM From 74134919bdf2bad94e3e768c61c2fefe503ee26c Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:04:02 +0000 Subject: [PATCH 33/93] feat(MultiTapeTM): a computable function read from a work tape, as a tape transformer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `exists_transformsTapes_ofComputable`: the input-tape adapter, made to read from a work tape instead. The machine is `setMark ; inputFromTape M₀ ; setClear`, where `M₀` is the `ofComputableInput` machine (reading the real input) and `inputFromTape` redirects its input reading onto the virtual work tape, bracketed by two one-cell writes placing and removing the boundary flag the redirection needs. The middle phase's run and space go through `runFrom_inCfg` / `spaceUsed_inputFromTape` and `M₀`'s own `TransformsTapes` (which threads the real output through). Three phases assembled by nested `seq_spec`. This is the adapter the loop body call and the g-side of function composition both consume. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Adapters.lean | 217 ++++++++++++++++++ 1 file changed, 217 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index 91e252874..e4c5e06b0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -9,6 +9,8 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape /-! # From a computable function to a tape transformer @@ -170,4 +172,219 @@ public theorem exists_transformsTapes_ofComputableInput have e5 : 4 * w.length ≤ (k₀ + 4) * w.length := Nat.mul_le_mul (by omega) (le_refl _) omega +/-- **A computable function, read from a work tape, as a tape transformer.** The virtual input +tape is the work tape `Fin.last (k₀ + 1)` (one past the tidy machine's tapes and its output tape); +the result is written to the tidy machine's output tape `⟨k₀, _⟩`. Started with the input on the +virtual tape and every other work tape blank, the machine halts having written the encoded result +to the output tape, in linear time and space linear in the input and result lengths. + +Built from `exists_transformsTapes_ofComputableInput`'s machine `M₀` (which reads the *real* input +and leaves the result on a work tape): `inputFromTape M₀` redirects `M₀`'s input reading to the +virtual tape, bracketed by two one-cell writes that place and remove the boundary flag `M₀`'s +input redirection needs. -/ +public theorem exists_transformsTapes_ofComputable + {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ (c K : ℕ) (i o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + i ≠ o ∧ ∀ a, TransformsTapes tm + (fun _ ws => ws i = enc a ∧ ∀ l, l ≠ i → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) (c * (s a + (enc a).length + (encOut (g a)).length + 1) + K) := by + classical + -- The base machine `M₀` reads the *real* input tape and leaves `encOut (g a)` on work tape `o₀`. + obtain ⟨c_f, K₀, o₀, State₀, hfin₀, M₀, hM₀⟩ := exists_transformsTapes_ofComputableInput h + -- Two one-cell writers on the flag tape `⟨K₀ + 1, _⟩`: one places the boundary mark, one clears + -- it. They bracket the redirected run of `M₀` and supply what its input redirection needs. + obtain ⟨SM, hSMfin, setMark, hMark⟩ := + exists_setCell (Symbol := Bool) (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) (some true) + obtain ⟨SC, hSCfin, setClear, hClear⟩ := + exists_setCell (Symbol := Bool) (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) none + have := hfin₀ + have := hSMfin + have := hSCfin + refine ⟨c_f + 2 * K₀ + 12, K₀ + 2, ⟨K₀, by omega⟩, o₀.castAdd 2, SM ⊕ State₀ ⊕ SC, inferInstance, + setMark.seq ((inputFromTape M₀).seq setClear), ?_, fun a => ?_⟩ + · -- The virtual input tape `⟨K₀, _⟩` and the output tape `o₀.castAdd 2` are distinct. + exact Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + intro input ws out hP + obtain ⟨hi, hblank⟩ := hP + -- Split any tape index into an inner tape, the virtual input tape, or the flag tape. + have tcase : ∀ l : Fin (K₀ + 2), + (∃ j : Fin K₀, l = j.castAdd 2) ∨ l = ⟨K₀, by omega⟩ ∨ l = ⟨K₀ + 1, by omega⟩ := by + intro l + rcases Nat.lt_trichotomy l.val K₀ with hlt | heq | hgt + · exact Or.inl ⟨⟨l.val, hlt⟩, Fin.ext (by simp)⟩ + · exact Or.inr (Or.inl (Fin.ext (by simpa using heq))) + · have hb := l.isLt + exact Or.inr (Or.inr (Fin.ext (by simp; omega))) + -- Run the base machine on the real input `enc a`, reading off the encoded result and its bounds. + obtain ⟨τ, hτ, ws₀', hM₀run, hws₀', hM₀sp⟩ := hM₀ a (enc a) (fun _ => []) out ⟨rfl, fun _ => rfl⟩ + set w := encOut (g a) with hw_def + set start := wordsCfg input (some (setMark.seq ((inputFromTape M₀).seq setClear)).q₀) ws out + with hstart + -- =================================================================================== + -- Phase 1: place the boundary mark on the flag tape's cell `-1`. + -- =================================================================================== + obtain ⟨u₁, hu₁, h1act, h1eq, h1frame⟩ := + hMark input (start.withState (some setMark.q₀)) rfl (by simp [hstart]) + set C1 := setMark.runFrom (start.withState (some setMark.q₀)) u₁ with hC1 + -- The halting configuration of phase 1, restarted for `M₀`, is exactly `M₀`'s start as the + -- input-redirected machine sees it: the input `enc a` on the virtual tape, the flag marked. + have hAstart : C1.withState (some M₀.q₀) + = inCfg true (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) input := by + rw [h1eq, hstart] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · have hjf : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + have hji : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + funext z + simp [Cfg.withState_workTapes, inCfg_workTapes_castAdd, wordsCfg_workTapes, + Function.update_of_ne hjf, hblank _ hji] + · funext z + simp [Cfg.withState_workTapes, inCfg_workTapes_vip, wordsCfg_workTapes, hi] + · have hfi : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + rcases eq_or_ne z (-1 : ℤ) with hz | hz + · subst hz + simp [Cfg.withState_workTapes, inCfg_workTapes_flag, Function.update_self] + · simp [Cfg.withState_workTapes, inCfg_workTapes_flag, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hz, hblank _ hfi, tapeOfList_nil] + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_castAdd, wordsCfg_workTapePos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_vip, wordsCfg_workTapePos, + wordsCfg_inputPos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_workTapePos, + wordsCfg_inputPos] + -- Phase-1 space: one head walks `[-1, 0]`, every other head is fixed. + have h1sp : setMark.spaceUsed (start.withState (some setMark.q₀)) u₁ ≤ K₀ + 4 := by + refine le_trans (spaceUsed_le_of_one_moving _ u₁ (⟨K₀ + 1, by omega⟩) (-1) 0 + (fun m hm => ⟨(h1frame m hm).2.2.2.1, (h1frame m hm).2.2.2.2⟩) + (fun m hm j hj => ((h1frame m hm).2.2.1 j hj).2)) ?_ + have : ((0 : ℤ) + 1 - (-1)).toNat = 2 := by omega + omega + -- =================================================================================== + -- Phase 2: run `M₀`, redirected to read `enc a` from the virtual tape. + -- =================================================================================== + -- The redirected run mirrors `M₀`'s run, which `hM₀` says lands in `wordsCfg (enc a) none ws₀'`. + have hA_run_tau : (inputFromTape M₀).runFrom (C1.withState (some M₀.q₀)) τ + = inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input := by + rw [hAstart, runFrom_inCfg, hM₀run] + -- Replace `τ` by the first halting time `τ'`, which gives the phase-2 activity for free. + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time (inputFromTape M₀) (C1.withState (some M₀.q₀)) τ + (by rw [hA_run_tau]; rfl) + have h_A : (inputFromTape M₀).runFrom (C1.withState (some M₀.q₀)) τ' + = inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input := + (runFrom_eq_of_halt (inputFromTape M₀) _ hτ'le hτ'halt).symm.trans hA_run_tau + -- Phase-2 space: the base machine's space, plus one frontier walk over the virtual input. + have hA_sp : (inputFromTape M₀).spaceUsed (C1.withState (some M₀.q₀)) τ' + ≤ c_f * (s a + w.length + 1) + K₀ + 2 * ((enc a).length + 2) := by + rw [hAstart] + refine le_trans (spaceUsed_inputFromTape M₀ true + (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) input τ') ?_ + have hmono : M₀.spaceUsed (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) τ' + ≤ M₀.spaceUsed (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) τ := + spaceUsed_mono M₀ _ hτ'le + omega + -- =================================================================================== + -- Phase 3: clear the boundary mark from the flag tape's cell `-1`. + -- =================================================================================== + obtain ⟨uB, huB, hBact, hBeq, hBframe⟩ := + hClear input + ((inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input).withState + (some setClear.q₀)) + rfl (by simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_inputPos]) + have hB_sp : setClear.spaceUsed + ((inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input).withState + (some setClear.q₀)) uB + ≤ K₀ + 4 := by + refine le_trans (spaceUsed_le_of_one_moving _ uB (⟨K₀ + 1, by omega⟩) (-1) 0 + (fun m hm => ⟨(hBframe m hm).2.2.2.1, (hBframe m hm).2.2.2.2⟩) + (fun m hm j hj => ((hBframe m hm).2.2.1 j hj).2)) ?_ + have : ((0 : ℤ) + 1 - (-1)).toNat = 2 := by omega + omega + -- =================================================================================== + -- Assemble the three phases (a nested sequential composition) and read off the results. + -- =================================================================================== + obtain ⟨inner_run, inner_act, inner_sp⟩ := + seq_spec (tm₁ := inputFromTape M₀) (tm₂ := setClear) + (c := C1.withState (some ((inputFromTape M₀).seq setClear).q₀)) + rfl h_A rfl hτ'act hA_sp hBeq rfl hBact hB_sp + obtain ⟨outer_run, outer_act, outer_sp⟩ := + seq_spec (tm₁ := setMark) (tm₂ := (inputFromTape M₀).seq setClear) (c := start) + (by rw [hstart]; rfl) hC1.symm (by rw [h1eq]) h1act h1sp inner_run rfl inner_act inner_sp + refine ⟨u₁ + (τ' + uB), ?_, Function.update ws (o₀.castAdd 2) w, ?_, rfl, ?_⟩ + · -- Time: `u₁ + τ' + uB ≤ 4 + c_f·(t a + 1) + 4`, absorbed by the generous constant. + have e : (c_f + 2 * K₀ + 12) * (t a + 1) + = c_f * (t a + 1) + (2 * K₀ + 12) * (t a + 1) := by + rw [show c_f + 2 * K₀ + 12 = c_f + (2 * K₀ + 12) from by omega, Nat.add_mul] + have h8 : 8 * 1 ≤ (2 * K₀ + 12) * (t a + 1) := Nat.mul_le_mul (by omega) (by omega) + omega + · -- The composed run halts in the normal-form configuration, with `w` on the output tape. + rw [outer_run] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · have hjf : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + have hji : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + funext z + simp only [Cfg.withState_workTapes, Function.update_of_ne hjf, inCfg_workTapes_castAdd, + wordsCfg_workTapes, hws₀'] + by_cases hjo : j = o₀ + · subst hjo + simp only [Function.update_self] + · have hjo2 : (j.castAdd 2 : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + fun hh => hjo (Fin.ext (by simpa using congrArg Fin.val hh)) + simp only [Function.update_of_ne hjo, Function.update_of_ne hjo2, hblank _ hji] + · have hio : (⟨K₀, by omega⟩ : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + have hif : (⟨K₀, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + simp only [Cfg.withState_workTapes, Function.update_of_ne hif, inCfg_workTapes_vip, + wordsCfg_workTapes, Function.update_of_ne hio, hi] + · have hfo : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + have hfi : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + rcases eq_or_ne z (-1 : ℤ) with hz | hz + · subst hz + simp [Cfg.withState_workTapes, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hfo, hblank _ hfi, tapeOfList_nil] + · simp [Cfg.withState_workTapes, inCfg_workTapes_flag, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hz, Function.update_of_ne hfo, + hblank _ hfi, tapeOfList_nil] + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_castAdd, wordsCfg_workTapePos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_vip, wordsCfg_workTapePos, + wordsCfg_inputPos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_workTapePos, + wordsCfg_inputPos] + · -- Space: the two flag writes plus the redirected run fit the generous budget. + refine le_trans outer_sp ?_ + have eL : (c_f + 2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) + = c_f * (s a + (enc a).length + w.length + 1) + + (2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) := by + rw [show c_f + 2 * K₀ + 12 = c_f + (2 * K₀ + 12) from by omega, Nat.add_mul] + have ecf : c_f * (s a + w.length + 1) + ≤ c_f * (s a + (enc a).length + w.length + 1) := Nat.mul_le_mul (le_refl _) (by omega) + have ebig : (2 * K₀ + 12) * ((enc a).length + 1) + ≤ (2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have eexp : (2 * K₀ + 12) * ((enc a).length + 1) + = (2 * K₀ + 12) * (enc a).length + (2 * K₀ + 12) := by + rw [Nat.mul_add, Nat.mul_one] + have elen : 2 * (enc a).length ≤ (2 * K₀ + 12) * (enc a).length := + Nat.mul_le_mul (by omega) (le_refl _) + omega + end Turing.MultiTapeTM From 81110259d15546cdeed9dd4d62d3ca6618823963 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:08:25 +0000 Subject: [PATCH 34/93] feat(MultiTapeTM): from a tape transformer back to a computable function MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `computableInTimeAndSpace_of_transformsTapes`: the exit from the word-transformer interface. A machine that reads the input from the real input tape and halts with the encoded result on work tape `o` computes that function once the result is copied from tape `o` to the real output tape — `tm.seq (emitTape o)`. The result tape's contents are emitted by the `emitTape` scan; the space stays linear via the one-moving-head bound on the emit phase. With `ofComputableInput`, `ofComputable` and this, the bridge between machines and functions is complete in both directions. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Adapters.lean | 78 +++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index e4c5e06b0..89a674683 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -387,4 +387,82 @@ public theorem exists_transformsTapes_ofComputable Nat.mul_le_mul (by omega) (le_refl _) omega +/-- **From a tape transformer back to a computable function.** A machine that, reading the input +from the real input tape with every work tape blank, halts with the encoded result on work tape +`o`, computes that function once the result is copied from tape `o` to the real output tape. -/ +public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Type} [Finite State] + (o : Fin K) {tm : MultiTapeTM K Bool State} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {gg : α → β} {t s : α → ℕ} + (hT : ∀ a, TransformsTapes tm (fun input ws => input = encIn a ∧ ∀ l, ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (gg a))) (t a) (s a)) : + ∃ c, ComputableInTimeAndSpace gg encIn encOut + (fun a => t a + (encOut (gg a)).length + 2) + (fun a => c * (s a + (encOut (gg a)).length + 1)) := by + obtain ⟨SE, hSE, tmE, hE⟩ := exists_emitTape (Symbol := Bool) o + have := hSE + refine ⟨K + 1, K, State ⊕ SE, inferInstance, tm.seq tmE, fun a => ?_⟩ + -- run the transformer, then emit tape `o` + set start := (tm.seq tmE).initCfg (encIn a) with hstart + have hstart_words : start = wordsCfg (encIn a) (some (tm.seq tmE).q₀) (fun _ => []) [] := by + rw [hstart, initCfg_eq_wordsCfg] + -- phase 1: the transformer halts with the result on tape `o` + obtain ⟨τ, hτ, ws', hrun1, hws', hsp1⟩ := + hT a (encIn a) (fun _ => []) [] ⟨rfl, fun _ => rfl⟩ + have hc1eq : tm.runFrom (start.withState (some tm.q₀)) τ = + wordsCfg (encIn a) none ws' [] := by + rw [hstart_words]; exact hrun1 + -- first halting time of phase 1, for activity + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tm (start.withState (some tm.q₀)) τ (by rw [hc1eq]; rfl) + have hc1eq' : tm.runFrom (start.withState (some tm.q₀)) τ' = wordsCfg (encIn a) none ws' [] := + (runFrom_eq_of_halt tm _ hτ'le hτ'halt).symm.trans hc1eq + set c₁ := wordsCfg (encIn a) (none : Option State) ws' [] with hc1def + -- tape `o` holds the encoded result, head at 0 + have ho_tape : c₁.workTapes o = tapeOfList (encOut (gg a)) := by + rw [hc1def] + change tapeOfList (ws' o) = tapeOfList (encOut (gg a)) + rw [hws', Function.update_self] + have ho_pos : c₁.workTapePos o = 0 := by rw [hc1def, wordsCfg_workTapePos] + -- phase 2: emit tape `o` to the output + obtain ⟨u₂, hu₂, h₂act, h₂run, h₂frame⟩ := + hE (encIn a) (c₁.withState (some tmE.q₀)) (encOut (gg a)) rfl ho_tape ho_pos + -- the two phase-space bounds + have hstartws : start.withState (some tm.q₀) = + wordsCfg (encIn a) (some tm.q₀) (fun _ => []) [] := by + rw [hstart_words]; rfl + have hsp1' : tm.spaceUsed (start.withState (some tm.q₀)) τ' ≤ s a := by + rw [hstartws] + exact le_trans (spaceUsed_mono tm _ hτ'le) hsp1 + have hsp2' : tmE.spaceUsed (c₁.withState (some tmE.q₀)) u₂ ≤ + (encOut (gg a)).length + 1 + K := by + refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmE.q₀)) u₂ o + 0 ((encOut (gg a)).length : ℤ) (fun m hm => ⟨(h₂frame m hm).2.2.2.1, + (h₂frame m hm).2.2.2.2⟩) (fun m hm j hj => (h₂frame m hm).2.2.1 j hj)) ?_ + have : ((encOut (gg a)).length + 1 - (0 : ℤ)).toNat = (encOut (gg a)).length + 1 := by omega + omega + -- assemble + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tm) (tm₂ := tmE) (c := start) (by rw [hstart_words]; rfl) + hc1eq' (by rw [hc1def]; rfl) hτ'act hsp1' h₂run rfl h₂act hsp2' + refine ⟨τ' + u₂, ?_, (tm.seq tmE).spaceUsed start (τ' + u₂), ?_, ?_, ?_, rfl⟩ + · -- time bound + change τ' + u₂ ≤ t a + (encOut (gg a)).length + 2 + have : u₂ ≤ (encOut (gg a)).length + 2 := hu₂ + omega + · -- space bound: `s a + (|encOut|+1+K) ≤ (K+1)·(s a + |encOut| + 1)` + change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K + 1) * (s a + (encOut (gg a)).length + 1) + refine le_trans hseq_sp ?_ + set S := s a + (encOut (gg a)).length + 1 with hSdef + have hexp : (K + 1) * S = S + K * S := by rw [Nat.add_mul, Nat.one_mul, Nat.add_comm] + have hKS : K ≤ K * S := Nat.le_mul_of_pos_right K (by omega) + have : s a + ((encOut (gg a)).length + 1 + K) = S + K := by omega + omega + · -- the run halts + rw [hseq_run]; rfl + · -- output is the encoded result + rw [hseq_run] + simp only [Cfg.withState_output] + change (c₁.withState (some tmE.q₀)).output ++ encOut (gg a) = encOut (gg a) + rw [Cfg.withState_output, hc1def, wordsCfg_output, List.nil_append] + end Turing.MultiTapeTM From d31b5d67db4f12fbe21175e0e0ff4410e9085ba3 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:11:55 +0000 Subject: [PATCH 35/93] feat(MultiTapeTM): reindexing preserves being a tape transformer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `transformsTapes_extendTapes`: if `M` transforms tapes along `P`/`Q`, then `extendTapes M e` does so on the tapes selected by `e`, leaving the tapes outside the range untouched, in the same time and space plus one cell per added tape. The key is `wordsCfg_eq_embed`: a `wordsCfg` over the larger tape set is the smaller `wordsCfg` embedded, with the leftover tapes carrying their own words. This is what lets two different-arity transformers be placed on a common tape layout — the last piece before function composition. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Adapters.lean | 68 +++++++++++++++++++ .../MultiTape/Plumbing/ExtendTapes.lean | 12 ++++ 2 files changed, 80 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index 89a674683..d80fc9a44 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -11,6 +11,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTap public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes /-! # From a computable function to a tape transformer @@ -465,4 +466,71 @@ public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Ty change (c₁.withState (some tmE.q₀)).output ++ encOut (gg a) = encOut (gg a) rw [Cfg.withState_output, hc1def, wordsCfg_output, List.nil_append] +/-- A `wordsCfg` over `k'` tapes, viewed as the `k`-tape `wordsCfg` on the tapes selected by `e`, +embedded with the remaining tapes carrying the leftover words. -/ +private lemma wordsCfg_eq_embed {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k') + (input : List Bool) (q : Option State) (ws : Fin k' → List Bool) (out : List Bool) : + wordsCfg input q ws out = + embed e (wordsCfg input q (fun j => ws (e j)) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + change tapeOfList (ws l) z = _ + rcases hpi : partialInv e l with _ | j + · simp [embed, hpi] + · simp only [embed, hpi, wordsCfg_workTapes, partialInv_eq_some e hpi] + · funext l + change (0 : ℤ) = _ + rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] + +/-- **Reindexing preserves being a tape transformer.** If `M` transforms tapes along `P`/`Q`, then +`extendTapes M e` transforms them on the tapes selected by `e`, leaving the tapes outside the range +of `e` untouched, in the same time and space plus one cell per added tape. -/ +public theorem transformsTapes_extendTapes {k k' : ℕ} {State : Type} + (e : Fin k ↪ Fin k') {M : MultiTapeTM k Bool State} + {P : (input : List Bool) → (Fin k → List Bool) → Prop} + {Q : (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} + {t s : ℕ} (h : TransformsTapes M P Q t s) : + TransformsTapes (extendTapes M e) + (fun input ws => P input (fun j => ws (e j)) ∧ ∀ l, (∀ j, e j ≠ l) → ws l = []) + (fun input ws ws' => Q input (fun j => ws (e j)) (fun j => ws' (e j)) ∧ + ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) + t (s + (k' - k)) := by + intro input ws out ⟨hP, hextra⟩ + -- the start config, viewed through the embedding + have hstart : wordsCfg input (some (extendTapes M e).q₀) ws out = + embed e (wordsCfg input (some M.q₀) (fun j => ws (e j)) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := + wordsCfg_eq_embed e input (some M.q₀) ws out + -- run the inner machine + obtain ⟨τ, hτ, ws', hrun, hQ, hsp⟩ := + h input (fun j => ws (e j)) out hP + refine ⟨τ, hτ, fun l => match partialInv e l with | some j => ws' j | none => ws l, ?_, ?_, ?_⟩ + · -- the run: the embedded halting config is a `wordsCfg` + rw [hstart, runFrom_embed, hrun] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapes l z = + (wordsCfg input (none : Option State) + (fun l => match partialInv e l with | some j => ws' j | none => ws l) out).workTapes l z + rcases hpi : partialInv e l with _ | j + · simp [embed, hpi] + · simp [embed, hpi, wordsCfg_workTapes] + · funext l + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapePos l = (0 : ℤ) + rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] + · -- the postcondition + refine ⟨?_, ?_⟩ + · have : (fun j => (fun l => match partialInv e l with | some j => ws' j | none => ws l) (e j)) + = ws' := by + funext j; simp only [partialInv_embed] + rw [this]; exact hQ + · intro l hl + simp only [partialInv_eq_none e (fun ⟨j, hj⟩ => hl j hj)] + · -- the space + rw [hstart] + exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) + end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean index 871e8bd09..0a7314508 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean @@ -91,6 +91,18 @@ public lemma partialInv_eq_none (e : Fin k ↪ Fin k') {l : Fin k'} (hl : ¬ ∃ partialInv e l = none := dite_eq_right hl +/-- If the partial inverse is `some j`, then `e j = l`. -/ +public lemma partialInv_eq_some (e : Fin k ↪ Fin k') {l : Fin k'} {j : Fin k} + (h : partialInv e l = some j) : e j = l := by + unfold partialInv at h + by_cases hl : ∃ j, e j = l + · rw [dif_pos hl] at h + have hspec := Fintype.choose_spec (fun j' => e j' = l) + (existsUnique_of_exists_of_unique hl fun _ _ ha hb => e.injective (ha.trans hb.symm)) + rw [Option.some_inj] at h + rw [← h]; exact hspec + · rw [dif_neg hl] at h; exact absurd h (by simp) + @[simp] public lemma embed_inputSymbol (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) : From 9f11d17d975d25d719d388ed23f24896a81ee6de Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:13:48 +0000 Subject: [PATCH 36/93] wip(MultiTapeTM): computableInTimeAndSpace_comp statement (sorry body) Co-Authored-By: Claude Opus 5 (1M context) --- .../Turing/MultiTape/NormalForms/Adapters.lean | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index d80fc9a44..a243015f3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -533,4 +533,18 @@ public theorem transformsTapes_extendTapes {k k' : ℕ} {State : Type} rw [hstart] exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) +/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`: run the +machine for `f` (its result on a work tape), then the machine for `gg` reading that tape, then emit. +The two machines are placed on a shared tape layout with the first's output tape identified with the +second's input tape; the first's blank scratch is reused by the second. -/ +public theorem computableInTimeAndSpace_comp + {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} + {tf sf : α → ℕ} {tg sg : β → ℕ} + (hf : ComputableInTimeAndSpace f encA encB tf sf) + (hg : ComputableInTimeAndSpace gg encB encC tg sg) : + ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC + (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) + (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by + sorry + end Turing.MultiTapeTM From 3cf2b3df9b7de4d83a2a1e5a051f5c02d6c1fe1c Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:57:14 +0000 Subject: [PATCH 37/93] chore(MultiTapeTM): modern dite lemmas in ExtendTapes Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean index 0a7314508..dc157b323 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean @@ -96,12 +96,12 @@ public lemma partialInv_eq_some (e : Fin k ↪ Fin k') {l : Fin k'} {j : Fin k} (h : partialInv e l = some j) : e j = l := by unfold partialInv at h by_cases hl : ∃ j, e j = l - · rw [dif_pos hl] at h + · rw [dite_eq_left hl] at h have hspec := Fintype.choose_spec (fun j' => e j' = l) (existsUnique_of_exists_of_unique hl fun _ _ ha hb => e.injective (ha.trans hb.symm)) rw [Option.some_inj] at h rw [← h]; exact hspec - · rw [dif_neg hl] at h; exact absurd h (by simp) + · rw [dite_eq_right hl] at h; exact absurd h (by simp) @[simp] public lemma embed_inputSymbol (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) From e72e09bf20598192df1cb033bfcc1cd1923069a7 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 22:57:14 +0000 Subject: [PATCH 38/93] feat(MultiTapeTM): complexity of function composition MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `computableInTimeAndSpace_comp`: if `f` and `g` are computable, so is `g ∘ f`. The machine runs `f` (via `ofComputableInput`, result on a work tape), then `g` (via `ofComputable`, reading that tape), then emits. The two machines are placed on a shared tape layout by `extendTapes`, with `f`'s output tape identified with `g`'s input tape and `f`'s blanked scratch reused by `g`; they compose with `transformsTapes_seq`. The composite is not a clean single-tape-update transformer — `g` leaves its input `encB (f a)` on the shared tape — so the emit step is inlined rather than routed through `computableInTimeAndSpace_of_transformsTapes` (that leftover is irrelevant to the halting/output/space a computation checks). The whole machine layer — tidy normal form, tape redirections, reindexing, and the four adapters — now delivers a function-level complexity result with no machine reasoning in sight. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/NormalForms/Adapters.lean | 242 +++++++++++++++++- 1 file changed, 241 insertions(+), 1 deletion(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index a243015f3..8f03b917f 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -545,6 +545,246 @@ public theorem computableInTimeAndSpace_comp ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by - sorry + classical + -- `M_f` reads the real input and leaves `encB (f a)` on its output tape `o_f`. + obtain ⟨c_f, K_f, o_f, S_f, hS_f, M_f, hM_f⟩ := exists_transformsTapes_ofComputableInput hf + -- `M_g` reads `encB x` from its input tape `i_g` and leaves `encC (gg x)` on `o_g`. + obtain ⟨c_g, K_g, i_g, o_g, S_g, hS_g, M_g, hio, hM_g⟩ := exists_transformsTapes_ofComputable hg + have hfin_f := hS_f + have hfin_g := hS_g + -- The length of `gg`'s output is bounded by its running time. + have hlenC : ∀ x, (encC (gg x)).length ≤ tg x := by + intro x + obtain ⟨kk, SS, hfinSS, tmm, hcomp⟩ := hg + obtain ⟨t', ht', s', hs', hhaltm, houtm, hspm⟩ := hcomp x + have hlen : ∀ d, (tmm.runFrom (tmm.initCfg (encB x)) d).output.length ≤ d := by + intro d + induction d with + | zero => rw [runFrom_zero, initCfg_eq_wordsCfg]; simp + | succ d ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + have h1 : (tmm.outputSymbol (tmm.runFrom (tmm.initCfg (encB x)) d)).toList.length ≤ 1 := by + cases tmm.outputSymbol (tmm.runFrom (tmm.initCfg (encB x)) d) <;> simp + omega + have hle := hlen t' + rw [houtm] at hle + omega + -- The shared tape layout on `Fin (K_f + K_g)`: `M_f` occupies the first block, `M_g` the second, + -- with `M_g`'s virtual input tape `i_g` identified with `M_f`'s output tape `o_f`. + let e_f : Fin K_f ↪ Fin (K_f + K_g) := Fin.castAddEmb K_g + have e_g_inj : Function.Injective + (fun j : Fin K_g => + if j = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else j.natAdd K_f) := by + intro j₁ j₂ h + dsimp only at h + split_ifs at h with h1 h2 + · rw [h1, h2] + · exfalso + have hv := congrArg Fin.val h + rw [Fin.val_castAdd, Fin.val_natAdd] at hv + have := o_f.isLt; omega + · exfalso + have hv := congrArg Fin.val h + rw [Fin.val_natAdd, Fin.val_castAdd] at hv + have := o_f.isLt; omega + · have hv := congrArg Fin.val h + rw [Fin.val_natAdd, Fin.val_natAdd] at hv + exact Fin.ext (by omega) + let e_g : Fin K_g ↪ Fin (K_f + K_g) := + ⟨fun j => if j = i_g then (o_f.castAdd K_g) else j.natAdd K_f, e_g_inj⟩ + -- `M_g`'s input tape coincides with `M_f`'s output tape. + have hei : (e_g i_g : Fin (K_f + K_g)) = e_f o_f := by + change (if i_g = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else i_g.natAdd K_f) + = o_f.castAdd K_g + rw [ite_eq_left rfl] + -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output. + have hMc : ∀ a, TransformsTapes ((extendTapes M_f e_f).seq (extendTapes M_g e_g)) + (fun input ws => input = encA a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' (e_g o_g) = encC (gg (f a))) + (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) + (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g))) := by + intro a + refine (transformsTapes_seq (transformsTapes_extendTapes e_f (hM_f a)) + (transformsTapes_extendTapes e_g (hM_g (f a))) ?_).imp ?_ ?_ le_rfl le_rfl + · -- The handoff: after `M_f`, `M_g`'s precondition holds on the shared layout. + rintro input ws ws' ⟨⟨rfl, hwf⟩, hoff⟩ ⟨hQf1, hQf2⟩ + have hwsblank : ∀ l, ws l = [] := by + intro l + by_cases hl : ∃ j, e_f j = l + · obtain ⟨j, rfl⟩ := hl; exact hwf j + · exact hoff l (fun j hj => hl ⟨j, hj⟩) + refine ⟨⟨?_, ?_⟩, ?_⟩ + · -- `M_g`'s input tape carries `encB (f a)`. + change ws' (e_g i_g) = encB (f a) + rw [hei] + have hk := congrFun hQf1 o_f + simpa using hk + · -- Every other of `M_g`'s tapes is blank. + intro l hl + change ws' (e_g l) = [] + have hne : (e_g l : Fin (K_f + K_g)) = l.natAdd K_f := by + change (if l = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else l.natAdd K_f) + = l.natAdd K_f + rw [ite_eq_right hl] + have hout : ∀ j, e_f j ≠ e_g l := by + intro j hj + have h1 : (e_f j).val < K_f := by + change (j.castAdd K_g).val < K_f + rw [Fin.val_castAdd]; exact j.isLt + rw [hj, hne, Fin.val_natAdd] at h1; omega + rw [hQf2 (e_g l) hout, hwsblank] + · -- The tapes outside `M_g`'s layout are blank. + intro l hl + by_cases hlr : ∃ j, e_f j = l + · obtain ⟨j, rfl⟩ := hlr + have hjo : j ≠ o_f := by intro hjeq; subst hjeq; exact hl i_g hei + have hk := congrFun hQf1 j + rw [Function.update_of_ne hjo] at hk + exact hk.trans (hwf j) + · exact (hQf2 l (fun j hj => hlr ⟨j, hj⟩)).trans (hwsblank l) + · -- Precondition: an all-blank input satisfies the lifted `M_f` precondition. + rintro input ws ⟨rfl, hblank⟩ + exact ⟨⟨rfl, fun l => hblank (e_f l)⟩, fun l _ => hblank l⟩ + · -- Postcondition: read the result off `M_g`'s output tape. + rintro input ws ws'' _ ⟨ws', _, hQg⟩ + have hk := congrFun hQg.1 o_g + simpa using hk + -- Append an emit machine to copy the result from `e_g o_g` to the real output tape. + have hbase : ComputableInTimeAndSpace (gg ∘ f) encA encC + (fun a => c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 2) + (fun a => (K_f + K_g + 1) * + (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1)) := by + obtain ⟨SE, hSE, tmE, hE⟩ := exists_emitTape (Symbol := Bool) (e_g o_g) + have := hSE + refine ⟨K_f + K_g, (S_f ⊕ S_g) ⊕ SE, inferInstance, + ((extendTapes M_f e_f).seq (extendTapes M_g e_g)).seq tmE, fun a => ?_⟩ + set tm := (extendTapes M_f e_f).seq (extendTapes M_g e_g) with htm + set start := (tm.seq tmE).initCfg (encA a) with hstart + have hstart_words : start = wordsCfg (encA a) (some (tm.seq tmE).q₀) (fun _ => []) [] := by + rw [hstart, initCfg_eq_wordsCfg] + obtain ⟨τ, hτ, ws', hrun1, hws', hsp1⟩ := + hMc a (encA a) (fun _ => []) [] ⟨rfl, fun _ => rfl⟩ + have hc1eq : tm.runFrom (start.withState (some tm.q₀)) τ = + wordsCfg (encA a) none ws' [] := by + rw [hstart_words]; exact hrun1 + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tm (start.withState (some tm.q₀)) τ (by rw [hc1eq]; rfl) + have hc1eq' : tm.runFrom (start.withState (some tm.q₀)) τ' = wordsCfg (encA a) none ws' [] := + (runFrom_eq_of_halt tm _ hτ'le hτ'halt).symm.trans hc1eq + set c₁ := wordsCfg (encA a) (none : Option (S_f ⊕ S_g)) ws' [] with hc1def + have ho_tape : c₁.workTapes (e_g o_g) = tapeOfList (encC (gg (f a))) := by + rw [hc1def] + change tapeOfList (ws' (e_g o_g)) = tapeOfList (encC (gg (f a))) + rw [hws'] + have ho_pos : c₁.workTapePos (e_g o_g) = 0 := by rw [hc1def, wordsCfg_workTapePos] + obtain ⟨u₂, hu₂, h₂act, h₂run, h₂frame⟩ := + hE (encA a) (c₁.withState (some tmE.q₀)) (encC (gg (f a))) rfl ho_tape ho_pos + have hstartws : start.withState (some tm.q₀) = + wordsCfg (encA a) (some tm.q₀) (fun _ => []) [] := by + rw [hstart_words]; rfl + have hsp1' : tm.spaceUsed (start.withState (some tm.q₀)) τ' ≤ + c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) := by + rw [hstartws] + exact le_trans (spaceUsed_mono tm _ hτ'le) hsp1 + have hsp2' : tmE.spaceUsed (c₁.withState (some tmE.q₀)) u₂ ≤ + (encC (gg (f a))).length + 1 + (K_f + K_g) := by + refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmE.q₀)) u₂ (e_g o_g) + 0 ((encC (gg (f a))).length : ℤ) (fun m hm => ⟨(h₂frame m hm).2.2.2.1, + (h₂frame m hm).2.2.2.2⟩) (fun m hm j hj => (h₂frame m hm).2.2.1 j hj)) ?_ + have : ((encC (gg (f a))).length + 1 - (0 : ℤ)).toNat = (encC (gg (f a))).length + 1 := by + omega + omega + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tm) (tm₂ := tmE) (c := start) (by rw [hstart_words]; rfl) + hc1eq' (by rw [hc1def]; rfl) hτ'act hsp1' h₂run rfl h₂act hsp2' + refine ⟨τ' + u₂, ?_, (tm.seq tmE).spaceUsed start (τ' + u₂), ?_, ?_, ?_, rfl⟩ + · -- Time bound. + change τ' + u₂ ≤ c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 2 + have : u₂ ≤ (encC (gg (f a))).length + 2 := hu₂ + omega + · -- Space bound. + change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K_f + K_g + 1) * + (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1) + refine le_trans hseq_sp ?_ + set S := c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1 with hSdef + have hexp : (K_f + K_g + 1) * S = S + (K_f + K_g) * S := by + rw [Nat.add_mul, Nat.one_mul, Nat.add_comm] + have hKS : (K_f + K_g) ≤ (K_f + K_g) * S := Nat.le_mul_of_pos_right _ (by omega) + have hrw : c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + ((encC (gg (f a))).length + 1 + (K_f + K_g)) + = S + (K_f + K_g) := by + rw [hSdef]; omega + omega + · -- The run halts. + rw [hseq_run]; rfl + · -- The output is the encoded result. + rw [hseq_run] + simp only [Cfg.withState_output] + change (c₁.withState (some tmE.q₀)).output ++ encC (gg (f a)) = encC (gg (f a)) + rw [Cfg.withState_output, hc1def, wordsCfg_output, List.nil_append] + -- Relax the bounds to the stated linear form. + refine ⟨(K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3, + hbase.mono ?_ ?_⟩ + · -- Time. + intro a + have hlc : (encC (gg (f a))).length ≤ tg (f a) := hlenC (f a) + have hcf : c_f + c_g + 3 ≤ + (K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3 := by omega + have e1 : c_f * (tf a + 1) ≤ c_f * (tf a + tg (f a) + (encB (f a)).length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have e2 : c_g * (tg (f a) + 1) ≤ c_g * (tf a + tg (f a) + (encB (f a)).length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have hexp : (c_f + c_g + 3) * (tf a + tg (f a) + (encB (f a)).length + 1) = + c_f * (tf a + tg (f a) + (encB (f a)).length + 1) + + c_g * (tf a + tg (f a) + (encB (f a)).length + 1) + + 3 * (tf a + tg (f a) + (encB (f a)).length + 1) := by + rw [Nat.add_mul, Nat.add_mul] + have e3 : (c_f + c_g + 3) * (tf a + tg (f a) + (encB (f a)).length + 1) ≤ + ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3) * + (tf a + tg (f a) + (encB (f a)).length + 1) := Nat.mul_le_mul hcf (le_refl _) + have e4 : (encC (gg (f a))).length + 2 ≤ 3 * (tf a + tg (f a) + (encB (f a)).length + 1) := by + omega + omega + · -- Space. + intro a + set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS + have hsub1 : K_f + K_g - K_f = K_g := by omega + have hsub2 : K_f + K_g - K_g = K_f := by omega + have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := + Nat.mul_le_mul (le_refl _) (by omega) + have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := + Nat.mul_le_mul (le_refl _) (by omega) + have q1 : 2 * K_f ≤ 2 * K_f * PS := Nat.le_mul_of_pos_right _ (by omega) + have q2 : 2 * K_g ≤ 2 * K_g * PS := Nat.le_mul_of_pos_right _ (by omega) + have hexpS : (c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS = + c_f * PS + c_g * PS + 2 * K_f * PS + 2 * K_g * PS + 2 * PS := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul] + have hSbound : c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1 ≤ + (c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS := by + rw [hsub1, hsub2, hexpS] + omega + calc (K_f + K_g + 1) * + (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + + (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1) + ≤ (K_f + K_g + 1) * ((c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS) := + Nat.mul_le_mul (le_refl _) hSbound + _ = ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2)) * PS := + (Nat.mul_assoc _ _ _).symm + _ ≤ ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3) * PS := + Nat.mul_le_mul (by omega) (le_refl _) end Turing.MultiTapeTM From 1df08ee9c5ca406247a01cf751168bd42fdef0d6 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 23:12:13 +0000 Subject: [PATCH 39/93] feat(MultiTapeTM): branching on a tape symbol Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../Turing/MultiTape/Plumbing/Branch.lean | 248 ++++++++++++++++++ 2 files changed, 249 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean diff --git a/Cslib.lean b/Cslib.lean index a3774ed7e..dc6f068a8 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -62,6 +62,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean new file mode 100644 index 000000000..a4d8221b5 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Mathlib.Data.Fintype.Option +public import Mathlib.Basic.Finite.Sum + +/-! +# Branching on a work-tape symbol + +`branch i x tm₁ tm₂` first reads the symbol under the head of work tape `i` and then, depending on +whether that symbol equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its initial +state on the tapes as they were. This is a control combinator analogous to sequential composition +(`Plumbing/Sequential.lean`): the state space adds a fresh dispatch state on top of `State₁ ⊕ +State₂`, the dispatch is one step that writes nothing and moves no head, and afterwards the machine +mirrors the chosen sub-machine through a left/right embedding just as `seq` mirrors its second +machine. + +Because at a starting `wordsCfg` the head of every work tape sits at the start of its word, tape +`i`'s symbol there is exactly `(ws i).head?`, so the dispatch reads precisely the predicate the +specification branches on. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_branch`: from two transformations sharing a + postcondition, a single machine that runs one or the other according to the symbol under tape + `i`, with the time bound `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} + +namespace Branch + +/-- The tape holding `xs` reads `xs.head?` at its start cell. -/ +private lemma tapeOfList_zero (xs : List Bool) : tapeOfList xs 0 = xs.head? := by + have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl + rw [h, tapeOfList_ofNat] + cases xs <;> rfl + +/-- The branching machine. State `none` is a fresh dispatch state: it reads the symbol under tape +`i`'s head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial state +(if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, its +states carried by `Sum.inl`/`Sum.inr`. -/ +private def branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) + (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where + q₀ := none + tr q inp work := + match q with + | none => + { inputTape := 0 + workTapes := fun _ => (none, 0) + output := none + state := if work i = some x then some (some (Sum.inl tm₁.q₀)) + else some (some (Sum.inr tm₂.q₀)) } + | some (Sum.inl q₁) => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))) } + | some (Sum.inr q₂) => + let a := tm₂.tr q₂ inp work + { a with state := a.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))) } + +variable {i : Fin k} {x : Bool} {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} + +/-- A configuration of `tm₁`, embedded into the branching machine: a halted state stays halted, a +live state is carried by `Sum.inl`. -/ +private def leftCfg (cfg : Cfg k Bool S₁ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + ⟨cfg.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))), cfg.inputPos, cfg.workTapes, + cfg.workTapePos, cfg.output⟩ + +/-- A configuration of `tm₂`, embedded into the branching machine. -/ +private def rightCfg (cfg : Cfg k Bool S₂ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + ⟨cfg.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))), cfg.inputPos, cfg.workTapes, + cfg.workTapePos, cfg.output⟩ + +@[simp] +private lemma workTapePos_leftCfg (cfg : Cfg k Bool S₁ input) : + (leftCfg (S₂ := S₂) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma workTapePos_rightCfg (cfg : Cfg k Bool S₂ input) : + (rightCfg (S₁ := S₁) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma leftCfg_wordsCfg (q : Option S₁) (ws : Fin k → List Bool) (out : List Bool) : + leftCfg (S₂ := S₂) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +@[simp] +private lemma rightCfg_wordsCfg (q : Option S₂) (ws : Fin k → List Bool) (out : List Bool) : + rightCfg (S₁ := S₁) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. -/ +private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : + (branch i x tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [leftCfg, hq]), step_of_halt hq] + | some q => + have h1 : (leftCfg (S₂ := S₂) cfg).state = some (some (Sum.inl q)) := by simp [leftCfg, hq] + simp only [step, h1, hq] + rfl + +/-- On `tm₂`'s configurations, the branching machine mirrors `tm₂` step for step. -/ +private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : + (branch i x tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [rightCfg, hq]), step_of_halt hq] + | some q => + have h1 : (rightCfg (S₁ := S₁) cfg).state = some (some (Sum.inr q)) := by simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +private lemma runFrom_leftCfg (cfg : Cfg k Bool S₁ input) (n : ℕ) : + (branch i x tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step leftCfg (fun c => step_leftCfg c) cfg n + +private lemma runFrom_rightCfg (cfg : Cfg k Bool S₂ input) (n : ℕ) : + (branch i x tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-- The dispatch step when the symbol under tape `i` is `some x`: it lands on `tm₁`'s initial +configuration, embedded on the left. -/ +private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) + (h : (ws i).head? = some x) : + (branch i x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, wordsCfg, Action.apply, + SignType.cast] + +/-- The dispatch step when the symbol under tape `i` is not `some x`: it lands on `tm₂`'s initial +configuration, embedded on the right. -/ +private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ (ws i).head? = some x) : + (branch i x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, wordsCfg, Action.apply, + SignType.cast] + +end Branch + +open Branch in +/-- **Branching on a tape symbol.** Given two transformations that share a postcondition `Q`, a +single machine reads the symbol under the head of work tape `i`: if it is `some x` it performs the +first transformation, otherwise the second. The dispatch costs one step and, moving no head, at +most `k` cells, so the time bound is `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. -/ +public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) (x : Bool) + {State₁ State₂ : Type} [Finite State₁] [Finite State₂] + {tm₁ : MultiTapeTM k Bool State₁} {tm₂ : MultiTapeTM k Bool State₂} + {P₁ P₂ : J → (input : List Bool) → (Fin k → List Bool) → Prop} + {Q : J → (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} + {t₁ s₁ t₂ s₂ : J → ℕ} + (h₁ : ∀ j, TransformsTapes tm₁ (P₁ j) (Q j) (t₁ j) (s₁ j)) + (h₂ : ∀ j, TransformsTapes tm₂ (P₂ j) (Q j) (t₂ j) (s₂ j)) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ j : J, + TransformsTapes tm + (fun input ws => if (ws i).head? = some x then P₁ j input ws else P₂ j input ws) + (Q j) (max (t₁ j) (t₂ j) + 1) (max (s₁ j) (s₂ j) + k) := by + refine ⟨Option (State₁ ⊕ State₂), inferInstance, branch i x tm₁ tm₂, fun j input ws out hP => ?_⟩ + -- the machine's initial state is the dispatch state `none` + rw [show (branch i x tm₁ tm₂).q₀ = none from rfl] + by_cases h : (ws i).head? = some x + · -- read `some x`: run `tm₁` + simp only [h] at hP + obtain ⟨τ₁, hτ₁, ws', hrun₁, hQ₁, hsp₁⟩ := h₁ j input ws out hP + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + leftCfg (S₂ := State₂) (wordsCfg input (some tm₁.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_left ws out h] + refine ⟨τ₁ + 1, by have := Nat.le_max_left (t₁ j) (t₂ j); omega, ws', ?_, hQ₁, ?_⟩ + · rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg, hrun₁] + simp + · -- space: the dispatch adds at most `k` cells, `tm₁`'s run at most `s₁ j` + have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 + fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₁ ≤ s₁ j := by + rw [hstep1] + refine le_trans (le_of_eq + (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₁) + (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) + τ₁ fun m _ => ?_)) hsp₁ + rw [runFrom_leftCfg, workTapePos_leftCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ₁ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ₁) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₁ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ₁ + _ ≤ k + s₁ j := Nat.add_le_add hsp1 hsp2 + _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_left (s₁ j) (s₂ j); omega + · -- read something else: run `tm₂` + simp only [h] at hP + obtain ⟨τ₂, hτ₂, ws', hrun₂, hQ₂, hsp₂⟩ := h₂ j input ws out hP + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + rightCfg (S₁ := State₁) (wordsCfg input (some tm₂.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_right ws out h] + refine ⟨τ₂ + 1, by have := Nat.le_max_right (t₁ j) (t₂ j); omega, ws', ?_, hQ₂, ?_⟩ + · rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg, hrun₂] + simp + · have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 + fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₂ ≤ s₂ j := by + rw [hstep1] + refine le_trans (le_of_eq + (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₂) + (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) + τ₂ fun m _ => ?_)) hsp₂ + rw [runFrom_rightCfg, workTapePos_rightCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ₂ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ₂) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₂ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ₂ + _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 + _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega + +end Turing.MultiTapeTM From a6d970fdef888a33ba37bfc78a964b248bf82a61 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 9 Sep 2026 23:38:49 +0000 Subject: [PATCH 40/93] feat(MultiTapeTM): repeating a machine until a tape signals stop Co-Authored-By: Claude Fable 5 --- Cslib.lean | 1 + .../Turing/MultiTape/Plumbing/Repeat.lean | 323 ++++++++++++++++++ 2 files changed, 324 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean diff --git a/Cslib.lean b/Cslib.lean index dc6f068a8..dce59c966 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -69,6 +69,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.NeverOutputs public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean new file mode 100644 index 000000000..71ba307b8 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Mathlib.Basic.Finite.Sum + +/-! +# Repeating a machine until a tape signals stop + +`repeatTM i x tm` runs `tm` over and over. After each run of `tm`, it inspects the symbol under the +head of work tape `i`: if it is `some x` the loop halts, otherwise `tm` is started again on the +tapes as it left them. This is the loop-back control combinator: the state space is `State₀ ⊕ +Unit`, where `Sum.inr ()` is a fresh *check* state; `tm`'s halting transition is redirected to it, +so the inspection costs one extra step per round and the handoff back to `tm` costs no step. + +The specification `exists_transformsTapes_repeat` is stated for a family indexed by `J`, with a +round predicate `P j n` describing the tapes after `n` rounds and a stopping predicate `R j`. As +long as round `n < N j` leaves the flag unequal to `x`, the loop keeps going; round `N j` leaves it +equal to `x`, so the loop halts. Because every round begins from a `wordsCfg` (all heads at the +start of their words), the configurations thread cleanly round to round. + +The time bound is `(N j + 1) * (t j + 1)`: there are `N j + 1` rounds, each of at most `t j` steps +of `tm` plus one inspection step. The space bound `2 * k * s j + k` is **independent of the number +of rounds**: every round starts with the heads at `0` and uses at most `s j` cells, so on each tape +that round's visited cells form an interval around `0` contained in `[-s j, s j]`; the whole run's +visited set is the union of the rounds' sets, still within `[-s j, s j]`, hence at most `2 * s j + +1` cells per tape. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_repeat`: from a family of per-round transformations + and a stopping transformation, a single machine that loops until tape `i` shows `x`, with time + bound `(N j + 1) * (t j + 1)` and space bound `2 * k * s j + k`. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {State₀ : Type*} {input : List Bool} + +namespace Repeat + +/-- The tape holding `xs` reads `xs.head?` at its start cell. -/ +private lemma tapeOfList_zero (xs : List Bool) : tapeOfList xs 0 = xs.head? := by + have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl + rw [h, tapeOfList_ofNat] + cases xs <;> rfl + +/-- The looping machine. On a live state `Sum.inl q` it runs `tm`, but redirects `tm`'s halting +transition to the fresh check state `Sum.inr ()`. On the check state it reads the symbol under +tape `i`'s head: if it is `some x` the machine halts, otherwise it restarts `tm` from its initial +state, writing nothing and moving no head. -/ +private def repeatTM (i : Fin k) (x : Bool) (tm : MultiTapeTM k Bool State₀) : + MultiTapeTM k Bool (State₀ ⊕ Unit) where + q₀ := .inl tm.q₀ + tr q inp work := + match q with + | .inl q => + let a := tm.tr q inp work + { a with state := some (a.state.elim (.inr ()) .inl) } + | .inr _ => + if work i = some x then + { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + else + { inputTape := 0, workTapes := fun _ => (none, 0), output := none, + state := some (.inl tm.q₀) } + +variable {i : Fin k} {x : Bool} {tm : MultiTapeTM k Bool State₀} + +/-- A configuration of `tm`, embedded into the looping machine: a halted state is sent to the +check state `Sum.inr ()`, a live state is carried by `Sum.inl`. Under this map the machine mirrors +`tm` step for step while `tm` is live, and lands on the check state exactly when `tm` halts. -/ +private def leftCfg (cfg : Cfg k Bool State₀ input) : Cfg k Bool (State₀ ⊕ Unit) input := + ⟨some (cfg.state.elim (.inr ()) .inl), cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + +@[simp] +private lemma workTapePos_leftCfg (cfg : Cfg k Bool State₀ input) : + (leftCfg cfg).workTapePos = cfg.workTapePos := rfl + +private lemma leftCfg_wordsCfg (q : Option State₀) (ws : Fin k → List Bool) (out : List Bool) : + leftCfg (input := input) (wordsCfg input q ws out) = + wordsCfg input (some (q.elim (.inr ()) .inl)) ws out := rfl + +/-- On `tm`'s live configurations, the looping machine mirrors `tm` step for step. -/ +private lemma step_leftCfg (cfg : Cfg k Bool State₀ input) (h : cfg.state ≠ none) : + (repeatTM i x tm).step (leftCfg cfg) = leftCfg (tm.step cfg) := by + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h + have h1 : (leftCfg cfg).state = some (Sum.inl q : State₀ ⊕ Unit) := by simp [leftCfg, hq] + simp only [step, h1, hq] + rfl + +/-- While `tm` is live, the looping machine mirrors it. -/ +private lemma runFrom_leftCfg (cfg : Cfg k Bool State₀ input) (n : ℕ) + (h : ∀ m < n, (tm.runFrom cfg m).state ≠ none) : + (repeatTM i x tm).runFrom (leftCfg cfg) n = leftCfg (tm.runFrom cfg n) := by + induction n with + | zero => rfl + | succ n ih => + rw [runFrom_succ_eq_step', runFrom_succ_eq_step', ih fun m hm => h m (by omega), + step_leftCfg _ (h n (by omega))] + +/-- The run of the looping machine on a starting `wordsCfg`, while `tm` is live. -/ +private lemma runFrom_left_wordsCfg (w : Fin k → List Bool) (out : List Bool) (n : ℕ) + (hact : ∀ m < n, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) n = + leftCfg (tm.runFrom (wordsCfg input (some tm.q₀) w out) n) := by + have h : wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inl tm.q₀)) w out = + leftCfg (wordsCfg input (some tm.q₀) w out) := rfl + rw [h, runFrom_leftCfg _ n hact] + +/-- The check step, when tape `i` shows `x`: the machine halts, leaving the words untouched. -/ +private lemma step_check_halt (ws : Fin k → List Bool) (out : List Bool) + (h : (ws i).head? = some x) : + (repeatTM i x tm).step (wordsCfg input (some (Sum.inr ())) ws out) = + wordsCfg input none ws out := by + have hstate : (wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inr ())) ws out).state = + some (Sum.inr ()) := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [repeatTM, Cfg.workTapeSymbols, tapeOfList_zero, h, wordsCfg, Action.apply, SignType.cast] + +/-- The check step, when tape `i` does not show `x`: the machine restarts `tm` from its initial +state, leaving the words untouched. -/ +private lemma step_check_restart (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ (ws i).head? = some x) : + (repeatTM i x tm).step (wordsCfg input (some (Sum.inr ())) ws out) = + wordsCfg input (some (Sum.inl tm.q₀)) ws out := by + have hstate : (wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inr ())) ws out).state = + some (Sum.inr ()) := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [repeatTM, Cfg.workTapeSymbols, tapeOfList_zero, h, wordsCfg, Action.apply, SignType.cast] + +/-- On the check state, the step moves no work-tape head. -/ +private lemma check_step_workTapePos (c : Cfg k Bool (State₀ ⊕ Unit) input) + (hstate : c.state = some (Sum.inr ())) (l : Fin k) : + ((repeatTM i x tm).step c).workTapePos l = c.workTapePos l := by + have h2 : (((repeatTM i x tm).tr (Sum.inr ()) c.inputSymbol c.workTapeSymbols).workTapes l).2 + = 0 := by + simp only [repeatTM] + split <;> rfl + rw [step_workTapePos_of_state hstate l, h2] + simp + +/-- One full round takes the loop from a `wordsCfg` on `tm`'s initial state to a `wordsCfg` on +`tm`'s initial state, when tape `i` does not show `x`. -/ +private lemma runFrom_round_restart (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hrestart : ¬ (w' i).head? = some x) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) (u + 1) = + wordsCfg input (some (Sum.inl tm.q₀)) w' out := by + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + exact step_check_restart w' out hrestart + +/-- The last round: when tape `i` shows `x`, the loop halts on a `wordsCfg`. -/ +private lemma runFrom_round_halt (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hstop : (w' i).head? = some x) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) (u + 1) = + wordsCfg input none w' out := by + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + exact step_check_halt w' out hstop + +/-- A `tm`-run started at a `wordsCfg` (head at `0`) using at most `s0` cells stays, on each tape, +within `[-s0, s0]`. -/ +private lemma visited_subset_Icc (cfg : Cfg k Bool State₀ input) (u : ℕ) (l : Fin k) (s0 : ℕ) + (h0 : cfg.workTapePos l = 0) (hsp : tm.spaceUsed cfg u ≤ s0) : + tm.visitedByTapeHead cfg u l ⊆ Finset.Icc (-(s0 : ℤ)) (s0 : ℤ) := by + obtain ⟨lo, hi, hlo, hhi, hvisited⟩ := tm.exists_visitedByTapeHead_eq_Icc cfg u l + rw [h0] at hlo hhi + have hcard : (tm.visitedByTapeHead cfg u l).card ≤ s0 := + le_trans (tm.spaceUsedByTape_le_spaceUsed cfg u l) hsp + rw [hvisited, Int.card_Icc] at hcard + intro z hz + rw [hvisited] at hz + rw [Finset.mem_Icc] at hz ⊢ + omega + +/-- **The per-round space confinement.** Every configuration reached within one round keeps every +work-tape head inside `[-s0, s0]`: during `tm`'s phase because that phase starts with the head at +`0` and uses at most `s0` cells, and at the check step because it moves no head. -/ +private lemma round_Icc (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) (s0 : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hsp : tm.spaceUsed (wordsCfg input (some tm.q₀) w out) u ≤ s0) : + ∀ m ≤ u + 1, ∀ l : Fin k, + ((repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) m).workTapePos l + ∈ Finset.Icc (-(s0 : ℤ)) (s0 : ℤ) := by + intro m hm l + rcases Nat.lt_or_ge m (u + 1) with hlt | hge + · -- during `tm`'s phase: the head is in `tm`'s visited set, which lies in `[-s0, s0]` + have hmu : m ≤ u := by omega + rw [runFrom_left_wordsCfg w out m (fun r hr => hact r (by omega)), workTapePos_leftCfg] + apply visited_subset_Icc (tm := tm) _ u l s0 rfl hsp + exact mem_visitedByTapeHead.mpr ⟨m, by omega, rfl⟩ + · -- the check step: the head does not move, and it sits at `0` + have hmeq : m = u + 1 := by omega + subst hmeq + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + rw [check_step_workTapePos _ (by rw [leftCfg_wordsCfg]; rfl) l] + rw [leftCfg_wordsCfg] + simp only [Finset.mem_Icc, wordsCfg_workTapePos] + omega + +end Repeat + +open Repeat in +/-- **Repeating a machine until a tape signals stop.** Given a family of per-round +transformations `hround` (each of which advances the round predicate `P j n` to `P j (n+1)` while +leaving tape `i`'s head symbol unequal to `x`) and a stopping transformation `hstop` (which +establishes `R j` while leaving tape `i`'s head symbol equal to `x`), a single machine loops `tm`, +inspecting tape `i` after each round, until that head symbol equals `x`. It performs `N j + 1` +rounds, so the time bound is `(N j + 1) * (t j + 1)`; because every round starts with the heads at +the start of their words and uses at most `s j` cells, the space bound `2 * k * s j + k` is +independent of the number of rounds. -/ +public theorem exists_transformsTapes_repeat {J : Type*} {k : ℕ} (i : Fin k) (x : Bool) + {State₀ : Type} [Finite State₀] {tm : MultiTapeTM k Bool State₀} + {P : J → ℕ → (input : List Bool) → (Fin k → List Bool) → Prop} + {R : J → (input : List Bool) → (Fin k → List Bool) → Prop} + {N : J → ℕ} {t s : J → ℕ} + (hround : ∀ (j : J) (n : ℕ), n < N j → TransformsTapes tm (P j n) + (fun input _ ws' => P j (n + 1) input ws' ∧ (ws' i).head? ≠ some x) (t j) (s j)) + (hstop : ∀ j : J, TransformsTapes tm (P j (N j)) + (fun input _ ws' => R j input ws' ∧ (ws' i).head? = some x) (t j) (s j)) : + ∃ (State : Type) (_ : Finite State) (tm' : MultiTapeTM k Bool State), ∀ j : J, + TransformsTapes tm' (P j 0) (fun input _ ws' => R j input ws') + ((N j + 1) * (t j + 1)) (2 * k * s j + k) := by + refine ⟨State₀ ⊕ Unit, inferInstance, repeatTM i x tm, fun j input ws out hP0 => ?_⟩ + rw [show (repeatTM i x tm).q₀ = Sum.inl tm.q₀ from rfl] + set start := wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inl tm.q₀)) ws out with hstart + -- After `n ≤ N j` rounds, the loop is back on `tm`'s initial state with words satisfying `P j n`, + -- has taken at most `n * (t j + 1)` steps, and has kept every head inside `[-s j, s j]`. + have hrec : ∀ n, n ≤ N j → ∃ (T : ℕ) (wsn : Fin k → List Bool), + (repeatTM i x tm).runFrom start T = wordsCfg input (some (Sum.inl tm.q₀)) wsn out ∧ + P j n input wsn ∧ T ≤ n * (t j + 1) ∧ + ∀ m ≤ T, ∀ l, ((repeatTM i x tm).runFrom start m).workTapePos l + ∈ Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro n + induction n with + | zero => + intro _ + refine ⟨0, ws, by rw [runFrom_zero, hstart], hP0, by omega, fun m hm l => ?_⟩ + have : m = 0 := by omega + subst this + rw [runFrom_zero, hstart] + simp only [Finset.mem_Icc, wordsCfg_workTapePos] + omega + | succ n ih => + intro hn + obtain ⟨T, wsn, hrun, hPn, hT, hIcc⟩ := ih (by omega) + obtain ⟨τ, hτ, wsn', hrunTm, hQ, hsp⟩ := hround j n (by omega) input wsn out hPn + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm + (wordsCfg input (some tm.q₀) wsn out) τ (by rw [hrunTm]; rfl) + have hu_run : tm.runFrom (wordsCfg input (some tm.q₀) wsn out) u = + wordsCfg input none wsn' out := by + rw [← runFrom_eq_of_halt tm _ hu huhalt, hrunTm] + have hsp_u : tm.spaceUsed (wordsCfg input (some tm.q₀) wsn out) u ≤ s j := + le_trans (spaceUsed_mono tm _ hu) hsp + refine ⟨T + (u + 1), wsn', ?_, hQ.1, ?_, ?_⟩ + · rw [runFrom_add, hrun, runFrom_round_restart wsn wsn' out u huactive hu_run hQ.2] + · have hexp : (n + 1) * (t j + 1) = n * (t j + 1) + (t j + 1) := by rw [add_mul, one_mul] + have : u ≤ t j := le_trans hu hτ + omega + · intro m hm l + rcases Nat.lt_or_ge m (T + 1) with hmT | hmT + · exact hIcc m (by omega) l + · obtain ⟨m', rfl⟩ : ∃ m', m = T + m' := ⟨m - T, by omega⟩ + rw [runFrom_add, hrun] + exact round_Icc wsn wsn' out u (s j) huactive hu_run hsp_u m' (by omega) l + -- The stopping round: apply `hstop`, take the minimal halting time, and read off `R j`. + obtain ⟨T, wsN, hrun, hPN, hT, hIcc⟩ := hrec (N j) le_rfl + obtain ⟨τ, hτ, ws', hrunTm, hQ, hsp⟩ := hstop j input wsN out hPN + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm + (wordsCfg input (some tm.q₀) wsN out) τ (by rw [hrunTm]; rfl) + have hu_run : tm.runFrom (wordsCfg input (some tm.q₀) wsN out) u = + wordsCfg input none ws' out := by + rw [← runFrom_eq_of_halt tm _ hu huhalt, hrunTm] + have hsp_u : tm.spaceUsed (wordsCfg input (some tm.q₀) wsN out) u ≤ s j := + le_trans (spaceUsed_mono tm _ hu) hsp + -- The head stays in `[-s j, s j]` for the whole run. + have hIccAll : ∀ m ≤ T + (u + 1), ∀ l, + ((repeatTM i x tm).runFrom start m).workTapePos l ∈ Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro m hm l + rcases Nat.lt_or_ge m (T + 1) with hmT | hmT + · exact hIcc m (by omega) l + · obtain ⟨m', rfl⟩ : ∃ m', m = T + m' := ⟨m - T, by omega⟩ + rw [runFrom_add, hrun] + exact round_Icc wsN ws' out u (s j) huactive hu_run hsp_u m' (by omega) l + refine ⟨T + (u + 1), ?_, ws', ?_, hQ.1, ?_⟩ + · -- time bound + have hexp : (N j + 1) * (t j + 1) = N j * (t j + 1) + (t j + 1) := by rw [add_mul, one_mul] + have : u ≤ t j := le_trans hu hτ + omega + · -- the run ends in the halting `wordsCfg` + rw [runFrom_add, hrun, runFrom_round_halt wsN ws' out u huactive hu_run hQ.2] + · -- space bound: each tape's visited set lies in `[-s j, s j]`, so has at most `2 * s j + 1` + -- cells, and there are `k` tapes + have hbound : ∀ l : Fin k, + (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l ≤ 2 * s j + 1 := by + intro l + have hsub : (repeatTM i x tm).visitedByTapeHead start (T + (u + 1)) l ⊆ + Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + exact hIccAll m (by omega) l + calc (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l + ≤ (Finset.Icc (-(s j : ℤ)) (s j : ℤ)).card := Finset.card_le_card hsub + _ = 2 * s j + 1 := by rw [Int.card_Icc]; omega + calc (repeatTM i x tm).spaceUsed start (T + (u + 1)) + = ∑ l : Fin k, (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l := rfl + _ ≤ ∑ _l : Fin k, (2 * s j + 1) := Finset.sum_le_sum fun l _ => hbound l + _ = 2 * k * s j + k := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, Nat.cast_id, + Nat.mul_add, Nat.mul_one, ← Nat.mul_assoc, Nat.mul_comm k 2] + +end Turing.MultiTapeTM From c8083240c771040882a228de7e745f27bd4d4287 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 00:04:38 +0000 Subject: [PATCH 41/93] feat(Turing): general-layout adapters for computable tape transformers Rename the canonical-layout adapters to `*_fixed`, add a relaxed embedding-lift `transformsTapes_extendTapes'` (drops the vestigial blank-tapes precondition), placement-embedding helpers, and the general-layout `exists_transformsTapes_ofComputable` / `exists_transformsTapes_ofComputableInput`. Co-Authored-By: Claude Opus 4.8 --- .../MultiTape/NormalForms/Adapters.lean | 328 +++++++++++++++++- 1 file changed, 323 insertions(+), 5 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index 8f03b917f..e07524c7a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -38,7 +38,7 @@ variable {α β : Type*} /-- **A computable function, read from the input tape, as a tape transformer.** Started with the input on the real input tape and every work tape blank, the machine halts having written the encoded result to the last work tape, in linear time and in space linear in the result length. -/ -public theorem exists_transformsTapes_ofComputableInput +public theorem exists_transformsTapes_ofComputableInput_fixed {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace g enc encOut t s) : ∃ (c K : ℕ) (o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), @@ -183,7 +183,7 @@ Built from `exists_transformsTapes_ofComputableInput`'s machine `M₀` (which re and leaves the result on a work tape): `inputFromTape M₀` redirects `M₀`'s input reading to the virtual tape, bracketed by two one-cell writes that place and remove the boundary flag `M₀`'s input redirection needs. -/ -public theorem exists_transformsTapes_ofComputable +public theorem exists_transformsTapes_ofComputable_fixed {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace g enc encOut t s) : ∃ (c K : ℕ) (i o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), @@ -193,7 +193,7 @@ public theorem exists_transformsTapes_ofComputable (c * (t a + 1)) (c * (s a + (enc a).length + (encOut (g a)).length + 1) + K) := by classical -- The base machine `M₀` reads the *real* input tape and leaves `encOut (g a)` on work tape `o₀`. - obtain ⟨c_f, K₀, o₀, State₀, hfin₀, M₀, hM₀⟩ := exists_transformsTapes_ofComputableInput h + obtain ⟨c_f, K₀, o₀, State₀, hfin₀, M₀, hM₀⟩ := exists_transformsTapes_ofComputableInput_fixed h -- Two one-cell writers on the flag tape `⟨K₀ + 1, _⟩`: one places the boundary mark, one clears -- it. They bracket the redirected run of `M₀` and supply what its input redirection needs. obtain ⟨SM, hSMfin, setMark, hMark⟩ := @@ -533,6 +533,56 @@ public theorem transformsTapes_extendTapes {k k' : ℕ} {State : Type} rw [hstart] exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) +/-- **Reindexing preserves being a tape transformer (relaxed precondition).** Same as +`transformsTapes_extendTapes`, but the precondition no longer requires the tapes outside `range e` +to be blank: those tapes are simply carried through unchanged, as the postcondition records. -/ +public theorem transformsTapes_extendTapes' {k k' : ℕ} {State : Type} + (e : Fin k ↪ Fin k') {M : MultiTapeTM k Bool State} + {P : (input : List Bool) → (Fin k → List Bool) → Prop} + {Q : (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} + {t s : ℕ} (h : TransformsTapes M P Q t s) : + TransformsTapes (extendTapes M e) + (fun input ws => P input (fun j => ws (e j))) + (fun input ws ws' => Q input (fun j => ws (e j)) (fun j => ws' (e j)) ∧ + ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) + t (s + (k' - k)) := by + intro input ws out hP + -- the start config, viewed through the embedding + have hstart : wordsCfg input (some (extendTapes M e).q₀) ws out = + embed e (wordsCfg input (some M.q₀) (fun j => ws (e j)) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := + wordsCfg_eq_embed e input (some M.q₀) ws out + -- run the inner machine + obtain ⟨τ, hτ, ws', hrun, hQ, hsp⟩ := + h input (fun j => ws (e j)) out hP + refine ⟨τ, hτ, fun l => match partialInv e l with | some j => ws' j | none => ws l, ?_, ?_, ?_⟩ + · -- the run: the embedded halting config is a `wordsCfg` + rw [hstart, runFrom_embed, hrun] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapes l z = + (wordsCfg input (none : Option State) + (fun l => match partialInv e l with | some j => ws' j | none => ws l) out).workTapes l z + rcases hpi : partialInv e l with _ | j + · simp [embed, hpi] + · simp [embed, hpi, wordsCfg_workTapes] + · funext l + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapePos l = (0 : ℤ) + rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] + · -- the postcondition + refine ⟨?_, ?_⟩ + · have : (fun j => (fun l => match partialInv e l with | some j => ws' j | none => ws l) (e j)) + = ws' := by + funext j; simp only [partialInv_embed] + rw [this]; exact hQ + · intro l hl + simp only [partialInv_eq_none e (fun ⟨j, hj⟩ => hl j hj)] + · -- the space + rw [hstart] + exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) + /-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`: run the machine for `f` (its result on a work tape), then the machine for `gg` reading that tape, then emit. The two machines are placed on a shared tape layout with the first's output tape identified with the @@ -547,9 +597,10 @@ public theorem computableInTimeAndSpace_comp (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by classical -- `M_f` reads the real input and leaves `encB (f a)` on its output tape `o_f`. - obtain ⟨c_f, K_f, o_f, S_f, hS_f, M_f, hM_f⟩ := exists_transformsTapes_ofComputableInput hf + obtain ⟨c_f, K_f, o_f, S_f, hS_f, M_f, hM_f⟩ := exists_transformsTapes_ofComputableInput_fixed hf -- `M_g` reads `encB x` from its input tape `i_g` and leaves `encC (gg x)` on `o_g`. - obtain ⟨c_g, K_g, i_g, o_g, S_g, hS_g, M_g, hio, hM_g⟩ := exists_transformsTapes_ofComputable hg + obtain ⟨c_g, K_g, i_g, o_g, S_g, hS_g, M_g, hio, hM_g⟩ := + exists_transformsTapes_ofComputable_fixed hg have hfin_f := hS_f have hfin_g := hS_g -- The length of `gg`'s output is bounded by its running time. @@ -787,4 +838,271 @@ public theorem computableInTimeAndSpace_comp _ ≤ ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3) * PS := Nat.mul_le_mul (by omega) (le_refl _) +/-- **Placement embedding (two pins).** Given distinct canonical indices `i₀ ≠ o₀` in `Fin K` and +distinct target indices `i ≠ o` in `Fin k` avoiding a set `keep`, with enough room +(`K + keep.card ≤ k`), there is an embedding `Fin K ↪ Fin k` sending `i₀ ↦ i`, `o₀ ↦ o`, and every +other index to a tape outside `insert i (insert o keep)`. -/ +private lemma exists_embed_placing {K k : ℕ} (i₀ o₀ : Fin K) (hio₀ : i₀ ≠ o₀) + (i o : Fin k) (keep : Finset (Fin k)) (hio : i ≠ o) (_hik : i ∉ keep) (_hok : o ∉ keep) + (hroom : K + keep.card ≤ k) : + ∃ e : Fin K ↪ Fin k, e i₀ = i ∧ e o₀ = o ∧ + ∀ j, j ≠ i₀ → j ≠ o₀ → e j ∉ insert i (insert o keep) := by + classical + set forb : Finset (Fin k) := insert i (insert o keep) with hforb + set avail : Finset (Fin k) := Finset.univ \ forb with havail + have hforb_card : forb.card ≤ keep.card + 2 := by + have h1 : (insert o keep).card ≤ keep.card + 1 := Finset.card_insert_le _ _ + have h2 : forb.card ≤ (insert o keep).card + 1 := by + rw [hforb]; exact Finset.card_insert_le _ _ + omega + have havail_card : avail.card = k - forb.card := by + rw [havail, Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin] + have hlhs : (Finset.univ \ {i₀, o₀} : Finset (Fin K)).card = K - 2 := by + rw [Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, Fintype.card_fin, + Finset.card_pair_eq_two_iff.mpr hio₀] + have hcard_le : Fintype.card {x : Fin K // x ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))} + ≤ Fintype.card {x : Fin k // x ∈ avail} := by + simp only [Fintype.card_coe] + rw [hlhs, havail_card]; omega + obtain ⟨g⟩ := Function.Embedding.nonempty_of_card_le hcard_le + have hmem : ∀ j : Fin K, j ≠ i₀ → j ≠ o₀ → + j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by + intro j hj1 hj2 + simp only [Finset.mem_sdiff, Finset.mem_univ, true_and, Finset.mem_insert, + Finset.mem_singleton, not_or] + exact ⟨hj1, hj2⟩ + have hg_forb : ∀ y : {x : Fin K // x ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))}, + (g y).val ∉ forb := by + intro y + have hy : (g y).val ∈ Finset.univ \ forb := (g y).2 + exact (Finset.mem_sdiff.mp hy).2 + have hi_forb : i ∈ forb := by rw [hforb]; exact Finset.mem_insert_self _ _ + have ho_forb : o ∈ forb := by + rw [hforb]; exact Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hg_ne_i : ∀ y, (g y).val ≠ i := fun y hcon => hg_forb y (by rw [hcon]; exact hi_forb) + have hg_ne_o : ∀ y, (g y).val ≠ o := fun y hcon => hg_forb y (by rw [hcon]; exact ho_forb) + set f : Fin K → Fin k := fun j => + if hj : j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) then (g ⟨j, hj⟩).val + else if j = i₀ then i else o with hf_def + have hmem_i₀ : i₀ ∉ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by simp + have hmem_o₀ : o₀ ∉ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by simp + have hfi₀ : f i₀ = i := by + rw [hf_def]; dsimp only; rw [dite_eq_right hmem_i₀]; exact ite_eq_left rfl + have hfo₀ : f o₀ = o := by + rw [hf_def]; dsimp only; rw [dite_eq_right hmem_o₀]; exact ite_eq_right (Ne.symm hio₀) + have hfother : ∀ j (hj : j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))), + f j = (g ⟨j, hj⟩).val := by + intro j hj; rw [hf_def]; dsimp only; rw [dite_eq_left hj] + have hf_inj : Function.Injective f := by + intro a b hab + by_cases ha : a ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · by_cases hb : b ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · rw [hfother a ha, hfother b hb] at hab + exact congrArg Subtype.val (g.injective (Subtype.ext hab)) + · exfalso + rw [hfother a ha] at hab + have hb' : b = i₀ ∨ b = o₀ := by + by_contra hbc; rw [not_or] at hbc; exact hb (hmem b hbc.1 hbc.2) + rcases hb' with rfl | rfl + · rw [hfi₀] at hab; exact hg_ne_i _ hab + · rw [hfo₀] at hab; exact hg_ne_o _ hab + · by_cases hb : b ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · exfalso + rw [hfother b hb] at hab + have ha' : a = i₀ ∨ a = o₀ := by + by_contra hac; rw [not_or] at hac; exact ha (hmem a hac.1 hac.2) + rcases ha' with rfl | rfl + · rw [hfi₀] at hab; exact hg_ne_i _ hab.symm + · rw [hfo₀] at hab; exact hg_ne_o _ hab.symm + · have ha' : a = i₀ ∨ a = o₀ := by + by_contra hac; rw [not_or] at hac; exact ha (hmem a hac.1 hac.2) + have hb' : b = i₀ ∨ b = o₀ := by + by_contra hbc; rw [not_or] at hbc; exact hb (hmem b hbc.1 hbc.2) + rcases ha' with rfl | rfl <;> rcases hb' with rfl | rfl + · rfl + · exfalso; rw [hfi₀, hfo₀] at hab; exact hio hab + · exfalso; rw [hfi₀, hfo₀] at hab; exact hio hab.symm + · rfl + refine ⟨⟨f, hf_inj⟩, hfi₀, hfo₀, ?_⟩ + intro j hj1 hj2 + change f j ∉ forb + rw [hfother j (hmem j hj1 hj2)] + exact hg_forb ⟨j, hmem j hj1 hj2⟩ + +/-- **Placement embedding (one pin).** Like `exists_embed_placing`, but pinning a single index +`o₀ ↦ o`, sending every other index outside `insert o keep`. -/ +private lemma exists_embed_placing_one {K k : ℕ} (o₀ : Fin K) + (o : Fin k) (keep : Finset (Fin k)) (_hok : o ∉ keep) (hroom : K + keep.card ≤ k) : + ∃ e : Fin K ↪ Fin k, e o₀ = o ∧ ∀ j, j ≠ o₀ → e j ∉ insert o keep := by + classical + set forb : Finset (Fin k) := insert o keep with hforb + set avail : Finset (Fin k) := Finset.univ \ forb with havail + have hforb_card : forb.card ≤ keep.card + 1 := by rw [hforb]; exact Finset.card_insert_le _ _ + have havail_card : avail.card = k - forb.card := by + rw [havail, Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin] + have hlhs : (Finset.univ \ {o₀} : Finset (Fin K)).card = K - 1 := by + rw [Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, Fintype.card_fin, + Finset.card_singleton] + have hcard_le : Fintype.card {x : Fin K // x ∈ (Finset.univ \ {o₀} : Finset (Fin K))} + ≤ Fintype.card {x : Fin k // x ∈ avail} := by + simp only [Fintype.card_coe] + rw [hlhs, havail_card]; omega + obtain ⟨g⟩ := Function.Embedding.nonempty_of_card_le hcard_le + have hmem : ∀ j : Fin K, j ≠ o₀ → j ∈ (Finset.univ \ {o₀} : Finset (Fin K)) := by + intro j hj + simp only [Finset.mem_sdiff, Finset.mem_univ, true_and, Finset.mem_singleton] + exact hj + have hg_forb : ∀ y : {x : Fin K // x ∈ (Finset.univ \ {o₀} : Finset (Fin K))}, + (g y).val ∉ forb := by + intro y + have hy : (g y).val ∈ Finset.univ \ forb := (g y).2 + exact (Finset.mem_sdiff.mp hy).2 + have ho_forb : o ∈ forb := by rw [hforb]; exact Finset.mem_insert_self _ _ + have hg_ne_o : ∀ y, (g y).val ≠ o := fun y hcon => hg_forb y (by rw [hcon]; exact ho_forb) + set f : Fin K → Fin k := fun j => + if hj : j ∈ (Finset.univ \ {o₀} : Finset (Fin K)) then (g ⟨j, hj⟩).val else o with hf_def + have hmem_o₀ : o₀ ∉ (Finset.univ \ {o₀} : Finset (Fin K)) := by simp + have hfo₀ : f o₀ = o := by rw [hf_def]; dsimp only; rw [dite_eq_right hmem_o₀] + have hfother : ∀ j (hj : j ∈ (Finset.univ \ {o₀} : Finset (Fin K))), + f j = (g ⟨j, hj⟩).val := by + intro j hj; rw [hf_def]; dsimp only; rw [dite_eq_left hj] + have hf_inj : Function.Injective f := by + intro a b hab + by_cases ha : a ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · by_cases hb : b ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · rw [hfother a ha, hfother b hb] at hab + exact congrArg Subtype.val (g.injective (Subtype.ext hab)) + · exfalso + rw [hfother a ha] at hab + have hb' : b = o₀ := by by_contra hbc; exact hb (hmem b hbc) + rw [hb', hfo₀] at hab; exact hg_ne_o _ hab + · by_cases hb : b ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · exfalso + rw [hfother b hb] at hab + have ha' : a = o₀ := by by_contra hac; exact ha (hmem a hac) + rw [ha', hfo₀] at hab; exact hg_ne_o _ hab.symm + · have ha' : a = o₀ := by by_contra hac; exact ha (hmem a hac) + have hb' : b = o₀ := by by_contra hbc; exact hb (hmem b hbc) + rw [ha', hb'] + refine ⟨⟨f, hf_inj⟩, hfo₀, ?_⟩ + intro j hj + change f j ∉ forb + rw [hfother j (hmem j hj)] + exact hg_forb ⟨j, hmem j hj⟩ + +/-- **A computable function, read from a work tape, as a tape transformer (general layout).** Placed +on any tape count `k` with a chosen input tape `i`, output tape `o` and a set `keep` of tapes to +leave untouched, provided there is room for the machine's own tapes. -/ +public theorem exists_transformsTapes_ofComputable {α β : Type*} {enc : α ↪ List Bool} + {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ m c : ℕ, ∀ (k : ℕ) (i o : Fin k) (keep : Finset (Fin k)), + i ≠ o → i ∉ keep → o ∉ keep → m + 2 + keep.card ≤ k → + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ a : α, + TransformsTapes tm + (fun _ ws => ws i = enc a ∧ ∀ l, l ≠ i → l ∉ keep → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) + (c * (s a + (enc a).length + (encOut (g a)).length + 1) + k) := by + classical + obtain ⟨c, K, i₀, o₀, State₀, hfin₀, tm₀, hio₀, hcanon⟩ := + exists_transformsTapes_ofComputable_fixed h + have hK2 : 2 ≤ K := by + by_contra hlt + exact hio₀ (Fin.ext (by have := i₀.isLt; have := o₀.isLt; omega)) + refine ⟨K - 2, c, fun k i o keep hio hik hok hroom => ?_⟩ + have hKk : K ≤ k := by omega + have hroom' : K + keep.card ≤ k := by omega + obtain ⟨e, hei, heo, hother⟩ := + exists_embed_placing i₀ o₀ hio₀ i o keep hio hik hok hroom' + refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ + refine (transformsTapes_extendTapes' e (hcanon a)).imp ?_ ?_ le_rfl ?_ + · -- precondition: the general layout satisfies the embedded canonical precondition + rintro input ws ⟨hwi, hwblank⟩ + refine ⟨?_, ?_⟩ + · change ws (e i₀) = enc a + rw [hei]; exact hwi + · intro l' hl' + change ws (e l') = [] + by_cases hlo : l' = o₀ + · subst hlo; rw [heo]; exact hwblank o (Ne.symm hio) hok + · have hmem := hother l' hl' hlo + rw [Finset.mem_insert, not_or] at hmem + obtain ⟨hne_i, hmem2⟩ := hmem + rw [Finset.mem_insert, not_or] at hmem2 + exact hwblank (e l') hne_i hmem2.2 + · -- postcondition: read the update back through the embedding + rintro input ws ws' _ ⟨hQ1, hQ2⟩ + funext l + by_cases hlo : l = o + · subst hlo + have hh := congrFun hQ1 o₀ + simp only [heo, Function.update_self] at hh + rw [Function.update_self]; exact hh + · rw [Function.update_of_ne hlo] + by_cases hex : ∃ j, e j = l + · obtain ⟨j, rfl⟩ := hex + have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] + have hh := congrFun hQ1 j + rw [Function.update_of_ne hjo] at hh + exact hh + · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + · -- space + omega + +/-- **A computable function, read from the input tape, as a tape transformer (general layout).** +Placed on any tape count `k` with a chosen output tape `o` and a set `keep` of tapes to leave +untouched, provided there is room for the machine's own tapes. -/ +public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : α ↪ List Bool} + {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ m c : ℕ, ∀ (k : ℕ) (o : Fin k) (keep : Finset (Fin k)), + o ∉ keep → m + 1 + keep.card ≤ k → + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ a : α, + TransformsTapes tm + (fun input ws => input = enc a ∧ ∀ l, l ∉ keep → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) + (c * (s a + (encOut (g a)).length + 1) + k) := by + classical + obtain ⟨c, K, o₀, State₀, hfin₀, tm₀, hcanon⟩ := + exists_transformsTapes_ofComputableInput_fixed h + have hK1 : 1 ≤ K := by have := o₀.isLt; omega + refine ⟨K - 1, c, fun k o keep hok hroom => ?_⟩ + have hKk : K ≤ k := by omega + have hroom' : K + keep.card ≤ k := by omega + obtain ⟨e, heo, hother⟩ := exists_embed_placing_one o₀ o keep hok hroom' + refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ + refine (transformsTapes_extendTapes' e (hcanon a)).imp ?_ ?_ le_rfl ?_ + · -- precondition + rintro input ws ⟨hinput, hwblank⟩ + refine ⟨hinput, ?_⟩ + intro l' + change ws (e l') = [] + by_cases hlo : l' = o₀ + · subst hlo; rw [heo]; exact hwblank o hok + · have hmem := hother l' hlo + rw [Finset.mem_insert, not_or] at hmem + exact hwblank (e l') hmem.2 + · -- postcondition + rintro input ws ws' _ ⟨hQ1, hQ2⟩ + funext l + by_cases hlo : l = o + · subst hlo + have hh := congrFun hQ1 o₀ + simp only [heo, Function.update_self] at hh + rw [Function.update_self]; exact hh + · rw [Function.update_of_ne hlo] + by_cases hex : ∃ j, e j = l + · obtain ⟨j, rfl⟩ := hex + have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] + have hh := congrFun hQ1 j + rw [Function.update_of_ne hjo] at hh + exact hh + · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + · -- space + omega + end Turing.MultiTapeTM From dd126a45e67e5dc99cbbda4c639e4d775edd13bb Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 00:10:15 +0000 Subject: [PATCH 42/93] feat(Turing): prove complexity of the loop combinator Bring the loop combinator's dependencies onto the tape-transformer branch and prove `computableInTimeAndSpace_loopFunction` against the now-real plumbing primitives (branch, repeat, clear, nop, seq, and the general `ofComputable`/`ofComputableInput` adapters), so both function composition and the loop are established with no `sorry`. * Combinators/Loop.lean: the `loopFunction`/`loopIterate` theory and the complexity theorem, ported onto the split `TransformsTapes` interface (abstract combinator use; contradiction cases adapted to the wordsCfg form of the specification). * Combinators/AlmostConstant.lean, Encodings/Option.lean, Combinators/Id.lean: the almost-constant functions, the option-encoding `isNone` test and the identity, needed by the loop. * Deterministic.lean: `length_output_runFrom_le` and `ComputableInTimeAndSpace.length_encOut_le` (an emitted word is no longer than the time bound), used to bound the intermediate encodings. * Configuration.lean: `Cfg.ext_zero_tapes`. * NormalForms/Adapters.lean: weaken `computableInTimeAndSpace_of_transformsTapes` to the single-tape postcondition `ws' o = encOut (g a)` with the `c * (t + |out| + 1)` time bound the loop assembly needs. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 4 + .../MultiTape/Combinators/AlmostConstant.lean | 391 +++++++++ .../Turing/MultiTape/Combinators/Id.lean | 117 +++ .../Turing/MultiTape/Combinators/Loop.lean | 798 ++++++++++++++++++ .../Turing/MultiTape/Configuration.lean | 8 + .../Turing/MultiTape/Deterministic.lean | 25 + .../Turing/MultiTape/Encodings/Option.lean | 92 ++ .../MultiTape/NormalForms/Adapters.lean | 25 +- 8 files changed, 1449 insertions(+), 11 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean diff --git a/Cslib.lean b/Cslib.lean index dce59c966..cacd600d8 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -54,9 +54,13 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop 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.Encodings.Option public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean new file mode 100644 index 000000000..950f57961 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Mathlib.Data.List.Infix +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of Almost Constant Functions + +A function `f : α → β` that is constant except for a finite number of arguments is computable in +constant time and zero space: the machine reads the encoded input while remembering the prefix it +has seen so far. After a finite number of steps it either reaches the end of the input or a point +where the prefix cannot be extended to the encoding of one of the finitely many exceptions. In both +cases, it emits the corresponding output one symbol at a time. + +This result also holds for functions whose domain is already finite. + +## Main Results + +* `computableInTimeAndSpace_of_finite`: Every function on a finite type is computable in + constant time and zero space, relative to any encoding. +* `computableInTimeAndSpace_of_exists_finite_ne`: Every function that is constant except + for a finite number of arguments is computable in constant time and zero space, relative to any + encoding. +* `computableInTimeAndSpace_of_const`: Every constant function is computable in constant + time and zero space, relative to any encoding. +* `computableInTimeAndSpace_almostConstTime` and + `computableInTimeAndSpace_finiteFunTime`: The same with explicit time bounds. + +-/ + +namespace Turing.MultiTapeTM + +section AlmostConstFun + +/-! ## The machine computing a function that is constant outside a finite set + +The machine `almostConstTM encIn encOut f S out` computes `f`, provided that the encoded output +of `f` is the fixed Boolean string `out` outside of the finite set `S`. -/ + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {f : α → β} + {S : Finset α} {out : List Bool} + +/-- The prefixes of the encodings of the elements of a finite set `S`, together with the empty list. + +The empty list has to be added explicitly for the case where `S` is empty: `almostConstTM` uses +the elements of this set as its states while reading the input, so the set has to contain the +starting state `[]` even if there is nothing to distinguish. -/ +def encPrefixes (encIn : α ↪ List Bool) (S : Finset α) : Finset (List Bool) := + insert [] (S.biUnion fun a => (encIn a).inits.toFinset) + +lemma mem_encPrefixes {p : List Bool} {a : α} (ha : a ∈ S) (h : p <+: encIn a) : + p ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, List.mem_inits] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of prefixes is closed under taking prefixes. -/ +lemma prefix_mem_encPrefixes {p q : List Bool} (h : p ∈ encPrefixes encIn S) (hq : q <+: p) : + q ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h ⊢ + rcases h with rfl | ⟨a, ha, hp⟩ + · exact Or.inl (List.prefix_nil.mp hq) + · exact Or.inr ⟨a, ha, hq.trans hp⟩ + +/-- The suffixes of the default output and of the encoded values of `f` on `S`. -/ +def outSuffixes (encOut : β ↪ List Bool) (f : α → β) (S : Finset α) (out : List Bool) : + Finset (List Bool) := + out.tails.toFinset ∪ S.biUnion fun a => (encOut (f a)).tails.toFinset + +lemma suffix_out_mem_outSuffixes {w : List Bool} (h : w <:+ out) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, List.mem_toFinset, List.mem_tails] + exact Or.inl h + +lemma mem_outSuffixes {w : List Bool} {a : α} (ha : a ∈ S) (h : w <:+ encOut (f a)) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, List.mem_tails] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of suffixes is closed under taking suffixes. -/ +lemma suffix_mem_outSuffixes {v w : List Bool} (h : w ∈ outSuffixes encOut f S out) (hv : v <:+ w) : + v ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, + List.mem_tails] at h ⊢ + rcases h with h | ⟨a, ha, h⟩ + · exact Or.inl (hv.trans h) + · exact Or.inr ⟨a, ha, hv.trans h⟩ + +lemma tail_mem_outSuffixes {w : List Bool} (h : w ∈ outSuffixes encOut f S out) : + w.tail ∈ outSuffixes encOut f S out := + suffix_mem_outSuffixes h (List.tail_suffix w) + +/-- If the encoded output is the default output outside of `S`, then every encoded output occurs +among the suffixes. -/ +lemma encOut_mem_outSuffixes (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + encOut (f a) ∈ outSuffixes encOut f S out := by + by_cases ha : a ∈ S + · exact mem_outSuffixes ha (List.suffix_refl _) + · rw [h a ha] + exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +/-- The states of the machine `almostConstTM`: either the prefix of the input read so far, or the +part of the output that still has to be emitted. -/ +abbrev AlmostConstState (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : Type := + {p : List Bool // p ∈ encPrefixes encIn S} ⊕ {w : List Bool // w ∈ outSuffixes encOut f S out} + +open Classical in +/-- The function `f`, transported along the encodings of its domain and codomain: it maps the +encoding of an element of `S` to the encoding of its value under `f`, and every other list to the +default output. -/ +noncomputable def encodedFun (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) (p : List Bool) : List Bool := + if h : ∃ a ∈ S, encIn a = p then encOut (f h.choose) else out + +@[simp] +lemma encodedFun_enc {a : α} (ha : a ∈ S) : + encodedFun encIn encOut f S out (encIn a) = encOut (f a) := by + have hex : ∃ a' ∈ S, encIn a' = encIn a := ⟨a, ha, rfl⟩ + rw [encodedFun, dite_eq_left_of_eq_true (eq_true hex), encIn.injective hex.choose_spec.2] + +@[simp] +lemma encodedFun_enc_of_notMem {a : α} (ha : a ∉ S) : + encodedFun encIn encOut f S out (encIn a) = out := by + have hex : ¬ ∃ a' ∈ S, encIn a' = encIn a := by + rintro ⟨a', ha', h⟩ + exact ha (encIn.injective h ▸ ha') + rw [encodedFun, dite_eq_right_of_eq_false (eq_false hex)] + +lemma encodedFun_mem_outSuffixes (p : List Bool) : + encodedFun encIn encOut f S out p ∈ outSuffixes encOut f S out := by + rw [encodedFun] + split + · next h => exact mem_outSuffixes h.choose_spec.1 (List.suffix_refl _) + · exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +open Classical in +/-- The machine computing a function that is constant outside of `S`. It has no work tapes. + +While reading the input it remembers the prefix read so far. Once this prefix cannot be extended +to the encoding of an element of `S` anymore, or the blank behind the input is reached, it +switches to the state that holds the encoded output, which it then emits one symbol per step +before halting. -/ +noncomputable def almostConstTM (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : + MultiTapeTM 0 Bool (AlmostConstState encIn encOut f S out) where + q₀ := Sum.inl ⟨[], by simp [encPrefixes]⟩ + tr q input _ := + match q with + | Sum.inl p => + match input with + | some b => + if h : p.val ++ [b] ∈ encPrefixes encIn S then + ⟨.pos, Fin.elim0, none, some (Sum.inl ⟨p.val ++ [b], h⟩)⟩ + else + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨out, suffix_out_mem_outSuffixes (List.suffix_refl out)⟩)⟩ + | none => + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨encodedFun encIn encOut f S out p.val, + encodedFun_mem_outSuffixes p.val⟩)⟩ + | Sum.inr w => + ⟨0, Fin.elim0, w.val.head?, + if w.val = [] then none + else some (Sum.inr ⟨w.val.tail, tail_mem_outSuffixes w.property⟩)⟩ + +/-- The configuration reached after `j` steps of reading the input. -/ +lemma runFrom_read (a : α) {j : ℕ} (hj : j ≤ (encIn a).length) + (hmem : (encIn a).take j ∈ encPrefixes encIn S) : + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) j = + { state := some (Sum.inl ⟨(encIn a).take j, hmem⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + induction j with + | zero => + simp only [runFrom_zero, initCfg, List.take_zero] + ext <;> simp [almostConstTM] + | succ j ih => + have hprefix : (encIn a).take j <+: (encIn a).take (j + 1) := by + simp + have hmem' : (encIn a).take j ∈ encPrefixes encIn S := prefix_mem_encPrefixes hmem hprefix + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∈ encPrefixes encIn S := by + grind [List.take_concat_get'] + have hmove : moveInputPos (⟨1 + j, by omega⟩ : Fin ((encIn a).length + 2)) SignType.pos + = ⟨1 + (j + 1), by omega⟩ := by + grind [moveInputPos_pos_of_ne_right] + have hstart : 1 + j ≠ 0 := by omega + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + rw [runFrom_succ_eq_step', ih (by omega) hmem'] + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat] + exact Cfg.ext_zero_tapes (by grind [List.take_concat_get']) hmove (by simp) + +/-- The configuration reached after having emitted the first `i` symbols of `w`, starting from a +configuration that is about to emit `w`. -/ +lemma runFrom_write {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) {i : ℕ} (hi : i ≤ w.length) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } i = + { state := some (Sum.inr ⟨w.drop i, suffix_mem_outSuffixes hw (w.drop_suffix i)⟩), + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w.take i } := by + induction i with + | zero => simp [runFrom_zero] + | succ i ih => + have hilt : i < w.length := by omega + have htake := List.take_concat_get' w i hilt + have hnotdone : ¬ (w.length ≤ i) := by omega + rw [runFrom_succ_eq_step', ih (by omega)] + simp only [step, Action.apply, almostConstTM, List.head?_drop, + List.getElem?_eq_getElem hilt, List.drop_eq_nil_iff, hnotdone, reduceIte, List.tail_drop, + moveInputPos_zero, Option.toList_some] + exact Cfg.ext_zero_tapes rfl rfl (by grind) + +/-- Starting from a configuration that is about to emit `w`, the machine halts after `w.length + 1` +steps, having emitted `w`. -/ +lemma runFrom_write_halted {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } (w.length + 1) = + { state := none, + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w } := by + rw [runFrom_succ_eq_step', runFrom_write pos o hw le_rfl] + simp only [step, Action.apply, almostConstTM, List.drop_length, reduceIte, List.head?_nil, + moveInputPos_zero, Option.toList_none, List.append_nil, List.take_length] + exact Cfg.ext_zero_tapes rfl rfl (by simp) + +/-- A constant time bound for the machine `almostConstTM`. -/ +public def almostConstTime (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : ℕ := + 2 + out.length + S.sup fun a => (encIn a).length + (encOut (f a)).length + +lemma length_le_sup_of_mem_encPrefixes {p : List Bool} (h : p ∈ encPrefixes encIn S) : + p.length ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h + rcases h with rfl | ⟨a, ha, hp⟩ + · simp + · have hsup : (encIn a).length + (encOut (f a)).length ≤ + S.sup fun a => (encIn a).length + (encOut (f a)).length := + Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha + have := hp.length_le + omega + +/-- The machine reaches the state in which it starts emitting the encoded output after a number +of steps that is bounded independently of the input. -/ +lemma reaches_write (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + ∃ (j : ℕ) (hj : j ≤ (encIn a).length), + j + (encOut (f a)).length ≤ + out.length + S.sup (fun a => (encIn a).length + (encOut (f a)).length) ∧ + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) = + { state := some (Sum.inr ⟨encOut (f a), encOut_mem_outSuffixes h a⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + classical + set j := Nat.findGreatest (fun j => (encIn a).take j ∈ encPrefixes encIn S) (encIn a).length + with hjdef + have hmem : (encIn a).take j ∈ encPrefixes encIn S := + Nat.findGreatest_spec (P := fun j => (encIn a).take j ∈ encPrefixes encIn S) + (Nat.zero_le _) (by simp [encPrefixes]) + have hjle : j ≤ (encIn a).length := Nat.findGreatest_le _ + have hjsup : j ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + have hlen := length_le_sup_of_mem_encPrefixes (encOut := encOut) (f := f) hmem + rw [List.length_take] at hlen + omega + use j, hjle + constructor + · by_cases ha : a ∈ S + · grind [Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha] + · grind [h a ha] + rw [runFrom_succ_eq_step', runFrom_read a hjle hmem] + rcases eq_or_lt_of_le hjle with heq | hlt + · -- the whole input has been read, so the machine decodes it + have hend : 1 + j = (encIn a).length + 1 := by omega + have hdec : encodedFun encIn encOut f S out ((encIn a).take j) = encOut (f a) := by + rw [heq, List.take_length] + by_cases ha : a ∈ S + · exact encodedFun_enc ha + · rw [encodedFun_enc_of_notMem ha, h a ha] + simp only [step, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, hend, + reduceDIte, dite_eq_ite, ite_self, hdec] + exact Cfg.ext_zero_tapes rfl (by simp) (by simp) + · -- the prefix read so far cannot be extended, so the machine emits the default output + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + have hnotmem : (encIn a).take (j + 1) ∉ encPrefixes encIn S := + Nat.findGreatest_is_greatest (hjdef ▸ Nat.lt_succ_self j) (by omega) + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∉ encPrefixes encIn S := by + grind [List.take_concat_get'] + have ha : a ∉ S := fun ha => hnotmem (mem_encPrefixes ha ((encIn a).take_prefix _)) + have hstart : 1 + j ≠ 0 := by omega + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat, moveInputPos_zero] + refine Cfg.ext_zero_tapes ?_ (by simp) (by simp) + simp only [Option.some.injEq, Sum.inr.injEq, Subtype.mk.injEq] + exact (h a ha).symm + +/-- The machine `almostConstTM` computes `f` in at most `almostConstTime` steps and no space. -/ +lemma computesFunInTimeAndSpace_almostConstTM (h : ∀ a ∉ S, encOut (f a) = out) : + ComputesFunInTimeAndSpace (almostConstTM encIn encOut f S out) encIn encOut f + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := by + intro a + obtain ⟨j, hjle, hj, hrun⟩ := reaches_write h a + have hhalt := (almostConstTM encIn encOut f S out).runFrom_add + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) ((encOut (f a)).length + 1) + rw [hrun, runFrom_write_halted] at hhalt + use j + 1 + ((encOut (f a)).length + 1) + refine ⟨?_, 0, le_rfl, ?_⟩ + · change j + 1 + ((encOut (f a)).length + 1) ≤ almostConstTime encIn encOut f S out + rw [almostConstTime] + omega + · unfold ComputesInTimeAndSpace + rw [hhalt] + simp + +end AlmostConstFun + +section Results + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + +/-- Every function whose encoded output is constant outside of a finite set is computable in time +`almostConstTime` and zero space. -/ +public theorem computableInTimeAndSpace_almostConstTime + (f : α → β) (S : Finset α) (out : List Bool) (h : ∀ a ∉ S, encOut (f a) = out) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := + ⟨0, AlmostConstState encIn encOut f S out, inferInstance, almostConstTM encIn encOut f S out, + computesFunInTimeAndSpace_almostConstTM h⟩ + +/-- Every almost constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_exists_finite_ne + {f : α → β} (h : ∃ b : β, {a : α | f a ≠ b}.Finite) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := by + obtain ⟨b, hb⟩ := h + refine ⟨_, computableInTimeAndSpace_almostConstTime f hb.toFinset (encOut b) ?_⟩ + intro a ha + simp only [Set.Finite.mem_toFinset, Set.mem_ofPred_eq, not_not] at ha + rw [ha] + +/-- Every constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_const {α β : Type*} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (b : β) : + ∃ c, ComputableInTimeAndSpace (Function.const α b) encIn encOut + (fun _ => c) (fun _ => 0) := + computableInTimeAndSpace_of_exists_finite_ne ⟨b, by simp⟩ + +/-- A constant time bound for functions on a finite type. -/ +public noncomputable def finiteFunTime {α β : Type*} [Finite α] (encIn : α ↪ List Bool) + (encOut : β ↪ List Bool) (f : α → β) : ℕ := + haveI := Fintype.ofFinite α + almostConstTime encIn encOut f Finset.univ [] + +/-- Every function on a finite type is computable in time `finiteFunTime` and zero space. -/ +public theorem computableInTimeAndSpace_finiteFunTime {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (f : α → β) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => finiteFunTime encIn encOut f) (fun _ => 0) := + computableInTimeAndSpace_almostConstTime f (@Finset.univ α (Fintype.ofFinite α)) [] + fun a ha => absurd (@Finset.mem_univ α (Fintype.ofFinite α) a) ha + +/-- Every function on a finite type is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_finite {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + (f : α → β) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := + ⟨_, computableInTimeAndSpace_finiteFunTime f⟩ + +end Results + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean new file mode 100644 index 000000000..38e8f5b97 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of the identity function + +A machine with a single state and no work tapes scans the input from left to right, copying each +symbol to the output tape, and halts on the blank at the right end of the input. On input `w` it +outputs `w` after `w.length + 1` steps, and having no work tapes it uses zero space. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_id`: the identity is computable in one step per + input symbol and zero space. +-/ + +namespace Turing.MultiTapeTM + +variable {Symbol : Type*} {input : List Symbol} + +/-- The copy machine: a single state and no work tapes. It copies every input symbol to the output +tape while moving right, and halts on reading the blank at the right end of the input. -/ +def copy : MultiTapeTM 0 Symbol Unit where + q₀ := () + tr _ s _ := + match s with + | some b => { inputTape := 1, workTapes := fun i => i.elim0, output := some b, + state := some () } + | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } + +namespace Copy + +/-- A configuration of the copy machine, given by the input, the control state, the input head +position and the output written so far. There are no work tapes. `input` is explicit because it is +inferable only through the expected type: the head position is written as an anonymous +constructor, which pins nothing. -/ +def cfg (input : List Symbol) (q : Option Unit) (p : Fin (input.length + 2)) + (out : List Symbol) : Cfg 0 Symbol Unit input := + ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ + +/-- With no work tapes, configurations are equal as soon as the state, the input position and the +output agree. -/ +lemma cfg_ext {c₁ c₂ : Cfg 0 Symbol Unit input} (hstate : c₁.state = c₂.state) + (hpos : c₁.inputPos = c₂.inputPos) (hout : c₁.output = c₂.output) : c₁ = c₂ := + Cfg.ext hstate hpos (funext fun i => i.elim0) (funext fun i => i.elim0) hout + +/-- Over an input symbol, the copy machine emits it and moves right. -/ +lemma step_scan {n : ℕ} (hn : n < input.length) (out : List Symbol) : + copy.step (cfg input (some ()) ⟨n + 1, by omega⟩ out) = + cfg input (some ()) ⟨n + 2, by omega⟩ (out ++ [input[n]]) := by + have hsym : (cfg input (some ()) ⟨n + 1, by omega⟩ out).inputSymbol = + some input[n] := inputSymbolInner n (by simp only [cfg]; omega) hn + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + refine cfg_ext rfl ?_ rfl + apply Fin.ext + simp [copy, Action.apply, moveInputPos] + grind + +/-- On the blank at the right end of the input, the copy machine halts in place. -/ +lemma step_halt (out : List Symbol) : + copy.step (cfg input (some ()) ⟨input.length + 1, by omega⟩ out) = + cfg input none ⟨input.length + 1, by omega⟩ out := by + have hsym : (cfg input (some ()) ⟨input.length + 1, by omega⟩ out).inputSymbol = + none := + inputSymbol_eq_none_of_boundary (Or.inr rfl) + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + exact cfg_ext rfl (by simp [copy, Action.apply]) (by simp [copy, Action.apply]) + +/-- After `n ≤ input.length` steps, the copy machine has copied the first `n` input symbols to the +output and its head is over the `n`-th cell of the input. -/ +lemma runFrom_scan (n : ℕ) (hn : n ≤ input.length) : + copy.runFrom (copy.initCfg input) n = + cfg input (some ()) ⟨n + 1, by omega⟩ (input.take n) := by + induction n with + | zero => exact cfg_ext rfl rfl rfl + | succ n ih => + rw [runFrom_succ_eq_step', ih (by omega), step_scan (by omega)] + have htake : input.take n ++ [input[n]] = input.take (n + 1) := by + rw [List.take_add_one, List.getElem?_eq_getElem (by omega), Option.toList_some] + rw [htake] + +/-- The complete run: after `input.length + 1` steps the copy machine has halted with the input +copied to the output. -/ +lemma runFrom_full (input : List Symbol) : + copy.runFrom (copy.initCfg input) (input.length + 1) = + cfg input none ⟨input.length + 1, by omega⟩ input := by + rw [runFrom_succ_eq_step', runFrom_scan input.length le_rfl, List.take_length, step_halt] + +/-- The copy machine outputs its input unchanged, in `input.length + 1` steps and zero space. -/ +theorem computesInTimeAndSpace (input : List Symbol) : + ComputesInTimeAndSpace copy input input (input.length + 1) 0 := + ⟨by rw [runFrom_full]; rfl, by rw [runFrom_full]; rfl, + copy.spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ + +end Copy + +variable {α : Type*} + +/-- The identity function is computable in one step per input symbol and zero space. -/ +public theorem computableInTimeAndSpace_id {enc : α ↪ List Bool} : + ComputableInTimeAndSpace (id : α → α) enc enc + (fun a => (enc a).length + 1) (fun _ => 0) := + ⟨0, Unit, inferInstance, copy, fun a => + ⟨(enc a).length + 1, le_rfl, 0, le_rfl, Copy.computesInTimeAndSpace (enc a)⟩⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean new file mode 100644 index 000000000..08bb3e48f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean @@ -0,0 +1,798 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Mathlib.Basic.Finite.Sum +public import Mathlib.Data.PFun +public import Mathlib.Tactic.Ring +public import Mathlib.Computability.StateTransition +public import Cslib.Computability.Machines.Turing.MultiTape.Encodings.Option +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Loop combinator + +This file is about the loop whose condition and body are fused into a single function +`body : α → Option α`, which returns `none` exactly when the loop is to stop: + +``` +loop + match body a with + | none => return a + | some a' => a := a' +``` + +This is the form in which the loop is implemented by a machine, since it needs only one machine for +the whole loop body. The usual `while` loop, with a separate condition and body, is derived from it +in `Cslib.Computability.Machines.Turing.MultiTape.Combinators.While`. + +## Main definitions + +* `Turing.MultiTapeTM.loopFunction`: the partial function computed by the loop, defined as + `StateTransition.eval` of the loop body. It is undefined on the inputs for which the loop + diverges. +* `Turing.MultiTapeTM.loopIterate`: the value after a given number of iterations, or `none` if the + loop has already stopped. + +## Main results + +* `Turing.MultiTapeTM.mem_loopFunction_iff`: the loop started at `a` terminates in `b` exactly if + `b` is an iterate of `a` at which the body stops. +* `Turing.MultiTapeTM.computableInTimeAndSpace_loopFunction`: the complexity of the loop. +-/ + +namespace Turing.MultiTapeTM + +variable {α : Type*} + +/-- The partial function computed by the loop with the fused body `body`, which returns `none` +exactly when the loop is to stop. It is defined exactly on the inputs for which the loop +terminates. -/ +@[expose] public def loopFunction (body : α → Option α) : α →. α := StateTransition.eval body + +/-- The value after `n` iterations of the fused loop body, or `none` if the loop has stopped +after at most `n` iterations. -/ +@[expose] public def loopIterate (body : α → Option α) : ℕ → α → Option α + | 0, a => some a + | n + 1, a => (body a).bind (loopIterate body n) + +section Iterate + +/-! ## The iterates of the loop body + +The loop is described by two views of its body: `loopIterate`, which is what the machine actually +runs through, and `loopFunction`, which is what it computes. This section relates them. +-/ + +variable {body : α → Option α} + +@[simp] +public lemma loopIterate_zero (a : α) : loopIterate body 0 a = some a := rfl + +public lemma loopIterate_succ (n : ℕ) (a : α) : + loopIterate body (n + 1) a = (body a).bind (loopIterate body n) := rfl + +@[simp] +public lemma loopIterate_one (a : α) : loopIterate body 1 a = body a := by + cases h : body a <;> simp [loopIterate_succ, h] + +/-- The iterates of the loop body compose. -/ +public lemma loopIterate_add (m n : ℕ) (a : α) : + loopIterate body (m + n) a = (loopIterate body m a).bind (loopIterate body n) := by + induction m generalizing a with + | zero => simp + | succ m ih => + cases h : body a with + | none => simp [show m + 1 + n = m + n + 1 by omega, loopIterate_succ, h] + | some b => simp [show m + 1 + n = m + n + 1 by omega, loopIterate_succ, h, ih] + +/-- One more iteration can also be performed at the end. -/ +public lemma loopIterate_succ' (n : ℕ) (a : α) : + loopIterate body (n + 1) a = (loopIterate body n a).bind body := by + rw [loopIterate_add] + simp + +/-- Once the loop has stopped it stays stopped. -/ +public lemma loopIterate_eq_none_of_le {m n : ℕ} {a : α} (h : m ≤ n) + (hm : loopIterate body m a = none) : loopIterate body n a = none := by + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le h + rw [loopIterate_add, hm] + rfl + +/-- Before the loop has stopped it has not stopped. -/ +public lemma loopIterate_ne_none_of_le {m n : ℕ} {a : α} (h : m ≤ n) + (hn : loopIterate body n a ≠ none) : loopIterate body m a ≠ none := + fun hm => hn (loopIterate_eq_none_of_le h hm) + +/-- As long as the loop has not stopped, each iterate is obtained from the previous one by a +successful call of the body. -/ +public lemma loopIterate_succ_of_lt {m n : ℕ} {a x : α} (hn : n < m) + (hm : loopIterate body m a ≠ none) (hx : loopIterate body n a = some x) : + ∃ x', body x = some x' ∧ loopIterate body (n + 1) a = some x' := by + have heq : loopIterate body (n + 1) a = body x := by rw [loopIterate_succ', hx]; simp + have hne : body x ≠ none := heq ▸ loopIterate_ne_none_of_le hn hm + obtain ⟨x', hx'⟩ := Option.ne_none_iff_exists'.mp hne + exact ⟨x', hx', by rw [heq, hx']⟩ + +/-- The values reachable by repeatedly applying the loop body are exactly its iterates. -/ +public lemma reaches_iff_loopIterate {a b : α} : + Relation.ReflTransGen (fun x y => y ∈ body x) a b ↔ ∃ n, loopIterate body n a = some b := by + constructor + · intro h + induction h using Relation.ReflTransGen.head_induction_on with + | refl => exact ⟨0, rfl⟩ + | head hstep _ ih => + obtain ⟨n, hn⟩ := ih + exact ⟨n + 1, by rw [loopIterate_succ, Option.mem_def.mp hstep]; exact hn⟩ + · rintro ⟨n, hn⟩ + induction n generalizing a with + | zero => + rw [loopIterate_zero, Option.some_inj] at hn + exact hn ▸ Relation.ReflTransGen.refl + | succ n ih => + rw [loopIterate_succ] at hn + cases hc : body a with + | none => rw [hc] at hn; simp at hn + | some c => + rw [hc] at hn + exact Relation.ReflTransGen.head (Option.mem_def.mpr hc) (ih hn) + +/-- **The graph of `loopFunction`.** The loop started at `a` terminates in `b` exactly if `b` is an +iterate of `a` at which the body stops. -/ +public theorem mem_loopFunction_iff {a b : α} : + b ∈ loopFunction body a ↔ ∃ n, loopIterate body n a = some b ∧ body b = none := by + rw [loopFunction, StateTransition.mem_eval, StateTransition.Reaches, reaches_iff_loopIterate] + exact ⟨fun ⟨⟨n, hn⟩, hb⟩ => ⟨n, hn, hb⟩, fun ⟨n, hn, hb⟩ => ⟨⟨n, hn⟩, hb⟩⟩ + +end Iterate + +section Bounds + +/-! ## Arithmetic helpers + +Every machine that the loop is assembled from costs a constant times the sum of a few lengths, and +every one of those lengths is bounded by a constant times `s a + 1` or `t a + s a + 1`. These +lemmas turn such a sum into a single constant times the bound. -/ + +private lemma nat_bound₀ {W u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) : X + 1 ≤ (W + 1) * u := by + calc X + 1 ≤ W * u + u := Nat.add_le_add hX hu + _ = (W + 1) * u := by ring + +private lemma nat_bound₁ {c W u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) : + c * (X + 1) ≤ c * (W + 1) * u := by + calc c * (X + 1) ≤ c * (W * u + u) := by gcongr + _ = c * (W + 1) * u := by ring + +private lemma nat_bound₂ {c W u X Y : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) (hY : Y ≤ W * u) : + c * (X + Y + 1) ≤ c * (2 * W + 1) * u := by + calc c * (X + Y + 1) ≤ c * (W * u + W * u + u) := by gcongr + _ = c * (2 * W + 1) * u := by ring + +private lemma nat_bound₃ {c W u X Y Z : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) (hY : Y ≤ W * u) + (hZ : Z ≤ W * u) : c * (X + Y + Z + 1) ≤ c * (3 * W + 1) * u := by + calc c * (X + Y + Z + 1) ≤ c * (W * u + W * u + W * u + u) := by gcongr + _ = c * (3 * W + 1) * u := by ring + +/-- A constant summand is absorbed into the constant factor. -/ +private lemma nat_bound_add {c d u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ c * u) : X + d ≤ (c + d) * u := by + calc X + d ≤ c * u + d * u := by gcongr; exact Nat.le_mul_of_pos_right d (by omega) + _ = (c + d) * u := by ring + +end Bounds + +section TapeWords + +/-! ## The vector of words on three named tapes + +Every configuration the loop machine passes through is blank outside of three named work tapes; +`tapeWords` is the vector of words of such a configuration. The tape-transformer machines return +whole vectors — their postconditions are equalities — so the projection, blankness and +`Function.update` equations here are all that is needed to glue the steps of the loop. -/ + +variable {K : ℕ} + +/-- The vector of words that holds `w₁`, `w₂` and `w₃` on the tapes `i₁`, `i₂` and `i₃` and is +blank everywhere else. -/ +private def tapeWords (i₁ i₂ i₃ : Fin K) (w₁ w₂ w₃ : List Bool) : Fin K → List Bool := + fun l => if l = i₁ then w₁ else if l = i₂ then w₂ else if l = i₃ then w₃ else [] + +variable {i₁ i₂ i₃ : Fin K} {w₁ w₂ w₃ w : List Bool} + +private lemma tapeWords_fst : tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₁ = w₁ := by + simp [tapeWords] + +private lemma tapeWords_snd (h₁₂ : i₁ ≠ i₂) : tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₂ = w₂ := by + simp [tapeWords, Ne.symm h₁₂] + +private lemma tapeWords_thd (h₁₃ : i₁ ≠ i₃) (h₂₃ : i₂ ≠ i₃) : + tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₃ = w₃ := by + simp [tapeWords, Ne.symm h₁₃, Ne.symm h₂₃] + +private lemma tapeWords_of_ne_fst {l : Fin K} (h₁ : l ≠ i₁) : + tapeWords i₁ i₂ i₃ w₁ [] [] l = [] := by + simp [tapeWords, h₁] + +private lemma tapeWords_of_ne_snd {l : Fin K} (h₂ : l ≠ i₂) : + tapeWords i₁ i₂ i₃ [] w₂ [] l = [] := by + simp [tapeWords, h₂] + +private lemma tapeWords_of_ne_fst_snd {l : Fin K} (h₁ : l ≠ i₁) (h₂ : l ≠ i₂) : + tapeWords i₁ i₂ i₃ w₁ w₂ [] l = [] := by + simp [tapeWords, h₁, h₂] + +private lemma update_tapeWords_fst : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₁ w = tapeWords i₁ i₂ i₃ w w₂ w₃ := by + funext l + by_cases h : l = i₁ + · subst h; rw [Function.update_self, tapeWords_fst] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +private lemma update_tapeWords_snd (h₁₂ : i₁ ≠ i₂) : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₂ w = tapeWords i₁ i₂ i₃ w₁ w w₃ := by + funext l + by_cases h : l = i₂ + · subst h; rw [Function.update_self, tapeWords_snd h₁₂] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +private lemma update_tapeWords_thd (h₁₃ : i₁ ≠ i₃) (h₂₃ : i₂ ≠ i₃) : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₃ w = tapeWords i₁ i₂ i₃ w₁ w₂ w := by + funext l + by_cases h : l = i₃ + · subst h; rw [Function.update_self, tapeWords_thd h₁₃ h₂₃] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +end TapeWords + +-- The `Finite` instances of the machines that are combined are produced by `obtain`, so they have +-- to be registered as instances with `haveI` even though the goal is a proposition. +set_option linter.style.haveILetI false in +/-- **Complexity of a loop.** + +Assume that +* `f` picks, for every input, a value at which the loop terminates (`hf`), and the loop started at + `a` stops after at most `iterBound a` iterations (`hiter`); +* the loop body is computable in time `t` and space `s` (`hbody`), where `s` also bounds the + encoded length of all the values encountered while running the loop (`hsize`, which includes `a` + itself); +* these bounds do not increase along the iterations of the loop (`ht`, `hs`). + +Then `f` is computable in time proportional to the number of iterations times the cost of one +iteration, and in space proportional to the space of one iteration. + +The machine uses three named work tapes, `T1` holding the current value, `T3` holding the result of +the last call of the body and `T4` holding the flag that says whether the loop is over, plus the +scratch tapes of the machines it runs, which `exists_transformsTapes_ofComputable` hides. It first +copies its input onto `T1` and runs the machine for `body` with `T1` as its input tape and `T3` as +its output tape. Then it repeats: run the machine for `Option.isNone` on `T3`, writing the flag to +`T4`, and branch on the flag; if the loop is over, stop, so that the contents of `T1` can be +emitted; otherwise clear `T4`, clear `T1`, run the destructor of `some` with `T3` as its input and +`T1` as its output, clear `T3` and run the body again with `T1` as its input and `T3` as its +output. + +Note that `T1` has to be kept until the result of the body has been inspected, since on exit the +result of the loop is the value that was fed to the last call of the body. Copying the input onto +`T1` before the first call of the body costs only `O(s a)`, since `hsize` bounds the length of the +encoded input. + +The space bound of the body alone does not bound the encoded length of the intermediate values: the +input tape is read-only and the output tape is append-only, so neither counts towards the space +bound, and a machine can produce an output much longer than the space it uses. The intermediate +values, however, are stored on a work tape, and hence `hsize` is a genuine additional assumption on +`s`. Since the resulting bounds are stated up to a constant factor, using a single `s` for both +purposes is no weaker than using two separate bounds, whose maximum `s` can be taken to be. -/ +public theorem computableInTimeAndSpace_loopFunction + {α : Type*} {body : α → Option α} {f : α → α} + {enc : α ↪ List Bool} {encOpt : Option α ↪ List Bool} {t s iterBound : α → ℕ} + (henc : IsOptionEncoding enc encOpt) + (hf : ∀ a, f a ∈ loopFunction body a) + (hiter : ∀ a, ∃ m ≤ iterBound a, loopIterate body m a = none) + (hsize : ∀ a m x, loopIterate body m a = some x → (enc x).length ≤ s a) + (hbody : ComputableInTimeAndSpace body enc encOpt t s) + (ht : ∀ a m x, loopIterate body m a = some x → t x ≤ t a) + (hs : ∀ a m x, loopIterate body m a = some x → s x ≤ s a) : + ∃ c, ComputableInTimeAndSpace f enc enc + (fun a => c * (iterBound a + 1) * (t a + s a + 1)) + (fun a => c * (s a + 1)) := by + classical + -- ### The number of iterations + -- `N a` is the number of iterations after which the loop started at `a` stops, and `f a` is the + -- value it stops at. + have hkey : ∀ a, ∃ n, loopIterate body n a = some (f a) ∧ body (f a) = none := + fun a => mem_loopFunction_iff.mp (hf a) + choose N hN hNstop using hkey + have hNle : ∀ a, N a + 1 ≤ iterBound a := by + intro a + obtain ⟨m, hm, hmnone⟩ := hiter a + have hlt : N a < m := by + by_contra hcon + have hcontra := loopIterate_eq_none_of_le (Nat.le_of_not_lt hcon) hmnone + rw [hN a] at hcontra + simp at hcontra + omega + -- every round before `N a` produces the value the next one starts at + have hnext : ∀ a n, n < N a → ∀ x, loopIterate body n a = some x → + ∃ x', body x = some x' ∧ loopIterate body (n + 1) a = some x' := + fun a n hn x hx => loopIterate_succ_of_lt hn + (by rw [hN a]; exact Option.some_ne_none _) hx + -- ### The encoding of the loop flag + obtain ⟨encBool, hencBoolHead, hencBoolLen⟩ : + ∃ e : Bool ↪ List Bool, (∀ b, (e b).head? = some b) ∧ ∀ b, (e b).length = 1 := + ⟨⟨fun b => [b], fun b₁ b₂ h => by simpa using h⟩, fun _ => rfl, fun _ => rfl⟩ + -- ### Lengths of the encodings encountered along the loop + obtain ⟨cc, hcc⟩ := henc.constructor_computable + have hccLen : ∀ x : α, (encOpt (some x)).length ≤ cc * ((enc x).length + 1) := + hcc.length_encOut_le + obtain ⟨E, hE⟩ : ∃ E, ∀ a n x, loopIterate body n a = some x → + (encOpt (body x)).length ≤ E * (s a + 1) := by + refine ⟨cc + (encOpt none).length, fun a n x hx => ?_⟩ + rcases hb : body x with _ | x' + · calc (encOpt none).length ≤ cc + (encOpt none).length := Nat.le_add_left _ _ + _ ≤ (cc + (encOpt none).length) * (s a + 1) := + Nat.le_mul_of_pos_right _ (Nat.succ_pos _) + · have hx' : loopIterate body (n + 1) a = some x' := by + rw [loopIterate_succ', hx]; simpa using hb + calc (encOpt (some x')).length ≤ cc * ((enc x').length + 1) := hccLen x' + _ ≤ cc * (s a + 1) := Nat.mul_le_mul_left _ (by have := hsize a (n + 1) x' hx'; omega) + _ ≤ (cc + (encOpt none).length) * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The machines the loop is assembled from + obtain ⟨cd, hd⟩ := henc.destructor_computable + obtain ⟨cn, hisNone⟩ := + computableInTimeAndSpace_isNone (α := α) (encOpt := encOpt) (encBool := encBool) + obtain ⟨ci, hid⟩ : ∃ c, ComputableInTimeAndSpace (id : α → α) enc enc + (fun a => c * ((enc a).length + 1)) (fun _ => 0) := + ⟨1, computableInTimeAndSpace_id.mono (fun a => (one_mul _).symm.le) (fun _ => le_rfl)⟩ + obtain ⟨mB, cB, hB⟩ := exists_transformsTapes_ofComputable hbody + obtain ⟨mD, cD, hD⟩ := exists_transformsTapes_ofComputable hd + obtain ⟨mN, cN, hNm⟩ := exists_transformsTapes_ofComputable hisNone + obtain ⟨mI, cI, hI⟩ := exists_transformsTapes_ofComputableInput hid + -- the tape layout: `T1` the current value, `T3` the result of the body, `T4` the flag + obtain ⟨K, T1, T3, T4, hT13, hT14, hT34, hKB, hKD, hKN, hKI⟩ : + ∃ (K : ℕ) (T1 T3 T4 : Fin K), T1 ≠ T3 ∧ T1 ≠ T4 ∧ T3 ≠ T4 ∧ + mB + 2 ≤ K ∧ mD + 2 ≤ K ∧ mN + 3 ≤ K ∧ mI + 1 ≤ K := + ⟨mB + mD + mN + mI + 5, ⟨0, by omega⟩, ⟨1, by omega⟩, ⟨2, by omega⟩, + Fin.ne_of_val_ne (by simp), Fin.ne_of_val_ne (by simp), Fin.ne_of_val_ne (by simp), + by omega, by omega, by omega, by omega⟩ + obtain ⟨SB, hSB, MBody, hMBody⟩ := + hB K T1 T3 ∅ hT13 (by simp) (by simp) (by simpa using hKB) + obtain ⟨SD, hSD, MDestr, hMDestr⟩ := + hD K T3 T1 ∅ (Ne.symm hT13) (by simp) (by simp) (by simpa using hKD) + obtain ⟨SN, hSN, MIsNone, hMIsNone⟩ := + hNm K T3 T4 {T1} hT34 (by simpa using Ne.symm hT13) (by simpa using Ne.symm hT14) + (by simp only [Finset.card_singleton]; omega) + obtain ⟨SI, hSI, MCopy, hMCopy⟩ := hI K T1 ∅ (by simp) (by simpa using hKI) + obtain ⟨cC1, SC1, hSC1, MClear1, hMClear1⟩ := exists_transformsTapes_clear (Symbol := Bool) T1 + obtain ⟨cC3, SC3, hSC3, MClear3, hMClear3⟩ := exists_transformsTapes_clear (Symbol := Bool) T3 + obtain ⟨cC4, SC4, hSC4, MClear4, hMClear4⟩ := exists_transformsTapes_clear (Symbol := Bool) T4 + obtain ⟨SNop, hSNop, MNop, hMNop⟩ := exists_transformsTapes_nop K Bool + haveI := hSB; haveI := hSD; haveI := hSN; haveI := hSI + haveI := hSC1; haveI := hSC3; haveI := hSC4; haveI := hSNop + -- ### One constant bounding every length that occurs + obtain ⟨W, hW1, hWci, hWlen⟩ : ∃ W : ℕ, 1 ≤ W ∧ ci ≤ W ∧ + ∀ a n x, loopIterate body n a = some x → + (enc x).length ≤ W * (s a + 1) ∧ + (encOpt (body x)).length ≤ W * (s a + 1) ∧ + (encOpt (some x)).length ≤ W * (s a + 1) ∧ + cd * ((encOpt (some x)).length + 1) ≤ W * (s a + 1) ∧ + s x ≤ W * (s a + 1) ∧ t x ≤ W * (t a + s a + 1) := by + refine ⟨ci + cc + E + cd * (cc + 1) + 1, by omega, by omega, + fun a n x hx => ⟨?_, ?_, ?_, ?_, ?_, ?_⟩⟩ + · exact le_trans (by have := hsize a n x hx; omega) + (Nat.le_mul_of_pos_left _ (by omega)) + · exact (hE a n x hx).trans (Nat.mul_le_mul_right _ (by omega)) + · exact (hccLen x).trans ((Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega)).trans + (Nat.mul_le_mul_right _ (by omega))) + · have h1 : (encOpt (some x)).length ≤ cc * (s a + 1) := + (hccLen x).trans (Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega)) + calc cd * ((encOpt (some x)).length + 1) + ≤ cd * (cc * (s a + 1) + (s a + 1)) := + Nat.mul_le_mul_left _ (Nat.add_le_add h1 (by omega)) + _ = cd * (cc + 1) * (s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (by omega) + · exact le_trans (by have := hs a n x hx; omega) (Nat.le_mul_of_pos_left _ (by omega)) + · exact le_trans (by have := ht a n x hx; omega) (Nat.le_mul_of_pos_left _ (by omega)) + -- the two units in which the bounds are measured + have hu1 : ∀ a, 1 ≤ t a + s a + 1 := fun a => by omega + have hv1 : ∀ a, 1 ≤ s a + 1 := fun a => by omega + have hvu : ∀ (a : α) (c : ℕ), c * (s a + 1) ≤ c * (t a + s a + 1) := + fun a c => Nat.mul_le_mul_left _ (by omega) + -- ### Descriptions of the tape contents at the various points of a round + -- Every configuration of the loop is a `tapeWords T1 T3 T4` vector, and the machines return + -- whole vectors, so the steps below are glued by rewriting with the equations of `tapeWords`. + -- The predicates are obtained from existentials so that they are unfolded only where intended. + obtain ⟨Pround, hPround⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) []) := ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PMid, hPMid⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PExit, hPExit⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ body y = none ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PCont, hPCont⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y y', loopIterate body n a = some y ∧ body y = some y' ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨QR, hQR⟩ : ∃ Q : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws', Q a n ws' ↔ + ((∀ y, loopIterate body n a = some y → body y = none → + ws' T1 = enc y ∧ (ws' T4).head? = some true) ∧ + (∀ y y', loopIterate body n a = some y → body y = some y' → + ws' = tapeWords T1 T3 T4 (enc y') (encOpt (body y')) [] ∧ + (ws' T4).head? ≠ some true)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + -- ### Bounds for the individual machines + -- Every length occurring in the bound of a machine of a round is bounded by `W * (s a + 1)`, + -- hence its time by a constant times `t a + s a + 1` and its space by a constant times `s a + 1`. + have hWt : ∀ a n x, loopIterate body n a = some x → + (enc x).length ≤ W * (t a + s a + 1) ∧ + (encOpt (body x)).length ≤ W * (t a + s a + 1) ∧ + (encOpt (some x)).length ≤ W * (t a + s a + 1) ∧ + cd * ((encOpt (some x)).length + 1) ≤ W * (t a + s a + 1) ∧ + s x ≤ W * (t a + s a + 1) ∧ t x ≤ W * (t a + s a + 1) := by + intro a n x hx + obtain ⟨h1, h2, h3, h4, h5, h6⟩ := hWlen a n x hx + exact ⟨h1.trans (hvu a W), h2.trans (hvu a W), h3.trans (hvu a W), h4.trans (hvu a W), + h5.trans (hvu a W), h6⟩ + have hcW : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (t a + s a + 1) := fun c a hc => + hc.trans (Nat.le_mul_of_pos_right _ (by omega)) + have hcWv : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (s a + 1) := fun c a hc => + hc.trans (Nat.le_mul_of_pos_right _ (by omega)) + obtain ⟨A1, hA1⟩ : ∃ c, ∀ a : α, cN * (cn + 1) ≤ c * (t a + s a + 1) := + ⟨cN * (cn + 1), fun a => Nat.le_mul_of_pos_right _ (by omega)⟩ + obtain ⟨A2, hA2⟩ : ∃ c, ∀ (a : α) (b : Bool), + cC4 * ((encBool b).length + 1) ≤ c * (t a + s a + 1) := by + refine ⟨cC4 * (W + 1), fun a b => ?_⟩ + rw [hencBoolLen] + exact nat_bound₁ (hu1 a) (hcW 1 a hW1) + obtain ⟨A3, hA3⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cC1 * ((enc x).length + 1) ≤ c * (t a + s a + 1) := + ⟨cC1 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).1⟩ + obtain ⟨A4, hA4⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cD * (cd * ((encOpt (some x)).length + 1) + 1) ≤ c * (t a + s a + 1) := + ⟨cD * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.2.1⟩ + obtain ⟨A5, hA5⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cC3 * ((encOpt (some x)).length + 1) ≤ c * (t a + s a + 1) := + ⟨cC3 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.1⟩ + obtain ⟨A6, hA6⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cB * (t x + 1) ≤ c * (t a + s a + 1) := + ⟨cB * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.2.2.2⟩ + obtain ⟨A7, hA7⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cI * (ci * ((enc x).length + 1) + 1) ≤ c * (t a + s a + 1) := by + refine ⟨cI * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ?_⟩ + calc ci * ((enc x).length + 1) ≤ ci * (s a + 1) := + Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega) + _ ≤ W * (s a + 1) := Nat.mul_le_mul_right _ hWci + _ ≤ W * (t a + s a + 1) := hvu a W + obtain ⟨B1, hB1⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cN * (0 + (encOpt (body x)).length + (encBool (body x).isNone).length + 1) + K + ≤ c * (s a + 1) := by + refine ⟨cN * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) ?_⟩ + rw [hencBoolLen] + exact nat_bound₃ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).2.1 (hcWv 1 a hW1) + obtain ⟨B2, hB2⟩ : ∃ c, ∀ (a : α) (w : List Bool), w.length ≤ W * (s a + 1) → + w.length + 1 + K ≤ c * (s a + 1) := + ⟨W + 1 + K, fun a w hw => nat_bound_add (hv1 a) (nat_bound₀ (hv1 a) hw)⟩ + obtain ⟨B3, hB3⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cD * (0 + (encOpt (some x)).length + (enc x).length + 1) + K ≤ c * (s a + 1) := + ⟨cD * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₃ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).2.2.1 (hWlen a n x hx).1)⟩ + obtain ⟨B4, hB4⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cB * (s x + (enc x).length + (encOpt (body x)).length + 1) + K ≤ c * (s a + 1) := + ⟨cB * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₃ (hv1 a) (hWlen a n x hx).2.2.2.2.1 (hWlen a n x hx).1 + (hWlen a n x hx).2.1)⟩ + obtain ⟨B5, hB5⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cI * (0 + (enc x).length + 1) + K ≤ c * (s a + 1) := + ⟨cI * (2 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₂ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).1)⟩ + -- the cost of one round, and of the whole loop + set A : ℕ := A1 + A2 + A3 + A4 + A5 + A6 + A7 + 1 with hAdef + set B : ℕ := B1 + 3 * B2 + B3 + B4 + B5 + K + 1 with hBdef + -- ### The exit branch: the loop is over, so nothing is left to do + have hExit : ∀ p : α × ℕ, TransformsTapes MNop (fun _ ws => PExit p.1 p.2 ws) + (fun _ _ ws' => QR p.1 p.2 ws') (A * (t p.1 + s p.1 + 1)) (B * (s p.1 + 1)) := by + rintro ⟨a, n⟩ + refine hMNop.imp (fun _ _ _ => trivial) (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · rw [hQ] + obtain ⟨y, hy, hby, hws⟩ := (hPExit a n ws).mp hP + refine (hQR a n ws).mpr ⟨fun z hz _ => ?_, fun z z' hz hbz => ?_⟩ + · rw [hy] at hz + obtain rfl : z = y := (Option.some.inj hz).symm + refine ⟨by rw [hws, tapeWords_fst], ?_⟩ + simp [hws, tapeWords_thd hT14 hT34, hby, hencBoolHead] + · rw [hy] at hz + obtain rfl : z = y := (Option.some.inj hz).symm + rw [hby] at hbz + exact absurd hbz (by simp) + · calc (1 : ℕ) ≤ 1 * (t a + s a + 1) := by omega + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · calc K ≤ K * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The continuation branch: one more iteration of the loop body + have hCont : ∀ p : α × ℕ, TransformsTapes + (MClear4.seq (MClear1.seq (MDestr.seq (MClear3.seq MBody)))) + (fun _ ws => PCont p.1 p.2 ws) (fun _ _ ws' => QR p.1 p.2 ws') + (A * (t p.1 + s p.1 + 1)) (B * (s p.1 + 1)) := by + rintro ⟨a, n⟩ + rcases hit : loopIterate body n a with _ | x + · intro input ws out hP + obtain ⟨y, y', hy, _, _⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + exact absurd hy (by simp) + rcases hb : body x with _ | x' + · intro input ws out hP + obtain ⟨y, y', hy, hby, _⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + rw [hb] at hby + exact absurd hby (by simp) + have hx' : loopIterate body (n + 1) a = some x' := by + rw [loopIterate_succ', hit]; simpa using hb + have hPC : ∀ ws, PCont a n ws → + ws = tapeWords T1 T3 T4 (enc x) (encOpt (body x)) (encBool (body x).isNone) := by + intro ws hP + obtain ⟨y, y', hy, _, hws⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + exact hws + -- clear the flag tape + have step4 : TransformsTapes MClear4 (fun _ ws => PCont a n ws) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x) (encOpt (some x')) []) + (cC4 * ((encBool (body x).isNone).length + 1)) + ((encBool (body x).isNone).length + 1 + K) := + (hMClear4 (encBool (body x).isNone)).imp + (fun _ ws hP => by rw [hPC ws hP, tapeWords_thd hT14 hT34]) + (fun _ ws ws' hP hQ => by + rw [hQ, hPC ws hP, update_tapeWords_thd hT14 hT34, hb]) le_rfl le_rfl + -- clear the tape holding the current value + have step1 : TransformsTapes MClear1 + (fun _ ws => ws = tapeWords T1 T3 T4 (enc x) (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 [] (encOpt (some x')) []) + (cC1 * ((enc x).length + 1)) ((enc x).length + 1 + K) := + (hMClear1 (enc x)).imp (fun _ ws hP => by rw [hP, tapeWords_fst]) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_fst]) le_rfl le_rfl + -- extract the new value from the result of the body + have stepD : TransformsTapes MDestr + (fun _ ws => ws = tapeWords T1 T3 T4 [] (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') (encOpt (some x')) []) + (cD * (cd * ((encOpt (some x')).length + 1) + 1)) + (cD * (0 + (encOpt (some x')).length + (enc x').length + 1) + K) := + (hMDestr x').imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_snd hT13]; simp, + fun l hl3 _ => by rw [hP]; exact tapeWords_of_ne_snd hl3⟩) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_fst]; simp) le_rfl le_rfl + -- clear the tape holding the result of the body + have step3 : TransformsTapes MClear3 + (fun _ ws => ws = tapeWords T1 T3 T4 (enc x') (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') [] []) + (cC3 * ((encOpt (some x')).length + 1)) ((encOpt (some x')).length + 1 + K) := + (hMClear3 (encOpt (some x'))).imp (fun _ ws hP => by rw [hP, tapeWords_snd hT13]) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_snd hT13]) le_rfl le_rfl + -- run the body on the new value + have stepB : TransformsTapes MBody (fun _ ws => ws = tapeWords T1 T3 T4 (enc x') [] []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') (encOpt (body x')) []) + (cB * (t x' + 1)) + (cB * (s x' + (enc x').length + (encOpt (body x')).length + 1) + K) := + (hMBody x').imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_fst], + fun l hl1 _ => by rw [hP]; exact tapeWords_of_ne_fst hl1⟩) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_snd hT13]) le_rfl le_rfl + refine (transformsTapes_seq step4 (transformsTapes_seq step1 (transformsTapes_seq stepD + (transformsTapes_seq step3 stepB (fun _ _ _ _ h => h)) (fun _ _ _ _ h => h)) + (fun _ _ _ _ h => h)) (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · obtain ⟨_, rfl, _, rfl, _, rfl, _, rfl, hfin⟩ := hQ + refine (hQR a n ws').mpr ⟨fun z hz hbz => ?_, fun z z' hz hbz => ?_⟩ + · rw [hit] at hz + obtain rfl : z = x := (Option.some.inj hz).symm + rw [hb] at hbz + exact absurd hbz (by simp) + · rw [hit] at hz + obtain rfl : z = x := (Option.some.inj hz).symm + rw [hb] at hbz + obtain rfl : z' = x' := (Option.some.inj hbz).symm + exact ⟨hfin, by rw [hfin, tapeWords_thd hT14 hT34]; simp⟩ + · have e2 := hA2 a (body x).isNone + have e3 := hA3 a n x hit + have e4 := hA4 a (n + 1) x' hx' + have e5 := hA5 a (n + 1) x' hx' + have e6 := hA6 a (n + 1) x' hx' + calc _ ≤ A2 * (t a + s a + 1) + (A3 * (t a + s a + 1) + (A4 * (t a + s a + 1) + + (A5 * (t a + s a + 1) + A6 * (t a + s a + 1)))) := + Nat.add_le_add e2 (Nat.add_le_add e3 (Nat.add_le_add e4 (Nat.add_le_add e5 e6))) + _ = (A2 + A3 + A4 + A5 + A6) * (t a + s a + 1) := by ring + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · have g2 := hB2 a (encBool (body x).isNone) (by rw [hencBoolLen]; exact hcWv 1 a hW1) + have g3 := hB2 a (enc x) (hWlen a n x hit).1 + have g4 := hB3 a (n + 1) x' hx' + have g5 := hB2 a (encOpt (some x')) (hWlen a (n + 1) x' hx').2.2.1 + have g6 := hB4 a (n + 1) x' hx' + calc _ ≤ B2 * (s a + 1) + (B2 * (s a + 1) + (B3 * (s a + 1) + + (B2 * (s a + 1) + B4 * (s a + 1)))) := + Nat.add_le_add g2 (Nat.add_le_add g3 (Nat.add_le_add g4 (Nat.add_le_add g5 g6))) + _ = (B2 + B2 + B3 + B2 + B4) * (s a + 1) := by ring + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### One round: compute the flag on `T4` and branch on it + obtain ⟨SBr, hSBr, MBranch, hMBranch⟩ := + exists_transformsTapes_branch (J := α × ℕ) T4 true + (P₁ := fun p _ ws => PExit p.1 p.2 ws) (P₂ := fun p _ ws => PCont p.1 p.2 ws) + (Q := fun p _ _ ws' => QR p.1 p.2 ws') + (t₁ := fun p => A * (t p.1 + s p.1 + 1)) (s₁ := fun p => B * (s p.1 + 1)) + (t₂ := fun p => A * (t p.1 + s p.1 + 1)) (s₂ := fun p => B * (s p.1 + 1)) hExit hCont + haveI := hSBr + set A' : ℕ := A1 + A + 1 with hA'def + set B' : ℕ := B1 + B + K + 1 with hB'def + have hRound : ∀ (a : α) (n : ℕ), TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a n ws) (fun _ _ ws' => QR a n ws') + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a n + rcases hit : loopIterate body n a with _ | x + · intro input ws out hP + obtain ⟨y, hy, _⟩ := (hPround a n ws).mp hP + rw [hit] at hy + exact absurd hy (by simp) + have hPr : ∀ ws, Pround a n ws → ws = tapeWords T1 T3 T4 (enc x) (encOpt (body x)) [] := by + intro ws hP + obtain ⟨y, hy, hws⟩ := (hPround a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + exact hws + have stepN : TransformsTapes MIsNone (fun _ ws => Pround a n ws) + (fun _ _ ws' => PMid a n ws') + (cN * (cn + 1)) + (cN * (0 + (encOpt (body x)).length + (encBool (body x).isNone).length + 1) + K) := + (hMIsNone (body x)).imp + (fun _ ws hP => ⟨by rw [hPr ws hP, tapeWords_snd hT13], + fun l hl3 hl1 => by + rw [hPr ws hP]; exact tapeWords_of_ne_fst_snd (by simpa using hl1) hl3⟩) + (fun _ ws ws' hP hQ => + (hPMid a n ws').mpr ⟨x, hit, by + rw [hQ, hPr ws hP, update_tapeWords_thd hT14 hT34]⟩) le_rfl le_rfl + refine (transformsTapes_seq stepN (hMBranch (a, n)) (fun _ ws ws' hP hQ => ?_)).imp + (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · -- the flag decides which branch is taken + obtain ⟨y, hy, hws⟩ := (hPMid a n ws').mp hQ + by_cases hflag : (ws' T4).head? = some true + · rw [ite_eq_left hflag] + rw [hws, tapeWords_thd hT14 hT34, hencBoolHead] at hflag + exact (hPExit a n ws').mpr ⟨y, hy, by simpa using hflag, hws⟩ + · rw [ite_eq_right hflag] + rcases hby : body y with _ | y' + · exact absurd (by simp [hws, tapeWords_thd hT14 hT34, hby, hencBoolHead]) hflag + · exact (hPCont a n ws').mpr ⟨y, y', hy, hby, hws⟩ + · obtain ⟨w1, -, h2⟩ := hQ + exact h2 + · simp only [max_self] + have e1 := hA1 a + calc _ ≤ A1 * (t a + s a + 1) + (A * (t a + s a + 1) + 1 * (t a + s a + 1)) := + Nat.add_le_add e1 (Nat.add_le_add le_rfl (by omega)) + _ = (A1 + A + 1) * (t a + s a + 1) := by ring + _ ≤ A' * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · simp only [max_self] + have g1 := hB1 a n x hit + calc _ ≤ B1 * (s a + 1) + (B * (s a + 1) + K * (s a + 1)) := + Nat.add_le_add g1 (Nat.add_le_add le_rfl (Nat.le_mul_of_pos_right _ (by omega))) + _ = (B1 + B + K) * (s a + 1) := by ring + _ ≤ B' * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The loop: repeat the round until the flag says that the loop is over + have hroundOK : ∀ (a : α) (n : ℕ), n < N a → TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a n ws) + (fun _ _ ws' => Pround a (n + 1) ws' ∧ (ws' T4).head? ≠ some true) + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a n hn + refine (hRound a n).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + obtain ⟨y, hy, -⟩ := (hPround a n ws).mp hP + obtain ⟨y', hby, hy'⟩ := hnext a n hn y hy + obtain ⟨-, q2⟩ := (hQR a n ws').mp hQ + obtain ⟨hb', hflag⟩ := q2 y y' hy hby + exact ⟨(hPround a (n + 1) ws').mpr ⟨y', hy', hb'⟩, hflag⟩ + have hstopOK : ∀ a : α, TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a (N a) ws) + (fun _ _ ws' => ws' T1 = enc (f a) ∧ (ws' T4).head? = some true) + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a + refine (hRound a (N a)).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + exact ((hQR a (N a) ws').mp hQ).1 (f a) (hN a) (hNstop a) + obtain ⟨SL, hSL, MLoop, hMLoop⟩ := + exists_transformsTapes_repeat (J := α) T4 true + (P := fun a n _ ws => Pround a n ws) (R := fun a _ ws' => ws' T1 = enc (f a)) + (N := N) (t := fun a => A' * (t a + s a + 1)) (s := fun a => B' * (s a + 1)) + hroundOK hstopOK + haveI := hSL + -- ### The prologue: copy the input onto `T1` and run the body once + have hPro : ∀ a : α, TransformsTapes (MCopy.seq MBody) + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => Pround a 0 ws') (A * (t a + s a + 1)) (B * (s a + 1)) := by + intro a + have s1 : TransformsTapes MCopy (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc a) [] []) + (cI * (ci * ((enc a).length + 1) + 1)) + (cI * (0 + (enc a).length + 1) + K) := by + refine (hMCopy a).imp (fun _ ws hP => ⟨hP.1, fun l _ => hP.2 l⟩) + (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + have hws : ws = tapeWords T1 T3 T4 [] [] [] := by + funext l + rw [hP.2 l] + by_cases h1 : l = T1 + · subst h1; rw [tapeWords_fst] + · rw [tapeWords_of_ne_fst h1] + rw [hQ, hws, update_tapeWords_fst] + simp + have s2 : TransformsTapes MBody (fun _ ws => ws = tapeWords T1 T3 T4 (enc a) [] []) + (fun _ _ ws' => Pround a 0 ws') + (cB * (t a + 1)) + (cB * (s a + (enc a).length + (encOpt (body a)).length + 1) + K) := + (hMBody a).imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_fst], + fun l hl1 _ => by rw [hP]; exact tapeWords_of_ne_fst hl1⟩) + (fun _ ws ws' hP hQ => (hPround a 0 ws').mpr + ⟨a, rfl, by rw [hQ, hP, update_tapeWords_snd hT13]⟩) + le_rfl le_rfl + refine (transformsTapes_seq s1 s2 (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · obtain ⟨w1, -, h2⟩ := hQ + exact h2 + · calc _ ≤ A7 * (t a + s a + 1) + A6 * (t a + s a + 1) := + Nat.add_le_add (hA7 a 0 a rfl) (hA6 a 0 a rfl) + _ = (A7 + A6) * (t a + s a + 1) := by ring + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · calc _ ≤ B5 * (s a + 1) + B4 * (s a + 1) := + Nat.add_le_add (hB5 a 0 a rfl) (hB4 a 0 a rfl) + _ = (B5 + B4) * (s a + 1) := by ring + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The whole machine + have hMain : ∀ a : α, TransformsTapes ((MCopy.seq MBody).seq MLoop) + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' T1 = enc (f a)) + (A * (t a + s a + 1) + (N a + 1) * (A' * (t a + s a + 1) + 1)) + (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K)) := by + intro a + refine (transformsTapes_seq (hPro a) (hMLoop a) (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + obtain ⟨w1, -, h2⟩ := hQ + exact h2 + obtain ⟨c₀, hc₀⟩ := computableInTimeAndSpace_of_transformsTapes T1 hMain + -- ### The final bounds + refine ⟨c₀ * (A + A' + 2) + c₀ * (B + 2 * K * B' + K + 2), hc₀.mono (fun a => ?_) (fun a => ?_)⟩ + · have hl : (enc (f a)).length ≤ s a := hsize a (N a) (f a) (hN a) + have h1 : (N a + 1) * (A' * (t a + s a + 1) + 1) + ≤ iterBound a * ((A' + 1) * (t a + s a + 1)) := by + refine Nat.mul_le_mul (hNle a) ?_ + calc A' * (t a + s a + 1) + 1 ≤ A' * (t a + s a + 1) + (t a + s a + 1) := by omega + _ = (A' + 1) * (t a + s a + 1) := by ring + have hkey : A + iterBound a * (A' + 1) + 2 ≤ (A + A' + 2) * (iterBound a + 1) := by + have hm1 : iterBound a * (A' + 1) ≤ (A + A' + 2) * iterBound a := by + rw [Nat.mul_comm] + exact Nat.mul_le_mul_right _ (by omega) + have hm2 : (A + A' + 2) * (iterBound a + 1) + = (A + A' + 2) * iterBound a + (A + A' + 2) := by ring + omega + calc c₀ * (A * (t a + s a + 1) + (N a + 1) * (A' * (t a + s a + 1) + 1) + + (enc (f a)).length + 1) + ≤ c₀ * (A * (t a + s a + 1) + iterBound a * ((A' + 1) * (t a + s a + 1)) + + (t a + s a + 1) + (t a + s a + 1)) := Nat.mul_le_mul_left _ (by omega) + _ = c₀ * ((A + iterBound a * (A' + 1) + 2) * (t a + s a + 1)) := by ring + _ ≤ c₀ * (((A + A' + 2) * (iterBound a + 1)) * (t a + s a + 1)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ hkey) + _ = c₀ * (A + A' + 2) * (iterBound a + 1) * (t a + s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (Nat.mul_le_mul_right _ (by omega)) + · have hl : (enc (f a)).length ≤ s a := hsize a (N a) (f a) (hN a) + have hK1 : K ≤ K * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + calc c₀ * (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K) + (enc (f a)).length + 1) + ≤ c₀ * (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K * (s a + 1)) + + (s a + 1) + (s a + 1)) := Nat.mul_le_mul_left _ (by omega) + _ = c₀ * (B + 2 * K * B' + K + 2) * (s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (by omega) + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index c68eecd9d..b6a97c150 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -81,6 +81,14 @@ structure Cfg (k : ℕ) (Symbol State : Type*) (input : List Symbol) where output : List Symbol deriving Inhabited +/-- Two configurations with no work tapes are equal when their state, input head and output +agree. -/ +lemma Cfg.ext_zero_tapes {Symbol State : Type*} {input : List Symbol} + {cfg₁ cfg₂ : Cfg 0 Symbol State input} (state : cfg₁.state = cfg₂.state) + (inputPos : cfg₁.inputPos = cfg₂.inputPos) (output : cfg₁.output = cfg₂.output) : + cfg₁ = cfg₂ := + Cfg.ext state inputPos (funext fun i => i.elim0) (funext fun i => i.elim0) output + /-- Attempt to move the input tape head. The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index df5c34846..dc44eb839 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -370,6 +370,31 @@ theorem ComputableInTimeAndSpace.mono {α β : Type*} obtain ⟨k, State, hfinite, tm, htm⟩ := h exact ⟨k, State, hfinite, tm, htm.mono ht hs⟩ +theorem length_output_runFrom_le (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) : + (tm.runFrom cfg t).output.length ≤ cfg.output.length + t := by + induction t with + | zero => simp + | succ t ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + have : (tm.outputSymbol (tm.runFrom cfg t)).toList.length ≤ 1 := by + cases tm.outputSymbol (tm.runFrom cfg t) <;> simp + omega + +/-- A machine emits at most one symbol per step, so the encoded result of a computation is no +longer than its time bound. This is the only bound available on the length of an intermediate +result: a machine can produce an output much longer than the space it uses. -/ +theorem ComputableInTimeAndSpace.length_encOut_le {α β : Type*} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {f : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace f encIn encOut t s) (a : α) : + (encOut (f a)).length ≤ t a := by + obtain ⟨k, State, _, tm, htm⟩ := h + obtain ⟨t', ht', s', _, _, hout, _⟩ := htm a + have hlen := length_output_runFrom_le tm (tm.initCfg (encIn a)) t' + rw [hout] at hlen + have h0 : (tm.initCfg (encIn a)).output.length = 0 := rfl + omega + open Classical in /-- The Boolean indicator function of a set. -/ noncomputable def indicator {α : Type*} (L : Set α) : α → Bool := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean b/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean new file mode 100644 index 000000000..422160ef5 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant + +/-! +# Encodings of `Option` + +A combinator that produces or consumes an `Option` should not prescribe how `Option α` is encoded. +It is enough that the encoding relates to the encoding of `α` in the way one would expect of a +tagged union: the constructor `some` and its destructor are computable in linear time and zero +space, i.e. by streaming the input to the output without using a work tape. + +The constructor is stated as computability of `Option.some` itself. There is no such function for +the destructor, since a total function `Option α → α` would need a junk value at `none`. Instead, +the destructor is stated as computability of the identity of `α`, read at the encoding of `α` +induced by `encOpt` via `some` on the input side and at `enc` on the output side. This says exactly +that the encoding of `some a` can be turned into the encoding of `a`, and says nothing about +encodings of `none`. + +A subtype `{o : Option α // o.isSome}` would be another way of expressing this, but it is not +needed for composability: computability only depends on the bit strings `encIn a` and +`encOut (f a)`, so by `ComputableInTimeAndSpace.congr` a machine computing `body : α → Option α` +is, on the inputs where the result is `some x`, a machine computing `x` at the encoding +`Function.Embedding.some.trans encOpt`, which is exactly the input encoding of the destructor. The +subtype would drag `Subtype.val` embeddings and `isSome` proofs through every statement without +buying anything. + +Testing an encoded value for `none` is *not* a requirement: `fun o => o.isNone` is constant except +at the single argument `none`, so it is computable in constant time and zero space for every +encoding, by `computableInTimeAndSpace_of_exists_finite_ne`. + +## Main definitions + +* `Turing.MultiTapeTM.IsOptionEncoding`: the requirements on an encoding of `Option α` relative to + an encoding of `α`. +* `Turing.MultiTapeTM.encOption`: the canonical encoding of `Option α`, which prefixes the encoding + of the value with a tag bit. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_isNone`: testing for `none` is computable in + constant time and zero space, for every encoding. +* `Turing.MultiTapeTM.isOptionEncoding_encOption`: the canonical encoding satisfies the + requirements. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α : Type*} + +/-- The requirements on an encoding `encOpt` of `Option α`, relative to an encoding `enc` of `α`: +the constructor `some` and its destructor are computable in linear time and zero space. -/ +public structure IsOptionEncoding (enc : α ↪ List Bool) (encOpt : Option α ↪ List Bool) : Prop where + /-- The constructor `some` is computable in linear time and zero space. -/ + constructor_computable : ∃ c, ComputableInTimeAndSpace (Option.some : α → Option α) enc encOpt + (fun a => c * ((enc a).length + 1)) (fun _ => 0) + /-- The destructor of `some` is computable in linear time and zero space. Note that this only + constrains the encodings of values of the form `some a`. -/ + destructor_computable : ∃ c, ComputableInTimeAndSpace (id : α → α) + (Function.Embedding.some.trans encOpt) enc + (fun a => c * ((encOpt (some a)).length + 1)) (fun _ => 0) + +/-- Testing an encoded value for `none` is computable in constant time and zero space, for every +encoding of `Option α`, since the function is constant except at the single argument `none`. -/ +public theorem computableInTimeAndSpace_isNone {encOpt : Option α ↪ List Bool} + {encBool : Bool ↪ List Bool} : + ∃ c, ComputableInTimeAndSpace (fun o : Option α => o.isNone) encOpt encBool + (fun _ => c) (fun _ => 0) := + computableInTimeAndSpace_of_exists_finite_ne ⟨false, + Set.Finite.subset (Set.finite_singleton none) (by rintro (_ | a) ha <;> simp_all)⟩ + +/-- The canonical encoding of `Option α`: a tag bit, followed by the encoding of the value. -/ +public def encOption (enc : α ↪ List Bool) : Option α ↪ List Bool where + toFun + | none => [false] + | some a => true :: enc a + inj' := by rintro (_ | a) (_ | b) h <;> simp_all + +/-- The canonical encoding of `Option α` satisfies the requirements: the constructor emits a `true` +and then copies its input, the destructor drops the `true` and copies the rest. -/ +proof_wanted isOptionEncoding_encOption {enc : α ↪ List Bool} : + IsOptionEncoding enc (encOption enc) + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index e07524c7a..b6200a91c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -395,13 +395,13 @@ public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Ty (o : Fin K) {tm : MultiTapeTM K Bool State} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {gg : α → β} {t s : α → ℕ} (hT : ∀ a, TransformsTapes tm (fun input ws => input = encIn a ∧ ∀ l, ws l = []) - (fun _ ws ws' => ws' = Function.update ws o (encOut (gg a))) (t a) (s a)) : + (fun _ _ ws' => ws' o = encOut (gg a)) (t a) (s a)) : ∃ c, ComputableInTimeAndSpace gg encIn encOut - (fun a => t a + (encOut (gg a)).length + 2) + (fun a => c * (t a + (encOut (gg a)).length + 1)) (fun a => c * (s a + (encOut (gg a)).length + 1)) := by obtain ⟨SE, hSE, tmE, hE⟩ := exists_emitTape (Symbol := Bool) o have := hSE - refine ⟨K + 1, K, State ⊕ SE, inferInstance, tm.seq tmE, fun a => ?_⟩ + refine ⟨K + 2, K, State ⊕ SE, inferInstance, tm.seq tmE, fun a => ?_⟩ -- run the transformer, then emit tape `o` set start := (tm.seq tmE).initCfg (encIn a) with hstart have hstart_words : start = wordsCfg (encIn a) (some (tm.seq tmE).q₀) (fun _ => []) [] := by @@ -422,7 +422,7 @@ public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Ty have ho_tape : c₁.workTapes o = tapeOfList (encOut (gg a)) := by rw [hc1def] change tapeOfList (ws' o) = tapeOfList (encOut (gg a)) - rw [hws', Function.update_self] + rw [hws'] have ho_pos : c₁.workTapePos o = 0 := by rw [hc1def, wordsCfg_workTapePos] -- phase 2: emit tape `o` to the output obtain ⟨u₂, hu₂, h₂act, h₂run, h₂frame⟩ := @@ -446,17 +446,20 @@ public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Ty seq_spec (tm₁ := tm) (tm₂ := tmE) (c := start) (by rw [hstart_words]; rfl) hc1eq' (by rw [hc1def]; rfl) hτ'act hsp1' h₂run rfl h₂act hsp2' refine ⟨τ' + u₂, ?_, (tm.seq tmE).spaceUsed start (τ' + u₂), ?_, ?_, ?_, rfl⟩ - · -- time bound - change τ' + u₂ ≤ t a + (encOut (gg a)).length + 2 - have : u₂ ≤ (encOut (gg a)).length + 2 := hu₂ + · -- time bound: τ'+u₂ ≤ t a+|encOut|+2 ≤ (K+2)·(t a+|encOut|+1) + change τ' + u₂ ≤ (K + 2) * (t a + (encOut (gg a)).length + 1) + have hu : u₂ ≤ (encOut (gg a)).length + 2 := hu₂ + have hτt : τ' ≤ t a := le_trans hτ'le hτ + have hprod2 : 2 * (t a + (encOut (gg a)).length + 1) + ≤ (K + 2) * (t a + (encOut (gg a)).length + 1) := Nat.mul_le_mul_right _ (by omega) omega - · -- space bound: `s a + (|encOut|+1+K) ≤ (K+1)·(s a + |encOut| + 1)` - change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K + 1) * (s a + (encOut (gg a)).length + 1) + · -- space bound: s a + (|encOut|+1+K) ≤ (K+2)·(s a + |encOut| + 1) + change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K + 2) * (s a + (encOut (gg a)).length + 1) refine le_trans hseq_sp ?_ set S := s a + (encOut (gg a)).length + 1 with hSdef - have hexp : (K + 1) * S = S + K * S := by rw [Nat.add_mul, Nat.one_mul, Nat.add_comm] have hKS : K ≤ K * S := Nat.le_mul_of_pos_right K (by omega) - have : s a + ((encOut (gg a)).length + 1 + K) = S + K := by omega + have hexp : (K + 2) * S = K * S + S + S := by rw [Nat.add_mul]; omega + have hrw : s a + ((encOut (gg a)).length + 1 + K) = S + K := by omega omega · -- the run halts rw [hseq_run]; rfl From 245168125034c5d2ac5bfb10334a9e32af0d8aa5 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 09:20:15 +0000 Subject: [PATCH 43/93] refactor(Turing): simplify computableInTimeAndSpace_comp via the adapter layer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Rewrite the composition proof to delegate to the abstractions that the loop combinator introduced, instead of reconstructing them inline. The proof drops from ~250 lines to ~90: * place `f` and `gg` with the general `exists_transformsTapes_ofComputable{,Input}` adapters, so the shared tape layout, scratch tapes and `keep` bookkeeping are hidden — no hand-built `e_f`/`e_g` embeddings or `Fin.castAdd`/`natAdd` arithmetic; * compose them with a one-line handoff on the single shared tape `o1`; * emit through `computableInTimeAndSpace_of_transformsTapes` (now that it takes the single-tape postcondition `ws' o = encOut …`), replacing the inlined emit assembly; * bound the intermediate encoding with `ComputableInTimeAndSpace.length_encOut_le` instead of an ad-hoc induction. `comp` moves below the general adapters it now uses. No change to its statement; still axiom-clean (propext/Classical.choice/Quot.sound), full `--wfail` build and linters pass. Co-Authored-By: Claude Opus 4.8 --- .../MultiTape/NormalForms/Adapters.lean | 346 +++++------------- 1 file changed, 91 insertions(+), 255 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index b6200a91c..dd7adb161 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -586,261 +586,6 @@ public theorem transformsTapes_extendTapes' {k k' : ℕ} {State : Type} rw [hstart] exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) -/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`: run the -machine for `f` (its result on a work tape), then the machine for `gg` reading that tape, then emit. -The two machines are placed on a shared tape layout with the first's output tape identified with the -second's input tape; the first's blank scratch is reused by the second. -/ -public theorem computableInTimeAndSpace_comp - {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} - {tf sf : α → ℕ} {tg sg : β → ℕ} - (hf : ComputableInTimeAndSpace f encA encB tf sf) - (hg : ComputableInTimeAndSpace gg encB encC tg sg) : - ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC - (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) - (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by - classical - -- `M_f` reads the real input and leaves `encB (f a)` on its output tape `o_f`. - obtain ⟨c_f, K_f, o_f, S_f, hS_f, M_f, hM_f⟩ := exists_transformsTapes_ofComputableInput_fixed hf - -- `M_g` reads `encB x` from its input tape `i_g` and leaves `encC (gg x)` on `o_g`. - obtain ⟨c_g, K_g, i_g, o_g, S_g, hS_g, M_g, hio, hM_g⟩ := - exists_transformsTapes_ofComputable_fixed hg - have hfin_f := hS_f - have hfin_g := hS_g - -- The length of `gg`'s output is bounded by its running time. - have hlenC : ∀ x, (encC (gg x)).length ≤ tg x := by - intro x - obtain ⟨kk, SS, hfinSS, tmm, hcomp⟩ := hg - obtain ⟨t', ht', s', hs', hhaltm, houtm, hspm⟩ := hcomp x - have hlen : ∀ d, (tmm.runFrom (tmm.initCfg (encB x)) d).output.length ≤ d := by - intro d - induction d with - | zero => rw [runFrom_zero, initCfg_eq_wordsCfg]; simp - | succ d ih => - rw [runFrom_succ_eq_step', step_output, List.length_append] - have h1 : (tmm.outputSymbol (tmm.runFrom (tmm.initCfg (encB x)) d)).toList.length ≤ 1 := by - cases tmm.outputSymbol (tmm.runFrom (tmm.initCfg (encB x)) d) <;> simp - omega - have hle := hlen t' - rw [houtm] at hle - omega - -- The shared tape layout on `Fin (K_f + K_g)`: `M_f` occupies the first block, `M_g` the second, - -- with `M_g`'s virtual input tape `i_g` identified with `M_f`'s output tape `o_f`. - let e_f : Fin K_f ↪ Fin (K_f + K_g) := Fin.castAddEmb K_g - have e_g_inj : Function.Injective - (fun j : Fin K_g => - if j = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else j.natAdd K_f) := by - intro j₁ j₂ h - dsimp only at h - split_ifs at h with h1 h2 - · rw [h1, h2] - · exfalso - have hv := congrArg Fin.val h - rw [Fin.val_castAdd, Fin.val_natAdd] at hv - have := o_f.isLt; omega - · exfalso - have hv := congrArg Fin.val h - rw [Fin.val_natAdd, Fin.val_castAdd] at hv - have := o_f.isLt; omega - · have hv := congrArg Fin.val h - rw [Fin.val_natAdd, Fin.val_natAdd] at hv - exact Fin.ext (by omega) - let e_g : Fin K_g ↪ Fin (K_f + K_g) := - ⟨fun j => if j = i_g then (o_f.castAdd K_g) else j.natAdd K_f, e_g_inj⟩ - -- `M_g`'s input tape coincides with `M_f`'s output tape. - have hei : (e_g i_g : Fin (K_f + K_g)) = e_f o_f := by - change (if i_g = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else i_g.natAdd K_f) - = o_f.castAdd K_g - rw [ite_eq_left rfl] - -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output. - have hMc : ∀ a, TransformsTapes ((extendTapes M_f e_f).seq (extendTapes M_g e_g)) - (fun input ws => input = encA a ∧ ∀ l, ws l = []) - (fun _ _ ws' => ws' (e_g o_g) = encC (gg (f a))) - (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) - (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g))) := by - intro a - refine (transformsTapes_seq (transformsTapes_extendTapes e_f (hM_f a)) - (transformsTapes_extendTapes e_g (hM_g (f a))) ?_).imp ?_ ?_ le_rfl le_rfl - · -- The handoff: after `M_f`, `M_g`'s precondition holds on the shared layout. - rintro input ws ws' ⟨⟨rfl, hwf⟩, hoff⟩ ⟨hQf1, hQf2⟩ - have hwsblank : ∀ l, ws l = [] := by - intro l - by_cases hl : ∃ j, e_f j = l - · obtain ⟨j, rfl⟩ := hl; exact hwf j - · exact hoff l (fun j hj => hl ⟨j, hj⟩) - refine ⟨⟨?_, ?_⟩, ?_⟩ - · -- `M_g`'s input tape carries `encB (f a)`. - change ws' (e_g i_g) = encB (f a) - rw [hei] - have hk := congrFun hQf1 o_f - simpa using hk - · -- Every other of `M_g`'s tapes is blank. - intro l hl - change ws' (e_g l) = [] - have hne : (e_g l : Fin (K_f + K_g)) = l.natAdd K_f := by - change (if l = i_g then (o_f.castAdd K_g : Fin (K_f + K_g)) else l.natAdd K_f) - = l.natAdd K_f - rw [ite_eq_right hl] - have hout : ∀ j, e_f j ≠ e_g l := by - intro j hj - have h1 : (e_f j).val < K_f := by - change (j.castAdd K_g).val < K_f - rw [Fin.val_castAdd]; exact j.isLt - rw [hj, hne, Fin.val_natAdd] at h1; omega - rw [hQf2 (e_g l) hout, hwsblank] - · -- The tapes outside `M_g`'s layout are blank. - intro l hl - by_cases hlr : ∃ j, e_f j = l - · obtain ⟨j, rfl⟩ := hlr - have hjo : j ≠ o_f := by intro hjeq; subst hjeq; exact hl i_g hei - have hk := congrFun hQf1 j - rw [Function.update_of_ne hjo] at hk - exact hk.trans (hwf j) - · exact (hQf2 l (fun j hj => hlr ⟨j, hj⟩)).trans (hwsblank l) - · -- Precondition: an all-blank input satisfies the lifted `M_f` precondition. - rintro input ws ⟨rfl, hblank⟩ - exact ⟨⟨rfl, fun l => hblank (e_f l)⟩, fun l _ => hblank l⟩ - · -- Postcondition: read the result off `M_g`'s output tape. - rintro input ws ws'' _ ⟨ws', _, hQg⟩ - have hk := congrFun hQg.1 o_g - simpa using hk - -- Append an emit machine to copy the result from `e_g o_g` to the real output tape. - have hbase : ComputableInTimeAndSpace (gg ∘ f) encA encC - (fun a => c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 2) - (fun a => (K_f + K_g + 1) * - (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1)) := by - obtain ⟨SE, hSE, tmE, hE⟩ := exists_emitTape (Symbol := Bool) (e_g o_g) - have := hSE - refine ⟨K_f + K_g, (S_f ⊕ S_g) ⊕ SE, inferInstance, - ((extendTapes M_f e_f).seq (extendTapes M_g e_g)).seq tmE, fun a => ?_⟩ - set tm := (extendTapes M_f e_f).seq (extendTapes M_g e_g) with htm - set start := (tm.seq tmE).initCfg (encA a) with hstart - have hstart_words : start = wordsCfg (encA a) (some (tm.seq tmE).q₀) (fun _ => []) [] := by - rw [hstart, initCfg_eq_wordsCfg] - obtain ⟨τ, hτ, ws', hrun1, hws', hsp1⟩ := - hMc a (encA a) (fun _ => []) [] ⟨rfl, fun _ => rfl⟩ - have hc1eq : tm.runFrom (start.withState (some tm.q₀)) τ = - wordsCfg (encA a) none ws' [] := by - rw [hstart_words]; exact hrun1 - obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := - exists_minimal_halting_time tm (start.withState (some tm.q₀)) τ (by rw [hc1eq]; rfl) - have hc1eq' : tm.runFrom (start.withState (some tm.q₀)) τ' = wordsCfg (encA a) none ws' [] := - (runFrom_eq_of_halt tm _ hτ'le hτ'halt).symm.trans hc1eq - set c₁ := wordsCfg (encA a) (none : Option (S_f ⊕ S_g)) ws' [] with hc1def - have ho_tape : c₁.workTapes (e_g o_g) = tapeOfList (encC (gg (f a))) := by - rw [hc1def] - change tapeOfList (ws' (e_g o_g)) = tapeOfList (encC (gg (f a))) - rw [hws'] - have ho_pos : c₁.workTapePos (e_g o_g) = 0 := by rw [hc1def, wordsCfg_workTapePos] - obtain ⟨u₂, hu₂, h₂act, h₂run, h₂frame⟩ := - hE (encA a) (c₁.withState (some tmE.q₀)) (encC (gg (f a))) rfl ho_tape ho_pos - have hstartws : start.withState (some tm.q₀) = - wordsCfg (encA a) (some tm.q₀) (fun _ => []) [] := by - rw [hstart_words]; rfl - have hsp1' : tm.spaceUsed (start.withState (some tm.q₀)) τ' ≤ - c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) := by - rw [hstartws] - exact le_trans (spaceUsed_mono tm _ hτ'le) hsp1 - have hsp2' : tmE.spaceUsed (c₁.withState (some tmE.q₀)) u₂ ≤ - (encC (gg (f a))).length + 1 + (K_f + K_g) := by - refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmE.q₀)) u₂ (e_g o_g) - 0 ((encC (gg (f a))).length : ℤ) (fun m hm => ⟨(h₂frame m hm).2.2.2.1, - (h₂frame m hm).2.2.2.2⟩) (fun m hm j hj => (h₂frame m hm).2.2.1 j hj)) ?_ - have : ((encC (gg (f a))).length + 1 - (0 : ℤ)).toNat = (encC (gg (f a))).length + 1 := by - omega - omega - obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := - seq_spec (tm₁ := tm) (tm₂ := tmE) (c := start) (by rw [hstart_words]; rfl) - hc1eq' (by rw [hc1def]; rfl) hτ'act hsp1' h₂run rfl h₂act hsp2' - refine ⟨τ' + u₂, ?_, (tm.seq tmE).spaceUsed start (τ' + u₂), ?_, ?_, ?_, rfl⟩ - · -- Time bound. - change τ' + u₂ ≤ c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 2 - have : u₂ ≤ (encC (gg (f a))).length + 2 := hu₂ - omega - · -- Space bound. - change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K_f + K_g + 1) * - (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1) - refine le_trans hseq_sp ?_ - set S := c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1 with hSdef - have hexp : (K_f + K_g + 1) * S = S + (K_f + K_g) * S := by - rw [Nat.add_mul, Nat.one_mul, Nat.add_comm] - have hKS : (K_f + K_g) ≤ (K_f + K_g) * S := Nat.le_mul_of_pos_right _ (by omega) - have hrw : c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + ((encC (gg (f a))).length + 1 + (K_f + K_g)) - = S + (K_f + K_g) := by - rw [hSdef]; omega - omega - · -- The run halts. - rw [hseq_run]; rfl - · -- The output is the encoded result. - rw [hseq_run] - simp only [Cfg.withState_output] - change (c₁.withState (some tmE.q₀)).output ++ encC (gg (f a)) = encC (gg (f a)) - rw [Cfg.withState_output, hc1def, wordsCfg_output, List.nil_append] - -- Relax the bounds to the stated linear form. - refine ⟨(K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3, - hbase.mono ?_ ?_⟩ - · -- Time. - intro a - have hlc : (encC (gg (f a))).length ≤ tg (f a) := hlenC (f a) - have hcf : c_f + c_g + 3 ≤ - (K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3 := by omega - have e1 : c_f * (tf a + 1) ≤ c_f * (tf a + tg (f a) + (encB (f a)).length + 1) := - Nat.mul_le_mul (le_refl _) (by omega) - have e2 : c_g * (tg (f a) + 1) ≤ c_g * (tf a + tg (f a) + (encB (f a)).length + 1) := - Nat.mul_le_mul (le_refl _) (by omega) - have hexp : (c_f + c_g + 3) * (tf a + tg (f a) + (encB (f a)).length + 1) = - c_f * (tf a + tg (f a) + (encB (f a)).length + 1) + - c_g * (tf a + tg (f a) + (encB (f a)).length + 1) + - 3 * (tf a + tg (f a) + (encB (f a)).length + 1) := by - rw [Nat.add_mul, Nat.add_mul] - have e3 : (c_f + c_g + 3) * (tf a + tg (f a) + (encB (f a)).length + 1) ≤ - ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3) * - (tf a + tg (f a) + (encB (f a)).length + 1) := Nat.mul_le_mul hcf (le_refl _) - have e4 : (encC (gg (f a))).length + 2 ≤ 3 * (tf a + tg (f a) + (encB (f a)).length + 1) := by - omega - omega - · -- Space. - intro a - set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS - have hsub1 : K_f + K_g - K_f = K_g := by omega - have hsub2 : K_f + K_g - K_g = K_f := by omega - have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := - Nat.mul_le_mul (le_refl _) (by omega) - have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := - Nat.mul_le_mul (le_refl _) (by omega) - have q1 : 2 * K_f ≤ 2 * K_f * PS := Nat.le_mul_of_pos_right _ (by omega) - have q2 : 2 * K_g ≤ 2 * K_g * PS := Nat.le_mul_of_pos_right _ (by omega) - have hexpS : (c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS = - c_f * PS + c_g * PS + 2 * K_f * PS + 2 * K_g * PS + 2 * PS := by - rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul] - have hSbound : c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1 ≤ - (c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS := by - rw [hsub1, hsub2, hexpS] - omega - calc (K_f + K_g + 1) * - (c_f * (sf a + (encB (f a)).length + 1) + K_f + (K_f + K_g - K_f) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + K_g + - (K_f + K_g - K_g)) + (encC (gg (f a))).length + 1) - ≤ (K_f + K_g + 1) * ((c_f + c_g + 2 * K_f + 2 * K_g + 2) * PS) := - Nat.mul_le_mul (le_refl _) hSbound - _ = ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2)) * PS := - (Nat.mul_assoc _ _ _).symm - _ ≤ ((K_f + K_g + 1) * (c_f + c_g + 2 * K_f + 2 * K_g + 2) + c_f + c_g + 3) * PS := - Nat.mul_le_mul (by omega) (le_refl _) - /-- **Placement embedding (two pins).** Given distinct canonical indices `i₀ ≠ o₀` in `Fin K` and distinct target indices `i ≠ o` in `Fin k` avoiding a set `keep`, with enough room (`K + keep.card ≤ k`), there is an embedding `Fin K ↪ Fin k` sending `i₀ ↦ i`, `o₀ ↦ o`, and every @@ -1108,4 +853,95 @@ public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : · -- space omega +/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`. The two +function machines are placed by the general adapters on a shared layout: `f` reads the real input +and writes tape `o1`, `gg` reads `o1` and writes tape `o`, and the result is emitted from `o`. All +the tape bookkeeping is hidden inside `exists_transformsTapes_ofComputable{,Input}`; here only the +handoff `o1` between the two machines and the final emit remain. -/ +public theorem computableInTimeAndSpace_comp + {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} + {tf sf : α → ℕ} {tg sg : β → ℕ} + (hf : ComputableInTimeAndSpace f encA encB tf sf) + (hg : ComputableInTimeAndSpace gg encB encC tg sg) : + ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC + (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) + (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by + classical + -- `f` reads the real input and leaves `encB (f a)` on tape `o1`; `gg` reads `o1` and leaves + -- `encC (gg x)` on tape `o`. The general adapters hide their scratch tapes. + obtain ⟨m_f, c_f, hf'⟩ := exists_transformsTapes_ofComputableInput hf + obtain ⟨m_g, c_g, hg'⟩ := exists_transformsTapes_ofComputable hg + set k := m_f + m_g + 2 with hk + let o1 : Fin k := ⟨0, by omega⟩ + let o : Fin k := ⟨1, by omega⟩ + have ho1o : o1 ≠ o := by + apply Fin.ne_of_val_ne; simp + obtain ⟨S_f, hS_f, M_f, hM_f⟩ := + hf' k o1 ∅ (by simp) (by simp only [Finset.card_empty]; omega) + obtain ⟨S_g, hS_g, M_g, hM_g⟩ := + hg' k o1 o ∅ ho1o (by simp) (by simp) (by simp only [Finset.card_empty]; omega) + have hfin_f := hS_f + have hfin_g := hS_g + -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output tape `o1`. + have hMc : ∀ a, TransformsTapes (M_f.seq M_g) + (fun input ws => input = encA a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encC (gg (f a))) + (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) + ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k)) := by + intro a + refine (transformsTapes_seq (h₀ := hM_f a) (h₁ := hM_g (f a)) ?_).imp ?_ ?_ le_rfl le_rfl + · -- handoff: after `M_f`, `M_g`'s precondition holds on tape `o1` + rintro input ws ws' ⟨rfl, hblank⟩ hQf + refine ⟨?_, ?_⟩ + · rw [hQf, Function.update_self] + · intro l hl _ + rw [hQf, Function.update_of_ne hl] + exact hblank l (by simp) + · -- precondition: an all-blank input satisfies `M_f`'s (empty-`keep`) precondition + rintro input ws ⟨rfl, hblank⟩ + exact ⟨rfl, fun l _ => hblank l⟩ + · -- postcondition: read the result off `M_g`'s output tape `o` + rintro input ws ws'' _ ⟨ws', _, hQg⟩ + rw [hQg, Function.update_self] + -- Emit tape `o` as the real output, turning the transformer into a computation. + obtain ⟨c, hc⟩ := + computableInTimeAndSpace_of_transformsTapes (gg := gg ∘ f) o hMc + -- Relax the bounds to the stated linear form. + refine ⟨c * (c_f + c_g + 2 * k + 2), hc.mono (fun a => ?_) (fun a => ?_)⟩ + · -- Time. + have hlc : (encC (gg (f a))).length ≤ tg (f a) := hg.length_encOut_le (f a) + set T := tf a + tg (f a) + (encB (f a)).length + 1 with hT + have e1 : c_f * (tf a + 1) ≤ c_f * T := Nat.mul_le_mul_left _ (by omega) + have e2 : c_g * (tg (f a) + 1) ≤ c_g * T := Nat.mul_le_mul_left _ (by omega) + have hexp : (c_f + c_g + 2 * k + 2) * T = + c_f * T + c_g * T + 2 * k * T + 2 * T := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * T := by omega + have hmul : c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := Nat.mul_le_mul_left _ (by omega) + calc c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * T := (Nat.mul_assoc _ _ _).symm + · -- Space. + set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS + have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := + Nat.mul_le_mul_left _ (by omega) + have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := + Nat.mul_le_mul_left _ (by omega) + have q1 : 2 * k ≤ 2 * k * PS := Nat.le_mul_of_pos_right _ (by omega) + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * PS := by omega + have hexpS : (c_f + c_g + 2 * k + 2) * PS = + c_f * PS + c_g * PS + 2 * k * PS + 2 * PS := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have hmul : c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := Nat.mul_le_mul_left _ (by omega) + calc c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * PS := (Nat.mul_assoc _ _ _).symm + end Turing.MultiTapeTM From 34fdb38875df5a9dc10863dbe5db1133f2995b78 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 09:46:11 +0000 Subject: [PATCH 44/93] refactor(Turing): move computableInTimeAndSpace_comp to Combinators The composition result is a combinator, not an adapter, so it belongs beside `Loop` in `Combinators/`. Move it verbatim from `NormalForms/Adapters.lean` into a new `Combinators/Comp.lean` that imports `Adapters`. No statement or proof change; still axiom-clean, `--wfail` build and linters pass. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 + .../Turing/MultiTape/Combinators/Comp.lean | 123 ++++++++++++++++++ .../MultiTape/NormalForms/Adapters.lean | 91 ------------- 3 files changed, 124 insertions(+), 91 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean diff --git a/Cslib.lean b/Cslib.lean index cacd600d8..fa09c2e9e 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -55,6 +55,7 @@ public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop public import Cslib.Computability.Machines.Turing.MultiTape.Configuration diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean new file mode 100644 index 000000000..435f81c66 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters + +/-! +# Complexity of function composition + +If `f` and `gg` are computable in time and space, then so is `gg ∘ f`. The two function machines are +placed by the general tape-transformer adapters on a shared work-tape layout — `f` reads the real +input and writes a scratch tape, `gg` reads that tape and writes another — and the result is emitted +as the output. All the tape bookkeeping is hidden inside the adapters, so the proof only has to name +the single handoff tape between the two machines. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_comp`: the complexity of `gg ∘ f`. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β γ : Type*} + +/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`. The two +function machines are placed by the general adapters on a shared layout: `f` reads the real input +and writes tape `o1`, `gg` reads `o1` and writes tape `o`, and the result is emitted from `o`. All +the tape bookkeeping is hidden inside `exists_transformsTapes_ofComputable{,Input}`; here only the +handoff `o1` between the two machines and the final emit remain. -/ +public theorem computableInTimeAndSpace_comp + {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} + {tf sf : α → ℕ} {tg sg : β → ℕ} + (hf : ComputableInTimeAndSpace f encA encB tf sf) + (hg : ComputableInTimeAndSpace gg encB encC tg sg) : + ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC + (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) + (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by + classical + -- `f` reads the real input and leaves `encB (f a)` on tape `o1`; `gg` reads `o1` and leaves + -- `encC (gg x)` on tape `o`. The general adapters hide their scratch tapes. + obtain ⟨m_f, c_f, hf'⟩ := exists_transformsTapes_ofComputableInput hf + obtain ⟨m_g, c_g, hg'⟩ := exists_transformsTapes_ofComputable hg + set k := m_f + m_g + 2 with hk + let o1 : Fin k := ⟨0, by omega⟩ + let o : Fin k := ⟨1, by omega⟩ + have ho1o : o1 ≠ o := by + apply Fin.ne_of_val_ne; simp + obtain ⟨S_f, hS_f, M_f, hM_f⟩ := + hf' k o1 ∅ (by simp) (by simp only [Finset.card_empty]; omega) + obtain ⟨S_g, hS_g, M_g, hM_g⟩ := + hg' k o1 o ∅ ho1o (by simp) (by simp) (by simp only [Finset.card_empty]; omega) + have hfin_f := hS_f + have hfin_g := hS_g + -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output tape `o1`. + have hMc : ∀ a, TransformsTapes (M_f.seq M_g) + (fun input ws => input = encA a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encC (gg (f a))) + (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) + ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k)) := by + intro a + refine (transformsTapes_seq (h₀ := hM_f a) (h₁ := hM_g (f a)) ?_).imp ?_ ?_ le_rfl le_rfl + · -- handoff: after `M_f`, `M_g`'s precondition holds on tape `o1` + rintro input ws ws' ⟨rfl, hblank⟩ hQf + refine ⟨?_, ?_⟩ + · rw [hQf, Function.update_self] + · intro l hl _ + rw [hQf, Function.update_of_ne hl] + exact hblank l (by simp) + · -- precondition: an all-blank input satisfies `M_f`'s (empty-`keep`) precondition + rintro input ws ⟨rfl, hblank⟩ + exact ⟨rfl, fun l _ => hblank l⟩ + · -- postcondition: read the result off `M_g`'s output tape `o` + rintro input ws ws'' _ ⟨ws', _, hQg⟩ + rw [hQg, Function.update_self] + -- Emit tape `o` as the real output, turning the transformer into a computation. + obtain ⟨c, hc⟩ := + computableInTimeAndSpace_of_transformsTapes (gg := gg ∘ f) o hMc + -- Relax the bounds to the stated linear form. + refine ⟨c * (c_f + c_g + 2 * k + 2), hc.mono (fun a => ?_) (fun a => ?_)⟩ + · -- Time. + have hlc : (encC (gg (f a))).length ≤ tg (f a) := hg.length_encOut_le (f a) + set T := tf a + tg (f a) + (encB (f a)).length + 1 with hT + have e1 : c_f * (tf a + 1) ≤ c_f * T := Nat.mul_le_mul_left _ (by omega) + have e2 : c_g * (tg (f a) + 1) ≤ c_g * T := Nat.mul_le_mul_left _ (by omega) + have hexp : (c_f + c_g + 2 * k + 2) * T = + c_f * T + c_g * T + 2 * k * T + 2 * T := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * T := by omega + have hmul : c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := Nat.mul_le_mul_left _ (by omega) + calc c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * T := (Nat.mul_assoc _ _ _).symm + · -- Space. + set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS + have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := + Nat.mul_le_mul_left _ (by omega) + have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := + Nat.mul_le_mul_left _ (by omega) + have q1 : 2 * k ≤ 2 * k * PS := Nat.le_mul_of_pos_right _ (by omega) + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * PS := by omega + have hexpS : (c_f + c_g + 2 * k + 2) * PS = + c_f * PS + c_g * PS + 2 * k * PS + 2 * PS := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have hmul : c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := Nat.mul_le_mul_left _ (by omega) + calc c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * PS := (Nat.mul_assoc _ _ _).symm + + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index dd7adb161..e4f74b8b3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -853,95 +853,4 @@ public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : · -- space omega -/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`. The two -function machines are placed by the general adapters on a shared layout: `f` reads the real input -and writes tape `o1`, `gg` reads `o1` and writes tape `o`, and the result is emitted from `o`. All -the tape bookkeeping is hidden inside `exists_transformsTapes_ofComputable{,Input}`; here only the -handoff `o1` between the two machines and the final emit remain. -/ -public theorem computableInTimeAndSpace_comp - {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} - {tf sf : α → ℕ} {tg sg : β → ℕ} - (hf : ComputableInTimeAndSpace f encA encB tf sf) - (hg : ComputableInTimeAndSpace gg encB encC tg sg) : - ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC - (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) - (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by - classical - -- `f` reads the real input and leaves `encB (f a)` on tape `o1`; `gg` reads `o1` and leaves - -- `encC (gg x)` on tape `o`. The general adapters hide their scratch tapes. - obtain ⟨m_f, c_f, hf'⟩ := exists_transformsTapes_ofComputableInput hf - obtain ⟨m_g, c_g, hg'⟩ := exists_transformsTapes_ofComputable hg - set k := m_f + m_g + 2 with hk - let o1 : Fin k := ⟨0, by omega⟩ - let o : Fin k := ⟨1, by omega⟩ - have ho1o : o1 ≠ o := by - apply Fin.ne_of_val_ne; simp - obtain ⟨S_f, hS_f, M_f, hM_f⟩ := - hf' k o1 ∅ (by simp) (by simp only [Finset.card_empty]; omega) - obtain ⟨S_g, hS_g, M_g, hM_g⟩ := - hg' k o1 o ∅ ho1o (by simp) (by simp) (by simp only [Finset.card_empty]; omega) - have hfin_f := hS_f - have hfin_g := hS_g - -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output tape `o1`. - have hMc : ∀ a, TransformsTapes (M_f.seq M_g) - (fun input ws => input = encA a ∧ ∀ l, ws l = []) - (fun _ _ ws' => ws' o = encC (gg (f a))) - (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) - ((c_f * (sf a + (encB (f a)).length + 1) + k) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k)) := by - intro a - refine (transformsTapes_seq (h₀ := hM_f a) (h₁ := hM_g (f a)) ?_).imp ?_ ?_ le_rfl le_rfl - · -- handoff: after `M_f`, `M_g`'s precondition holds on tape `o1` - rintro input ws ws' ⟨rfl, hblank⟩ hQf - refine ⟨?_, ?_⟩ - · rw [hQf, Function.update_self] - · intro l hl _ - rw [hQf, Function.update_of_ne hl] - exact hblank l (by simp) - · -- precondition: an all-blank input satisfies `M_f`'s (empty-`keep`) precondition - rintro input ws ⟨rfl, hblank⟩ - exact ⟨rfl, fun l _ => hblank l⟩ - · -- postcondition: read the result off `M_g`'s output tape `o` - rintro input ws ws'' _ ⟨ws', _, hQg⟩ - rw [hQg, Function.update_self] - -- Emit tape `o` as the real output, turning the transformer into a computation. - obtain ⟨c, hc⟩ := - computableInTimeAndSpace_of_transformsTapes (gg := gg ∘ f) o hMc - -- Relax the bounds to the stated linear form. - refine ⟨c * (c_f + c_g + 2 * k + 2), hc.mono (fun a => ?_) (fun a => ?_)⟩ - · -- Time. - have hlc : (encC (gg (f a))).length ≤ tg (f a) := hg.length_encOut_le (f a) - set T := tf a + tg (f a) + (encB (f a)).length + 1 with hT - have e1 : c_f * (tf a + 1) ≤ c_f * T := Nat.mul_le_mul_left _ (by omega) - have e2 : c_g * (tg (f a) + 1) ≤ c_g * T := Nat.mul_le_mul_left _ (by omega) - have hexp : (c_f + c_g + 2 * k + 2) * T = - c_f * T + c_g * T + 2 * k * T + 2 * T := by - rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] - have e4 : (encC (gg (f a))).length + 1 ≤ 2 * T := by omega - have hmul : c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) - ≤ c * ((c_f + c_g + 2 * k + 2) * T) := Nat.mul_le_mul_left _ (by omega) - calc c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) - ≤ c * ((c_f + c_g + 2 * k + 2) * T) := hmul - _ = c * (c_f + c_g + 2 * k + 2) * T := (Nat.mul_assoc _ _ _).symm - · -- Space. - set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS - have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := - Nat.mul_le_mul_left _ (by omega) - have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := - Nat.mul_le_mul_left _ (by omega) - have q1 : 2 * k ≤ 2 * k * PS := Nat.le_mul_of_pos_right _ (by omega) - have e4 : (encC (gg (f a))).length + 1 ≤ 2 * PS := by omega - have hexpS : (c_f + c_g + 2 * k + 2) * PS = - c_f * PS + c_g * PS + 2 * k * PS + 2 * PS := by - rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] - have hmul : c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + - (encC (gg (f a))).length + 1) - ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := Nat.mul_le_mul_left _ (by omega) - calc c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + - (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + - (encC (gg (f a))).length + 1) - ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := hmul - _ = c * (c_f + c_g + 2 * k + 2) * PS := (Nat.mul_assoc _ _ _).symm - end Turing.MultiTapeTM From 3046b6aafbd285ed5230faeded8e99d3dff63ec2 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 09:47:10 +0000 Subject: [PATCH 45/93] refactor(Turing): reuse length_encOut_le in ofComputableInput_fixed The `exists_transformsTapes_ofComputableInput_fixed` proof inlined an output-length induction that is a verbatim copy of `length_output_runFrom_le` and reconstructs `ComputableInTimeAndSpace.length_encOut_le`. Replace the 15-line block with the one-line `h.length_encOut_le a`. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/NormalForms/Adapters.lean | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index e4f74b8b3..babc287b8 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -62,21 +62,7 @@ public theorem exists_transformsTapes_ofComputableInput_fixed obtain ⟨τ, hτ, htidyrun, htidysp⟩ := htidy a -- The encoded result is produced by the *original* machine in at most `t a` steps, so it is no -- longer than `t a` — a fact the tidy interface alone (which only bounds by `τ`) does not give. - have hw_len : (encOut (g a)).length ≤ t a := by - obtain ⟨kk, SS, hfinSS, tmm, hcomp⟩ := h - obtain ⟨t', ht', s', hs', hhaltm, houtm, hspm⟩ := hcomp a - have hlen : ∀ d, (tmm.runFrom (tmm.initCfg (enc a)) d).output.length ≤ d := by - intro d - induction d with - | zero => rw [runFrom_zero, initCfg_eq_wordsCfg]; simp - | succ d ih => - rw [runFrom_succ_eq_step', step_output, List.length_append] - have h1 : (tmm.outputSymbol (tmm.runFrom (tmm.initCfg (enc a)) d)).toList.length ≤ 1 := by - cases tmm.outputSymbol (tmm.runFrom (tmm.initCfg (enc a)) d) <;> simp - omega - have hle := hlen t' - rw [houtm] at hle - omega + have hw_len : (encOut (g a)).length ≤ t a := h.length_encOut_le a -- Abbreviations: the encoded result `w`, the tidy halting configuration `X`, and the start. set w := encOut (g a) with hw_def set X := wordsCfg (enc a) none (fun _ => []) w with hX_def From 18b5a91fbd54ebee9d867895cb672137c2e93b9e Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 10:04:33 +0000 Subject: [PATCH 46/93] refactor(Turing): remove dead declarations and dedup low-level lemmas Review cleanup, part 1 (no statement or public-behaviour change): * delete the unused `Plumbing/NeverOutputs.lean` (nothing imported it; the used variant is `OutputToTape`'s `*_outputToTape_withOutput`); * drop the dead `content_natAbs_le_spaceUsedByTape` chain (TapeLemmas), unused `runFrom_seq` (Sequential, superseded by `seq_spec`), unused `step_state_of_state` (StepLemmas), never-fired `@[simp] embed_inputSymbol` and dead `eraseFrom` (Sweep); * hoist the twice-copied `tapeOfList_zero` into `TransformsTapes` (was duplicated in Repeat and Branch); * simplify the `nop` space bound via `spaceUsed_le_of_workTapePos_const`, fold the two `cases partialInv` in `ExtendTapes`, and drop a cosmetic `by exact h` in Configuration. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 - .../Turing/MultiTape/Configuration.lean | 4 +- .../Turing/MultiTape/NormalForms/Sweep.lean | 4 - .../Turing/MultiTape/Plumbing/Branch.lean | 6 -- .../MultiTape/Plumbing/ExtendTapes.lean | 13 +-- .../MultiTape/Plumbing/NeverOutputs.lean | 79 ------------------- .../Turing/MultiTape/Plumbing/Repeat.lean | 6 -- .../Turing/MultiTape/Plumbing/Sequential.lean | 15 ---- .../Turing/MultiTape/Plumbing/StepLemmas.lean | 5 -- .../MultiTape/Plumbing/TransformsTapes.lean | 23 +++--- .../Machines/Turing/MultiTape/TapeLemmas.lean | 28 ------- 11 files changed, 15 insertions(+), 169 deletions(-) delete mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean diff --git a/Cslib.lean b/Cslib.lean index fa09c2e9e..6765bba88 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -72,7 +72,6 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.NeverOutputs public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index b6a97c150..58994d8dc 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -154,11 +154,11 @@ lemma val_moveInputPos_eq {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : have hmc : (m.cast : ℤ) = -1 ∨ (m.cast : ℤ) = 0 ∨ (m.cast : ℤ) = 1 := by rcases m with _ | _ | _ <;> simp [SignType.cast] by_cases h : (((pos.val : ℤ) + (m.cast : ℤ)).toNat) < n + 2 - · rw [dite_eq_left (by exact h)] + · rw [dite_eq_left h] have := pos.isLt push_cast omega - · rw [dite_eq_right (by exact h)] + · rw [dite_eq_right h] have := pos.isLt push_cast omega diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean index fb92265f3..ffb496797 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean @@ -151,10 +151,6 @@ private def F : ℤ → Option Bool := fun z => private def eraseAbove (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => if q < z then none else T z -/-- A tape erased at `q` and above. -/ -private def eraseFrom (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => - if q ≤ z then none else T z - /-- The footprint after the left sweep has reached position `q`: everything at `q + 1` and above erased except the anchor. -/ private def eraseKeepAnchor (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index a4d8221b5..7c5180013 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -39,12 +39,6 @@ variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} namespace Branch -/-- The tape holding `xs` reads `xs.head?` at its start cell. -/ -private lemma tapeOfList_zero (xs : List Bool) : tapeOfList xs 0 = xs.head? := by - have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl - rw [h, tapeOfList_ofNat] - cases xs <;> rfl - /-- The branching machine. State `none` is a fresh dispatch state: it reads the symbol under tape `i`'s head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial state (if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, its diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean index dc157b323..0f4ac2e2b 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean @@ -103,11 +103,6 @@ public lemma partialInv_eq_some (e : Fin k ↪ Fin k') {l : Fin k'} {j : Fin k} rw [← h]; exact hspec · rw [dite_eq_right hl] at h; exact absurd h (by simp) -@[simp] -public lemma embed_inputSymbol (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) - (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) : - (embed e cfg extraTapes extraPos).inputSymbol = cfg.inputSymbol := rfl - @[simp] public lemma embed_workTapes_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : @@ -148,14 +143,10 @@ public lemma step_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') refine Cfg.ext rfl rfl ?_ ?_ rfl · funext l z simp only [Action.apply, embed] - cases partialInv e l with - | none => rfl - | some j => rfl + cases partialInv e l <;> rfl · funext l simp only [Action.apply, embed] - cases partialInv e l with - | none => simp - | some j => rfl + cases partialInv e l <;> simp /-- The reindexed run mirrors the original, with the extra tapes held fixed throughout. -/ public lemma runFrom_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean deleted file mode 100644 index 81b9752b2..000000000 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/NeverOutputs.lean +++ /dev/null @@ -1,79 +0,0 @@ -/- -Copyright (c) 2026 Christian Reitwiessner. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Christian Reitwiessner --/ - -module - -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas -public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas - -/-! -# Machines that never write the real output - -Every tape *transformer* redirects its result onto a work tape and never touches the real output. -For such a machine the real output is inert: preserved along the whole run, and the run and space -usage commute with replacing it. This is what lets a transformer be run from a configuration whose -output is already present, as the word-transformer interface -`Turing.MultiTapeTM.TransformsTapes` quantifies over — the caller need not know the output is -empty. --/ - -@[expose] public section - -namespace Turing.MultiTapeTM - -variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} - -/-- A machine none of whose transitions emit an output symbol. -/ -public def NeverOutputs (tm : MultiTapeTM k Symbol State) : Prop := - ∀ q inp work, (tm.tr q inp work).output = none - -variable {tm : MultiTapeTM k Symbol State} - -/-- Such a machine's step commutes with replacing the real output. -/ -public lemma step_withOutput_of_neverOutputs (h : NeverOutputs tm) - (cfg : Cfg k Symbol State input) (out : List Symbol) : - tm.step (cfg.withOutput out) = (tm.step cfg).withOutput out := by - cases hq : cfg.state with - | none => - have h1 : (cfg.withOutput out).state = none := hq - rw [step_of_halt h1, step_of_halt hq] - | some q => - have h1 : (cfg.withOutput out).state = some q := hq - have hin : (cfg.withOutput out).inputSymbol = cfg.inputSymbol := rfl - have hws : (cfg.withOutput out).workTapeSymbols = cfg.workTapeSymbols := rfl - rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] - refine Cfg.ext rfl rfl (funext fun l => funext fun z => by simp [Cfg.withOutput]) - (funext fun l => by simp [Cfg.withOutput]) ?_ - simp only [Action.apply_output, Cfg.withOutput_output, - h q cfg.inputSymbol cfg.workTapeSymbols, Option.toList_none, List.append_nil] - -/-- The run of such a machine commutes with replacing the real output. -/ -public lemma runFrom_withOutput_of_neverOutputs (h : NeverOutputs tm) - (cfg : Cfg k Symbol State input) (out : List Symbol) (n : ℕ) : - tm.runFrom (cfg.withOutput out) n = (tm.runFrom cfg n).withOutput out := - runFrom_comm_of_step (fun c => c.withOutput out) - (fun c => step_withOutput_of_neverOutputs h c out) cfg n - -/-- Such a machine's space does not depend on the real output already present. -/ -public lemma spaceUsed_withOutput_of_neverOutputs (h : NeverOutputs tm) - (cfg : Cfg k Symbol State input) (out : List Symbol) (u : ℕ) : - tm.spaceUsed (cfg.withOutput out) u = tm.spaceUsed cfg u := by - refine spaceUsed_eq_of_workTapePos _ _ u fun m _ => ?_ - rw [runFrom_withOutput_of_neverOutputs h]; rfl - -/-- The real output is unchanged along the run of such a machine. -/ -public lemma output_runFrom_of_neverOutputs (h : NeverOutputs tm) - (cfg : Cfg k Symbol State input) (n : ℕ) : - (tm.runFrom cfg n).output = cfg.output := by - induction n with - | zero => simp - | succ n ih => - rw [runFrom_succ_eq_step', step_output, ih] - rcases hs : (tm.runFrom cfg n).state with _ | q - · simp [outputSymbol, hs] - · simp [outputSymbol, hs, h q] - -end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean index 71ba307b8..76b8426b6 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean @@ -45,12 +45,6 @@ variable {k : ℕ} {State₀ : Type*} {input : List Bool} namespace Repeat -/-- The tape holding `xs` reads `xs.head?` at its start cell. -/ -private lemma tapeOfList_zero (xs : List Bool) : tapeOfList xs 0 = xs.head? := by - have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl - rw [h, tapeOfList_ofNat] - cases xs <;> rfl - /-- The looping machine. On a live state `Sum.inl q` it runs `tm`, but redirects `tm`'s halting transition to the fresh check state `Sum.inr ()`. On the check state it reads the symbol under tape `i`'s head: if it is `some x` the machine halts, otherwise it restarts `tm` from its initial diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean index 9bdfeea3e..7043c2c2d 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -118,21 +118,6 @@ public lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : public lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl -/-- **The run of `seq`, raw form.** Once the first machine has halted (at its first halting -time), the composite continues as the second machine from the handoff configuration. This is the -form used to chain phases whose intermediate configurations are not normalised; the -`TransformsTapes`-level composition is `transformsTapes_seq`. -/ -public lemma runFrom_seq (cfg : Cfg k Symbol State₀ input) (u v : ℕ) - (hhalt : (tm₀.runFrom cfg u).state = none) - (hactive : ∀ m < u, (tm₀.runFrom cfg m).state ≠ none) : - (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) (u + v) = - rightCfg (tm₁.runFrom ((tm₀.runFrom cfg u).withState (some tm₁.q₀)) v) := by - rw [runFrom_add, runFrom_leftCfg _ u hactive] - have h : leftCfg tm₁ (tm₀.runFrom cfg u) = - rightCfg ((tm₀.runFrom cfg u).withState (some tm₁.q₀)) := by - simp [leftCfg, rightCfg, Cfg.withState, hhalt] - rw [h, runFrom_rightCfg] - end Sequential open Sequential in diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean index 1c12f6afe..02095c3ac 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean @@ -62,11 +62,6 @@ public lemma step_apply_of_state (h : cfg.state = some q) : tm.step cfg = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).apply cfg := by rw [step, h] -/-- The state after a live step. -/ -public lemma step_state_of_state (h : cfg.state = some q) : - (tm.step cfg).state = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).state := by - rw [step_apply_of_state h, Action.apply_state] - /-- The input head after a live step. -/ public lemma step_inputPos_of_state (h : cfg.state = some q) : (tm.step cfg).inputPos = diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index 0f6d6cb6e..34b3e0ed3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -73,6 +73,12 @@ public lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := b funext z cases z <;> simp +/-- The cell at position `0` holds the first symbol of the word. -/ +public lemma tapeOfList_zero (xs : List Symbol) : tapeOfList xs 0 = xs.head? := by + have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl + rw [h, tapeOfList_ofNat] + cases xs <;> rfl + /-- The same configuration in a different control state, possibly of a different state type. -/ @[expose, simps] public def _root_.Turing.Cfg.withState (cfg : Cfg k Symbol State input) {State' : Type*} (q : Option State') : Cfg k Symbol State' input := @@ -148,18 +154,11 @@ public theorem exists_transformsTapes_nop (k : ℕ) (Symbol : Type*) : have hrun : (nop k Symbol).runFrom (wordsCfg input (some ()) ws out) 1 = wordsCfg input none ws out := by rw [runFrom_succ_eq_step', runFrom_zero, step_nop] - refine ⟨1, le_rfl, ws, hrun, rfl, ?_⟩ - -- the heads never move, so each tape's visited set is contained in the single cell `0` - have hsub : ∀ i, (nop k Symbol).visitedByTapeHead (wordsCfg input (some ()) ws out) 1 i - ⊆ {0} := by - intro i z hz - obtain ⟨t', ht', rfl⟩ := mem_visitedByTapeHead.mp hz - rcases (by omega : t' = 0 ∨ t' = 1) with rfl | rfl - · simp - · simp [hrun] - refine le_trans ?_ (le_of_eq (by simp : (∑ _i : Fin k, 1) = k)) - exact Finset.sum_le_sum fun i _ => - (Finset.card_le_card (hsub i)).trans_eq (Finset.card_singleton 0) + -- the heads never move, so each tape touches only the single cell `0` + refine ⟨1, le_rfl, ws, hrun, rfl, spaceUsed_le_of_workTapePos_const _ 1 fun m hm => ?_⟩ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hrun]; funext i; simp only [wordsCfg_workTapePos] end Nop diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index c8df87ea2..ed7a4d6aa 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -89,34 +89,6 @@ lemma mem_visitedByTapeHead_of_workTapes_ne · rw [tm.step_workTapes_eq_of_ne _ j z hz] at h exact tm.visitedByTapeHead_mono cfg j (Nat.le_succ t) (ih h) -/-- Every position visited by the head of tape `i` lies within `spaceUsedByTape … i` of the -head's starting position. -/ -lemma natAbs_le_spaceUsedByTape_of_mem_visited - {i : Fin k} - {z : ℤ} - {t : ℕ} - (hz : z ∈ tm.visitedByTapeHead cfg t i) : - (z - cfg.workTapePos i).natAbs ≤ tm.spaceUsedByTape cfg t i := by - obtain ⟨t', ht', rfl⟩ := tm.mem_visitedByTapeHead.mp hz - have h1 := Finset.card_le_card - ((tm.uIcc_workTapePos_subset_visitedByTapeHead cfg i t').trans - (tm.visitedByTapeHead_mono cfg i (show t' ≤ t by omega))) - rw [Int.card_uIcc] at h1 - unfold spaceUsedByTape - omega - -/-- Every non-blank cell on work tape `i` lies within `spaceUsedByTape … i t` of the origin. -/ -lemma content_natAbs_le_spaceUsedByTape - {i : Fin k} - (t : ℕ) - (z : ℤ) - (h : (tm.runFrom (tm.initCfg input) t).workTapes i z ≠ none) : - z.natAbs ≤ tm.spaceUsedByTape (tm.initCfg input) t i := by - -- The work tapes start out blank, so any non-blank cell has been visited by the head; the - -- initial head position is `0`, so the displacement bound is a bound on the position itself. - simpa using tm.natAbs_le_spaceUsedByTape_of_mem_visited - (tm.mem_visitedByTapeHead_of_workTapes_ne i t z h) - /-- The number of cells touched by a single work tape grows by at most one each step. -/ lemma spaceUsedByTape_le (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : tm.spaceUsedByTape cfg t i ≤ t + 1 := by From be54f65735fd295dec05335d6144e604f5e9002d Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 10:10:25 +0000 Subject: [PATCH 47/93] refactor(Turing): dedup proofs across adapters, loop, and tidy machines MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Review cleanup, part 2 (proof bodies only, no statement change): * Adapters: drop the unused `transformsTapes_extendTapes` (byte-copy of the relaxed variant with a vestigial hypothesis) and rename the relaxed one to it; extract `update_of_embed_update` for the two identical "read the update back through the embedding" postcondition blocks in the general adapters. * Loop: remove the `hWt` bound-lift block, projecting `hWlen` directly with `.trans (hvu a W)` at the four use sites; tidy three unused `⟨w1, …⟩` binders. * Id: drop `Copy.cfg_ext` in favour of the shared `Cfg.ext_zero_tapes`. * Tidy: fold `hL0'`/`h0R'` into term-mode one-liners. * EmitTape/RewindTape: collapse eight `constructor · … · …` interval-bound blocks into `constructor <;> simp only […] <;> omega`. Full `--wfail` build and linters pass; `comp` and `loopFunction` remain axiom-clean (propext/Classical.choice/Quot.sound). Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Id.lean | 12 +- .../Turing/MultiTape/Combinators/Loop.lean | 24 ++-- .../MultiTape/NormalForms/Adapters.lean | 112 +++++------------- .../Turing/MultiTape/NormalForms/Tidy.lean | 10 +- .../Turing/MultiTape/Plumbing/EmitTape.lean | 20 +--- .../Turing/MultiTape/Plumbing/RewindTape.lean | 18 +-- 6 files changed, 53 insertions(+), 143 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean index 38e8f5b97..d72f72103 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean @@ -45,12 +45,6 @@ def cfg (input : List Symbol) (q : Option Unit) (p : Fin (input.length + 2)) (out : List Symbol) : Cfg 0 Symbol Unit input := ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ -/-- With no work tapes, configurations are equal as soon as the state, the input position and the -output agree. -/ -lemma cfg_ext {c₁ c₂ : Cfg 0 Symbol Unit input} (hstate : c₁.state = c₂.state) - (hpos : c₁.inputPos = c₂.inputPos) (hout : c₁.output = c₂.output) : c₁ = c₂ := - Cfg.ext hstate hpos (funext fun i => i.elim0) (funext fun i => i.elim0) hout - /-- Over an input symbol, the copy machine emits it and moves right. -/ lemma step_scan {n : ℕ} (hn : n < input.length) (out : List Symbol) : copy.step (cfg input (some ()) ⟨n + 1, by omega⟩ out) = @@ -60,7 +54,7 @@ lemma step_scan {n : ℕ} (hn : n < input.length) (out : List Symbol) : unfold step simp only [cfg] at hsym ⊢ rw [hsym] - refine cfg_ext rfl ?_ rfl + refine Cfg.ext_zero_tapes rfl ?_ rfl apply Fin.ext simp [copy, Action.apply, moveInputPos] grind @@ -75,7 +69,7 @@ lemma step_halt (out : List Symbol) : unfold step simp only [cfg] at hsym ⊢ rw [hsym] - exact cfg_ext rfl (by simp [copy, Action.apply]) (by simp [copy, Action.apply]) + exact Cfg.ext_zero_tapes rfl (by simp [copy, Action.apply]) (by simp [copy, Action.apply]) /-- After `n ≤ input.length` steps, the copy machine has copied the first `n` input symbols to the output and its head is over the `n`-th cell of the input. -/ @@ -83,7 +77,7 @@ lemma runFrom_scan (n : ℕ) (hn : n ≤ input.length) : copy.runFrom (copy.initCfg input) n = cfg input (some ()) ⟨n + 1, by omega⟩ (input.take n) := by induction n with - | zero => exact cfg_ext rfl rfl rfl + | zero => exact Cfg.ext_zero_tapes rfl rfl rfl | succ n ih => rw [runFrom_succ_eq_step', ih (by omega), step_scan (by omega)] have htake : input.take n ++ [input[n]] = input.take (n + 1) := by diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean index 08bb3e48f..b4836d698 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean @@ -434,16 +434,6 @@ public theorem computableInTimeAndSpace_loopFunction -- ### Bounds for the individual machines -- Every length occurring in the bound of a machine of a round is bounded by `W * (s a + 1)`, -- hence its time by a constant times `t a + s a + 1` and its space by a constant times `s a + 1`. - have hWt : ∀ a n x, loopIterate body n a = some x → - (enc x).length ≤ W * (t a + s a + 1) ∧ - (encOpt (body x)).length ≤ W * (t a + s a + 1) ∧ - (encOpt (some x)).length ≤ W * (t a + s a + 1) ∧ - cd * ((encOpt (some x)).length + 1) ≤ W * (t a + s a + 1) ∧ - s x ≤ W * (t a + s a + 1) ∧ t x ≤ W * (t a + s a + 1) := by - intro a n x hx - obtain ⟨h1, h2, h3, h4, h5, h6⟩ := hWlen a n x hx - exact ⟨h1.trans (hvu a W), h2.trans (hvu a W), h3.trans (hvu a W), h4.trans (hvu a W), - h5.trans (hvu a W), h6⟩ have hcW : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (t a + s a + 1) := fun c a hc => hc.trans (Nat.le_mul_of_pos_right _ (by omega)) have hcWv : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (s a + 1) := fun c a hc => @@ -457,16 +447,16 @@ public theorem computableInTimeAndSpace_loopFunction exact nat_bound₁ (hu1 a) (hcW 1 a hW1) obtain ⟨A3, hA3⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → cC1 * ((enc x).length + 1) ≤ c * (t a + s a + 1) := - ⟨cC1 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).1⟩ + ⟨cC1 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).1.trans (hvu a W))⟩ obtain ⟨A4, hA4⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → cD * (cd * ((encOpt (some x)).length + 1) + 1) ≤ c * (t a + s a + 1) := - ⟨cD * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.2.1⟩ + ⟨cD * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).2.2.2.1.trans (hvu a W))⟩ obtain ⟨A5, hA5⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → cC3 * ((encOpt (some x)).length + 1) ≤ c * (t a + s a + 1) := - ⟨cC3 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.1⟩ + ⟨cC3 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).2.2.1.trans (hvu a W))⟩ obtain ⟨A6, hA6⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → cB * (t x + 1) ≤ c * (t a + s a + 1) := - ⟨cB * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWt a n x hx).2.2.2.2.2⟩ + ⟨cB * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWlen a n x hx).2.2.2.2.2⟩ obtain ⟨A7, hA7⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → cI * (ci * ((enc x).length + 1) + 1) ≤ c * (t a + s a + 1) := by refine ⟨cI * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ?_⟩ @@ -671,7 +661,7 @@ public theorem computableInTimeAndSpace_loopFunction rcases hby : body y with _ | y' · exact absurd (by simp [hws, tapeWords_thd hT14 hT34, hby, hencBoolHead]) hflag · exact (hPCont a n ws').mpr ⟨y, y', hy, hby, hws⟩ - · obtain ⟨w1, -, h2⟩ := hQ + · obtain ⟨_, -, h2⟩ := hQ exact h2 · simp only [max_self] have e1 := hA1 a @@ -741,7 +731,7 @@ public theorem computableInTimeAndSpace_loopFunction le_rfl le_rfl refine (transformsTapes_seq s1 s2 (fun _ _ _ _ h => h)).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) ?_ ?_ - · obtain ⟨w1, -, h2⟩ := hQ + · obtain ⟨_, -, h2⟩ := hQ exact h2 · calc _ ≤ A7 * (t a + s a + 1) + A6 * (t a + s a + 1) := Nat.add_le_add (hA7 a 0 a rfl) (hA6 a 0 a rfl) @@ -760,7 +750,7 @@ public theorem computableInTimeAndSpace_loopFunction intro a refine (transformsTapes_seq (hPro a) (hMLoop a) (fun _ _ _ _ h => h)).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl - obtain ⟨w1, -, h2⟩ := hQ + obtain ⟨_, -, h2⟩ := hQ exact h2 obtain ⟨c₀, hc₀⟩ := computableInTimeAndSpace_of_transformsTapes T1 hMain -- ### The final bounds diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index babc287b8..d81d875d4 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -471,61 +471,11 @@ private lemma wordsCfg_eq_embed {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k · funext l change (0 : ℤ) = _ rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] - /-- **Reindexing preserves being a tape transformer.** If `M` transforms tapes along `P`/`Q`, then `extendTapes M e` transforms them on the tapes selected by `e`, leaving the tapes outside the range -of `e` untouched, in the same time and space plus one cell per added tape. -/ +of `e` carried through unchanged (as the postcondition records), in the same time and space plus one +cell per added tape. -/ public theorem transformsTapes_extendTapes {k k' : ℕ} {State : Type} - (e : Fin k ↪ Fin k') {M : MultiTapeTM k Bool State} - {P : (input : List Bool) → (Fin k → List Bool) → Prop} - {Q : (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} - {t s : ℕ} (h : TransformsTapes M P Q t s) : - TransformsTapes (extendTapes M e) - (fun input ws => P input (fun j => ws (e j)) ∧ ∀ l, (∀ j, e j ≠ l) → ws l = []) - (fun input ws ws' => Q input (fun j => ws (e j)) (fun j => ws' (e j)) ∧ - ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) - t (s + (k' - k)) := by - intro input ws out ⟨hP, hextra⟩ - -- the start config, viewed through the embedding - have hstart : wordsCfg input (some (extendTapes M e).q₀) ws out = - embed e (wordsCfg input (some M.q₀) (fun j => ws (e j)) out) - (fun l => tapeOfList (ws l)) (fun _ => 0) := - wordsCfg_eq_embed e input (some M.q₀) ws out - -- run the inner machine - obtain ⟨τ, hτ, ws', hrun, hQ, hsp⟩ := - h input (fun j => ws (e j)) out hP - refine ⟨τ, hτ, fun l => match partialInv e l with | some j => ws' j | none => ws l, ?_, ?_, ?_⟩ - · -- the run: the embedded halting config is a `wordsCfg` - rw [hstart, runFrom_embed, hrun] - refine Cfg.ext rfl rfl ?_ ?_ rfl - · funext l z - change (embed e (wordsCfg input (none : Option State) ws' out) - (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapes l z = - (wordsCfg input (none : Option State) - (fun l => match partialInv e l with | some j => ws' j | none => ws l) out).workTapes l z - rcases hpi : partialInv e l with _ | j - · simp [embed, hpi] - · simp [embed, hpi, wordsCfg_workTapes] - · funext l - change (embed e (wordsCfg input (none : Option State) ws' out) - (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapePos l = (0 : ℤ) - rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] - · -- the postcondition - refine ⟨?_, ?_⟩ - · have : (fun j => (fun l => match partialInv e l with | some j => ws' j | none => ws l) (e j)) - = ws' := by - funext j; simp only [partialInv_embed] - rw [this]; exact hQ - · intro l hl - simp only [partialInv_eq_none e (fun ⟨j, hj⟩ => hl j hj)] - · -- the space - rw [hstart] - exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) - -/-- **Reindexing preserves being a tape transformer (relaxed precondition).** Same as -`transformsTapes_extendTapes`, but the precondition no longer requires the tapes outside `range e` -to be blank: those tapes are simply carried through unchanged, as the postcondition records. -/ -public theorem transformsTapes_extendTapes' {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k') {M : MultiTapeTM k Bool State} {P : (input : List Bool) → (Fin k → List Bool) → Prop} {Q : (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} @@ -572,6 +522,30 @@ public theorem transformsTapes_extendTapes' {k k' : ℕ} {State : Type} rw [hstart] exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) +/-- Reading a `Function.update` back through an embedding: if the words on the tapes selected by `e` +form `Function.update … o₀ v` and every tape outside the range of `e` is unchanged, then the whole +vector is `Function.update … o v`, where `o = e o₀`. -/ +private lemma update_of_embed_update {K k : ℕ} (e : Fin K ↪ Fin k) + (o₀ : Fin K) (o : Fin k) (heo : e o₀ = o) + (ws ws' : Fin k → List Bool) (v : List Bool) + (hQ1 : (fun j => ws' (e j)) = Function.update (fun j => ws (e j)) o₀ v) + (hQ2 : ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) : + ws' = Function.update ws o v := by + funext l + by_cases hlo : l = o + · subst hlo + have hh := congrFun hQ1 o₀ + simp only [heo, Function.update_self] at hh + rw [Function.update_self]; exact hh + · rw [Function.update_of_ne hlo] + by_cases hex : ∃ j, e j = l + · obtain ⟨j, rfl⟩ := hex + have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] + have hh := congrFun hQ1 j + rw [Function.update_of_ne hjo] at hh + exact hh + · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + /-- **Placement embedding (two pins).** Given distinct canonical indices `i₀ ≠ o₀` in `Fin K` and distinct target indices `i ≠ o` in `Fin k` avoiding a set `keep`, with enough room (`K + keep.card ≤ k`), there is an embedding `Fin K ↪ Fin k` sending `i₀ ↦ i`, `o₀ ↦ o`, and every @@ -752,7 +726,7 @@ public theorem exists_transformsTapes_ofComputable {α β : Type*} {enc : α ↪ obtain ⟨e, hei, heo, hother⟩ := exists_embed_placing i₀ o₀ hio₀ i o keep hio hik hok hroom' refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ - refine (transformsTapes_extendTapes' e (hcanon a)).imp ?_ ?_ le_rfl ?_ + refine (transformsTapes_extendTapes e (hcanon a)).imp ?_ ?_ le_rfl ?_ · -- precondition: the general layout satisfies the embedded canonical precondition rintro input ws ⟨hwi, hwblank⟩ refine ⟨?_, ?_⟩ @@ -769,20 +743,7 @@ public theorem exists_transformsTapes_ofComputable {α β : Type*} {enc : α ↪ exact hwblank (e l') hne_i hmem2.2 · -- postcondition: read the update back through the embedding rintro input ws ws' _ ⟨hQ1, hQ2⟩ - funext l - by_cases hlo : l = o - · subst hlo - have hh := congrFun hQ1 o₀ - simp only [heo, Function.update_self] at hh - rw [Function.update_self]; exact hh - · rw [Function.update_of_ne hlo] - by_cases hex : ∃ j, e j = l - · obtain ⟨j, rfl⟩ := hex - have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] - have hh := congrFun hQ1 j - rw [Function.update_of_ne hjo] at hh - exact hh - · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + exact update_of_embed_update e o₀ o heo ws ws' _ hQ1 hQ2 · -- space omega @@ -809,7 +770,7 @@ public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : have hroom' : K + keep.card ≤ k := by omega obtain ⟨e, heo, hother⟩ := exists_embed_placing_one o₀ o keep hok hroom' refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ - refine (transformsTapes_extendTapes' e (hcanon a)).imp ?_ ?_ le_rfl ?_ + refine (transformsTapes_extendTapes e (hcanon a)).imp ?_ ?_ le_rfl ?_ · -- precondition rintro input ws ⟨hinput, hwblank⟩ refine ⟨hinput, ?_⟩ @@ -822,20 +783,7 @@ public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : exact hwblank (e l') hmem.2 · -- postcondition rintro input ws ws' _ ⟨hQ1, hQ2⟩ - funext l - by_cases hlo : l = o - · subst hlo - have hh := congrFun hQ1 o₀ - simp only [heo, Function.update_self] at hh - rw [Function.update_self]; exact hh - · rw [Function.update_of_ne hlo] - by_cases hex : ∃ j, e j = l - · obtain ⟨j, rfl⟩ := hex - have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] - have hh := congrFun hQ1 j - rw [Function.update_of_ne hjo] at hh - exact hh - · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + exact update_of_embed_update e o₀ o heo ws ws' _ hQ1 hQ2 · -- space omega diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean index 14540c56b..7ec5374b5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -306,14 +306,8 @@ public theorem exists_tidy {α β : Type*} {encIn : α ↪ List Bool} {encOut : (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)).withState (some tmA.q₀)) rfl -- the interval data, in usable form - have hL0' : ∀ j, L j ≤ 0 := by - intro j - have := hL0 j - simpa [Cfg.init] using this - have h0R' : ∀ j, 0 ≤ R j := by - intro j - have := h0R j - simpa [Cfg.init] using this + have hL0' : ∀ j, L j ≤ 0 := fun j => by simpa [Cfg.init] using hL0 j + have h0R' : ∀ j, 0 ≤ R j := fun j => by simpa [Cfg.init] using h0R j -- phases D and E, from any configuration with the right fields have hDE : ∀ (c : Cfg (k₀ + k₀) Bool (SD ⊕ SE) (encIn a)), c.state = some (tmD.seq tmE).q₀ → diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean index 77262637f..29f3dfcce 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean @@ -156,14 +156,10 @@ lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) rcases Nat.lt_or_ge m (w.length + 1) with hlt | hge · have hml : m ≤ w.length := by omega rw [runFrom_scan hw m hml] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega · obtain rfl : m = w.length + 1 := by omega rw [runFrom_full hw] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega /-- No action of the machine writes to a work tape. -/ lemma tr_write_none (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) (l : Fin K) : @@ -380,17 +376,11 @@ lemma runFrom_pos_range (m : ℕ) (hm : m ≤ 2) : ((setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) m).workTapePos i ≤ 0 := by rcases m with _ | _ | _ | m · rw [runFrom_zero] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega · rw [runFrom_one] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega · rw [runFrom_two] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega · exact absurd hm (by omega) /-- No action of the machine moves the input head. -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean index 19818ff30..be24fb6e5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean @@ -171,10 +171,10 @@ machine has halted with the head of tape `i` back at position `0`. -/ lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) (w.length + 2) = cfg input i none ip W WP out 0 := by - have hstep1 : (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = + have hstep1 : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1) := by - rw [runFrom_succ_eq_step', runFrom_zero] - exact step_start + rw [runFrom_succ_eq_step', runFrom_zero]; exact step_start have hscanEnd : (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) (1 + w.length) = cfg input i (some .scan) ip W WP out (-1) := by @@ -202,21 +202,15 @@ lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) rcases Nat.lt_or_ge m 1 with h0 | h1 · obtain rfl : m = 0 := by omega rw [runFrom_zero] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega rcases Nat.lt_or_ge m (w.length + 2) with hlt | hge · -- scanning: head at `w.length - m` obtain ⟨d, hd, rfl⟩ : ∃ d, d ≤ w.length ∧ m = 1 + d := ⟨m - 1, by omega, by omega⟩ rw [runFrom_add, hstep1, runFrom_scan hw d hd] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega · obtain rfl : m = w.length + 2 := by omega rw [runFrom_full hw] - constructor - · simp only [cfg, Function.update_self]; omega - · simp only [cfg, Function.update_self]; omega + constructor <;> simp only [cfg, Function.update_self] <;> omega /-- No action of the machine writes to a work tape. -/ lemma tr_write_none (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) From f16021c499a83d0ac8015d42adabbdf46380c667 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 10:41:12 +0000 Subject: [PATCH 48/93] refactor(Turing): Mathlib-readiness polish from review Apply the in-scope naming/visibility/docstring findings of the readiness review (pre-existing origin/main declarations left untouched): * make the internal canonical adapters `exists_transformsTapes_ofComputable{,Input}_fixed` and `step_projCfg` private (used only within their files); * drop the inert `@[expose]` on the lemma-only `StepLemmas` section; * add `## Main results` sections to `Adapters` and `Tidy` (listing `exists_tidy`), fix `AlmostConstant`'s `## Main Results` heading casing; * remove the dangling `Combinators.While` module reference from `Loop`'s docstring. Full `--wfail` build and linters pass; comp and loop remain axiom-clean. Co-Authored-By: Claude Opus 4.8 --- .../MultiTape/Combinators/AlmostConstant.lean | 2 +- .../Turing/MultiTape/Combinators/Loop.lean | 4 ++-- .../Turing/MultiTape/NormalForms/Adapters.lean | 15 +++++++++++++-- .../Turing/MultiTape/NormalForms/Instrument.lean | 2 +- .../Turing/MultiTape/NormalForms/Tidy.lean | 5 +++++ .../Turing/MultiTape/Plumbing/StepLemmas.lean | 2 +- 6 files changed, 23 insertions(+), 7 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean index 950f57961..13399914c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean @@ -20,7 +20,7 @@ cases, it emits the corresponding output one symbol at a time. This result also holds for functions whose domain is already finite. -## Main Results +## Main results * `computableInTimeAndSpace_of_finite`: Every function on a finite type is computable in constant time and zero space, relative to any encoding. diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean index b4836d698..8b1564993 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean @@ -33,8 +33,8 @@ loop ``` This is the form in which the loop is implemented by a machine, since it needs only one machine for -the whole loop body. The usual `while` loop, with a separate condition and body, is derived from it -in `Cslib.Computability.Machines.Turing.MultiTape.Combinators.While`. +the whole loop body. The usual `while` loop, with a separate condition and body, is the special case +obtained by fusing the condition into the body. ## Main definitions diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index d81d875d4..63487d3c5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -27,6 +27,17 @@ interface expects. `exists_transformsTapes_ofComputableInput` is the resulting adapter for a function read from the real input tape. The output tape is the last of `k₀ + 1` work tapes, where `k₀` is the tidy machine's tape count. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_ofComputableInput`: evaluate a computable function, + reading its argument from the real input tape, as a tape transformer on any large-enough layout. +* `Turing.MultiTapeTM.exists_transformsTapes_ofComputable`: the same, reading the argument from a + work tape. +* `Turing.MultiTapeTM.computableInTimeAndSpace_of_transformsTapes`: turn a tape transformer whose + result lands on one work tape back into a computable function, by emitting that tape. +* `Turing.MultiTapeTM.transformsTapes_extendTapes`: a tape transformer stays one after its tapes are + reindexed into a larger layout. -/ @[expose] public section @@ -38,7 +49,7 @@ variable {α β : Type*} /-- **A computable function, read from the input tape, as a tape transformer.** Started with the input on the real input tape and every work tape blank, the machine halts having written the encoded result to the last work tape, in linear time and in space linear in the result length. -/ -public theorem exists_transformsTapes_ofComputableInput_fixed +private theorem exists_transformsTapes_ofComputableInput_fixed {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace g enc encOut t s) : ∃ (c K : ℕ) (o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), @@ -169,7 +180,7 @@ Built from `exists_transformsTapes_ofComputableInput`'s machine `M₀` (which re and leaves the result on a work tape): `inputFromTape M₀` redirects `M₀`'s input reading to the virtual tape, bracketed by two one-cell writes that place and remove the boundary flag `M₀`'s input redirection needs. -/ -public theorem exists_transformsTapes_ofComputable_fixed +private theorem exists_transformsTapes_ofComputable_fixed {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace g enc encOut t s) : ∃ (c K : ℕ) (i o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean index f6f455774..49a1ce0eb 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean @@ -67,7 +67,7 @@ public lemma projCfg_workTapeSymbols (c : Cfg (k + k) Symbol State input) (j : F /-- The projection is a step-semiconjugation: the instrumented machine acts on everything except the footprints exactly as the original does. -/ -public lemma step_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) +private lemma step_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) (c : Cfg (k + k) Symbol State input) : tm.step (projCfg c) = projCfg ((tm.instrument mark).step c) := by cases hq : c.state with diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean index 7ec5374b5..c449bf2f0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -33,6 +33,11 @@ outside-in towards the anchor. ## Main definitions * `Turing.MultiTapeTM.TidyComputes`: the machine computes the function and halts tidily. + +## Main results + +* `Turing.MultiTapeTM.exists_tidy`: every computable function has a tidy machine, at a + constant-factor cost in time and space. -/ namespace Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean index 02095c3ac..f7e2e4a16 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean @@ -25,7 +25,7 @@ min_def, max_def]; split_ifs <;> omega` closes them (`SignType` casts to `ℤ` a `simp`-reducible in Mathlib). The redirection machines are the customers. -/ -@[expose] public section +public section namespace Turing From 15e2245b0ea6793e7d80f5452e0fe52bce528446 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 13:03:48 +0000 Subject: [PATCH 49/93] feat(Turing): streaming-dispatch tool exists_branch_run Add the streaming dispatch combinator on top of the branch machine: a single machine that reads a work-tape symbol and runs one of two given machines to completion, output included. Unlike exists_transformsTapes_branch (which composes output-preserving transformers), the arms may emit, so the combined run's output/halting/space are the chosen arm's plus one dispatch step. This is the tool a case analysis needs to send a branch's result straight to the output tape instead of parking it on a work tape. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Plumbing/Branch.lean | 120 ++++++++++++++++++ 1 file changed, 120 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index 7c5180013..d5152a50a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -148,6 +148,88 @@ private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, wordsCfg, Action.apply, SignType.cast] +/-- The full run when the symbol under tape `i` is `some x`: after the dispatch step the machine +mirrors `tm₁` step for step, so `τ + 1` steps of the branching machine are one dispatch step +followed by `τ` steps of `tm₁`, embedded on the left. -/ +private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : (ws i).head? = some x) : + (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg] + +/-- The full run when the symbol under tape `i` is not `some x`: after the dispatch step the machine +mirrors `tm₂` step for step. -/ +private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ (ws i).head? = some x) : + (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg] + +/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run +of `tm₁` uses exactly `tm₁`'s space, so `τ + 1` steps use at most `tm₁`'s space plus `k`. -/ +private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : (ws i).head? = some x) : + (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_left ws out h] + have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₁) + (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_leftCfg, workTapePos_leftCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ + +/-- Space bound of the right branch. -/ +private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ (ws i).head? = some x) : + (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_right ws out h] + have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₂) + (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_rightCfg, workTapePos_rightCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ + end Branch open Branch in @@ -239,4 +321,42 @@ public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) ( _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega +open Branch in +/-- **Streaming dispatch.** A single machine that reads tape `i`'s first symbol and then runs one +of two given machines to completion — output included. Unlike `exists_transformsTapes_branch` +(which composes output-*preserving* transformers), the arms may emit: the combined machine's +output, halting and space are exactly the chosen arm's, plus one dispatch step (costing `k`). + +Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the +symbol under tape `i` and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. Because +the dispatch and the mirroring embeddings both carry the output through unchanged, the combined +run's output, whether it has halted, and its space are those of the chosen arm's `τ`-step run, +the space paying at most `k` extra for the dispatch step. This is what lets a case analysis send a +branch's result straight to the real output tape instead of parking it on a work tape. -/ +public theorem exists_branch_run {k : ℕ} (i : Fin k) (x : Bool) {S₁ S₂ : Type} + [Finite S₁] [Finite S₂] + (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), + ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), + ((ws i).head? = some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ + ((ws i).head? ≠ some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by + refine ⟨Option (S₁ ⊕ S₂), inferInstance, branch i x tm₁ tm₂, + fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ + · rw [show (branch i x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] + exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ + · rw [show (branch i x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] + exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ + end Turing.MultiTapeTM From 38409b624cf9865984be14c1eff712048d243c24 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 13:34:49 +0000 Subject: [PATCH 50/93] feat(Turing): boolEnc and computableInTimeAndSpace_cond Add the single-symbol Boolean encoding boolEnc and the two-way streaming case analysis computableInTimeAndSpace_cond: the scrutinee bit is materialised on a work tape by the selector transformer, then the streaming dispatch runs the chosen branch to emit its result straight to the output tape. The space bound carries no time term. Includes the private bridges wordsCfg_eq_embed and exists_arm_run. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 306 ++++++++++++++++++ 1 file changed, 306 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean new file mode 100644 index 000000000..f1f4a76dc --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch + +/-! +# Complexity of a case analysis + +A case analysis runs a machine that says which case holds and then continues with the machine for +that case. This file has one primitive, `computableInTimeAndSpace_match`, which does exactly that +for a scrutinee in an arbitrary finite type; `cond`, `ite` and `dite` are the instances at `Bool`. + +## Why the finite case is the primitive and not the binary one + +Lean's `ite` is not primitive: `ite c t e` is `Decidable.casesOn`, the recursor of the two +constructor inductive `Decidable c`, whose constructors carry only proofs. Since `Prop` is erased, +the computational content of `ite` is exactly the recursor of `Bool`, and a `match` on a finite +inductive type is that recursor nested once per constructor. So `Bool.rec` is the primitive of the +*elaborator*. + +It is not the right primitive here, because a machine does not nest. Deciding among `n` cases is +one machine reading a scrutinee of constant length and dispatching from its finite control, which +is no harder than deciding among two; the nesting is a fiction that the machine never performs. +Building the finite case analysis out of the binary one therefore does not decompose it into +anything simpler — it only replays `n - 1` copies of the same argument, and each replay multiplies +the constants, so the bounds have to be renormalised into a fixed shape at every step to make the +induction go through. Taking the finite case as the primitive deletes all of that: what remains of +the arithmetic is three weakenings. + +The two are equivalent up to constant factors in both directions, so there is no loss. Tests for +individual cases, which is what the binary form consumes, and the tag itself, which is what this +one consumes, are interderivable at constant cost: the tag gives every test by one composition +with a function on a finite type, and the tests give the tag by running all `n` of them. There is +consequently no reason to state both. + +## Why this has to be a combinator + +`cond` is a perfectly ordinary computable *function*: as a map `Bool × β × β → β` it reads a tag +and streams out the component it selects, in linear time and no space. But that function does not +give the case analysis, because + +``` +fun a => if c a then f a else g a = cond ∘ (fun a => (c a, f a, g a)) +``` + +computes *both* `f a` and `g a`. That costs `tf + tg` instead of `max tf tg`, it stores both +encoded results on work tapes, and — the real problem — nesting `n` conditionals evaluates `2 ^ n` +branches instead of `n`. The content of a case analysis is that the branch not taken is never run, +and that laziness is not expressible by composing total functions: the machine has to choose before +it runs, which is why this is a combinator with a machine-level branch behind it and not a +consequence of `computableInTimeAndSpace_comp`. + +## The streaming dispatch + +The space bound has no time term in it — a machine computing all the branches would have to park +their encoded outputs on work tapes, and an output's length is bounded only by the time that +produced it, so its space would be `s a + t a`. What buys the pure `s a` is that the branch taken +emits its result *straight to the real output tape*, never parking it. That is why the branch is +run by the streaming dispatch `exists_branch_run`, whose arm is allowed to emit, rather than by the +output-preserving `computableInTimeAndSpace_of_transformsTapes`. The scrutinee, by contrast, ranges +over finitely many values whose encodings have a constant bound on their length, so materialising +it on a work tape costs only `O(1)` space; here it is a single symbol. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_match`: the primitive, a case analysis on a + scrutinee in a finite type. See `CslibTests.Complexity.Combinators` for worked examples. +* `Turing.MultiTapeTM.computableInTimeAndSpace_cond`: the recursor of `Bool`. +* `Turing.MultiTapeTM.computableInTimeAndSpace_ite`: Lean's `ite`, for a decidable predicate. +* `Turing.MultiTapeTM.computableInTimeAndSpace_dite`: Lean's `dite`, whose branches are defined + only under a hypothesis and so are supplied through total extensions. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β : Type*} + +/-- The single-symbol encoding of a Boolean: `true`/`false` become the one-element words `[true]`, +`[false]`. Branching on a tape holding `boolEnc b` reads `b` directly as the head symbol, so the +dispatch of a two-way case analysis is a single-symbol read. -/ +public def boolEnc : Bool ↪ List Bool := ⟨fun b => [b], by intro a b h; simpa using h⟩ + +@[simp] public lemma boolEnc_apply (b : Bool) : boolEnc b = [b] := rfl + +/-- A run of a machine placed by `extendTapes` on tapes that are blank on its range mirrors the +run of the underlying machine, seen through the tape embedding. This is the decomposition of a +word configuration into an embedded configuration: the tapes in the range carry the machine's own +(here blank) words, the tapes outside it are carried through as extra tapes. -/ +private lemma wordsCfg_eq_embed {k kr : ℕ} {Sr : Type} + (tmr : MultiTapeTM kr Bool Sr) (er : Fin kr ↪ Fin k) (input : List Bool) + (ws : Fin k → List Bool) (out : List Bool) (hblank : ∀ j, ws (er j) = []) : + wordsCfg input (some (extendTapes tmr er).q₀) ws out = + embed er (wordsCfg input (some tmr.q₀) (fun _ => []) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases hp : partialInv er l with _ | j + · simp only [embed, hp, wordsCfg] + · rw [← partialInv_eq_some er hp, embed_workTapes_embed] + simp only [wordsCfg, hblank j] + · funext l + rcases hp : partialInv er l with _ | j + · simp only [embed, hp, wordsCfg] + · rw [← partialInv_eq_some er hp, embed_workTapePos_embed] + simp only [wordsCfg] + +/-- **Phase two of the case analysis: run the chosen arm to completion.** Given the streaming +dispatch's guarantee for one arm — that after the dispatch step the combined machine's output, +halting and space are the embedded arm's — and the underlying arm machine's own guarantee that it +halts with the encoded result, the dispatch halts with that result on the output tape, in one more +step than the arm, using at most the arm's space plus twice the layout size. -/ +private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} [Finite Sr] + {tmr : MultiTapeTM kr Bool Sr} {er : Fin kr ↪ Fin k} + {tmd : MultiTapeTM k Bool Sd} {input : List Bool} {ws' : Fin k → List Bool} + {O : List Bool} {τ_br s_br : ℕ} + (hblank : ∀ j, ws' (er j) = []) + (harm : + (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).output = + ((extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).output ∧ + ((tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).state = none ↔ + ((extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).state = none) ∧ + tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) ≤ + (extendTapes tmr er).spaceUsed + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br + k) + (hhalt : (tmr.runFrom (tmr.initCfg input) τ_br).state = none) + (hout : (tmr.runFrom (tmr.initCfg input) τ_br).output = O) + (hsp : tmr.spaceUsed (tmr.initCfg input) τ_br ≤ s_br) : + ∃ u₂ ≤ τ_br + 1, + (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) u₂).state = none ∧ + (∀ m < u₂, (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) m).state ≠ none) ∧ + (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) u₂).output = O ∧ + tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) u₂ ≤ s_br + 2 * k := by + have hinit : tmr.initCfg input = wordsCfg input (some tmr.q₀) (fun _ => []) [] := + initCfg_eq_wordsCfg tmr input + have hdecomp : (extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br = + embed er (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br) + (fun l => tapeOfList (ws' l)) (fun _ => 0) := by + rw [wordsCfg_eq_embed tmr er input ws' [] hblank, runFrom_embed] + -- the embedded arm's output and halting are the raw arm's + have hEout : ((extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).output = O := by + rw [hdecomp] + change (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br).output = O + rw [← hinit, hout] + have hEhalt : ((extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).state = none := by + rw [hdecomp] + change (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br).state = none + rw [← hinit, hhalt] + -- so the dispatch halts at `τ_br + 1` with the result + have hDhalt : (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).state = none := + harm.2.1.mpr hEhalt + have hDout : (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).output = O := + harm.1.trans hEout + -- the embedded arm's space is the raw arm's plus the extra tapes + have hEsp : (extendTapes tmr er).spaceUsed + (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br ≤ s_br + k := by + rw [wordsCfg_eq_embed tmr er input ws' [] hblank] + refine le_trans (spaceUsed_embed_le tmr er _ _ _ τ_br) ?_ + have h1 : tmr.spaceUsed (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br ≤ s_br := by + rw [← hinit]; exact hsp + omega + have hDsp : tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) ≤ s_br + 2 * k := by + refine le_trans harm.2.2 ?_; omega + -- the first halting time is no later, and output and space are inherited + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act⟩ := + exists_minimal_halting_time tmd (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) hDhalt + refine ⟨u₂, hu₂le, hu₂halt, hu₂act, ?_, ?_⟩ + · rw [← hDout]; exact (runFrom_output_eq_of_halt tmd _ hu₂le hu₂halt).symm + · exact le_trans (spaceUsed_mono tmd _ hu₂le) hDsp + +/-- **Complexity of a two-way case analysis**, the recursor of `Bool`. If the scrutinee and both +branches are computable, then so is the case analysis `bif sel a then g a else h a`, in time the +test plus the larger branch and, crucially, space the test plus the larger branch — with no time +term, because the branch taken emits straight to the output tape. The scrutinee is encoded by +`boolEnc`, so the dispatch reads a single symbol. -/ +public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → β} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} + (hsel : ComputableInTimeAndSpace sel encIn boolEnc tc sc) + (hif : ComputableInTimeAndSpace g encIn encOut tif sif) + (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : + ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut + (fun a => c * (tc a + max (tif a) (telse a) + 1)) + (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + classical + obtain ⟨m_c, c_c, Hc⟩ := exists_transformsTapes_ofComputableInput hsel + obtain ⟨kg, Sg, hSg, tmg, Hg⟩ := hif + obtain ⟨kh, Sh, hSh, tmh, Hh⟩ := helse + set K := m_c + kg + kh + 1 with hK + -- tape 0 holds the scrutinee bit; the branch machines live on tapes disjoint from it + have hK0 : 0 < K := by omega + let T_c : Fin K := ⟨0, hK0⟩ + let e_g : Fin kg ↪ Fin K := + ⟨fun j => ⟨1 + j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + let e_h : Fin kh ↪ Fin K := + ⟨fun j => ⟨1 + kg + j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + have hne_g : ∀ j, e_g j ≠ T_c := fun j => Fin.ne_of_val_ne (by change 1 + j.val ≠ 0; omega) + have hne_h : ∀ j, e_h j ≠ T_c := fun j => Fin.ne_of_val_ne (by change 1 + kg + j.val ≠ 0; omega) + -- the scrutinee transformer, leaving `[sel a]` on tape `T_c` + obtain ⟨Sc, hSc, tmc, Hc_spec⟩ := Hc K T_c ∅ (by simp) (by simp only [Finset.card_empty]; omega) + -- the streaming dispatch between the two (embedded) branch machines + obtain ⟨Sd, hSd, tmd, Hd⟩ := + exists_branch_run T_c true (extendTapes tmg e_g) (extendTapes tmh e_h) + -- build with the raw additive bounds, then renormalise once + have main : ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut + (fun a => c_c * (tc a + 1) + (max (tif a) (telse a) + 1)) + (fun a => c_c * (sc a + 1 + 1) + K + (max (sif a) (selse a) + 2 * K)) := by + refine ⟨K, Sc ⊕ Sd, inferInstance, tmc.seq tmd, fun a => ?_⟩ + set start := (tmc.seq tmd).initCfg (encIn a) with hstart + have hstart_words : start = wordsCfg (encIn a) (some (tmc.seq tmd).q₀) (fun _ => []) [] := by + rw [hstart, initCfg_eq_wordsCfg] + -- phase one: the scrutinee transformer leaves `[sel a]` on `T_c`, blank elsewhere + obtain ⟨τ, hτ, ws', hrun1, hQ1, hsp1⟩ := + Hc_spec a (encIn a) (fun _ => []) [] ⟨rfl, fun l _ => rfl⟩ + have hlen : (boolEnc (sel a)).length = 1 := rfl + rw [hlen] at hsp1 + have hc1eq : tmc.runFrom (start.withState (some tmc.q₀)) τ = + wordsCfg (encIn a) none ws' [] := by rw [hstart_words]; exact hrun1 + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tmc (start.withState (some tmc.q₀)) τ (by rw [hc1eq]; rfl) + have hc1eq' : tmc.runFrom (start.withState (some tmc.q₀)) τ' = wordsCfg (encIn a) none ws' [] := + (runFrom_eq_of_halt tmc _ hτ'le hτ'halt).symm.trans hc1eq + have hblank : ∀ l, l ≠ T_c → ws' l = [] := by + intro l hl; rw [hQ1, Function.update_of_ne hl] + have hTc_head : (ws' T_c).head? = some (sel a) := by + rw [hQ1, Function.update_self]; rfl + have hstartws : start.withState (some tmc.q₀) = + wordsCfg (encIn a) (some tmc.q₀) (fun _ => []) [] := by rw [hstart_words]; rfl + have hsp1' : tmc.spaceUsed (start.withState (some tmc.q₀)) τ' ≤ c_c * (sc a + 1 + 1) + K := by + rw [hstartws]; exact le_trans (spaceUsed_mono tmc _ hτ'le) hsp1 + -- phase two: reduce to running the chosen arm to completion + suffices H : ∀ u₂ : ℕ, u₂ ≤ max (tif a) (telse a) + 1 → + (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂).state = none → + (∀ m < u₂, (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) m).state ≠ none) → + (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂).output = + encOut (bif sel a then g a else h a) → + tmd.spaceUsed (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂ ≤ max (sif a) (selse a) + 2 * K → + ∃ t' ≤ c_c * (tc a + 1) + (max (tif a) (telse a) + 1), + ∃ s' ≤ c_c * (sc a + 1 + 1) + K + (max (sif a) (selse a) + 2 * K), + ComputesInTimeAndSpace (tmc.seq tmd) (encIn a) + (encOut (bif sel a then g a else h a)) t' s' by + cases hb : sel a with + | false => + obtain ⟨t'h, ht'hle, s'h, hs'hle, hhstate, hhout, hhsp⟩ := Hh a + have hhead : (ws' T_c).head? ≠ some true := by rw [hTc_head, hb]; simp + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := + exists_arm_run (fun j => hblank (e_h j) (hne_h j)) ((Hd (encIn a) ws' [] t'h).2 hhead) + hhstate hhout (le_trans hhsp.le (le_trans hs'hle (le_max_right (sif a) (selse a)))) + exact H u₂ (by have := le_max_right (tif a) (telse a); omega) hu₂halt hu₂act + (by rw [hb]; exact hu₂out) hu₂sp + | true => + obtain ⟨t'g, ht'gle, s'g, hs'gle, hgstate, hgout, hgsp⟩ := Hg a + have hhead : (ws' T_c).head? = some true := by rw [hTc_head, hb] + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := + exists_arm_run (fun j => hblank (e_g j) (hne_g j)) ((Hd (encIn a) ws' [] t'g).1 hhead) + hgstate hgout (le_trans hgsp.le (le_trans hs'gle (le_max_left (sif a) (selse a)))) + exact H u₂ (by have := le_max_left (tif a) (telse a); omega) hu₂halt hu₂act + (by rw [hb]; exact hu₂out) hu₂sp + intro u₂ hu₂ hu₂halt hu₂act hu₂out hu₂sp + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tmc) (tm₂ := tmd) (c := start) (by rw [hstart_words]; rfl) + hc1eq' rfl hτ'act hsp1' rfl hu₂halt hu₂act hu₂sp + refine ⟨τ' + u₂, by omega, (tmc.seq tmd).spaceUsed start (τ' + u₂), hseq_sp, ?_, ?_, rfl⟩ + · rw [hseq_run]; rfl + · rw [hseq_run]; exact hu₂out + -- renormalise the additive bounds into the stated multiplicative shape + refine ⟨2 * c_c + 3 * K + 2, main.mono (fun a => ?_) (fun a => ?_)⟩ + · -- time + have e1 : c_c * (tc a + 1) ≤ c_c * (tc a + max (tif a) (telse a) + 1) := + Nat.mul_le_mul_left c_c (by omega) + have e2 : c_c * (tc a + max (tif a) (telse a) + 1) + (tc a + max (tif a) (telse a) + 1) = + (c_c + 1) * (tc a + max (tif a) (telse a) + 1) := (Nat.succ_mul c_c _).symm + have e3 : (c_c + 1) * (tc a + max (tif a) (telse a) + 1) ≤ + (2 * c_c + 3 * K + 2) * (tc a + max (tif a) (telse a) + 1) := + Nat.mul_le_mul_right _ (by omega) + omega + · -- space + set mS := max (sif a) (selse a) with hmS + set MS := sc a + mS + 1 with hMS + have P1 : c_c * (sc a + 1 + 1) ≤ 2 * (c_c * MS) := by + have h2 : c_c * (sc a + 1 + 1) ≤ c_c * (MS + 1) := Nat.mul_le_mul_left c_c (by omega) + have h3 : c_c * (MS + 1) = c_c * MS + c_c := Nat.mul_succ c_c MS + have h4 : c_c ≤ c_c * MS := Nat.le_mul_of_pos_right c_c (by omega) + omega + have P3 : 3 * K ≤ 3 * (K * MS) := by + have : K ≤ K * MS := Nat.le_mul_of_pos_right K (by omega) + omega + have expand : (2 * c_c + 3 * K + 2) * MS = 2 * (c_c * MS) + 3 * (K * MS) + 2 * MS := by + rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] + omega + +end Turing.MultiTapeTM From 5c91bd4657d22f4dbb4c232b07555dee52c7220f Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 13:43:46 +0000 Subject: [PATCH 51/93] feat(Turing): finite case analysis computableInTimeAndSpace_match MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Build the finite case-analysis combinator on the streaming two-way cond. A finite set covering the scrutinee's reachable values is inducted on; each step splices in one cond (test sel a = i₀, run br i₀ or the reselected scrutinee's branch), with all bounds renormalised to the fixed shape c*(t a+1), c*(s a+1) so the constants stay absorbed. Derive ite and dite as the decidable-predicate instances. Space bounds carry no time term. Registers the module in Cslib.lean. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 + .../Turing/MultiTape/Combinators/Ite.lean | 240 +++++++++++++++++- 2 files changed, 240 insertions(+), 1 deletion(-) diff --git a/Cslib.lean b/Cslib.lean index 6765bba88..f04d1646e 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -57,6 +57,7 @@ public import Cslib.Computability.Languages.SafetyLiveness public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop public import Cslib.Computability.Machines.Turing.MultiTape.Configuration public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index f1f4a76dc..5b688ea4d 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -118,7 +118,7 @@ dispatch's guarantee for one arm — that after the dispatch step the combined m halting and space are the embedded arm's — and the underlying arm machine's own guarantee that it halts with the encoded result, the dispatch halts with that result on the output tape, in one more step than the arm, using at most the arm's space plus twice the layout size. -/ -private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} [Finite Sr] +private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} {tmr : MultiTapeTM kr Bool Sr} {er : Fin kr ↪ Fin k} {tmd : MultiTapeTM k Bool Sd} {input : List Bool} {ws' : Fin k → List Bool} {O : List Bool} {τ_br s_br : ℕ} @@ -303,4 +303,242 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] omega +/-! ### The finite case analysis + +The finite case analysis is built from `computableInTimeAndSpace_cond` by induction on a finite +set covering the scrutinee's reachable values. Because each inductive step splices in one more +`cond`, whose constants multiply, the bounds are renormalised at every step into the single fixed +shape `fun a => c * (t a + 1)`, `fun a => c * (s a + 1)`; the following three helpers do the +combining and the renormalisation, and the induction then reduces to routing the scrutinee. -/ + +variable {t s : α → ℕ} {encIn : α ↪ List Bool} + +/-- A constant function, in the normalised bound shape. -/ +private lemma const_norm {encOut : β ↪ List Bool} (b : β) : + ∃ c, ComputableInTimeAndSpace (fun _ : α => b) encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_of_const (encIn := encIn) (encOut := encOut) b + exact ⟨c, hc.mono (fun a => Nat.le_mul_of_pos_right c (by omega)) (fun a => Nat.zero_le _)⟩ + +/-- A two-way case analysis of three functions all given in the normalised bound shape stays in +that shape: the `cond` bound `C * (tc + max tif telse + 1)` collapses because every argument is a +constant times `t a + 1`. -/ +private lemma cond_norm {sel : α → Bool} {g h : α → β} {encOut : β ↪ List Bool} + (hsel : ∃ c, ComputableInTimeAndSpace sel encIn boolEnc + (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) + (hg : ∃ c, ComputableInTimeAndSpace g encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) + (hh : ∃ c, ComputableInTimeAndSpace h encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) : + ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + obtain ⟨c1, h1⟩ := hsel + obtain ⟨c2, h2⟩ := hg + obtain ⟨c3, h3⟩ := hh + obtain ⟨C, hC⟩ := computableInTimeAndSpace_cond h1 h2 h3 + refine ⟨C * (c1 + max c2 c3 + 1), hC.mono (fun a => ?_) (fun a => ?_)⟩ + · have hm : max (c2 * (t a + 1)) (c3 * (t a + 1)) ≤ max c2 c3 * (t a + 1) := + max_le (Nat.mul_le_mul_right _ (le_max_left c2 c3)) + (Nat.mul_le_mul_right _ (le_max_right c2 c3)) + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left C ?_ + have hd : (c1 + max c2 c3 + 1) * (t a + 1) = + c1 * (t a + 1) + max c2 c3 * (t a + 1) + (t a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] + omega + · have hm : max (c2 * (s a + 1)) (c3 * (s a + 1)) ≤ max c2 c3 * (s a + 1) := + max_le (Nat.mul_le_mul_right _ (le_max_left c2 c3)) + (Nat.mul_le_mul_right _ (le_max_right c2 c3)) + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left C ?_ + have hd : (c1 + max c2 c3 + 1) * (s a + 1) = + c1 * (s a + 1) + max c2 c3 * (s a + 1) + (s a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] + omega + +/-- The single-bit test `decide (sel a = i₀)`, in the normalised bound shape. Composing the +scrutinee with the almost-constant test `· = i₀` is a `computableInTimeAndSpace_comp`; the extra +terms it introduces — the constant test cost and the encoded scrutinee's length — are absorbed +because the scrutinee's encoded length is bounded by the constant `L`. -/ +private lemma cond_of_sel {ι : Type} [DecidableEq ι] {sel : α → ι} {encι : ι ↪ List Bool} + (i₀ : ι) (L : ℕ) (hL : ∀ a, (encι (sel a)).length ≤ L) + (hsel : ∃ c, ComputableInTimeAndSpace sel encIn encι + (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) : + ∃ c, ComputableInTimeAndSpace (fun a => decide (sel a = i₀)) encIn boolEnc + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + obtain ⟨c_sel, hsel'⟩ := hsel + obtain ⟨cψ, hψ⟩ := computableInTimeAndSpace_of_exists_finite_ne + (f := fun i => decide (i = i₀)) (encIn := encι) (encOut := boolEnc) + ⟨false, by + have hset : {i : ι | (fun i => decide (i = i₀)) i ≠ false} = {i₀} := by ext i; simp + rw [hset]; exact Set.finite_singleton i₀⟩ + obtain ⟨cC, hcomp⟩ := computableInTimeAndSpace_comp hsel' hψ + refine ⟨cC * (c_sel + cψ + L + 2), hcomp.mono (fun a => ?_) (fun a => ?_)⟩ + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cC ?_ + have hL' := hL a + have hexp : (c_sel + cψ + L + 2) * (t a + 1) = + c_sel * (t a + 1) + cψ * (t a + 1) + L * (t a + 1) + 2 * (t a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have h1 : cψ ≤ cψ * (t a + 1) := Nat.le_mul_of_pos_right _ (by omega) + have h2 : L ≤ L * (t a + 1) := Nat.le_mul_of_pos_right _ (by omega) + omega + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cC ?_ + have hL' := hL a + have hbl : (boolEnc (decide (sel a = i₀))).length = 1 := rfl + rw [hbl] + have hexp : (c_sel + cψ + L + 2) * (s a + 1) = + c_sel * (s a + 1) + cψ * (s a + 1) + L * (s a + 1) + 2 * (s a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have h2 : L ≤ L * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + omega + +/-- The engine of `computableInTimeAndSpace_match`: induction on a finite set `R` covering the +scrutinee's values. Everything is carried in the normalised bound shape `c * (t a + 1)`, +`c * (s a + 1)`. At `insert i₀ R'` the scrutinee is split by the test `sel a = i₀`: on `true` the +branch is `br i₀`, on `false` the reselected scrutinee `sel'` lands in `R'` and the induction +hypothesis applies. -/ +private lemma match_aux {ι : Type} {br : ι → α → β} + {encι : ι ↪ List Bool} {encOut : β ↪ List Bool} (R : Finset ι) : + ∀ (sel : α → ι), (∀ a, sel a ∈ R) → + (∀ i ∈ R, ComputableInTimeAndSpace (br i) encIn encOut t s) → + (∃ c, ComputableInTimeAndSpace sel encIn encι + (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) → + ∃ c, ComputableInTimeAndSpace (fun a => br (sel a) a) encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + classical + induction R using Finset.induction_on with + | empty => + intro sel hmem _ _ + have hemp : IsEmpty α := ⟨fun a => absurd (hmem a) (Finset.notMem_empty _)⟩ + let : Fintype α := Fintype.ofIsEmpty + obtain ⟨c, hc⟩ := + computableInTimeAndSpace_of_finite (encIn := encIn) (encOut := encOut) (fun a => br (sel a) a) + exact ⟨c, hc.mono (fun a => Nat.le_mul_of_pos_right c (by omega)) (fun a => Nat.zero_le _)⟩ + | @insert i₀ R' hi₀ IH => + intro sel hmem hbr hsel + by_cases hR'e : R' = ∅ + · subst hR'e + have hall : ∀ a, sel a = i₀ := by + intro a + have hm := hmem a + rw [Finset.mem_insert] at hm + rcases hm with h | h + · exact h + · exact absurd h (Finset.notMem_empty _) + have heq : (fun a => br (sel a) a) = br i₀ := funext fun a => by rw [hall a] + rw [heq] + exact ⟨1, (hbr i₀ (Finset.mem_insert_self i₀ ∅)).mono + (fun a => by omega) (fun a => by omega)⟩ + · obtain ⟨d, hd⟩ := Finset.nonempty_iff_ne_empty.mpr hR'e + have hL : ∀ a, (encι (sel a)).length ≤ (insert i₀ R').sup (fun i => (encι i).length) := + fun a => Finset.le_sup (f := fun i => (encι i).length) (hmem a) + obtain ⟨cc, hcc⟩ := cond_of_sel i₀ _ hL hsel + have hsel' : ∃ c, ComputableInTimeAndSpace + (fun a => bif decide (sel a = i₀) then d else sel a) encIn encι + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := + cond_norm ⟨cc, hcc⟩ (const_norm d) hsel + have hmem' : ∀ a, (fun a => bif decide (sel a = i₀) then d else sel a) a ∈ R' := by + intro a + by_cases h : sel a = i₀ + · simpa [h] using hd + · have hm := hmem a + simp only [Finset.mem_insert, h, false_or] at hm + simpa [h] using hm + obtain ⟨cRec, hRec⟩ := IH (fun a => bif decide (sel a = i₀) then d else sel a) + hmem' (fun i hi => hbr i (Finset.mem_insert_of_mem hi)) hsel' + have hGeq : (fun a => br (sel a) a) = + (fun a => bif decide (sel a = i₀) then br i₀ a + else br (bif decide (sel a = i₀) then d else sel a) a) := by + funext a + by_cases h : sel a = i₀ <;> simp [h] + rw [hGeq] + exact cond_norm ⟨cc, hcc⟩ + ⟨1, (hbr i₀ (Finset.mem_insert_self i₀ R')).mono (fun a => by omega) (fun a => by omega)⟩ + ⟨cRec, hRec⟩ + +/-- **Complexity of a case analysis on a finite type.** If the scrutinee and every branch are +computable, then so is the case analysis. The machine runs the machine for `sel`, redirecting its +output onto a work tape; since the scrutinee's range is finite there are only finitely many +possible contents, all of constant length, so the finite control can tell them apart in constant +time and continue with the machine for the branch that is taken, on the original input. + +What is asked of the scrutinee's type is not that it be finite but that only finitely many of its +values be reachable, which is what the machine needs: finitely many possible contents of the work +tape, of bounded length, for the control to tell apart. For a finite type that is `Set.toFinite _`. + +A single pair of bounds covers the scrutinee and every branch. The number of cases is a constant +of the covering set and is absorbed into the constant factor. What expresses that only the branch +taken is executed is that no time bound appears in the space bound: a machine computing every +branch would have to park their encoded outputs, whose length is bounded only by the time that +produced them, so its space would be `s a + t a`. + +A branch only has to *agree* with the function being computed where it is taken, which is what +`hagree` says; what it does elsewhere is irrelevant, since it is never run there. `f` carries no +information — it is `fun a => br (sel a) a` up to `funext` — but is kept because it is what a caller +has: their goal is a `match`, not an application of the branch family. It is inferred from the +goal, so apply this with `exact` or `refine` rather than `obtain`. -/ +public theorem computableInTimeAndSpace_match {ι : Type} + {sel : α → ι} {f : α → β} {br : ι → α → β} + {encι : ι ↪ List Bool} {encOut : β ↪ List Bool} + (hfin : (Set.range sel).Finite) + (hagree : ∀ a, br (sel a) a = f a) + (hsel : ComputableInTimeAndSpace sel encIn encι t s) + (hbr : ∀ i ∈ Set.range sel, ComputableInTimeAndSpace (br i) encIn encOut t s) : + ∃ c, ComputableInTimeAndSpace f encIn encOut + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + classical + obtain ⟨c, hc⟩ := match_aux hfin.toFinset sel + (fun a => hfin.mem_toFinset.mpr (Set.mem_range_self a)) + (fun i hi => hbr i (hfin.mem_toFinset.mp hi)) + ⟨1, hsel.mono (fun a => by omega) (fun a => by omega)⟩ + refine ⟨c, ?_⟩ + have hf : (fun a => br (sel a) a) = f := funext hagree + rwa [hf] at hc + +/-- **Complexity of Lean's `ite`.** A conditional on a decidable predicate, given a machine that +decides it. This is `computableInTimeAndSpace_cond` read through `decide`: the `Decidable` instance +of `ite` carries no computational content, so all that is needed of the predicate is that its +Boolean test is computable to `boolEnc`. -/ +public theorem computableInTimeAndSpace_ite {p : α → Prop} [DecidablePred p] {g h : α → β} + {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc tc sc) + (hif : ComputableInTimeAndSpace g encIn encOut tif sif) + (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : + ∃ c, ComputableInTimeAndSpace (fun a => if p a then g a else h a) encIn encOut + (fun a => c * (tc a + max (tif a) (telse a) + 1)) + (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_cond hp hif helse + refine ⟨c, ?_⟩ + have hfun : (fun a => bif decide (p a) then g a else h a) = + fun a => if p a then g a else h a := by + funext a; by_cases h : p a <;> simp [h] + rwa [hfun] at hc + +/-- **Complexity of Lean's `dite`.** The branches of a `dite` are not functions of the input alone: +each is defined only under the hypothesis that its case holds, so neither can be asked to be +computable as it stands. What is asked instead is a computable *total* function agreeing with the +branch where that branch is taken. -/ +public theorem computableInTimeAndSpace_dite {p : α → Prop} [DecidablePred p] + {_if : (a : α) → p a → β} {_else : (a : α) → ¬ p a → β} {If Else : α → β} + {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} + (hIf : ∀ a (h : p a), If a = _if a h) + (hElse : ∀ a (h : ¬ p a), Else a = _else a h) + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc tc sc) + (hif : ComputableInTimeAndSpace If encIn encOut tif sif) + (helse : ComputableInTimeAndSpace Else encIn encOut telse selse) : + ∃ c, ComputableInTimeAndSpace (fun a => dite (p a) (_if a) (_else a)) encIn encOut + (fun a => c * (tc a + max (tif a) (telse a) + 1)) + (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_ite (p := p) hp hif helse + refine ⟨c, ?_⟩ + have hfun : (fun a => if p a then If a else Else a) = + fun a => dite (p a) (_if a) (_else a) := by + funext a + by_cases h : p a + · simp [h, hIf a h] + · simp [h, hElse a h] + rwa [hfun] at hc + end Turing.MultiTapeTM From a368919ee1cc015f90ea9b332898b1becfc06ded Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 15:07:50 +0000 Subject: [PATCH 52/93] refactor(Turing): unify state-remap embeddings via Cfg.mapState MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The control-flow combinators (seq, branch, repeat) each embedded a sub-machine's configurations into the combined machine by the same operation — remap the state, leave the input head, work tapes, heads and output alone. Factor that into a single `Cfg.mapState` (with `@[simps]`) in Configuration, plus its `wordsCfg` interaction lemma in TransformsTapes, and rewrite the five `leftCfg`/`rightCfg` embeddings across the three combinators to use it. The run-level semiconjugation was already shared (`runFrom_comm_of_step`); this removes the remaining duplication in the embeddings themselves. `Cfg.mapState` also generalizes the existing `Cfg.withState`. No statement change; full `--wfail` build and linters pass; loop, comp, match, branch and the streaming dispatch remain axiom-clean. Co-Authored-By: Claude Opus 4.8 --- .../Machines/Turing/MultiTape/Configuration.lean | 8 ++++++++ .../Machines/Turing/MultiTape/Plumbing/Branch.lean | 14 ++++++-------- .../Machines/Turing/MultiTape/Plumbing/Repeat.lean | 5 +++-- .../Turing/MultiTape/Plumbing/Sequential.lean | 13 ++++++------- .../Turing/MultiTape/Plumbing/TransformsTapes.lean | 6 ++++++ 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 58994d8dc..0038df9c2 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -194,6 +194,14 @@ abbrev Cfg.Halted (cfg : Cfg k Symbol State input) : Prop := cfg.state = none Cfg k Symbol State input := ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ +/-- Remap the (optional) state of a configuration through `φ`, leaving the input head, the work +tapes, the work-tape heads and the output alone. The control-flow combinators (`seq`, `branch`, +`repeat`) embed a sub-machine's configurations into the combined machine by exactly such a state +remap. -/ +@[simps] def Cfg.mapState {State' : Type*} (φ : Option State → Option State') + (c : Cfg k Symbol State input) : Cfg k Symbol State' input := + ⟨φ c.state, c.inputPos, c.workTapes, c.workTapePos, c.output⟩ + /-- The initial configuration for a starting state and an input string. -/ @[simp] def Cfg.init (q₀ : State) (input : List Symbol) : Cfg k Symbol State input := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index d5152a50a..4765a730e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -66,13 +66,11 @@ variable {i : Fin k} {x : Bool} {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : Multi /-- A configuration of `tm₁`, embedded into the branching machine: a halted state stays halted, a live state is carried by `Sum.inl`. -/ private def leftCfg (cfg : Cfg k Bool S₁ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := - ⟨cfg.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))), cfg.inputPos, cfg.workTapes, - cfg.workTapePos, cfg.output⟩ + cfg.mapState (Option.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) /-- A configuration of `tm₂`, embedded into the branching machine. -/ private def rightCfg (cfg : Cfg k Bool S₂ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := - ⟨cfg.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))), cfg.inputPos, cfg.workTapes, - cfg.workTapePos, cfg.output⟩ + cfg.mapState (Option.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) @[simp] private lemma workTapePos_leftCfg (cfg : Cfg k Bool S₁ input) : @@ -132,8 +130,8 @@ private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) some none := rfl rw [step_apply_of_state hstate] refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, wordsCfg, Action.apply, - SignType.cast] + simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, Cfg.mapState, wordsCfg, + Action.apply, SignType.cast] /-- The dispatch step when the symbol under tape `i` is not `some x`: it lands on `tm₂`'s initial configuration, embedded on the right. -/ @@ -145,8 +143,8 @@ private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) some none := rfl rw [step_apply_of_state hstate] refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, wordsCfg, Action.apply, - SignType.cast] + simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, + Action.apply, SignType.cast] /-- The full run when the symbol under tape `i` is `some x`: after the dispatch step the machine mirrors `tm₁` step for step, so `τ + 1` steps of the branching machine are one dispatch step diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean index 76b8426b6..151822219 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean @@ -70,7 +70,7 @@ variable {i : Fin k} {x : Bool} {tm : MultiTapeTM k Bool State₀} check state `Sum.inr ()`, a live state is carried by `Sum.inl`. Under this map the machine mirrors `tm` step for step while `tm` is live, and lands on the check state exactly when `tm` halts. -/ private def leftCfg (cfg : Cfg k Bool State₀ input) : Cfg k Bool (State₀ ⊕ Unit) input := - ⟨some (cfg.state.elim (.inr ()) .inl), cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + cfg.mapState (fun st => some (st.elim (.inr ()) .inl)) @[simp] private lemma workTapePos_leftCfg (cfg : Cfg k Bool State₀ input) : @@ -84,7 +84,8 @@ private lemma leftCfg_wordsCfg (q : Option State₀) (ws : Fin k → List Bool) private lemma step_leftCfg (cfg : Cfg k Bool State₀ input) (h : cfg.state ≠ none) : (repeatTM i x tm).step (leftCfg cfg) = leftCfg (tm.step cfg) := by obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h - have h1 : (leftCfg cfg).state = some (Sum.inl q : State₀ ⊕ Unit) := by simp [leftCfg, hq] + have h1 : (leftCfg cfg).state = some (Sum.inl q : State₀ ⊕ Unit) := by + simp [leftCfg, Cfg.mapState, hq] simp only [step, h1, hq] rfl diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean index 7043c2c2d..fb435368e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -56,20 +56,19 @@ the initial state of the second phase. Under this map, the whole first phase of run of `tm₀`, *including* its halting step. -/ @[expose] public def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : Cfg k Symbol (State₀ ⊕ State₁) input := - ⟨some (cfg.state.elim (.inr tm₁.q₀) .inl), cfg.inputPos, cfg.workTapes, cfg.workTapePos, - cfg.output⟩ + cfg.mapState (fun st => some (st.elim (.inr tm₁.q₀) .inl)) /-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the run of `tm₁`. -/ @[expose] public def rightCfg (cfg : Cfg k Symbol State₁ input) : Cfg k Symbol (State₀ ⊕ State₁) input := - ⟨cfg.state.map .inr, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + cfg.mapState (Option.map .inr) public lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by - simp [leftCfg, hq] + simp [leftCfg, Cfg.mapState, hq] simp only [step, h1, hq] rfl @@ -77,7 +76,7 @@ public lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by cases hq : cfg.state with | none => - have h1 : (rightCfg (State₀ := State₀) cfg).state = none := by simp [rightCfg, hq] + have h1 : (rightCfg (State₀ := State₀) cfg).state = none := by simp [rightCfg, Cfg.mapState, hq] simp only [step, h1, hq] | some q => have h1 : (rightCfg (State₀ := State₀) cfg).state = some (Sum.inr q : State₀ ⊕ State₁) := by @@ -200,7 +199,7 @@ public lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sy have hmid : (tm₁.seq tm₂).runFrom c u₁ = rightCfg (c₁.withState (some tm₂.q₀)) := by rw [hleft u₁ le_rfl, h₁] refine Cfg.ext ?_ rfl rfl rfl rfl - simp [leftCfg, rightCfg, Cfg.withState, h₁halt] + simp [leftCfg, rightCfg, Cfg.mapState, Cfg.withState, h₁halt] have hright : ∀ m, (tm₁.seq tm₂).runFrom c (u₁ + m) = rightCfg (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m) := by intro m @@ -216,7 +215,7 @@ public lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sy · obtain ⟨m', rfl⟩ : ∃ m', m = u₁ + m' := ⟨m - u₁, by omega⟩ rw [hright m'] have h := h₂act m' (by omega) - simpa only [rightCfg, ne_eq, Option.map_eq_none_iff] using h + simpa only [rightCfg, Cfg.mapState_state, ne_eq, Option.map_eq_none_iff] using h · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) · refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₁ fun m hm => ?_)) h₁sp rw [hleft m hm] diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index 34b3e0ed3..e316b2e38 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -91,6 +91,12 @@ public def wordsCfg (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := ⟨q, 1, fun i => tapeOfList (ws i), fun _ => 0, out⟩ +/-- Remapping the state of a `wordsCfg` remaps its state and leaves the words alone. -/ +@[simp] +public lemma mapState_wordsCfg {State' : Type*} (φ : Option State → Option State') + (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : + (wordsCfg input q ws out).mapState φ = wordsCfg input (φ q) ws out := rfl + /-- The initial configuration is the word configuration with blank tapes and no output. -/ public lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : tm.initCfg input = wordsCfg input (some tm.q₀) (fun _ => []) [] := by From b196faf3174a4a7ef3215ca05f7f0cf2f10d61b4 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 15:29:35 +0000 Subject: [PATCH 53/93] refactor(Turing): share wordsCfg_eq_embed between Adapters and Ite The "a wordsCfg on the big layout is an embed of a wordsCfg on the small layout" fact was proved as a private lemma in both NormalForms/Adapters and Combinators/Ite (the latter re-derived it because the former was private). Make the general version in Adapters public (Adapters is the lowest file importing both `embed` and `wordsCfg`), and have Ite's blank-tape specialization derive from it in two lines instead of re-proving the Cfg.ext argument. No statement change; full --wfail build and linters pass; match stays axiom-clean. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 20 ++++++------------- .../MultiTape/NormalForms/Adapters.lean | 2 +- 2 files changed, 7 insertions(+), 15 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 5b688ea4d..13359f6a5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -95,23 +95,15 @@ public def boolEnc : Bool ↪ List Bool := ⟨fun b => [b], by intro a b h; simp run of the underlying machine, seen through the tape embedding. This is the decomposition of a word configuration into an embedded configuration: the tapes in the range carry the machine's own (here blank) words, the tapes outside it are carried through as extra tapes. -/ -private lemma wordsCfg_eq_embed {k kr : ℕ} {Sr : Type} +private lemma wordsCfg_eq_embed_blank {k kr : ℕ} {Sr : Type} (tmr : MultiTapeTM kr Bool Sr) (er : Fin kr ↪ Fin k) (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (hblank : ∀ j, ws (er j) = []) : wordsCfg input (some (extendTapes tmr er).q₀) ws out = embed er (wordsCfg input (some tmr.q₀) (fun _ => []) out) (fun l => tapeOfList (ws l)) (fun _ => 0) := by - refine Cfg.ext rfl rfl ?_ ?_ rfl - · funext l - rcases hp : partialInv er l with _ | j - · simp only [embed, hp, wordsCfg] - · rw [← partialInv_eq_some er hp, embed_workTapes_embed] - simp only [wordsCfg, hblank j] - · funext l - rcases hp : partialInv er l with _ | j - · simp only [embed, hp, wordsCfg] - · rw [← partialInv_eq_some er hp, embed_workTapePos_embed] - simp only [wordsCfg] + change wordsCfg input (some tmr.q₀) ws out = _ + rw [wordsCfg_eq_embed er input (some tmr.q₀) ws out, + show (fun j => ws (er j)) = (fun _ => []) from funext hblank] /-- **Phase two of the case analysis: run the chosen arm to completion.** Given the streaming dispatch's guarantee for one arm — that after the dispatch step the combined machine's output, @@ -147,7 +139,7 @@ private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br = embed er (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br) (fun l => tapeOfList (ws' l)) (fun _ => 0) := by - rw [wordsCfg_eq_embed tmr er input ws' [] hblank, runFrom_embed] + rw [wordsCfg_eq_embed_blank tmr er input ws' [] hblank, runFrom_embed] -- the embedded arm's output and halting are the raw arm's have hEout : ((extendTapes tmr er).runFrom (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).output = O := by @@ -167,7 +159,7 @@ private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} -- the embedded arm's space is the raw arm's plus the extra tapes have hEsp : (extendTapes tmr er).spaceUsed (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br ≤ s_br + k := by - rw [wordsCfg_eq_embed tmr er input ws' [] hblank] + rw [wordsCfg_eq_embed_blank tmr er input ws' [] hblank] refine le_trans (spaceUsed_embed_le tmr er _ _ _ τ_br) ?_ have h1 : tmr.spaceUsed (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br ≤ s_br := by rw [← hinit]; exact hsp diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean index 63487d3c5..b9958923a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -468,7 +468,7 @@ public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Ty /-- A `wordsCfg` over `k'` tapes, viewed as the `k`-tape `wordsCfg` on the tapes selected by `e`, embedded with the remaining tapes carrying the leftover words. -/ -private lemma wordsCfg_eq_embed {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k') +public lemma wordsCfg_eq_embed {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k') (input : List Bool) (q : Option State) (ws : Fin k' → List Bool) (out : List Bool) : wordsCfg input q ws out = embed e (wordsCfg input q (fun j => ws (e j)) out) From 41de338ab6a833e9aee43420ac25e148bc457f89 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 16:23:32 +0000 Subject: [PATCH 54/93] feat(Turing): input-symbol dispatch machine exists_inputBranch_run Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 + .../MultiTape/Plumbing/InputBranch.lean | 272 ++++++++++++++++++ 2 files changed, 273 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean diff --git a/Cslib.lean b/Cslib.lean index f04d1646e..d74447b4b 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -72,6 +72,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputBranch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean new file mode 100644 index 000000000..9c1ca6f95 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Mathlib.Data.Fintype.Option +public import Mathlib.Basic.Finite.Sum + +/-! +# Branching on the input's first symbol + +`inputBranch x tm₁ tm₂` first reads the symbol under the input head and then, depending on whether +that symbol equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its initial state on +the tapes as they were. It is the input-tape analogue of `Plumbing/Branch.lean`: the dispatch reads +the *input* symbol rather than a work-tape symbol, so the two arms then read the whole input in +place — the dispatch step writes nothing and moves no head — and may emit their result straight to +the real output tape. + +At a starting `wordsCfg` the input head sits at the first input symbol, so the dispatch reads +exactly `input.head?`, the predicate the specification branches on. + +## Main results + +* `Turing.MultiTapeTM.exists_inputBranch_run`: a single machine that reads the input's first symbol + and runs one of two given machines to completion — output included — plus one dispatch step. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} + +/-- The symbol under the input head of a `wordsCfg` is the input's first symbol: the head is at +position `1`, over `input[0]` when the input is nonempty and at the right boundary otherwise. -/ +public lemma inputSymbol_wordsCfg {State : Type*} (input : List Bool) (q : Option State) + (ws : Fin k → List Bool) (out : List Bool) : + (wordsCfg input q ws out).inputSymbol = input.head? := by + cases input with + | nil => simp only [wordsCfg, Cfg.inputSymbol]; rfl + | cons b t => + rw [inputSymbolInner 0 (by simp [wordsCfg]) (by simp)] + simp + +namespace InputBranch + +/-- The input-branching machine. State `none` is a fresh dispatch state: it reads the symbol under +the input head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial +state (if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, +its states carried by `Sum.inl`/`Sum.inr`. -/ +private def inputBranch (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) + (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where + q₀ := none + tr q inp work := + match q with + | none => + { inputTape := 0 + workTapes := fun _ => (none, 0) + output := none + state := if inp = some x then some (some (Sum.inl tm₁.q₀)) + else some (some (Sum.inr tm₂.q₀)) } + | some (Sum.inl q₁) => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))) } + | some (Sum.inr q₂) => + let a := tm₂.tr q₂ inp work + { a with state := a.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))) } + +variable {x : Bool} {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} + +/-- A configuration of `tm₁`, embedded into the branching machine. -/ +private def leftCfg (cfg : Cfg k Bool S₁ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + cfg.mapState (Option.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) + +/-- A configuration of `tm₂`, embedded into the branching machine. -/ +private def rightCfg (cfg : Cfg k Bool S₂ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + cfg.mapState (Option.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) + +@[simp] +private lemma workTapePos_leftCfg (cfg : Cfg k Bool S₁ input) : + (leftCfg (S₂ := S₂) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma workTapePos_rightCfg (cfg : Cfg k Bool S₂ input) : + (rightCfg (S₁ := S₁) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma leftCfg_wordsCfg (q : Option S₁) (ws : Fin k → List Bool) (out : List Bool) : + leftCfg (S₂ := S₂) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +@[simp] +private lemma rightCfg_wordsCfg (q : Option S₂) (ws : Fin k → List Bool) (out : List Bool) : + rightCfg (S₁ := S₁) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. -/ +private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : + (inputBranch x tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [leftCfg, hq]), step_of_halt hq] + | some q => + have h1 : (leftCfg (S₂ := S₂) cfg).state = some (some (Sum.inl q)) := by simp [leftCfg, hq] + simp only [step, h1, hq] + rfl + +/-- On `tm₂`'s configurations, the branching machine mirrors `tm₂` step for step. -/ +private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : + (inputBranch x tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [rightCfg, hq]), step_of_halt hq] + | some q => + have h1 : (rightCfg (S₁ := S₁) cfg).state = some (some (Sum.inr q)) := by simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +private lemma runFrom_leftCfg (cfg : Cfg k Bool S₁ input) (n : ℕ) : + (inputBranch x tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step leftCfg (fun c => step_leftCfg c) cfg n + +private lemma runFrom_rightCfg (cfg : Cfg k Bool S₂ input) (n : ℕ) : + (inputBranch x tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-- The dispatch step when the input's first symbol is `some x`: it lands on `tm₁`'s initial +configuration, embedded on the left. -/ +private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate, inputSymbol_wordsCfg] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [inputBranch, h, leftCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] + +/-- The dispatch step when the input's first symbol is not `some x`: it lands on `tm₂`'s initial +configuration, embedded on the right. -/ +private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate, inputSymbol_wordsCfg] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [inputBranch, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] + +/-- The full run when the input's first symbol is `some x`: after the dispatch step the machine +mirrors `tm₁` step for step. -/ +private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg] + +/-- The full run when the input's first symbol is not `some x`. -/ +private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg] + +/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run +of `tm₁` uses exactly `tm₁`'s space. -/ +private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by + have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_left ws out h] + have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₁) + (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_leftCfg, workTapePos_leftCfg] + calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ + +/-- Space bound of the right branch. -/ +private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by + have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_right ws out h] + have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₂) + (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_rightCfg, workTapePos_rightCfg] + calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ + +end InputBranch + +open InputBranch in +/-- **Streaming dispatch on the input.** A single machine that reads the input's first symbol and +then runs one of two given machines to completion — output included. The arms read the whole input +in place (the dispatch moves no head) and may emit: the combined machine's output, halting and +space are exactly the chosen arm's, plus one dispatch step (costing at most `k`). + +Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the +input's first symbol and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. This is +what lets a case analysis send a branch's result straight to the real output tape instead of +parking it. -/ +public theorem exists_inputBranch_run {k : ℕ} (x : Bool) {S₁ S₂ : Type} + [Finite S₁] [Finite S₂] + (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), + ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), + (input.head? = some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ + (input.head? ≠ some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by + refine ⟨Option (S₁ ⊕ S₂), inferInstance, inputBranch x tm₁ tm₂, + fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ + · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] + exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ + · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] + exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ + +end Turing.MultiTapeTM From 4e855409e0f4255cbbfbce3650e0e79aae20d171 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 16:29:06 +0000 Subject: [PATCH 55/93] feat(Turing): computableInTimeAndSpace_iteFirstBit atom Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 83 +++++++++++++++++++ 1 file changed, 83 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 13359f6a5..86f194659 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -9,6 +9,8 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputBranch +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters /-! # Complexity of a case analysis @@ -173,6 +175,87 @@ private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} · rw [← hDout]; exact (runFrom_output_eq_of_halt tmd _ hu₂le hu₂halt).symm · exact le_trans (spaceUsed_mono tmd _ hu₂le) hDsp +/-- **The elementary two-way branch on the input's first symbol.** If `g` and `h` are computable, +then so is the function that runs `g` when the input's first encoded symbol is `some true` and `h` +otherwise. The dispatch reads the input directly, so both arms then read the whole input in place +and emit their result straight to the real output tape — no scrutinee is materialised, and there is +no time term in the space bound. + +This is the atom on which the whole conditional family is rebuilt: `cond`, `ite`, `dite` and the +finite `match` all reduce to it by tagging the input with a selector bit and stripping the tag in +each arm. -/ +public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tg sg th sh : α → ℕ} + (hg : ComputableInTimeAndSpace g encIn encOut tg sg) + (hh : ComputableInTimeAndSpace h encIn encOut th sh) : + ∃ c, ComputableInTimeAndSpace + (fun a => if (encIn a).head? = some true then g a else h a) encIn encOut + (fun a => c * (tg a + th a + 1)) (fun a => c * (sg a + sh a + 1)) := by + classical + obtain ⟨kg, Sg, hSg, tmg, Hg⟩ := hg + obtain ⟨kh, Sh, hSh, tmh, Hh⟩ := hh + set K := kg + kh with hK + -- the two branch machines live on disjoint blocks of a shared `K`-tape layout + let e_g : Fin kg ↪ Fin K := + ⟨fun j => ⟨j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + let e_h : Fin kh ↪ Fin K := + ⟨fun j => ⟨kg + j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + -- the streaming input-dispatch between the two (embedded) branch machines + obtain ⟨Sd, hSd, tmd, Hd⟩ := + exists_inputBranch_run true (extendTapes tmg e_g) (extendTapes tmh e_h) + refine ⟨2 * K + 1, K, Sd, hSd, tmd, fun a => ?_⟩ + -- reduce to running the chosen arm to completion on all-blank work tapes + by_cases hb : (encIn a).head? = some true + · -- the input starts with `true`: run `g`'s machine + obtain ⟨t'g, ht'gle, s'g, hs'gle, hgstate, hgout, hgsp⟩ := Hg a + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := + exists_arm_run (er := e_g) (fun _ => rfl) + ((Hd (encIn a) (fun _ => []) [] t'g).1 hb) hgstate hgout hgsp.le + refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ + · -- time: `u₂ ≤ t'g + 1 ≤ tg a + 1` + have hu : u₂ ≤ tg a + 1 := by omega + have h2 : tg a + 1 ≤ tg a + th a + 1 := by omega + exact le_trans hu (le_trans h2 (Nat.le_mul_of_pos_left _ (by omega))) + · -- space: `≤ s'g + 2K ≤ sg a + 2K` + show tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) + have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sg a + 2 * K := by + rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) + refine le_trans hle ?_ + have hexp : (2 * K + 1) * (sg a + sh a + 1) = + (2 * K + 1) * (sg a + sh a) + (2 * K + 1) := Nat.mul_succ _ _ + have hge : sg a ≤ (2 * K + 1) * (sg a + sh a) := by + have h2 : sg a + sh a ≤ (2 * K + 1) * (sg a + sh a) := + Nat.le_mul_of_pos_left _ (by omega) + omega + omega + · rw [initCfg_eq_wordsCfg]; exact hu₂halt + · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] + · rfl + · -- otherwise: run `h`'s machine + obtain ⟨t'h, ht'hle, s'h, hs'hle, hhstate, hhout, hhsp⟩ := Hh a + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := + exists_arm_run (er := e_h) (fun _ => rfl) + ((Hd (encIn a) (fun _ => []) [] t'h).2 hb) hhstate hhout hhsp.le + refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ + · have : u₂ ≤ th a + 1 := by omega + exact le_trans this (le_trans (by omega) (Nat.le_mul_of_pos_left _ (by omega))) + · show tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) + have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sh a + 2 * K := by + rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) + refine le_trans hle ?_ + have hexp : (2 * K + 1) * (sg a + sh a + 1) = + (2 * K + 1) * (sg a + sh a) + (2 * K + 1) := Nat.mul_succ _ _ + have hge : sh a ≤ (2 * K + 1) * (sg a + sh a) := by + have h2 : sg a + sh a ≤ (2 * K + 1) * (sg a + sh a) := + Nat.le_mul_of_pos_left _ (by omega) + omega + omega + · rw [initCfg_eq_wordsCfg]; exact hu₂halt + · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] + · rfl + /-- **Complexity of a two-way case analysis**, the recursor of `Bool`. If the scrutinee and both branches are computable, then so is the case analysis `bif sel a then g a else h a`, in time the test plus the larger branch and, crucially, space the test plus the larger branch — with no time From adffe15509457e7feceecfe694ccdd0894ead2db Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 16:51:58 +0000 Subject: [PATCH 56/93] feat(Turing): computableInTimeAndSpace_concat and _pair atoms Streaming concatenation via two tidy machines writing to the shared append-only output tape; relaxed multiplicative bounds. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 + .../Turing/MultiTape/Combinators/Concat.lean | 287 ++++++++++++++++++ 2 files changed, 288 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean diff --git a/Cslib.lean b/Cslib.lean index d74447b4b..ed41a241f 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -56,6 +56,7 @@ public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean new file mode 100644 index 000000000..4d9138e09 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential + +/-! +# Complexity of a concatenation of two functions + +If `f` and `g` are computable, then so is any function whose encoded result is the encoded result +of `f` followed by the encoded result of `g`. The machine runs a *tidy* machine for `f`, which +halts with `encB (f x)` on the append-only output tape and every work tape blank and the input head +rewound, and then a tidy machine for `g` on disjoint work tapes, which appends `encC (g x)` to the +same output tape. The intermediate results are never stored on a work tape: both machines write +straight to the output, which is append-only, so the outputs end up concatenated. + +Because the tidy machine rewinds the input head and re-blanks its work tapes, the configuration +between the two phases is again a clean word configuration, and the second machine reads the same +input as the first with no explicit rewinding step in between. + +This is the introduction rule of a finite product, dual to the case analysis of +`Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite`. Note that only the *syntactic* +factorisation of the encoding is required: producing a pair asks nothing of the encoding beyond +`henc`; reading a component back out is a genuine computability requirement, handled elsewhere. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_concat`: the complexity of a concatenation. +* `Turing.MultiTapeTM.computableInTimeAndSpace_pair`: the special case of a pair. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β γ δ : Type*} {k : ℕ} {State : Type*} {input : List Bool} + +/-- Running from a configuration with a nonempty output tape is the same as running from the empty +one and prepending: the transition never reads the output, so its only effect on the run is a +constant prefix on the final output tape. -/ +private lemma step_withOutput_prepend (tm : MultiTapeTM k Bool State) (Y : List Bool) + (c : Cfg k Bool State input) : + tm.step (c.withOutput (Y ++ c.output)) = + (tm.step c).withOutput (Y ++ (tm.step c).output) := by + cases hq : c.state with + | none => + have h1 : (c.withOutput (Y ++ c.output)).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (c.withOutput (Y ++ c.output)).state = some q := hq + have hin : (c.withOutput (Y ++ c.output)).inputSymbol = c.inputSymbol := rfl + have hws : (c.withOutput (Y ++ c.output)).workTapeSymbols = c.workTapeSymbols := rfl + rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] + refine Cfg.ext rfl rfl rfl rfl ?_ + simp only [Action.apply_output, Cfg.withOutput_output, List.append_assoc] + +/-- The run from a configuration with output `Y ++ c.output` is the run from `c` with `Y` prepended +to the final output. -/ +private lemma runFrom_withOutput_prepend (tm : MultiTapeTM k Bool State) (Y : List Bool) + (c : Cfg k Bool State input) (n : ℕ) : + tm.runFrom (c.withOutput (Y ++ c.output)) n = + (tm.runFrom c n).withOutput (Y ++ (tm.runFrom c n).output) := + runFrom_comm_of_step (fun c => c.withOutput (Y ++ c.output)) + (fun c => step_withOutput_prepend tm Y c) c n + +/-- Replacing the output of a word configuration is again a word configuration. -/ +private lemma withOutput_wordsCfg (q : Option State) (ws : Fin k → List Bool) (o z : List Bool) : + (wordsCfg input q ws o).withOutput z = wordsCfg input q ws z := rfl + +/-- An all-blank word configuration on `k` tapes, embedded through `er` with blank extra tapes, is +that same all-blank word configuration. Both hold the empty word on every tape with every head at +the start. -/ +private lemma embed_blank_collapse {kr : ℕ} {Sr : Type} (er : Fin kr ↪ Fin k) + (input : List Bool) (q : Option Sr) (out : List Bool) : + embed er (wordsCfg input q (fun _ => []) out) (fun _ _ => none) (fun _ => 0) = + wordsCfg input q (fun _ => []) out := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + simp only [embed, wordsCfg_workTapes] + cases partialInv er l <;> simp [tapeOfList_nil] + · funext l; simp only [embed, wordsCfg_workTapePos]; cases partialInv er l <;> rfl + +/-- **Bridge: an all-blank run of a reindexed machine mirrors the underlying machine.** If the +underlying machine `tmr`, started on blank tapes with output `outS`, halts on blank tapes with +output `outF`, then so does `extendTapes tmr er` on the larger blank layout. Both endpoints are +all-blank word configurations, so the tape embedding collapses on each side. -/ +private lemma extendTapes_run_blank {kr : ℕ} {Sr : Type} (tmr : MultiTapeTM kr Bool Sr) + (er : Fin kr ↪ Fin k) (input outS outF : List Bool) (n : ℕ) + (hrun : tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) outS) n = + wordsCfg input none (fun _ => []) outF) : + (extendTapes tmr er).runFrom + (wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS) n = + wordsCfg input none (fun _ => []) outF := by + have hstart : wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS = + embed er (wordsCfg input (some tmr.q₀) (fun _ => []) outS) (fun _ _ => none) (fun _ => 0) := + (embed_blank_collapse er input (some tmr.q₀) outS).symm + rw [hstart, runFrom_embed, hrun, embed_blank_collapse] + +/-- **Bridge for space.** The space used by a reindexed all-blank run is that of the underlying +run plus at most one cell for each of the extra tapes. -/ +private lemma spaceUsed_extendTapes_blank {kr : ℕ} {Sr : Type} (tmr : MultiTapeTM kr Bool Sr) + (er : Fin kr ↪ Fin k) (input outS : List Bool) (n : ℕ) : + (extendTapes tmr er).spaceUsed + (wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS) n ≤ + tmr.spaceUsed (wordsCfg input (some tmr.q₀) (fun _ => []) outS) n + (k - kr) := by + rw [show wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS = + embed er (wordsCfg input (some tmr.q₀) (fun _ => []) outS) (fun _ _ => none) (fun _ => 0) from + (embed_blank_collapse er input (some tmr.q₀) outS).symm] + exact spaceUsed_embed_le tmr er _ _ _ n + +/-- **Complexity of a concatenation.** If `f` and `g` are computable and the encoded result of `h` +is the encoded result of `f` followed by the encoded result of `g`, then `h` is computable: run a +tidy machine for `f`, whose result is emitted to the output tape, then a tidy machine for `g` on +disjoint work tapes, which appends its result to the same output tape. + +The bound is stated in the relaxed multiplicative shape `c * (… + 1)`: nothing downstream needs it +tight, and the space bound carries no output-length term because neither result is ever parked on a +work tape. -/ +public theorem computableInTimeAndSpace_concat + {f : α → β} {g : α → γ} {h : α → δ} + {encIn : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} {encD : δ ↪ List Bool} + {tf sf tg sg : α → ℕ} + (henc : ∀ x, encD (h x) = encB (f x) ++ encC (g x)) + (hf : ComputableInTimeAndSpace f encIn encB tf sf) + (hg : ComputableInTimeAndSpace g encIn encC tg sg) : + ∃ c, ComputableInTimeAndSpace h encIn encD + (fun x => c * (tf x + tg x + 1)) + (fun x => c * (sf x + sg x + 1)) := by + classical + obtain ⟨cf, kf, Sf, hSf, tmf, Hf⟩ := exists_tidy hf + obtain ⟨cg, kg, Sg, hSg, tmg, Hg⟩ := exists_tidy hg + have := hSf; have := hSg + set K := kf + kg with hK + let e_f : Fin kf ↪ Fin K := + ⟨fun j => ⟨j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + let e_g : Fin kg ↪ Fin K := + ⟨fun j => ⟨kf + j.val, by have := j.isLt; omega⟩, + fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ + -- the composed machine and the additive-bound version of the claim + have main : ComputableInTimeAndSpace h encIn encD + (fun x => cf * (tf x + 1) + cg * (tg x + 1)) + (fun x => (cf * (sf x + 1) + kf + K) + (cg * (sg x + 1) + kg + K)) := by + refine ⟨K, Sf ⊕ Sg, inferInstance, (extendTapes tmf e_f).seq (extendTapes tmg e_g), fun x => ?_⟩ + obtain ⟨τf, hτf, hrunf, hspf⟩ := Hf x + obtain ⟨τg, hτg, hrung, hspg⟩ := Hg x + -- beta-reduce the tidy bounds so the arithmetic solvers see them + replace hτf : τf ≤ cf * (tf x + 1) := hτf + replace hspf : tmf.spaceUsed (tmf.initCfg (encIn x)) τf ≤ cf * (sf x + 1) + kf := hspf + replace hτg : τg ≤ cg * (tg x + 1) := hτg + replace hspg : tmg.spaceUsed (tmg.initCfg (encIn x)) τg ≤ cg * (sg x + 1) + kg := hspg + set start := ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).initCfg (encIn x) with hstart + have hstart_words : start = wordsCfg (encIn x) + (some ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).q₀) (fun _ => []) [] := by + rw [hstart, initCfg_eq_wordsCfg] + -- the raw `tmg` run started with `encB (f x)` already on the output tape, via prepending + have hrung' : tmg.runFrom (wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x))) τg = + wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := by + have hstart_eq : + wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x)) = + (tmg.initCfg (encIn x)).withOutput + (encB (f x) ++ (tmg.initCfg (encIn x)).output) := by + rw [initCfg_eq_wordsCfg, wordsCfg_output, List.append_nil, withOutput_wordsCfg] + rw [hstart_eq, runFrom_withOutput_prepend, hrung, + wordsCfg_output, withOutput_wordsCfg, henc] + -- phase 1 and phase 2 as reindexed all-blank runs + have hMf : (extendTapes tmf e_f).runFrom + (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) τf = + wordsCfg (encIn x) none (fun _ => []) (encB (f x)) := + extendTapes_run_blank tmf e_f (encIn x) [] (encB (f x)) τf + (by rw [← initCfg_eq_wordsCfg]; exact hrunf) + have hMg : (extendTapes tmg e_g).runFrom + (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) τg = + wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := + extendTapes_run_blank tmg e_g (encIn x) (encB (f x)) (encD (h x)) τg hrung' + -- first halting times, for the activity hypotheses + obtain ⟨u₁, hu₁le, hu₁halt, hu₁act⟩ := + exists_minimal_halting_time (extendTapes tmf e_f) + (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) τf (by rw [hMf]; rfl) + have hMf' : (extendTapes tmf e_f).runFrom + (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) u₁ = + wordsCfg (encIn x) none (fun _ => []) (encB (f x)) := + (runFrom_eq_of_halt _ _ hu₁le hu₁halt).symm.trans hMf + obtain ⟨u₂, hu₂le, hu₂halt, hu₂act⟩ := + exists_minimal_halting_time (extendTapes tmg e_g) + (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) τg + (by rw [hMg]; rfl) + have hMg' : (extendTapes tmg e_g).runFrom + (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) u₂ = + wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := + (runFrom_eq_of_halt _ _ hu₂le hu₂halt).symm.trans hMg + -- space bounds for the two phases, via the space bridge + have hspf' : (extendTapes tmf e_f).spaceUsed + (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) u₁ ≤ + cf * (sf x + 1) + kf + K := by + refine le_trans (spaceUsed_extendTapes_blank tmf e_f (encIn x) [] u₁) ?_ + rw [← initCfg_eq_wordsCfg] + have hb : tmf.spaceUsed (tmf.initCfg (encIn x)) u₁ ≤ cf * (sf x + 1) + kf := + le_trans (spaceUsed_mono tmf _ hu₁le) hspf + omega + have hspg' : (extendTapes tmg e_g).spaceUsed + (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) u₂ ≤ + cg * (sg x + 1) + kg + K := by + refine le_trans (spaceUsed_extendTapes_blank tmg e_g (encIn x) (encB (f x)) u₂) ?_ + -- the raw run's space is output-independent, so the tidy bound (at `initCfg`) controls it + have hsp_out : + tmg.spaceUsed (wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x))) u₂ = + tmg.spaceUsed (tmg.initCfg (encIn x)) u₂ := by + have hstart_eq : + wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x)) = + (tmg.initCfg (encIn x)).withOutput + (encB (f x) ++ (tmg.initCfg (encIn x)).output) := by + rw [initCfg_eq_wordsCfg, wordsCfg_output, List.append_nil, withOutput_wordsCfg] + rw [hstart_eq] + refine spaceUsed_eq_of_workTapePos _ _ u₂ fun m _ => ?_ + rw [runFrom_withOutput_prepend]; rfl + rw [hsp_out] + have hb : tmg.spaceUsed (tmg.initCfg (encIn x)) u₂ ≤ cg * (sg x + 1) + kg := + le_trans (spaceUsed_mono tmg _ hu₂le) hspg + omega + -- assemble the two phases; the phase start configurations are word configurations + have hcwf : start.withState (some (extendTapes tmf e_f).q₀) = + wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) [] := by + rw [hstart_words]; rfl + have hcwg : + (wordsCfg (k := K) (State := Sf) (encIn x) none (fun _ => []) (encB (f x))).withState + (some (extendTapes tmg e_g).q₀) = + wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x)) := rfl + rw [← hcwf] at hMf' hu₁act hspf' + rw [← hcwg] at hMg' hu₂act hspg' + obtain ⟨hseq_run, _hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := extendTapes tmf e_f) (tm₂ := extendTapes tmg e_g) (c := start) + (c₁ := wordsCfg (encIn x) none (fun _ => []) (encB (f x))) + (c₂ := wordsCfg (encIn x) none (fun _ => []) (encD (h x))) + (by rw [hstart_words]; rfl) + hMf' rfl hu₁act hspf' + hMg' rfl hu₂act hspg' + refine ⟨u₁ + u₂, (by omega : u₁ + u₂ ≤ cf * (tf x + 1) + cg * (tg x + 1)), + ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).spaceUsed start (u₁ + u₂), hseq_sp, + ?_, ?_, rfl⟩ + · rw [hseq_run]; rfl + · rw [hseq_run]; rfl + -- renormalise the additive bounds into the stated multiplicative shape + refine ⟨cf + cg + 3 * K + 1, main.mono (fun x => ?_) (fun x => ?_)⟩ + · -- time: `cf·(tf+1) + cg·(tg+1) ≤ (cf+cg)·(tf+tg+1) ≤ D·(tf+tg+1)` + set D := cf + cg + 3 * K + 1 with hD + have ha : cf * (tf x + 1) ≤ cf * (tf x + tg x + 1) := Nat.mul_le_mul le_rfl (by omega) + have hb : cg * (tg x + 1) ≤ cg * (tf x + tg x + 1) := Nat.mul_le_mul le_rfl (by omega) + have hsum : cf * (tf x + tg x + 1) + cg * (tf x + tg x + 1) = + (cf + cg) * (tf x + tg x + 1) := (Nat.add_mul _ _ _).symm + have hDle : (cf + cg) * (tf x + tg x + 1) ≤ D * (tf x + tg x + 1) := + Nat.mul_le_mul (by omega) le_rfl + omega + · -- space: `cf·(sf+1) + cg·(sg+1) + 3K ≤ (cf+cg+3K)·(sf+sg+1) ≤ D·(sf+sg+1)` + set D := cf + cg + 3 * K + 1 with hD + have ha : cf * (sf x + 1) ≤ cf * (sf x + sg x + 1) := Nat.mul_le_mul le_rfl (by omega) + have hb : cg * (sg x + 1) ≤ cg * (sf x + sg x + 1) := Nat.mul_le_mul le_rfl (by omega) + have hsum : cf * (sf x + sg x + 1) + cg * (sf x + sg x + 1) = + (cf + cg) * (sf x + sg x + 1) := (Nat.add_mul _ _ _).symm + have hkk : 3 * K ≤ (3 * K) * (sf x + sg x + 1) := Nat.le_mul_of_pos_right _ (by omega) + have hsum2 : (cf + cg) * (sf x + sg x + 1) + (3 * K) * (sf x + sg x + 1) = + (cf + cg + 3 * K) * (sf x + sg x + 1) := (Nat.add_mul _ _ _).symm + have hDle : (cf + cg + 3 * K) * (sf x + sg x + 1) ≤ D * (sf x + sg x + 1) := + Nat.mul_le_mul (by omega) le_rfl + omega + +/-- **Complexity of computing a pair.** The special case of `computableInTimeAndSpace_concat` in +which the two results are packed into a pair, encoded by concatenating the two encodings. -/ +public theorem computableInTimeAndSpace_pair + {f : α → β} {g : α → γ} + {encIn : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} + {encPair : β × γ ↪ List Bool} {tf sf tg sg : α → ℕ} + (henc : ∀ p : β × γ, encPair p = encB p.1 ++ encC p.2) + (hf : ComputableInTimeAndSpace f encIn encB tf sf) + (hg : ComputableInTimeAndSpace g encIn encC tg sg) : + ∃ c, ComputableInTimeAndSpace (fun x => (f x, g x)) encIn encPair + (fun x => c * (tf x + tg x + 1)) + (fun x => c * (sf x + sg x + 1)) := + computableInTimeAndSpace_concat (fun x => henc (f x, g x)) hf hg + +end Turing.MultiTapeTM From 3cb4f4a0c2121d55155b38912a0f306e990f42da Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 17:16:29 +0000 Subject: [PATCH 57/93] feat(Turing): computableInTimeAndSpace_drop and _take atoms MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Streaming take/drop machines with no work tapes, stated as an encoding change for id : α → α. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 + .../MultiTape/Combinators/TakeDrop.lean | 294 ++++++++++++++++++ 2 files changed, 295 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean diff --git a/Cslib.lean b/Cslib.lean index ed41a241f..11239cd6d 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -60,6 +60,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.TakeDrop public import Cslib.Computability.Machines.Turing.MultiTape.Configuration public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean new file mode 100644 index 000000000..968cda674 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of `take` and `drop` + +Two single-purpose streaming machines with no work tapes: + +* `dropMachine n` skips the first `n` input symbols and then copies the rest to the output tape; +* `takeMachine n` copies the first `n` input symbols to the output tape and then halts. + +Both run in one step per input symbol and use no space. They are the tools that, together with +concatenation, let a one-bit tag be stripped from an encoding: `drop 1` recovers the argument after +a tag, `take 1` reads the tag. + +The results are stated at the level of an *encoding change*: `id : α → α` is computable from an +encoding `encFrom` to an encoding `encTo` whenever `encTo a` is `(encFrom a).drop n` (respectively +`(encFrom a).take n`). + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_drop`: dropping a fixed prefix is computable. +* `Turing.MultiTapeTM.computableInTimeAndSpace_take`: taking a fixed prefix is computable. +-/ + +namespace Turing.MultiTapeTM + +variable {α : Type*} {input : List Bool} + +/-! ### Dropping a fixed prefix -/ + +/-- The drop machine: no work tapes, states `Fin (n + 1)` counting the symbols skipped so far. In a +state below `n` it skips the current symbol (move right, emit nothing); in the top state `n` it +copies the current symbol to the output and moves right; on the blank at the right end it halts. -/ +def dropMachine (n : ℕ) : MultiTapeTM 0 Bool (Fin (n + 1)) where + q₀ := ⟨0, by omega⟩ + tr q s _ := + match s with + | some b => + if h : q.val < n then + { inputTape := 1, workTapes := fun i => i.elim0, output := none, + state := some ⟨q.val + 1, by omega⟩ } + else + { inputTape := 1, workTapes := fun i => i.elim0, output := some b, state := some q } + | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } + +namespace Drop + +/-- A configuration of the drop machine: the state, the input head position and the output. -/ +def cfg (n : ℕ) (input : List Bool) (q : Option (Fin (n + 1))) (p : Fin (input.length + 2)) + (out : List Bool) : Cfg 0 Bool (Fin (n + 1)) input := + ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ + +variable {n : ℕ} + +/-- A skip step: below the top state, over an input symbol, the machine moves right and advances the +counter without emitting. -/ +lemma step_skip {i : ℕ} (hi : i < n) (hj : i < input.length) (out : List Bool) : + (dropMachine n).step (cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) = + cfg n input (some ⟨i + 1, by omega⟩) ⟨i + 2, by omega⟩ out := by + have hsym := inputSymbolInner (cfg := cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) + i (by simp only [cfg]; omega) hj + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + simp only [dropMachine, hi, ↓reduceDIte] + refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) (by simp [Action.apply]) + simp [Action.apply, moveInputPos] + grind + +/-- A copy step: in the top state, over an input symbol, the machine emits it and moves right. -/ +lemma step_copy {j : ℕ} (hj : j < input.length) (out : List Bool) : + (dropMachine n).step (cfg n input (some ⟨n, by omega⟩) ⟨j + 1, by omega⟩ out) = + cfg n input (some ⟨n, by omega⟩) ⟨j + 2, by omega⟩ (out ++ (input[j]?).toList) := by + have hsym := inputSymbolInner (cfg := cfg n input (some ⟨n, by omega⟩) ⟨j + 1, by omega⟩ out) + j (by simp only [cfg]; omega) hj + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + simp only [dropMachine, lt_irrefl, ↓reduceDIte] + refine Cfg.ext_zero_tapes rfl ?_ ?_ + · apply Fin.ext; simp [Action.apply, moveInputPos]; grind + · simp [Action.apply, List.getElem?_eq_getElem hj] + +/-- On the blank at the right end of the input, the machine halts in place, wherever the head is +parked at that boundary. -/ +lemma step_halt {q : Fin (n + 1)} {p : Fin (input.length + 2)} (hp : p.val = input.length + 1) + (out : List Bool) : + (dropMachine n).step (cfg n input (some q) p out) = cfg n input none p out := by + have hsym : (cfg n input (some q) p out).inputSymbol = none := + inputSymbol_eq_none_of_boundary (Or.inr hp) + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + exact Cfg.ext_zero_tapes rfl (by simp [dropMachine, Action.apply]) (by simp [dropMachine, + Action.apply]) + +/-- The skip phase: after `i ≤ min n input.length` steps the machine has skipped the first `i` +symbols and is over the `i`-th input cell in state `⟨i⟩`, with empty output. -/ +lemma runFrom_skip (i : ℕ) (hin : i ≤ n) (hil : i ≤ input.length) : + (dropMachine n).runFrom ((dropMachine n).initCfg input) i = + cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ [] := by + induction i with + | zero => exact Cfg.ext_zero_tapes rfl rfl rfl + | succ i ih => + rw [runFrom_succ_eq_step', ih (by omega) (by omega), step_skip (by omega) (by omega)] + +/-- The copy phase: from the top state at input cell `n`, after `j` steps the machine has copied +`(input.drop n).take j`. -/ +lemma runFrom_copy (j : ℕ) (hj : n + j ≤ input.length) : + (dropMachine n).runFrom (cfg n input (some ⟨n, by omega⟩) ⟨n + 1, by omega⟩ []) j = + cfg n input (some ⟨n, by omega⟩) ⟨n + j + 1, by omega⟩ ((input.drop n).take j) := by + induction j with + | zero => simp only [Nat.add_zero, List.take_zero]; rfl + | succ j ih => + rw [runFrom_succ_eq_step', ih (by omega), step_copy (j := n + j) (by omega)] + simp only [cfg] + refine Cfg.ext_zero_tapes rfl rfl ?_ + rw [List.take_add_one, List.getElem?_drop] + +/-- The full run halts, in `input.length + 1` steps, with `input.drop n` on the output tape. -/ +lemma runFrom_full (n : ℕ) (input : List Bool) : + (dropMachine n).runFrom ((dropMachine n).initCfg input) (input.length + 1) = + cfg n input none ⟨input.length + 1, by omega⟩ (input.drop n) := by + by_cases hle : n ≤ input.length + · -- skip `n`, copy `length - n`, then one halt step + have hcopy := runFrom_copy (input := input) (n := n) (input.length - n) (by omega) + conv_lhs => rw [show input.length + 1 = n + ((input.length - n) + 1) from by omega] + rw [runFrom_add, runFrom_skip n le_rfl hle, runFrom_add, hcopy, runFrom_succ_eq_step', + runFrom_zero, + step_halt (show (⟨n + (input.length - n) + 1, by omega⟩ : Fin (input.length + 2)).val = + input.length + 1 from by simp; omega)] + simp only [cfg] + refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) ?_ + · change n + (input.length - n) + 1 = input.length + 1 + omega + · change (input.drop n).take (input.length - n) = input.drop n + rw [show input.length - n = (input.drop n).length from by rw [List.length_drop], + List.take_length] + · -- the input is exhausted during the skip phase and the machine halts blank + rw [runFrom_succ_eq_step', runFrom_skip input.length (by omega) le_rfl, step_halt rfl] + simp only [cfg] + refine Cfg.ext_zero_tapes rfl rfl ?_ + rw [List.drop_eq_nil_of_le (by omega)] + +/-- **The drop machine outputs `input.drop n`**, in `input.length + 1` steps and no space. -/ +theorem computesInTimeAndSpace (n : ℕ) (input : List Bool) : + ComputesInTimeAndSpace (dropMachine n) input (input.drop n) (input.length + 1) 0 := + ⟨by rw [runFrom_full]; rfl, by rw [runFrom_full]; rfl, + (dropMachine n).spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ + +end Drop + +/-- **Dropping a fixed prefix is computable.** If `encTo a` is `(encFrom a).drop n` for every `a`, +then the identity is computable from `encFrom` to `encTo`, in one step per input symbol and no +space. -/ +public theorem computableInTimeAndSpace_drop {encFrom encTo : α ↪ List Bool} (n : ℕ) + (h : ∀ a, encTo a = (encFrom a).drop n) : + ComputableInTimeAndSpace (id : α → α) encFrom encTo + (fun a => (encFrom a).length + 1) (fun _ => 0) := + ⟨0, Fin (n + 1), inferInstance, dropMachine n, fun a => + ⟨(encFrom a).length + 1, le_rfl, 0, le_rfl, by + rw [show encTo (id a) = (encFrom a).drop n from h a] + exact Drop.computesInTimeAndSpace n (encFrom a)⟩⟩ + +/-! ### Taking a fixed prefix -/ + +/-- The take machine: no work tapes, states `Fin (n + 1)` counting the symbols copied so far. Below +the top state `n`, over an input symbol, it copies it to the output and moves right; on reaching the +top state, or the blank at the right end, it halts. -/ +def takeMachine (n : ℕ) : MultiTapeTM 0 Bool (Fin (n + 1)) where + q₀ := ⟨0, by omega⟩ + tr q s _ := + match s with + | some b => + if h : q.val < n then + { inputTape := 1, workTapes := fun i => i.elim0, output := some b, + state := some ⟨q.val + 1, by omega⟩ } + else + { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } + | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } + +namespace Take + +/-- A configuration of the take machine. -/ +def cfg (n : ℕ) (input : List Bool) (q : Option (Fin (n + 1))) (p : Fin (input.length + 2)) + (out : List Bool) : Cfg 0 Bool (Fin (n + 1)) input := + ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ + +variable {n : ℕ} + +/-- A copy step: below the top state, over an input symbol, emit it and move right. -/ +lemma step_copy {i : ℕ} (hi : i < n) (hj : i < input.length) (out : List Bool) : + (takeMachine n).step (cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) = + cfg n input (some ⟨i + 1, by omega⟩) ⟨i + 2, by omega⟩ (out ++ (input[i]?).toList) := by + have hsym := inputSymbolInner (cfg := cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) + i (by simp only [cfg]; omega) hj + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + simp only [takeMachine, hi, ↓reduceDIte] + refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) ?_ + · simp [Action.apply, moveInputPos]; grind + · simp [Action.apply, List.getElem?_eq_getElem hj] + +/-- In the top state the machine halts in place, whatever it reads. -/ +lemma step_halt_top {p : Fin (input.length + 2)} (out : List Bool) : + (takeMachine n).step (cfg n input (some ⟨n, by omega⟩) p out) = cfg n input none p out := by + unfold step + simp only [cfg] + cases hsym : (⟨some (⟨n, by omega⟩ : Fin (n + 1)), p, fun _ _ => none, fun _ => 0, out⟩ : + Cfg 0 Bool (Fin (n + 1)) input).inputSymbol with + | none => + simp only [takeMachine] + exact Cfg.ext_zero_tapes rfl (by simp [Action.apply, moveInputPos_zero]) + (by simp [Action.apply]) + | some b => + simp only [takeMachine, lt_irrefl, ↓reduceDIte] + exact Cfg.ext_zero_tapes rfl (by simp [Action.apply, moveInputPos_zero]) + (by simp [Action.apply]) + +/-- On the blank at the right end the machine halts. -/ +lemma step_halt_blank {q : Fin (n + 1)} {p : Fin (input.length + 2)} (hp : p.val = input.length + 1) + (out : List Bool) : + (takeMachine n).step (cfg n input (some q) p out) = cfg n input none p out := by + have hsym : (cfg n input (some q) p out).inputSymbol = none := + inputSymbol_eq_none_of_boundary (Or.inr hp) + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + exact Cfg.ext_zero_tapes rfl (by simp [takeMachine, Action.apply]) (by simp [takeMachine, + Action.apply]) + +/-- The copy phase: after `i ≤ min n input.length` steps the machine has copied the first `i` +symbols and sits over cell `i` in state `⟨i⟩`. -/ +lemma runFrom_copy (i : ℕ) (hin : i ≤ n) (hil : i ≤ input.length) : + (takeMachine n).runFrom ((takeMachine n).initCfg input) i = + cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ (input.take i) := by + induction i with + | zero => exact Cfg.ext_zero_tapes rfl rfl rfl + | succ i ih => + rw [runFrom_succ_eq_step', ih (by omega) (by omega), step_copy (by omega) (by omega)] + simp only [cfg] + refine Cfg.ext_zero_tapes rfl rfl ?_ + change input.take i ++ (input[i]?).toList = input.take (i + 1) + rw [List.take_add_one] + +/-- The full run halts, in `input.length + 1` steps, with `input.take n` on the output tape (the +input head is parked wherever the machine stopped, so the position is left existential). -/ +lemma runFrom_full (n : ℕ) (input : List Bool) : + ∃ p, (takeMachine n).runFrom ((takeMachine n).initCfg input) (input.length + 1) = + cfg n input none p (input.take n) := by + by_cases hle : n ≤ input.length + · -- copy `n` symbols, then halt in the top state (position `n + 1`) + refine ⟨⟨n + 1, by omega⟩, ?_⟩ + conv_lhs => rw [show input.length + 1 = n + 1 + (input.length - n) from by omega] + rw [runFrom_add, runFrom_add, runFrom_copy n le_rfl hle, runFrom_succ_eq_step', + runFrom_zero, step_halt_top, runFrom_of_halt _ (by simp [cfg])] + · -- the input is exhausted first, and the machine halts blank (position `length + 1`) + refine ⟨⟨input.length + 1, by omega⟩, ?_⟩ + rw [runFrom_succ_eq_step', runFrom_copy input.length (by omega) le_rfl, step_halt_blank rfl] + simp only [cfg] + refine Cfg.ext_zero_tapes rfl rfl ?_ + change input.take input.length = input.take n + rw [List.take_length, List.take_of_length_le (by omega)] + +/-- **The take machine outputs `input.take n`**, in `input.length + 1` steps and no space. -/ +theorem computesInTimeAndSpace (n : ℕ) (input : List Bool) : + ComputesInTimeAndSpace (takeMachine n) input (input.take n) (input.length + 1) 0 := by + obtain ⟨p, hp⟩ := runFrom_full n input + exact ⟨by rw [hp]; rfl, by rw [hp]; rfl, (takeMachine n).spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ + +end Take + +/-- **Taking a fixed prefix is computable.** If `encTo a` is `(encFrom a).take n` for every `a`, +then the identity is computable from `encFrom` to `encTo`, in one step per input symbol and no +space. -/ +public theorem computableInTimeAndSpace_take {encFrom encTo : α ↪ List Bool} (n : ℕ) + (h : ∀ a, encTo a = (encFrom a).take n) : + ComputableInTimeAndSpace (id : α → α) encFrom encTo + (fun a => (encFrom a).length + 1) (fun _ => 0) := + ⟨0, Fin (n + 1), inferInstance, takeMachine n, fun a => + ⟨(encFrom a).length + 1, le_rfl, 0, le_rfl, by + rw [show encTo (id a) = (encFrom a).take n from h a] + exact Take.computesInTimeAndSpace n (encFrom a)⟩⟩ + +end Turing.MultiTapeTM From a37463bba2ec1dd3bd542e8a36a839ffc4c5b052 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 17:30:19 +0000 Subject: [PATCH 58/93] refactor(Turing): rebuild cond/ite/dite/match on elementary atoms cond is now function-level: tag the input with the selector bit (concat), branch on the first bit (iteFirstBit), strip the tag in each arm (drop), untag on the way in (comp). Bounds relaxed to a single c*(...+1) shape; ite/dite/match relaxed accordingly. Full build green. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 342 +++++++++--------- 1 file changed, 174 insertions(+), 168 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 86f194659..284dba050 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -11,6 +11,9 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostCo public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputBranch public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.TakeDrop +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id /-! # Complexity of a case analysis @@ -219,7 +222,7 @@ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} have h2 : tg a + 1 ≤ tg a + th a + 1 := by omega exact le_trans hu (le_trans h2 (Nat.le_mul_of_pos_left _ (by omega))) · -- space: `≤ s'g + 2K ≤ sg a + 2K` - show tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) + change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sg a + 2 * K := by rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) refine le_trans hle ?_ @@ -241,7 +244,7 @@ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ · have : u₂ ≤ th a + 1 := by omega exact le_trans this (le_trans (by omega) (Nat.le_mul_of_pos_left _ (by omega))) - · show tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) + · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sh a + 2 * K := by rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) refine le_trans hle ?_ @@ -256,127 +259,129 @@ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] · rfl +/-- **Normalised composition.** Composing a computable `id`-relabelling with a computable function, +both in the normalised bound shape `c * (P a + 1)`, stays in that shape. The scratch encoding's +length is bounded by `P a + 1`, and the composed result's length by the second function's bound, so +every term that composition adds is already a multiple of `P a + 1`. -/ +private lemma norm_comp {γ' : Type*} {gg : α → γ'} {encX encY : α ↪ List Bool} + {encZ : γ' ↪ List Bool} {P : α → ℕ} {cf cg : ℕ} + (hf : ComputableInTimeAndSpace (id : α → α) encX encY + (fun a => cf * (P a + 1)) (fun a => cf * (P a + 1))) + (hg : ComputableInTimeAndSpace gg encY encZ + (fun a => cg * (P a + 1)) (fun a => cg * (P a + 1))) + (hY : ∀ a, (encY a).length ≤ P a + 1) : + ∃ c, ComputableInTimeAndSpace gg encX encZ + (fun a => c * (P a + 1)) (fun a => c * (P a + 1)) := by + obtain ⟨cc, hcc⟩ := computableInTimeAndSpace_comp hf hg + rw [show gg ∘ (id : α → α) = gg from rfl] at hcc + refine ⟨cc * (cf + 2 * cg + 2), hcc.mono (fun a => ?_) (fun a => ?_)⟩ + · simp only [id_eq] + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cc ?_ + have hexp : (cf + 2 * cg + 2) * (P a + 1) = + cf * (P a + 1) + 2 * (cg * (P a + 1)) + 2 * (P a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc] + have hY' := hY a + omega + · simp only [id_eq] + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cc ?_ + have hexp : (cf + 2 * cg + 2) * (P a + 1) = + cf * (P a + 1) + 2 * (cg * (P a + 1)) + 2 * (P a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc] + have hY' := hY a + have hZ := hg.length_encOut_le a + omega + /-- **Complexity of a two-way case analysis**, the recursor of `Bool`. If the scrutinee and both -branches are computable, then so is the case analysis `bif sel a then g a else h a`, in time the -test plus the larger branch and, crucially, space the test plus the larger branch — with no time -term, because the branch taken emits straight to the output tape. The scrutinee is encoded by -`boolEnc`, so the dispatch reads a single symbol. -/ +branches are computable, then so is the case analysis `bif sel a then g a else h a`. + +The construction is entirely at the function level, on top of the elementary atoms. The selector's +bit is concatenated ahead of the input (`computableInTimeAndSpace_concat`) to form a tagged value +whose encoding starts with `sel a`; the branch on that first bit +(`computableInTimeAndSpace_iteFirstBit`) runs `g` or `h`, each first stripping the tag with `drop 1` +(`computableInTimeAndSpace_drop`) and running its branch by composition; and the tagging is undone +on the way in by one more composition. Bounds are relaxed to the single shape `c * (P a + 1)`, with +`P` collecting the six input bounds and the input length — nothing downstream needs them tight. -/ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → β} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} (hsel : ComputableInTimeAndSpace sel encIn boolEnc tc sc) (hif : ComputableInTimeAndSpace g encIn encOut tif sif) (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut - (fun a => c * (tc a + max (tif a) (telse a) + 1)) - (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by classical - obtain ⟨m_c, c_c, Hc⟩ := exists_transformsTapes_ofComputableInput hsel - obtain ⟨kg, Sg, hSg, tmg, Hg⟩ := hif - obtain ⟨kh, Sh, hSh, tmh, Hh⟩ := helse - set K := m_c + kg + kh + 1 with hK - -- tape 0 holds the scrutinee bit; the branch machines live on tapes disjoint from it - have hK0 : 0 < K := by omega - let T_c : Fin K := ⟨0, hK0⟩ - let e_g : Fin kg ↪ Fin K := - ⟨fun j => ⟨1 + j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - let e_h : Fin kh ↪ Fin K := - ⟨fun j => ⟨1 + kg + j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - have hne_g : ∀ j, e_g j ≠ T_c := fun j => Fin.ne_of_val_ne (by change 1 + j.val ≠ 0; omega) - have hne_h : ∀ j, e_h j ≠ T_c := fun j => Fin.ne_of_val_ne (by change 1 + kg + j.val ≠ 0; omega) - -- the scrutinee transformer, leaving `[sel a]` on tape `T_c` - obtain ⟨Sc, hSc, tmc, Hc_spec⟩ := Hc K T_c ∅ (by simp) (by simp only [Finset.card_empty]; omega) - -- the streaming dispatch between the two (embedded) branch machines - obtain ⟨Sd, hSd, tmd, Hd⟩ := - exists_branch_run T_c true (extendTapes tmg e_g) (extendTapes tmh e_h) - -- build with the raw additive bounds, then renormalise once - have main : ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut - (fun a => c_c * (tc a + 1) + (max (tif a) (telse a) + 1)) - (fun a => c_c * (sc a + 1 + 1) + K + (max (sif a) (selse a) + 2 * K)) := by - refine ⟨K, Sc ⊕ Sd, inferInstance, tmc.seq tmd, fun a => ?_⟩ - set start := (tmc.seq tmd).initCfg (encIn a) with hstart - have hstart_words : start = wordsCfg (encIn a) (some (tmc.seq tmd).q₀) (fun _ => []) [] := by - rw [hstart, initCfg_eq_wordsCfg] - -- phase one: the scrutinee transformer leaves `[sel a]` on `T_c`, blank elsewhere - obtain ⟨τ, hτ, ws', hrun1, hQ1, hsp1⟩ := - Hc_spec a (encIn a) (fun _ => []) [] ⟨rfl, fun l _ => rfl⟩ - have hlen : (boolEnc (sel a)).length = 1 := rfl - rw [hlen] at hsp1 - have hc1eq : tmc.runFrom (start.withState (some tmc.q₀)) τ = - wordsCfg (encIn a) none ws' [] := by rw [hstart_words]; exact hrun1 - obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := - exists_minimal_halting_time tmc (start.withState (some tmc.q₀)) τ (by rw [hc1eq]; rfl) - have hc1eq' : tmc.runFrom (start.withState (some tmc.q₀)) τ' = wordsCfg (encIn a) none ws' [] := - (runFrom_eq_of_halt tmc _ hτ'le hτ'halt).symm.trans hc1eq - have hblank : ∀ l, l ≠ T_c → ws' l = [] := by - intro l hl; rw [hQ1, Function.update_of_ne hl] - have hTc_head : (ws' T_c).head? = some (sel a) := by - rw [hQ1, Function.update_self]; rfl - have hstartws : start.withState (some tmc.q₀) = - wordsCfg (encIn a) (some tmc.q₀) (fun _ => []) [] := by rw [hstart_words]; rfl - have hsp1' : tmc.spaceUsed (start.withState (some tmc.q₀)) τ' ≤ c_c * (sc a + 1 + 1) + K := by - rw [hstartws]; exact le_trans (spaceUsed_mono tmc _ hτ'le) hsp1 - -- phase two: reduce to running the chosen arm to completion - suffices H : ∀ u₂ : ℕ, u₂ ≤ max (tif a) (telse a) + 1 → - (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂).state = none → - (∀ m < u₂, (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) m).state ≠ none) → - (tmd.runFrom (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂).output = - encOut (bif sel a then g a else h a) → - tmd.spaceUsed (wordsCfg (encIn a) (some tmd.q₀) ws' []) u₂ ≤ max (sif a) (selse a) + 2 * K → - ∃ t' ≤ c_c * (tc a + 1) + (max (tif a) (telse a) + 1), - ∃ s' ≤ c_c * (sc a + 1 + 1) + K + (max (sif a) (selse a) + 2 * K), - ComputesInTimeAndSpace (tmc.seq tmd) (encIn a) - (encOut (bif sel a then g a else h a)) t' s' by - cases hb : sel a with - | false => - obtain ⟨t'h, ht'hle, s'h, hs'hle, hhstate, hhout, hhsp⟩ := Hh a - have hhead : (ws' T_c).head? ≠ some true := by rw [hTc_head, hb]; simp - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := - exists_arm_run (fun j => hblank (e_h j) (hne_h j)) ((Hd (encIn a) ws' [] t'h).2 hhead) - hhstate hhout (le_trans hhsp.le (le_trans hs'hle (le_max_right (sif a) (selse a)))) - exact H u₂ (by have := le_max_right (tif a) (telse a); omega) hu₂halt hu₂act - (by rw [hb]; exact hu₂out) hu₂sp - | true => - obtain ⟨t'g, ht'gle, s'g, hs'gle, hgstate, hgout, hgsp⟩ := Hg a - have hhead : (ws' T_c).head? = some true := by rw [hTc_head, hb] - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := - exists_arm_run (fun j => hblank (e_g j) (hne_g j)) ((Hd (encIn a) ws' [] t'g).1 hhead) - hgstate hgout (le_trans hgsp.le (le_trans hs'gle (le_max_left (sif a) (selse a)))) - exact H u₂ (by have := le_max_left (tif a) (telse a); omega) hu₂halt hu₂act - (by rw [hb]; exact hu₂out) hu₂sp - intro u₂ hu₂ hu₂halt hu₂act hu₂out hu₂sp - obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := - seq_spec (tm₁ := tmc) (tm₂ := tmd) (c := start) (by rw [hstart_words]; rfl) - hc1eq' rfl hτ'act hsp1' rfl hu₂halt hu₂act hu₂sp - refine ⟨τ' + u₂, by omega, (tmc.seq tmd).spaceUsed start (τ' + u₂), hseq_sp, ?_, ?_, rfl⟩ - · rw [hseq_run]; rfl - · rw [hseq_run]; exact hu₂out - -- renormalise the additive bounds into the stated multiplicative shape - refine ⟨2 * c_c + 3 * K + 2, main.mono (fun a => ?_) (fun a => ?_)⟩ - · -- time - have e1 : c_c * (tc a + 1) ≤ c_c * (tc a + max (tif a) (telse a) + 1) := - Nat.mul_le_mul_left c_c (by omega) - have e2 : c_c * (tc a + max (tif a) (telse a) + 1) + (tc a + max (tif a) (telse a) + 1) = - (c_c + 1) * (tc a + max (tif a) (telse a) + 1) := (Nat.succ_mul c_c _).symm - have e3 : (c_c + 1) * (tc a + max (tif a) (telse a) + 1) ≤ - (2 * c_c + 3 * K + 2) * (tc a + max (tif a) (telse a) + 1) := - Nat.mul_le_mul_right _ (by omega) - omega - · -- space - set mS := max (sif a) (selse a) with hmS - set MS := sc a + mS + 1 with hMS - have P1 : c_c * (sc a + 1 + 1) ≤ 2 * (c_c * MS) := by - have h2 : c_c * (sc a + 1 + 1) ≤ c_c * (MS + 1) := Nat.mul_le_mul_left c_c (by omega) - have h3 : c_c * (MS + 1) = c_c * MS + c_c := Nat.mul_succ c_c MS - have h4 : c_c ≤ c_c * MS := Nat.le_mul_of_pos_right c_c (by omega) - omega - have P3 : 3 * K ≤ 3 * (K * MS) := by - have : K ≤ K * MS := Nat.le_mul_of_pos_right K (by omega) - omega - have expand : (2 * c_c + 3 * K + 2) * MS = 2 * (c_c * MS) + 3 * (K * MS) + 2 * MS := by - rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] - omega + set P : α → ℕ := + fun a => tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length with hP + -- the tagged encoding: the selector bit in front of the input + let encTag : α ↪ List Bool := + ⟨fun a => sel a :: encIn a, fun a b hab => by + simp only [List.cons.injEq] at hab; exact encIn.injective hab.2⟩ + have hencTag : ∀ a, encTag a = sel a :: encIn a := fun a => rfl + -- pointwise facts about `P` + have hLin : ∀ a, (encIn a).length ≤ P a := fun a => by simp only [hP]; omega + have hLtag : ∀ a, (encTag a).length ≤ P a + 1 := fun a => by + rw [hencTag]; simp only [List.length_cons]; have := hLin a; omega + -- normalise the three inputs and the identity into the `c * (P a + 1)` shape + have hsel_n : ComputableInTimeAndSpace sel encIn boolEnc + (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := + hsel.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) + have hif_n : ComputableInTimeAndSpace g encIn encOut + (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := + hif.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) + have helse_n : ComputableInTimeAndSpace h encIn encOut + (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := + helse.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) + have hid_n : ComputableInTimeAndSpace (id : α → α) encIn encIn + (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := + (computableInTimeAndSpace_id (enc := encIn)).mono + (fun a => by have := hLin a; omega) (fun a => by omega) + -- tag: `id : encIn → encTag`, via concatenation of the selector bit and the input + obtain ⟨ct, htag⟩ := computableInTimeAndSpace_concat + (encD := encTag) (f := sel) (g := (id : α → α)) (h := (id : α → α)) + (fun a => by rw [hencTag]; rfl) hsel_n hid_n + have htag_n : ComputableInTimeAndSpace (id : α → α) encIn encTag + (fun a => (ct * 3) * (P a + 1)) (fun a => (ct * 3) * (P a + 1)) := by + refine htag.mono (fun a => ?_) (fun a => ?_) <;> + · rw [Nat.mul_assoc]; refine Nat.mul_le_mul_left ct ?_ + have h3 : (3 : ℕ) * (P a + 1) = (P a + 1) + (P a + 1) + (P a + 1) := by + rw [Nat.succ_mul, Nat.succ_mul, Nat.one_mul] + omega + -- untag: `id : encTag → encIn`, dropping the tag bit + have huntag_n : ComputableInTimeAndSpace (id : α → α) encTag encIn + (fun a => 2 * (P a + 1)) (fun a => 2 * (P a + 1)) := by + refine (computableInTimeAndSpace_drop (encFrom := encTag) (encTo := encIn) 1 + (fun a => by rw [hencTag]; rfl)).mono (fun a => ?_) (fun a => ?_) + · have := hLtag a; omega + · omega + -- each branch on the tagged input: strip the tag, then run the branch + obtain ⟨cg', hg'⟩ := + norm_comp (P := P) huntag_n hif_n (fun a => le_trans (hLin a) (Nat.le_succ _)) + obtain ⟨ch', hh'⟩ := + norm_comp (P := P) huntag_n helse_n (fun a => le_trans (hLin a) (Nat.le_succ _)) + -- branch on the first (tag) bit of the tagged input + obtain ⟨ci, hite⟩ := computableInTimeAndSpace_iteFirstBit hg' hh' + have hite_n : ComputableInTimeAndSpace + (fun a => if (encTag a).head? = some true then g a else h a) encTag encOut + (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) + (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) := by + refine hite.mono (fun a => ?_) (fun a => ?_) <;> + · rw [Nat.mul_assoc]; refine Nat.mul_le_mul_left ci ?_ + have hexp : (cg' + ch' + 1) * (P a + 1) = + cg' * (P a + 1) + ch' * (P a + 1) + (P a + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] + omega + -- undo the tagging on the way in, then read off the case analysis + obtain ⟨cf, hfinal⟩ := norm_comp (P := P) htag_n hite_n hLtag + refine ⟨cf, ?_⟩ + have hfun : (fun a => if (encTag a).head? = some true then g a else h a) = + fun a => bif sel a then g a else h a := by + funext a + rw [hencTag] + cases hb : sel a <;> simp + rw [hfun] at hfinal + exact hfinal /-! ### The finite case analysis @@ -388,59 +393,56 @@ combining and the renormalisation, and the induction then reduces to routing the variable {t s : α → ℕ} {encIn : α ↪ List Bool} -/-- A constant function, in the normalised bound shape. -/ +/-- A constant function, in the normalised bound shape `c * (t a + s a + (encIn a).length + 1)`. -/ private lemma const_norm {encOut : β ↪ List Bool} (b : β) : ∃ c, ComputableInTimeAndSpace (fun _ : α => b) encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by obtain ⟨c, hc⟩ := computableInTimeAndSpace_of_const (encIn := encIn) (encOut := encOut) b exact ⟨c, hc.mono (fun a => Nat.le_mul_of_pos_right c (by omega)) (fun a => Nat.zero_le _)⟩ -/-- A two-way case analysis of three functions all given in the normalised bound shape stays in -that shape: the `cond` bound `C * (tc + max tif telse + 1)` collapses because every argument is a -constant times `t a + 1`. -/ +/-- A two-way case analysis of three functions all given in the normalised shape stays in it. The +new `cond` bound mixes each argument's time *and* space bounds and adds the input length, but every +one of those is a constant times `t a + s a + (encIn a).length + 1`, so the shape is preserved. -/ private lemma cond_norm {sel : α → Bool} {g h : α → β} {encOut : β ↪ List Bool} (hsel : ∃ c, ComputableInTimeAndSpace sel encIn boolEnc - (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) (hg : ∃ c, ComputableInTimeAndSpace g encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) (hh : ∃ c, ComputableInTimeAndSpace h encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) : + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) : ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by obtain ⟨c1, h1⟩ := hsel obtain ⟨c2, h2⟩ := hg obtain ⟨c3, h3⟩ := hh obtain ⟨C, hC⟩ := computableInTimeAndSpace_cond h1 h2 h3 - refine ⟨C * (c1 + max c2 c3 + 1), hC.mono (fun a => ?_) (fun a => ?_)⟩ - · have hm : max (c2 * (t a + 1)) (c3 * (t a + 1)) ≤ max c2 c3 * (t a + 1) := - max_le (Nat.mul_le_mul_right _ (le_max_left c2 c3)) - (Nat.mul_le_mul_right _ (le_max_right c2 c3)) - rw [Nat.mul_assoc] - refine Nat.mul_le_mul_left C ?_ - have hd : (c1 + max c2 c3 + 1) * (t a + 1) = - c1 * (t a + 1) + max c2 c3 * (t a + 1) + (t a + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] - omega - · have hm : max (c2 * (s a + 1)) (c3 * (s a + 1)) ≤ max c2 c3 * (s a + 1) := - max_le (Nat.mul_le_mul_right _ (le_max_left c2 c3)) - (Nat.mul_le_mul_right _ (le_max_right c2 c3)) - rw [Nat.mul_assoc] - refine Nat.mul_le_mul_left C ?_ - have hd : (c1 + max c2 c3 + 1) * (s a + 1) = - c1 * (s a + 1) + max c2 c3 * (s a + 1) + (s a + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] - omega + refine ⟨C * (2 * c1 + 2 * c2 + 2 * c3 + 2), hC.mono (fun a => ?_) (fun a => ?_)⟩ <;> + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left C ?_ + have hexp : (2 * c1 + 2 * c2 + 2 * c3 + 2) * (t a + s a + (encIn a).length + 1) = + 2 * (c1 * (t a + s a + (encIn a).length + 1)) + + 2 * (c2 * (t a + s a + (encIn a).length + 1)) + + 2 * (c3 * (t a + s a + (encIn a).length + 1)) + + 2 * (t a + s a + (encIn a).length + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc, Nat.mul_assoc] + omega -/-- The single-bit test `decide (sel a = i₀)`, in the normalised bound shape. Composing the -scrutinee with the almost-constant test `· = i₀` is a `computableInTimeAndSpace_comp`; the extra -terms it introduces — the constant test cost and the encoded scrutinee's length — are absorbed -because the scrutinee's encoded length is bounded by the constant `L`. -/ +/-- The single-bit test `decide (sel a = i₀)`, in the normalised shape. Composing the scrutinee with +the almost-constant test `· = i₀` is a `computableInTimeAndSpace_comp`; the constant test cost and +the encoded scrutinee's length are absorbed because the latter is bounded by the constant `L`. -/ private lemma cond_of_sel {ι : Type} [DecidableEq ι] {sel : α → ι} {encι : ι ↪ List Bool} (i₀ : ι) (L : ℕ) (hL : ∀ a, (encι (sel a)).length ≤ L) (hsel : ∃ c, ComputableInTimeAndSpace sel encIn encι - (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) : + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) : ∃ c, ComputableInTimeAndSpace (fun a => decide (sel a = i₀)) encIn boolEnc - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by obtain ⟨c_sel, hsel'⟩ := hsel obtain ⟨cψ, hψ⟩ := computableInTimeAndSpace_of_exists_finite_ne (f := fun i => decide (i = i₀)) (encIn := encι) (encOut := boolEnc) @@ -452,36 +454,38 @@ private lemma cond_of_sel {ι : Type} [DecidableEq ι] {sel : α → ι} {encι · rw [Nat.mul_assoc] refine Nat.mul_le_mul_left cC ?_ have hL' := hL a - have hexp : (c_sel + cψ + L + 2) * (t a + 1) = - c_sel * (t a + 1) + cψ * (t a + 1) + L * (t a + 1) + 2 * (t a + 1) := by + have hexp : (c_sel + cψ + L + 2) * (t a + s a + (encIn a).length + 1) = + c_sel * (t a + s a + (encIn a).length + 1) + cψ * (t a + s a + (encIn a).length + 1) + + L * (t a + s a + (encIn a).length + 1) + 2 * (t a + s a + (encIn a).length + 1) := by rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] - have h1 : cψ ≤ cψ * (t a + 1) := Nat.le_mul_of_pos_right _ (by omega) - have h2 : L ≤ L * (t a + 1) := Nat.le_mul_of_pos_right _ (by omega) + have h1 : cψ ≤ cψ * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) + have h2 : L ≤ L * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) omega · rw [Nat.mul_assoc] refine Nat.mul_le_mul_left cC ?_ have hL' := hL a have hbl : (boolEnc (decide (sel a = i₀))).length = 1 := rfl rw [hbl] - have hexp : (c_sel + cψ + L + 2) * (s a + 1) = - c_sel * (s a + 1) + cψ * (s a + 1) + L * (s a + 1) + 2 * (s a + 1) := by + have hexp : (c_sel + cψ + L + 2) * (t a + s a + (encIn a).length + 1) = + c_sel * (t a + s a + (encIn a).length + 1) + cψ * (t a + s a + (encIn a).length + 1) + + L * (t a + s a + (encIn a).length + 1) + 2 * (t a + s a + (encIn a).length + 1) := by rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] - have h2 : L ≤ L * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + have h2 : L ≤ L * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) omega /-- The engine of `computableInTimeAndSpace_match`: induction on a finite set `R` covering the -scrutinee's values. Everything is carried in the normalised bound shape `c * (t a + 1)`, -`c * (s a + 1)`. At `insert i₀ R'` the scrutinee is split by the test `sel a = i₀`: on `true` the -branch is `br i₀`, on `false` the reselected scrutinee `sel'` lands in `R'` and the induction -hypothesis applies. -/ +scrutinee's values, everything carried in the normalised shape `c * (t a + s a + (encIn a).length + +1)`. At `insert i₀ R'` the scrutinee is split by the test `sel a = i₀`. -/ private lemma match_aux {ι : Type} {br : ι → α → β} {encι : ι ↪ List Bool} {encOut : β ↪ List Bool} (R : Finset ι) : ∀ (sel : α → ι), (∀ a, sel a ∈ R) → (∀ i ∈ R, ComputableInTimeAndSpace (br i) encIn encOut t s) → (∃ c, ComputableInTimeAndSpace sel encIn encι - (fun a => c * (t a + 1)) (fun a => c * (s a + 1))) → + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) → ∃ c, ComputableInTimeAndSpace (fun a => br (sel a) a) encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by classical induction R using Finset.induction_on with | empty => @@ -512,7 +516,8 @@ private lemma match_aux {ι : Type} {br : ι → α → β} obtain ⟨cc, hcc⟩ := cond_of_sel i₀ _ hL hsel have hsel' : ∃ c, ComputableInTimeAndSpace (fun a => bif decide (sel a = i₀) then d else sel a) encIn encι - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := cond_norm ⟨cc, hcc⟩ (const_norm d) hsel have hmem' : ∀ a, (fun a => bif decide (sel a = i₀) then d else sel a) a ∈ R' := by intro a @@ -562,7 +567,8 @@ public theorem computableInTimeAndSpace_match {ι : Type} (hsel : ComputableInTimeAndSpace sel encIn encι t s) (hbr : ∀ i ∈ Set.range sel, ComputableInTimeAndSpace (br i) encIn encOut t s) : ∃ c, ComputableInTimeAndSpace f encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by classical obtain ⟨c, hc⟩ := match_aux hfin.toFinset sel (fun a => hfin.mem_toFinset.mpr (Set.mem_range_self a)) @@ -582,8 +588,8 @@ public theorem computableInTimeAndSpace_ite {p : α → Prop} [DecidablePred p] (hif : ComputableInTimeAndSpace g encIn encOut tif sif) (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : ∃ c, ComputableInTimeAndSpace (fun a => if p a then g a else h a) encIn encOut - (fun a => c * (tc a + max (tif a) (telse a) + 1)) - (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by obtain ⟨c, hc⟩ := computableInTimeAndSpace_cond hp hif helse refine ⟨c, ?_⟩ have hfun : (fun a => bif decide (p a) then g a else h a) = @@ -604,8 +610,8 @@ public theorem computableInTimeAndSpace_dite {p : α → Prop} [DecidablePred p] (hif : ComputableInTimeAndSpace If encIn encOut tif sif) (helse : ComputableInTimeAndSpace Else encIn encOut telse selse) : ∃ c, ComputableInTimeAndSpace (fun a => dite (p a) (_if a) (_else a)) encIn encOut - (fun a => c * (tc a + max (tif a) (telse a) + 1)) - (fun a => c * (sc a + max (sif a) (selse a) + 1)) := by + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) + (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by obtain ⟨c, hc⟩ := computableInTimeAndSpace_ite (p := p) hp hif helse refine ⟨c, ?_⟩ have hfun : (fun a => if p a then If a else Else a) = From c6c49817687fe7b833bf4d9325c2254b1c026540 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 17:32:36 +0000 Subject: [PATCH 59/93] refactor(Turing): remove now-unused exists_branch_run; rewrite Ite doc The function-level rebuild no longer needs the streaming work-tape dispatch; its helpers are deleted from Branch.lean (exists_transformsTapes_branch, used by loop, stays). Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 93 ++++++-------- .../Turing/MultiTape/Plumbing/Branch.lean | 120 ------------------ 2 files changed, 37 insertions(+), 176 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 284dba050..1caa2db09 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -18,65 +18,46 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id /-! # Complexity of a case analysis -A case analysis runs a machine that says which case holds and then continues with the machine for -that case. This file has one primitive, `computableInTimeAndSpace_match`, which does exactly that -for a scrutinee in an arbitrary finite type; `cond`, `ite` and `dite` are the instances at `Bool`. - -## Why the finite case is the primitive and not the binary one - -Lean's `ite` is not primitive: `ite c t e` is `Decidable.casesOn`, the recursor of the two -constructor inductive `Decidable c`, whose constructors carry only proofs. Since `Prop` is erased, -the computational content of `ite` is exactly the recursor of `Bool`, and a `match` on a finite -inductive type is that recursor nested once per constructor. So `Bool.rec` is the primitive of the -*elaborator*. - -It is not the right primitive here, because a machine does not nest. Deciding among `n` cases is -one machine reading a scrutinee of constant length and dispatching from its finite control, which -is no harder than deciding among two; the nesting is a fiction that the machine never performs. -Building the finite case analysis out of the binary one therefore does not decompose it into -anything simpler — it only replays `n - 1` copies of the same argument, and each replay multiplies -the constants, so the bounds have to be renormalised into a fixed shape at every step to make the -induction go through. Taking the finite case as the primitive deletes all of that: what remains of -the arithmetic is three weakenings. - -The two are equivalent up to constant factors in both directions, so there is no loss. Tests for -individual cases, which is what the binary form consumes, and the tag itself, which is what this -one consumes, are interderivable at constant cost: the tag gives every test by one composition -with a function on a finite type, and the tests give the tag by running all `n` of them. There is -consequently no reason to state both. - -## Why this has to be a combinator - -`cond` is a perfectly ordinary computable *function*: as a map `Bool × β × β → β` it reads a tag -and streams out the component it selects, in linear time and no space. But that function does not -give the case analysis, because - -``` -fun a => if c a then f a else g a = cond ∘ (fun a => (c a, f a, g a)) -``` - -computes *both* `f a` and `g a`. That costs `tf + tg` instead of `max tf tg`, it stores both -encoded results on work tapes, and — the real problem — nesting `n` conditionals evaluates `2 ^ n` -branches instead of `n`. The content of a case analysis is that the branch not taken is never run, -and that laziness is not expressible by composing total functions: the machine has to choose before -it runs, which is why this is a combinator with a machine-level branch behind it and not a -consequence of `computableInTimeAndSpace_comp`. - -## The streaming dispatch - -The space bound has no time term in it — a machine computing all the branches would have to park -their encoded outputs on work tapes, and an output's length is bounded only by the time that -produced it, so its space would be `s a + t a`. What buys the pure `s a` is that the branch taken -emits its result *straight to the real output tape*, never parking it. That is why the branch is -run by the streaming dispatch `exists_branch_run`, whose arm is allowed to emit, rather than by the -output-preserving `computableInTimeAndSpace_of_transformsTapes`. The scrutinee, by contrast, ranges -over finitely many values whose encodings have a constant bound on their length, so materialising -it on a work tape costs only `O(1)` space; here it is a single symbol. +A case analysis chooses which of several machines to continue with. Everything here is built at the +function level on a single machine-level atom — `computableInTimeAndSpace_iteFirstBit`, the branch +on the input's first encoded bit — together with the reusable atoms +`computableInTimeAndSpace_concat` (concatenate two outputs), `computableInTimeAndSpace_drop` (strip +a prefix) and function composition. + +## The one machine atom, and why the branch not taken is never run + +`iteFirstBit` reads the first symbol of the input directly and, before it has run anything, jumps +to `g`'s machine or `h`'s machine; that machine then reads the whole input in place and emits its +result *straight to the real output tape*. Only one arm ever runs, and its result is never parked on +a work tape — so there is no time term in the space bound, and nesting `n` conditionals runs `n` +arms, not +`2 ^ n`. This laziness is the content of a case analysis, and it cannot come from composing total +functions (`cond ∘ (fun a => (c a, f a, g a))` would compute every branch), which is why one +machine-level branch is unavoidable. It is the only one this file needs. + +## From the atom to `cond`, `ite`, `dite` and `match` + +`iteFirstBit` branches on the input's first bit; `cond sel g h` branches on `sel a`, which is not +the input's first bit. The gap is closed entirely with the other atoms: the selector's bit is +concatenated ahead of the input to form a tagged value whose encoding starts with `sel a`, the +branch reads that bit, each arm strips the tag with `drop 1` before running its branch, and the +tagging is undone on the way in by one composition. `ite` and `dite` are `cond` read through +`decide`; the finite `match` is a `Finset` induction that splices in one `cond` per case. + +## Bounds + +Bounds here are deliberately relaxed to a single shape, `c * (… + 1)`: nothing downstream depends on +the conditional family being tight (`loop` and `comp` do not use it), and the function-level +construction spends constant factors freely. The space bound still carries no *time* term, because +the branch taken streams to the output; it does pick up the constant-factor and input-length slack +that composition introduces. ## Main results -* `Turing.MultiTapeTM.computableInTimeAndSpace_match`: the primitive, a case analysis on a - scrutinee in a finite type. See `CslibTests.Complexity.Combinators` for worked examples. +* `Turing.MultiTapeTM.computableInTimeAndSpace_iteFirstBit`: the machine atom, the branch on the + input's first encoded bit. +* `Turing.MultiTapeTM.computableInTimeAndSpace_match`: a case analysis on a scrutinee in a finite + type. See `CslibTests.Complexity.Combinators` for worked examples. * `Turing.MultiTapeTM.computableInTimeAndSpace_cond`: the recursor of `Bool`. * `Turing.MultiTapeTM.computableInTimeAndSpace_ite`: Lean's `ite`, for a decidable predicate. * `Turing.MultiTapeTM.computableInTimeAndSpace_dite`: Lean's `dite`, whose branches are defined diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index 4765a730e..c54ee5d1d 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -146,88 +146,6 @@ private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] -/-- The full run when the symbol under tape `i` is `some x`: after the dispatch step the machine -mirrors `tm₁` step for step, so `τ + 1` steps of the branching machine are one dispatch step -followed by `τ` steps of `tm₁`, embedded on the left. -/ -private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : (ws i).head? = some x) : - (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg] - -/-- The full run when the symbol under tape `i` is not `some x`: after the dispatch step the machine -mirrors `tm₂` step for step. -/ -private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ (ws i).head? = some x) : - (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg] - -/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run -of `tm₁` uses exactly `tm₁`'s space, so `τ + 1` steps use at most `tm₁`'s space plus `k`. -/ -private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : (ws i).head? = some x) : - (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by - have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - step_start_left ws out h] - have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (branch i x tm₁ tm₂).spaceUsed - ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₁) - (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_leftCfg, workTapePos_leftCfg] - calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (branch i x tm₁ tm₂).spaceUsed - ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ - -/-- Space bound of the right branch. -/ -private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ (ws i).head? = some x) : - (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by - have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - step_start_right ws out h] - have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (branch i x tm₁ tm₂).spaceUsed - ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₂) - (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_rightCfg, workTapePos_rightCfg] - calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (branch i x tm₁ tm₂).spaceUsed - ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ - end Branch open Branch in @@ -319,42 +237,4 @@ public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) ( _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega -open Branch in -/-- **Streaming dispatch.** A single machine that reads tape `i`'s first symbol and then runs one -of two given machines to completion — output included. Unlike `exists_transformsTapes_branch` -(which composes output-*preserving* transformers), the arms may emit: the combined machine's -output, halting and space are exactly the chosen arm's, plus one dispatch step (costing `k`). - -Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the -symbol under tape `i` and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. Because -the dispatch and the mirroring embeddings both carry the output through unchanged, the combined -run's output, whether it has halted, and its space are those of the chosen arm's `τ`-step run, -the space paying at most `k` extra for the dispatch step. This is what lets a case analysis send a -branch's result straight to the real output tape instead of parking it on a work tape. -/ -public theorem exists_branch_run {k : ℕ} (i : Fin k) (x : Bool) {S₁ S₂ : Type} - [Finite S₁] [Finite S₂] - (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : - ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), - ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), - ((ws i).head? = some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ - ((ws i).head? ≠ some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by - refine ⟨Option (S₁ ⊕ S₂), inferInstance, branch i x tm₁ tm₂, - fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ - · rw [show (branch i x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] - exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ - · rw [show (branch i x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] - exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ - end Turing.MultiTapeTM From 31396a37716ee7d8b2b7e497c56944068a09d676 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 19:17:08 +0000 Subject: [PATCH 60/93] refactor(Turing): factor branch/inputBranch onto a shared `armed` core `Plumbing/Branch.lean` and `Plumbing/InputBranch.lean` held two dispatch machines whose arm-mirroring apparatus was byte-identical and differed only in the single dispatch transition. Introduce a private machine `armed d` parameterised by the dispatch decision `d`, prove the semiconjugation (`step_leftCfg`/`step_rightCfg`/`runFrom_leftCfg`/`runFrom_rightCfg`) once for all `d`, and redefine `branch`/`inputBranch` as instances. Merge InputBranch into Branch (single file keeps the shared helpers `private`) and delete `Plumbing/InputBranch.lean`; `Combinators/Ite.lean` now imports only `Plumbing.Branch`. No statement or public-API change: both `exists_transformsTapes_branch` and `exists_inputBranch_run` keep their signatures and stay axiom-clean. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 1 - .../Turing/MultiTape/Combinators/Ite.lean | 1 - .../Turing/MultiTape/Plumbing/Branch.lean | 238 +++++++++++++-- .../MultiTape/Plumbing/InputBranch.lean | 272 ------------------ 4 files changed, 212 insertions(+), 300 deletions(-) delete mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean diff --git a/Cslib.lean b/Cslib.lean index 11239cd6d..defbccb40 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -74,7 +74,6 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputBranch public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 1caa2db09..625589470 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -9,7 +9,6 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputBranch public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.TakeDrop diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index c54ee5d1d..2b1ca4c77 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -12,39 +12,61 @@ public import Mathlib.Data.Fintype.Option public import Mathlib.Basic.Finite.Sum /-! -# Branching on a work-tape symbol +# Branching combinators -`branch i x tm₁ tm₂` first reads the symbol under the head of work tape `i` and then, depending on -whether that symbol equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its initial -state on the tapes as they were. This is a control combinator analogous to sequential composition -(`Plumbing/Sequential.lean`): the state space adds a fresh dispatch state on top of `State₁ ⊕ -State₂`, the dispatch is one step that writes nothing and moves no head, and afterwards the machine -mirrors the chosen sub-machine through a left/right embedding just as `seq` mirrors its second -machine. +Two dispatch combinators sit on a shared core. Each first reads one symbol, then — depending on +whether that symbol equals `some x` — behaves like `tm₁` or like `tm₂`, each started in its initial +state on the tapes as they were: + +* `branch i x tm₁ tm₂` reads the symbol under the head of work tape `i`; +* `inputBranch x tm₁ tm₂` reads the symbol under the input head. + +Both are control combinators analogous to sequential composition (`Plumbing/Sequential.lean`): the +state space adds a fresh dispatch state on top of `State₁ ⊕ State₂`, the dispatch is one step that +writes nothing and moves no head, and afterwards the machine mirrors the chosen sub-machine through +a left/right embedding just as `seq` mirrors its second machine. The only difference between the +two is which symbol the dispatch reads, so both are instances of a single machine `armed d` +parameterised by the dispatch decision `d`, and the arm-mirroring semiconjugation is proved once, +for all `d`. Because at a starting `wordsCfg` the head of every work tape sits at the start of its word, tape -`i`'s symbol there is exactly `(ws i).head?`, so the dispatch reads precisely the predicate the -specification branches on. +`i`'s symbol there is exactly `(ws i).head?`, and the input head sits at the first input symbol, so +that symbol is exactly `input.head?`; each dispatch reads precisely the predicate its specification +branches on. ## Main results * `Turing.MultiTapeTM.exists_transformsTapes_branch`: from two transformations sharing a postcondition, a single machine that runs one or the other according to the symbol under tape `i`, with the time bound `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. +* `Turing.MultiTapeTM.exists_inputBranch_run`: a single machine that reads the input's first symbol + and runs one of two given machines to completion — output included — plus one dispatch step. -/ namespace Turing.MultiTapeTM variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} +/-- The symbol under the input head of a `wordsCfg` is the input's first symbol: the head is at +position `1`, over `input[0]` when the input is nonempty and at the right boundary otherwise. -/ +public lemma inputSymbol_wordsCfg {State : Type*} (input : List Bool) (q : Option State) + (ws : Fin k → List Bool) (out : List Bool) : + (wordsCfg input q ws out).inputSymbol = input.head? := by + cases input with + | nil => simp only [wordsCfg, Cfg.inputSymbol]; rfl + | cons b t => + rw [inputSymbolInner 0 (by simp [wordsCfg]) (by simp)] + simp + namespace Branch -/-- The branching machine. State `none` is a fresh dispatch state: it reads the symbol under tape -`i`'s head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial state -(if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, its -states carried by `Sum.inl`/`Sum.inr`. -/ -private def branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) - (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where +/-- The shared branching machine, parameterised by a dispatch decision `d`. State `none` is a fresh +dispatch state: it reads the input symbol and the work-tape symbols and, in one step that writes +nothing and moves no head, jumps to the sub-machine's initial state chosen by `d`. Thereafter it +mirrors the chosen machine, its states carried by `Sum.inl`/`Sum.inr`. -/ +private def armed (d : Option Bool → (Fin k → Option Bool) → S₁ ⊕ S₂) + (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : + MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where q₀ := none tr q inp work := match q with @@ -52,8 +74,7 @@ private def branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) { inputTape := 0 workTapes := fun _ => (none, 0) output := none - state := if work i = some x then some (some (Sum.inl tm₁.q₀)) - else some (some (Sum.inr tm₂.q₀)) } + state := some (some (d inp work)) } | some (Sum.inl q₁) => let a := tm₁.tr q₁ inp work { a with state := a.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))) } @@ -61,7 +82,8 @@ private def branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) let a := tm₂.tr q₂ inp work { a with state := a.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))) } -variable {i : Fin k} {x : Bool} {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} +variable {d : Option Bool → (Fin k → Option Bool) → S₁ ⊕ S₂} + {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} /-- A configuration of `tm₁`, embedded into the branching machine: a halted state stays halted, a live state is carried by `Sum.inl`. -/ @@ -90,9 +112,11 @@ private lemma rightCfg_wordsCfg (q : Option S₂) (ws : Fin k → List Bool) (ou rightCfg (S₁ := S₁) (wordsCfg input q ws out) = wordsCfg input (q.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) ws out := rfl -/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. -/ +/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. This holds for +every dispatch `d`, since it only touches the live `Sum.inl` states, whose transition is +independent of `d`. -/ private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : - (branch i x tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by + (armed d tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by cases hq : cfg.state with | none => rw [step_of_halt (by simp [leftCfg, hq]), step_of_halt hq] @@ -103,7 +127,7 @@ private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : /-- On `tm₂`'s configurations, the branching machine mirrors `tm₂` step for step. -/ private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : - (branch i x tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by + (armed d tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by cases hq : cfg.state with | none => rw [step_of_halt (by simp [rightCfg, hq]), step_of_halt hq] @@ -113,13 +137,25 @@ private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : rfl private lemma runFrom_leftCfg (cfg : Cfg k Bool S₁ input) (n : ℕ) : - (branch i x tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := + (armed d tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := runFrom_comm_of_step leftCfg (fun c => step_leftCfg c) cfg n private lemma runFrom_rightCfg (cfg : Cfg k Bool S₂ input) (n : ℕ) : - (branch i x tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := + (armed d tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n +/-! ### The work-tape branch -/ + +/-- The branching machine. State `none` is a fresh dispatch state: it reads the symbol under tape +`i`'s head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial state +(if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, its +states carried by `Sum.inl`/`Sum.inr`. -/ +private abbrev branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) + (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) := + armed (fun _inp work => if work i = some x then Sum.inl tm₁.q₀ else Sum.inr tm₂.q₀) tm₁ tm₂ + +variable {i : Fin k} {x : Bool} + /-- The dispatch step when the symbol under tape `i` is `some x`: it lands on `tm₁`'s initial configuration, embedded on the left. -/ private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) @@ -130,7 +166,7 @@ private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) some none := rfl rw [step_apply_of_state hstate] refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, Cfg.mapState, wordsCfg, + simp [branch, armed, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] /-- The dispatch step when the symbol under tape `i` is not `some x`: it lands on `tm₂`'s initial @@ -143,9 +179,123 @@ private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) some none := rfl rw [step_apply_of_state hstate] refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [branch, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, + simp [branch, armed, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] +/-! ### The input branch -/ + +/-- The input-branching machine. State `none` is a fresh dispatch state: it reads the symbol under +the input head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial +state (if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, +its states carried by `Sum.inl`/`Sum.inr`. -/ +private abbrev inputBranch (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) + (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) := + armed (fun inp _work => if inp = some x then Sum.inl tm₁.q₀ else Sum.inr tm₂.q₀) tm₁ tm₂ + +/-- The dispatch step when the input's first symbol is `some x`: it lands on `tm₁`'s initial +configuration, embedded on the left. -/ +private lemma inputStep_start_left (ws : Fin k → List Bool) (out : List Bool) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate, inputSymbol_wordsCfg] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [inputBranch, armed, h, leftCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] + +/-- The dispatch step when the input's first symbol is not `some x`: it lands on `tm₂`'s initial +configuration, embedded on the right. -/ +private lemma inputStep_start_right (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate, inputSymbol_wordsCfg] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [inputBranch, armed, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] + +/-- The full run when the input's first symbol is `some x`: after the dispatch step the machine +mirrors `tm₁` step for step. -/ +private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, inputStep_start_left ws out h, runFrom_leftCfg] + +/-- The full run when the input's first symbol is not `some x`. -/ +private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = + rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by + rw [runFrom_succ_eq_step, inputStep_start_right ws out h, runFrom_rightCfg] + +/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run +of `tm₁` uses exactly `tm₁`'s space. -/ +private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : input.head? = some x) : + (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by + have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + inputStep_start_left ws out h] + have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₁) + (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_leftCfg, workTapePos_leftCfg] + calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ + +/-- Space bound of the right branch. -/ +private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) + (h : ¬ input.head? = some x) : + (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by + have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + inputStep_start_right ws out h] + have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by + rw [hstep1] + refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₂) + (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) + τ fun m _ => ?_) + rw [runFrom_rightCfg, workTapePos_rightCfg] + calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) + = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by + rw [Nat.add_comm] + _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (inputBranch x tm₁ tm₂).spaceUsed + ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ + _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 + _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ + end Branch open Branch in @@ -237,4 +387,40 @@ public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) ( _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega +open Branch in +/-- **Streaming dispatch on the input.** A single machine that reads the input's first symbol and +then runs one of two given machines to completion — output included. The arms read the whole input +in place (the dispatch moves no head) and may emit: the combined machine's output, halting and +space are exactly the chosen arm's, plus one dispatch step (costing at most `k`). + +Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the +input's first symbol and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. This is +what lets a case analysis send a branch's result straight to the real output tape instead of +parking it. -/ +public theorem exists_inputBranch_run {k : ℕ} (x : Bool) {S₁ S₂ : Type} + [Finite S₁] [Finite S₂] + (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), + ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), + (input.head? = some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ + (input.head? ≠ some x → + (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ + ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ + (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by + refine ⟨Option (S₁ ⊕ S₂), inferInstance, inputBranch x tm₁ tm₂, + fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ + · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] + exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ + · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] + exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ + end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean deleted file mode 100644 index 9c1ca6f95..000000000 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputBranch.lean +++ /dev/null @@ -1,272 +0,0 @@ -/- -Copyright (c) 2026 Christian Reitwiessner. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Christian Reitwiessner --/ - -module - -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas -public import Mathlib.Data.Fintype.Option -public import Mathlib.Basic.Finite.Sum - -/-! -# Branching on the input's first symbol - -`inputBranch x tm₁ tm₂` first reads the symbol under the input head and then, depending on whether -that symbol equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its initial state on -the tapes as they were. It is the input-tape analogue of `Plumbing/Branch.lean`: the dispatch reads -the *input* symbol rather than a work-tape symbol, so the two arms then read the whole input in -place — the dispatch step writes nothing and moves no head — and may emit their result straight to -the real output tape. - -At a starting `wordsCfg` the input head sits at the first input symbol, so the dispatch reads -exactly `input.head?`, the predicate the specification branches on. - -## Main results - -* `Turing.MultiTapeTM.exists_inputBranch_run`: a single machine that reads the input's first symbol - and runs one of two given machines to completion — output included — plus one dispatch step. --/ - -namespace Turing.MultiTapeTM - -variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} - -/-- The symbol under the input head of a `wordsCfg` is the input's first symbol: the head is at -position `1`, over `input[0]` when the input is nonempty and at the right boundary otherwise. -/ -public lemma inputSymbol_wordsCfg {State : Type*} (input : List Bool) (q : Option State) - (ws : Fin k → List Bool) (out : List Bool) : - (wordsCfg input q ws out).inputSymbol = input.head? := by - cases input with - | nil => simp only [wordsCfg, Cfg.inputSymbol]; rfl - | cons b t => - rw [inputSymbolInner 0 (by simp [wordsCfg]) (by simp)] - simp - -namespace InputBranch - -/-- The input-branching machine. State `none` is a fresh dispatch state: it reads the symbol under -the input head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial -state (if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, -its states carried by `Sum.inl`/`Sum.inr`. -/ -private def inputBranch (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) - (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where - q₀ := none - tr q inp work := - match q with - | none => - { inputTape := 0 - workTapes := fun _ => (none, 0) - output := none - state := if inp = some x then some (some (Sum.inl tm₁.q₀)) - else some (some (Sum.inr tm₂.q₀)) } - | some (Sum.inl q₁) => - let a := tm₁.tr q₁ inp work - { a with state := a.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))) } - | some (Sum.inr q₂) => - let a := tm₂.tr q₂ inp work - { a with state := a.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))) } - -variable {x : Bool} {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} - -/-- A configuration of `tm₁`, embedded into the branching machine. -/ -private def leftCfg (cfg : Cfg k Bool S₁ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := - cfg.mapState (Option.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) - -/-- A configuration of `tm₂`, embedded into the branching machine. -/ -private def rightCfg (cfg : Cfg k Bool S₂ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := - cfg.mapState (Option.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) - -@[simp] -private lemma workTapePos_leftCfg (cfg : Cfg k Bool S₁ input) : - (leftCfg (S₂ := S₂) cfg).workTapePos = cfg.workTapePos := rfl - -@[simp] -private lemma workTapePos_rightCfg (cfg : Cfg k Bool S₂ input) : - (rightCfg (S₁ := S₁) cfg).workTapePos = cfg.workTapePos := rfl - -@[simp] -private lemma leftCfg_wordsCfg (q : Option S₁) (ws : Fin k → List Bool) (out : List Bool) : - leftCfg (S₂ := S₂) (wordsCfg input q ws out) = - wordsCfg input (q.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) ws out := rfl - -@[simp] -private lemma rightCfg_wordsCfg (q : Option S₂) (ws : Fin k → List Bool) (out : List Bool) : - rightCfg (S₁ := S₁) (wordsCfg input q ws out) = - wordsCfg input (q.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) ws out := rfl - -/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. -/ -private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : - (inputBranch x tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by - cases hq : cfg.state with - | none => - rw [step_of_halt (by simp [leftCfg, hq]), step_of_halt hq] - | some q => - have h1 : (leftCfg (S₂ := S₂) cfg).state = some (some (Sum.inl q)) := by simp [leftCfg, hq] - simp only [step, h1, hq] - rfl - -/-- On `tm₂`'s configurations, the branching machine mirrors `tm₂` step for step. -/ -private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : - (inputBranch x tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by - cases hq : cfg.state with - | none => - rw [step_of_halt (by simp [rightCfg, hq]), step_of_halt hq] - | some q => - have h1 : (rightCfg (S₁ := S₁) cfg).state = some (some (Sum.inr q)) := by simp [rightCfg, hq] - simp only [step, h1, hq] - rfl - -private lemma runFrom_leftCfg (cfg : Cfg k Bool S₁ input) (n : ℕ) : - (inputBranch x tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := - runFrom_comm_of_step leftCfg (fun c => step_leftCfg c) cfg n - -private lemma runFrom_rightCfg (cfg : Cfg k Bool S₂ input) (n : ℕ) : - (inputBranch x tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := - runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n - -/-- The dispatch step when the input's first symbol is `some x`: it lands on `tm₁`'s initial -configuration, embedded on the left. -/ -private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = - leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by - have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = - some none := rfl - rw [step_apply_of_state hstate, inputSymbol_wordsCfg] - refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [inputBranch, h, leftCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] - -/-- The dispatch step when the input's first symbol is not `some x`: it lands on `tm₂`'s initial -configuration, embedded on the right. -/ -private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = - rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by - have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = - some none := rfl - rw [step_apply_of_state hstate, inputSymbol_wordsCfg] - refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [inputBranch, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] - -/-- The full run when the input's first symbol is `some x`: after the dispatch step the machine -mirrors `tm₁` step for step. -/ -private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg] - -/-- The full run when the input's first symbol is not `some x`. -/ -private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg] - -/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run -of `tm₁` uses exactly `tm₁`'s space. -/ -private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by - have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - step_start_left ws out h] - have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₁) - (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_leftCfg, workTapePos_leftCfg] - calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ - -/-- Space bound of the right branch. -/ -private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by - have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - step_start_right ws out h] - have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₂) - (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_rightCfg, workTapePos_rightCfg] - calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ - -end InputBranch - -open InputBranch in -/-- **Streaming dispatch on the input.** A single machine that reads the input's first symbol and -then runs one of two given machines to completion — output included. The arms read the whole input -in place (the dispatch moves no head) and may emit: the combined machine's output, halting and -space are exactly the chosen arm's, plus one dispatch step (costing at most `k`). - -Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the -input's first symbol and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. This is -what lets a case analysis send a branch's result straight to the real output tape instead of -parking it. -/ -public theorem exists_inputBranch_run {k : ℕ} (x : Bool) {S₁ S₂ : Type} - [Finite S₁] [Finite S₂] - (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : - ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), - ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), - (input.head? = some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ - (input.head? ≠ some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by - refine ⟨Option (S₁ ⊕ S₂), inferInstance, inputBranch x tm₁ tm₂, - fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ - · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] - exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ - · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] - exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ - -end Turing.MultiTapeTM From 4cedcf350e12945680b8b48990cfa6068f416544 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 21:18:24 +0000 Subject: [PATCH 61/93] refactor(Turing): single time/space bound for iteFirstBit's two arms `tg,th` and `sg,sh` only ever appeared summed in the conclusion, so carrying four bounds was pointless. Give both arms a common `t s` (the caller weakens to a shared bound first, as `match` already does), yielding `c*(t a+1)` / `c*(s a+1)`. The per-branch bound arithmetic collapses and the two `by_cases` arms become identical. `cond`'s call weakens its two arms to `(cg'+ch')*(P+1)` before applying. No downstream change (only `cond` uses `iteFirstBit`); full --wfail build, lint, and axioms clean. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 54 ++++++++----------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 625589470..9afa89548 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -168,12 +168,12 @@ This is the atom on which the whole conditional family is rebuilt: `cond`, `ite` finite `match` all reduce to it by tagging the input with a selector bit and stripping the tag in each arm. -/ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} - {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tg sg th sh : α → ℕ} - (hg : ComputableInTimeAndSpace g encIn encOut tg sg) - (hh : ComputableInTimeAndSpace h encIn encOut th sh) : + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {t s : α → ℕ} + (hg : ComputableInTimeAndSpace g encIn encOut t s) + (hh : ComputableInTimeAndSpace h encIn encOut t s) : ∃ c, ComputableInTimeAndSpace (fun a => if (encIn a).head? = some true then g a else h a) encIn encOut - (fun a => c * (tg a + th a + 1)) (fun a => c * (sg a + sh a + 1)) := by + (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by classical obtain ⟨kg, Sg, hSg, tmg, Hg⟩ := hg obtain ⟨kh, Sh, hSh, tmh, Hh⟩ := hh @@ -197,21 +197,14 @@ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} exists_arm_run (er := e_g) (fun _ => rfl) ((Hd (encIn a) (fun _ => []) [] t'g).1 hb) hgstate hgout hgsp.le refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ - · -- time: `u₂ ≤ t'g + 1 ≤ tg a + 1` - have hu : u₂ ≤ tg a + 1 := by omega - have h2 : tg a + 1 ≤ tg a + th a + 1 := by omega - exact le_trans hu (le_trans h2 (Nat.le_mul_of_pos_left _ (by omega))) - · -- space: `≤ s'g + 2K ≤ sg a + 2K` - change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) - have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sg a + 2 * K := by + · have hu : u₂ ≤ t a + 1 := by omega + exact le_trans hu (Nat.le_mul_of_pos_left _ (by omega)) + · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (s a + 1) + have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ s a + 2 * K := by rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) refine le_trans hle ?_ - have hexp : (2 * K + 1) * (sg a + sh a + 1) = - (2 * K + 1) * (sg a + sh a) + (2 * K + 1) := Nat.mul_succ _ _ - have hge : sg a ≤ (2 * K + 1) * (sg a + sh a) := by - have h2 : sg a + sh a ≤ (2 * K + 1) * (sg a + sh a) := - Nat.le_mul_of_pos_left _ (by omega) - omega + have hexp : (2 * K + 1) * (s a + 1) = (2 * K + 1) * (s a) + (2 * K + 1) := Nat.mul_succ _ _ + have hge : s a ≤ (2 * K + 1) * (s a) := Nat.le_mul_of_pos_left _ (by omega) omega · rw [initCfg_eq_wordsCfg]; exact hu₂halt · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] @@ -222,18 +215,14 @@ public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} exists_arm_run (er := e_h) (fun _ => rfl) ((Hd (encIn a) (fun _ => []) [] t'h).2 hb) hhstate hhout hhsp.le refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ - · have : u₂ ≤ th a + 1 := by omega - exact le_trans this (le_trans (by omega) (Nat.le_mul_of_pos_left _ (by omega))) - · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (sg a + sh a + 1) - have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ sh a + 2 * K := by + · have hu : u₂ ≤ t a + 1 := by omega + exact le_trans hu (Nat.le_mul_of_pos_left _ (by omega)) + · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (s a + 1) + have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ s a + 2 * K := by rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) refine le_trans hle ?_ - have hexp : (2 * K + 1) * (sg a + sh a + 1) = - (2 * K + 1) * (sg a + sh a) + (2 * K + 1) := Nat.mul_succ _ _ - have hge : sh a ≤ (2 * K + 1) * (sg a + sh a) := by - have h2 : sg a + sh a ≤ (2 * K + 1) * (sg a + sh a) := - Nat.le_mul_of_pos_left _ (by omega) - omega + have hexp : (2 * K + 1) * (s a + 1) = (2 * K + 1) * (s a) + (2 * K + 1) := Nat.mul_succ _ _ + have hge : s a ≤ (2 * K + 1) * (s a) := Nat.le_mul_of_pos_left _ (by omega) omega · rw [initCfg_eq_wordsCfg]; exact hu₂halt · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] @@ -341,16 +330,19 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → obtain ⟨ch', hh'⟩ := norm_comp (P := P) huntag_n helse_n (fun a => le_trans (hLin a) (Nat.le_succ _)) -- branch on the first (tag) bit of the tagged input - obtain ⟨ci, hite⟩ := computableInTimeAndSpace_iteFirstBit hg' hh' + obtain ⟨ci, hite⟩ := computableInTimeAndSpace_iteFirstBit + (hg'.mono (fun a => Nat.mul_le_mul (Nat.le_add_right cg' ch') le_rfl) + (fun a => Nat.mul_le_mul (Nat.le_add_right cg' ch') le_rfl)) + (hh'.mono (fun a => Nat.mul_le_mul (Nat.le_add_left ch' cg') le_rfl) + (fun a => Nat.mul_le_mul (Nat.le_add_left ch' cg') le_rfl)) have hite_n : ComputableInTimeAndSpace (fun a => if (encTag a).head? = some true then g a else h a) encTag encOut (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) := by refine hite.mono (fun a => ?_) (fun a => ?_) <;> · rw [Nat.mul_assoc]; refine Nat.mul_le_mul_left ci ?_ - have hexp : (cg' + ch' + 1) * (P a + 1) = - cg' * (P a + 1) + ch' * (P a + 1) + (P a + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.one_mul] + have hexp : (cg' + ch' + 1) * (P a + 1) = (cg' + ch') * (P a + 1) + (P a + 1) := by + rw [Nat.add_mul, Nat.one_mul] omega -- undo the tagging on the way in, then read off the case analysis obtain ⟨cf, hfinal⟩ := norm_comp (P := P) htag_n hite_n hLtag From 0edd525e14be0ff7a34e1a2d612309dad3927317 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 21:44:07 +0000 Subject: [PATCH 62/93] refactor(Turing): rebuild cond on the transformer path, drop iteFirstBit Rebuild `computableInTimeAndSpace_cond` directly on the general tape-transformer machinery: the selector and both branches enter via `exists_transformsTapes_ofComputableInput`, `exists_transformsTapes_branch` dispatches on the selector bit, and the result is emitted with `computableInTimeAndSpace_of_transformsTapes`. This removes the hand-rolled input-dispatch atom `computableInTimeAndSpace_iteFirstBit` together with its placement lemmas `exists_arm_run`, `wordsCfg_eq_embed_blank`, the helper `norm_comp`, and the `concat`/`drop`/`id` tagging construction. `ite`, `dite` and `match` derive unchanged from the compatible combined bound. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 444 ++++++------------ 1 file changed, 147 insertions(+), 297 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 9afa89548..0be380799 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -9,52 +9,39 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters -public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat -public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.TakeDrop -public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id /-! # Complexity of a case analysis -A case analysis chooses which of several machines to continue with. Everything here is built at the -function level on a single machine-level atom — `computableInTimeAndSpace_iteFirstBit`, the branch -on the input's first encoded bit — together with the reusable atoms -`computableInTimeAndSpace_concat` (concatenate two outputs), `computableInTimeAndSpace_drop` (strip -a prefix) and function composition. +A case analysis chooses which of several machines to continue with. `cond` is built directly on the +general tape-transformer machinery: the selector and the two branches enter the transformer +interface through `exists_transformsTapes_ofComputableInput`, and `exists_transformsTapes_branch` +dispatches on the selector's bit. `ite`, `dite` and the finite `match` are then read off `cond`. -## The one machine atom, and why the branch not taken is never run +## Why the branch not taken is never run -`iteFirstBit` reads the first symbol of the input directly and, before it has run anything, jumps -to `g`'s machine or `h`'s machine; that machine then reads the whole input in place and emits its -result *straight to the real output tape*. Only one arm ever runs, and its result is never parked on -a work tape — so there is no time term in the space bound, and nesting `n` conditionals runs `n` -arms, not -`2 ^ n`. This laziness is the content of a case analysis, and it cannot come from composing total -functions (`cond ∘ (fun a => (c a, f a, g a))` would compute every branch), which is why one -machine-level branch is unavoidable. It is the only one this file needs. +The dispatch reads the selector bit that the selector machine has left on a work tape and, in one +step, jumps to the `then`-arm or the `else`-arm; only that arm runs, and it emits its result +*straight to the shared output tape*. Only one arm ever runs, and its result is never parked to be +copied out — so nesting `n` conditionals runs `n` arms, not `2 ^ n`. This laziness is the content of +a case analysis, and it cannot come from composing total functions (`cond ∘ (fun a => (c a, f a, +g a))` would compute every branch), which is why one machine-level branch is unavoidable. -## From the atom to `cond`, `ite`, `dite` and `match` +## From `cond` to `ite`, `dite` and `match` -`iteFirstBit` branches on the input's first bit; `cond sel g h` branches on `sel a`, which is not -the input's first bit. The gap is closed entirely with the other atoms: the selector's bit is -concatenated ahead of the input to form a tagged value whose encoding starts with `sel a`, the -branch reads that bit, each arm strips the tag with `drop 1` before running its branch, and the -tagging is undone on the way in by one composition. `ite` and `dite` are `cond` read through -`decide`; the finite `match` is a `Finset` induction that splices in one `cond` per case. +`ite` and `dite` are `cond` read through `decide`; the finite `match` is a `Finset` induction that +splices in one `cond` per case. ## Bounds -Bounds here are deliberately relaxed to a single shape, `c * (… + 1)`: nothing downstream depends on -the conditional family being tight (`loop` and `comp` do not use it), and the function-level -construction spends constant factors freely. The space bound still carries no *time* term, because -the branch taken streams to the output; it does pick up the constant-factor and input-length slack -that composition introduces. +Bounds here are deliberately relaxed to a single combined shape, `c * (… + 1)`, collecting the six +input bounds and the input length: nothing downstream depends on the conditional family being tight +(`loop` and `comp` do not use it), and the construction spends constant factors freely. ## Main results -* `Turing.MultiTapeTM.computableInTimeAndSpace_iteFirstBit`: the machine atom, the branch on the - input's first encoded bit. * `Turing.MultiTapeTM.computableInTimeAndSpace_match`: a case analysis on a scrutinee in a finite type. See `CslibTests.Complexity.Combinators` for worked examples. * `Turing.MultiTapeTM.computableInTimeAndSpace_cond`: the recursor of `Bool`. @@ -76,202 +63,20 @@ public def boolEnc : Bool ↪ List Bool := ⟨fun b => [b], by intro a b h; simp @[simp] public lemma boolEnc_apply (b : Bool) : boolEnc b = [b] := rfl -/-- A run of a machine placed by `extendTapes` on tapes that are blank on its range mirrors the -run of the underlying machine, seen through the tape embedding. This is the decomposition of a -word configuration into an embedded configuration: the tapes in the range carry the machine's own -(here blank) words, the tapes outside it are carried through as extra tapes. -/ -private lemma wordsCfg_eq_embed_blank {k kr : ℕ} {Sr : Type} - (tmr : MultiTapeTM kr Bool Sr) (er : Fin kr ↪ Fin k) (input : List Bool) - (ws : Fin k → List Bool) (out : List Bool) (hblank : ∀ j, ws (er j) = []) : - wordsCfg input (some (extendTapes tmr er).q₀) ws out = - embed er (wordsCfg input (some tmr.q₀) (fun _ => []) out) - (fun l => tapeOfList (ws l)) (fun _ => 0) := by - change wordsCfg input (some tmr.q₀) ws out = _ - rw [wordsCfg_eq_embed er input (some tmr.q₀) ws out, - show (fun j => ws (er j)) = (fun _ => []) from funext hblank] - -/-- **Phase two of the case analysis: run the chosen arm to completion.** Given the streaming -dispatch's guarantee for one arm — that after the dispatch step the combined machine's output, -halting and space are the embedded arm's — and the underlying arm machine's own guarantee that it -halts with the encoded result, the dispatch halts with that result on the output tape, in one more -step than the arm, using at most the arm's space plus twice the layout size. -/ -private lemma exists_arm_run {k kr : ℕ} {Sr Sd : Type} - {tmr : MultiTapeTM kr Bool Sr} {er : Fin kr ↪ Fin k} - {tmd : MultiTapeTM k Bool Sd} {input : List Bool} {ws' : Fin k → List Bool} - {O : List Bool} {τ_br s_br : ℕ} - (hblank : ∀ j, ws' (er j) = []) - (harm : - (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).output = - ((extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).output ∧ - ((tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).state = none ↔ - ((extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).state = none) ∧ - tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) ≤ - (extendTapes tmr er).spaceUsed - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br + k) - (hhalt : (tmr.runFrom (tmr.initCfg input) τ_br).state = none) - (hout : (tmr.runFrom (tmr.initCfg input) τ_br).output = O) - (hsp : tmr.spaceUsed (tmr.initCfg input) τ_br ≤ s_br) : - ∃ u₂ ≤ τ_br + 1, - (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) u₂).state = none ∧ - (∀ m < u₂, (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) m).state ≠ none) ∧ - (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) u₂).output = O ∧ - tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) u₂ ≤ s_br + 2 * k := by - have hinit : tmr.initCfg input = wordsCfg input (some tmr.q₀) (fun _ => []) [] := - initCfg_eq_wordsCfg tmr input - have hdecomp : (extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br = - embed er (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br) - (fun l => tapeOfList (ws' l)) (fun _ => 0) := by - rw [wordsCfg_eq_embed_blank tmr er input ws' [] hblank, runFrom_embed] - -- the embedded arm's output and halting are the raw arm's - have hEout : ((extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).output = O := by - rw [hdecomp] - change (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br).output = O - rw [← hinit, hout] - have hEhalt : ((extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br).state = none := by - rw [hdecomp] - change (tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br).state = none - rw [← hinit, hhalt] - -- so the dispatch halts at `τ_br + 1` with the result - have hDhalt : (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).state = none := - harm.2.1.mpr hEhalt - have hDout : (tmd.runFrom (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1)).output = O := - harm.1.trans hEout - -- the embedded arm's space is the raw arm's plus the extra tapes - have hEsp : (extendTapes tmr er).spaceUsed - (wordsCfg input (some (extendTapes tmr er).q₀) ws' []) τ_br ≤ s_br + k := by - rw [wordsCfg_eq_embed_blank tmr er input ws' [] hblank] - refine le_trans (spaceUsed_embed_le tmr er _ _ _ τ_br) ?_ - have h1 : tmr.spaceUsed (wordsCfg input (some tmr.q₀) (fun _ => []) []) τ_br ≤ s_br := by - rw [← hinit]; exact hsp - omega - have hDsp : tmd.spaceUsed (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) ≤ s_br + 2 * k := by - refine le_trans harm.2.2 ?_; omega - -- the first halting time is no later, and output and space are inherited - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act⟩ := - exists_minimal_halting_time tmd (wordsCfg input (some tmd.q₀) ws' []) (τ_br + 1) hDhalt - refine ⟨u₂, hu₂le, hu₂halt, hu₂act, ?_, ?_⟩ - · rw [← hDout]; exact (runFrom_output_eq_of_halt tmd _ hu₂le hu₂halt).symm - · exact le_trans (spaceUsed_mono tmd _ hu₂le) hDsp - -/-- **The elementary two-way branch on the input's first symbol.** If `g` and `h` are computable, -then so is the function that runs `g` when the input's first encoded symbol is `some true` and `h` -otherwise. The dispatch reads the input directly, so both arms then read the whole input in place -and emit their result straight to the real output tape — no scrutinee is materialised, and there is -no time term in the space bound. - -This is the atom on which the whole conditional family is rebuilt: `cond`, `ite`, `dite` and the -finite `match` all reduce to it by tagging the input with a selector bit and stripping the tag in -each arm. -/ -public theorem computableInTimeAndSpace_iteFirstBit {g h : α → β} - {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {t s : α → ℕ} - (hg : ComputableInTimeAndSpace g encIn encOut t s) - (hh : ComputableInTimeAndSpace h encIn encOut t s) : - ∃ c, ComputableInTimeAndSpace - (fun a => if (encIn a).head? = some true then g a else h a) encIn encOut - (fun a => c * (t a + 1)) (fun a => c * (s a + 1)) := by - classical - obtain ⟨kg, Sg, hSg, tmg, Hg⟩ := hg - obtain ⟨kh, Sh, hSh, tmh, Hh⟩ := hh - set K := kg + kh with hK - -- the two branch machines live on disjoint blocks of a shared `K`-tape layout - let e_g : Fin kg ↪ Fin K := - ⟨fun j => ⟨j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - let e_h : Fin kh ↪ Fin K := - ⟨fun j => ⟨kg + j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - -- the streaming input-dispatch between the two (embedded) branch machines - obtain ⟨Sd, hSd, tmd, Hd⟩ := - exists_inputBranch_run true (extendTapes tmg e_g) (extendTapes tmh e_h) - refine ⟨2 * K + 1, K, Sd, hSd, tmd, fun a => ?_⟩ - -- reduce to running the chosen arm to completion on all-blank work tapes - by_cases hb : (encIn a).head? = some true - · -- the input starts with `true`: run `g`'s machine - obtain ⟨t'g, ht'gle, s'g, hs'gle, hgstate, hgout, hgsp⟩ := Hg a - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := - exists_arm_run (er := e_g) (fun _ => rfl) - ((Hd (encIn a) (fun _ => []) [] t'g).1 hb) hgstate hgout hgsp.le - refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ - · have hu : u₂ ≤ t a + 1 := by omega - exact le_trans hu (Nat.le_mul_of_pos_left _ (by omega)) - · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (s a + 1) - have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ s a + 2 * K := by - rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) - refine le_trans hle ?_ - have hexp : (2 * K + 1) * (s a + 1) = (2 * K + 1) * (s a) + (2 * K + 1) := Nat.mul_succ _ _ - have hge : s a ≤ (2 * K + 1) * (s a) := Nat.le_mul_of_pos_left _ (by omega) - omega - · rw [initCfg_eq_wordsCfg]; exact hu₂halt - · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] - · rfl - · -- otherwise: run `h`'s machine - obtain ⟨t'h, ht'hle, s'h, hs'hle, hhstate, hhout, hhsp⟩ := Hh a - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act, hu₂out, hu₂sp⟩ := - exists_arm_run (er := e_h) (fun _ => rfl) - ((Hd (encIn a) (fun _ => []) [] t'h).2 hb) hhstate hhout hhsp.le - refine ⟨u₂, ?_, tmd.spaceUsed (tmd.initCfg (encIn a)) u₂, ?_, ?_, ?_, ?_⟩ - · have hu : u₂ ≤ t a + 1 := by omega - exact le_trans hu (Nat.le_mul_of_pos_left _ (by omega)) - · change tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ (2 * K + 1) * (s a + 1) - have hle : tmd.spaceUsed (tmd.initCfg (encIn a)) u₂ ≤ s a + 2 * K := by - rw [initCfg_eq_wordsCfg]; exact le_trans hu₂sp (by omega) - refine le_trans hle ?_ - have hexp : (2 * K + 1) * (s a + 1) = (2 * K + 1) * (s a) + (2 * K + 1) := Nat.mul_succ _ _ - have hge : s a ≤ (2 * K + 1) * (s a) := Nat.le_mul_of_pos_left _ (by omega) - omega - · rw [initCfg_eq_wordsCfg]; exact hu₂halt - · rw [initCfg_eq_wordsCfg, hu₂out]; simp [hb] - · rfl - -/-- **Normalised composition.** Composing a computable `id`-relabelling with a computable function, -both in the normalised bound shape `c * (P a + 1)`, stays in that shape. The scratch encoding's -length is bounded by `P a + 1`, and the composed result's length by the second function's bound, so -every term that composition adds is already a multiple of `P a + 1`. -/ -private lemma norm_comp {γ' : Type*} {gg : α → γ'} {encX encY : α ↪ List Bool} - {encZ : γ' ↪ List Bool} {P : α → ℕ} {cf cg : ℕ} - (hf : ComputableInTimeAndSpace (id : α → α) encX encY - (fun a => cf * (P a + 1)) (fun a => cf * (P a + 1))) - (hg : ComputableInTimeAndSpace gg encY encZ - (fun a => cg * (P a + 1)) (fun a => cg * (P a + 1))) - (hY : ∀ a, (encY a).length ≤ P a + 1) : - ∃ c, ComputableInTimeAndSpace gg encX encZ - (fun a => c * (P a + 1)) (fun a => c * (P a + 1)) := by - obtain ⟨cc, hcc⟩ := computableInTimeAndSpace_comp hf hg - rw [show gg ∘ (id : α → α) = gg from rfl] at hcc - refine ⟨cc * (cf + 2 * cg + 2), hcc.mono (fun a => ?_) (fun a => ?_)⟩ - · simp only [id_eq] - rw [Nat.mul_assoc] - refine Nat.mul_le_mul_left cc ?_ - have hexp : (cf + 2 * cg + 2) * (P a + 1) = - cf * (P a + 1) + 2 * (cg * (P a + 1)) + 2 * (P a + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc] - have hY' := hY a - omega - · simp only [id_eq] - rw [Nat.mul_assoc] - refine Nat.mul_le_mul_left cc ?_ - have hexp : (cf + 2 * cg + 2) * (P a + 1) = - cf * (P a + 1) + 2 * (cg * (P a + 1)) + 2 * (P a + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.mul_assoc] - have hY' := hY a - have hZ := hg.length_encOut_le a - omega - /-- **Complexity of a two-way case analysis**, the recursor of `Bool`. If the scrutinee and both branches are computable, then so is the case analysis `bif sel a then g a else h a`. -The construction is entirely at the function level, on top of the elementary atoms. The selector's -bit is concatenated ahead of the input (`computableInTimeAndSpace_concat`) to form a tagged value -whose encoding starts with `sel a`; the branch on that first bit -(`computableInTimeAndSpace_iteFirstBit`) runs `g` or `h`, each first stripping the tag with `drop 1` -(`computableInTimeAndSpace_drop`) and running its branch by composition; and the tagging is undone -on the way in by one more composition. Bounds are relaxed to the single shape `c * (P a + 1)`, with -`P` collecting the six input bounds and the input length — nothing downstream needs them tight. -/ +The construction reuses the general tape-transformer machinery. The selector, the `then`-branch +and the `else`-branch are each placed on a shared work-tape layout by +`exists_transformsTapes_ofComputableInput`: the selector leaves its single bit `boolEnc (sel a)` on +tape `c`, and each branch reads the real input and leaves its encoded result on the shared output +tape `o` (treating `c` as a tape to keep). `exists_transformsTapes_branch` on tape `c` then runs the +`then`-branch when that bit is `true` and the `else`-branch otherwise — the two arms share the +postcondition "`o` holds `encOut (bif sel a then g a else h a)`", each arm supplying the case +(`sel a = true` / `sel a = false`) that identifies its result with it. Sequencing the selector +before the branch and emitting tape `o` (`computableInTimeAndSpace_of_transformsTapes`) reads off +the case analysis. Bounds are relaxed to the single combined shape `c * (… + 1)`; nothing +downstream needs them tight. -/ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → β} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} (hsel : ComputableInTimeAndSpace sel encIn boolEnc tc sc) @@ -281,79 +86,124 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by classical - set P : α → ℕ := - fun a => tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length with hP - -- the tagged encoding: the selector bit in front of the input - let encTag : α ↪ List Bool := - ⟨fun a => sel a :: encIn a, fun a b hab => by - simp only [List.cons.injEq] at hab; exact encIn.injective hab.2⟩ - have hencTag : ∀ a, encTag a = sel a :: encIn a := fun a => rfl - -- pointwise facts about `P` - have hLin : ∀ a, (encIn a).length ≤ P a := fun a => by simp only [hP]; omega - have hLtag : ∀ a, (encTag a).length ≤ P a + 1 := fun a => by - rw [hencTag]; simp only [List.length_cons]; have := hLin a; omega - -- normalise the three inputs and the identity into the `c * (P a + 1)` shape - have hsel_n : ComputableInTimeAndSpace sel encIn boolEnc - (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := - hsel.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) - have hif_n : ComputableInTimeAndSpace g encIn encOut - (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := - hif.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) - have helse_n : ComputableInTimeAndSpace h encIn encOut - (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := - helse.mono (fun a => by simp only [hP]; omega) (fun a => by simp only [hP]; omega) - have hid_n : ComputableInTimeAndSpace (id : α → α) encIn encIn - (fun a => 1 * (P a + 1)) (fun a => 1 * (P a + 1)) := - (computableInTimeAndSpace_id (enc := encIn)).mono - (fun a => by have := hLin a; omega) (fun a => by omega) - -- tag: `id : encIn → encTag`, via concatenation of the selector bit and the input - obtain ⟨ct, htag⟩ := computableInTimeAndSpace_concat - (encD := encTag) (f := sel) (g := (id : α → α)) (h := (id : α → α)) - (fun a => by rw [hencTag]; rfl) hsel_n hid_n - have htag_n : ComputableInTimeAndSpace (id : α → α) encIn encTag - (fun a => (ct * 3) * (P a + 1)) (fun a => (ct * 3) * (P a + 1)) := by - refine htag.mono (fun a => ?_) (fun a => ?_) <;> - · rw [Nat.mul_assoc]; refine Nat.mul_le_mul_left ct ?_ - have h3 : (3 : ℕ) * (P a + 1) = (P a + 1) + (P a + 1) + (P a + 1) := by - rw [Nat.succ_mul, Nat.succ_mul, Nat.one_mul] - omega - -- untag: `id : encTag → encIn`, dropping the tag bit - have huntag_n : ComputableInTimeAndSpace (id : α → α) encTag encIn - (fun a => 2 * (P a + 1)) (fun a => 2 * (P a + 1)) := by - refine (computableInTimeAndSpace_drop (encFrom := encTag) (encTo := encIn) 1 - (fun a => by rw [hencTag]; rfl)).mono (fun a => ?_) (fun a => ?_) - · have := hLtag a; omega - · omega - -- each branch on the tagged input: strip the tag, then run the branch - obtain ⟨cg', hg'⟩ := - norm_comp (P := P) huntag_n hif_n (fun a => le_trans (hLin a) (Nat.le_succ _)) - obtain ⟨ch', hh'⟩ := - norm_comp (P := P) huntag_n helse_n (fun a => le_trans (hLin a) (Nat.le_succ _)) - -- branch on the first (tag) bit of the tagged input - obtain ⟨ci, hite⟩ := computableInTimeAndSpace_iteFirstBit - (hg'.mono (fun a => Nat.mul_le_mul (Nat.le_add_right cg' ch') le_rfl) - (fun a => Nat.mul_le_mul (Nat.le_add_right cg' ch') le_rfl)) - (hh'.mono (fun a => Nat.mul_le_mul (Nat.le_add_left ch' cg') le_rfl) - (fun a => Nat.mul_le_mul (Nat.le_add_left ch' cg') le_rfl)) - have hite_n : ComputableInTimeAndSpace - (fun a => if (encTag a).head? = some true then g a else h a) encTag encOut - (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) - (fun a => (ci * (cg' + ch' + 1)) * (P a + 1)) := by - refine hite.mono (fun a => ?_) (fun a => ?_) <;> - · rw [Nat.mul_assoc]; refine Nat.mul_le_mul_left ci ?_ - have hexp : (cg' + ch' + 1) * (P a + 1) = (cg' + ch') * (P a + 1) + (P a + 1) := by - rw [Nat.add_mul, Nat.one_mul] - omega - -- undo the tagging on the way in, then read off the case analysis - obtain ⟨cf, hfinal⟩ := norm_comp (P := P) htag_n hite_n hLtag - refine ⟨cf, ?_⟩ - have hfun : (fun a => if (encTag a).head? = some true then g a else h a) = - fun a => bif sel a then g a else h a := by - funext a - rw [hencTag] - cases hb : sel a <;> simp - rw [hfun] at hfinal - exact hfinal + -- the three function machines, placed on a shared layout by the general adapters + obtain ⟨m_sel, c_sel, hsel'⟩ := exists_transformsTapes_ofComputableInput hsel + obtain ⟨m_g, c_g, hif'⟩ := exists_transformsTapes_ofComputableInput hif + obtain ⟨m_h, c_h, helse'⟩ := exists_transformsTapes_ofComputableInput helse + set k := m_sel + m_g + m_h + 3 with hk + let c : Fin k := ⟨0, by omega⟩ + let o : Fin k := ⟨1, by omega⟩ + have hoc : o ≠ c := by apply Fin.ne_of_val_ne; simp + -- `M_sel` writes the selector bit to tape `c`; `M_g`/`M_h` read the input, keep `c`, write to `o` + obtain ⟨S_sel, hS_sel, M_sel, hM_sel⟩ := + hsel' k c ∅ (by simp) (by simp only [Finset.card_empty]; omega) + obtain ⟨S_g, hS_g, M_g, hM_g⟩ := + hif' k o {c} (by simpa using hoc) (by simp only [Finset.card_singleton]; omega) + obtain ⟨S_h, hS_h, M_h, hM_h⟩ := + helse' k o {c} (by simpa using hoc) (by simp only [Finset.card_singleton]; omega) + have := hS_sel; have := hS_g; have := hS_h + have hleg : ∀ a, (encOut (g a)).length ≤ tif a := hif.length_encOut_le + have hleh : ∀ a, (encOut (h a)).length ≤ telse a := helse.length_encOut_le + -- arm 1: run `g`, guarded by `sel a = true`, its result identified with the case analysis + have h₁ : ∀ a, TransformsTapes M_g + (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = true) + (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (c_g * (tif a + 1)) (c_g * (sif a + (encOut (g a)).length + 1) + k) := by + intro a + refine (hM_g a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl + rw [hQ]; simp only [hP.2, Bool.cond_true] + -- arm 2: run `h`, guarded by `sel a = false` + have h₂ : ∀ a, TransformsTapes M_h + (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = false) + (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (c_h * (telse a + 1)) (c_h * (selse a + (encOut (h a)).length + 1) + k) := by + intro a + refine (hM_h a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl + rw [hQ]; simp only [hP.2, Bool.cond_false] + -- branch on the selector bit on tape `c` + obtain ⟨S_br, hS_br, M_br, hM_br⟩ := + exists_transformsTapes_branch (J := α) c true + (P₁ := fun a input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = true) + (P₂ := fun a input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = false) + (Q := fun a _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (t₁ := fun a => c_g * (tif a + 1)) + (s₁ := fun a => c_g * (sif a + (encOut (g a)).length + 1) + k) + (t₂ := fun a => c_h * (telse a + 1)) + (s₂ := fun a => c_h * (selse a + (encOut (h a)).length + 1) + k) h₁ h₂ + have := hS_br + -- run the selector, then the branch, as a single tape transformer emitting `o` + have hMc : ∀ a, TransformsTapes (M_sel.seq M_br) + (fun input ws => input = encIn a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encOut (bif sel a then g a else h a)) + (c_sel * (tc a + 1) + (max (c_g * (tif a + 1)) (c_h * (telse a + 1)) + 1)) + (c_sel * (sc a + (boolEnc (sel a)).length + 1) + k + + (max (c_g * (sif a + (encOut (g a)).length + 1) + k) + (c_h * (selse a + (encOut (h a)).length + 1) + k) + k)) := by + intro a + refine (transformsTapes_seq (hM_sel a) (hM_br a) ?_).imp ?_ ?_ le_rfl le_rfl + · -- handoff: after the selector, the branch precondition holds + rintro _ ws ws' ⟨rfl, hblank⟩ hQsel + have hchead : (ws' c).head? = some (sel a) := by rw [hQsel, Function.update_self]; simp + have hbl : ∀ l, l ∉ ({c} : Finset (Fin k)) → ws' l = [] := fun l hl => by + rw [hQsel, Function.update_of_ne (by simpa using hl)]; exact hblank l (by simp) + split + · rename_i hcond + rw [hchead] at hcond + exact ⟨⟨rfl, hbl⟩, Option.some.inj hcond⟩ + · rename_i hcond + rw [hchead] at hcond + refine ⟨⟨rfl, hbl⟩, ?_⟩ + rw [← Bool.not_eq_true] + exact fun h => hcond (by rw [h]) + · -- an all-blank input satisfies the selector's precondition + rintro _ ws ⟨rfl, hblank⟩ + exact ⟨rfl, fun l _ => hblank l⟩ + · -- read the result off the output tape + rintro _ ws ws'' _ ⟨ws', _, hQbr⟩ + rw [hQbr, Function.update_self] + -- emit tape `o`, turning the transformer into a computation + obtain ⟨c₀, hc₀⟩ := + computableInTimeAndSpace_of_transformsTapes (gg := fun a => bif sel a then g a else h a) o hMc + refine ⟨c₀ * (2 * c_sel + c_g + c_h + 3 * k + 3), hc₀.mono (fun a => ?_) (fun a => ?_)⟩ + · -- time + set U := tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1 with hU + have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by + have := hleg a; have := hleh a + cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left c₀ ?_ + have e_sel : c_sel * (tc a + 1) ≤ c_sel * U := Nat.mul_le_mul_left _ (by omega) + have e_g : c_g * (tif a + 1) ≤ c_g * U := Nat.mul_le_mul_left _ (by omega) + have e_h : c_h * (telse a + 1) ≤ c_h * U := Nat.mul_le_mul_left _ (by omega) + have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U + = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] + omega + · -- space + set U := tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1 with hU + have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by + have := hleg a; have := hleh a + cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left c₀ ?_ + have hkU : k ≤ k * U := Nat.le_mul_of_pos_right k (by omega) + have e_sel : c_sel * (sc a + (boolEnc (sel a)).length + 1) ≤ 2 * (c_sel * U) := by + have h1 : (boolEnc (sel a)).length = 1 := by simp + calc c_sel * (sc a + (boolEnc (sel a)).length + 1) + ≤ c_sel * (2 * U) := Nat.mul_le_mul_left _ (by rw [h1]; omega) + _ = 2 * (c_sel * U) := by rw [Nat.mul_left_comm] + have e_g : c_g * (sif a + (encOut (g a)).length + 1) ≤ c_g * U := + Nat.mul_le_mul_left _ (by have := hleg a; omega) + have e_h : c_h * (selse a + (encOut (h a)).length + 1) ≤ c_h * U := + Nat.mul_le_mul_left _ (by have := hleh a; omega) + have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U + = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] + omega /-! ### The finite case analysis From 1593bff9ae938da4d36c53d9232632841380253f Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 21:45:38 +0000 Subject: [PATCH 63/93] refactor(Turing): delete the now-dead input-branch machinery With `cond` rebuilt on the tape-transformer path, the streaming input-dispatch machine is unused. Remove `exists_inputBranch_run`, the `inputBranch` instance and its per-instance dispatch lemmas (`inputStep_start_*`, `runFrom_start_*`, `spaceUsed_start_*`) and `inputSymbol_wordsCfg`. The shared `armed`/`branch` core and `exists_transformsTapes_branch` are kept. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Plumbing/Branch.lean | 186 +----------------- 1 file changed, 9 insertions(+), 177 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean index 2b1ca4c77..14f752ab6 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -14,50 +14,32 @@ public import Mathlib.Basic.Finite.Sum /-! # Branching combinators -Two dispatch combinators sit on a shared core. Each first reads one symbol, then — depending on -whether that symbol equals `some x` — behaves like `tm₁` or like `tm₂`, each started in its initial -state on the tapes as they were: +`branch i x tm₁ tm₂` first reads one symbol — the one under the head of work tape `i` — then, +depending on whether it equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its +initial state on the tapes as they were. -* `branch i x tm₁ tm₂` reads the symbol under the head of work tape `i`; -* `inputBranch x tm₁ tm₂` reads the symbol under the input head. - -Both are control combinators analogous to sequential composition (`Plumbing/Sequential.lean`): the +It is a control combinator analogous to sequential composition (`Plumbing/Sequential.lean`): the state space adds a fresh dispatch state on top of `State₁ ⊕ State₂`, the dispatch is one step that writes nothing and moves no head, and afterwards the machine mirrors the chosen sub-machine through -a left/right embedding just as `seq` mirrors its second machine. The only difference between the -two is which symbol the dispatch reads, so both are instances of a single machine `armed d` -parameterised by the dispatch decision `d`, and the arm-mirroring semiconjugation is proved once, -for all `d`. +a left/right embedding just as `seq` mirrors its second machine. It is an instance of a single +machine `armed d` parameterised by the dispatch decision `d`, and the arm-mirroring semiconjugation +is proved once, for all `d`. Because at a starting `wordsCfg` the head of every work tape sits at the start of its word, tape -`i`'s symbol there is exactly `(ws i).head?`, and the input head sits at the first input symbol, so -that symbol is exactly `input.head?`; each dispatch reads precisely the predicate its specification -branches on. +`i`'s symbol there is exactly `(ws i).head?`, so the dispatch reads precisely the predicate its +specification branches on. ## Main results * `Turing.MultiTapeTM.exists_transformsTapes_branch`: from two transformations sharing a postcondition, a single machine that runs one or the other according to the symbol under tape `i`, with the time bound `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. -* `Turing.MultiTapeTM.exists_inputBranch_run`: a single machine that reads the input's first symbol - and runs one of two given machines to completion — output included — plus one dispatch step. -/ namespace Turing.MultiTapeTM variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} -/-- The symbol under the input head of a `wordsCfg` is the input's first symbol: the head is at -position `1`, over `input[0]` when the input is nonempty and at the right boundary otherwise. -/ -public lemma inputSymbol_wordsCfg {State : Type*} (input : List Bool) (q : Option State) - (ws : Fin k → List Bool) (out : List Bool) : - (wordsCfg input q ws out).inputSymbol = input.head? := by - cases input with - | nil => simp only [wordsCfg, Cfg.inputSymbol]; rfl - | cons b t => - rw [inputSymbolInner 0 (by simp [wordsCfg]) (by simp)] - simp - namespace Branch /-- The shared branching machine, parameterised by a dispatch decision `d`. State `none` is a fresh @@ -182,120 +164,6 @@ private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) simp [branch, armed, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] -/-! ### The input branch -/ - -/-- The input-branching machine. State `none` is a fresh dispatch state: it reads the symbol under -the input head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial -state (if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, -its states carried by `Sum.inl`/`Sum.inr`. -/ -private abbrev inputBranch (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) - (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) := - armed (fun inp _work => if inp = some x then Sum.inl tm₁.q₀ else Sum.inr tm₂.q₀) tm₁ tm₂ - -/-- The dispatch step when the input's first symbol is `some x`: it lands on `tm₁`'s initial -configuration, embedded on the left. -/ -private lemma inputStep_start_left (ws : Fin k → List Bool) (out : List Bool) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = - leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by - have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = - some none := rfl - rw [step_apply_of_state hstate, inputSymbol_wordsCfg] - refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [inputBranch, armed, h, leftCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] - -/-- The dispatch step when the input's first symbol is not `some x`: it lands on `tm₂`'s initial -configuration, embedded on the right. -/ -private lemma inputStep_start_right (ws : Fin k → List Bool) (out : List Bool) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).step (wordsCfg input (some none) ws out) = - rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by - have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = - some none := rfl - rw [step_apply_of_state hstate, inputSymbol_wordsCfg] - refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> - simp [inputBranch, armed, h, rightCfg, Cfg.mapState, wordsCfg, Action.apply, SignType.cast] - -/-- The full run when the input's first symbol is `some x`: after the dispatch step the machine -mirrors `tm₁` step for step. -/ -private lemma runFrom_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - leftCfg (S₂ := S₂) (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, inputStep_start_left ws out h, runFrom_leftCfg] - -/-- The full run when the input's first symbol is not `some x`. -/ -private lemma runFrom_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) (τ + 1) = - rightCfg (S₁ := S₁) (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ) := by - rw [runFrom_succ_eq_step, inputStep_start_right ws out h, runFrom_rightCfg] - -/-- Space bound of the left branch: the dispatch step costs at most `k` cells and the mirrored run -of `tm₁` uses exactly `tm₁`'s space. -/ -private lemma spaceUsed_start_left (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : input.head? = some x) : - (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := by - have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - inputStep_start_left ws out h] - have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₁) - (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_leftCfg, workTapePos_leftCfg] - calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k := Nat.add_comm _ _ - -/-- Space bound of the right branch. -/ -private lemma spaceUsed_start_right (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ) - (h : ¬ input.head? = some x) : - (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := by - have hstep1 : (inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = - rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by - rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, - inputStep_start_right ws out h] - have hsp1 : (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by - refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 fun m _ => ?_ - rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl - · rw [runFrom_zero] - · rw [hstep1]; rfl - have hsp2 : (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := by - rw [hstep1] - refine le_of_eq (spaceUsed_eq_of_workTapePos (tm := inputBranch x tm₁ tm₂) (tm' := tm₂) - (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) - τ fun m _ => ?_) - rw [runFrom_rightCfg, workTapePos_rightCfg] - calc (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ + 1) - = (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ) := by - rw [Nat.add_comm] - _ ≤ (inputBranch x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + - (inputBranch x tm₁ tm₂).spaceUsed - ((inputBranch x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ := - spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ - _ ≤ k + tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ := Nat.add_le_add hsp1 hsp2 - _ = tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k := Nat.add_comm _ _ - end Branch open Branch in @@ -387,40 +255,4 @@ public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) ( _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega -open Branch in -/-- **Streaming dispatch on the input.** A single machine that reads the input's first symbol and -then runs one of two given machines to completion — output included. The arms read the whole input -in place (the dispatch moves no head) and may emit: the combined machine's output, halting and -space are exactly the chosen arm's, plus one dispatch step (costing at most `k`). - -Started at a word configuration in the dispatch state, in `τ + 1` steps the machine reads the -input's first symbol and, if it is `some x`, runs `tm₁` for `τ` steps, otherwise `tm₂`. This is -what lets a case analysis send a branch's result straight to the real output tape instead of -parking it. -/ -public theorem exists_inputBranch_run {k : ℕ} (x : Bool) {S₁ S₂ : Type} - [Finite S₁] [Finite S₂] - (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : - ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), - ∀ (input : List Bool) (ws : Fin k → List Bool) (out : List Bool) (τ : ℕ), - (input.head? = some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₁.spaceUsed (wordsCfg input (some tm₁.q₀) ws out) τ + k) ∧ - (input.head? ≠ some x → - (tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).output = - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).output ∧ - ((tm.runFrom (wordsCfg input (some tm.q₀) ws out) (τ + 1)).state = none ↔ - (tm₂.runFrom (wordsCfg input (some tm₂.q₀) ws out) τ).state = none) ∧ - tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) (τ + 1) ≤ - tm₂.spaceUsed (wordsCfg input (some tm₂.q₀) ws out) τ + k) := by - refine ⟨Option (S₁ ⊕ S₂), inferInstance, inputBranch x tm₁ tm₂, - fun input ws out τ => ⟨fun h => ?_, fun h => ?_⟩⟩ - · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_left ws out τ h] - exact ⟨rfl, by simp [leftCfg, Option.map_eq_none_iff], spaceUsed_start_left ws out τ h⟩ - · rw [show (inputBranch x tm₁ tm₂).q₀ = none from rfl, runFrom_start_right ws out τ h] - exact ⟨rfl, by simp [rightCfg, Option.map_eq_none_iff], spaceUsed_start_right ws out τ h⟩ - end Turing.MultiTapeTM From b76d2f1b1b9413b4c38d5f485c5e57f0153b4961 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 21:47:50 +0000 Subject: [PATCH 64/93] refactor(Turing): delete dead concat/pair/take/drop combinators After `cond` was rebuilt on the transformer path, `computableInTimeAndSpace_concat`, `_pair`, `_take`, `_drop` had no callers (referenced only by the aggregator). Remove `Combinators/Concat.lean` and `Combinators/TakeDrop.lean`. Co-Authored-By: Claude Opus 4.8 --- Cslib.lean | 2 - .../Turing/MultiTape/Combinators/Concat.lean | 287 ----------------- .../MultiTape/Combinators/TakeDrop.lean | 294 ------------------ 3 files changed, 583 deletions(-) delete mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean delete mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean diff --git a/Cslib.lean b/Cslib.lean index defbccb40..f04d1646e 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -56,11 +56,9 @@ public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp -public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Concat public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop -public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.TakeDrop public import Cslib.Computability.Machines.Turing.MultiTape.Configuration public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean deleted file mode 100644 index 4d9138e09..000000000 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Concat.lean +++ /dev/null @@ -1,287 +0,0 @@ -/- -Copyright (c) 2026 Christian Reitwiessner. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Christian Reitwiessner --/ - -module - -public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes -public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential - -/-! -# Complexity of a concatenation of two functions - -If `f` and `g` are computable, then so is any function whose encoded result is the encoded result -of `f` followed by the encoded result of `g`. The machine runs a *tidy* machine for `f`, which -halts with `encB (f x)` on the append-only output tape and every work tape blank and the input head -rewound, and then a tidy machine for `g` on disjoint work tapes, which appends `encC (g x)` to the -same output tape. The intermediate results are never stored on a work tape: both machines write -straight to the output, which is append-only, so the outputs end up concatenated. - -Because the tidy machine rewinds the input head and re-blanks its work tapes, the configuration -between the two phases is again a clean word configuration, and the second machine reads the same -input as the first with no explicit rewinding step in between. - -This is the introduction rule of a finite product, dual to the case analysis of -`Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite`. Note that only the *syntactic* -factorisation of the encoding is required: producing a pair asks nothing of the encoding beyond -`henc`; reading a component back out is a genuine computability requirement, handled elsewhere. - -## Main results - -* `Turing.MultiTapeTM.computableInTimeAndSpace_concat`: the complexity of a concatenation. -* `Turing.MultiTapeTM.computableInTimeAndSpace_pair`: the special case of a pair. --/ - -@[expose] public section - -namespace Turing.MultiTapeTM - -variable {α β γ δ : Type*} {k : ℕ} {State : Type*} {input : List Bool} - -/-- Running from a configuration with a nonempty output tape is the same as running from the empty -one and prepending: the transition never reads the output, so its only effect on the run is a -constant prefix on the final output tape. -/ -private lemma step_withOutput_prepend (tm : MultiTapeTM k Bool State) (Y : List Bool) - (c : Cfg k Bool State input) : - tm.step (c.withOutput (Y ++ c.output)) = - (tm.step c).withOutput (Y ++ (tm.step c).output) := by - cases hq : c.state with - | none => - have h1 : (c.withOutput (Y ++ c.output)).state = none := hq - rw [step_of_halt h1, step_of_halt hq] - | some q => - have h1 : (c.withOutput (Y ++ c.output)).state = some q := hq - have hin : (c.withOutput (Y ++ c.output)).inputSymbol = c.inputSymbol := rfl - have hws : (c.withOutput (Y ++ c.output)).workTapeSymbols = c.workTapeSymbols := rfl - rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] - refine Cfg.ext rfl rfl rfl rfl ?_ - simp only [Action.apply_output, Cfg.withOutput_output, List.append_assoc] - -/-- The run from a configuration with output `Y ++ c.output` is the run from `c` with `Y` prepended -to the final output. -/ -private lemma runFrom_withOutput_prepend (tm : MultiTapeTM k Bool State) (Y : List Bool) - (c : Cfg k Bool State input) (n : ℕ) : - tm.runFrom (c.withOutput (Y ++ c.output)) n = - (tm.runFrom c n).withOutput (Y ++ (tm.runFrom c n).output) := - runFrom_comm_of_step (fun c => c.withOutput (Y ++ c.output)) - (fun c => step_withOutput_prepend tm Y c) c n - -/-- Replacing the output of a word configuration is again a word configuration. -/ -private lemma withOutput_wordsCfg (q : Option State) (ws : Fin k → List Bool) (o z : List Bool) : - (wordsCfg input q ws o).withOutput z = wordsCfg input q ws z := rfl - -/-- An all-blank word configuration on `k` tapes, embedded through `er` with blank extra tapes, is -that same all-blank word configuration. Both hold the empty word on every tape with every head at -the start. -/ -private lemma embed_blank_collapse {kr : ℕ} {Sr : Type} (er : Fin kr ↪ Fin k) - (input : List Bool) (q : Option Sr) (out : List Bool) : - embed er (wordsCfg input q (fun _ => []) out) (fun _ _ => none) (fun _ => 0) = - wordsCfg input q (fun _ => []) out := by - refine Cfg.ext rfl rfl ?_ ?_ rfl - · funext l z - simp only [embed, wordsCfg_workTapes] - cases partialInv er l <;> simp [tapeOfList_nil] - · funext l; simp only [embed, wordsCfg_workTapePos]; cases partialInv er l <;> rfl - -/-- **Bridge: an all-blank run of a reindexed machine mirrors the underlying machine.** If the -underlying machine `tmr`, started on blank tapes with output `outS`, halts on blank tapes with -output `outF`, then so does `extendTapes tmr er` on the larger blank layout. Both endpoints are -all-blank word configurations, so the tape embedding collapses on each side. -/ -private lemma extendTapes_run_blank {kr : ℕ} {Sr : Type} (tmr : MultiTapeTM kr Bool Sr) - (er : Fin kr ↪ Fin k) (input outS outF : List Bool) (n : ℕ) - (hrun : tmr.runFrom (wordsCfg input (some tmr.q₀) (fun _ => []) outS) n = - wordsCfg input none (fun _ => []) outF) : - (extendTapes tmr er).runFrom - (wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS) n = - wordsCfg input none (fun _ => []) outF := by - have hstart : wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS = - embed er (wordsCfg input (some tmr.q₀) (fun _ => []) outS) (fun _ _ => none) (fun _ => 0) := - (embed_blank_collapse er input (some tmr.q₀) outS).symm - rw [hstart, runFrom_embed, hrun, embed_blank_collapse] - -/-- **Bridge for space.** The space used by a reindexed all-blank run is that of the underlying -run plus at most one cell for each of the extra tapes. -/ -private lemma spaceUsed_extendTapes_blank {kr : ℕ} {Sr : Type} (tmr : MultiTapeTM kr Bool Sr) - (er : Fin kr ↪ Fin k) (input outS : List Bool) (n : ℕ) : - (extendTapes tmr er).spaceUsed - (wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS) n ≤ - tmr.spaceUsed (wordsCfg input (some tmr.q₀) (fun _ => []) outS) n + (k - kr) := by - rw [show wordsCfg input (some (extendTapes tmr er).q₀) (fun _ => []) outS = - embed er (wordsCfg input (some tmr.q₀) (fun _ => []) outS) (fun _ _ => none) (fun _ => 0) from - (embed_blank_collapse er input (some tmr.q₀) outS).symm] - exact spaceUsed_embed_le tmr er _ _ _ n - -/-- **Complexity of a concatenation.** If `f` and `g` are computable and the encoded result of `h` -is the encoded result of `f` followed by the encoded result of `g`, then `h` is computable: run a -tidy machine for `f`, whose result is emitted to the output tape, then a tidy machine for `g` on -disjoint work tapes, which appends its result to the same output tape. - -The bound is stated in the relaxed multiplicative shape `c * (… + 1)`: nothing downstream needs it -tight, and the space bound carries no output-length term because neither result is ever parked on a -work tape. -/ -public theorem computableInTimeAndSpace_concat - {f : α → β} {g : α → γ} {h : α → δ} - {encIn : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} {encD : δ ↪ List Bool} - {tf sf tg sg : α → ℕ} - (henc : ∀ x, encD (h x) = encB (f x) ++ encC (g x)) - (hf : ComputableInTimeAndSpace f encIn encB tf sf) - (hg : ComputableInTimeAndSpace g encIn encC tg sg) : - ∃ c, ComputableInTimeAndSpace h encIn encD - (fun x => c * (tf x + tg x + 1)) - (fun x => c * (sf x + sg x + 1)) := by - classical - obtain ⟨cf, kf, Sf, hSf, tmf, Hf⟩ := exists_tidy hf - obtain ⟨cg, kg, Sg, hSg, tmg, Hg⟩ := exists_tidy hg - have := hSf; have := hSg - set K := kf + kg with hK - let e_f : Fin kf ↪ Fin K := - ⟨fun j => ⟨j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - let e_g : Fin kg ↪ Fin K := - ⟨fun j => ⟨kf + j.val, by have := j.isLt; omega⟩, - fun a b hab => Fin.ext (by have := congrArg Fin.val hab; simpa using this)⟩ - -- the composed machine and the additive-bound version of the claim - have main : ComputableInTimeAndSpace h encIn encD - (fun x => cf * (tf x + 1) + cg * (tg x + 1)) - (fun x => (cf * (sf x + 1) + kf + K) + (cg * (sg x + 1) + kg + K)) := by - refine ⟨K, Sf ⊕ Sg, inferInstance, (extendTapes tmf e_f).seq (extendTapes tmg e_g), fun x => ?_⟩ - obtain ⟨τf, hτf, hrunf, hspf⟩ := Hf x - obtain ⟨τg, hτg, hrung, hspg⟩ := Hg x - -- beta-reduce the tidy bounds so the arithmetic solvers see them - replace hτf : τf ≤ cf * (tf x + 1) := hτf - replace hspf : tmf.spaceUsed (tmf.initCfg (encIn x)) τf ≤ cf * (sf x + 1) + kf := hspf - replace hτg : τg ≤ cg * (tg x + 1) := hτg - replace hspg : tmg.spaceUsed (tmg.initCfg (encIn x)) τg ≤ cg * (sg x + 1) + kg := hspg - set start := ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).initCfg (encIn x) with hstart - have hstart_words : start = wordsCfg (encIn x) - (some ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).q₀) (fun _ => []) [] := by - rw [hstart, initCfg_eq_wordsCfg] - -- the raw `tmg` run started with `encB (f x)` already on the output tape, via prepending - have hrung' : tmg.runFrom (wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x))) τg = - wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := by - have hstart_eq : - wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x)) = - (tmg.initCfg (encIn x)).withOutput - (encB (f x) ++ (tmg.initCfg (encIn x)).output) := by - rw [initCfg_eq_wordsCfg, wordsCfg_output, List.append_nil, withOutput_wordsCfg] - rw [hstart_eq, runFrom_withOutput_prepend, hrung, - wordsCfg_output, withOutput_wordsCfg, henc] - -- phase 1 and phase 2 as reindexed all-blank runs - have hMf : (extendTapes tmf e_f).runFrom - (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) τf = - wordsCfg (encIn x) none (fun _ => []) (encB (f x)) := - extendTapes_run_blank tmf e_f (encIn x) [] (encB (f x)) τf - (by rw [← initCfg_eq_wordsCfg]; exact hrunf) - have hMg : (extendTapes tmg e_g).runFrom - (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) τg = - wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := - extendTapes_run_blank tmg e_g (encIn x) (encB (f x)) (encD (h x)) τg hrung' - -- first halting times, for the activity hypotheses - obtain ⟨u₁, hu₁le, hu₁halt, hu₁act⟩ := - exists_minimal_halting_time (extendTapes tmf e_f) - (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) τf (by rw [hMf]; rfl) - have hMf' : (extendTapes tmf e_f).runFrom - (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) u₁ = - wordsCfg (encIn x) none (fun _ => []) (encB (f x)) := - (runFrom_eq_of_halt _ _ hu₁le hu₁halt).symm.trans hMf - obtain ⟨u₂, hu₂le, hu₂halt, hu₂act⟩ := - exists_minimal_halting_time (extendTapes tmg e_g) - (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) τg - (by rw [hMg]; rfl) - have hMg' : (extendTapes tmg e_g).runFrom - (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) u₂ = - wordsCfg (encIn x) none (fun _ => []) (encD (h x)) := - (runFrom_eq_of_halt _ _ hu₂le hu₂halt).symm.trans hMg - -- space bounds for the two phases, via the space bridge - have hspf' : (extendTapes tmf e_f).spaceUsed - (wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) []) u₁ ≤ - cf * (sf x + 1) + kf + K := by - refine le_trans (spaceUsed_extendTapes_blank tmf e_f (encIn x) [] u₁) ?_ - rw [← initCfg_eq_wordsCfg] - have hb : tmf.spaceUsed (tmf.initCfg (encIn x)) u₁ ≤ cf * (sf x + 1) + kf := - le_trans (spaceUsed_mono tmf _ hu₁le) hspf - omega - have hspg' : (extendTapes tmg e_g).spaceUsed - (wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x))) u₂ ≤ - cg * (sg x + 1) + kg + K := by - refine le_trans (spaceUsed_extendTapes_blank tmg e_g (encIn x) (encB (f x)) u₂) ?_ - -- the raw run's space is output-independent, so the tidy bound (at `initCfg`) controls it - have hsp_out : - tmg.spaceUsed (wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x))) u₂ = - tmg.spaceUsed (tmg.initCfg (encIn x)) u₂ := by - have hstart_eq : - wordsCfg (encIn x) (some tmg.q₀) (fun _ => []) (encB (f x)) = - (tmg.initCfg (encIn x)).withOutput - (encB (f x) ++ (tmg.initCfg (encIn x)).output) := by - rw [initCfg_eq_wordsCfg, wordsCfg_output, List.append_nil, withOutput_wordsCfg] - rw [hstart_eq] - refine spaceUsed_eq_of_workTapePos _ _ u₂ fun m _ => ?_ - rw [runFrom_withOutput_prepend]; rfl - rw [hsp_out] - have hb : tmg.spaceUsed (tmg.initCfg (encIn x)) u₂ ≤ cg * (sg x + 1) + kg := - le_trans (spaceUsed_mono tmg _ hu₂le) hspg - omega - -- assemble the two phases; the phase start configurations are word configurations - have hcwf : start.withState (some (extendTapes tmf e_f).q₀) = - wordsCfg (encIn x) (some (extendTapes tmf e_f).q₀) (fun _ => []) [] := by - rw [hstart_words]; rfl - have hcwg : - (wordsCfg (k := K) (State := Sf) (encIn x) none (fun _ => []) (encB (f x))).withState - (some (extendTapes tmg e_g).q₀) = - wordsCfg (encIn x) (some (extendTapes tmg e_g).q₀) (fun _ => []) (encB (f x)) := rfl - rw [← hcwf] at hMf' hu₁act hspf' - rw [← hcwg] at hMg' hu₂act hspg' - obtain ⟨hseq_run, _hseq_act, hseq_sp⟩ := - seq_spec (tm₁ := extendTapes tmf e_f) (tm₂ := extendTapes tmg e_g) (c := start) - (c₁ := wordsCfg (encIn x) none (fun _ => []) (encB (f x))) - (c₂ := wordsCfg (encIn x) none (fun _ => []) (encD (h x))) - (by rw [hstart_words]; rfl) - hMf' rfl hu₁act hspf' - hMg' rfl hu₂act hspg' - refine ⟨u₁ + u₂, (by omega : u₁ + u₂ ≤ cf * (tf x + 1) + cg * (tg x + 1)), - ((extendTapes tmf e_f).seq (extendTapes tmg e_g)).spaceUsed start (u₁ + u₂), hseq_sp, - ?_, ?_, rfl⟩ - · rw [hseq_run]; rfl - · rw [hseq_run]; rfl - -- renormalise the additive bounds into the stated multiplicative shape - refine ⟨cf + cg + 3 * K + 1, main.mono (fun x => ?_) (fun x => ?_)⟩ - · -- time: `cf·(tf+1) + cg·(tg+1) ≤ (cf+cg)·(tf+tg+1) ≤ D·(tf+tg+1)` - set D := cf + cg + 3 * K + 1 with hD - have ha : cf * (tf x + 1) ≤ cf * (tf x + tg x + 1) := Nat.mul_le_mul le_rfl (by omega) - have hb : cg * (tg x + 1) ≤ cg * (tf x + tg x + 1) := Nat.mul_le_mul le_rfl (by omega) - have hsum : cf * (tf x + tg x + 1) + cg * (tf x + tg x + 1) = - (cf + cg) * (tf x + tg x + 1) := (Nat.add_mul _ _ _).symm - have hDle : (cf + cg) * (tf x + tg x + 1) ≤ D * (tf x + tg x + 1) := - Nat.mul_le_mul (by omega) le_rfl - omega - · -- space: `cf·(sf+1) + cg·(sg+1) + 3K ≤ (cf+cg+3K)·(sf+sg+1) ≤ D·(sf+sg+1)` - set D := cf + cg + 3 * K + 1 with hD - have ha : cf * (sf x + 1) ≤ cf * (sf x + sg x + 1) := Nat.mul_le_mul le_rfl (by omega) - have hb : cg * (sg x + 1) ≤ cg * (sf x + sg x + 1) := Nat.mul_le_mul le_rfl (by omega) - have hsum : cf * (sf x + sg x + 1) + cg * (sf x + sg x + 1) = - (cf + cg) * (sf x + sg x + 1) := (Nat.add_mul _ _ _).symm - have hkk : 3 * K ≤ (3 * K) * (sf x + sg x + 1) := Nat.le_mul_of_pos_right _ (by omega) - have hsum2 : (cf + cg) * (sf x + sg x + 1) + (3 * K) * (sf x + sg x + 1) = - (cf + cg + 3 * K) * (sf x + sg x + 1) := (Nat.add_mul _ _ _).symm - have hDle : (cf + cg + 3 * K) * (sf x + sg x + 1) ≤ D * (sf x + sg x + 1) := - Nat.mul_le_mul (by omega) le_rfl - omega - -/-- **Complexity of computing a pair.** The special case of `computableInTimeAndSpace_concat` in -which the two results are packed into a pair, encoded by concatenating the two encodings. -/ -public theorem computableInTimeAndSpace_pair - {f : α → β} {g : α → γ} - {encIn : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} - {encPair : β × γ ↪ List Bool} {tf sf tg sg : α → ℕ} - (henc : ∀ p : β × γ, encPair p = encB p.1 ++ encC p.2) - (hf : ComputableInTimeAndSpace f encIn encB tf sf) - (hg : ComputableInTimeAndSpace g encIn encC tg sg) : - ∃ c, ComputableInTimeAndSpace (fun x => (f x, g x)) encIn encPair - (fun x => c * (tf x + tg x + 1)) - (fun x => c * (sf x + sg x + 1)) := - computableInTimeAndSpace_concat (fun x => henc (f x, g x)) hf hg - -end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean deleted file mode 100644 index 968cda674..000000000 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/TakeDrop.lean +++ /dev/null @@ -1,294 +0,0 @@ -/- -Copyright (c) 2026 Christian Reitwiessner. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Christian Reitwiessner --/ - -module - -public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic - -/-! -# Complexity of `take` and `drop` - -Two single-purpose streaming machines with no work tapes: - -* `dropMachine n` skips the first `n` input symbols and then copies the rest to the output tape; -* `takeMachine n` copies the first `n` input symbols to the output tape and then halts. - -Both run in one step per input symbol and use no space. They are the tools that, together with -concatenation, let a one-bit tag be stripped from an encoding: `drop 1` recovers the argument after -a tag, `take 1` reads the tag. - -The results are stated at the level of an *encoding change*: `id : α → α` is computable from an -encoding `encFrom` to an encoding `encTo` whenever `encTo a` is `(encFrom a).drop n` (respectively -`(encFrom a).take n`). - -## Main results - -* `Turing.MultiTapeTM.computableInTimeAndSpace_drop`: dropping a fixed prefix is computable. -* `Turing.MultiTapeTM.computableInTimeAndSpace_take`: taking a fixed prefix is computable. --/ - -namespace Turing.MultiTapeTM - -variable {α : Type*} {input : List Bool} - -/-! ### Dropping a fixed prefix -/ - -/-- The drop machine: no work tapes, states `Fin (n + 1)` counting the symbols skipped so far. In a -state below `n` it skips the current symbol (move right, emit nothing); in the top state `n` it -copies the current symbol to the output and moves right; on the blank at the right end it halts. -/ -def dropMachine (n : ℕ) : MultiTapeTM 0 Bool (Fin (n + 1)) where - q₀ := ⟨0, by omega⟩ - tr q s _ := - match s with - | some b => - if h : q.val < n then - { inputTape := 1, workTapes := fun i => i.elim0, output := none, - state := some ⟨q.val + 1, by omega⟩ } - else - { inputTape := 1, workTapes := fun i => i.elim0, output := some b, state := some q } - | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } - -namespace Drop - -/-- A configuration of the drop machine: the state, the input head position and the output. -/ -def cfg (n : ℕ) (input : List Bool) (q : Option (Fin (n + 1))) (p : Fin (input.length + 2)) - (out : List Bool) : Cfg 0 Bool (Fin (n + 1)) input := - ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ - -variable {n : ℕ} - -/-- A skip step: below the top state, over an input symbol, the machine moves right and advances the -counter without emitting. -/ -lemma step_skip {i : ℕ} (hi : i < n) (hj : i < input.length) (out : List Bool) : - (dropMachine n).step (cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) = - cfg n input (some ⟨i + 1, by omega⟩) ⟨i + 2, by omega⟩ out := by - have hsym := inputSymbolInner (cfg := cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) - i (by simp only [cfg]; omega) hj - unfold step - simp only [cfg] at hsym ⊢ - rw [hsym] - simp only [dropMachine, hi, ↓reduceDIte] - refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) (by simp [Action.apply]) - simp [Action.apply, moveInputPos] - grind - -/-- A copy step: in the top state, over an input symbol, the machine emits it and moves right. -/ -lemma step_copy {j : ℕ} (hj : j < input.length) (out : List Bool) : - (dropMachine n).step (cfg n input (some ⟨n, by omega⟩) ⟨j + 1, by omega⟩ out) = - cfg n input (some ⟨n, by omega⟩) ⟨j + 2, by omega⟩ (out ++ (input[j]?).toList) := by - have hsym := inputSymbolInner (cfg := cfg n input (some ⟨n, by omega⟩) ⟨j + 1, by omega⟩ out) - j (by simp only [cfg]; omega) hj - unfold step - simp only [cfg] at hsym ⊢ - rw [hsym] - simp only [dropMachine, lt_irrefl, ↓reduceDIte] - refine Cfg.ext_zero_tapes rfl ?_ ?_ - · apply Fin.ext; simp [Action.apply, moveInputPos]; grind - · simp [Action.apply, List.getElem?_eq_getElem hj] - -/-- On the blank at the right end of the input, the machine halts in place, wherever the head is -parked at that boundary. -/ -lemma step_halt {q : Fin (n + 1)} {p : Fin (input.length + 2)} (hp : p.val = input.length + 1) - (out : List Bool) : - (dropMachine n).step (cfg n input (some q) p out) = cfg n input none p out := by - have hsym : (cfg n input (some q) p out).inputSymbol = none := - inputSymbol_eq_none_of_boundary (Or.inr hp) - unfold step - simp only [cfg] at hsym ⊢ - rw [hsym] - exact Cfg.ext_zero_tapes rfl (by simp [dropMachine, Action.apply]) (by simp [dropMachine, - Action.apply]) - -/-- The skip phase: after `i ≤ min n input.length` steps the machine has skipped the first `i` -symbols and is over the `i`-th input cell in state `⟨i⟩`, with empty output. -/ -lemma runFrom_skip (i : ℕ) (hin : i ≤ n) (hil : i ≤ input.length) : - (dropMachine n).runFrom ((dropMachine n).initCfg input) i = - cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ [] := by - induction i with - | zero => exact Cfg.ext_zero_tapes rfl rfl rfl - | succ i ih => - rw [runFrom_succ_eq_step', ih (by omega) (by omega), step_skip (by omega) (by omega)] - -/-- The copy phase: from the top state at input cell `n`, after `j` steps the machine has copied -`(input.drop n).take j`. -/ -lemma runFrom_copy (j : ℕ) (hj : n + j ≤ input.length) : - (dropMachine n).runFrom (cfg n input (some ⟨n, by omega⟩) ⟨n + 1, by omega⟩ []) j = - cfg n input (some ⟨n, by omega⟩) ⟨n + j + 1, by omega⟩ ((input.drop n).take j) := by - induction j with - | zero => simp only [Nat.add_zero, List.take_zero]; rfl - | succ j ih => - rw [runFrom_succ_eq_step', ih (by omega), step_copy (j := n + j) (by omega)] - simp only [cfg] - refine Cfg.ext_zero_tapes rfl rfl ?_ - rw [List.take_add_one, List.getElem?_drop] - -/-- The full run halts, in `input.length + 1` steps, with `input.drop n` on the output tape. -/ -lemma runFrom_full (n : ℕ) (input : List Bool) : - (dropMachine n).runFrom ((dropMachine n).initCfg input) (input.length + 1) = - cfg n input none ⟨input.length + 1, by omega⟩ (input.drop n) := by - by_cases hle : n ≤ input.length - · -- skip `n`, copy `length - n`, then one halt step - have hcopy := runFrom_copy (input := input) (n := n) (input.length - n) (by omega) - conv_lhs => rw [show input.length + 1 = n + ((input.length - n) + 1) from by omega] - rw [runFrom_add, runFrom_skip n le_rfl hle, runFrom_add, hcopy, runFrom_succ_eq_step', - runFrom_zero, - step_halt (show (⟨n + (input.length - n) + 1, by omega⟩ : Fin (input.length + 2)).val = - input.length + 1 from by simp; omega)] - simp only [cfg] - refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) ?_ - · change n + (input.length - n) + 1 = input.length + 1 - omega - · change (input.drop n).take (input.length - n) = input.drop n - rw [show input.length - n = (input.drop n).length from by rw [List.length_drop], - List.take_length] - · -- the input is exhausted during the skip phase and the machine halts blank - rw [runFrom_succ_eq_step', runFrom_skip input.length (by omega) le_rfl, step_halt rfl] - simp only [cfg] - refine Cfg.ext_zero_tapes rfl rfl ?_ - rw [List.drop_eq_nil_of_le (by omega)] - -/-- **The drop machine outputs `input.drop n`**, in `input.length + 1` steps and no space. -/ -theorem computesInTimeAndSpace (n : ℕ) (input : List Bool) : - ComputesInTimeAndSpace (dropMachine n) input (input.drop n) (input.length + 1) 0 := - ⟨by rw [runFrom_full]; rfl, by rw [runFrom_full]; rfl, - (dropMachine n).spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ - -end Drop - -/-- **Dropping a fixed prefix is computable.** If `encTo a` is `(encFrom a).drop n` for every `a`, -then the identity is computable from `encFrom` to `encTo`, in one step per input symbol and no -space. -/ -public theorem computableInTimeAndSpace_drop {encFrom encTo : α ↪ List Bool} (n : ℕ) - (h : ∀ a, encTo a = (encFrom a).drop n) : - ComputableInTimeAndSpace (id : α → α) encFrom encTo - (fun a => (encFrom a).length + 1) (fun _ => 0) := - ⟨0, Fin (n + 1), inferInstance, dropMachine n, fun a => - ⟨(encFrom a).length + 1, le_rfl, 0, le_rfl, by - rw [show encTo (id a) = (encFrom a).drop n from h a] - exact Drop.computesInTimeAndSpace n (encFrom a)⟩⟩ - -/-! ### Taking a fixed prefix -/ - -/-- The take machine: no work tapes, states `Fin (n + 1)` counting the symbols copied so far. Below -the top state `n`, over an input symbol, it copies it to the output and moves right; on reaching the -top state, or the blank at the right end, it halts. -/ -def takeMachine (n : ℕ) : MultiTapeTM 0 Bool (Fin (n + 1)) where - q₀ := ⟨0, by omega⟩ - tr q s _ := - match s with - | some b => - if h : q.val < n then - { inputTape := 1, workTapes := fun i => i.elim0, output := some b, - state := some ⟨q.val + 1, by omega⟩ } - else - { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } - | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } - -namespace Take - -/-- A configuration of the take machine. -/ -def cfg (n : ℕ) (input : List Bool) (q : Option (Fin (n + 1))) (p : Fin (input.length + 2)) - (out : List Bool) : Cfg 0 Bool (Fin (n + 1)) input := - ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ - -variable {n : ℕ} - -/-- A copy step: below the top state, over an input symbol, emit it and move right. -/ -lemma step_copy {i : ℕ} (hi : i < n) (hj : i < input.length) (out : List Bool) : - (takeMachine n).step (cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) = - cfg n input (some ⟨i + 1, by omega⟩) ⟨i + 2, by omega⟩ (out ++ (input[i]?).toList) := by - have hsym := inputSymbolInner (cfg := cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ out) - i (by simp only [cfg]; omega) hj - unfold step - simp only [cfg] at hsym ⊢ - rw [hsym] - simp only [takeMachine, hi, ↓reduceDIte] - refine Cfg.ext_zero_tapes rfl (Fin.ext ?_) ?_ - · simp [Action.apply, moveInputPos]; grind - · simp [Action.apply, List.getElem?_eq_getElem hj] - -/-- In the top state the machine halts in place, whatever it reads. -/ -lemma step_halt_top {p : Fin (input.length + 2)} (out : List Bool) : - (takeMachine n).step (cfg n input (some ⟨n, by omega⟩) p out) = cfg n input none p out := by - unfold step - simp only [cfg] - cases hsym : (⟨some (⟨n, by omega⟩ : Fin (n + 1)), p, fun _ _ => none, fun _ => 0, out⟩ : - Cfg 0 Bool (Fin (n + 1)) input).inputSymbol with - | none => - simp only [takeMachine] - exact Cfg.ext_zero_tapes rfl (by simp [Action.apply, moveInputPos_zero]) - (by simp [Action.apply]) - | some b => - simp only [takeMachine, lt_irrefl, ↓reduceDIte] - exact Cfg.ext_zero_tapes rfl (by simp [Action.apply, moveInputPos_zero]) - (by simp [Action.apply]) - -/-- On the blank at the right end the machine halts. -/ -lemma step_halt_blank {q : Fin (n + 1)} {p : Fin (input.length + 2)} (hp : p.val = input.length + 1) - (out : List Bool) : - (takeMachine n).step (cfg n input (some q) p out) = cfg n input none p out := by - have hsym : (cfg n input (some q) p out).inputSymbol = none := - inputSymbol_eq_none_of_boundary (Or.inr hp) - unfold step - simp only [cfg] at hsym ⊢ - rw [hsym] - exact Cfg.ext_zero_tapes rfl (by simp [takeMachine, Action.apply]) (by simp [takeMachine, - Action.apply]) - -/-- The copy phase: after `i ≤ min n input.length` steps the machine has copied the first `i` -symbols and sits over cell `i` in state `⟨i⟩`. -/ -lemma runFrom_copy (i : ℕ) (hin : i ≤ n) (hil : i ≤ input.length) : - (takeMachine n).runFrom ((takeMachine n).initCfg input) i = - cfg n input (some ⟨i, by omega⟩) ⟨i + 1, by omega⟩ (input.take i) := by - induction i with - | zero => exact Cfg.ext_zero_tapes rfl rfl rfl - | succ i ih => - rw [runFrom_succ_eq_step', ih (by omega) (by omega), step_copy (by omega) (by omega)] - simp only [cfg] - refine Cfg.ext_zero_tapes rfl rfl ?_ - change input.take i ++ (input[i]?).toList = input.take (i + 1) - rw [List.take_add_one] - -/-- The full run halts, in `input.length + 1` steps, with `input.take n` on the output tape (the -input head is parked wherever the machine stopped, so the position is left existential). -/ -lemma runFrom_full (n : ℕ) (input : List Bool) : - ∃ p, (takeMachine n).runFrom ((takeMachine n).initCfg input) (input.length + 1) = - cfg n input none p (input.take n) := by - by_cases hle : n ≤ input.length - · -- copy `n` symbols, then halt in the top state (position `n + 1`) - refine ⟨⟨n + 1, by omega⟩, ?_⟩ - conv_lhs => rw [show input.length + 1 = n + 1 + (input.length - n) from by omega] - rw [runFrom_add, runFrom_add, runFrom_copy n le_rfl hle, runFrom_succ_eq_step', - runFrom_zero, step_halt_top, runFrom_of_halt _ (by simp [cfg])] - · -- the input is exhausted first, and the machine halts blank (position `length + 1`) - refine ⟨⟨input.length + 1, by omega⟩, ?_⟩ - rw [runFrom_succ_eq_step', runFrom_copy input.length (by omega) le_rfl, step_halt_blank rfl] - simp only [cfg] - refine Cfg.ext_zero_tapes rfl rfl ?_ - change input.take input.length = input.take n - rw [List.take_length, List.take_of_length_le (by omega)] - -/-- **The take machine outputs `input.take n`**, in `input.length + 1` steps and no space. -/ -theorem computesInTimeAndSpace (n : ℕ) (input : List Bool) : - ComputesInTimeAndSpace (takeMachine n) input (input.take n) (input.length + 1) 0 := by - obtain ⟨p, hp⟩ := runFrom_full n input - exact ⟨by rw [hp]; rfl, by rw [hp]; rfl, (takeMachine n).spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ - -end Take - -/-- **Taking a fixed prefix is computable.** If `encTo a` is `(encFrom a).take n` for every `a`, -then the identity is computable from `encFrom` to `encTo`, in one step per input symbol and no -space. -/ -public theorem computableInTimeAndSpace_take {encFrom encTo : α ↪ List Bool} (n : ℕ) - (h : ∀ a, encTo a = (encFrom a).take n) : - ComputableInTimeAndSpace (id : α → α) encFrom encTo - (fun a => (encFrom a).length + 1) (fun _ => 0) := - ⟨0, Fin (n + 1), inferInstance, takeMachine n, fun a => - ⟨(encFrom a).length + 1, le_rfl, 0, le_rfl, by - rw [show encTo (id a) = (encFrom a).take n from h a] - exact Take.computesInTimeAndSpace n (encFrom a)⟩⟩ - -end Turing.MultiTapeTM From eea37ab61b44650940ffc926b42901424a3caa8e Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 10 Sep 2026 22:14:58 +0000 Subject: [PATCH 65/93] refactor(Turing): share a single t s across cond/ite/dite Collapse the six per-branch bounds `tc sc tif sif telse selse` in `computableInTimeAndSpace_cond`/`_ite`/`_dite` into a single shared `t s` pair used by the selector and both branches, matching `computableInTimeAndSpace_match`. The conclusion becomes the normalised `c * (t a + s a + (encIn a).length + 1)` shape for both time and space. `cond_norm` first weakens its three differently-scaled inputs to a common bound before applying the single-bound `cond`. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Combinators/Ite.lean | 115 ++++++++++-------- 1 file changed, 65 insertions(+), 50 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean index 0be380799..0439a5636 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -36,9 +36,10 @@ splices in one `cond` per case. ## Bounds -Bounds here are deliberately relaxed to a single combined shape, `c * (… + 1)`, collecting the six -input bounds and the input length: nothing downstream depends on the conditional family being tight -(`loop` and `comp` do not use it), and the construction spends constant factors freely. +Bounds here are deliberately relaxed to a single combined shape, `c * (… + 1)`, collecting the +shared time and space bounds and the input length: nothing downstream depends on the conditional +family being tight (`loop` and `comp` do not use it), and the construction spends constant factors +freely. ## Main results @@ -78,13 +79,13 @@ before the branch and emitting tape `o` (`computableInTimeAndSpace_of_transforms the case analysis. Bounds are relaxed to the single combined shape `c * (… + 1)`; nothing downstream needs them tight. -/ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → β} - {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} - (hsel : ComputableInTimeAndSpace sel encIn boolEnc tc sc) - (hif : ComputableInTimeAndSpace g encIn encOut tif sif) - (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {t s : α → ℕ} + (hsel : ComputableInTimeAndSpace sel encIn boolEnc t s) + (hif : ComputableInTimeAndSpace g encIn encOut t s) + (helse : ComputableInTimeAndSpace h encIn encOut t s) : ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by classical -- the three function machines, placed on a shared layout by the general adapters obtain ⟨m_sel, c_sel, hsel'⟩ := exists_transformsTapes_ofComputableInput hsel @@ -102,14 +103,14 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → obtain ⟨S_h, hS_h, M_h, hM_h⟩ := helse' k o {c} (by simpa using hoc) (by simp only [Finset.card_singleton]; omega) have := hS_sel; have := hS_g; have := hS_h - have hleg : ∀ a, (encOut (g a)).length ≤ tif a := hif.length_encOut_le - have hleh : ∀ a, (encOut (h a)).length ≤ telse a := helse.length_encOut_le + have hleg : ∀ a, (encOut (g a)).length ≤ t a := hif.length_encOut_le + have hleh : ∀ a, (encOut (h a)).length ≤ t a := helse.length_encOut_le -- arm 1: run `g`, guarded by `sel a = true`, its result identified with the case analysis have h₁ : ∀ a, TransformsTapes M_g (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) ∧ sel a = true) (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) - (c_g * (tif a + 1)) (c_g * (sif a + (encOut (g a)).length + 1) + k) := by + (c_g * (t a + 1)) (c_g * (s a + (encOut (g a)).length + 1) + k) := by intro a refine (hM_g a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl rw [hQ]; simp only [hP.2, Bool.cond_true] @@ -118,7 +119,7 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) ∧ sel a = false) (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) - (c_h * (telse a + 1)) (c_h * (selse a + (encOut (h a)).length + 1) + k) := by + (c_h * (t a + 1)) (c_h * (s a + (encOut (h a)).length + 1) + k) := by intro a refine (hM_h a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl rw [hQ]; simp only [hP.2, Bool.cond_false] @@ -130,19 +131,19 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → (P₂ := fun a input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) ∧ sel a = false) (Q := fun a _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) - (t₁ := fun a => c_g * (tif a + 1)) - (s₁ := fun a => c_g * (sif a + (encOut (g a)).length + 1) + k) - (t₂ := fun a => c_h * (telse a + 1)) - (s₂ := fun a => c_h * (selse a + (encOut (h a)).length + 1) + k) h₁ h₂ + (t₁ := fun a => c_g * (t a + 1)) + (s₁ := fun a => c_g * (s a + (encOut (g a)).length + 1) + k) + (t₂ := fun a => c_h * (t a + 1)) + (s₂ := fun a => c_h * (s a + (encOut (h a)).length + 1) + k) h₁ h₂ have := hS_br -- run the selector, then the branch, as a single tape transformer emitting `o` have hMc : ∀ a, TransformsTapes (M_sel.seq M_br) (fun input ws => input = encIn a ∧ ∀ l, ws l = []) (fun _ _ ws' => ws' o = encOut (bif sel a then g a else h a)) - (c_sel * (tc a + 1) + (max (c_g * (tif a + 1)) (c_h * (telse a + 1)) + 1)) - (c_sel * (sc a + (boolEnc (sel a)).length + 1) + k + - (max (c_g * (sif a + (encOut (g a)).length + 1) + k) - (c_h * (selse a + (encOut (h a)).length + 1) + k) + k)) := by + (c_sel * (t a + 1) + (max (c_g * (t a + 1)) (c_h * (t a + 1)) + 1)) + (c_sel * (s a + (boolEnc (sel a)).length + 1) + k + + (max (c_g * (s a + (encOut (g a)).length + 1) + k) + (c_h * (s a + (encOut (h a)).length + 1) + k) + k)) := by intro a refine (transformsTapes_seq (hM_sel a) (hM_br a) ?_).imp ?_ ?_ le_rfl le_rfl · -- handoff: after the selector, the branch precondition holds @@ -170,35 +171,35 @@ public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → computableInTimeAndSpace_of_transformsTapes (gg := fun a => bif sel a then g a else h a) o hMc refine ⟨c₀ * (2 * c_sel + c_g + c_h + 3 * k + 3), hc₀.mono (fun a => ?_) (fun a => ?_)⟩ · -- time - set U := tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1 with hU + set U := t a + s a + (encIn a).length + 1 with hU have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by have := hleg a; have := hleh a cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega rw [Nat.mul_assoc] refine Nat.mul_le_mul_left c₀ ?_ - have e_sel : c_sel * (tc a + 1) ≤ c_sel * U := Nat.mul_le_mul_left _ (by omega) - have e_g : c_g * (tif a + 1) ≤ c_g * U := Nat.mul_le_mul_left _ (by omega) - have e_h : c_h * (telse a + 1) ≤ c_h * U := Nat.mul_le_mul_left _ (by omega) + have e_sel : c_sel * (t a + 1) ≤ c_sel * U := Nat.mul_le_mul_left _ (by omega) + have e_g : c_g * (t a + 1) ≤ c_g * U := Nat.mul_le_mul_left _ (by omega) + have e_h : c_h * (t a + 1) ≤ c_h * U := Nat.mul_le_mul_left _ (by omega) have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] omega · -- space - set U := tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1 with hU + set U := t a + s a + (encIn a).length + 1 with hU have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by have := hleg a; have := hleh a cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega rw [Nat.mul_assoc] refine Nat.mul_le_mul_left c₀ ?_ have hkU : k ≤ k * U := Nat.le_mul_of_pos_right k (by omega) - have e_sel : c_sel * (sc a + (boolEnc (sel a)).length + 1) ≤ 2 * (c_sel * U) := by + have e_sel : c_sel * (s a + (boolEnc (sel a)).length + 1) ≤ 2 * (c_sel * U) := by have h1 : (boolEnc (sel a)).length = 1 := by simp - calc c_sel * (sc a + (boolEnc (sel a)).length + 1) + calc c_sel * (s a + (boolEnc (sel a)).length + 1) ≤ c_sel * (2 * U) := Nat.mul_le_mul_left _ (by rw [h1]; omega) _ = 2 * (c_sel * U) := by rw [Nat.mul_left_comm] - have e_g : c_g * (sif a + (encOut (g a)).length + 1) ≤ c_g * U := + have e_g : c_g * (s a + (encOut (g a)).length + 1) ≤ c_g * U := Nat.mul_le_mul_left _ (by have := hleg a; omega) - have e_h : c_h * (selse a + (encOut (h a)).length + 1) ≤ c_h * U := + have e_h : c_h * (s a + (encOut (h a)).length + 1) ≤ c_h * U := Nat.mul_le_mul_left _ (by have := hleh a; omega) have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by @@ -242,16 +243,30 @@ private lemma cond_norm {sel : α → Bool} {g h : α → β} {encOut : β ↪ L obtain ⟨c1, h1⟩ := hsel obtain ⟨c2, h2⟩ := hg obtain ⟨c3, h3⟩ := hh - obtain ⟨C, hC⟩ := computableInTimeAndSpace_cond h1 h2 h3 - refine ⟨C * (2 * c1 + 2 * c2 + 2 * c3 + 2), hC.mono (fun a => ?_) (fun a => ?_)⟩ <;> + set C₀ := c1 + c2 + c3 with hC₀ + -- weaken the three inputs to the common bound `C₀ * (t + s + L + 1)` + have hmono : ∀ (c' : ℕ), c' ≤ C₀ → ∀ a, + c' * (t a + s a + (encIn a).length + 1) ≤ C₀ * (t a + s a + (encIn a).length + 1) := + fun _ hc' a => Nat.mul_le_mul_right _ hc' + have h1' : ComputableInTimeAndSpace sel encIn boolEnc + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h1.mono (hmono c1 (by omega)) (hmono c1 (by omega)) + have h2' : ComputableInTimeAndSpace g encIn encOut + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h2.mono (hmono c2 (by omega)) (hmono c2 (by omega)) + have h3' : ComputableInTimeAndSpace h encIn encOut + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h3.mono (hmono c3 (by omega)) (hmono c3 (by omega)) + obtain ⟨C, hC⟩ := computableInTimeAndSpace_cond h1' h2' h3' + refine ⟨C * (2 * C₀ + 1), hC.mono (fun a => ?_) (fun a => ?_)⟩ <;> · rw [Nat.mul_assoc] refine Nat.mul_le_mul_left C ?_ - have hexp : (2 * c1 + 2 * c2 + 2 * c3 + 2) * (t a + s a + (encIn a).length + 1) = - 2 * (c1 * (t a + s a + (encIn a).length + 1)) + - 2 * (c2 * (t a + s a + (encIn a).length + 1)) + - 2 * (c3 * (t a + s a + (encIn a).length + 1)) + - 2 * (t a + s a + (encIn a).length + 1) := by - rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc, Nat.mul_assoc] + have hexp : (2 * C₀ + 1) * (t a + s a + (encIn a).length + 1) = + 2 * (C₀ * (t a + s a + (encIn a).length + 1)) + (t a + s a + (encIn a).length + 1) := by + rw [Nat.add_mul, Nat.mul_assoc, Nat.one_mul] omega /-- The single-bit test `decide (sel a = i₀)`, in the normalised shape. Composing the scrutinee with @@ -405,13 +420,13 @@ decides it. This is `computableInTimeAndSpace_cond` read through `decide`: the ` of `ite` carries no computational content, so all that is needed of the predicate is that its Boolean test is computable to `boolEnc`. -/ public theorem computableInTimeAndSpace_ite {p : α → Prop} [DecidablePred p] {g h : α → β} - {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} - (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc tc sc) - (hif : ComputableInTimeAndSpace g encIn encOut tif sif) - (helse : ComputableInTimeAndSpace h encIn encOut telse selse) : + {encOut : β ↪ List Bool} {t s : α → ℕ} + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc t s) + (hif : ComputableInTimeAndSpace g encIn encOut t s) + (helse : ComputableInTimeAndSpace h encIn encOut t s) : ∃ c, ComputableInTimeAndSpace (fun a => if p a then g a else h a) encIn encOut - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by obtain ⟨c, hc⟩ := computableInTimeAndSpace_cond hp hif helse refine ⟨c, ?_⟩ have hfun : (fun a => bif decide (p a) then g a else h a) = @@ -425,15 +440,15 @@ computable as it stands. What is asked instead is a computable *total* function branch where that branch is taken. -/ public theorem computableInTimeAndSpace_dite {p : α → Prop} [DecidablePred p] {_if : (a : α) → p a → β} {_else : (a : α) → ¬ p a → β} {If Else : α → β} - {encOut : β ↪ List Bool} {tc sc tif sif telse selse : α → ℕ} + {encOut : β ↪ List Bool} {t s : α → ℕ} (hIf : ∀ a (h : p a), If a = _if a h) (hElse : ∀ a (h : ¬ p a), Else a = _else a h) - (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc tc sc) - (hif : ComputableInTimeAndSpace If encIn encOut tif sif) - (helse : ComputableInTimeAndSpace Else encIn encOut telse selse) : + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc t s) + (hif : ComputableInTimeAndSpace If encIn encOut t s) + (helse : ComputableInTimeAndSpace Else encIn encOut t s) : ∃ c, ComputableInTimeAndSpace (fun a => dite (p a) (_if a) (_else a)) encIn encOut - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) - (fun a => c * (tc a + sc a + tif a + sif a + telse a + selse a + (encIn a).length + 1)) := by + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by obtain ⟨c, hc⟩ := computableInTimeAndSpace_ite (p := p) hp hif helse refine ⟨c, ?_⟩ have hfun : (fun a => if p a then If a else Else a) = From 1cf208215b97d795f33fbe1f8a3414ede7bd288b Mon Sep 17 00:00:00 2001 From: Jesse Alama Date: Fri, 11 Sep 2026 09:58:10 +0000 Subject: [PATCH 66/93] ci: drop manual TEST_ARGS step (#896) The step where we inject `TEST_ARGS` into the `GITHUB_ENV` environment variable was a workaround for a bug in `lean-action`, in which it ignored its own `test-args` input. That fix landed in leanprover/lean-action#153 and is included in `lean-action` since v1.6.0, which is what we pick up here on the CSLib side. --- .github/workflows/lean_action_ci.yml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml index d5ca8cefa..95bc25bd1 100644 --- a/.github/workflows/lean_action_ci.yml +++ b/.github/workflows/lean_action_ci.yml @@ -14,10 +14,6 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - - name: Set TEST_ARGS manually - run: | - echo "TEST_ARGS='--wfail --iofail'" >> $GITHUB_ENV - shell: bash - uses: leanprover/lean-action@v1 with: build-args: "--wfail --iofail" From 1aa581038190a3e5b7b8691be6f8c38afbfd6241 Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 11 Sep 2026 12:39:37 +0000 Subject: [PATCH 67/93] chore(Turing): align tape-transformer files with the split-out transforms-tapes PR Bring the interface files on this campaign branch in line with the finalized `transforms-tapes` PR (the first split-out PR against main), so that once it lands the campaign PR shows only the remaining work: * `Plumbing/TransformsTapes.lean`, `TapeLemmas.lean`: take the PR's versions verbatim (docstring/normal-form rewrite, section-style visibility, #768's space lemmas restored). * `Configuration.lean`: `Cfg.withState` moves here from `TransformsTapes`. * `Plumbing/Sequential.lean`: same docstring/section-style cleanup; `seq_spec` and its helpers stay, since they ship with a later PR (Adapters/Tidy use them). Full `lake build --wfail` + `lake lint` + `lint-style` clean. Co-Authored-By: Claude Opus 4.8 --- .../Turing/MultiTape/Configuration.lean | 5 ++ .../Turing/MultiTape/Plumbing/Sequential.lean | 37 +++++------ .../MultiTape/Plumbing/TransformsTapes.lean | 61 ++++++++----------- .../Machines/Turing/MultiTape/TapeLemmas.lean | 28 +++++++++ 4 files changed, 78 insertions(+), 53 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 0038df9c2..83494f5ab 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -194,6 +194,11 @@ abbrev Cfg.Halted (cfg : Cfg k Symbol State input) : Prop := cfg.state = none Cfg k Symbol State input := ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ +/-- The same configuration in a different control state, possibly of a different state type. -/ +@[simps] def Cfg.withState (cfg : Cfg k Symbol State input) + {State' : Type*} (q : Option State') : Cfg k Symbol State' input := + ⟨q, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + /-- Remap the (optional) state of a configuration through `φ`, leaving the input head, the work tapes, the work-tape heads and the output alone. The control-flow combinators (`seq`, `branch`, `repeat`) embed a sub-machine's configurations into the combined machine by exactly such a state diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean index fb435368e..ebb3daf2e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -12,13 +12,12 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsT # Sequential composition of machines on shared tapes `seq tm₀ tm₁` behaves like `tm₀` until `tm₀` would halt, at which point it continues as `tm₁`, -started in its initial state on the tapes as `tm₀` left them. The design is due to Samuel -Schlesinger (leanprover/cslib#872): the state space is `State₀ ⊕ State₁`, and the *halting -transition* of the first phase is mapped to the initial state of the second, so the handoff costs -no extra step. +started in its initial state on the tapes as `tm₀` left them. The state space is +`State₀ ⊕ State₁`, and the *halting transition* of the first phase is mapped to the initial state +of the second, so the handoff costs no extra step. At the specification level this is `transformsTapes_seq`: transformations compose, with the time -and space bounds adding. The postcondition of `TransformsTapes` is what makes the proof direct — +and space bounds adding. The postcondition of `TransformsTapes` is what makes the proof direct: the first machine halts in a full `wordsCfg`, which is exactly a starting configuration for the second. @@ -28,6 +27,8 @@ second. * `Turing.MultiTapeTM.transformsTapes_seq`: transformations compose, bounds adding. -/ +@[expose] public section + namespace Turing.MultiTapeTM variable {k : ℕ} {Symbol State₀ State₁ : Type*} {input : List Symbol} @@ -35,7 +36,7 @@ variable {k : ℕ} {Symbol State₀ State₁ : Type*} {input : List Symbol} /-- The sequential composition of `tm₀` and `tm₁`: it behaves like `tm₀` until `tm₀` would halt, at which point it switches to the initial state of `tm₁` and behaves like `tm₁`. The switch is folded into the halting transition of `tm₀`, so it costs no step. -/ -@[expose] public def seq (tm₀ : MultiTapeTM k Symbol State₀) (tm₁ : MultiTapeTM k Symbol State₁) : +def seq (tm₀ : MultiTapeTM k Symbol State₀) (tm₁ : MultiTapeTM k Symbol State₁) : MultiTapeTM k Symbol (State₀ ⊕ State₁) where q₀ := .inl tm₀.q₀ tr q inp work := @@ -54,17 +55,17 @@ namespace Sequential /-- A configuration of the first phase: a configuration of `tm₀`, with a halted state mapped to the initial state of the second phase. Under this map, the whole first phase of `seq` mirrors the run of `tm₀`, *including* its halting step. -/ -@[expose] public def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : +def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : Cfg k Symbol (State₀ ⊕ State₁) input := cfg.mapState (fun st => some (st.elim (.inr tm₁.q₀) .inl)) /-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the run of `tm₁`. -/ -@[expose] public def rightCfg (cfg : Cfg k Symbol State₁ input) : +def rightCfg (cfg : Cfg k Symbol State₁ input) : Cfg k Symbol (State₀ ⊕ State₁) input := cfg.mapState (Option.map .inr) -public lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : +lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by @@ -72,7 +73,7 @@ public lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ simp only [step, h1, hq] rfl -public lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : +lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by cases hq : cfg.state with | none => @@ -85,12 +86,12 @@ public lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : rfl /-- The second phase of `seq` mirrors the run of `tm₁`. -/ -public lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : +lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : (tm₀.seq tm₁).runFrom (rightCfg cfg) n = rightCfg (tm₁.runFrom cfg n) := runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n /-- While `tm₀` is running, `seq` mirrors it. -/ -public lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) +lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) (h : ∀ m < n, (tm₀.runFrom cfg m).state ≠ none) : (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) n = leftCfg tm₁ (tm₀.runFrom cfg n) := by induction n with @@ -100,21 +101,21 @@ public lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) step_leftCfg _ (h n (by omega))] @[simp] -public lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : +lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : leftCfg tm₁ (wordsCfg input (some q) ws out) = wordsCfg input (some (Sum.inl q : State₀ ⊕ State₁)) ws out := rfl @[simp] -public lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : +lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : rightCfg (State₀ := State₀) (wordsCfg input q ws out) = wordsCfg input (q.map Sum.inr) ws out := rfl @[simp] -public lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : +lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : (leftCfg tm₁ cfg).workTapePos = cfg.workTapePos := rfl @[simp] -public lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : +lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl end Sequential @@ -123,7 +124,7 @@ open Sequential in /-- **Sequential composition of transformations.** If the postcondition of the first transformation implies the precondition of the second, the composed machine performs the two transformations one after the other, with the time and space bounds adding. -/ -public theorem transformsTapes_seq +theorem transformsTapes_seq {P₀ P₁ : (input : List Symbol) → (Fin k → List Symbol) → Prop} {Q₀ Q₁ : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} {t₀ s₀ t₁ s₁ : ℕ} @@ -172,7 +173,7 @@ section RawSeq variable {K : ℕ} {Sym S₁ S₂ : Type*} {inp : List Sym} open Sequential in -public lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sym S₂} +lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sym S₂} {c : Cfg K Sym (S₁ ⊕ S₂) inp} {c₁ : Cfg K Sym S₁ inp} {c₂ : Cfg K Sym S₂ inp} {u₁ u₂ s₁' s₂' : ℕ} (hc : c.state = some (tm₁.seq tm₂).q₀) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean index e316b2e38..4dcba97bf 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -12,22 +12,19 @@ public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas # Machines as transformers of tape words The interface through which combinators use machines: a machine reads words from its work tapes -and leaves words on them, and never touches the output. A combinator composing such machines talks -about words only — never about individual cells, head positions or the set of tapes a machine has -touched. +and leaves words on them. A combinator composing such machines talks about words only, never about +individual cells, head positions or the set of tapes a machine has touched. Configurations are described by *equalities*: `wordsCfg input q ws out` is the configuration whose -work tape `i` holds exactly the word `ws i` — contents `tapeOfList (ws i)`, head at the start — with +work tape `i` holds exactly the word `ws i` (contents `tapeOfList (ws i)`, head at the start), with the input head at the start of the input and output `out`. A specification `TransformsTapes tm P Q t s` says: started on word-holding tapes satisfying `P`, the machine halts -within `t` steps *in a configuration of the same shape* — work tapes again holding words, input -head back at the start, output untouched — with the new words related to the old ones by `Q`, and -using at most `s` work-tape cells. Because the postcondition is a single configuration equality, -specifications compose by rewriting: which tapes survived a step is read off the equation instead -of being proved cell by cell. - -The description of a tape's contents as a function, `tapeOfList`, is due to Samuel Schlesinger -(as `listTape` in leanprover/cslib#872). +within `t` steps in the *normal form* `wordsCfg input none ws' out` (every head reset to its +initial position, tapes blank outside their words, output untouched), with the new words related to +the old ones by `Q` and using at most `s` work-tape cells. Requiring this normal form is what lets +specifications compose by rewriting: the halting configuration of one machine is already a valid +start for the next, so which words survived a step is read off the equation, not re-established cell +by cell. ## Main definitions @@ -43,24 +40,26 @@ The description of a tape's contents as a function, `tapeOfList`, is due to Samu machine of the interface and the check that the format is inhabited as intended. -/ +@[expose] public section + namespace Turing.MultiTapeTM variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} /-- A tape containing exactly the symbols of `xs` at positions `0, ..., xs.length - 1`. -/ -@[expose] public def tapeOfList (xs : List Symbol) : ℤ → Option Symbol +def tapeOfList (xs : List Symbol) : ℤ → Option Symbol | .ofNat n => xs[n]? | .negSucc _ => none @[simp] -public lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl +lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl @[simp] -public lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : +lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : tapeOfList xs (.negSucc n) = none := rfl /-- Appending one symbol writes precisely the cell after the existing word. -/ -public lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : +lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : tapeOfList (xs ++ [x]) = Function.update (tapeOfList xs) (xs.length : ℤ) (some x) := by funext z cases z with @@ -69,36 +68,31 @@ public lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : /-- The blank tape holds the empty word. -/ @[simp] -public lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := by +lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := by funext z cases z <;> simp /-- The cell at position `0` holds the first symbol of the word. -/ -public lemma tapeOfList_zero (xs : List Symbol) : tapeOfList xs 0 = xs.head? := by +lemma tapeOfList_zero (xs : List Symbol) : tapeOfList xs 0 = xs.head? := by have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl rw [h, tapeOfList_ofNat] cases xs <;> rfl -/-- The same configuration in a different control state, possibly of a different state type. -/ -@[expose, simps] public def _root_.Turing.Cfg.withState (cfg : Cfg k Symbol State input) - {State' : Type*} (q : Option State') : Cfg k Symbol State' input := - ⟨q, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ - /-- The configuration whose work tape `i` holds exactly the word `ws i` with its head at the start, whose input head is at the start of the input, in state `q` with output `out`. -/ -@[expose, simps] -public def wordsCfg (input : List Symbol) (q : Option State) +@[simps] +def wordsCfg (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := ⟨q, 1, fun i => tapeOfList (ws i), fun _ => 0, out⟩ /-- Remapping the state of a `wordsCfg` remaps its state and leaves the words alone. -/ @[simp] -public lemma mapState_wordsCfg {State' : Type*} (φ : Option State → Option State') +lemma mapState_wordsCfg {State' : Type*} (φ : Option State → Option State') (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : (wordsCfg input q ws out).mapState φ = wordsCfg input (φ q) ws out := rfl /-- The initial configuration is the word configuration with blank tapes and no output. -/ -public lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : +lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : tm.initCfg input = wordsCfg input (some tm.q₀) (fun _ => []) [] := by refine Cfg.ext rfl rfl ?_ rfl rfl funext i @@ -106,14 +100,11 @@ public lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List /-- `TransformsTapes tm P Q t s`: started in its initial state on tapes holding words `ws` that satisfy the precondition `P`, the machine halts after at most `t` steps in the configuration whose -tapes hold words `ws'` with `Q input ws ws'`, with the input head back at the start and the output -unchanged, having used at most `s` work-tape cells. +tapes hold words `ws'` with `Q input ws ws'`, having used at most `s` work-tape cells. -The postcondition is a single configuration equality, so a machine satisfying it has re-normalised -everything: heads at the start, tapes blank outside their words, nothing written to the output. The bounds are numbers; a specification whose bounds depend on the data is a *family* `∀ j, TransformsTapes tm (P j) (Q j) (t j) (s j)` over one fixed machine. -/ -@[expose] public def TransformsTapes (tm : MultiTapeTM k Symbol State) +def TransformsTapes (tm : MultiTapeTM k Symbol State) (P : (input : List Symbol) → (Fin k → List Symbol) → Prop) (Q : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop) (t s : ℕ) : Prop := @@ -125,7 +116,7 @@ The bounds are numbers; a specification whose bounds depend on the data is a *fa /-- A `TransformsTapes` statement can be read with a stronger precondition, a weaker postcondition and larger bounds. -/ -public theorem TransformsTapes.imp {tm : MultiTapeTM k Symbol State} +theorem TransformsTapes.imp {tm : MultiTapeTM k Symbol State} {P P' : (input : List Symbol) → (Fin k → List Symbol) → Prop} {Q Q' : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} {t s t' s' : ℕ} (h : TransformsTapes tm P Q t s) @@ -150,10 +141,10 @@ private lemma step_nop (ws : Fin k → List Symbol) (out : List Symbol) : refine Cfg.ext rfl ?_ ?_ ?_ ?_ <;> simp [step, nop, Action.apply, wordsCfg, SignType.cast] -/-- **The machine that does nothing.** It halts in one step, leaving every word as it was. Its +/-- The machine that does nothing: it halts in one step, leaving every word as it was. Its heads never move, so it visits one cell per tape. This is the first machine of the interface: it checks that the specification format is inhabited exactly as intended. -/ -public theorem exists_transformsTapes_nop (k : ℕ) (Symbol : Type*) : +theorem exists_transformsTapes_nop (k : ℕ) (Symbol : Type*) : ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), TransformsTapes tm (fun _ _ => True) (fun _ ws ws' => ws' = ws) 1 k := by refine ⟨Unit, inferInstance, nop k Symbol, fun input ws out _ => ?_⟩ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index ed7a4d6aa..c8df87ea2 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -89,6 +89,34 @@ lemma mem_visitedByTapeHead_of_workTapes_ne · rw [tm.step_workTapes_eq_of_ne _ j z hz] at h exact tm.visitedByTapeHead_mono cfg j (Nat.le_succ t) (ih h) +/-- Every position visited by the head of tape `i` lies within `spaceUsedByTape … i` of the +head's starting position. -/ +lemma natAbs_le_spaceUsedByTape_of_mem_visited + {i : Fin k} + {z : ℤ} + {t : ℕ} + (hz : z ∈ tm.visitedByTapeHead cfg t i) : + (z - cfg.workTapePos i).natAbs ≤ tm.spaceUsedByTape cfg t i := by + obtain ⟨t', ht', rfl⟩ := tm.mem_visitedByTapeHead.mp hz + have h1 := Finset.card_le_card + ((tm.uIcc_workTapePos_subset_visitedByTapeHead cfg i t').trans + (tm.visitedByTapeHead_mono cfg i (show t' ≤ t by omega))) + rw [Int.card_uIcc] at h1 + unfold spaceUsedByTape + omega + +/-- Every non-blank cell on work tape `i` lies within `spaceUsedByTape … i t` of the origin. -/ +lemma content_natAbs_le_spaceUsedByTape + {i : Fin k} + (t : ℕ) + (z : ℤ) + (h : (tm.runFrom (tm.initCfg input) t).workTapes i z ≠ none) : + z.natAbs ≤ tm.spaceUsedByTape (tm.initCfg input) t i := by + -- The work tapes start out blank, so any non-blank cell has been visited by the head; the + -- initial head position is `0`, so the displacement bound is a bound on the position itself. + simpa using tm.natAbs_le_spaceUsedByTape_of_mem_visited + (tm.mem_visitedByTapeHead_of_workTapes_ne i t z h) + /-- The number of cells touched by a single work tape grows by at most one each step. -/ lemma spaceUsedByTape_le (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : tm.spaceUsedByTape cfg t i ≤ t + 1 := by From 70b71765bbee9a90fd26050b95869b4b7476c506 Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 11 Sep 2026 12:43:01 +0000 Subject: [PATCH 68/93] docs: add campaign PR plan (dependency DAG + proposed PR split) Campaign bookkeeping for the tape-transformer / loop work: the intra-module dependency DAG, new-vs-modified file inventory, and the proposed sequence of independently reviewable PRs against main (PR 1 = transforms-tapes finalized), with the foundation-lemma / seq_spec / withState placement decisions recorded. Not part of any split PR; must not be merged into main. Co-Authored-By: Claude Opus 4.8 --- PR_PLAN.md | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 PR_PLAN.md diff --git a/PR_PLAN.md b/PR_PLAN.md new file mode 100644 index 000000000..872c113e0 --- /dev/null +++ b/PR_PLAN.md @@ -0,0 +1,95 @@ +# Turing MultiTape complexity — campaign PR plan + +This branch (`loop/06-tape-transformers`) is the campaign branch: it proves **function +composition** (`computableInTimeAndSpace_comp`) and the **loop combinator** +(`computableInTimeAndSpace_loopFunction`) on top of a reusable machine-layer toolkit. It is also +the PR into `main` that tracks *what is still to do*. + +The work is being split into small, independently reviewable PRs against `main`, one at a time. +After each split PR is finalized, this branch's copies of the files it owns are made byte-identical +to it, so once it lands the campaign diff shows only the remaining work. + +This file is campaign bookkeeping; it is **not** part of any split PR and should never be merged +into `main`. + +## Status + +| PR | Name | State | Branch | +|----|------|-------|--------| +| 1 | transforms-tapes | **finalized** | `pr/transforms-tapes` (off `main`) | +| 2+ | see below | planned | — | + +Sibling PRs already split earlier in the campaign: `loop/03` (AlmostConstant), `loop/04` +(Option encoding), `loop/05` (Id). + +## Files: new vs. modified + +Pre-existing on `main` (campaign only *adds* to them): `Configuration.lean`, `Deterministic.lean`, +`TapeLemmas.lean`. Everything else under `Cslib/Computability/Machines/Turing/MultiTape/` +(`Plumbing/*`, `NormalForms/*`, `Combinators/*`, `Encodings/Option`) is new. + +## Dependency DAG (intra-`MultiTape` imports) + +``` +Configuration (base; +mapState +withState) + └─ Deterministic (+runFrom_eq_of_halt +exists_minimal_halting_time +...) + ├─ TapeLemmas (+space lemmas) + │ └─ Plumbing/TransformsTapes + │ ├─ Plumbing/Sequential (transformsTapes_seq; seq_spec deferred) + │ ├─ Plumbing/Clear + │ ├─ NormalForms/Instrument + │ └─ NormalForms/Sweep + ├─ Plumbing/StepLemmas + │ ├─ Plumbing/ExtendTapes (+TapeLemmas) + │ ├─ Plumbing/OutputToTape (+TransformsTapes) + │ ├─ Plumbing/InputFromTape (+TransformsTapes) + │ ├─ Plumbing/EmitTape (+TransformsTapes) + │ ├─ Plumbing/RewindTape (+TransformsTapes) + │ ├─ Plumbing/Branch (+TransformsTapes) + │ └─ Plumbing/Repeat (+TransformsTapes) + ├─ Plumbing/RewindInput + └─ Combinators/AlmostConstant (sibling PR) ─┐ + └─ Encodings/Option (sibling PR) │ + Combinators/Id (sibling PR) ─┘ + +NormalForms/Tidy <- Instrument, Sweep, RewindInput, Sequential (uses seq_spec) +NormalForms/Adapters <- Tidy, OutputToTape, RewindTape, InputFromTape, EmitTape, ExtendTapes + (uses seq_spec) +Combinators/Comp <- Adapters +Combinators/Ite <- Comp, AlmostConstant, Branch, Sequential, Adapters +Combinators/Loop <- Option, Id, Adapters, Branch, Repeat, Clear, Sequential, TransformsTapes +``` + +## Proposed PR sequence + +Each foundation lemma (in `Configuration`/`Deterministic`/`TapeLemmas`) rides with the PR of its +first user — no standalone "lemmas only" PR. + +| PR | Contents | Depends on | +|----|----------|-----------| +| **1** ✅ | `TapeLemmas` (space lemmas) · `Plumbing/TransformsTapes` · `Plumbing/Sequential` (interface-level `transformsTapes_seq` only) · `Configuration` (`mapState`, `withState`) · `Deterministic` (`runFrom_eq_of_halt`, `exists_minimal_halting_time`) | `main` | +| **2** | `Plumbing/StepLemmas` · `ExtendTapes` · `OutputToTape` · `InputFromTape` (+ their `Config`/`Deterministic` lemmas: `withOutput`, `val_moveInputPos_*`, `inputSymbol_eq_none_of_boundary`) | 1 | +| **3** | `EmitTape` · `RewindTape` · `RewindInput` · `Clear` | 1, 2 | +| **4** | `Branch` · `Repeat` | 1, 2 | +| **5** | `NormalForms/Instrument` · `Sweep` · `Tidy` (+ `Sequential.seq_spec`, `Deterministic.inputPos_runFrom_le`) | 1–4 | +| **6** | `NormalForms/Adapters` (+ `Deterministic.length_encOut_le`, `length_output_runFrom_le`) | 1–5 | +| **7** | `Combinators/Comp` (`computableInTimeAndSpace_comp`) | 6 | +| **8** | `Combinators/Ite` (`cond`/`ite`/`dite`/`match`) | 6, 7, sibling AlmostConstant | +| **9** | `Combinators/Loop` (`computableInTimeAndSpace_loopFunction`) | 6, siblings Option/Id | + +Siblings `AlmostConstant`, `Encodings/Option`, `Id` land via their own PRs (`loop/03`–`05`) and are +prerequisites for PRs 8–9. + +## Notes / deferrals + +- **`seq_spec`** (raw-configuration composition, `Plumbing/Sequential`) is *not* in PR 1. Its users + are `Tidy` and `Adapters`, so it ships with **PR 5** (first user). PR 1 keeps only the + interface-level `transformsTapes_seq`. On this campaign branch `seq_spec` is already present. +- **`withState`** was moved `TransformsTapes` → `Configuration` (it is a special case of + `mapState`). Applied on this branch too. +- **Follow-up (known):** `isOptionEncoding_encOption` (`Encodings/Option`) is still `proof_wanted`, + so `computableInTimeAndSpace_loopFunction` cannot yet be instantiated end-to-end with the + canonical `Option` encoding. Sound conditional result; discharge to make loop usable with it. +- **Policy:** don't build on Sam's PRs (#872, tm-03..06); credit him as author where his design is + used. Use Mathlib naming even where it conflicts with #872. +- Keep every PR building independently with `lake build --wfail` (+ `lake lint`, `lint-style`). From 1cda4bb11156272d35262705a96e0d9171d8e930 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Fri, 11 Sep 2026 15:04:26 +0000 Subject: [PATCH 69/93] fix(PACLearning): restrict consistency to realizable samples (#747) Fixes the definition of consistency to have realizability as a precondition. --- .../PACLearning/VersionSpace.lean | 57 +++++++++-------- CslibTests.lean | 1 + CslibTests/PACLearning.lean | 62 +++++++++++++++++++ 3 files changed, 93 insertions(+), 27 deletions(-) create mode 100644 CslibTests/PACLearning.lean diff --git a/Cslib/MachineLearning/PACLearning/VersionSpace.lean b/Cslib/MachineLearning/PACLearning/VersionSpace.lean index 7423f1fb8..753d80f80 100644 --- a/Cslib/MachineLearning/PACLearning/VersionSpace.lean +++ b/Cslib/MachineLearning/PACLearning/VersionSpace.lean @@ -21,8 +21,8 @@ Angluin (1980). - `VersionSpace C S`: the subset of `C` whose concepts agree with `S` on every sample point. -- `IsConsistent A C`: a learner is consistent with `C` if its output always lies - in the version space at the received sample. +- `IsConsistent A C`: a learner is consistent with `C` if its output lies in + the version space at every realizable sample. - `empiricalMiscount h S`: number of sample points where `h` errs (`[DecidableEq β]`). - `empiricalMeasure S`: the uniform Dirac mixture over the sample. - `empiricalError h S`: the empirical distribution's mass on the disagreement set. @@ -35,7 +35,7 @@ Angluin (1980). - `mem_versionSpace_iff_empiricalMiscount_zero`: combinatorial bridge. - `mem_versionSpace_iff_empiricalError_zero`: measure-theoretic bridge. - `IsConsistent.empiricalMiscount_eq_zero`, `IsConsistent.empiricalError_eq_zero`: - consistent learners achieve zero error / miscount on every sample. + consistent learners achieve zero error / miscount on every realizable sample. - `mem_versionSpace_of_realizable`, `Realizable.versionSpace_nonempty`: realizable samples give non-empty version spaces. - `ae_mem_versionSpace_of_realizable`: under iid sampling from a realizable @@ -169,49 +169,52 @@ theorem empiricalError_eq_div [DecidableEq β] simp only [Measure.dirac_apply, Set.indicator, Set.mem_ofPred_eq, Pi.one_apply, smul_eq_mul] rw [Finset.sum_boole, ← ENNReal.div_eq_inv_mul] +/-! ### Realizable Samples -/ + +/-- A labeled sample `S` is *realizable* by concept class `C` if some concept +in `C` labels every sample point correctly. -/ +def Realizable {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) : Prop := + ∃ c ∈ C, ∀ i : Fin m, (S i).2 = c (S i).1 + /-! ### Consistent Learners -/ -/-- A learner is *consistent* with the concept class `C` if, on every labeled -sample it receives, its output hypothesis lies in the version space of `C` at -that sample — i.e. the output is in `C` and agrees with every observed -labeled pair. -/ +/-- A learner is *consistent* with the concept class `C` if, on every sample +realizable by `C`, its output hypothesis lies in the version space of `C` at +that sample — i.e. the output is in `C` and agrees with every observed labeled +pair. No condition is imposed on samples that no concept in `C` can realize. -/ def IsConsistent {m : ℕ} (A : Learner α β m) (C : ConceptClass α β) : Prop := - ∀ S : LabeledSample α β m, A S ∈ VersionSpace C S + ∀ S : LabeledSample α β m, Realizable C S → A S ∈ VersionSpace C S -/-- A consistent learner's output is always in the concept class. -/ +/-- A consistent learner's output is in the concept class on every realizable sample. -/ theorem IsConsistent.output_mem_conceptClass {m : ℕ} {A : Learner α β m} - {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) : - A S ∈ C := (hA S).1 + {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) + (hS : Realizable C S) : + A S ∈ C := (hA S hS).1 -/-- A consistent learner's output agrees with the sample on every observed -point. -/ +/-- On every realizable sample, a consistent learner's output agrees with +every observed point. -/ theorem IsConsistent.output_agrees {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) - (i : Fin m) : - A S (S i).1 = (S i).2 := (hA S).2 i + (hS : Realizable C S) (i : Fin m) : + A S (S i).1 = (S i).2 := (hA S hS).2 i -/-- A consistent learner has zero empirical miscount on every sample. -/ +/-- A consistent learner has zero empirical miscount on every realizable sample. -/ theorem IsConsistent.empiricalMiscount_eq_zero [DecidableEq β] {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} (hA : IsConsistent A C) - (S : LabeledSample α β m) : + (S : LabeledSample α β m) (hS : Realizable C S) : empiricalMiscount (A S) S = 0 := - (mem_versionSpace_iff_empiricalMiscount_zero.mp (hA S)).2 + (mem_versionSpace_iff_empiricalMiscount_zero.mp (hA S hS)).2 -/-- A consistent learner has zero empirical error on every sample. -/ +/-- A consistent learner has zero empirical error on every realizable sample. -/ theorem IsConsistent.empiricalError_eq_zero [MeasurableSpace α] [MeasurableSpace β] [MeasurableSingletonClass α] [MeasurableSingletonClass β] {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} - (hA : IsConsistent A C) (S : LabeledSample α β m) : + (hA : IsConsistent A C) (S : LabeledSample α β m) (hS : Realizable C S) : empiricalError (A S) S = 0 := - (mem_versionSpace_iff_empiricalError_zero.mp (hA S)).2 - -/-! ### Realizable case -/ + (mem_versionSpace_iff_empiricalError_zero.mp (hA S hS)).2 -/-- A labeled sample `S` is *realizable* by concept class `C` if some concept -in `C` labels every sample point correctly. -/ -def Realizable {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) : Prop := - ∃ c ∈ C, ∀ i : Fin m, (S i).2 = c (S i).1 +/-! ### Realizable Version Spaces -/ /-- *Realizable version-space nonemptiness.* If a target concept `c` lies in `C` and the sample `S` is labeled by `c` (i.e. every `(S i).2 = c (S i).1`), diff --git a/CslibTests.lean b/CslibTests.lean index f7b53299f..64e84ecbe 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -21,5 +21,6 @@ import CslibTests.Modal import CslibTests.Modal.Ideal import CslibTests.Modal.Stlc import CslibTests.MultiTapeComplexity +import CslibTests.PACLearning import CslibTests.Reduction import CslibTests.StatefulProcesses diff --git a/CslibTests/PACLearning.lean b/CslibTests/PACLearning.lean new file mode 100644 index 000000000..2156a645e --- /dev/null +++ b/CslibTests/PACLearning.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.MachineLearning.PACLearning.VersionSpace + +namespace CslibTests.PACLearning + +open Cslib.MachineLearning.PACLearning + +/-- A learner on two samples over a singleton domain that predicts the first label. -/ +def firstLabelLearner : Learner Unit Bool 2 := + fun S _ => (S 0).2 + +/-- Two different labels for the same point form an unrealizable sample. -/ +def contradictorySample : LabeledSample Unit Bool 2 := + fun i => if i = 0 then ((), false) else ((), true) + +theorem contradictorySample_not_realizable : + ¬ Realizable (Set.univ : ConceptClass Unit Bool) contradictorySample := by + rintro ⟨c, _, hc⟩ + simpa [contradictorySample] using + (hc (0 : Fin 2)).trans (hc (1 : Fin 2)).symm + +/-- Regression: consistency does not require a learner to fit an unrealizable +contradictory sample. -/ +theorem firstLabelLearner_consistent : + IsConsistent firstLabelLearner (Set.univ : ConceptClass Unit Bool) := by + intro S hS + obtain ⟨c, _, hc⟩ := hS + rw [mem_versionSpace_iff] + refine ⟨Set.mem_univ _, fun i => ?_⟩ + change (S 0).2 = (S i).2 + calc + (S 0).2 = c (S 0).1 := hc 0 + _ = c (S i).1 := congrArg c (Subsingleton.elim _ _) + _ = (S i).2 := (hc i).symm + +example : + firstLabelLearner contradictorySample (contradictorySample 1).1 ≠ + (contradictorySample 1).2 := by + simp [firstLabelLearner, contradictorySample] + +/-- A realizable sample used to guard the positive consistency guarantee. -/ +def constantTrueSample : LabeledSample Unit Bool 2 := + fun _ => ((), true) + +theorem constantTrueSample_realizable : + Realizable (Set.univ : ConceptClass Unit Bool) constantTrueSample := by + refine ⟨fun _ => true, Set.mem_univ _, ?_⟩ + intro i + rfl + +example (i : Fin 2) : + firstLabelLearner constantTrueSample (constantTrueSample i).1 = + (constantTrueSample i).2 := + firstLabelLearner_consistent.output_agrees + constantTrueSample constantTrueSample_realizable i + +end CslibTests.PACLearning From b777e0891698a7764e1387300eb0f9053b417b42 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Fri, 11 Sep 2026 16:53:09 +0000 Subject: [PATCH 70/93] feat(governance): add Xueying Qin as reviewer (#898) Add Xueying Qin as reviewer. --- GOVERNANCE.md | 1 + 1 file changed, 1 insertion(+) diff --git a/GOVERNANCE.md b/GOVERNANCE.md index fbe4cce2d..b9b9a147c 100644 --- a/GOVERNANCE.md +++ b/GOVERNANCE.md @@ -56,3 +56,4 @@ Reviewers are trusted contributors who provide regular reviewing and technical g - Samuel Schlesinger (@SamuelSchlesinger). - Thomas Waring (@thomaskwaring). - Eric Wieser (@eric-wieser), Google DeepMind. +- Xueying Qin (@XYUnknown), FORM, University of Southern Denmark. From bdbd823028db6c316a0005d7f4cdf71aab4453ad Mon Sep 17 00:00:00 2001 From: Eric Wieser Date: Sat, 12 Sep 2026 12:04:55 +0000 Subject: [PATCH 71/93] feat: add a predicate for monad morphisms (#856) We show that various list operations are preserved under monad morphisms, and that FreeM.liftM is. Note that [PolyFun already has the _bundled_ version](https://github.com/Verified-zkEVM/PolyFun/blob/main/PolyFun/Control/Monad/Hom.lean), but having the unbundled version now does not preclude adding the bundled version later. --------- Co-authored-by: Fabrizio Montesi Co-authored-by: Kim Morrison <477956+kim-em@users.noreply.github.com> --- Cslib.lean | 2 + .../Algorithms/Lean/MergeSort/MergeSort.lean | 8 +- Cslib/Algorithms/Lean/Sort/Insertion.lean | 21 +- Cslib/Algorithms/Lean/Sort/Merge.lean | 29 +- Cslib/Algorithms/Lean/TimeM.lean | 12 + Cslib/Foundations/Control/Monad/Free.lean | 32 +- .../Foundations/Control/Monad/IsMonadHom.lean | 318 ++++++++++++++++++ .../Control/Monad/IsMonadHom/List.lean | 217 ++++++++++++ Cslib/Foundations/Data/PFunctor/Free.lean | 33 +- 9 files changed, 642 insertions(+), 30 deletions(-) create mode 100644 Cslib/Foundations/Control/Monad/IsMonadHom.lean create mode 100644 Cslib/Foundations/Control/Monad/IsMonadHom/List.lean diff --git a/Cslib.lean b/Cslib.lean index 8cfe47e01..2b04deb7f 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -83,6 +83,8 @@ public import Cslib.Foundations.Combinatorics.InfiniteGraphRamsey public import Cslib.Foundations.Control.Monad.Free public import Cslib.Foundations.Control.Monad.Free.Effects public import Cslib.Foundations.Control.Monad.Free.Fold +public import Cslib.Foundations.Control.Monad.IsMonadHom +public import Cslib.Foundations.Control.Monad.IsMonadHom.List public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.DecidableEqZero public import Cslib.Foundations.Data.FinFun.Basic diff --git a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean index 44a703f0b..2a1384cdc 100644 --- a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean +++ b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean @@ -40,18 +40,14 @@ open List in @[simp, grind =] theorem ret_mergeM {T} [AddMonoid T] (xs ys : List α) (le : α → α → TimeM T Bool) : ⟪List.mergeM xs ys le⟫ = List.merge xs ys (fun x y => ⟪le x y⟫) := by - fun_induction merge with grind [mergeM, nil_merge, merge_right, cons_merge_cons] + simpa using Id.ext_iff.1 <| isMonadHom_pure_ret.map_listMergeM xs ys le open List in /-- `TimeM.ret` passes through `List.mergeSortM` into the comparator. -/ @[simp] theorem ret_mergeSortM {T} [AddMonoid T] (xs : List α) (le : α → α → TimeM T Bool) : ⟪List.mergeSortM xs le⟫ = List.mergeSort xs (fun x y => ⟪le x y⟫) := by - fun_induction List.mergeSortM with - | case1 | case2 => simp - | case3 a b xs le iha ihb => - simp only [ret_bind, ret_mergeM, mergeSort] - rw [iha, ihb] + simpa using Id.ext_iff.1 <| isMonadHom_pure_ret.map_listMergeSortM xs le variable [LinearOrder α] diff --git a/Cslib/Algorithms/Lean/Sort/Insertion.lean b/Cslib/Algorithms/Lean/Sort/Insertion.lean index 8c571cf86..33a0e9ce3 100644 --- a/Cslib/Algorithms/Lean/Sort/Insertion.lean +++ b/Cslib/Algorithms/Lean/Sort/Insertion.lean @@ -6,6 +6,7 @@ Authors: Jeremy Avigad, Eric Wieser module public import Mathlib.Data.List.Sort +public import Cslib.Foundations.Control.Monad.IsMonadHom import Cslib.Init @@ -18,18 +19,20 @@ algorithmic analysis. public section +open Cslib (IsMonadHom) + namespace List -variable {m} [Monad m] (r : α → α → m Bool) +variable {m n} [Monad m] [Monad n] (r : α → α → m Bool) /-- A monadic version of `List.orderedInsert`. -/ def orderedInsertM (a : α) : List α → m (List α) | [] => return [a] | b :: l => do if ← r a b then return a :: b :: l else return b :: (← orderedInsertM a l) -@[simp] theorem orderedInsertM_nil (a : α) : orderedInsertM r a [] = pure [a] := by +@[simp, grind =] theorem orderedInsertM_nil (a : α) : orderedInsertM r a [] = pure [a] := by rfl -@[simp] theorem orderedInsertM_cons (a b : α) (l : List α) : +@[simp, grind =] theorem orderedInsertM_cons (a b : α) (l : List α) : orderedInsertM r a (b :: l) = do if ← r a b then return a :: b :: l else return b :: (← orderedInsertM r a l) := by rfl @@ -45,6 +48,12 @@ theorem idRun_orderedInsertM (r : α → α → Id Bool) (a : α) (xs : List α) Id.run (orderedInsertM r a xs) = orderedInsert (fun x y => Id.run <| r x y) a xs := orderedInsertM_pure _ _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_orderedInsertM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (r : α → α → m Bool) (a : α) (xs : List α) : + f (orderedInsertM r a xs) = orderedInsertM (fun x y => f (r x y)) a xs := by + fun_induction orderedInsertM r a xs with grind + /-- A monadic version of `List.insertionSort`. -/ def insertionSortM : List α → m (List α) | [] => return [] @@ -66,4 +75,10 @@ theorem idRun_insertionSortM (xs : List α) (r : α → α → Id Bool) : Id.run (insertionSortM r xs) = insertionSort (fun x y => Id.run <| r x y) xs := insertionSortM_pure _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listInsertionSortM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (r : α → α → m Bool) (xs : List α) : + f (insertionSortM r xs) = insertionSortM (fun x y => f (r x y)) xs := by + fun_induction insertionSortM r xs with simp [hf.map_pure, hf.map_bind, hf.map_orderedInsertM, *] + end List diff --git a/Cslib/Algorithms/Lean/Sort/Merge.lean b/Cslib/Algorithms/Lean/Sort/Merge.lean index a1f4c68d7..e64c6523b 100644 --- a/Cslib/Algorithms/Lean/Sort/Merge.lean +++ b/Cslib/Algorithms/Lean/Sort/Merge.lean @@ -5,8 +5,9 @@ Authors: Kim Morrison, Eric Wieser -/ module -import all Init.Data.List.Sort.Basic +public import Cslib.Foundations.Control.Monad.IsMonadHom +import all Init.Data.List.Sort.Basic import Cslib.Init /-! @@ -18,9 +19,11 @@ algorithmic analysis. public section +open Cslib (IsMonadHom) + namespace List -variable {m} [Monad m] +variable {m n} [Monad m] [Monad n] /-- A monadic version of `List.merge` -/ def mergeM (xs ys : List α) (le : α → α → m Bool) : m (List α) := do @@ -33,9 +36,11 @@ def mergeM (xs ys : List α) (le : α → α → m Bool) : m (List α) := do else return y :: (← mergeM (x :: xs) ys le) -@[simp] theorem nil_mergeM (ys : List α) (le : α → α → m Bool) : mergeM [] ys le = pure ys := by +@[simp, grind =] +theorem nil_mergeM (ys : List α) (le : α → α → m Bool) : mergeM [] ys le = pure ys := by simp [mergeM] -@[simp] theorem mergeM_right (xs : List α) (le : α → α → m Bool) : mergeM xs [] le = pure xs := by +@[simp, grind =] +theorem mergeM_right (xs : List α) (le : α → α → m Bool) : mergeM xs [] le = pure xs := by induction xs with | nil => simp | cons x xs ih => simp [mergeM] @@ -57,6 +62,14 @@ theorem idRun_mergeM (xs ys : List α) (le : α → α → Id Bool) : Id.run (mergeM xs ys le) = merge xs ys (fun x y => Id.run <| le x y) := mergeM_pure _ _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listMergeM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (xs ys : List α) (le : α → α → m Bool) : + f (mergeM xs ys le) = mergeM xs ys (fun x y => f (le x y)) := by + fun_induction mergeM xs ys le with + | case1 | case2 => grind + | case3 x xs y ys ihx ihy => simp [hf.map_bind, hf.map_pure, apply_ite f, ihx, ihy] + /-- A monadic version of `List.mergeSortM` -/ def mergeSortM (xs : List α) (le : α → α → m Bool) : m (List α) := match xs with @@ -88,4 +101,12 @@ theorem idRun_mergeSortM (xs : List α) (le : α → α → Id Bool) : Id.run (mergeSortM xs le) = mergeSort xs (fun x y => Id.run <| le x y) := mergeSortM_pure _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listMergeSortM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (xs : List α) (le : α → α → m Bool) : + f (mergeSortM xs le) = mergeSortM xs (fun x y => f (le x y)) := by + fun_induction mergeSortM xs le with + | case1 | case2 => simp [hf.map_pure] + | case3 a b xs le ih1 ih2 => simp only [mergeSortM, hf.map_bind, ih1, ih2, hf.map_listMergeM, le] + end List diff --git a/Cslib/Algorithms/Lean/TimeM.lean b/Cslib/Algorithms/Lean/TimeM.lean index 389d6945b..1cf75a4af 100644 --- a/Cslib/Algorithms/Lean/TimeM.lean +++ b/Cslib/Algorithms/Lean/TimeM.lean @@ -7,6 +7,7 @@ Authors: Sorrachai Yingchareonthawornhcai, Eric Wieser module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom public import Mathlib.Algebra.Group.Defs /-! @@ -97,6 +98,8 @@ instance [AddZero T] : Monad (TimeM T) where @[simp, grind =] theorem ret_bind {α β} [Add T] (m : TimeM T α) (f : α → TimeM T β) : (m >>= f).ret = (f m.ret).ret := rfl @[simp, grind =] theorem ret_map {α β} (f : α → β) (x : TimeM T α) : (f <$> x).ret = f x.ret := rfl +@[simp, grind =] theorem ret_mapConst {α β} (a : α) (x : TimeM T β) : + (Functor.mapConst a x).ret = a := rfl @[simp] theorem ret_seqRight {α} (x : TimeM T α) (y : Unit → TimeM T β) [Add T] : (SeqRight.seqRight x y).ret = (y ()).ret := rfl @[simp] theorem ret_seqLeft {α} [Add T] (x : TimeM T α) (y : Unit → TimeM T β) : @@ -104,6 +107,15 @@ instance [AddZero T] : Monad (TimeM T) where @[simp] theorem ret_seq {α β} [Add T] (f : TimeM T (α → β)) (x : Unit → TimeM T α) : (Seq.seq f x).ret = f.ret (x ()).ret := rfl +theorem isMonadHom_pure_ret [AddZero T] : Cslib.IsMonadHom (TimeM T) Id (fun x => pure x.ret) where + map_map _ _ := Id.ext <| ret_map _ _ + map_mapConst _ __ := Id.ext <| ret_mapConst _ _ + map_pure _ := Id.ext <| ret_pure _ + map_seq _ _ := Id.ext <| ret_seq _ _ + map_seqLeft _ _ := Id.ext <| ret_seqLeft _ _ + map_seqRight _ _ := Id.ext <| ret_seqRight _ _ + map_bind _ _ := Id.ext <| ret_bind _ _ + @[simp, grind =] theorem time_bind {α β} [Add T] (m : TimeM T α) (f : α → TimeM T β) : (m >>= f).time = m.time + (f m.ret).time := rfl @[simp, grind =] theorem time_pure {α} [Zero T] (a : α) : (pure a : TimeM T α).time = 0 := rfl diff --git a/Cslib/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean index 09d550b8b..74dea4913 100644 --- a/Cslib/Foundations/Control/Monad/Free.lean +++ b/Cslib/Foundations/Control/Monad/Free.lean @@ -7,6 +7,7 @@ Authors: Tanner Duve, Eric Wieser module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom /-! # Free Monad @@ -243,29 +244,44 @@ lemma liftM_bind [LawfulMonad m] | pure a => simp only [liftM_pure, LawfulMonad.pure_bind] | lift_bind op cont ih => simp [← ih] +/-- A morphism of monads moves inside `FreeM.liftM`. -/ +theorem _root_.Cslib.IsMonadHom.map_freeMLiftM [Monad n] + {f : ∀ {α}, m α → n α} (hf : IsMonadHom m n f) + (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) : + f (x.liftM interp) = x.liftM (fun op => f (interp op)) := by + induction x with + | pure a => exact hf.map_pure a + | lift_bind op cont ih => + simp only [bind_eq_bind, liftM_lift_bind, hf.map_bind, ih] + +/-- `FreeM.liftM interp` is a morphism of monads. -/ +theorem isMonadHom_liftM [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) : + IsMonadHom (FreeM F) m (FreeM.liftM interp) := + IsMonadHom.mk' (liftM_pure interp) (liftM_bind interp) + @[simp] lemma liftM_map [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (f : α → β) (x : FreeM F α) : - (f <$> x).liftM interp = f <$> x.liftM interp := by - simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure] + (f <$> x).liftM interp = f <$> x.liftM interp := + isMonadHom_liftM interp |>.map_map _ _ @[simp] lemma liftM_seq [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F (α → β)) (y : FreeM F α) : - (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := by - simp [seq_eq_bind_map] + (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := + isMonadHom_liftM interp |>.map_seq _ _ @[simp] lemma liftM_seqLeft [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) (y : FreeM F β) : - (x <* y).liftM interp = x.liftM interp <* y.liftM interp := by - simp [seqLeft_eq_bind] + (x <* y).liftM interp = x.liftM interp <* y.liftM interp := + isMonadHom_liftM interp |>.map_seqLeft _ _ @[simp] lemma liftM_seqRight [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) (y : FreeM F β) : - (x *> y).liftM interp = x.liftM interp *> y.liftM interp := by - simp [seqRight_eq_bind] + (x *> y).liftM interp = x.liftM interp *> y.liftM interp := + isMonadHom_liftM interp |>.map_seqRight _ _ /-- A predicate stating that `interp : FreeM F α → m α` is an interpreter for the effect diff --git a/Cslib/Foundations/Control/Monad/IsMonadHom.lean b/Cslib/Foundations/Control/Monad/IsMonadHom.lean new file mode 100644 index 000000000..a515d1a40 --- /dev/null +++ b/Cslib/Foundations/Control/Monad/IsMonadHom.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Eric Wieser. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Eric Wieser +-/ +module + +public import Cslib.Init + +public import Batteries.Control.AlternativeMonad +public import Std.Do.WP.Monad + +/-! +# (unbundled) morphisms of monads + +This file defines predicates on functions `f : ∀ {α}, m α → n α` that preserve functor, applicative, +monadic, and alternative structure (`IsFunctorHom`, `IsApplicativeHom`, `IsMonadHom`, +`IsAlternativeHom`, `IsAlternativeMonadHom`). + +Rather than assuming lawfulness, they explicitly require compatibility with every operator +defined by the corresponding typeclasses, with helper constructors that dismiss the derived +operators when the structures are lawful. +-/ + +public section + +namespace Cslib + +/-! ### Functor Homomorphisms -/ + +/-- +A function `f` is a morphism of functors if it preserves `<$>` and `Functor.mapConst`. +-/ +structure IsFunctorHom (m n) [Functor m] [Functor n] (f : ∀ {α}, m α → n α) : Prop where + map_map {α β} (g : α → β) (x : m α) : f (g <$> x) = g <$> f x + map_mapConst {α β} (a : α) (x : m β) : f (Functor.mapConst a x) = Functor.mapConst a (f x) + +namespace IsFunctorHom +variable {m n p : Type _ → Type _} [Functor m] [Functor n] [Functor p] + +attribute [grind .] map_map map_mapConst + +private theorem map_mapConst_of_map_map + [LawfulFunctor m] [LawfulFunctor n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) : + ∀ {α β} (a : α) (x : m β), f (Functor.mapConst a x) = Functor.mapConst a (f x) := by + intros α β a x + simp [LawfulFunctor.map_const, map_map] + +/-- Construct an `IsFunctorHom` for lawful functors from `map_map`. -/ +theorem mk' [LawfulFunctor m] [LawfulFunctor n] {f : ∀ {α}, m α → n α} + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) : + IsFunctorHom m n f where + map_map := map_map + map_mapConst := map_mapConst_of_map_map f map_map + +variable (m) in +protected theorem id : IsFunctorHom m m id where + map_map _ _ := rfl + map_mapConst _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsFunctorHom n p f) (hg : IsFunctorHom m n g) : + IsFunctorHom m p (f ∘ g) where + map_map _ _ := by simp [hf.map_map, hg.map_map] + map_mapConst _ _ := by simp [hf.map_mapConst, hg.map_mapConst] + +end IsFunctorHom + + +/-! ### Applicative Homomorphisms -/ + +/-- +A function `f` is a morphism of applicatives if it preserves `pure`, `<$>`, `<*>`, `<*`, and `*>`. +-/ +structure IsApplicativeHom (m n) [Applicative m] [Applicative n] (f : ∀ {α}, m α → n α) : Prop + extends IsFunctorHom m n f where + map_pure {α} (a : α) : f (pure a) = pure a + map_seq {α β} (x : m (α → β)) (y : Unit → m α) : + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·) + map_seqLeft {α β} (x : m α) (y : Unit → m β) : + f (SeqLeft.seqLeft x y) = SeqLeft.seqLeft (f x) (f <| y ·) + map_seqRight {α β} (x : m α) (y : Unit → m β) : + f (SeqRight.seqRight x y) = SeqRight.seqRight (f x) (f <| y ·) + + +namespace IsApplicativeHom +variable {m n p : Type _ → Type _} [Applicative m] [Applicative n] [Applicative p] + +attribute [grind .] map_pure map_seq map_seqLeft map_seqRight +attribute [grind →] toIsFunctorHom + +private theorem map_map_of_map_pure_map_seq + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x := by + intros α β g x + rw [← pure_seq, ← pure_seq] + change f (Seq.seq (pure g) (fun _ => x)) = Seq.seq (pure g) (fun _ => f x) + rw [map_seq, map_pure] + +private theorem map_seqLeft_of_map_seq_map_map + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (x : m α) (y : Unit → m β), + f (SeqLeft.seqLeft x y) = SeqLeft.seqLeft (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seqLeft_eq, map_seq, map_map] + +private theorem map_seqRight_of_map_seq_map_map + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (x : m α) (y : Unit → m β), + f (SeqRight.seqRight x y) = SeqRight.seqRight (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seqRight_eq, map_seq, map_map] + +/-- Construct an `IsApplicativeHom` for lawful applicatives from `map_pure` and `map_seq`. -/ +theorem mk' [LawfulApplicative m] [LawfulApplicative n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + IsApplicativeHom m n f where + map_pure + toIsFunctorHom := .mk' (map_map_of_map_pure_map_seq f map_pure map_seq) + map_seq + map_seqLeft := map_seqLeft_of_map_seq_map_map f + (map_map_of_map_pure_map_seq f map_pure map_seq) map_seq + map_seqRight := map_seqRight_of_map_seq_map_map f + (map_map_of_map_pure_map_seq f map_pure map_seq) map_seq + +variable (m) in +protected theorem id : IsApplicativeHom m m id where + map_pure _ := rfl + toIsFunctorHom := IsFunctorHom.id m + map_seq _ _ := rfl + map_seqLeft _ _ := rfl + map_seqRight _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsApplicativeHom n p f) (hg : IsApplicativeHom m n g) : + IsApplicativeHom m p (f ∘ g) where + map_pure _ := by simp [hf.map_pure, hg.map_pure] + toIsFunctorHom := hf.toIsFunctorHom.comp hg.toIsFunctorHom + map_seq _ _ := by simp [hf.map_seq, hg.map_seq] + map_seqLeft _ _ := by simp [hf.map_seqLeft, hg.map_seqLeft] + map_seqRight _ _ := by simp [hf.map_seqRight, hg.map_seqRight] + +end IsApplicativeHom + + +/-! ### Monad Homomorphisms -/ + +/-- +A function `f` is a morphism of monads if it preserves `pure`, `>>=`, `<$>`, `<*>`, `<*`, and `*>`. +-/ +structure IsMonadHom (m n) [Monad m] [Monad n] (f : ∀ {α}, m α → n α) : Prop + extends IsApplicativeHom m n f where + map_bind {α β} (x : m α) (y : α → m β) : f (x >>= y) = f x >>= (f <| y ·) + +namespace IsMonadHom +variable {m n p : Type _ → Type _} [Monad m] [Monad n] [Monad p] + +attribute [grind .] map_bind +attribute [grind →] toIsApplicativeHom + +private theorem map_map_of_map_pure_map_bind + [LawfulMonad m] [LawfulMonad n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x := by + intros α β g x + simp [← bind_pure_comp, map_bind, map_pure] + +private theorem map_seq_of_map_pure_map_bind + [LawfulMonad m] [LawfulMonad n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seq_eq_bind_map, map_map_of_map_pure_map_bind f map_pure, map_bind] + +/-- Construct an `IsMonadHom` for lawful monads from `map_pure` and `map_bind`. -/ +theorem mk' [LawfulMonad m] [LawfulMonad n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + IsMonadHom m n f where + map_bind + toIsApplicativeHom := .mk' map_pure (map_seq_of_map_pure_map_bind f map_pure map_bind) + +variable (m) in +protected theorem id : IsMonadHom m m id where + toIsApplicativeHom := IsApplicativeHom.id m + map_bind _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsMonadHom n p f) (hg : IsMonadHom m n g) : + IsMonadHom m p (f ∘ g) where + toIsApplicativeHom := hf.toIsApplicativeHom.comp hg.toIsApplicativeHom + map_bind _ _ := by simp [hf.map_bind, hg.map_bind] + +protected theorem monadLift [LawfulMonad m] [LawfulMonad n] + [MonadLift m n] [LawfulMonadLift m n] : + IsMonadHom m n MonadLift.monadLift := + .mk' LawfulMonadLift.monadLift_pure LawfulMonadLift.monadLift_bind + +protected theorem monadLiftT [LawfulMonad m] [LawfulMonad n] + [MonadLiftT m n] [LawfulMonadLiftT m n] : + IsMonadHom m n monadLift := + .mk' LawfulMonadLiftT.monadLift_pure LawfulMonadLiftT.monadLift_bind + +end IsMonadHom + +/-! ### Alternative Homomorphisms -/ + +/-- +A function `f` is a morphism of alternatives if it preserves `pure`, `<$>`, `<*>`, `<*`, `*>`, +`failure`, and `orElse`. +-/ +structure IsAlternativeHom (m n) [Alternative m] [Alternative n] (f : ∀ {α}, m α → n α) : Prop + extends IsApplicativeHom m n f where + map_failure {α} : f (Alternative.failure : m α) = Alternative.failure + map_orElse {α} (x : m α) (y : Unit → m α) : + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·) + +namespace IsAlternativeHom +variable {m n p : Type _ → Type _} [Alternative m] [Alternative n] [Alternative p] + +attribute [grind .] map_failure map_orElse +attribute [grind →] toIsApplicativeHom + +/-- Construct an `IsAlternativeHom` for lawful applicatives from `map_pure`, `map_seq`, +`map_failure`, and `map_orElse`. -/ +theorem mk' [LawfulApplicative m] [LawfulApplicative n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) + (map_failure : ∀ {α}, f (Alternative.failure : m α) = Alternative.failure) + (map_orElse : ∀ {α} (x : m α) (y : Unit → m α), + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·)) : + IsAlternativeHom m n f where + toIsApplicativeHom := .mk' map_pure map_seq + map_failure + map_orElse + +variable (m) in +protected theorem id : IsAlternativeHom m m id where + toIsApplicativeHom := IsApplicativeHom.id m + map_failure := rfl + map_orElse _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsAlternativeHom n p f) (hg : IsAlternativeHom m n g) : + IsAlternativeHom m p (f ∘ g) where + toIsApplicativeHom := hf.toIsApplicativeHom.comp hg.toIsApplicativeHom + map_failure := by simp [hf.map_failure, hg.map_failure] + map_orElse _ _ := by simp [hf.map_orElse, hg.map_orElse] + +end IsAlternativeHom + +/-! ### Alternative Monad Homomorphisms -/ + +/-- +A function `f` is a morphism of alternative monads if it preserves monadic and alternative +structure. +-/ +structure IsAlternativeMonadHom (m n) [AlternativeMonad m] [AlternativeMonad n] + (f : ∀ {α}, m α → n α) : Prop + extends IsMonadHom m n f, IsAlternativeHom m n f + +namespace IsAlternativeMonadHom +variable {m n p : Type _ → Type _} [AlternativeMonad m] [AlternativeMonad n] [AlternativeMonad p] + +attribute [grind →] toIsMonadHom toIsAlternativeHom + +/-- Construct an `IsAlternativeMonadHom` for lawful monads from `map_pure`, `map_bind`, +`map_failure`, and `map_orElse`. -/ +theorem mk' [LawfulMonad m] [LawfulMonad n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) + (map_failure : ∀ {α}, f (Alternative.failure : m α) = Alternative.failure) + (map_orElse : ∀ {α} (x : m α) (y : Unit → m α), + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·)) : + IsAlternativeMonadHom m n f where + toIsMonadHom := .mk' map_pure map_bind + map_failure + map_orElse + +variable (m) in +protected theorem id : IsAlternativeMonadHom m m id where + toIsMonadHom := IsMonadHom.id m + map_failure := rfl + map_orElse _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsAlternativeMonadHom n p f) (hg : IsAlternativeMonadHom m n g) : + IsAlternativeMonadHom m p (f ∘ g) where + toIsMonadHom := hf.toIsMonadHom.comp hg.toIsMonadHom + map_failure := by simp [hf.map_failure, hg.map_failure] + map_orElse _ _ := by simp [hf.map_orElse, hg.map_orElse] + +end IsAlternativeMonadHom + +open Std.Do WPMonad in +theorem IsMonadHom.wp [Monad m] [WPMonad m ps] : IsMonadHom m (PredTrans ps) WP.wp := + .mk' wp_pure wp_bind + +end Cslib diff --git a/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean b/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean new file mode 100644 index 000000000..44e3cc658 --- /dev/null +++ b/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Eric Wieser. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Eric Wieser +-/ +module + +public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom +public import Mathlib.Data.List.Monad + +import all Init.Data.List.Control +import Mathlib.Data.List.Basic + +/-! +# List operations and monad morphisms + +This file proves that monadic operations on lists commute with monad homomorphisms +(and applicative homomorphisms), and that `List.reverse` is a monad homomorphism on `List`. +-/ + +public section + +namespace Cslib + +universe u um un v +variable {m : Type u → Type um} {n : Type u → Type un} + +/-! ### Preservation of list operations under applicative homomorphisms -/ + +namespace IsApplicativeHom +variable [Applicative m] [Applicative n] + +@[grind .] +theorem map_listMapA {F : ∀ {α}, m α → n α} (hf : IsApplicativeHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapA f) = l.mapA (F ∘ f) := by + induction l with grind [List.mapA] + +@[grind .] +theorem map_listForA {F : ∀ {α}, m α → n α} (hf : IsApplicativeHom m n F) + {α : Type v} (l : List α) (f : α → m PUnit) : + F (l.forA f) = l.forA (F ∘ f) := by + induction l with grind [List.forA] + +end IsApplicativeHom + +/-! ### Preservation of list operations under monad homomorphisms -/ + +namespace IsMonadHom +variable [Monad m] [Monad n] + +@[grind .] +theorem map_listMapM' + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapM' f) = l.mapM' (F ∘ f) := by + induction l with grind [List.mapM'] + +@[grind .] +theorem map_listMapMLoop + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) (acc : List β) : + F (List.mapM.loop f l acc) = List.mapM.loop (F ∘ f) l acc := by + induction l generalizing acc with + | nil => exact hf.map_pure _ + | cons a l ih => simp only [List.mapM.loop, hf.map_bind, ih, Function.comp_def] + +@[grind .] +theorem map_listMapM + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapM f) = l.mapM (F ∘ f) := by + grind [List.mapM] + +@[grind .] +theorem map_listForM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (l : List α) (f : α → m PUnit) : + F (l.forM f) = l.forM (F ∘ f) := by + induction l with grind [List.forM] + +@[grind .] +theorem map_listFoldlM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {s : Type u} {α : Type v} (f : s → α → m s) (init : s) (l : List α) : + F (l.foldlM f init) = l.foldlM (fun s a => F (f s a)) init := by + induction l generalizing init with grind [List.foldlM] + +@[grind .] +theorem map_listFoldrM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {s : Type u} {α : Type v} (f : α → s → m s) (init : s) (l : List α) : + F (l.foldrM f init) = l.foldrM (fun a s => F (f a s)) init := by + simp only [List.foldrM] + exact hf.map_listFoldlM (fun s a => f a s) init l.reverse + +@[grind .] +theorem map_listFindSomeM? + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m (Option β)) (l : List α) : + F (l.findSomeM? f) = l.findSomeM? (F ∘ f) := by + induction l with grind + +@[grind .] +theorem map_listFindM? {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l : List α) : + F (l.findM? p) = l.findM? (F ∘ p) := by + induction l with grind [List.findM?] + +@[grind .] +theorem map_listAnyM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (p : α → m Bool) (l : List α) : + F (l.anyM p) = l.anyM (F ∘ p) := by + induction l with grind [List.anyM] + +@[grind .] +theorem map_listAllM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (p : α → m Bool) (l : List α) : + F (l.allM p) = l.allM (F ∘ p) := by + induction l with grind [List.allM] + +@[grind .] +theorem map_listFilterAuxM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l acc : List α) : + F (List.filterAuxM p l acc) = List.filterAuxM (F ∘ p) l acc := by + induction l generalizing acc with grind [List.filterAuxM] + +@[grind .] +theorem map_listFilterM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l : List α) : + F (l.filterM p) = l.filterM (F ∘ p) := by + grind [List.filterM] + +end IsMonadHom + +/-! ### Preservation of list operations under alternative homomorphisms -/ + +namespace IsAlternativeHom +variable [Alternative m] [Alternative n] + +@[grind .] +theorem map_listFirstM {F : ∀ {α}, m α → n α} (hf : IsAlternativeHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.firstM f) = l.firstM (F ∘ f) := by + induction l with grind [List.firstM] + +end IsAlternativeHom + +/-! ### Monad homomorphisms on the `List` monad -/ + +@[grind .] +theorem IsApplicativeHom.map_listSingleton + {F : ∀ {α}, List α → List α} (hf : IsApplicativeHom List List F) {α} (a : α) : + F ([a] : List α) = [a] := hf.map_pure _ + +theorem IsMonadHom.map_listFlatMap + {F : ∀ {α}, List α → List α} (hf : IsMonadHom List List F) {α β} (l : List α) (g : α → List β) : + F (l.flatMap g) = (F l).flatMap (F <| g ·) := hf.map_bind _ _ + +@[grind .] +theorem IsFunctorHom.map_listNil {F : ∀ {α}, List α → List α} (hf : IsFunctorHom List List F) {α} : + F ([] : List α) = [] := by + simpa [Subsingleton.elim (F ([] : List PEmpty)) []] + using (hf.map_map PEmpty.elim []).symm + +protected theorem _root_.List.isMonadHom_reverse : IsMonadHom List List List.reverse := + .mk' (fun _ => rfl) (fun _ _ => List.reverse_flatMap) + +section uniqueness + +/-- A property holds on all lists if it holds on the nil list, the singleton list, +and concatenations thereof. -/ +private theorem List.nil_singleton_append_induction {α : Type*} {motive : List α → Prop} + (nil : motive []) (singleton : ∀ a, motive [a]) + (append : ∀ xs ys, motive xs → motive ys → motive (xs ++ ys)) : + ∀ l, motive l + | [] => nil + | x :: xs => append [x] xs (singleton x) (nil_singleton_append_induction nil singleton append xs) + +/-- Universe-generic type with two elements. This is used only internally in a proof, and keeps +things more concise than `ULift Bool`. -/ +private inductive Two : Type u | a | b + +private theorem eq_ab_or_ba : ∀ (l : List Two), + l.flatMap (fun | .a => [.a] | .b => []) = [Two.a] → + l.flatMap (fun | .a => [] | .b => [.b]) = [Two.b] → + l = [Two.a, Two.b] ∨ l = [Two.b, Two.a] + | [.a, .b], _, _ => .inl rfl + | [.b, .a], _, _ => .inr rfl + +/-- The only monad morphisms on lists are the identity and reversal. -/ +theorem isMonadHom_list_iff (f : ∀ {α : Type u}, List α → List α) : + IsMonadHom List List @f ↔ @f = (@id <| List ·) ∨ @f = @List.reverse := by + refine ⟨fun h => ?_, ?_⟩ + · have h_append {α} (xs ys : List α) : + f (xs ++ ys) = (f [Two.a, Two.b]).flatMap (fun | .a => f xs | .b => f ys) := by + have : xs ++ ys = [Two.a, Two.b].flatMap (fun | .a => xs | .b => ys) := by + simp + rw [this, h.map_listFlatMap] + congr 1; funext x; cases x <;> rfl + refine (eq_ab_or_ba (f [Two.a, Two.b]) ?_ ?_).imp (fun hL => ?_) (fun hL => ?_) + · simpa [h.map_listNil, h.map_listSingleton] using (h_append [Two.a] []).symm + · simpa [h.map_listNil, h.map_listSingleton] using (h_append [] [Two.b]).symm + · funext α l + induction l using List.nil_singleton_append_induction with grind + · funext α l + induction l using List.nil_singleton_append_induction with grind + · rintro (rfl | rfl) + · exact .id _ + · exact List.isMonadHom_reverse + +end uniqueness + +end Cslib diff --git a/Cslib/Foundations/Data/PFunctor/Free.lean b/Cslib/Foundations/Data/PFunctor/Free.lean index a29e97470..05cb6535d 100644 --- a/Cslib/Foundations/Data/PFunctor/Free.lean +++ b/Cslib/Foundations/Data/PFunctor/Free.lean @@ -7,6 +7,7 @@ Authors: Quang Dao module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom public import Mathlib.Data.PFunctor.Univariate.Basic /-! @@ -321,6 +322,16 @@ theorem Interprets.iff (handler : (a : P.A) → m (P.B a)) (eval : P.FreeM α Interprets handler eval ↔ eval = (·.liftM handler) := ⟨(·.eq), fun h => h ▸ Interprets.liftM _⟩ +/-- A morphism of monads moves inside `FreeM.liftM`. -/ +theorem _root_.Cslib.IsMonadHom.map_pfunctorFreeMLiftM [Monad n] + {f : ∀ {α}, m α → n α} (hf : Cslib.IsMonadHom m n f) (interp : (a : P.A) → m (P.B a)) + (x : P.FreeM α) : + f (x.liftM interp) = x.liftM (fun op => f (interp op)) := by + induction x with + | pure a => exact hf.map_pure a + | lift_bind op cont ih => + simp only [bind_eq_bind, liftM_lift_bind, hf.map_bind, ih] + variable [LawfulMonad m] @[simp] @@ -336,28 +347,32 @@ lemma liftM_bind {α β : Type uB} (x : P.FreeM α) (f : α → P.FreeM β) : funext u exact h u +/-- `FreeM.liftM interp` is a morphism of monads. -/ +theorem isMonadHom_liftM : Cslib.IsMonadHom P.FreeM m (FreeM.liftM interp) := + .mk' (liftM_pure interp) (liftM_bind interp) + @[simp] -lemma liftM_map {α β : Type uB} (f : α → β) (x : P.FreeM α) : - (f <$> x).liftM interp = f <$> x.liftM interp := by - simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure] +lemma liftM_map {α β : Type uB} (f : α → β) (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) : + (f <$> x).liftM interp = f <$> x.liftM interp := + isMonadHom_liftM interp |>.map_map _ _ @[simp] lemma liftM_seq {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM (α → β)) (y : P.FreeM α) : - (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := by - simp [seq_eq_bind_map] + (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := + isMonadHom_liftM interp |>.map_seq _ _ @[simp] lemma liftM_seqLeft {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : - (x <* y).liftM interp = x.liftM interp <* y.liftM interp := by - simp [seqLeft_eq_bind] + (x <* y).liftM interp = x.liftM interp <* y.liftM interp := + isMonadHom_liftM interp |>.map_seqLeft _ _ @[simp] lemma liftM_seqRight {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : - (x *> y).liftM interp = x.liftM interp *> y.liftM interp := by - simp [seqRight_eq_bind] + (x *> y).liftM interp = x.liftM interp *> y.liftM interp := + isMonadHom_liftM interp |>.map_seqRight _ _ @[simp] lemma liftM_lift (interp : (a : P.A) → m (P.B a)) (a : P.A) : From ec95751f0b75029e416534dcf830cad6bb8efd51 Mon Sep 17 00:00:00 2001 From: Thomas Krishna Waring <51426330+thomaskwaring@users.noreply.github.com> Date: Sun, 13 Sep 2026 13:50:02 +0000 Subject: [PATCH 72/93] feat(Foundations/Relation/Confluence): generalize results from confluence to commutation (#880) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This PR generalises many results from confluent to commuting relations, and obtains the classical case as a specialisation. We add `HJoin` and `MHJoin` — heterogenous versions of `Join` and `MJoin` — and associated API for them and related relational constructions. NB: the theorem `confluent_equivalents` is now public, and the `TFAE` has been extended with certain other properties which generalise better to the heterogenous case. --------- Co-authored-by: twwar --- Cslib/Foundations/Relation/Basic.lean | 113 +++++++- Cslib/Foundations/Relation/Confluence.lean | 250 ++++++++++-------- Cslib/Foundations/Relation/Defs.lean | 18 +- Cslib/Languages/CombinatoryLogic/Basic.lean | 2 +- .../CombinatoryLogic/Confluence.lean | 18 +- Cslib/Languages/CombinatoryLogic/Defs.lean | 10 +- .../CombinatoryLogic/Evaluation.lean | 50 ++-- 7 files changed, 308 insertions(+), 153 deletions(-) diff --git a/Cslib/Foundations/Relation/Basic.lean b/Cslib/Foundations/Relation/Basic.lean index aafcddac2..9369e346c 100644 --- a/Cslib/Foundations/Relation/Basic.lean +++ b/Cslib/Foundations/Relation/Basic.lean @@ -9,7 +9,13 @@ module public import Cslib.Foundations.Relation.Defs public import Mathlib.Order.WellFounded -/-! # Basic properties of relations -/ +/-! # Basic properties of relations + +## TODO: +Many of the results here could be upstreamed to Mathlib. In particular: +- `ReflGen.le_reflGen` and relatives, +- `ReflGen.to_eqvGen` and relatives. +-/ @[expose] public section @@ -24,6 +30,8 @@ theorem WellFounded.iff_transGen : WellFounded (Relation.TransGen r) ↔ WellFou namespace Relation +open Function + /-- A pair of subrelations lifts to transitivity on the relation. -/ @[implicit_reducible] def transLeftRight (s s' r : α → α → Prop) [IsTrans α r] (h : s ≤ r) (h' : s' ≤ r) : @@ -40,28 +48,105 @@ def transLeft (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans s def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r s r where trans hab hbc := _root_.trans hab (h _ _ hbc) +@[scoped grind .] +theorem comp_le_comp {s s' r r' : α → α → Prop} (hs : s ≤ s') (hr : r ≤ r') : + Comp s r ≤ Comp s' r' := fun a c ⟨b, hab, hbc⟩ ↦ ⟨b, hs a b hab, hr b c hbc⟩ + +theorem comp_self_le (r : α → α → Prop) [IsTrans α r] : Comp r r ≤ r := + fun _ _ ⟨_, hab, hbc⟩ ↦ _root_.trans hab hbc + +theorem swap_le_iff_le_swap {r₁ r₂ : α → α → Prop} : swap r₁ ≤ r₂ ↔ r₁ ≤ swap r₂ := by + constructor <;> intro h a b hab <;> exact h b a hab + attribute [scoped grind] ReflGen TransGen ReflTransGen EqvGen +@[scoped grind .] +theorem ReflGen.le_reflGen : r ≤ ReflGen r := fun _ _ => ReflGen.single + theorem ReflGen.to_eqvGen (h : ReflGen r a b) : EqvGen r a b := EqvGen.reflGen_le_eqvGen r _ _ h +@[scoped grind .] +theorem TransGen.le_transGen : r ≤ TransGen r := fun _ _ => TransGen.single + theorem TransGen.to_eqvGen (h : TransGen r a b) : EqvGen r a b := EqvGen.transGen_le_eqvGen r _ _ h theorem ReflTransGen.to_eqvGen (h : ReflTransGen r a b) : EqvGen r a b := EqvGen.reflTransGen_le_eqvGen r _ _ h +@[scoped grind .] +theorem SymmGen.le_symmGen : r ≤ SymmGen r := fun _ _ => Or.inl + theorem SymmGen.to_eqvGen (h : SymmGen r a b) : EqvGen r a b := EqvGen.symmGen_le_eqvGen r _ _ h +@[simp, scoped grind =] theorem sup_swap_eq_symmGen : r ⊔ Function.swap r = SymmGen r := rfl + +@[scoped grind .] +theorem EqvGen.le_eqvGen : r ≤ EqvGen r := EqvGen.rel + +theorem _root_.Equivalence.eqvGen_le (h : Equivalence r₂) (hle : r₁ ≤ r₂) : EqvGen r₁ ≤ r₂ := + have := h.isEquiv + EqvGen.eqvGen_le hle + attribute [scoped grind →] ReflGen.to_eqvGen TransGen.to_eqvGen ReflTransGen.to_eqvGen SymmGen.to_eqvGen -@[deprecated _root_.refl (since := "2026-09-07")] +theorem Join.single [Std.Refl r] (h : r a b) : Join r a b := ⟨b, h, refl b⟩ + +@[simp, scoped grind =] theorem join₂_eq_join : Join₂ r r = Join r := rfl + +theorem join₂_eq_comp_swap : Join₂ r₁ r₂ = Comp r₁ (swap r₂) := rfl + +instance [Std.Refl r₁] [Std.Refl r₂] : Std.Refl (Join₂ r₁ r₂) where + refl a := ⟨a, refl a, refl a⟩ + +theorem Join₂.single_left [Std.Refl r₂] (h : r₁ a b) : Join₂ r₁ r₂ a b := ⟨b, h, refl b⟩ + +theorem Join₂.single_right [Std.Refl r₁] (h : r₂ a b) : Join₂ r₁ r₂ b a := ⟨b, refl b, h⟩ + +theorem Join₂.join₂_le [IsTrans α r] (h₁ : r₁ ≤ r) (h₂ : swap r₂ ≤ r) : Join₂ r₁ r₂ ≤ r := + (comp_le_comp h₁ h₂).trans (comp_self_le r) + +theorem Join₂.swap_iff {a b : α} : Join₂ r₁ r₂ b a ↔ Join₂ r₂ r₁ a b := by grind [Join₂] + +protected theorem Join₂.mono (h₁ : r₁ ≤ r₁') (h₂ : r₂ ≤ r₂') : Join₂ r₁ r₂ ≤ Join₂ r₁' r₂' := + fun x y ⟨z, hxz, hyz⟩ => ⟨z, h₁ x z hxz, h₂ y z hyz⟩ + +@[deprecated _root_.refl +typeChanged (since := "2026-09-07")] theorem MJoin.refl (a : α) : MJoin r a a := _root_.refl a -theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by - use b +@[deprecated Join.single +typeChanged (since := "2026-09-07")] +theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := Join.single h + +theorem _root_.Equivalence.join_reflTransGen_le (h : Equivalence r₂) (hle : r₁ ≤ r₂) : + Join (ReflTransGen r₁) ≤ r₂ := + have := h.isEquiv + join_le_of_equivalence_of_le h <| reflTransGen_le_of_le hle + +theorem join_reflTransGen_le_eqvGen : Join (ReflTransGen r) ≤ EqvGen r := + (EqvGen.is_equivalence r).join_reflTransGen_le EqvGen.le_eqvGen + +theorem join₂_reflTransGen_le [Std.Refl r] [IsTrans α r] (h₁ : r₁ ≤ r) (h₂ : swap r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := by + refine Join₂.join₂_le ?_ (ReflTransGen.swap.trans ?_) + <;> apply reflTransGen_le_of_le <;> assumption + +theorem join₂_reflTransGen_le_of_isEquiv [IsEquiv α r] (h₁ : r₁ ≤ r) (h₂ : r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := + join₂_reflTransGen_le h₁ (by rwa [swap_le_iff_le_swap, Std.Symm.swap_eq]) + +theorem _root_.Equivalence.join₂_reflTransGen_le (h : Equivalence r) (h₁ : r₁ ≤ r) (h₂ : r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := + have := h.isEquiv + join₂_reflTransGen_le_of_isEquiv h₁ h₂ + +theorem left_le_join₂_reflTransGen : r₁ ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂) := + fun _ _ h => Join₂.single_left (.single h) + +theorem swap_right_le_join₂_reflTransGen : swap r₂ ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂) := + fun _ _ h => Join₂.single_right (.single h) /-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/ theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) : @@ -69,11 +154,27 @@ theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTra ext a b exact ⟨ReflTransGen.mono h₁ a b, reflTransGen_closed h₂ a b⟩ -@[deprecated Relation.ReflGen.stdSymm (since := "2026-09-03")] +@[deprecated Relation.ReflGen.stdSymm +typeChanged (since := "2026-09-03")] lemma ReflGen.symmGen_symm : ReflGen (SymmGen r) a b → ReflGen (SymmGen r) b a := Std.Symm.symm a b -@[simp, grind =] +@[simp, scoped grind =] theorem reflTransGen_symmGen : ReflTransGen (SymmGen r) = EqvGen r := EqvGen.reflTransGen_symmGen r +@[scoped grind <=] +theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := + Or.inl r₁_ab + +@[scoped grind <=] +theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := + Or.inr r₂_ab + +@[scoped grind <=] +theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := + ReflTransGen.mono le_sup_left _ _ r₁_ab + +@[scoped grind <=] +theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := + ReflTransGen.mono le_sup_right _ _ r₂_ab + end Relation diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean index bdfb8b857..94b028824 100644 --- a/Cslib/Foundations/Relation/Confluence.lean +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -7,9 +7,9 @@ Authors: Fabrizio Montesi, Thomas Waring, Chris Henson module public import Cslib.Foundations.Relation.Termination -public import Mathlib.Data.List.Pairwise +public import Mathlib.Tactic.TFAE -/-! # Relations: Confluence and Termination +/-! # Relations: Confluence This module proves some properties regarding confluence that are used for both lambda calculi and combinatory logic. Some notable theorems: @@ -17,6 +17,9 @@ combinatory logic. Some notable theorems: * `Diamond.to_confluent`: the diamond property implies confluence * `LocallyConfluent.terminating_toConfluent`: Newman's lemma +We prove most results first for two relations, where `Confluent r` becomes `Commute r₁ r₂`, then +specialize to the classical case where `r₁ = r₂`. + ## References * [*Term Rewriting and All That*][Baader1998] @@ -29,60 +32,115 @@ variable {α : Type*} {r r₁ r₂ : α → α → Prop} namespace Relation +open Function ReflTransGen + +theorem Commute.to_confluent : Commute r r = Confluent r := rfl + +@[deprecated (since := "2026-09-03")] alias Commute.toConfluent := Commute.to_confluent + +@[simp] theorem StronglyCommute.to_stronglyConfluent : + StronglyCommute r r = StronglyConfluent r := rfl + +@[deprecated (since := "2026-09-03")] alias StronglyCommute.toStronglyConfluent := + StronglyCommute.to_stronglyConfluent + +@[simp] theorem DiamondCommute.to_diamond : DiamondCommute r r = Diamond r := rfl + +@[deprecated (since := "2026-09-03")] alias DiamondCommute.toDiamond := DiamondCommute.to_diamond + +@[simp] theorem SemiCommute.to_semiConfluent : SemiCommute r r = SemiConfluent r := rfl + +@[simp] theorem LocallyCommute.to_locallyConfluent : LocallyCommute r r = LocallyConfluent r := rfl + +instance : Std.Symm (@DiamondCommute α) where + symm _ _ h _ _ _ h₁ h₂ := Join₂.swap_iff.mp <| h h₂ h₁ + +instance : Std.Symm (@LocallyCommute α) where + symm _ _ h _ _ _ h₁ h₂ := Join₂.swap_iff.mp <| h h₂ h₁ + +lemma DiamondCommute.diamond_commute_reflTransGen_right (h : DiamondCommute r₁ r₂) : + DiamondCommute r₁ (ReflTransGen r₂) := by + intro a b c h₁ h₂ + induction h₂ using ReflTransGen.head_induction_on generalizing b with + | refl => exact Join₂.single_right h₁ + | head ha _ ih => + obtain ⟨d, hbd, hcd⟩ := h h₁ ha + obtain ⟨d', hdd', hcd'⟩ := ih hcd + exact ⟨d', hdd'.head hbd, hcd'⟩ + +lemma DiamondCommute.diamond_commute_reflTransGen_left (h : DiamondCommute r₁ r₂) : + DiamondCommute (ReflTransGen r₁) r₂ := by + rw [comm (r := DiamondCommute)] at h ⊢ + exact h.diamond_commute_reflTransGen_right + +lemma DiamondCommute.to_semiCommute (h : DiamondCommute r₁ r₂) : SemiCommute r₁ r₂ := + fun h₁ h₂ => Join₂.mono le_rfl ReflTransGen.le_reflTransGen _ _ <| + h.diamond_commute_reflTransGen_right h₁ h₂ + /-- Extending a multistep reduction by a single step preserves multi-joinability. -/ -lemma Diamond.extend (h : Diamond r) : - ReflTransGen r a b → r a c → Join (ReflTransGen r) b c := by - intros ab ac - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c, .single ac - case head a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h ac a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .head cd d_d'⟩ - -/-- The diamond property implies confluence. -/ -theorem Diamond.to_confluent (h : Diamond r) : Confluent r := by - intros a b c ab bc - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c - case head _ _ a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h.extend bc a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .trans cd d_d'⟩ +lemma Diamond.to_semiConfluent (h : Diamond r) : SemiConfluent r := DiamondCommute.to_semiCommute h -@[deprecated (since := "2026-09-03")] alias Diamond.toConfluent := Diamond.to_confluent +@[deprecated (since := "2026-09-12")] alias Diamond.extend := Diamond.to_semiConfluent -theorem Confluent.to_churchRosser (h : Confluent r) : ChurchRosser r := by - intro x y h_eqv - induction h_eqv with - | rel _ b => exists b; grind [ReflTransGen.single] - | refl a => exists a - | symm a b _ ih => exact symm ih - | trans _ _ _ _ _ ih1 ih2 => - obtain ⟨u, _, hbu⟩ := ih1 - obtain ⟨v, hbv, _⟩ := ih2 - obtain ⟨w, _, _⟩ := h hbu hbv - exists w - grind [ReflTransGen.trans] - -@[deprecated (since := "2026-09-03")] alias Confluent.toChurchRosser := Confluent.to_churchRosser - -theorem SemiConfluent.to_confluent (h : SemiConfluent r) : Confluent r := by - intro x y1 y2 h_xy1 h_xy2 - induction h_xy1 with - | refl => use y2 - | tail h_xz h_zy1 ih => - obtain ⟨u, h_zu, _⟩ := ih - obtain ⟨v, _, _⟩ := h h_zu h_zy1 - exists v - grind [ReflTransGen.trans] +theorem Commute.isTrans_join₂_reflTransGen (h : Commute r₁ r₂) : + IsTrans α (Join₂ (ReflTransGen r₁) (ReflTransGen r₂)) where + trans a b c := by + intro ⟨d, had, hbd⟩ ⟨d', hbd', hcd'⟩ + obtain ⟨e, he, he'⟩ := h hbd' hbd + exact ⟨e, had.trans he', hcd'.trans he⟩ -@[deprecated (since := "2026-09-03")] alias SemiConfluent.toConfluent := SemiConfluent.to_confluent +theorem Confluent.isTrans_join_reflTransGen (h : Confluent r) : IsTrans α (Join (ReflTransGen r)) := + Commute.isTrans_join₂_reflTransGen h -attribute [scoped grind →] Confluent.to_churchRosser SemiConfluent.to_confluent +theorem SemiCommute.to_commute (h : SemiCommute r₁ r₂) : Commute r₁ r₂ := by + intro a b₁ b₂ hab₁ hab₂ + induction hab₁ with + | refl => use b₂ + | tail hab hbb' ih => + obtain ⟨d, hd, hd'⟩ := ih + obtain ⟨e, he, he'⟩ := h hbb' hd + use e, he, hd'.trans he' + +theorem SemiConfluent.to_confluent (h : SemiConfluent r) : Confluent r := SemiCommute.to_commute h + +@[deprecated (since := "2026-09-03")] alias SemiConfluent.toConfluent := SemiConfluent.to_confluent -private theorem confluent_equivalents : [ChurchRosser r, SemiConfluent r, Confluent r].TFAE := by - grind [List.tfae_cons_cons, List.tfae_singleton] +theorem commute_equivalents : + [SemiCommute r₁ r₂, Commute r₁ r₂, IsTrans α (Join₂ (ReflTransGen r₁) (ReflTransGen r₂)), + ReflTransGen (r₁ ⊔ swap r₂) ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂), + ReflTransGen (r₁ ⊔ swap r₂) = Join₂ (ReflTransGen r₁) (ReflTransGen r₂)].TFAE := by + tfae_have 1 → 2 := SemiCommute.to_commute + tfae_have 2 → 3 := Commute.isTrans_join₂_reflTransGen + tfae_have 3 → 4 := fun h => reflTransGen_le_of_le <| + sup_le left_le_join₂_reflTransGen swap_right_le_join₂_reflTransGen + tfae_have 4 → 5 := fun h => h.antisymm <| + join₂_reflTransGen_le (le_sup_left.trans le_reflTransGen) (le_sup_right.trans le_reflTransGen) + tfae_have 5 → 1 := by + intro h a b₁ b₂ h₁ h₂ + rw [Join₂.swap_iff, ← h] + exact (ReflTransGen.mono le_sup_right _ _ <| reflTransGen_swap.mpr h₂).tail (Or.inl h₁) + tfae_finish + +theorem semiCommute_iff_commute : SemiCommute r₁ r₂ ↔ Commute r₁ r₂ := commute_equivalents.out 1 2 + +theorem DiamondCommute.to_commute (h : DiamondCommute r₁ r₂) : Commute r₁ r₂ := + semiCommute_iff_commute.mp h.to_semiCommute + +instance : Std.Symm (@SemiCommute α) where + symm r₁ r₂ h := by + rw [semiCommute_iff_commute] at h ⊢ + exact symm (r := Commute) h + +theorem churchRosser_iff_eqvGen_le_join_reflTransGen : + ChurchRosser r ↔ EqvGen r ≤ Join (ReflTransGen r) := + Iff.rfl + +theorem confluent_equivalents : + [ChurchRosser r, SemiConfluent r, Confluent r, IsTrans α (Join (ReflTransGen r)), + EqvGen r ≤ Join (ReflTransGen r), EqvGen r = Join (ReflTransGen r)].TFAE := by + refine (List.tfae_cons ?_).mpr ⟨churchRosser_iff_eqvGen_le_join_reflTransGen, ?_⟩ + · grind + · simpa [reflTransGen_symmGen] using commute_equivalents (r₁ := r) (r₂ := r) theorem semiConfluent_iff_churchRosser : SemiConfluent r ↔ ChurchRosser r := List.TFAE.out confluent_equivalents 2 1 @@ -93,14 +151,22 @@ theorem semiConfluent_iff_churchRosser : SemiConfluent r ↔ ChurchRosser r := theorem confluent_iff_churchRosser : Confluent r ↔ ChurchRosser r := List.TFAE.out confluent_equivalents 3 1 +alias ⟨_, Confluent.to_churchRosser⟩ := confluent_iff_churchRosser + @[deprecated (since := "2026-09-03")] alias Confluent_iff_ChurchRosser := confluent_iff_churchRosser +attribute [scoped grind →] Confluent.to_churchRosser SemiConfluent.to_confluent + theorem confluent_iff_semiConfluent : Confluent r ↔ SemiConfluent r := List.TFAE.out confluent_equivalents 3 2 @[deprecated (since := "2026-09-03")] alias Confluent_iff_SemiConfluent := confluent_iff_semiConfluent +theorem Diamond.to_confluent (h : Diamond r) : Confluent r := DiamondCommute.to_commute h + +@[deprecated (since := "2026-09-03")] alias Diamond.toConfluent := Diamond.to_confluent + theorem confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) : Confluent r := by intro a b c hab hac exact ⟨x, h b, h c⟩ @@ -125,9 +191,8 @@ theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) : apply equivalence_join grind -theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : +theorem Normalizing.confluent_iff_forall_unique_normal (hn : Normalizing r) : Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := by - have hn : Normalizing r := ht.to_normalizing constructor · intro hc a apply existsUnique_of_exists_of_unique (hn a) @@ -142,11 +207,11 @@ theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : obtain ⟨nc, hcnc, hnc⟩ := hn c have hanb : (ReflTransGen r) a nb := ReflTransGen.trans hab hbnb have hanc : (ReflTransGen r) a nc := ReflTransGen.trans hac hcnc - have hnanb : nb = na := H nb ⟨hanb, hnb⟩ - have hnanc : nc = na := H nc ⟨hanc, hnc⟩ - rw [hnanb] at hbnb - rw [hnanc] at hcnc - exact ⟨hbnb, hcnc⟩ + grind + +theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : + Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := + ht.to_normalizing.confluent_iff_forall_unique_normal @[deprecated (since := "2026-09-03")] alias Terminating.isConfluent_iff_all_unique_Normal := Terminating.confluent_iff_forall_unique_normal @@ -177,45 +242,28 @@ theorem Confluent.to_locallyConfluent (h : Confluent r) : LocallyConfluent r := @[deprecated (since := "2026-09-03")] alias Confluent.toLocallyConfluent := Confluent.to_locallyConfluent -/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ -theorem LocallyConfluent.terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : - Confluent r := by +theorem LocallyCommute.commute_of_terminating_sup (hlc : LocallyCommute r₁ r₂) + (ht : Terminating (r₁ ⊔ r₂)) : Commute r₁ r₂ := by intro x induction x using ht.induction with | h x ih => - intro y z xy xz - cases xy.cases_head with - | inl => exists z; grind - | inr h => - obtain ⟨y₁, x_y₁, y₁_y⟩ := h - cases xz.cases_head with - | inl => exists y; grind - | inr h => - obtain ⟨z₁, x_z₁, z₁_z⟩ := h - have ⟨u, z₁_u, y₁_u⟩ := hlc x_z₁ x_y₁ - have ⟨v, uv, yv⟩ : Join (ReflTransGen r) u y := by grind - have ⟨w, vw, zw⟩ : Join (ReflTransGen r) v z := by grind [ReflTransGen.trans] - exact ⟨w, .trans yv vw, zw⟩ + intro y z hy hz + rcases hy.cases_head with (rfl | ⟨y', hy, hy'⟩) + · use z + · rcases hz.cases_head with (rfl | ⟨z', hz, hz'⟩) + · use y + · obtain ⟨u, hyu, hzu⟩ := hlc hy hz + obtain ⟨v, hyv, huv⟩ := ih y' (join_inl hy) hy' hyu + obtain ⟨w, hvw, hzw⟩ := ih z' (join_inr hz) (hzu.trans huv) hz' + exact ⟨w, hyv.trans hvw, hzw⟩ + +/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ +theorem LocallyConfluent.terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : + Confluent r := LocallyCommute.commute_of_terminating_sup hlc ((sup_idem r).symm ▸ ht) @[deprecated (since := "2026-09-03")] alias LocallyConfluent.Terminating_toConfluent := LocallyConfluent.terminating_toConfluent -instance : Std.Symm (@Commute α) where - symm r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ := by grind [h x_y₂ x_y₁] - -theorem Commute.to_confluent : Commute r r = Confluent r := rfl - -@[deprecated (since := "2026-09-03")] alias Commute.toConfluent := Commute.to_confluent - -theorem StronglyCommute.to_stronglyConfluent : StronglyCommute r r = StronglyConfluent r := rfl - -@[deprecated (since := "2026-09-03")] alias StronglyCommute.toStronglyConfluent := - StronglyCommute.to_stronglyConfluent - -theorem DiamondCommute.to_diamond : DiamondCommute r r = Diamond r := by rfl - -@[deprecated (since := "2026-09-03")] alias DiamondCommute.toDiamond := DiamondCommute.to_diamond - theorem StronglyCommute.extend (h : StronglyCommute r₁ r₂) (xy : ReflTransGen r₁ x y) (xz : r₂ x z) : ∃ w, ReflGen r₂ y w ∧ ReflTransGen r₁ z w := by induction xy with @@ -243,37 +291,19 @@ theorem StronglyConfluent.to_confluent (h : StronglyConfluent r) : Confluent r : @[deprecated (since := "2026-09-03")] alias StronglyConfluent.toConfluent := StronglyConfluent.to_confluent -variable {r₁ r₂ : α → α → Prop} - -@[scoped grind <=] -theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := - Or.inl r₁_ab - -@[scoped grind <=] -theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := - Or.inr r₂_ab - -@[scoped grind <=] -theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := - ReflTransGen.mono le_sup_left _ _ r₁_ab - -@[scoped grind <=] -theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := - ReflTransGen.mono le_sup_right _ _ r₂_ab - lemma Commute.join_left (c₁ : Commute r₁ r₃) (c₂ : Commute r₂ r₃) : Commute (r₁ ⊔ r₂) r₃ := by intro x y z xy xz induction xy with - | refl => grind + | refl => grind [Join₂] | @tail b c _ bc ih => have ⟨w, bw, _⟩ := ih cases bc with | inl bc => obtain ⟨_, _, _⟩ := c₁ (.single bc) bw - grind [ReflTransGen.trans] + grind [Join₂, ReflTransGen.trans] | inr bc => obtain ⟨_, _, _⟩ := c₂ (.single bc) bw - grind [ReflTransGen.trans] + grind [Join₂, ReflTransGen.trans] theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) (comm : Commute r₁ r₂) : Confluent (r₁ ⊔ r₂) := by diff --git a/Cslib/Foundations/Relation/Defs.lean b/Cslib/Foundations/Relation/Defs.lean index 10e57bd42..07a6980e1 100644 --- a/Cslib/Foundations/Relation/Defs.lean +++ b/Cslib/Foundations/Relation/Defs.lean @@ -35,8 +35,12 @@ def dom (r : α → β → Prop) : Set α := {a | ∃ b, r a b} /-- Codomain of a relation, aka range. -/ def cod (r : α → β → Prop) : Set β := {b | ∃ a, r a b} +/-- Generalisation of `Join` to two relations. -/ +def Join₂ (r₁ r₂ : α → α → Prop) (a b : α) : Prop := ∃ c, r₁ a c ∧ r₂ b c + /-- The join of the reflexive transitive closure. This is not named in Mathlib, but see `#loogle Relation.Join (Relation.ReflTransGen ?r)` -/ +@[deprecated "use `Join (ReflTrasnGen ·)` instead" (since := "2026-09-12")] abbrev MJoin (r : α → α → Prop) := Join (ReflTransGen r) /-- The relation `r` 'up to' the relation `s`. -/ @@ -51,8 +55,8 @@ def Preserves (r : α → α → Prop) (P : α → Prop) : Prop := ∀ ⦃a b⦄ abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c /-- Generalization of `Diamond` to two relations. -/ -def DiamondCommute (r₁ r₂ : α → α → Prop) := - ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, r₂ y₁ z ∧ r₁ y₂ z +abbrev DiamondCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → Join₂ r₂ r₁ y₁ y₂ /-- A relation is confluent when its reflexive transitive closure has the diamond property. -/ abbrev Confluent (r : α → α → Prop) := Diamond (ReflTransGen r) @@ -63,7 +67,11 @@ abbrev Commute (r₁ r₂ : α → α → Prop) := DiamondCommute (ReflTransGen /-- A relation is semi-confluent when single and multiple steps with common origin are multi-joinable. -/ abbrev SemiConfluent (r : α → α → Prop) := - ∀ {x y₁ y₂}, ReflTransGen r x y₂ → r x y₁ → Join (ReflTransGen r) y₁ y₂ + ∀ {x y₁ y₂}, r x y₁ → ReflTransGen r x y₂ → Join (ReflTransGen r) y₁ y₂ + +/-- Generalisation of `SemiConfluent` to two relations. -/ +abbrev SemiCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → ReflTransGen r₂ x y₂ → Join₂ (ReflTransGen r₂) (ReflTransGen r₁) y₁ y₂ /-- A relation has the Church Rosser property when equivalence implies multi-joinability. -/ abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join (ReflTransGen r) x y @@ -72,6 +80,10 @@ abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join abbrev LocallyConfluent (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join (ReflTransGen r) b c +/-- Generalization of `LocallyConfluent` to two relations. -/ +def LocallyCommute (r₁ r₂ : α → α → Prop) := + ∀ {a b c : α}, r₁ a b → r₂ a c → Join₂ (ReflTransGen r₂) (ReflTransGen r₁) b c + /-- A relation is strongly confluent when single steps are reflexive- and multi-joinable. -/ abbrev StronglyConfluent (r : α → α → Prop) := ∀ {x y₁ y₂}, r x y₁ → r x y₂ → ∃ z, ReflGen r y₁ z ∧ ReflTransGen r y₂ z diff --git a/Cslib/Languages/CombinatoryLogic/Basic.lean b/Cslib/Languages/CombinatoryLogic/Basic.lean index 579fb5aa4..04488c220 100644 --- a/Cslib/Languages/CombinatoryLogic/Basic.lean +++ b/Cslib/Languages/CombinatoryLogic/Basic.lean @@ -223,7 +223,7 @@ theorem Y_def (f : SKI) : (Y ⬝ f) ↠ H ⬝ f ⬝ (H ⬝ f) := YPoly.toSKI_correct [f] (by simp) /-- The fixed-point property of the Y-combinator -/ -theorem Y_correct (f : SKI) : MJoin Red (Y ⬝ f) (f ⬝ (Y ⬝ f)) := by +theorem Y_correct (f : SKI) : Join (ReflTransGen Red) (Y ⬝ f) (f ⬝ (Y ⬝ f)) := by use f ⬝ (H ⬝ f ⬝ (H ⬝ f)) constructor · exact Trans.trans (Y_def f) (H_def f (H ⬝ f)) diff --git a/Cslib/Languages/CombinatoryLogic/Confluence.lean b/Cslib/Languages/CombinatoryLogic/Confluence.lean index 97c48458d..a59ea5cfc 100644 --- a/Cslib/Languages/CombinatoryLogic/Confluence.lean +++ b/Cslib/Languages/CombinatoryLogic/Confluence.lean @@ -16,8 +16,8 @@ This file proves the **Church-Rosser** theorem for the SKI calculus, that is, if `a ↠ c`, `b ↠ d` and `c ↠ d` for some term `d`. More strongly (though equivalently), we show that the relation of having a common reduct is transitive — in the above situation, `a` and `b`, and `a` and `c` have common reducts, so the result implies the same of `b` and `c`. Note that -`MJoin Red` is symmetric (trivially) and reflexive (since `↠` is), so we in fact show that -`MJoin Red` is an equivalence. +`Join (ReflTransGen Red)` is symmetric (trivially) and reflexive (since `↠` is), so we in fact show +that `Join (ReflTransGen Red)` is an equivalence. Our proof follows the method of Tait and Martin-Löf for the lambda calculus, as presented for instance in @@ -33,7 +33,7 @@ reduction on the head and tail of a term. - `parallelReduction_diamond` : parallel reduction satisfies the diamond property, that is, it is confluent in a single step. -- `mJoin_red_equivalence` : by a general result, the diamond property for `⭢ₚ` implies the same +- `join_mRed_equivalence` : by a general result, the diamond property for `⭢ₚ` implies the same for its reflexive-transitive closure. This closure is exactly `↠`, which implies the **Church-Rosser** theorem as sketched above. -/ @@ -205,20 +205,20 @@ theorem parallelReduction_diamond : Diamond ParallelReduction := by case red_S => exact ⟨a ⬝ c ⬝ (b ⬝ c), .refl _, .refl _,⟩ theorem join_parallelReduction_equivalence : - Equivalence (MJoin ParallelReduction) := + Equivalence (Join (ReflTransGen ParallelReduction)) := Confluent.equivalence_join_reflTransGen <| Diamond.to_confluent parallelReduction_diamond /-- The **Church-Rosser** theorem in its general form. -/ -theorem mJoin_red_equivalence : Equivalence (MJoin Red) := by - rw [MJoin, ←reflTransGen_parallelReduction_mRed] +theorem join_mRed_equivalence : Equivalence (Join (ReflTransGen Red)) := by + rw [←reflTransGen_parallelReduction_mRed] exact join_parallelReduction_equivalence /-- The **Church-Rosser** theorem in the form it is usually stated. -/ theorem MRed.diamond : Confluent Red := by intro a b c hab hac - apply mJoin_red_equivalence.trans (y := a) - · exact mJoin_red_equivalence.symm (MJoin.single hab) - · exact MJoin.single hac + apply join_mRed_equivalence.trans (y := a) + · exact join_mRed_equivalence.symm (Join.single hab) + · exact Join.single hac end SKI diff --git a/Cslib/Languages/CombinatoryLogic/Defs.lean b/Cslib/Languages/CombinatoryLogic/Defs.lean index 7d028d283..ea8aedce7 100644 --- a/Cslib/Languages/CombinatoryLogic/Defs.lean +++ b/Cslib/Languages/CombinatoryLogic/Defs.lean @@ -113,12 +113,18 @@ lemma parallel_mRed {a a' b b' : SKI} (ha : a ↠ a') (hb : b ↠ b') : lemma parallel_red {a a' b b' : SKI} (ha : a ⭢ a') (hb : b ⭢ b') : (a ⬝ b) ↠ (a' ⬝ b') := by trans a' ⬝ b <;> grind -theorem mJoin_red_head {x x' : SKI} (y : SKI) : MJoin Red x x' → MJoin Red (x ⬝ y) (x' ⬝ y) +theorem join_mRed_head {x x' : SKI} (y : SKI) : + Join (ReflTransGen Red) x x' → Join (ReflTransGen Red) (x ⬝ y) (x' ⬝ y) | ⟨z, hz, hz'⟩ => ⟨z ⬝ y, MRed.head y hz, MRed.head y hz'⟩ -theorem mJoin_red_tail (x : SKI) {y y' : SKI} : MJoin Red y y' → MJoin Red (x ⬝ y) (x ⬝ y') +@[deprecated (since := "2026-09-12")] alias mJoin_red_head := join_mRed_head + +theorem join_mRed_tail (x : SKI) {y y' : SKI} : + Join (ReflTransGen Red) y y' → Join (ReflTransGen Red) (x ⬝ y) (x ⬝ y') | ⟨z, hz, hz'⟩ => ⟨x ⬝ z, MRed.tail x hz, MRed.tail x hz'⟩ +@[deprecated (since := "2026-09-12")] alias mJoin_red_tail := join_mRed_tail + end SKI end Cslib diff --git a/Cslib/Languages/CombinatoryLogic/Evaluation.lean b/Cslib/Languages/CombinatoryLogic/Evaluation.lean index 8971eebe8..f2fa26a80 100644 --- a/Cslib/Languages/CombinatoryLogic/Evaluation.lean +++ b/Cslib/Languages/CombinatoryLogic/Evaluation.lean @@ -178,10 +178,13 @@ theorem redexFree_iff_mred_eq {x : SKI} : x.RedexFree ↔ ∀ y, (x ↠ y) ↔ x exact Red.ne hy (h.1 (Relation.ReflTransGen.single hy)) /-- If a term has a common reduct with a normal term, it in fact reduces to that term. -/ -theorem mJoin_red_redexFree {x y : SKI} (hy : y.RedexFree) (h : MJoin Red x y) : x ↠ y := +theorem join_mRed_redexFree {x y : SKI} (hy : y.RedexFree) (h : Join (ReflTransGen Red) x y) : + x ↠ y := let ⟨w, hyw, hzw⟩ := h (redexFree_iff_mred_eq.1 hy _ |>.1 hzw : y = w) ▸ hyw +@[deprecated (since := "2026-09-12")] alias mJoin_red_redexFree := join_mRed_redexFree + /-- If `x` reduces to both `y` and `z`, and `z` is not reducible, then `y` reduces to `z`. -/ lemma confluent_redexFree {x y z : SKI} (hxy : x ↠ y) (hxz : x ↠ z) (hz : RedexFree z) : y ↠ z := let ⟨w, hyw, hzw⟩ := MRed.diamond hxy hxz @@ -195,13 +198,16 @@ lemma unique_normal_form {x y z : SKI} (redexFree_iff_mred_eq.1 hy _).1 (confluent_redexFree hxy hxz hz) /-- If `x` and `y` are normal and have a common reduct, then they are equal. -/ -lemma eq_of_mJoin_red_redexFree {x y : SKI} (h : MJoin Red x y) +lemma eq_of_join_mRed_redexFree {x y : SKI} (h : Join (ReflTransGen Red) x y) (hx : x.RedexFree) (hy : y.RedexFree) : x = y := - (redexFree_iff_mred_eq.1 hx _).1 (mJoin_red_redexFree hy h) + (redexFree_iff_mred_eq.1 hx _).1 (join_mRed_redexFree hy h) + +@[deprecated (since := "2026-09-12")] alias eq_of_mJoin_red_redexFree := eq_of_join_mRed_redexFree + /-! ### Injectivity for datatypes -/ -lemma sk_nequiv : ¬ MJoin Red S K := by +lemma sk_nequiv : ¬ Join (ReflTransGen Red) S K := by intro ⟨z, hsz, hkz⟩ have hS : RedexFree S := by simp [RedexFree] have hK : RedexFree K := by simp [RedexFree] @@ -210,19 +216,19 @@ lemma sk_nequiv : ¬ MJoin Red S K := by /-- Injectivity for booleans. -/ theorem isBool_injective (x y : SKI) (u v : Bool) (hx : IsBool u x) (hy : IsBool v y) - (hxy : MJoin Red x y) : u = v := by - have h : MJoin Red (if u then S else K) (if v then S else K) := by - apply mJoin_red_equivalence.trans (y := x ⬝ S ⬝ K) - · apply mJoin_red_equivalence.symm - apply Relation.MJoin.single + (hxy : Join (ReflTransGen Red) x y) : u = v := by + have h : Join (ReflTransGen Red) (if u then S else K) (if v then S else K) := by + apply join_mRed_equivalence.trans (y := x ⬝ S ⬝ K) + · apply join_mRed_equivalence.symm + apply Relation.Join.single exact hx S K - · apply mJoin_red_equivalence.trans (y := y ⬝ S ⬝ K) - · exact mJoin_red_head K <| mJoin_red_head S hxy - · apply Relation.MJoin.single + · apply join_mRed_equivalence.trans (y := y ⬝ S ⬝ K) + · exact join_mRed_head K <| join_mRed_head S hxy + · apply Relation.Join.single exact hy S K - grind [sk_nequiv, mJoin_red_equivalence.symm h] + grind [sk_nequiv, join_mRed_equivalence.symm h] -lemma TF_nequiv : ¬ MJoin Red TT FF := fun h => +lemma TF_nequiv : ¬ Join (ReflTransGen Red) TT FF := fun h => (Bool.eq_not_self true).mp <| isBool_injective TT FF true false TT_correct FF_correct h /-- A specialisation of `Church : Nat → SKI`. -/ @@ -248,17 +254,17 @@ lemma churchK_injective : Function.Injective churchK := /-- Injectivity for Church numerals -/ theorem isChurch_injective (x y : SKI) (n m : Nat) (hx : IsChurch n x) (hy : IsChurch m y) - (hxy : MJoin Red x y) : n = m := by - suffices MJoin Red (churchK n) (churchK m) by + (hxy : Join (ReflTransGen Red) x y) : n = m := by + suffices Join (ReflTransGen Red) (churchK n) (churchK m) by apply churchK_injective - exact eq_of_mJoin_red_redexFree this (churchK_redexFree n) (churchK_redexFree m) - apply mJoin_red_equivalence.trans (y := x ⬝ K ⬝ K) + exact eq_of_join_mRed_redexFree this (churchK_redexFree n) (churchK_redexFree m) + apply join_mRed_equivalence.trans (y := x ⬝ K ⬝ K) · simp_rw [churchK_church] - exact mJoin_red_equivalence.symm <| Relation.MJoin.single (hx K K) - · apply mJoin_red_equivalence.trans (y := y ⬝ K ⬝ K) - · apply mJoin_red_head; apply mJoin_red_head; assumption + exact join_mRed_equivalence.symm <| Relation.Join.single (hx K K) + · apply join_mRed_equivalence.trans (y := y ⬝ K ⬝ K) + · apply join_mRed_head; apply join_mRed_head; assumption · simp_rw [churchK_church] - exact Relation.MJoin.single (hy K K) + exact Relation.Join.single (hy K K) /-- **Rice's theorem**: no SKI term is a non-trivial predicate. From 966d27a1197833c791af709facea3c9222fb7a8b Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Mon, 14 Sep 2026 09:32:05 +0000 Subject: [PATCH 73/93] feat(CCS): notation for CCS (#771) Adds notation for CCS processes and updates the vending machine example to use it. --- Cslib/Algorithms/CCS/VendingMachine.lean | 14 +++---- Cslib/Languages/CCS/Basic.lean | 48 +++++++++++++++++++++++- Cslib/Languages/CCS/Semantics.lean | 8 ++-- CslibTests/CCS/VendingMachine.lean | 2 +- 4 files changed, 59 insertions(+), 13 deletions(-) diff --git a/Cslib/Algorithms/CCS/VendingMachine.lean b/Cslib/Algorithms/CCS/VendingMachine.lean index 08bb84251..6dcfd1d92 100644 --- a/Cslib/Algorithms/CCS/VendingMachine.lean +++ b/Cslib/Algorithms/CCS/VendingMachine.lean @@ -48,27 +48,27 @@ inductive Constant | vm /-- The vending machine process. -/ -def vm : Process String Constant := const .vm +def vm : Process String Constant := `(CCS| const .vm) /-! ## Deterministic vending machine -/ /-- Constant definitions: vm = coin.(tea.VM + coffee.VM) -/ @[local grind =] def vendingDefs : Constant → Option (Process String Constant) - | .vm => some <| pre Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) + | .vm => some <| `(CCS| Coin. ((Tea. const .vm) + (Coffee. const .vm))) /-- The LTS of CCS for the deterministic vending machine. -/ abbrev ltsD := CCS.lts (defs := vendingDefs) /-- VM can perform a coin action. -/ -example : ltsD.Tr vm Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) := +example : ltsD.Tr vm Coin `(CCS| (Tea. (const .vm)) + (Coffee. (const .vm))) := Tr.const rfl Tr.pre /-! ## Nondeterministic vending machine -/ /-- vm = coin.tea.VM + coin.coffee.VM -/ def vendingDefsND : Constant → Option (Process String Constant) - | .vm => some <| (choice (pre Coin (pre Tea (const .vm))) (pre Coin (pre Coffee (const .vm)))) + | .vm => some <| `(CCS| (Coin. Tea. const .vm) + (Coin. Coffee. const .vm)) /-- The LTS of CCS for the nondeterministic vending machine. -/ abbrev ltsND := CCS.lts (defs := vendingDefsND) @@ -78,8 +78,8 @@ open LTS LTS.IsBisimulation LTS.Bisimilarity /-- The deterministic and nondeterministic vending machines are not bisimilar. -/ theorem vm_ltsD_ltsND_not_bisim : ¬(vm ~[ltsD, ltsND] vm) := by rintro ⟨r, hr, hbisim⟩ - let p₁ := (choice (pre Tea (const Constant.vm)) (pre Coffee (const Constant.vm))) - let q₁ := (pre Tea (const Constant.vm)) + let p₁ := `(CCS| (Tea. const Constant.vm) + (Coffee. const Constant.vm)) + let q₁ := `(CCS| Tea. const Constant.vm) have ltsD_vm_deterministic : ltsD.DeterministicStateLabel vm Coin := by intro _ _ htr₁ htr₂ grind [const_tr htr₁, const_tr htr₂] @@ -90,7 +90,7 @@ theorem vm_ltsD_ltsND_not_bisim : ¬(vm ~[ltsD, ltsND] vm) := by (.const rfl .pre) (.const rfl (.choiceL .pre)) have hp₁q₁ : p₁ ~[ltsD, ltsND] q₁ := by grind - have hp₁coffee : ltsD.Tr p₁ Coffee (const Constant.vm) := .choiceR .pre + have hp₁coffee : ltsD.Tr p₁ Coffee (.const .vm) := .choiceR .pre grind [hp₁q₁.follow_fst] end Cslib.Algorithms.CCS.VendingMachine diff --git a/Cslib/Languages/CCS/Basic.lean b/Cslib/Languages/CCS/Basic.lean index ec581611c..3f338f046 100644 --- a/Cslib/Languages/CCS/Basic.lean +++ b/Cslib/Languages/CCS/Basic.lean @@ -44,14 +44,60 @@ deriving DecidableEq /-- Processes. -/ inductive Process (Name : Type u) (Constant : Type v) : Type (max u v) where + /-- Terminated process. -/ | nil + /-- Do `μ` and proceed as `p`. -/ | pre (μ : Act Name) (p : Process Name Constant) + /-- `p` parallel `q`. -/ | par (p q : Process Name Constant) + /-- Do `p` or `q` (nondeterministically). -/ | choice (p q : Process Name Constant) + /-- Restriction. -/ | res (a : Name) (p : Process Name Constant) + /-- Constant. -/ | const (c : Constant) deriving DecidableEq +/-- Syntactic category for processes. -/ +declare_syntax_cat ccsProc + +@[inherit_doc Process.nil] +scoped syntax num : ccsProc + +@[inherit_doc Process.pre] +scoped syntax ident "." ccsProc : ccsProc + +@[inherit_doc Process.pre] +scoped syntax "(" term ")" "." ccsProc : ccsProc + +@[inherit_doc Process.choice] +scoped syntax ccsProc "+" ccsProc : ccsProc + +@[inherit_doc Process.par] +scoped syntax ccsProc "|" ccsProc : ccsProc + +@[inherit_doc Process.res] +scoped syntax "ν" term ccsProc : ccsProc + +@[inherit_doc Process.const] +scoped syntax "const" term : ccsProc + +@[inherit_doc Process] +scoped syntax "(" ccsProc ")" : ccsProc + +@[inherit_doc Process] +scoped syntax "`(CCS| " ccsProc ")" : term + +scoped macro_rules + | `(`(CCS| 0)) => `(Process.nil) + | `(`(CCS| $μ:ident . $p:ccsProc)) => `(Process.pre $μ `(CCS| $p)) + | `(`(CCS| ( $μ:term ) . $p:ccsProc)) => `(Process.pre $μ `(CCS| $p)) + | `(`(CCS| $p:ccsProc + $q:ccsProc)) => `(Process.choice `(CCS| $p) `(CCS| $q)) + | `(`(CCS| $p:ccsProc | $q:ccsProc)) => `(Process.par `(CCS| $p) `(CCS| $q)) + | `(`(CCS| ν $a:term $p:ccsProc)) => `(Process.res $a `(CCS| $p)) + | `(`(CCS| const $c:term)) => `(Process.const $c) + | `(`(CCS| ( $p:ccsProc ))) => `(`(CCS| $p)) + namespace Act /-- An action is visible if it a name or a coname. -/ @@ -151,7 +197,7 @@ theorem Context.complete (p : Process Name Constant) : obtain ⟨c, hc⟩ := ih exists res a c grind - case const k => + case «const» k => exists hole grind diff --git a/Cslib/Languages/CCS/Semantics.lean b/Cslib/Languages/CCS/Semantics.lean index 93be9f5e8..788396ddf 100644 --- a/Cslib/Languages/CCS/Semantics.lean +++ b/Cslib/Languages/CCS/Semantics.lean @@ -41,7 +41,7 @@ inductive Tr : Process Name Constant → Act Name → Process Name Constant → | choiceL : Tr p μ p' → Tr (choice p q) μ p' | choiceR : Tr q μ q' → Tr (choice p q) μ q' | res : μ ≠ Act.name a → μ ≠ Act.coname a → Tr p μ p' → Tr (res a p) μ (res a p') - | const : defs k = some p → Tr p μ p' → Tr (const k) μ p' + | const : defs k = some p → Tr p μ p' → Tr («const» k) μ p' instance : HasTau (Act Name) where τ := Act.τ @@ -69,10 +69,10 @@ theorem pre_tr (h : (lts (defs := defs)).Tr (pre μ p) μ' p') : μ = μ' ∧ p /-- Inversion lemma for constant transitions. -/ @[scoped grind →] -theorem const_tr (h : (lts (defs := defs)).Tr (const k) μ p') : +theorem const_tr (h : (lts (defs := defs)).Tr («const» k) μ p') : ∃ p, defs k = some p ∧ (lts (defs := defs)).Tr p μ p' := by cases h - case const p hdef htr => + case «const» p hdef htr => exists p /-- Prefixes are deterministic. -/ @@ -84,7 +84,7 @@ theorem pre_deterministicState : DeterministicState (lts (defs := defs)) (pre μ @[scoped grind .] theorem const_deterministicStateLabel (hdef : defs k = some p) (h : DeterministicStateLabel (lts (defs := defs)) p μ) : - DeterministicStateLabel (lts (defs := defs)) (const k) μ := by + DeterministicStateLabel (lts (defs := defs)) («const» k) μ := by intro p₁ p₂ h₁ h₂ cases h₁ cases h₂ diff --git a/CslibTests/CCS/VendingMachine.lean b/CslibTests/CCS/VendingMachine.lean index 7771ec301..285f8b2c9 100644 --- a/CslibTests/CCS/VendingMachine.lean +++ b/CslibTests/CCS/VendingMachine.lean @@ -11,7 +11,7 @@ namespace CslibTests open Cslib CCS Process Algorithms.CCS.VendingMachine /-- The deterministic vending machine can perform a coin action. -/ -example : ltsD.Tr vm Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) := +example : ltsD.Tr vm Coin `(CCS| (Tea. const .vm) + (Coffee. const .vm)) := Tr.const rfl Tr.pre end CslibTests From 37297d21d77fe57e1fd79ac6e8700a7317aa0af0 Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Mon, 14 Sep 2026 09:56:46 +0000 Subject: [PATCH 74/93] chore: Bump `mathlib` dependency to 87befc8 (#645) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bump `mathlib` dependency to [87befc8](https://github.com/leanprover-community/mathlib4/commit/87befc843c2b3a1be12f7fe9ba274d212b544348): doc(DerivNotation): remove stale "future work" note (#43662) (2026-09-13) Previously at: [950d270](https://github.com/leanprover-community/mathlib4/commit/950d27063f377d5ccd80d3eeedcebe319d3eb821): feat(TacticAnalysis): suggest `rwa` for `rw` followed by `assumption` (#42732) (2026-09-04) --- This is an automated dependency bump to the latest commit this project is known to build against (its **last-known-good** commit). `lake build` was run against the new commit before this PR was opened and succeeded, so it should be mergeable as-is. Only `lake build` is checked, though — if your own CI does more (linting, failing on warnings, downstream tests, …), run it on this PR before merging. _This PR was last updated on 2026-09-13 by [this workflow run](https://github.com/leanprover/cslib/actions/runs/34779898369). It is an automated bump using [downstream-reports/open-bump-pr](https://github.com/leanprover-community/downstream-reports)._ Co-authored-by: mathlib-nightly-testing[bot] --- lake-manifest.json | 8 ++++---- lakefile.toml | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lake-manifest.json b/lake-manifest.json index 931a3fb39..a1bb06ba0 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "950d27063f377d5ccd80d3eeedcebe319d3eb821", + "rev": "87befc843c2b3a1be12f7fe9ba274d212b544348", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "950d27063f377d5ccd80d3eeedcebe319d3eb821", + "inputRev": "87befc843c2b3a1be12f7fe9ba274d212b544348", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "e6f3c9cd0408a0024ba182319984f6243752cf4d", + "rev": "1681d78dd6e65e38b143f9740d829c826673807c", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "4cac2177c37f5530c4da76aa8e4307f3fc9e4dcb", + "rev": "3b4ce082a2051785ac99f899a50c55d43b6d9c28", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.toml b/lakefile.toml index 7e3bbf520..ca8ed2fd4 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "950d27063f377d5ccd80d3eeedcebe319d3eb821" +rev = "87befc843c2b3a1be12f7fe9ba274d212b544348" [[lean_lib]] name = "Cslib" From 105c46ebfdd9e83c8a853d5fbe675c612a3ce901 Mon Sep 17 00:00:00 2001 From: Christian Reitwiessner Date: Mon, 14 Sep 2026 11:46:30 +0000 Subject: [PATCH 75/93] feat(MultitapeTM): Prove an exponential upper bound in the number of configurations reachable in bounded space (#772) Proves an upper bound on the number of configurations reachable in bounded space on a multi-tape TM. The proof introduces the concept of `Storage`, the projection of `Cfg` that only contain the state and the work tapes. It shows that if the TM uses at most `s` space, there is an injection to a structure that only uses `[-s, s]` to index the tape. --------- Co-authored-by: Fabrizio Montesi --- Cslib.lean | 1 + .../Turing/MultiTape/ConfigBound.lean | 354 ++++++++++++++++++ .../Machines/Turing/MultiTape/TapeLemmas.lean | 23 ++ 3 files changed, 378 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean diff --git a/Cslib.lean b/Cslib.lean index 2b04deb7f..24388b6d4 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -54,6 +54,7 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness +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 diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean new file mode 100644 index 000000000..81db2e280 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Fintype.Prod +public import Mathlib.Data.Fintype.Option +public import Mathlib.Data.Set.Card +public import Mathlib.Order.Lattice.Nat +public import Mathlib.Algebra.Order.BigOperators.GroupWithZero.Finset +public import Mathlib.Tactic.Ring + +/-! +# Bounds on the number of reachable configurations in bounded space + +A multi-tape Turing machine that uses at most `s` cells of work-tape space can only reach a number +of configurations that differ in their storage content (state and work tapes) that is bounded +exponentially in `s`. Together with the `n + 2` possible positions of the input head this bounds +the number of configurations the machine can be in, disregarding the write-only output tape. + +## Important Definitions + +The results are layered, from the purely combinatorial to the machine-specific: + +* `MultiTapeTM.encard_fitsIn_le` is a counting statement about the type `Storage` alone and does + not mention Turing machines: a memory whose non-blank cells and heads stay within per-tape + windows of total size `s` can hold at most `storageBound Symbol State k s` different values. +* `MultiTapeTM.storage_fitsIn` is the geometric input: the storage reached after `t` steps stays + within the windows given by the space used up to step `t`. +* `MultiTapeTM.encard_storages_le` combines the two: a machine bounded by space `s` passes through + at most `storageBound Symbol State k s` storages *during its whole run*, no matter how long it + runs and how long its input is. This is the form needed for arguments below logarithmic space, + where the number of storages is much smaller than the number of input head positions. +* `MultiTapeTM.encard_cores_le` adds the input head position, giving the bound + `(n + 2) * storageBound Symbol State k s` on the number of reachable *cores* (`Cfg.core`, + a configuration without its output tape) for an input of length `n`. +* `MultiTapeTM.storageBound_le_base_mul_pow` restates `storageBound Symbol State k s` as + `storageBoundBase Symbol State k * 2 ^ (storageBoundExp Symbol k * s)`, so that the bounds can + be used to time-bound space-bounded machines. + +## Design + +The write-only output tape is never read by `step`, so it can be dropped: what a machine can still +react to is its `Cfg.core`, the pair of the input head position and the `Storage`. The input head +position, in contrast, *is* read, so it cannot be dropped and has to be counted, which is where +the factor `n + 2` comes from (the input head may move one step off the input in either direction). + +Starting from the all-blank tapes with every head at `0` and moving by at most one cell per step, +a computation in which tape `i` has visited at most `sᵢ` cells keeps that tape's head position and +every non-blank cell within the per-tape window `[-sᵢ, sᵢ]`. + +Hence a storage is determined by finite data over these windows, and counting it gives the +per-tape product `∏ᵢ (2 sᵢ + 1) · (|Symbol| + 1)^(2 sᵢ + 1)`. Since the tapes share the total space +budget (`∑ᵢ sᵢ ≤ s`), this collapses to an expression with the *total* space (`2s + k`) as the +alphabet exponent. + +We lose a factor of `2 * k` by simplifying the windows to `[-sᵢ, sᵢ]` instead of the actually used +area, but this is absorbed by the `O(s)` exponent in the final bound. + +The windows for a whole run are available because a machine that is space-bounded at every point in +time attains its per-tape space usage at a single step (`MultiTapeTM.exists_spaceUsedByTape_max`). +-/ + +@[expose] public section + +namespace Turing + +variable {k : ℕ} +variable {State Symbol : Type*} +variable {input : List Symbol} +variable {tm : MultiTapeTM k Symbol State} + +/-! +## Storage + +Defines the core data structure for this file, `Storage`, which contains the state and the work +tapes of a multi-tape Turing machine, with the work tape cells indexed over all of `ℤ`. It is +thus equivalent to a projection of `Cfg`. + +Then `BoundedStorage` is introduced, which restricts the cells and the head position of each tape +to a window `[-s, s]` (with a different `s` for each tape) and is therefore a finite type. It is +proven that the restriction map is injective on those `Storage`s whose non-blank cells and head +positions all lie inside the `[-s, s]` windows, so that counting `BoundedStorage` bounds the +number of such `Storage`s. +-/ + +/-- The state and work-tape data of a machine. -/ +@[ext] +structure Storage (Symbol State : Type*) (k : ℕ) where + /-- the state of the TM (cf. `Cfg.state`) -/ + state : Option State + /-- the contents of work tape `i` (cf. `Cfg.workTapes`) -/ + workTapes (i : Fin k) : ℤ → Option Symbol + /-- the position of the head on work tape `i` (cf. `Cfg.workTapePos`) -/ + workTapePos (i : Fin k) : ℤ + +/-- The window `[-s, s]` of tape positions allotted to a tape that uses `s` cells. -/ +@[scoped grind =] +def window (s : ℕ) : Finset ℤ := Finset.Icc (-(s : ℤ)) s + +@[scoped grind =] +lemma mem_window {s : ℕ} {z : ℤ} : z ∈ window s ↔ z.natAbs ≤ s := by + grind + +@[simp] +lemma card_window (s : ℕ) : (window s).card = 2 * s + 1 := by + grind [Int.card_Icc] + +/-- A bounded storage: the state and work-tape data of a machine, but with the cells and the head +position of tape `i` restricted to the finite window `[-(w i), w i]`. -/ +abbrev BoundedStorage (Symbol State : Type*) {k : ℕ} (w : Fin k → ℕ) := + Option State × ((i : Fin k) → window (w i) → Option Symbol) × ((i : Fin k) → window (w i)) + +/-- A storage fits in the per-tape windows `w`: on each tape `j`, the head position and every +non-blank cell have absolute value `≤ w j`. -/ +structure Storage.FitsIn (x : Storage Symbol State k) (w : Fin k → ℕ) : Prop where + /-- the head position on every tape lies within its window -/ + pos_le : ∀ j, (x.workTapePos j).natAbs ≤ w j + /-- every non-blank cell on every tape lies within its window -/ + cell_le : ∀ j z, x.workTapes j z ≠ none → z.natAbs ≤ w j + +/-- If a `Storage` fits in a smaller window, it also fits in the larger window. -/ +lemma Storage.FitsIn_mono {x : Storage Symbol State k} : Monotone x.FitsIn := by + intro w₁ w₂ h_le h_fits + refine ⟨?_, ?_⟩ + · intro j + exact (h_fits.pos_le j).trans (h_le j) + · intro j z h_ne + exact (h_fits.cell_le j z h_ne).trans (h_le j) + +/-- Restriction of a storage to the finite windows `w` (with heads outside their window +clamped to `0`). -/ +def Storage.toBounded (x : Storage Symbol State k) (w : Fin k → ℕ) : + BoundedStorage Symbol State w := + (x.state, fun j z => x.workTapes j z.1, + fun j => if h : x.workTapePos j ∈ window (w j) then ⟨x.workTapePos j, h⟩ + else ⟨0, mem_window.mpr (Nat.zero_le _)⟩) + +/-- The restriction is injective on storages that fit in the windows. -/ +lemma Storage.toBounded_injOn (w : Fin k → ℕ) : + Set.InjOn (Storage.toBounded (Symbol := Symbol) (State := State) · w) {x | x.FitsIn w} := by + rintro x ⟨_, _⟩ y ⟨_, _⟩ hxy + simp only [Storage.toBounded, Prod.mk.injEq] at hxy + obtain ⟨hstate, htapes, hpos⟩ := hxy + apply Storage.ext hstate (funext₂ fun j z => ?_) (funext fun j => ?_) + · by_cases hz : z ∈ window (w j) + · exact congrFun (congrFun htapes j) ⟨z, hz⟩ + · grind + · grind [congrFun hpos j] + +/-! ## Counting storages + +This section is purely combinatorial: it counts how many values a `Storage` restricted to given +windows can take, without reference to a machine or a run. +-/ + +/-- An upper bound on the number of storages a `k`-tape machine can be in while using +at most `s` cells of total work-tape space, over the given alphabet and state set. The `(2s + 1)^k` +factor counts the possible head positions; the dominant factor `(|Symbol| + 1)^(2s + k)` uses the +*total* space `s` in the exponent (the `k` tapes share the space budget). -/ +def storageBound (Symbol State : Type*) [Fintype Symbol] [Fintype State] (k s : ℕ) : ℕ := + (Fintype.card State + 1) * ((2 * s + 1) ^ k * (Fintype.card Symbol + 1) ^ (2 * s + k)) + +/-- The number of bounded storages is at most `storageBound`. Counting the tapes separately gives +the per-tape product `∏ᵢ (2 wᵢ + 1) · (|Symbol| + 1) ^ (2 wᵢ + 1)`; each tape uses at most the +total space `s`, and the tapes together use at most `s`, which collapses the alphabet exponent +to `2s + k`. -/ +lemma card_boundedStorage_le [Fintype Symbol] [Fintype State] + {w : Fin k → ℕ} {s : ℕ} (hsum : ∑ i, w i ≤ s) : + Fintype.card (BoundedStorage Symbol State w) ≤ storageBound Symbol State k s := by + have hle : ∀ i, w i ≤ s := fun i => + (Finset.single_le_sum (fun i _ => Nat.zero_le (w i)) (Finset.mem_univ i)).trans hsum + simp only [BoundedStorage, storageBound, Fintype.card_prod, Fintype.card_option, + Fintype.card_pi, Finset.prod_const, Finset.card_univ, Fintype.card_coe, card_window] + rw [mul_comm (∏ i, (Fintype.card Symbol + 1) ^ (2 * w i + 1)), Finset.prod_pow_eq_pow_sum] + have hsc : ∑ i : Fin k, (2 * w i + 1) = 2 * (∑ i, w i) + k := by + simp [two_mul, Finset.sum_add_distrib] + gcongr + · simpa using Finset.prod_le_pow_card Finset.univ (fun i => 2 * w i + 1) (2 * s + 1) + fun i _ => by have := hle i; omega + · omega + · omega + +/-- The counting result at the heart of this file: a `Storage` whose non-blank cells and head +positions stay within per-tape windows of total size at most `s` can take at most +`storageBound Symbol State k s` different values. -/ +theorem encard_fitsIn_le [Fintype Symbol] [Fintype State] + {w : Fin k → ℕ} {s : ℕ} (hsum : ∑ i, w i ≤ s) : + {x : Storage Symbol State k | x.FitsIn w}.encard + ≤ storageBound Symbol State k s := by + calc {x : Storage Symbol State k | x.FitsIn w}.encard + = ((Storage.toBounded · w) '' {x | x.FitsIn w}).encard := + ((Storage.toBounded_injOn w).encard_image).symm + _ ≤ (Set.univ : Set (BoundedStorage Symbol State w)).encard := + Set.encard_le_encard (Set.subset_univ _) + _ = Fintype.card (BoundedStorage Symbol State w) := by + simp [Set.encard_univ, ENat.card_eq_coe_fintype_card] + _ ≤ storageBound Symbol State k s := by + exact_mod_cast card_boundedStorage_le hsum + +/-! ### The exponential form of `storageBound` + +This proves that `storageBound` is exponential in the space `s`. + -/ + +/-- The base factor in the resulting exponential form of `storageBound`. -/ +def storageBoundBase (Symbol State : Type*) [Fintype Symbol] [Fintype State] (k : ℕ) : ℕ := + (Fintype.card State + 1) * 2 ^ ((Fintype.card Symbol + 1) * k + k) + +/-- The factor in the exponent of the exponential form of `storageBound`. -/ +def storageBoundExp (Symbol : Type*) [Fintype Symbol] (k : ℕ) : ℕ := + 2 * (Fintype.card Symbol + 1) + k + +/-- `storageBound` grows at most exponentially in the space `s`, with a constant factor and a +factor in the exponent that only depend on the machine's alphabet, state set and tape count. -/ +lemma storageBound_le_base_mul_pow [Fintype Symbol] [Fintype State] (s : ℕ) : + storageBound Symbol State k s + ≤ storageBoundBase Symbol State k * 2 ^ (storageBoundExp Symbol k * s) := by + set syms := Fintype.card Symbol + 1 with hB + set states := Fintype.card State + 1 with hQ + -- The strategy is to bound each factor of `storageBound` by a power of `2`, using + -- `syms ≤ 2 ^ syms` and `2 * s + 1 ≤ 2 ^ (s + 1)`. Collecting the exponents then yields + -- `(s + 1) * k + syms * (2 * s + k)`, which splits into the constant part `syms * k + k` + -- (which is in `storageBoundBase`) and the part `(2 * syms + k) * s` linear in `s`. + have hB2 : syms ≤ 2 ^ syms := Nat.lt_two_pow_self.le + have h2s1 : 2 * s + 1 ≤ 2 ^ (s + 1) := by grind [pow_succ, Nat.lt_two_pow_self] + calc storageBound Symbol State k s + = states * ((2 * s + 1) ^ k * syms ^ (2 * s + k)) := rfl + _ ≤ states * ((2 ^ (s + 1)) ^ k * (2 ^ syms) ^ (2 * s + k)) := by gcongr <;> omega + _ = states * 2 ^ ((s + 1) * k + syms * (2 * s + k)) := by ring + _ = states * 2 ^ ((syms * k + k) + (2 * syms + k) * s) := by ring_nf + _ = states * 2 ^ (syms * k + k) * 2 ^ ((2 * syms + k) * s) := by ring + +/-- `storageBound` grows at most exponentially in the space `s`: there exist constants `a` and `c` +(depending on the machine's alphabet, state set and tape count) with +`storageBound Symbol State k s ≤ a * 2 ^ (c * s)` for all `s`. -/ +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⟩ + +/-! ## The storage and the core of a configuration + +Now we relate `Cfg` and `Storage` by giving the projection. +-/ + +/-- This function maps a `Cfg` to `Storage`, forgetting the input head position and the +write-only output tape. -/ +def Cfg.storage (c : Cfg k Symbol State input) : Storage Symbol State k := + ⟨c.state, c.workTapes, c.workTapePos⟩ + +/-- The part of a configuration that the machine can still read: the input head position together +with the `Storage`, i.e. the configuration without the write-only output tape. -/ +def Cfg.core (c : Cfg k Symbol State input) : + Fin (input.length + 2) × Storage Symbol State k := + (c.inputPos, c.storage) + +/-- `step` never reads the output tape, so the core of the next configuration is determined by the +core of the current one. -/ +lemma core_step_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input} (h : c₁.core = c₂.core) : + (tm.step c₁).core = (tm.step c₂).core := by + simp only [Cfg.core, Cfg.storage, Prod.mk.injEq, Storage.mk.injEq] at h + obtain ⟨hpos, hstate, hwt, hwp⟩ := h + have hsym : c₁.inputSymbol = c₂.inputSymbol := by simp [Cfg.inputSymbol, hpos] + have hws : c₁.workTapeSymbols = c₂.workTapeSymbols := by + funext i + simp [Cfg.workTapeSymbols, hwt, hwp] + simp only [Cfg.core, Cfg.storage, MultiTapeTM.step, hstate, hsym, hws] + cases c₂.state <;> simp [hpos, hstate, hwt, hwp] + +/-! ## 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 + +/-- The storage reached after `t` steps fits in the windows given by the per-tape space usage up +to step `t`. -/ +lemma storage_fitsIn (t : ℕ) : + (tm.runFrom (tm.initCfg input) t).storage.FitsIn (tm.spaceUsedByTape (tm.initCfg input) t) := by + constructor + · intro j + simpa [Cfg.storage] using tm.natAbs_le_spaceUsedByTape_of_mem_visited + (tm.mem_visitedByTapeHead_self (tm.initCfg input) t j) + · intro j + exact content_natAbs_le_spaceUsedByTape t + +/-- A machine that uses at most `s` cells of work-tape space at every point in time passes through +at most `storageBound Symbol State k s` different storages during its whole run — independently of +the length of the input and of how long it runs. -/ +theorem encard_storages_le [Fintype Symbol] [Fintype State] {s : ℕ} + (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) : + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard + ≤ storageBound Symbol State k s := by + obtain ⟨T, hT⟩ := tm.exists_spaceUsedByTape_max (tm.initCfg input) hs + refine le_trans (Set.encard_le_encard ?_) (encard_fitsIn_le (hs T)) + rintro _ ⟨t, rfl⟩ + exact Storage.FitsIn_mono (fun i => hT t i) (tm.storage_fitsIn t) + +/-- The number of configuration cores that a machine bounded by space `s` can reach is at most +`(n + 2) * storageBound Symbol State k s`, where `n` is the length of the input. -/ +theorem encard_cores_le [Fintype Symbol] [Fintype State] {s : ℕ} + (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) : + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ (input.length + 2) * storageBound Symbol State k s := by + calc (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ ((Set.univ : Set (Fin (input.length + 2))) + ×ˢ (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage)).encard := by + apply Set.encard_le_encard + rintro _ ⟨t, rfl⟩ + exact ⟨Set.mem_univ _, t, rfl⟩ + _ = (Set.univ : Set (Fin (input.length + 2))).encard + * (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard := Set.encard_prod + _ ≤ (input.length + 2) * storageBound Symbol State k s := by + refine mul_le_mul' ?_ (tm.encard_storages_le hs) + simp [Set.encard_univ, ENat.card_eq_coe_fintype_card] + +/-- The storage bound in exponential form: the number of storages a space-`s`-bounded machine +passes through is at most `2 ^ (O(s))`, with constants depending only on the machine. -/ +theorem encard_storages_le_pow [Finite Symbol] [Finite State] : + ∃ a c : ℕ, ∀ (input : List Symbol) (s : ℕ), + (∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) → + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard ≤ a * 2 ^ (c * s) := by + have : Fintype Symbol := Fintype.ofFinite Symbol + have : Fintype State := Fintype.ofFinite State + obtain ⟨a, c, hpow⟩ := storageBound_le_pow (Symbol := Symbol) (State := State) (k := k) + refine ⟨a, c, fun input s hs => (tm.encard_storages_le hs).trans ?_⟩ + exact_mod_cast hpow s + +/-- The core bound in exponential form: the number of cores a space-`s`-bounded machine can reach +is at most `(n + 2) * 2 ^ (O(s))`, with constants depending only on the machine and not on the +input. -/ +theorem encard_cores_le_pow [Finite Symbol] [Finite State] : + ∃ a c : ℕ, ∀ (input : List Symbol) (s : ℕ), + (∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) → + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ (input.length + 2) * a * 2 ^ (c * s) := by + have : Fintype Symbol := Fintype.ofFinite Symbol + have : Fintype State := Fintype.ofFinite State + obtain ⟨a, c, hpow⟩ := storageBound_le_pow (Symbol := Symbol) (State := State) (k := k) + refine ⟨a, c, fun input s hs => (tm.encard_cores_le hs).trans ?_⟩ + calc ((input.length + 2) * storageBound Symbol State k s : ℕ∞) + ≤ ((input.length + 2) * (a * 2 ^ (c * s)) : ℕ) := by + exact_mod_cast Nat.mul_le_mul_left _ (hpow s) + _ = (input.length + 2) * a * 2 ^ (c * s) := by push_cast; ring + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index b6a2574d3..fcf67a3d0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -8,6 +8,7 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Mathlib.Data.Int.Interval +public import Mathlib.Order.Lattice.Nat /-! # Tape head visitation and space-usage lemmas @@ -17,6 +18,10 @@ This file collects lemmas about the set of positions visited by a work-tape head (`MultiTapeTM.spaceUsedByTape`, `MultiTapeTM.spaceUsed`) and how the tape head positions influence the cells that are modified on a tape. +`MultiTapeTM.exists_spaceUsedByTape_max` shows that a computation whose space usage is bounded +attains its per-tape space usage at a single step, which makes a bound that holds at every point +in time usable as a bound for the whole run. + -/ @[expose] public section @@ -148,4 +153,22 @@ lemma spaceUsed_mono (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State intro t t' h exact Finset.sum_le_sum (fun i _ => spaceUsedByTape_mono tm cfg i h) +/-- A computation whose total space usage stays below a bound reaches a step `T` at which the space +usage of *every* tape is maximal. This turns a bound that holds at every point in time into a +bound for the whole run. -/ +lemma exists_spaceUsedByTape_max (cfg : Cfg k Symbol State input) {s : ℕ} + (hs : ∀ t, tm.spaceUsed cfg t ≤ s) : + ∃ T, ∀ t i, tm.spaceUsedByTape cfg t i ≤ tm.spaceUsedByTape cfg T i := by + -- The space usage of a single tape is bounded, so it attains its supremum at some step `T i`. + have h : ∀ i, ∃ Ti, ∀ t, tm.spaceUsedByTape cfg t i ≤ tm.spaceUsedByTape cfg Ti i := by + intro i + have hbdd : BddAbove (Set.range (tm.spaceUsedByTape cfg · i)) := + ⟨s, by rintro _ ⟨t, rfl⟩; exact (tm.spaceUsedByTape_le_spaceUsed cfg t i).trans (hs t)⟩ + obtain ⟨Ti, hTi⟩ := Nat.sSup_mem (Set.range_nonempty (tm.spaceUsedByTape cfg · i)) hbdd + exact ⟨Ti, fun t => (le_csSup hbdd ⟨t, rfl⟩).trans hTi.ge⟩ + choose T hT using h + -- Monotonicity lets us use a single step that is late enough for every tape. + exact ⟨Finset.univ.sup T, fun t i => + (hT i t).trans (tm.spaceUsedByTape_mono cfg i (Finset.le_sup (Finset.mem_univ i)))⟩ + end Turing.MultiTapeTM From a374775894efb9b7196cccf11235c60a97086dc1 Mon Sep 17 00:00:00 2001 From: Christian Reitwiessner Date: Mon, 14 Sep 2026 15:39:14 +0000 Subject: [PATCH 76/93] feat(MultiTapeTM): Any function constant with finitely many exceptions is computable in constant time and space (#854) This is a starting point of a Turing machine combinator library, it adds one of the leaves: Any function that is constant with finitely many exceptions is computable in constant time and zero space, relative to any encoding. The same holds for any function with a finite domain. This result captures many functions we want to compose later or with a combinator library: Any function on tuples of `Bool`, for example and "equality comparison with a constant". Together with a "fold" and "composition" combinators, this already allows us to evaluate CNFs or compute `Nat.succ` on binary encoded numbers. --- Cslib.lean | 1 + .../MultiTape/Combinators/AlmostConstant.lean | 393 ++++++++++++++++++ .../Turing/MultiTape/Configuration.lean | 8 + CslibTests.lean | 1 + CslibTests/Complexity/Combinators.lean | 38 ++ 5 files changed, 441 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean create mode 100644 CslibTests/Complexity/Combinators.lean diff --git a/Cslib.lean b/Cslib.lean index 24388b6d4..6c20dd086 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -54,6 +54,7 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound public import Cslib.Computability.Machines.Turing.MultiTape.Configuration public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean new file mode 100644 index 000000000..6e0a104fe --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Mathlib.Data.List.Infix +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of Almost Constant Functions + +A function `f : α → β` that is constant except for a finite number of arguments is computable in +constant time and zero space: the machine reads the encoded input while remembering the prefix it +has seen so far. After a finite number of steps it either reaches the end of the input or a point +where the prefix cannot be extended to the encoding of one of the finitely many exceptions. In both +cases, it emits the corresponding output one symbol at a time. + +This result also holds for functions whose domain is already finite. + +## Main Results + +* `encodedComputableInTimeAndSpace_of_finite`: Every function on a finite type is computable in + constant time and zero space, relative to any encoding. +* `encodedComputableInTimeAndSpace_of_exists_finite_ne`: Every function that is constant except + for a finite number of arguments is computable in constant time and zero space, relative to any + encoding. +* `encodedComputableInTimeAndSpace_of_const`: Every constant function is computable in constant + time and zero space, relative to any encoding. +* `encodedComputableInTimeAndSpace_almostConstTime` and + `encodedComputableInTimeAndSpace_finiteFunTime`: The same with explicit time bounds. + +-/ + +namespace Turing.MultiTapeTM + +section AlmostConstFun + +/-! ## The machine computing a function that is constant outside a finite set + +The machine `almostConstTM encIn encOut f S out` computes `f`, provided that the encoded output +of `f` is the fixed Boolean string `out` outside of the finite set `S`. -/ + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {f : α → β} + {S : Finset α} {out : List Bool} + +/-- The prefixes of the encodings of the elements of a finite set `S`, together with the empty list. + +The empty list has to be added explicitly for the case where `S` is empty: `almostConstTM` uses +the elements of this set as its states while reading the input, so the set has to contain the +starting state `[]` even if there is nothing to distinguish. -/ +def encPrefixes (encIn : α ↪ List Bool) (S : Finset α) : Finset (List Bool) := + insert [] (S.biUnion fun a => (encIn a).inits.toFinset) + +lemma mem_encPrefixes {p : List Bool} {a : α} (ha : a ∈ S) (h : p <+: encIn a) : + p ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, List.mem_inits] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of prefixes is closed under taking prefixes. -/ +lemma prefix_mem_encPrefixes {p q : List Bool} (h : p ∈ encPrefixes encIn S) (hq : q <+: p) : + q ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h ⊢ + rcases h with rfl | ⟨a, ha, hp⟩ + · exact Or.inl (List.prefix_nil.mp hq) + · exact Or.inr ⟨a, ha, hq.trans hp⟩ + +/-- The suffixes of the default output and of the encoded values of `f` on `S`. -/ +def outSuffixes (encOut : β ↪ List Bool) (f : α → β) (S : Finset α) (out : List Bool) : + Finset (List Bool) := + out.tails.toFinset ∪ S.biUnion fun a => (encOut (f a)).tails.toFinset + +lemma suffix_out_mem_outSuffixes {w : List Bool} (h : w <:+ out) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, List.mem_toFinset, List.mem_tails] + exact Or.inl h + +lemma mem_outSuffixes {w : List Bool} {a : α} (ha : a ∈ S) (h : w <:+ encOut (f a)) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, List.mem_tails] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of suffixes is closed under taking suffixes. -/ +lemma suffix_mem_outSuffixes {v w : List Bool} (h : w ∈ outSuffixes encOut f S out) (hv : v <:+ w) : + v ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, + List.mem_tails] at h ⊢ + rcases h with h | ⟨a, ha, h⟩ + · exact Or.inl (hv.trans h) + · exact Or.inr ⟨a, ha, hv.trans h⟩ + +lemma tail_mem_outSuffixes {w : List Bool} (h : w ∈ outSuffixes encOut f S out) : + w.tail ∈ outSuffixes encOut f S out := + suffix_mem_outSuffixes h (List.tail_suffix w) + +/-- If the encoded output is the default output outside of `S`, then every encoded output occurs +among the suffixes. -/ +lemma encOut_mem_outSuffixes (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + encOut (f a) ∈ outSuffixes encOut f S out := by + by_cases ha : a ∈ S + · exact mem_outSuffixes ha (List.suffix_refl _) + · rw [h a ha] + exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +/-- The states of the machine `almostConstTM`: either the prefix of the input read so far, or the +part of the output that still has to be emitted. -/ +abbrev AlmostConstState (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : Type := + {p : List Bool // p ∈ encPrefixes encIn S} ⊕ {w : List Bool // w ∈ outSuffixes encOut f S out} + +open Classical in +/-- The function `f`, transported along the encodings of its domain and codomain: it maps the +encoding of an element of `S` to the encoding of its value under `f`, and every other list to the +default output. -/ +noncomputable def encodedFun (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) (p : List Bool) : List Bool := + if h : ∃ a ∈ S, encIn a = p then encOut (f h.choose) else out + +@[simp] +lemma encodedFun_enc {a : α} (ha : a ∈ S) : + encodedFun encIn encOut f S out (encIn a) = encOut (f a) := by + have hex : ∃ a' ∈ S, encIn a' = encIn a := ⟨a, ha, rfl⟩ + rw [encodedFun, dite_eq_left_of_eq_true (eq_true hex), encIn.injective hex.choose_spec.2] + +@[simp] +lemma encodedFun_enc_of_notMem {a : α} (ha : a ∉ S) : + encodedFun encIn encOut f S out (encIn a) = out := by + have hex : ¬ ∃ a' ∈ S, encIn a' = encIn a := by + rintro ⟨a', ha', h⟩ + exact ha (encIn.injective h ▸ ha') + rw [encodedFun, dite_eq_right_of_eq_false (eq_false hex)] + +lemma encodedFun_mem_outSuffixes (p : List Bool) : + encodedFun encIn encOut f S out p ∈ outSuffixes encOut f S out := by + rw [encodedFun] + split + · next h => exact mem_outSuffixes h.choose_spec.1 (List.suffix_refl _) + · exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +open Classical in +/-- The machine computing a function that is constant outside of `S`. It has no work tapes. + +While reading the input it remembers the prefix read so far. Once this prefix cannot be extended +to the encoding of an element of `S` anymore, or the blank behind the input is reached, it +switches to the state that holds the encoded output, which it then emits one symbol per step +before halting. -/ +noncomputable def almostConstTM (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : + MultiTapeTM 0 Bool (AlmostConstState encIn encOut f S out) where + q₀ := Sum.inl ⟨[], by simp [encPrefixes]⟩ + tr q input _ := + match q with + | Sum.inl p => + match input with + | some b => + if h : p.val ++ [b] ∈ encPrefixes encIn S then + ⟨.pos, Fin.elim0, none, some (Sum.inl ⟨p.val ++ [b], h⟩)⟩ + else + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨out, suffix_out_mem_outSuffixes (List.suffix_refl out)⟩)⟩ + | none => + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨encodedFun encIn encOut f S out p.val, + encodedFun_mem_outSuffixes p.val⟩)⟩ + | Sum.inr w => + ⟨0, Fin.elim0, w.val.head?, + if w.val = [] then none + else some (Sum.inr ⟨w.val.tail, tail_mem_outSuffixes w.property⟩)⟩ + +/-- The configuration reached after `j` steps of reading the input. -/ +lemma runFrom_read (a : α) {j : ℕ} (hj : j ≤ (encIn a).length) + (hmem : (encIn a).take j ∈ encPrefixes encIn S) : + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) j = + { state := some (Sum.inl ⟨(encIn a).take j, hmem⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + induction j with + | zero => + simp only [runFrom_zero, initCfg, List.take_zero] + ext <;> simp [almostConstTM] + | succ j ih => + have hprefix : (encIn a).take j <+: (encIn a).take (j + 1) := by + simp + have hmem' : (encIn a).take j ∈ encPrefixes encIn S := prefix_mem_encPrefixes hmem hprefix + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∈ encPrefixes encIn S := by + grind [List.take_concat_get'] + have hmove : moveInputPos (⟨1 + j, by omega⟩ : Fin ((encIn a).length + 2)) SignType.pos + = ⟨1 + (j + 1), by omega⟩ := by + grind [moveInputPos_pos_of_ne_right] + have hstart : 1 + j ≠ 0 := by omega + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + rw [runFrom_succ_eq_step', ih (by omega) hmem'] + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat] + exact Cfg.ext_zero_tapes (by grind [List.take_concat_get']) hmove (by simp) + +/-- The configuration reached after having emitted the first `i` symbols of `w`, starting from a +configuration that is about to emit `w`. -/ +lemma runFrom_write {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) {i : ℕ} (hi : i ≤ w.length) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } i = + { state := some (Sum.inr ⟨w.drop i, suffix_mem_outSuffixes hw (w.drop_suffix i)⟩), + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w.take i } := by + induction i with + | zero => simp [runFrom_zero] + | succ i ih => + have hilt : i < w.length := by omega + have htake := List.take_concat_get' w i hilt + have hnotdone : ¬ (w.length ≤ i) := by omega + rw [runFrom_succ_eq_step', ih (by omega)] + simp only [step, Action.apply, almostConstTM, List.head?_drop, + List.getElem?_eq_getElem hilt, List.drop_eq_nil_iff, hnotdone, reduceIte, List.tail_drop, + moveInputPos_zero, Option.toList_some] + exact Cfg.ext_zero_tapes rfl rfl (by grind) + +/-- Starting from a configuration that is about to emit `w`, the machine halts after `w.length + 1` +steps, having emitted `w`. -/ +lemma runFrom_write_halted {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } (w.length + 1) = + { state := none, + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w } := by + rw [runFrom_succ_eq_step', runFrom_write pos o hw le_rfl] + simp only [step, Action.apply, almostConstTM, List.drop_length, reduceIte, List.head?_nil, + moveInputPos_zero, Option.toList_none, List.append_nil, List.take_length] + exact Cfg.ext_zero_tapes rfl rfl (by simp) + +/-- A constant time bound for the machine `almostConstTM`. -/ +@[expose] +public def almostConstTime (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : ℕ := + 2 + out.length + S.sup fun a => (encIn a).length + (encOut (f a)).length + +lemma length_le_sup_of_mem_encPrefixes {p : List Bool} (h : p ∈ encPrefixes encIn S) : + p.length ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h + rcases h with rfl | ⟨a, ha, hp⟩ + · simp + · have hsup : (encIn a).length + (encOut (f a)).length ≤ + S.sup fun a => (encIn a).length + (encOut (f a)).length := + Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha + have := hp.length_le + omega + +/-- The machine reaches the state in which it starts emitting the encoded output after a number +of steps that is bounded independently of the input. -/ +lemma reaches_write (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + ∃ (j : ℕ) (hj : j ≤ (encIn a).length), + j + (encOut (f a)).length ≤ + out.length + S.sup (fun a => (encIn a).length + (encOut (f a)).length) ∧ + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) = + { state := some (Sum.inr ⟨encOut (f a), encOut_mem_outSuffixes h a⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + classical + set j := Nat.findGreatest (fun j => (encIn a).take j ∈ encPrefixes encIn S) (encIn a).length + with hjdef + have hmem : (encIn a).take j ∈ encPrefixes encIn S := + Nat.findGreatest_spec (P := fun j => (encIn a).take j ∈ encPrefixes encIn S) + (Nat.zero_le _) (by simp [encPrefixes]) + have hjle : j ≤ (encIn a).length := Nat.findGreatest_le _ + have hjsup : j ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + have hlen := length_le_sup_of_mem_encPrefixes (encOut := encOut) (f := f) hmem + rw [List.length_take] at hlen + omega + use j, hjle + constructor + · by_cases ha : a ∈ S + · grind [Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha] + · grind [h a ha] + rw [runFrom_succ_eq_step', runFrom_read a hjle hmem] + rcases eq_or_lt_of_le hjle with heq | hlt + · -- the whole input has been read, so the machine decodes it + have hend : 1 + j = (encIn a).length + 1 := by omega + have hdec : encodedFun encIn encOut f S out ((encIn a).take j) = encOut (f a) := by + rw [heq, List.take_length] + by_cases ha : a ∈ S + · exact encodedFun_enc ha + · rw [encodedFun_enc_of_notMem ha, h a ha] + simp only [step, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, hend, + reduceDIte, dite_eq_ite, ite_self, hdec] + exact Cfg.ext_zero_tapes rfl (by simp) (by simp) + · -- the prefix read so far cannot be extended, so the machine emits the default output + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + have hnotmem : (encIn a).take (j + 1) ∉ encPrefixes encIn S := + Nat.findGreatest_is_greatest (hjdef ▸ Nat.lt_succ_self j) (by omega) + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∉ encPrefixes encIn S := by + grind [List.take_concat_get'] + have ha : a ∉ S := fun ha => hnotmem (mem_encPrefixes ha ((encIn a).take_prefix _)) + have hstart : 1 + j ≠ 0 := by omega + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat, moveInputPos_zero] + refine Cfg.ext_zero_tapes ?_ (by simp) (by simp) + simp only [Option.some.injEq, Sum.inr.injEq, Subtype.mk.injEq] + exact (h a ha).symm + +/-- The machine `almostConstTM` computes `f` in at most `almostConstTime` steps and no space. -/ +lemma computesFunInTimeAndSpace_almostConstTM (h : ∀ a ∉ S, encOut (f a) = out) : + ComputesFunInTimeAndSpace (almostConstTM encIn encOut f S out) encIn encOut f + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := by + intro a + obtain ⟨j, hjle, hj, hrun⟩ := reaches_write h a + have hhalt := (almostConstTM encIn encOut f S out).runFrom_add + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) ((encOut (f a)).length + 1) + rw [hrun, runFrom_write_halted] at hhalt + use j + 1 + ((encOut (f a)).length + 1) + refine ⟨?_, 0, le_rfl, ?_⟩ + · change j + 1 + ((encOut (f a)).length + 1) ≤ almostConstTime encIn encOut f S out + rw [almostConstTime] + omega + · unfold ComputesInTimeAndSpace + rw [hhalt] + simp + +end AlmostConstFun + +section Results + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + +/-- Every function whose encoded output is constant outside of a finite set is computable in time +`almostConstTime` and zero space. -/ +public theorem computableInTimeAndSpace_almostConstTime + (f : α → β) (S : Finset α) (out : List Bool) (h : ∀ a ∉ S, encOut (f a) = out) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := + ⟨0, AlmostConstState encIn encOut f S out, inferInstance, almostConstTM encIn encOut f S out, + computesFunInTimeAndSpace_almostConstTM h⟩ + +/-- Every almost constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_exists_finite_ne + {f : α → β} (h : ∃ b : β, {a : α | f a ≠ b}.Finite) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := by + obtain ⟨b, hb⟩ := h + refine ⟨_, computableInTimeAndSpace_almostConstTime f hb.toFinset (encOut b) ?_⟩ + intro a ha + simp only [Set.Finite.mem_toFinset, Set.mem_ofPred_eq, not_not] at ha + rw [ha] + +/-- Every constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_const {α β : Type*} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (b : β) : + ∃ c, ComputableInTimeAndSpace (Function.const α b) encIn encOut + (fun _ => c) (fun _ => 0) := + computableInTimeAndSpace_of_exists_finite_ne ⟨b, by simp⟩ + +/-- A constant time bound for functions on a finite type. -/ +@[expose] +public noncomputable def finiteFunTime {α β : Type*} [Finite α] (encIn : α ↪ List Bool) + (encOut : β ↪ List Bool) (f : α → β) : ℕ := + haveI := Fintype.ofFinite α + almostConstTime encIn encOut f Finset.univ [] + +/-- Every function on a finite type is computable in time `finiteFunTime` and zero space. -/ +public theorem computableInTimeAndSpace_finiteFunTime {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (f : α → β) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => finiteFunTime encIn encOut f) (fun _ => 0) := + computableInTimeAndSpace_almostConstTime f (@Finset.univ α (Fintype.ofFinite α)) [] + fun a ha => absurd (@Finset.mem_univ α (Fintype.ofFinite α) a) ha + +/-- Every function on a finite type is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_finite {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + (f : α → β) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := + ⟨_, computableInTimeAndSpace_finiteFunTime f⟩ + +end Results + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 93e8aa70f..78237a5b5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -81,6 +81,14 @@ structure Cfg (k : ℕ) (Symbol State : Type*) (input : List Symbol) where output : List Symbol deriving Inhabited +/-- Two configurations of a machine without work tapes are equal if their states, input head +positions and outputs are equal. -/ +lemma Cfg.ext_zero_tapes {Symbol State : Type*} {input : List Symbol} + {cfg₁ cfg₂ : Cfg 0 Symbol State input} (state : cfg₁.state = cfg₂.state) + (inputPos : cfg₁.inputPos = cfg₂.inputPos) (output : cfg₁.output = cfg₂.output) : + cfg₁ = cfg₂ := + Cfg.ext state inputPos (funext fun i => i.elim0) (funext fun i => i.elim0) output + /-- Attempt to move the input tape head. The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. diff --git a/CslibTests.lean b/CslibTests.lean index 64e84ecbe..016de8648 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -4,6 +4,7 @@ import CslibTests.CCS.VendingMachine import CslibTests.CLL import CslibTests.Circuits import CslibTests.Commitment +import CslibTests.Complexity.Combinators import CslibTests.Congruence import CslibTests.DFA import CslibTests.FreeMonad diff --git a/CslibTests/Complexity/Combinators.lean b/CslibTests/Complexity/Combinators.lean new file mode 100644 index 000000000..b4c3a05a7 --- /dev/null +++ b/CslibTests/Complexity/Combinators.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant + +namespace CslibTests + +open Cslib Turing MultiTapeTM + +/-- The Boolean `and` function is computable in constant time and zero space. -/ +example : ∀ encIn encOut, ∃ c, ComputableInTimeAndSpace + (Function.uncurry Bool.and) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut + apply computableInTimeAndSpace_of_finite + +def fullAdder (a b carry : Bool) : Bool × Bool := + let sum := (a != b) != carry + let newCarry := (a && b) || (carry && (a != b)) + (sum, newCarry) + +/-- The binary full adder is computable in constant time and zero space. -/ +example : ∀ encIn encOut, ∃ c, ComputableInTimeAndSpace + (fun (a, b, carry) => fullAdder a b carry) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut + apply computableInTimeAndSpace_of_finite + +/-- Equality comparison to a constant is computable in constant time and zero space, +also for infinite domains. -/ +example {α : Type*} [DecidableEq α] : ∀ encIn encOut out, ∃ c, ComputableInTimeAndSpace + (fun a : α => a == out) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut out + refine computableInTimeAndSpace_of_exists_finite_ne ⟨false, ?_⟩ + exact Set.Finite.subset (Set.finite_singleton out) (by intro a ha; simp_all) + +end CslibTests From 91ab23c78b12e6c9d6fe747fa3f55c2771dd376e Mon Sep 17 00:00:00 2001 From: lyj Date: Tue, 15 Sep 2026 05:40:28 +0000 Subject: [PATCH 77/93] fix: correct Confluent.to_churchRosser alias (#906) --- Cslib/Foundations/Relation/Confluence.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean index 94b028824..f76091cb6 100644 --- a/Cslib/Foundations/Relation/Confluence.lean +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -151,7 +151,7 @@ theorem semiConfluent_iff_churchRosser : SemiConfluent r ↔ ChurchRosser r := theorem confluent_iff_churchRosser : Confluent r ↔ ChurchRosser r := List.TFAE.out confluent_equivalents 3 1 -alias ⟨_, Confluent.to_churchRosser⟩ := confluent_iff_churchRosser +alias ⟨Confluent.to_churchRosser, _⟩ := confluent_iff_churchRosser @[deprecated (since := "2026-09-03")] alias Confluent_iff_ChurchRosser := confluent_iff_churchRosser From 990e65a685bed413f43b139db900a36ad5322a10 Mon Sep 17 00:00:00 2001 From: Garmelon Date: Tue, 15 Sep 2026 11:13:25 +0000 Subject: [PATCH 78/93] chore: bump toolchain to v4.34.0 (#907) --- lake-manifest.json | 22 +++++++++++----------- lakefile.toml | 2 +- lean-toolchain | 2 +- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/lake-manifest.json b/lake-manifest.json index a1bb06ba0..2af0a16f3 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "87befc843c2b3a1be12f7fe9ba274d212b544348", + "rev": "5ed2965256430c3649e86755f9576b54eca72435", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "87befc843c2b3a1be12f7fe9ba274d212b544348", + "inputRev": "v4.34.0", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "d9598f07b1bc701f1e3aae163d2681c1fd978793", + "rev": "118aa17ee84656b8bd727fef7c458ee8c833385c", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "ba67e212be1197b84c1f1f6299488a10a3002713", + "rev": "ddf04cf3949fa556442341e87d47f9f6e6074707", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "1681d78dd6e65e38b143f9740d829c826673807c", + "rev": "e928b72544873815af278d38681b31c0293588e3", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "a8acbfd87375ff4abe14ce09db5b7664d383bc7f", + "rev": "106ff4fafc74ef4ac99d81dbf3ab399118f497a5", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "18889deb9e83ea7420ef51c160d6f88552e744e3", + "rev": "355695d523e41d0554926416cba2a2b3544fbbc9", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "507746ab8f4b643ccdacb2ec4cdb5853fa9f8ab3", + "rev": "6a489d9af5d0c47e5b259e2e8bcdfc1811b5a259", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "3b4ce082a2051785ac99f899a50c55d43b6d9c28", + "rev": "f2effa3d803fda822b1f97b806c47cf2adfbcbc2", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "ab3a82db9fea14cf0fd7f5a2de650f4b534640af", + "rev": "e92c9f15fdfacc8536f31cfb3b7ad26c3c8cd204", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.34.0-rc2", + "inputRev": "v4.34.0", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index ca8ed2fd4..289228147 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "87befc843c2b3a1be12f7fe9ba274d212b544348" +rev = "v4.34.0" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index b814d987e..12359f928 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.34.0-rc2 +leanprover/lean4:v4.34.0 From 2277592e0e11a02b87d00613d129b17217285749 Mon Sep 17 00:00:00 2001 From: Garmelon Date: Tue, 15 Sep 2026 22:09:01 +0000 Subject: [PATCH 79/93] chore: bump toolchain to v4.35.0-rc1 (#909) Co-authored-by: mathlib4-bot Co-authored-by: mathlib-nightly-testing[bot] <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Ching-Tsun Chou Co-authored-by: Chris Henson Co-authored-by: Chris Henson <46805207+chenson2018@users.noreply.github.com> Co-authored-by: Alexandre Rademaker Co-authored-by: leanprover-community-mathlib4-bot <129911861+leanprover-community-mathlib4-bot@users.noreply.github.com> Co-authored-by: leanprover-community-mathlib4-bot Co-authored-by: Kim Morrison Co-authored-by: Kim Morrison <477956+kim-em@users.noreply.github.com> Co-authored-by: Fabrizio Montesi Co-authored-by: downstream-lean4[bot] <296232862+downstream-lean4[bot]@users.noreply.github.com> Co-authored-by: downstream-lean4[bot] --- Cslib/Foundations/Semantics/LTS/HasTau.lean | 8 +++---- Cslib/Languages/CCS/BehaviouralTheory.lean | 5 +++-- .../Untyped/FullBetaConfluence.lean | 2 +- .../Untyped/StandardReduction.lean | 2 +- CslibTests/StatefulProcesses.lean | 2 +- lake-manifest.json | 22 +++++++++---------- lakefile.toml | 2 +- lean-toolchain | 2 +- 8 files changed, 23 insertions(+), 22 deletions(-) diff --git a/Cslib/Foundations/Semantics/LTS/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 89643fdff..1e28c9c9c 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -80,11 +80,11 @@ theorem saturate_τsTr_τSTr_iff [hHasTau : HasTau Label] (lts : LTS State Label apply Iff.intro <;> intro h case mp => induction h - case refl => constructor + case refl => exact .refl case tail _ _ _ h2 h3 => exact Relation.ReflTransGen.trans h3 ((sTr_τSTr_iff _).mp h2) case mpr => cases h - case refl => constructor + case refl => exact .refl case tail s' h2 h3 => have h4 := STr.tr h2 h3 Relation.ReflTransGen.refl exact Relation.ReflTransGen.single h4 @@ -121,13 +121,13 @@ theorem saturate_tr_saturate_sTr [hHasTau : HasTau Label] (lts : LTS State Label apply Iff.intro <;> intro h case mp => cases h - case refl => constructor + case refl => exact .refl case tr hstr1 htr hstr2 => apply STr.single exact STr.tr hstr1 htr hstr2 case mpr => cases h - case refl => constructor + case refl => exact .refl case tr hstr1 htr hstr2 => rw [saturate_τsTr_τSTr_iff lts] at hstr1 hstr2 rw [←sTr_τSTr_iff lts] at hstr1 hstr2 diff --git a/Cslib/Languages/CCS/BehaviouralTheory.lean b/Cslib/Languages/CCS/BehaviouralTheory.lean index f9684cddf..d14dcb165 100644 --- a/Cslib/Languages/CCS/BehaviouralTheory.lean +++ b/Cslib/Languages/CCS/BehaviouralTheory.lean @@ -193,7 +193,8 @@ open Bisimilarity in /-- P + Q ~ Q + P -/ theorem bisimilarity_choice_comm : (choice p q) ~[lts (defs := defs)] (choice q p) := by exists @ChoiceComm Name Constant defs - repeat constructor + constructor + · exact ChoiceComm.choiceComm intro s1 s2 hr μ cases hr case choiceComm p q => @@ -313,7 +314,7 @@ theorem bisimilarity_congr_choice : intro h exists @ChoiceBisim _ _ defs constructor - · constructor; assumption + · exact ChoiceBisim.choice h intro s1 s2 r μ constructor case left => diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean index 5e3187c3f..3a9a2d19b 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean @@ -91,7 +91,7 @@ lemma Parallel.le_reflTransGen_fullBeta : ((· ⭢ₚ ·) : Term Var → Term Var → Prop) ≤ (· ↠βᶠ ·) := by intro M N para induction para - case fvar => constructor + case fvar => exact .refl case app L L' R R' l_para m_para redex_l redex_m => have : L.app R ↠βᶠ L'.app R := by grind grind [ReflTransGen.trans] diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean index 628107821..85ade0802 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean @@ -65,7 +65,7 @@ lemma Standard.lc_l (step : M ⭢ₛ N) : LC M := by /-- Standard reduction is reflexive for locally closed terms. -/ lemma Standard.lc_refl (M : Term Var) (lc : LC M) : M ⭢ₛ M := by induction lc - all_goals constructor <;> assumption + all_goals constructor! <;> assumption /-- The right side of a standard reduction is locally closed. -/ lemma Standard.lc_r (step : M ⭢ₛ N) : LC N := by diff --git a/CslibTests/StatefulProcesses.lean b/CslibTests/StatefulProcesses.lean index 292a4cf79..f028381dc 100644 --- a/CslibTests/StatefulProcesses.lean +++ b/CslibTests/StatefulProcesses.lean @@ -63,7 +63,7 @@ def helloLts : LTS HelloCfg (Cfg.TrLabel String String String) := Cfg.lts string -- This is begging for more automation. example : helloLts.Tr helloCfg (.com "p" "q" "Hello") (Cfg.mk 0 (helloCfg.store[("q", "x") := "Hello"])) := by - apply Cfg.Tr.com (heval := by constructor) (hstore := rfl) + apply Cfg.Tr.com (heval := FunCallEval.EvalExpr.val) (hstore := rfl) apply Network.Tr.com (by constructor) (by constructor) ext p simp only [Pi.zero_apply, helloCfg, HasSubstitution.subst] diff --git a/lake-manifest.json b/lake-manifest.json index 2af0a16f3..2a2cf9a77 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "5ed2965256430c3649e86755f9576b54eca72435", + "rev": "c32e1ec0d1eb5237ba344eee50162f45d5b0fc76", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "v4.34.0", + "inputRev": "v4.35.0-rc1", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "118aa17ee84656b8bd727fef7c458ee8c833385c", + "rev": "16fe28ca7c2e01b71856f7a0a801ea844580f2d5", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "ddf04cf3949fa556442341e87d47f9f6e6074707", + "rev": "b43172c7f62b95ecd6daa0951602b83eb35182a1", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "e928b72544873815af278d38681b31c0293588e3", + "rev": "0b9118a4a6d4c752e51f4f731edc09f4cc135f4c", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "106ff4fafc74ef4ac99d81dbf3ab399118f497a5", + "rev": "af0c1665a9cdb1c90409b52a183113efbb5a4480", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "355695d523e41d0554926416cba2a2b3544fbbc9", + "rev": "7938bfd115516f80b260d43faf630c8520471a00", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "6a489d9af5d0c47e5b259e2e8bcdfc1811b5a259", + "rev": "21558817bf8b77bab8f4c3081e0062201fd974d2", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "f2effa3d803fda822b1f97b806c47cf2adfbcbc2", + "rev": "2a71587431553220d08be069a144b8215350e1d6", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "e92c9f15fdfacc8536f31cfb3b7ad26c3c8cd204", + "rev": "3c7ccd7060887fa478a55e555fae61bbf466c3ba", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.34.0", + "inputRev": "v4.35.0-rc1", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 289228147..f6b89ffd3 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "v4.34.0" +rev = "v4.35.0-rc1" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index 12359f928..3d1dc1d0f 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.34.0 +leanprover/lean4:v4.35.0-rc1 From 34a6570216f72a2bbebc80c32e6b9abda65edafd Mon Sep 17 00:00:00 2001 From: Jesse Alama Date: Wed, 16 Sep 2026 08:53:29 +0000 Subject: [PATCH 80/93] ci: add Dependabot config for actions and pip (#895) Add `.github/dependabot.yml` covering the two dependency sources CI actually has. Adding this will enable automatically created PRs if updates (checked weekly) are available, coming from two sources: - GitHub Actions - pip. Look only for minor and patch bumps. (Major versions are excluded, for now.) Related to #894, which introduces the requirements file the pip entry watches. But mechanically, either one can merge first. --- .github/dependabot.yml | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 .github/dependabot.yml diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 000000000..f8a3e493f --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,25 @@ +version: 2 +updates: + # Keep action pins fresh. Grouped so that all bumps land in a single weekly PR, + # which bounds the number of full Lean CI builds this triggers. + - package-ecosystem: github-actions + directory: / + schedule: + interval: weekly + groups: + actions: + patterns: ["*"] + commit-message: + prefix: ci + + # Python packages installed by workflows (see requirements.txt in this directory). + # Major bumps are left for a human to review. + - package-ecosystem: pip + directory: /.github + schedule: + interval: weekly + ignore: + - dependency-name: "*" + update-types: ["version-update:semver-major"] + commit-message: + prefix: ci From e9ebe0f3bf1d95380ea0a687e85e57ab5bca3e94 Mon Sep 17 00:00:00 2001 From: Jesse Alama Date: Wed, 16 Sep 2026 08:53:51 +0000 Subject: [PATCH 81/93] ci: pin zulip in a requirements file (#894) Replace the bare `pip install zulip` calls with a pinned `.github/requirements.txt`. This is pretty small on its own (effectively a no-op), but pinning a version increases reproducibility and helps track issues upstream, should they arise. This also gives Dependabot something to watch, once we've set that up. --- .github/requirements.txt | 1 + .github/workflows/report_failures_nightly-testing.yml | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 .github/requirements.txt diff --git a/.github/requirements.txt b/.github/requirements.txt new file mode 100644 index 000000000..d0dbe8356 --- /dev/null +++ b/.github/requirements.txt @@ -0,0 +1 @@ +zulip==0.9.1 diff --git a/.github/workflows/report_failures_nightly-testing.yml b/.github/workflows/report_failures_nightly-testing.yml index edeeb9168..03d827b6f 100644 --- a/.github/workflows/report_failures_nightly-testing.yml +++ b/.github/workflows/report_failures_nightly-testing.yml @@ -80,7 +80,7 @@ jobs: # Now post a success message to zulip, if the last message there is not a success message. # https://chat.openai.com/share/87656d2c-c804-4583-91aa-426d4f1537b3 - name: Install Zulip API client - run: pip install zulip + run: pip install -r .github/requirements.txt - name: Check last message and post if necessary env: @@ -270,7 +270,7 @@ jobs: SHA: ${{ env.SHA }} run: | echo "Installing zulip CLI..." - pip install zulip + pip install -r .github/requirements.txt echo "Configuring git identity for mathlib4-bot..." git config --global user.name "mathlib4-bot" git config --global user.email "github-mathlib4-bot@leanprover.zulipchat.com" From b55fc8661145dbeb571c6f341ba58728c487660d Mon Sep 17 00:00:00 2001 From: Jesse Alama Date: Wed, 16 Sep 2026 10:30:38 +0000 Subject: [PATCH 82/93] ci: lint workflow files with actionlint (#892) Adds a workflow that runs actionlint over the `.github/workflows` directory whenever those files change. actionlint checks expression types (used in the little GitHub Action DSL), undefined step/output references and needs/if conditions, and runs shellcheck over every `run:` shell block and [pyflakes](https://github.com/PyCQA/pyflakes) over `shell: python` chunks. To make sure that adding this workflow does not immediately break the build, I did a manual one-off run and found one thing, which is fixed here: an `echo | sed` pipeline that is now a parameter expansion. --- .github/workflows/actionlint.yml | 31 +++++++++++++++++++ .../bump_toolchain_nightly-testing.yml | 2 +- 2 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/actionlint.yml diff --git a/.github/workflows/actionlint.yml b/.github/workflows/actionlint.yml new file mode 100644 index 000000000..a8a3f0a06 --- /dev/null +++ b/.github/workflows/actionlint.yml @@ -0,0 +1,31 @@ +name: actionlint + +on: + push: + branches: + - main + paths: + - '.github/workflows/**' + pull_request: + paths: + - '.github/workflows/**' + workflow_dispatch: + +permissions: + contents: read + +jobs: + actionlint: + name: Lint workflow files + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@de0fac2e4500dabe0009e67214ff5f5447ce83dd # v6.0.2 + with: + sparse-checkout: | + .github/workflows + + # Also runs shellcheck over every `run:` block and pyflakes over + # `shell: python` steps. + - uses: raven-actions/actionlint@3d39aea434753780c3b3d4a1a31c854b4dbf49d7 # v2.2.0 + with: + version: 1.7.12 diff --git a/.github/workflows/bump_toolchain_nightly-testing.yml b/.github/workflows/bump_toolchain_nightly-testing.yml index 7bab15c8f..894c16636 100644 --- a/.github/workflows/bump_toolchain_nightly-testing.yml +++ b/.github/workflows/bump_toolchain_nightly-testing.yml @@ -45,7 +45,7 @@ jobs: GH_TOKEN: ${{ steps.app-token.outputs.token }} run: | # Extract date from RELEASE_TAG (format: nightly-YYYY-MM-DD) - DATE_PART=$(echo "$RELEASE_TAG" | sed 's/nightly-//') + DATE_PART="${RELEASE_TAG#nightly-}" NIGHTLY_TESTING_TAG="nightly-testing-${DATE_PART}" echo "NIGHTLY_TESTING_TAG=$NIGHTLY_TESTING_TAG" >> "${GITHUB_ENV}" From 012cc2f5dddcea6262fa9b6cb16e93b6e6db3e95 Mon Sep 17 00:00:00 2001 From: Jesse Alama Date: Wed, 16 Sep 2026 10:36:23 +0000 Subject: [PATCH 83/93] ci(nightly-testing): pass ZULIP_API_KEY through env instead of interpolating into script text (#889) Move the key into the step's `env:` block and reference it as a shell variable, matching how the step already receives its other values. --- .github/workflows/report_failures_nightly-testing.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/report_failures_nightly-testing.yml b/.github/workflows/report_failures_nightly-testing.yml index 03d827b6f..c5a58e012 100644 --- a/.github/workflows/report_failures_nightly-testing.yml +++ b/.github/workflows/report_failures_nightly-testing.yml @@ -268,6 +268,7 @@ jobs: BUMP_VERSION: ${{ steps.bump_version.outputs.result }} BUMP_BRANCH: ${{ steps.latest_bump_branch.outputs.result }} SHA: ${{ env.SHA }} + ZULIP_API_KEY: ${{ secrets.ZULIP_API_KEY }} run: | echo "Installing zulip CLI..." pip install -r .github/requirements.txt @@ -278,7 +279,7 @@ jobs: { echo "[api]" echo "email=github-mathlib4-bot@leanprover.zulipchat.com" - echo "key=${{ secrets.ZULIP_API_KEY }}" + echo "key=$ZULIP_API_KEY" echo "site=https://leanprover.zulipchat.com" } > ~/.zuliprc chmod 600 ~/.zuliprc From 0ef0424b53e9678a6d8fe914a1fea84509eca4ee Mon Sep 17 00:00:00 2001 From: Garmelon Date: Thu, 17 Sep 2026 15:28:27 +0000 Subject: [PATCH 84/93] chore: bump toolchain to v4.35.0-rc2 (#916) --- lake-manifest.json | 22 +++++++++++----------- lakefile.toml | 2 +- lean-toolchain | 2 +- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/lake-manifest.json b/lake-manifest.json index 2a2cf9a77..625b52fc3 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "c32e1ec0d1eb5237ba344eee50162f45d5b0fc76", + "rev": "065356127b1dc0016f66b7283ce0ce2c4055aa55", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "v4.35.0-rc1", + "inputRev": "v4.35.0-rc2", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "16fe28ca7c2e01b71856f7a0a801ea844580f2d5", + "rev": "e50948299c4dc4a4c21b1c34b6a6a4fddc19f912", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "b43172c7f62b95ecd6daa0951602b83eb35182a1", + "rev": "95e037bfdc31d3916ac615446847fb01960e2719", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "0b9118a4a6d4c752e51f4f731edc09f4cc135f4c", + "rev": "10930f8138f0462dbd744a91fc03a16fae0e046f", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "af0c1665a9cdb1c90409b52a183113efbb5a4480", + "rev": "4c70ac059693669e5756e32a7a94b57ee1e99dc5", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "7938bfd115516f80b260d43faf630c8520471a00", + "rev": "75d936c7af167cc93fac0d31237682fc2204591d", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "21558817bf8b77bab8f4c3081e0062201fd974d2", + "rev": "786b7acdca7eb4e9c76c5d1d5bd810e7e5c56334", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "2a71587431553220d08be069a144b8215350e1d6", + "rev": "ed9b316aabe389fec1ef43c3326ab48c7e59be42", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "3c7ccd7060887fa478a55e555fae61bbf466c3ba", + "rev": "2842b9871b04862f944c032e34052cb9448ccb71", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.35.0-rc1", + "inputRev": "v4.35.0-rc2", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index f6b89ffd3..f12bbee14 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "v4.35.0-rc1" +rev = "v4.35.0-rc2" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index 3d1dc1d0f..acc704ffe 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.35.0-rc1 +leanprover/lean4:v4.35.0-rc2 From 41094e5b1e871f5747c0d72582420558d2b03cb2 Mon Sep 17 00:00:00 2001 From: lyj Date: Fri, 18 Sep 2026 12:43:23 +0000 Subject: [PATCH 85/93] feat(Relation): Normal.sup_iff (#922) Prove that an element is normal for the supremum of two relations iff it is normal for each of them separately. Co-authored-by: Thomas Krishna Waring <51426330+thomaskwaring@users.noreply.github.com> --- Cslib/Foundations/Relation/Confluence.lean | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean index f76091cb6..02798537e 100644 --- a/Cslib/Foundations/Relation/Confluence.lean +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -321,4 +321,10 @@ theorem RightUnique.to_confluent (hr : Relator.RightUnique r) : Confluent r := b @[deprecated (since := "2026-09-03")] alias RightUnique.toConfluent := RightUnique.to_confluent +theorem Reducible.sup_iff (x : α) : Reducible (r₁ ⊔ r₂) x ↔ Reducible r₁ x ∨ Reducible r₂ x := + exists_or + +theorem Normal.sup_iff (x : α) : Normal (r₁ ⊔ r₂) x ↔ Normal r₁ x ∧ Normal r₂ x := + (not_iff_not.mpr <| Reducible.sup_iff x).trans not_or + end Relation From 17ff8552c21a28a5ac25204ead5b2668beae5a62 Mon Sep 17 00:00:00 2001 From: Christian Reitwiessner Date: Fri, 18 Sep 2026 16:26:02 +0000 Subject: [PATCH 86/93] feat(Automata): Two-way automata accept exactly the regular languages (#888) This implements Vardi's construction of a (one-way) finite automaton that accepts the complement of the language accepted by a two-way automaton. Together with closure of regular languages under complement and a simple mapping of one-way automata to two-way automata we get that two-way automata accept exactly the regular languages. AI disclosure: Claude was used throughout bit in a tight review loop. --- Cslib.lean | 2 + .../Automata/TwoWayNA/Basic.lean | 38 ++- .../Automata/TwoWayNA/ComplToNA.lean | 285 ++++++++++++++++++ .../Computability/Automata/TwoWayNA/OfNA.lean | 106 +++++++ .../Languages/RegularLanguage.lean | 19 ++ 5 files changed, 440 insertions(+), 10 deletions(-) create mode 100644 Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean create mode 100644 Cslib/Computability/Automata/TwoWayNA/OfNA.lean diff --git a/Cslib.lean b/Cslib.lean index 6c20dd086..428cfdab1 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -31,6 +31,8 @@ public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.NA.Total public import Cslib.Computability.Automata.Transducers.Transducer public import Cslib.Computability.Automata.TwoWayNA.Basic +public import Cslib.Computability.Automata.TwoWayNA.ComplToNA +public import Cslib.Computability.Automata.TwoWayNA.OfNA public import Cslib.Computability.Circuit.Basic public import Cslib.Computability.Circuit.Homomorphism public import Cslib.Computability.Circuit.Program diff --git a/Cslib/Computability/Automata/TwoWayNA/Basic.lean b/Cslib/Computability/Automata/TwoWayNA/Basic.lean index 4741a0c3f..edd70a119 100644 --- a/Cslib/Computability/Automata/TwoWayNA/Basic.lean +++ b/Cslib/Computability/Automata/TwoWayNA/Basic.lean @@ -27,7 +27,8 @@ ends in an accepting state with the head just past the end of the input. * `TwoWayNA`, the automaton itself * `TwoWayNACfg`, a configuration of a `TwoWayNA`: Its input plus a state and the head position. -* `TwoWayNA.Step`, The single-step relation between configurations. +* `TwoWayNA.toCfgNA`, the finite acceptor on configurations whose runs on a fixed input are + the runs of the two-way automaton on that input. It also provides the `Acceptor` instance. ## Implementation notes @@ -84,7 +85,7 @@ def TwoWayNACfg.IsAccepting (a : TwoWayNA State Symbol) (c : TwoWayNACfg State S /-- Returns a nondeterministic finite acceptor on the configurations as states, accepting exactly the runs of the two-way automaton on `input` that end in an accepting configuration. -/ -def TwoWayNA.toCfgNAFinAcc {State Symbol : Type*} (a : TwoWayNA State Symbol) +def TwoWayNA.toCfgNA {State Symbol : Type*} (a : TwoWayNA State Symbol) (input : List Symbol) : NA.FinAcc (TwoWayNACfg State Symbol) (Symbol × SignType) where Tr @@ -101,16 +102,33 @@ def TwoWayNA.toCfgNAFinAcc {State Symbol : Type*} (a : TwoWayNA State Symbol) start := { c | c.IsInitialForInput a input } accept := { c | c.IsAccepting a } -/-- Any reachable state of `a.toCfgNAFinAcc input` contains the original input. -/ -lemma TwoWayNA.toCfgNAFinAcc_input_eq {State Symbol : Type*} (a : TwoWayNA State Symbol) - (input : List Symbol) : - (a.toCfgNAFinAcc input).toLTS.TrInv (fun c => c.input = input) := by - intro c μ c' h_tr rfl - simp_all [TwoWayNA.toCfgNAFinAcc] - @[simp, scoped grind =] instance : Acceptor (TwoWayNA State Symbol) Symbol where Accepts (a : TwoWayNA State Symbol) (input : List Symbol) := - ∃ μs, Acceptor.Accepts (a.toCfgNAFinAcc input) μs + ∃ μs, Acceptor.Accepts (a.toCfgNA input) μs + +/-- Any reachable state of `a.toCfgNA input` contains the original input. -/ +lemma TwoWayNA.toCfgNA_input_eq {State Symbol : Type*} (a : TwoWayNA State Symbol) + (input : List Symbol) : + (a.toCfgNA input).TrInv (fun c => c.input = input) := by + intro c μ c' h_tr rfl + simp_all [TwoWayNA.toCfgNA] + +/-- A configuration running on `input` is the one determined by its state and head position. -/ +theorem TwoWayNACfg.eta {input : List Symbol} {c : TwoWayNACfg State Symbol} + (h : c.input = input) (h' : (c.pos : ℕ) < input.length + 1) : + ({ input := input, pos := ⟨c.pos, h'⟩, state := c.state } : TwoWayNACfg State Symbol) = c := by + cases c + subst h + rfl + +/-- A step reads the symbol at the head position, which therefore lies inside the input. -/ +theorem TwoWayNA.getElem_of_tr {a : TwoWayNA State Symbol} {input : List Symbol} + {c c' : TwoWayNACfg State Symbol} {x : Symbol} {m : SignType} + (htr : (a.toCfgNA input).Tr c (x, m) c') (hc : c.input = input) : + ∃ h : (c.pos : ℕ) < input.length, input[(c.pos : ℕ)] = x := by + obtain ⟨-, hx, -, -⟩ := htr + subst hc + exact List.getElem?_eq_some_iff.mp hx.symm end Cslib.Automata diff --git a/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean b/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean new file mode 100644 index 000000000..ae2932350 --- /dev/null +++ b/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean @@ -0,0 +1,285 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Automata.NA.Basic +public import Cslib.Computability.Automata.TwoWayNA.Basic +public import Cslib.Foundations.Data.OmegaSequence.Init +public import Cslib.Foundations.Semantics.LTS.Relation + +/-! # A finite acceptor for the complement of the language of a two-way automaton + +For every nondeterministic two-way automaton (`TwoWayNA`) `a`, this file constructs a +nondeterministic finite acceptor (`NA.FinAcc`) that accepts exactly the words rejected by `a` +(`TwoWayNA.complToNA`, `TwoWayNA.language_complToNA`). We follow Vardi's proof, which -- +unlike Shepherdson's crossing-sequence argument -- characterises non-acceptance in a way that can +be checked by a single left-to-right sweep over the input. + +This result is the main ingredient in proving equivalence of two-way and one-way automata, which +can be found in `Cslib.Computability.Languages.RegularLanguages`. + +## Vardi's condition of non-acceptance + +Fix a `TwoWayNA` `a` and an input word `input` of length `n`. A *rejection certificate* is a family +of subsets `cert i ⊆ State`, one for every head position `i ∈ {0, …, n}`, subject to three +conditions: + +1. `cert` contains every initial state at position `0` (`IsRejectionCert.start_mem`); +2. `cert` is an invariant of the transitions of `a`: if the state `c.state` is in `cert c.pos` and + `a` can step from the configuration `c` to the configuration `c'`, then `c'.state` is in + `cert c'.pos` (`TwoWayNA.IsStepClosed`, `IsRejectionCert.step_closed`); +3. no state in `cert n`, i.e. at the position just past the end of the input, is accepting + (`IsRejectionCert.accept_notMem`). + +Intuitively, `cert i` over-approximates the set of states in which `a` can be while its head sits at +position `i`: conditions 1 and 2 make `cert` an inductive invariant of the reachable configurations, +and condition 3 says that this invariant rules out acceptance -- being preserved by every step, it +holds at the end of every run (`LTS.mtrInv_of_trInv`). Conversely, the reachable states +(`TwoWayNA.reachable`) themselves form the least such family, so a certificate exists exactly when +`a` rejects (`TwoWayNA.not_accepts_iff_exists_isRejectionCert`). + +## The finite acceptor for the complement + +The point of the reformulation is locality: `TwoWayNA.isStepClosed_iff_localOK` turns condition 2 +into a condition `TwoWayNA.LocalOK` relating only `cert (i - 1)`, `cert i` and `cert (i + 1)` with +the symbol at position `i`. A finite acceptor can therefore guess the certificate while scanning the +input, keeping only the last two subsets in its state. This is `TwoWayNA.complToNA`, and +`TwoWayNA.accepts_complToNA_iff` shows that it accepts exactly the words rejected by `a`. + +## Implementation notes + +A rejection certificate is an `ωSequence`, i.e. indexed by `ℕ` rather than by +`Fin (input.length + 1)`, the type of `TwoWayNACfg.pos`: positions past the end of the input are +simply left unconstrained, which avoids casts when the certificate is compared along a run, whose +configurations carry their own input. The subset for the missing position to the left of the input +is supplied by prepending `Set.univ` with `ωSequence.cons`. + +`TwoWayNA.exists_accepting_mTr_iff` is proved by induction on the input word, prepending a subset +to the certificate at each step with `ωSequence.cons` and dropping one with `ωSequence.tail`. + +## References + +* [M. Y. Vardi, *A note on the reduction of two-way automata to one-way automata*][Vardi1989] +-/ + +@[expose] public section + +namespace Cslib.Automata + +open scoped ωSequence +open Acceptor + +variable {State Symbol : Type*} {a : TwoWayNA State Symbol} {input : List Symbol} + +namespace TwoWayNA + +/-! ## Vardi's condition of non-acceptance -/ + +/-- Every step of `a` on `input` out of a state that `cert` attaches to the head position lands in a +state that `cert` attaches to the new head position. The conjunct on the input restricts the +invariant to the configurations that run on `input`. -/ +def IsStepClosed (a : TwoWayNA State Symbol) (input : List Symbol) + (cert : ωSequence (Set State)) : Prop := + (a.toCfgNA input).TrInv (fun c => c.input = input ∧ c.state ∈ cert c.pos) + +/-- A family of subsets of the state set, one for every position of the input head on `input`, +which contains all initial states, is closed under the transitions of `a`, and contains no +accepting state at the position just past the end of the input. -/ +structure IsRejectionCert (a : TwoWayNA State Symbol) (input : List Symbol) + (cert : ωSequence (Set State)) : Prop where + /-- Every initial state occurs at the initial head position. -/ + start_mem : ∀ s ∈ a.start, s ∈ cert 0 + /-- The family is an invariant of the transitions of `a`. -/ + step_closed : a.IsStepClosed input cert + /-- No accepting state occurs past the end of the input. -/ + accept_notMem : ∀ s ∈ cert input.length, s ∉ a.accept + +variable {cert : ωSequence (Set State)} + +/-- If a rejection certificate for `input` exists, then `a` does not accept `input`. -/ +theorem IsRejectionCert.not_accepts (hT : a.IsRejectionCert input cert) : + ¬ Accepts a input := by + rintro ⟨μs, c, ⟨hstart, hpos, hinput⟩, c', ⟨hacc, hlast⟩, hmtr⟩ + obtain ⟨hinput', hmem⟩ := LTS.mtrInv_of_trInv hT.step_closed c μs c' hmtr + ⟨hinput, by simpa [hpos] using hT.start_mem c.state hstart⟩ + rw [hlast, Fin.val_last, hinput'] at hmem + exact hT.accept_notMem c'.state hmem hacc + +/-- The set of states that `a` can be in while its head sits at position `i` of `input`, having +started in an initial configuration. -/ +def reachable (a : TwoWayNA State Symbol) (input : List Symbol) : ωSequence (Set State) := + fun i => {q | ∃ c, c.IsInitialForInput a input ∧ + ∃ h : i < input.length + 1, + (a.toCfgNA input).CanReach c { input := input, pos := ⟨i, h⟩, state := q } } + +/-- If `a` does not accept `input`, then its reachable states form a rejection certificate. -/ +theorem isRejectionCert_reachable (h : ¬ Accepts a input) : + a.IsRejectionCert input (a.reachable input) where + start_mem s hs := + ⟨{ input := input, pos := ⟨0, Nat.succ_pos _⟩, state := s }, + ⟨hs, Fin.ext (by simp), rfl⟩, Nat.succ_pos _, LTS.CanReach.refl _ _⟩ + step_closed c μ c' htr := by + rintro ⟨hc_input, c₀, hstart, hlt, hreach⟩ + have hc'_input : c'.input = input := a.toCfgNA_input_eq input c μ c' htr hc_input + rw [TwoWayNACfg.eta hc_input hlt] at hreach + refine ⟨hc'_input, c₀, hstart, hc'_input ▸ c'.pos.isLt, ?_⟩ + rw [TwoWayNACfg.eta hc'_input] + exact (LTS.reflTransGen_unlabelledTr_iff _).mp + (((LTS.reflTransGen_unlabelledTr_iff _).mpr hreach).tail ⟨μ, htr⟩) + accept_notMem s hs hacc := by + obtain ⟨c₀, hstart, hlt, μs, hmtr⟩ := hs + exact h ⟨μs, c₀, hstart, _, ⟨hacc, Fin.ext (by simp)⟩, hmtr⟩ + +/-- A two-way automaton rejects an input exactly when a rejection certificate for it exists. -/ +theorem not_accepts_iff_exists_isRejectionCert (a : TwoWayNA State Symbol) + (input : List Symbol) : + ¬ Accepts a input ↔ ∃ T, a.IsRejectionCert input T := + ⟨fun h => ⟨_, isRejectionCert_reachable h⟩, by rintro ⟨_, hT⟩; exact hT.not_accepts⟩ + +/-! ## Localising the closure condition -/ + +/-- Every move of `a` out of a state in `cur` while reading `x` lands in `left`, in `cur` or in +`right`, according to whether it moves the head to the left, keeps it in place, or moves it to the +right. -/ +def LocalOK (a : TwoWayNA State Symbol) (x : Symbol) (left cur right : Set State) : Prop := + ∀ q ∈ cur, ∀ m q', a.Tr q x m q' → + q' ∈ match m with | .neg => left | .zero => cur | .pos => right + +/-- Closure of `cert` under the transitions of `a` is the same as local consistency of `cert` at +every position carrying an input symbol. -/ +theorem isStepClosed_iff_localOK : + a.IsStepClosed input cert ↔ + ∀ i : Fin input.length, + a.LocalOK input[i] ((Set.univ ::ω cert) i) (cert i) (cert (i + 1)) := by + constructor + · intro hcl i q hq m q' htr + have hlt : (i : ℕ) < input.length := i.isLt + cases m with + | zero => + exact (hcl ⟨input, q, ⟨i, by omega⟩⟩ (input[i], SignType.zero) + ⟨input, q', ⟨i, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + | pos => + exact (hcl ⟨input, q, ⟨i, by omega⟩⟩ (input[i], SignType.pos) + ⟨input, q', ⟨i + 1, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + | neg => + obtain ⟨iv, hiv⟩ := i + obtain _ | j := iv + · exact Set.mem_univ q' + · exact (hcl ⟨input, q, ⟨j + 1, by omega⟩⟩ (input[j + 1], SignType.neg) + ⟨input, q', ⟨j, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + · rintro hloc c ⟨x, m⟩ c' hstep ⟨hc_input, hmem⟩ + refine ⟨a.toCfgNA_input_eq input c (x, m) c' hstep hc_input, ?_⟩ + obtain ⟨hlt, rfl⟩ := getElem_of_tr hstep hc_input + obtain ⟨-, -, htr, hpos⟩ := hstep + have hthis := hloc ⟨(c.pos : ℕ), hlt⟩ c.state hmem m c'.state htr + cases m with + | zero => + have hpos' : (c'.pos : ℕ) = (c.pos : ℕ) := by simp at hpos; omega + rwa [hpos'] + | pos => + have hpos' : (c'.pos : ℕ) = (c.pos : ℕ) + 1 := by simp at hpos; omega + rwa [hpos'] + | neg => + simp only [SignType.neg_eq_neg_one, SignType.coe_neg_one] at hpos + obtain ⟨j, hj⟩ : ∃ j, (c.pos : ℕ) = j + 1 := ⟨(c.pos : ℕ) - 1, by omega⟩ + have hpos' : (c'.pos : ℕ) = j := by omega + rw [hpos'] + rwa [show ((⟨(c.pos : ℕ), hlt⟩ : Fin input.length) : ℕ) = j + 1 from hj] at hthis + +/-! ## The finite acceptor for the complement -/ + +/-- The nondeterministic finite acceptor that guesses a rejection certificate `cert` for `a` while +scanning the input, keeping the pair `(cert (i - 1), cert i)` in its state after reading `i` +symbols. +Reading the symbol at position `i` guesses `cert (i + 1)` and checks local consistency at `i`. -/ +def complToNA (a : TwoWayNA State Symbol) : NA.FinAcc (Set State × Set State) Symbol where + Tr + | (prev, cur), x, (prev', cur') => prev' = cur ∧ a.LocalOK x prev cur cur' + start := {(prev, cur) | prev = Set.univ ∧ a.start ⊆ cur} + accept := {(_, cur) | ∀ s ∈ cur, s ∉ a.accept} + +/-- An accepting multistep transition of `a.complToNA` out of `(left, cur)` over `xs` is the same +thing as a certificate starting with `left` and `cur` that is locally consistent at every position +of `xs` and has no accepting state at the position just past `xs`. -/ +theorem exists_accepting_mTr_iff (a : TwoWayNA State Symbol) (xs : List Symbol) + (left cur : Set State) : + (∃ f ∈ a.complToNA.accept, a.complToNA.MTr (left, cur) xs f) ↔ + ∃ cert : ωSequence (Set State), cert 0 = left ∧ cert 1 = cur ∧ + (∀ i, ∀ hi : i < xs.length, a.LocalOK xs[i] (cert i) (cert (i + 1)) (cert (i + 2))) ∧ + ∀ s ∈ cert (xs.length + 1), s ∉ a.accept := by + induction xs generalizing left cur with + | nil => + constructor + · rintro ⟨f, hf, hmtr⟩ + rw [LTS.MTr.nil_iff] at hmtr + subst hmtr + exact ⟨left ::ω ωSequence.const cur, rfl, rfl, by simp, by simpa [complToNA] using hf⟩ + · rintro ⟨cert, h0, h1, -, hacc⟩ + exact ⟨(left, cur), by simpa [complToNA, ← h1] using hacc, by simp⟩ + | cons x xs ih => + constructor + · rintro ⟨f, hf, hmtr⟩ + rw [LTS.MTr.cons_iff] at hmtr + obtain ⟨⟨m₁, m₂⟩, ⟨rfl, hlocal⟩, hmtr⟩ := hmtr + obtain ⟨cert, h0, h1, hloc, hacc⟩ := (ih m₁ m₂).mp ⟨f, hf, hmtr⟩ + have hstep : ∀ i, ∀ hi : i < (x :: xs).length, a.LocalOK (x :: xs)[i] + ((left ::ω cert) i) ((left ::ω cert) (i + 1)) ((left ::ω cert) (i + 2)) := by + intro i hi + obtain _ | i := i + · simpa [h0, h1] using hlocal + · simpa using hloc i (by simpa using hi) + exact ⟨left ::ω cert, rfl, by simpa using h0, hstep, by simpa using hacc⟩ + · rintro ⟨cert, h0, h1, hloc, hacc⟩ + have hstep : ∀ i, ∀ hi : i < xs.length, + a.LocalOK xs[i] (cert.tail i) (cert.tail (i + 1)) (cert.tail (i + 2)) := by + intro i hi + have h := hloc (i + 1) (by simpa using hi) + rw [List.getElem_cons_succ] at h + simpa [ωSequence.get_tail, Nat.add_right_comm] using h + obtain ⟨f, hf, hmtr⟩ := (ih cur (cert 2)).mpr + ⟨cert.tail, by simpa using h1, by simp [ωSequence.get_tail], hstep, by simpa using hacc⟩ + have hlocal : a.LocalOK x left cur (cert 2) := by + have h := hloc 0 (by simp) + rw [List.getElem_cons_zero] at h + simpa [h0, h1] using h + exact ⟨f, hf, LTS.MTr.cons_iff.mpr ⟨(cur, cert 2), ⟨rfl, hlocal⟩, hmtr⟩⟩ + +/-- `a.complToNA` accepts exactly the words that `a` rejects. -/ +theorem accepts_complToNA_iff (a : TwoWayNA State Symbol) (input : List Symbol) : + Accepts a.complToNA input ↔ ¬ Accepts a input := by + rw [not_accepts_iff_exists_isRejectionCert] + constructor + · rintro ⟨s, ⟨hs, hstart⟩, f, hf, hmtr⟩ + obtain ⟨cert, h0, h1, hloc, hacc⟩ := (exists_accepting_mTr_iff a input s.1 s.2).mp ⟨f, hf, hmtr⟩ + have hcert : Set.univ ::ω cert.tail = cert := by + rw [← hs, ← h0] + exact ωSequence.eta cert + have hstep : ∀ i : Fin input.length, + a.LocalOK input[i] ((Set.univ ::ω cert.tail) i) (cert.tail i) (cert.tail (i + 1)) := + fun i => by simpa [hcert, ωSequence.get_tail] using hloc i i.isLt + exact ⟨cert.tail, + { start_mem := by + intro q hq + simpa [h1] using hstart hq + step_closed := isStepClosed_iff_localOK.mpr hstep + accept_notMem := by simpa using hacc }⟩ + · rintro ⟨cert, hCert⟩ + have hloc := isStepClosed_iff_localOK.mp hCert.step_closed + obtain ⟨f, hf, hmtr⟩ := (exists_accepting_mTr_iff a input Set.univ (cert 0)).mpr + ⟨Set.univ ::ω cert, rfl, rfl, fun i hi => by simpa using hloc ⟨i, hi⟩, + by simpa using hCert.accept_notMem⟩ + exact ⟨(Set.univ, cert 0), ⟨rfl, hCert.start_mem⟩, f, hf, hmtr⟩ + +/-- `a.complToNA` recognises the complement of the language of `a`. -/ +theorem language_complToNA (a : TwoWayNA State Symbol) : language a.complToNA = (language a)ᶜ := by + ext xs + simp only [Acceptor.mem_language] + exact accepts_complToNA_iff a xs + +end TwoWayNA + +end Cslib.Automata diff --git a/Cslib/Computability/Automata/TwoWayNA/OfNA.lean b/Cslib/Computability/Automata/TwoWayNA/OfNA.lean new file mode 100644 index 000000000..5a556b013 --- /dev/null +++ b/Cslib/Computability/Automata/TwoWayNA/OfNA.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Automata.TwoWayNA.Basic + +/-! # Finite acceptors as two-way automata + +A nondeterministic finite acceptor (`NA.FinAcc`) is the special case of a nondeterministic two-way +automaton (`TwoWayNA`) that moves its head one symbol to the right in every step, +`NA.FinAcc.toTwoWayNA`. + +The head of `a.toTwoWayNA` is thus at position `i` exactly when `a` has read the first `i` +symbols of the input, so the runs of the two-way automaton are in lockstep with the multistep +transitions of `a` (`TwoWayNA.mTr_take_of_mTr_toCfgNA`, `TwoWayNA.mTr_toCfgNA_of_mTr`) and the two +accept the same words (`TwoWayNA.accepts_toTwoWayNA_iff`, `TwoWayNA.language_toTwoWayNA`). +-/ + +@[expose] public section + +namespace Cslib.Automata + +variable {State Symbol : Type*} {input : List Symbol} + +/-- The two-way automaton that performs the transitions of the nondeterministic finite acceptor +`n`, always moving its head one symbol to the right. -/ +def NA.FinAcc.toTwoWayNA (n : NA.FinAcc State Symbol) : TwoWayNA State Symbol where + Tr q x m q' := m = SignType.pos ∧ n.Tr q x q' + start := n.start + accept := n.accept + +namespace TwoWayNA + +variable {a : NA.FinAcc State Symbol} + +/-- A run of `a.toTwoWayNA` that starts in an initial configuration reads a multistep transition +of `a` over the prefix of `input` that its head has scanned. -/ +theorem mTr_take_of_mTr_toCfgNA {c c' : TwoWayNACfg State Symbol} + {μs : List (Symbol × SignType)} + (hstart : c ∈ (a.toTwoWayNA.toCfgNA input).start) + (hrun : (a.toTwoWayNA.toCfgNA input).MTr c μs c') : + a.MTr c.state (input.take c'.pos) c'.state := by + obtain ⟨-, hpos, rfl⟩ := hstart + refine (LTS.mtrInv_of_trInv + (p := fun d => d.input = c.input ∧ a.MTr c.state (c.input.take d.pos) d.state) ?_ c μs c' hrun + ⟨rfl, by simp [hpos]⟩).2 + rintro d ⟨x, m⟩ d' hstep ⟨hd, hmtr⟩ + obtain ⟨hlt, rfl⟩ := getElem_of_tr (input := c.input) hstep hd + obtain ⟨hinput, -, ⟨rfl, htr⟩, hpos⟩ := hstep + have hpos' : (d'.pos : ℕ) = (d.pos : ℕ) + 1 := by simp at hpos; omega + refine ⟨hinput ▸ hd, ?_⟩ + rw [hpos', List.take_succ_eq_append_getElem hlt] + exact LTS.MTr.stepR _ hmtr htr + +/-- A multistep transition of `a` over a prefix of `input` is read by the run of `a.toTwoWayNA` +that takes its head from the beginning of the input to the end of that prefix, moving one symbol +to the right in every step. -/ +theorem mTr_toCfgNA_of_mTr {s s' : State} {pre : List Symbol} (hpre : pre <+: input) + (hmtr : a.MTr s pre s') : + (a.toTwoWayNA.toCfgNA input).MTr ⟨input, s, 0⟩ (pre.map (·, SignType.pos)) + ⟨input, s', ⟨pre.length, by grind⟩⟩ := by + induction pre using List.reverseRecOn generalizing s' with + | nil => simp_all + | append_singleton pre x ih => + rw [LTS.MTr.append_iff] at hmtr + obtain ⟨t, hmtr, htr⟩ := hmtr + rw [LTS.MTr.singleton_iff] at htr + have hlt : pre.length < input.length := by grind + have hx : input[pre.length] = x := by + rw [← hpre.getElem (by simp)] + simp + have hstep : (a.toTwoWayNA.toCfgNA input).Tr + ⟨input, t, ⟨pre.length, by omega⟩⟩ (x, SignType.pos) + ⟨input, s', ⟨(pre ++ [x]).length, by simpa using hlt⟩⟩ := + ⟨rfl, by simp [← hx], ⟨rfl, htr⟩, by simp⟩ + rw [List.map_append] + exact LTS.MTr.stepR _ (ih ((List.prefix_append _ _).trans hpre) hmtr) hstep + +open Acceptor + +/-- A nondeterministic finite acceptor and its two-way rendering accept the same words. -/ +theorem accepts_toTwoWayNA_iff (a : NA.FinAcc State Symbol) (input : List Symbol) : + Accepts a.toTwoWayNA input ↔ Accepts a input := by + constructor + · rintro ⟨μs, c, ⟨hs, hpos, hinput⟩, c', ⟨hacc, hlast⟩, hmtr⟩ + subst hinput + have hinput' := LTS.mtrInv_of_trInv (toCfgNA_input_eq _ _) c μs c' hmtr rfl + have hmtr := mTr_take_of_mTr_toCfgNA ⟨hs, hpos, rfl⟩ hmtr + rw [hlast, Fin.val_last, hinput', List.take_length] at hmtr + exact ⟨c.state, hs, c'.state, hacc, hmtr⟩ + · rintro ⟨s, hs, s', hs', hmtr⟩ + exact ⟨_, ⟨input, s, 0⟩, ⟨hs, rfl, rfl⟩, ⟨input, s', Fin.last _⟩, ⟨hs', rfl⟩, + mTr_toCfgNA_of_mTr (List.prefix_refl _) hmtr⟩ + +/-- A nondeterministic finite acceptor and its two-way rendering recognise the same language. -/ +theorem language_toTwoWayNA (a : NA.FinAcc State Symbol) : language a.toTwoWayNA = language a := by + ext xs + simpa [Acceptor.mem_language] using accepts_toTwoWayNA_iff a xs + +end TwoWayNA + +end Cslib.Automata diff --git a/Cslib/Computability/Languages/RegularLanguage.lean b/Cslib/Computability/Languages/RegularLanguage.lean index ae70a9fee..f14436718 100644 --- a/Cslib/Computability/Languages/RegularLanguage.lean +++ b/Cslib/Computability/Languages/RegularLanguage.lean @@ -14,6 +14,8 @@ public import Cslib.Computability.Automata.DA.Prod public import Cslib.Computability.Automata.NA.Reverse public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.DA.ToNA +public import Cslib.Computability.Automata.TwoWayNA.OfNA +public import Cslib.Computability.Automata.TwoWayNA.ComplToNA public import Mathlib.Computability.DFA public import Mathlib.Computability.RegularExpressions public import Mathlib.Basic.Finite.Sum @@ -70,6 +72,23 @@ theorem IsRegular.compl {l : Language Symbol} (h : l.IsRegular) : (lᶜ).IsRegul simp only [language, Accepts] rfl +/-- A language is regular if and only if it is accepted by some two-way nondeterministic +automaton with finitely many states. -/ +theorem IsRegular.iff_twoWayNA {l : Language Symbol} : + l.IsRegular ↔ ∃ State : Type, ∃ _ : Finite State, + ∃ a : TwoWayNA State Symbol, language a = l := by + constructor + · intro h + rw [IsRegular.iff_nfa] at h + obtain ⟨State, hfin, na, rfl⟩ := h + exact ⟨State, hfin, NA.FinAcc.toTwoWayNA na, TwoWayNA.language_toTwoWayNA na⟩ + · rintro ⟨State, hfin, a, rfl⟩ + have := hfin + have hc : (language a)ᶜ.IsRegular := by + rw [IsRegular.iff_nfa] + exact ⟨Set State × Set State, inferInstance, a.complToNA, a.language_complToNA⟩ + simpa using hc.compl + /-- The empty language is regular. -/ @[simp] theorem IsRegular.zero : (0 : Language Symbol).IsRegular := by From 758c2c5f2e217ae3b3a36219b5f73ff123c79fd7 Mon Sep 17 00:00:00 2001 From: Christian Reitwiessner Date: Fri, 18 Sep 2026 16:26:26 +0000 Subject: [PATCH 87/93] feat(MultiTapeTM): TransformsTapes interface and sequential composition (#897) Introduce an abstraction over Turing machines that normalizes head positions and uses `List Symbol` for tape contents with a Hoare-style interface. This abstraction will be used by control-flow combinators to be introduced later. Here are the most important definitions and results: * `Plumbing/TransformsTapes.lean`: `tapeOfList` (a tape holding exactly a word), `wordsCfg` (a configuration whose tapes hold given words), `TransformsTapes` (started on word-holding tapes, halt in the normal form `wordsCfg input none ws' out` with the new words related to the old by a postcondition, within given time/space), its `.imp` weakening, and `exists_transformsTapes_nop` as the inhabiting example. * `Plumbing/Sequential.lean`: `transformsTapes_seq`, running one transformer then another. The halting configuration of the first is a valid starting configuration for the second, so the two chain by rewriting with the normal-form equality. * `TapeLemmas.lean`: add the visited-set / space-usage lemmas the interface needs (`visitedByTapeHead_add`, `spaceUsed_add_le`, `spaceUsed_eq_of_workTapePos`, `exists_visitedByTapeHead_eq_Icc`, `spaceUsed_le_of_one_moving`, ...). * `Configuration.lean`: add the state-remap embeddings `Cfg.mapState` and `Cfg.withState`, used to place a sub-machine's configurations into a larger one. * `Deterministic.lean`: add `runFrom_eq_of_halt` and `exists_minimal_halting_time`. AI disclosure: Claude code was heavily used in a tight review loop. --------- Co-authored-by: Claude Opus 4.8 --- Cslib.lean | 2 + .../Turing/MultiTape/Configuration.lean | 12 ++ .../Turing/MultiTape/Deterministic.lean | 20 ++ .../Turing/MultiTape/Plumbing/Sequential.lean | 176 +++++++++++++++++ .../MultiTape/Plumbing/TransformsTapes.lean | 178 ++++++++++++++++++ .../Machines/Turing/MultiTape/TapeLemmas.lean | 85 +++++++++ 6 files changed, 473 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean diff --git a/Cslib.lean b/Cslib.lean index 428cfdab1..e43365640 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -62,6 +62,8 @@ 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.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas public import Cslib.Computability.Machines.Turing.SingleTape.Defs public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 78237a5b5..a366358b5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -156,6 +156,18 @@ def Cfg.workTapeSymbols (cfg : Cfg k Symbol State input) (i : Fin k) : Option Sy /-- A configuration is halted when it has no state to continue from. -/ abbrev Cfg.Halted (cfg : Cfg k Symbol State input) : Prop := cfg.state = none +/-- The same configuration in a different control state, possibly of a different state type. -/ +@[simps] def Cfg.withState (cfg : Cfg k Symbol State input) + {State' : Type*} (q : Option State') : Cfg k Symbol State' input := + ⟨q, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + +/-- Remap the (optional) state of a configuration through `φ`, leaving the input head, the work +tapes, the work-tape heads and the output alone. This is the shape of embedding used to place a +sub-machine's configurations into a larger machine built from it. -/ +@[simps] def Cfg.mapState {State' : Type*} (φ : Option State → Option State') + (c : Cfg k Symbol State input) : Cfg k Symbol State' input := + ⟨φ c.state, c.inputPos, c.workTapes, c.workTapePos, c.output⟩ + /-- The initial configuration for a starting state and an input string. -/ @[simp] def Cfg.init (q₀ : State) (input : List Symbol) : Cfg k Symbol State input := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 602953c79..a587e2771 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -191,6 +191,26 @@ 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 +/-- Nothing changes after the machine has halted. -/ +lemma runFrom_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 = tm.runFrom cfg τ := by + conv_lhs => rw [← Nat.sub_add_cancel hle, Nat.add_comm] + rw [runFrom_add, runFrom_of_halt _ hhalt] + +/-- Every halted run has a first halting time no later than the supplied one. -/ +lemma exists_minimal_halting_time + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) + (hhalt : (tm.runFrom cfg t).state = none) : + ∃ u ≤ t, (tm.runFrom cfg u).state = none ∧ ∀ s < u, (tm.runFrom cfg s).state ≠ none := by + classical + have hex : ∃ n, (tm.runFrom cfg n).state = none := ⟨t, hhalt⟩ + exact ⟨Nat.find hex, Nat.find_min' hex hhalt, Nat.find_spec hex, + fun s hs => Nat.find_min hex hs⟩ + @[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/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean new file mode 100644 index 000000000..d5370bda1 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Sequential composition of machines on shared tapes + +`seq tm₀ tm₁` behaves like `tm₀` until `tm₀` would halt, at which point it continues as `tm₁`, +started in its initial state on the tapes as `tm₀` left them. The state space is +`State₀ ⊕ State₁`, and the *halting transition* of the first phase is mapped to the initial state +of the second, so the handoff costs no extra step. + +At the specification level this is `transformsTapes_seq`: transformations compose, with the time +and space bounds adding. The postcondition of `TransformsTapes` is what makes the proof direct: +the first machine halts in a full `wordsCfg`, which is exactly a starting configuration for the +second. + +## Main results + +* `Turing.MultiTapeTM.seq`: the composed machine. +* `Turing.MultiTapeTM.transformsTapes_seq`: transformations compose, bounds adding. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State₀ State₁ : Type*} {input : List Symbol} + +/-- The sequential composition of `tm₀` and `tm₁`: it behaves like `tm₀` until `tm₀` would halt, +at which point it switches to the initial state of `tm₁` and behaves like `tm₁`. The switch is +folded into the halting transition of `tm₀`, so it costs no step. -/ +def seq (tm₀ : MultiTapeTM k Symbol State₀) (tm₁ : MultiTapeTM k Symbol State₁) : + MultiTapeTM k Symbol (State₀ ⊕ State₁) where + q₀ := .inl tm₀.q₀ + tr q inp work := + match q with + | .inl q₀ => + let a := tm₀.tr q₀ inp work + { a with state := some (a.state.elim (.inr tm₁.q₀) .inl) } + | .inr q₁ => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map .inr } + +variable {tm₀ : MultiTapeTM k Symbol State₀} {tm₁ : MultiTapeTM k Symbol State₁} + +namespace Sequential + +/-- A configuration of the first phase: a configuration of `tm₀`, with a halted state mapped to +the initial state of the second phase. Under this map, the whole first phase of `seq` mirrors the +run of `tm₀`, *including* its halting step. -/ +def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := + cfg.mapState (fun st => some (st.elim (.inr tm₁.q₀) .inl)) + +/-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the +run of `tm₁`. -/ +def rightCfg (cfg : Cfg k Symbol State₁ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := + cfg.mapState (Option.map .inr) + +lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : + (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h + have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by + simp [leftCfg, Cfg.mapState, hq] + simp only [step, h1, hq] + rfl + +lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : + (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + have h1 : (rightCfg (State₀ := State₀) cfg).state = none := by simp [rightCfg, Cfg.mapState, hq] + simp only [step, h1, hq] + | some q => + have h1 : (rightCfg (State₀ := State₀) cfg).state = some (Sum.inr q : State₀ ⊕ State₁) := by + simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +/-- The second phase of `seq` mirrors the run of `tm₁`. -/ +lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : + (tm₀.seq tm₁).runFrom (rightCfg cfg) n = rightCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-- While `tm₀` is running, `seq` mirrors it. -/ +lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) + (h : ∀ m < n, (tm₀.runFrom cfg m).state ≠ none) : + (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) n = leftCfg tm₁ (tm₀.runFrom cfg n) := by + induction n with + | zero => rfl + | succ n ih => + rw [runFrom_succ_eq_step', runFrom_succ_eq_step', ih fun m hm => h m (by omega), + step_leftCfg _ (h n (by omega))] + +@[simp] +lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : + (leftCfg tm₁ cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : + (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl + +end Sequential + +open Sequential in +/-- **Sequential composition of transformations.** If the postcondition of the first +transformation implies the precondition of the second, the composed machine performs the two +transformations one after the other, with the time and space bounds adding. -/ +theorem transformsTapes_seq + {P₀ P₁ : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q₀ Q₁ : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t₀ s₀ t₁ s₁ : ℕ} + (h₀ : TransformsTapes tm₀ P₀ Q₀ t₀ s₀) (h₁ : TransformsTapes tm₁ P₁ Q₁ t₁ s₁) + (hmid : ∀ input ws ws', P₀ input ws → Q₀ input ws ws' → P₁ input ws') : + TransformsTapes (tm₀.seq tm₁) P₀ + (fun input ws ws'' => ∃ ws', Q₀ input ws ws' ∧ Q₁ input ws' ws'') + (t₀ + t₁) (s₀ + s₁) := by + intro input ws out hP₀ + obtain ⟨ws', hrun₀, hQ₀, hspace₀⟩ := h₀ input ws out hP₀ + obtain ⟨ws'', hrun₁, hQ₁, hspace₁⟩ := h₁ input ws' out (hmid input ws ws' hP₀ hQ₀) + -- the first halting time of the first machine, which may be earlier than `t₀` + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm₀ + (wordsCfg input (some tm₀.q₀) ws out) t₀ (by simp [hrun₀]) + have hu_run : tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) u = + wordsCfg input none ws' out := by + rw [← runFrom_eq_of_halt tm₀ _ hu huhalt, hrun₀] + -- the first phase mirrors the first machine, ending in the handoff configuration + have hleft : ∀ m ≤ u, (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) m + = leftCfg tm₁ (tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) m) := by + intro m hm + have : wordsCfg (State := State₀ ⊕ State₁) input (some (tm₀.seq tm₁).q₀) ws out = + leftCfg tm₁ (wordsCfg input (some tm₀.q₀) ws out) := rfl + rw [this, runFrom_leftCfg _ m fun r hr => + huactive r (by omega)] + -- the handoff configuration is the second machine's start, seen through the right embedding + have hhandoff : (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) u = + rightCfg (wordsCfg input (some tm₁.q₀) ws' out) := by + rw [hleft u le_rfl, hu_run] + rfl + -- the second phase mirrors the second machine + have hright : ∀ n, (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) (u + n) + = rightCfg (tm₁.runFrom (wordsCfg input (some tm₁.q₀) ws' out) n) := by + intro n + rw [runFrom_add, hhandoff, runFrom_rightCfg] + -- the composition is done after `u + t₁` steps and then simply stays put until `t₀ + t₁` + have hrun : (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) (u + t₁) + = wordsCfg input none ws'' out := by + rw [hright t₁, hrun₁] + rfl + have hhalt : ((tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) + (u + t₁)).state = none := by + rw [hrun] + rfl + have hle : u + t₁ ≤ t₀ + t₁ := by omega + refine ⟨ws'', ?_, ⟨ws', hQ₀, hQ₁⟩, ?_⟩ + · rw [runFrom_eq_of_halt _ _ hle hhalt, hrun] + · rw [spaceUsed_eq_of_halt _ hle hhalt] + refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · -- the first phase visits what the first machine visits + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u fun m hm => ?_)) + (le_trans (spaceUsed_mono tm₀ _ hu) hspace₀) + rw [hleft m hm, workTapePos_leftCfg] + · -- the second phase visits what the second machine visits + rw [hhandoff] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ t₁ fun m hm => ?_)) hspace₁ + rw [runFrom_rightCfg, workTapePos_rightCfg] + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean new file mode 100644 index 000000000..cb018275a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Machines as transformers of tape words + +The interface through which combinators use machines: a machine reads words from its work tapes +and leaves words on them. A combinator composing such machines talks about words only, never about +individual cells, head positions or the set of tapes a machine has touched. + +Configurations are described by *equalities*: `wordsCfg input q ws out` is the configuration whose +work tape `i` holds exactly the word `ws i` (contents `tapeOfList (ws i)`, head at the start), with +the input head at the start of the input and output `out`. A specification +`TransformsTapes tm P Q t s` says: started on word-holding tapes satisfying `P`, after exactly `t` +steps the machine sits in the halted *normal form* `wordsCfg input none ws' out` (every head reset +to its initial position, tapes blank outside their words, output untouched), with the new words +related to the old ones by `Q` and using at most `s` work-tape cells. The machine may halt earlier +than `t`; since a halted machine stays put and stops visiting new cells, running on to `t` costs +nothing, so a fixed step count loses no generality and spares every composition an existential. +Requiring this normal form is what lets specifications compose by rewriting: the halting +configuration of one machine is already a valid start for the next, so which words survived a step +is read off the equation, not re-established cell by cell. + +## Main definitions + +* `Turing.MultiTapeTM.tapeOfList`: the tape holding exactly a given word. +* `Turing.MultiTapeTM.wordsCfg`: the configuration whose tapes hold given words. +* `Turing.MultiTapeTM.TransformsTapes`: the specification format described above. +* `Turing.MultiTapeTM.nop`: the machine that does nothing. + +## Main results + +* `Turing.MultiTapeTM.TransformsTapes.imp`: strengthen the precondition, weaken the postcondition + and raise the bounds. +* `Turing.MultiTapeTM.transformsTapes_nop`: `nop` leaves every word as it was, the first machine of + the interface and the check that the format is inhabited as intended. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- A tape containing exactly the symbols of `xs` at positions `0, ..., xs.length - 1`. -/ +def tapeOfList (xs : List Symbol) : ℤ → Option Symbol + | .ofNat n => xs[n]? + | .negSucc _ => none + +@[simp] +lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl + +@[simp] +lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : + tapeOfList xs (.negSucc n) = none := rfl + +/-- Appending one symbol writes precisely the cell after the existing word. -/ +lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : + tapeOfList (xs ++ [x]) = Function.update (tapeOfList xs) (xs.length : ℤ) (some x) := by + funext z + cases z with + | negSucc n => simp [tapeOfList] + | ofNat n => grind [tapeOfList] + +/-- The blank tape holds the empty word. -/ +@[simp] +lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := by + funext z + cases z <;> simp + +/-- The cell at position `0` holds the first symbol of the word. -/ +lemma tapeOfList_zero (xs : List Symbol) : tapeOfList xs 0 = xs.head? := by + have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl + rw [h, tapeOfList_ofNat] + cases xs <;> rfl + +/-- The configuration whose work tape `i` holds exactly the word `ws i` with its head at the +start, whose input head is at the start of the input, in state `q` with output `out`. -/ +@[simps] +def wordsCfg (input : List Symbol) (q : Option State) + (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := + ⟨q, 1, fun i => tapeOfList (ws i), fun _ => 0, out⟩ + +/-- Remapping the state of a `wordsCfg` remaps its state and leaves the words alone. -/ +@[simp] +lemma mapState_wordsCfg {State' : Type*} (φ : Option State → Option State') + (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : + (wordsCfg input q ws out).mapState φ = wordsCfg input (φ q) ws out := rfl + +/-- The initial configuration is the word configuration with blank tapes and no output. -/ +lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : + tm.initCfg input = wordsCfg input (some tm.q₀) (fun _ => []) [] := by + refine Cfg.ext rfl rfl ?_ rfl rfl + funext i + simp [Cfg.init, wordsCfg] + +/-- `TransformsTapes tm P Q t s`: started in its initial state on tapes holding words `ws` that +satisfy the precondition `P`, the machine is halted after exactly `t` steps in the configuration +whose tapes hold words `ws'` with `Q input ws ws'`, having used at most `s` work-tape cells. The +machine is free to halt before step `t`, because it then stays in that configuration. + +The bounds are numbers; a specification whose bounds depend on the data is a *family* +`∀ j, TransformsTapes tm (P j) (Q j) (t j) (s j)` over one fixed machine. -/ +def TransformsTapes (tm : MultiTapeTM k Symbol State) + (P : (input : List Symbol) → (Fin k → List Symbol) → Prop) + (Q : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop) + (t s : ℕ) : Prop := + ∀ (input : List Symbol) (ws : Fin k → List Symbol) (out : List Symbol), P input ws → + ∃ ws', + tm.runFrom (wordsCfg input (some tm.q₀) ws out) t = wordsCfg input none ws' out ∧ + Q input ws ws' ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) t ≤ s + +/-- A `TransformsTapes` statement can be read with a stronger precondition, a weaker postcondition +and larger bounds. -/ +theorem TransformsTapes.imp {tm : MultiTapeTM k Symbol State} + {P P' : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q Q' : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t s t' s' : ℕ} (h : TransformsTapes tm P Q t s) + (hP : ∀ input ws, P' input ws → P input ws) + (hQ : ∀ input ws ws', P' input ws → Q input ws ws' → Q' input ws ws') + (ht : t ≤ t') (hs : s ≤ s') : + TransformsTapes tm P' Q' t' s' := by + intro input ws out hP' + obtain ⟨ws', hrun, hQ'', hspace⟩ := h input ws out (hP input ws hP') + -- the machine is halted at step `t`, so running on to `t'` changes neither tapes nor space + have hhalt : (tm.runFrom (wordsCfg input (some tm.q₀) ws out) t).state = none := by + rw [hrun] + rfl + refine ⟨ws', ?_, hQ input ws ws' hP' hQ'', ?_⟩ + · rw [runFrom_eq_of_halt tm _ ht hhalt, hrun] + · rw [spaceUsed_eq_of_halt _ ht hhalt] + exact hspace.trans hs + +section Nop + +/-- The machine that does nothing: it halts on its first step, leaving the configuration +unchanged. -/ +def nop (k : ℕ) (Symbol : Type*) : MultiTapeTM k Symbol Unit where + q₀ := () + tr _ _ _ := { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + +/-- A single step of `nop` halts and leaves the words alone. -/ +@[simp] +lemma step_nop (ws : Fin k → List Symbol) (out : List Symbol) : + (nop k Symbol).step (wordsCfg input (some ()) ws out) = wordsCfg input none ws out := by + refine Cfg.ext rfl ?_ ?_ ?_ ?_ <;> + simp [step, nop, Action.apply, wordsCfg, SignType.cast] + +/-- `nop` reaches its halting configuration after exactly one step. -/ +@[simp] +lemma runFrom_nop_one (ws : Fin k → List Symbol) (out : List Symbol) : + (nop k Symbol).runFrom (wordsCfg input (some ()) ws out) 1 = wordsCfg input none ws out := by + rw [runFrom_succ_eq_step', runFrom_zero, step_nop] + +/-- **The machine that does nothing** halts in one step, leaving every word as it was. Its heads +never move, so it visits one cell per tape. This is the first machine of the interface: it checks +that the specification format is inhabited exactly as intended. -/ +theorem transformsTapes_nop (k : ℕ) (Symbol : Type*) : + TransformsTapes (nop k Symbol) (fun _ _ => True) (fun _ ws ws' => ws' = ws) 1 k := by + intro input ws out _ + -- the heads never move, so each tape touches only the single cell `0` + refine ⟨ws, runFrom_nop_one ws out, rfl, + spaceUsed_le_of_workTapePos_const _ 1 fun m hm => ?_⟩ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [runFrom_nop_one]; funext i; simp only [wordsCfg_workTapePos] + +end Nop + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index fcf67a3d0..e3db9a32c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -171,4 +171,89 @@ 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)))⟩ + +/-- Every position the head takes up to step `t` lies in `S`, so the whole visited set does. This +is `Finset.image_subset_iff` for the visited set, and the workhorse behind the space bounds +below. -/ +lemma visitedByTapeHead_subset (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} {S : Finset ℤ} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i ∈ S) : + tm.visitedByTapeHead cfg t i ⊆ S := + Finset.image_subset_iff.mpr fun m hm => h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm)) + +/-- A set containing every position of a head bounds the space used by its tape. -/ +lemma spaceUsedByTape_le_card (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} {S : Finset ℤ} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i ∈ S) : + tm.spaceUsedByTape cfg t i ≤ S.card := + Finset.card_le_card (tm.visitedByTapeHead_subset cfg h) + +/-- A head that never moves uses a single cell. -/ +lemma spaceUsedByTape_le_one (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i = cfg.workTapePos i) : + tm.spaceUsedByTape cfg t i ≤ 1 := by + simpa using tm.spaceUsedByTape_le_card cfg (S := {cfg.workTapePos i}) + fun m hm => by simp [h m hm] + +/-- The cells a run visits are the ones visited by its two halves. -/ +lemma visitedByTapeHead_add (cfg : Cfg k Symbol State input) (a b : ℕ) (i : Fin k) : + tm.visitedByTapeHead cfg (a + b) i = + tm.visitedByTapeHead cfg a i ∪ tm.visitedByTapeHead (tm.runFrom cfg a) b i := by + ext z + simp only [mem_visitedByTapeHead, Finset.mem_union] + constructor + · rintro ⟨r, hr, rfl⟩ + rcases Nat.lt_or_ge r (a + 1) with h | h + · exact Or.inl ⟨r, h, rfl⟩ + · exact Or.inr ⟨r - a, by omega, + by rw [← runFrom_add, show a + (r - a) = r from by omega]⟩ + · rintro (⟨r, hr, rfl⟩ | ⟨r, hr, rfl⟩) + · exact ⟨r, by omega, rfl⟩ + · exact ⟨a + r, by omega, by rw [runFrom_add]⟩ + +/-- Splitting a run into two phases can only overcount the cells it visits, since the two phases +may revisit each other's cells. -/ +lemma spaceUsed_add_le (cfg : Cfg k Symbol State input) (a b : ℕ) : + tm.spaceUsed cfg (a + b) ≤ tm.spaceUsed cfg a + tm.spaceUsed (tm.runFrom cfg a) b := by + rw [spaceUsed, spaceUsed, spaceUsed, ← Finset.sum_add_distrib] + refine Finset.sum_le_sum fun i _ => ?_ + rw [spaceUsedByTape, visitedByTapeHead_add] + exact Finset.card_union_le _ _ + +/-- Space usage only depends on where the work-tape heads are at each step, so two runs whose head +positions agree use the same space. This is what lets a machine be replaced by a simulation of +it. -/ +lemma spaceUsed_eq_of_workTapePos {State' : Type*} {input' : List Symbol} + {tm' : MultiTapeTM k Symbol State'} (cfg : Cfg k Symbol State input) + (cfg' : Cfg k Symbol State' input') (t : ℕ) + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos = (tm'.runFrom cfg' m).workTapePos) : + tm.spaceUsed cfg t = tm'.spaceUsed cfg' t := by + refine Finset.sum_congr rfl fun i _ => congrArg Finset.card (Finset.image_congr fun m hm => ?_) + exact congrFun (h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm))) i + +/-- After the machine has halted the heads no longer move, so the visited set stops growing. -/ +lemma visitedByTapeHead_eq_of_halt (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.runFrom cfg τ).state = none) (i : Fin k) : + tm.visitedByTapeHead cfg t i = tm.visitedByTapeHead cfg τ i := by + refine Finset.Subset.antisymm (visitedByTapeHead_subset cfg fun m hm => ?_) + (tm.visitedByTapeHead_mono cfg i hle) + rcases Nat.le_total m τ with h | h + · exact mem_visitedByTapeHead.mpr ⟨m, by omega, rfl⟩ + · rw [runFrom_eq_of_halt tm cfg h hhalt] + exact tm.mem_visitedByTapeHead_self cfg τ i + +/-- After the machine has halted the heads no longer move, so the space usage stops growing. -/ +lemma spaceUsed_eq_of_halt (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.runFrom cfg τ).state = none) : + tm.spaceUsed cfg t = tm.spaceUsed cfg τ := + Finset.sum_congr rfl fun i _ => + congrArg Finset.card (tm.visitedByTapeHead_eq_of_halt cfg hle hhalt i) + +/-- A run that never moves a work-tape head visits one cell per tape. -/ +lemma spaceUsed_le_of_workTapePos_const (cfg : Cfg k Symbol State input) (u : ℕ) + (h : ∀ m ≤ u, (tm.runFrom cfg m).workTapePos = cfg.workTapePos) : + tm.spaceUsed cfg u ≤ k := by + have hcard : ∀ i ∈ Finset.univ, tm.spaceUsedByTape cfg u i ≤ 1 := + fun i _ => tm.spaceUsedByTape_le_one cfg fun m hm => congrFun (h m hm) i + simpa [spaceUsed] using Finset.sum_le_card_nsmul _ _ 1 hcard + + end Turing.MultiTapeTM From 619c183c34f55768a92007e3025bd8260ef475d6 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Fri, 18 Sep 2026 18:45:19 +0000 Subject: [PATCH 88/93] feat(Circuit): prove Lupanov upper bound (#890) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add Boolean synthesis with sharing and prove the uniform (1 + ε) 2^n/n upper bound for De Morgan circuits. Assisted by Codex, adapted from https://github.com/samuelSchlesinger/algebraic-circuits. --- Cslib.lean | 6 + Cslib/Computability/Circuit/Basic.lean | 8 +- .../Computability/Circuit/Boolean/Basic.lean | 68 +++++ .../Circuit/Boolean/Lupanov.lean | 234 ++++++++++++++ .../Circuit/Boolean/LupanovConstruction.lean | 288 ++++++++++++++++++ .../Circuit/Boolean/Synthesis.lean | 110 +++++++ Cslib/Computability/Circuit/Synthesis.lean | 238 +++++++++++++++ Cslib/Foundations/Data/Nat/Asymptotics.lean | 54 ++++ CslibTests.lean | 2 + CslibTests/BooleanCircuits.lean | 50 +++ CslibTests/Synthesis.lean | 126 ++++++++ references.bib | 35 +++ 12 files changed, 1216 insertions(+), 3 deletions(-) create mode 100644 Cslib/Computability/Circuit/Boolean/Basic.lean create mode 100644 Cslib/Computability/Circuit/Boolean/Lupanov.lean create mode 100644 Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean create mode 100644 Cslib/Computability/Circuit/Boolean/Synthesis.lean create mode 100644 Cslib/Computability/Circuit/Synthesis.lean create mode 100644 Cslib/Foundations/Data/Nat/Asymptotics.lean create mode 100644 CslibTests/BooleanCircuits.lean create mode 100644 CslibTests/Synthesis.lean diff --git a/Cslib.lean b/Cslib.lean index e43365640..212283054 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -34,9 +34,14 @@ public import Cslib.Computability.Automata.TwoWayNA.Basic public import Cslib.Computability.Automata.TwoWayNA.ComplToNA public import Cslib.Computability.Automata.TwoWayNA.OfNA public import Cslib.Computability.Circuit.Basic +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Boolean.Lupanov +public import Cslib.Computability.Circuit.Boolean.LupanovConstruction +public import Cslib.Computability.Circuit.Boolean.Synthesis public import Cslib.Computability.Circuit.Homomorphism public import Cslib.Computability.Circuit.Program public import Cslib.Computability.Circuit.Signature +public import Cslib.Computability.Circuit.Synthesis public import Cslib.Computability.Circuit.Wire public import Cslib.Computability.Distributed.FLP.Algorithm public import Cslib.Computability.Distributed.FLP.CanReachVia @@ -97,6 +102,7 @@ public import Cslib.Foundations.Data.FinFun.Basic public import Cslib.Foundations.Data.FinFun.Update public import Cslib.Foundations.Data.HasFresh public import Cslib.Foundations.Data.List.IsChainFromTo +public import Cslib.Foundations.Data.Nat.Asymptotics public import Cslib.Foundations.Data.Nat.Segment public import Cslib.Foundations.Data.OmegaSequence.Defs public import Cslib.Foundations.Data.OmegaSequence.Flatten diff --git a/Cslib/Computability/Circuit/Basic.lean b/Cslib/Computability/Circuit/Basic.lean index c3d1508bd..9671903cf 100644 --- a/Cslib/Computability/Circuit/Basic.lean +++ b/Cslib/Computability/Circuit/Basic.lean @@ -16,9 +16,6 @@ an output is free: projections and duplicated outputs cost no gates. The size of a circuit is its gate count and its depth is the maximum depth of a designated output wire. -A dependent pair `Σ gateCount, Circuit σ inputCount gateCount outputCount` -hides the gate count for constructions that compute it along the way. - For the standard Boolean circuit model, see [Arora and Barak, Section 6.1][AroraBarak09]. Here a topological ordering is part of the representation, and the Boolean gate basis is generalized to an arbitrary `Signature` and `Interpretation`. Our size @@ -87,6 +84,11 @@ def Circuit.eval (x : Fin inputCount → U) : Fin outputCount → U := c.program.trace i x ∘ c.outputs +/-- A single-output circuit computes `f` when its output agrees with `f` on every input. -/ +def Circuit.Computes (c : Circuit σ inputCount gateCount 1) + (interpretation : Interpretation σ U) (f : (Fin inputCount → U) → U) : Prop := + ∀ x, c.eval interpretation x 0 = f x + @[simp] theorem Circuit.eval_id (interpretation : Interpretation σ U) (input : Fin inputCount → U) : diff --git a/Cslib/Computability/Circuit/Boolean/Basic.lean b/Cslib/Computability/Circuit/Boolean/Basic.lean new file mode 100644 index 000000000..7dcdc4eee --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Basic.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic + +/-! +# Boolean circuits + +The De Morgan basis consists of binary AND and OR, unary NOT, and Boolean constants. +Every gate has fan-in at most two, so these are the usual bounded fan-in Boolean circuits +(`Program.fanInAtMost_two`). Circuit size counts every gate, including constants; +designated output wires are free. +-/ + +@[expose] public section + +namespace Cslib.Circuits +namespace Boolean + +/-- Boolean functions on `n` inputs. -/ +abbrev BooleanFunction (n : ℕ) := (Fin n → Bool) → Bool + +/-- Operations of the De Morgan basis, including constants. -/ +inductive Op where + /-- A Boolean constant. -/ + | const (value : Bool) + /-- Negation. -/ + | not + /-- Binary conjunction. -/ + | and + /-- Binary disjunction. -/ + | or + deriving DecidableEq + +/-- The De Morgan signature. -/ +abbrev signature : Signature where + Op := Op + Arity + | .const _ => 0 + | .not => 1 + | .and | .or => 2 + +/-- The usual Boolean interpretation. -/ +def interpretation : Interpretation signature Bool + | .const b, _ => b + | .not, x => !x 0 + | .and, x => x 0 && x 1 + | .or, x => x 0 || x 1 + +end Boolean + +/-- Every De Morgan program has fan-in at most two. -/ +theorem Program.fanInAtMost_two {n g : ℕ} (p : Program Boolean.signature n g) : + p.FanInAtMost 2 := by + induction p with + | empty => trivial + | gate p line ih => exact And.intro ih (by cases line.op <;> simp) + +/-- Every De Morgan circuit has fan-in at most two. -/ +theorem Circuit.fanInAtMost_two {n g o : ℕ} (c : Circuit Boolean.signature n g o) : + c.FanInAtMost 2 := + c.program.fanInAtMost_two + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Boolean/Lupanov.lean b/Cslib/Computability/Circuit/Boolean/Lupanov.lean new file mode 100644 index 000000000..22da82262 --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Lupanov.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.LupanovConstruction +public import Mathlib.Basic.Real.Basic +import Cslib.Foundations.Data.Nat.Asymptotics +import Mathlib.Algebra.Order.Archimedean.Real.Basic +import Mathlib.Order.Filter.AtTopBot.Basic +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.Ring + +/-! +# Lupanov's asymptotically optimal upper bound + +Every Boolean function on `n` inputs has a De Morgan circuit with at most +`(1 + ε) * 2 ^ n / n` gates for all sufficiently large `n`, given any `ε > 0`. +The threshold is uniform in the function; size counts constants and negations. +This matches Shannon's counting lower bound up to the factor `1 + ε`, which is why the +bound is called asymptotically optimal. + +This file only does the asymptotics. The circuit comes from the block construction in +`LupanovConstruction.lean`, which gives, for any split of the inputs into `k` address bits +and `d` data bits and any positive block size `s`, a circuit with at most `bound k d s` gates. + +## Choosing the parameters + +Write `l = log₂ n`. We take `k = 3 l` address bits, `d = n - 3 l` data bits, and blocks of +`s = n - 5 l` rows. Then: + +* the leading term of `bound` is `(2 ^ k / s + 1) · 2 ^ d ≈ 2 ^ n / s`, and since + `s = n - 5 l` is `n (1 - o(1))`, this is `(1 + o(1)) 2 ^ n / n` (`mainTerm_le`); +* the minterms cost about `(2 ^ k + 2 ^ d) · 2 n = O(n ^ 4) + O(2 ^ n / n ^ 2)`, using + `2 ^ k ≤ n ^ 3`; +* the `left` parts cost about `(2 ^ k / s) · 2 ^ s · 2 s ≈ 2 ^ (k + s) = 2 ^ (n - 2 l)`, + which is `O(2 ^ n / n ^ 2)`. + +`bound_le` packages the two error terms as `3 n ^ 4 + 16 n · 2 ^ d`; +`Nat.eventually_mul_pow_le_pow` and `error_le` show that the polynomial and the exponential +term are each `o(2 ^ n / n)`. Then `eventually_bound_le` combines everything into +`P · n · bound ≤ (P + 1) · 2 ^ n` for all large `n`, for any natural number `P`. +Taking `P > 1 / ε` in `exists_circuit` gives the theorem. + +## References + +* [O. B. Lupanov, *On a Method of Circuit Synthesis*][Lupanov1958], + Theorem 4 and Section 6, pp. 131-135: the upper bound for general weighted bases, + specialized here to the De Morgan basis. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012], + Theorem 1.15: a modern exposition. +-/ + +public section + +namespace Cslib.Circuits.Boolean.Lupanov + +open Filter + +/-- With the chosen parameters, the budget is the leading term `(2 ^ k / s + 1) · 2 ^ d` +plus error terms `3 n ^ 4`, from the address minterms, and `16 n · 2 ^ d`, from the data +minterms, the per-pattern overhead of every block (`left` parts, constants, conjunctions and +ORs), and the final constant. -/ +private theorem bound_le (n : ℕ) (hn : 5 * Nat.log2 n < n) : + bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) (n - 5 * Nat.log2 n) ≤ + (2 ^ (3 * Nat.log2 n) / (n - 5 * Nat.log2 n) + 1) * + 2 ^ (n - 3 * Nat.log2 n) + 3 * n ^ 4 + + 16 * n * 2 ^ (n - 3 * Nat.log2 n) := by + let l := Nat.log2 n + let k := 3 * l + let d := n - 3 * l + let s := n - 5 * l + let blockCount := 2 ^ k / s + 1 + have hl : 2 ^ l ≤ n := Nat.log2_self_le (by omega) + have hk : 2 ^ k ≤ n ^ 3 := by + calc + 2 ^ k = (2 ^ l) ^ 3 := by simp [k, pow_mul, Nat.mul_comm] + _ ≤ n ^ 3 := Nat.pow_le_pow_left hl _ + have hblocks : blockCount * s ≤ 2 ^ k + s := by + dsimp [blockCount] + nlinarith [Nat.div_mul_le_self (2 ^ k) s] + have hshift : 2 ^ k * 2 ^ s = 2 ^ l * 2 ^ d := by + rw [← pow_add, ← pow_add] + congr 1 + dsimp [k, s, d, l] + omega + have hbank : (2 ^ k + s) * 2 ^ s ≤ 2 * n * 2 ^ d := by + rw [Nat.add_mul, hshift] + have := Nat.mul_le_mul (by grind : s ≤ n) + (Nat.pow_le_pow_right (by omega : 1 ≤ 2) (by grind : s ≤ d)) + have := Nat.mul_le_mul_right (2 ^ d) hl + nlinarith + have hpattern : blockCount * (2 ^ s * (2 * s + 4)) ≤ 12 * n * 2 ^ d := by + calc + blockCount * (2 ^ s * (2 * s + 4)) ≤ blockCount * (2 ^ s * (6 * s)) := by + gcongr; grind + _ = 6 * (blockCount * s) * 2 ^ s := by ring + _ ≤ 6 * (2 ^ k + s) * 2 ^ s := by gcongr + _ ≤ 6 * (2 * n * 2 ^ d) := by nlinarith [hbank] + _ = 12 * n * 2 ^ d := by ring + have hmin : (2 ^ k + 2 ^ d) * (2 * n + 1) ≤ 3 * n ^ 4 + 3 * n * 2 ^ d := by + calc + (2 ^ k + 2 ^ d) * (2 * n + 1) ≤ (n ^ 3 + 2 ^ d) * (3 * n) := by gcongr; grind + _ = 3 * n ^ 4 + 3 * n * 2 ^ d := by ring + have hone : 1 ≤ n * 2 ^ d := Nat.mul_pos (by grind : 0 < n) (pow_pos (by omega) _) + change bound k d s ≤ blockCount * 2 ^ d + 3 * n ^ 4 + 16 * n * 2 ^ d + unfold bound + rw [show k + d = n by grind] + dsimp [blockCount] at hpattern ⊢ + nlinarith + +/-- For `P > 0`, the leading term is at most `(1 + 1 / P) · 2 ^ n / n` up to a lower-order +term, once `n` is large enough that dropping `5 log₂ n` rows per block costs at most a factor +`(P + 1) / P`. The statement is multiplied through by `P n` to stay in `ℕ`. -/ +private theorem mainTerm_le (P n : ℕ) + (hn : 5 * Nat.log2 n < n) (hP : (P + 1) * (5 * Nat.log2 n) ≤ n) : + P * n * ((2 ^ (3 * Nat.log2 n) / (n - 5 * Nat.log2 n) + 1) * + 2 ^ (n - 3 * Nat.log2 n)) ≤ (P + 1) * 2 ^ n + + (P + 1) * n * 2 ^ (n - 3 * Nat.log2 n) := by + let k := 3 * Nat.log2 n + let s := n - 5 * Nat.log2 n + let d := n - k + have hks : k + d = n := by dsimp [k, d]; omega + have hPs : P * n ≤ (P + 1) * s := by + dsimp [s] + have := Nat.sub_add_cancel (by omega : 5 * Nat.log2 n ≤ n) + nlinarith + have hblocks : (2 ^ k / s + 1) * s ≤ 2 ^ k + s := by + nlinarith [Nat.div_mul_le_self (2 ^ k) s] + calc + P * n * ((2 ^ k / s + 1) * 2 ^ d) ≤ + (P + 1) * s * ((2 ^ k / s + 1) * 2 ^ d) := by gcongr + _ = (P + 1) * ((2 ^ k / s + 1) * s) * 2 ^ d := by ring + _ ≤ (P + 1) * (2 ^ k + s) * 2 ^ d := by gcongr + _ = (P + 1) * 2 ^ n + (P + 1) * s * 2 ^ d := by + rw [show 2 ^ n = 2 ^ k * 2 ^ d by rw [← pow_add, hks]] + ring + _ ≤ (P + 1) * 2 ^ n + (P + 1) * n * 2 ^ d := by gcongr; exact Nat.sub_le _ _ + +/-- An error term of order `n · 2 ^ d` is `o(2 ^ n / n)`: with `d = n - 3 log₂ n`, +`c n ^ 2 · 2 ^ d ≤ 2 ^ n` once `n ≥ 8 c` and `3 log₂ n ≤ n`, using +`2 ^ (3 log₂ n) > (n / 2) ^ 3`. -/ +private theorem error_le (c n : ℕ) (hc : 8 * c ≤ n) (hn : 3 * Nat.log2 n ≤ n) : + c * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) ≤ 2 ^ n := by + let q := 2 ^ Nat.log2 n + have hq : n < 2 * q := by + simpa [q, pow_succ, Nat.mul_comm] using Nat.lt_log2_self (n := n) + have hcq : 4 * c ≤ q := by omega + have hpoly : c * n ^ 2 ≤ q ^ 3 := by + calc + c * n ^ 2 ≤ c * (2 * q) ^ 2 := by gcongr + _ = (4 * c) * q ^ 2 := by ring + _ ≤ q * q ^ 2 := by gcongr + _ = q ^ 3 := by ring + calc + c * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) ≤ q ^ 3 * 2 ^ (n - 3 * Nat.log2 n) := by gcongr + _ = 2 ^ n := by + dsimp [q] + rw [← pow_mul, ← pow_add] + congr 1 + omega + +/-- For every `P`, eventually `P n · bound ≤ (P + 1) 2 ^ n`; for `P > 0` this says the budget +is at most `(1 + 1 / P) · 2 ^ n / n`. Combines `bound_le`, `mainTerm_le`, +`Nat.eventually_mul_pow_le_pow`, and `error_le`; the slack `Q = 3 P` absorbs the constants in +the error terms. -/ +private theorem eventually_bound_le (P : ℕ) : + ∀ᶠ n : ℕ in atTop, + P * n * bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) (n - 5 * Nat.log2 n) ≤ + (P + 1) * 2 ^ n := by + let Q := 3 * P + -- The polynomial and data terms each contribute at most `2 ^ n` after scaling by `Q * n`. + filter_upwards [Nat.eventually_mul_log2_le (5 * (Q + 1) + 1), + Nat.eventually_mul_pow_le_pow (3 * Q) 5 Nat.one_lt_two, + eventually_ge_atTop (max 2 (8 * (17 * Q + 1)))] with n hlog hpoly hn + have hn2 : 2 ≤ n := (le_max_left _ _).trans hn + have hl : 0 < Nat.log2 n := (Nat.le_log2 (by omega)).mpr (by simpa using hn2) + have hstrict : 5 * Nat.log2 n < n := by nlinarith + have hremoved : (Q + 1) * (5 * Nat.log2 n) ≤ n := by nlinarith + have hmain := mainTerm_le Q n hstrict hremoved + have herr := error_le (17 * Q + 1) n ((le_max_right _ _).trans hn) (by omega) + have hbound := Nat.mul_le_mul_left (Q * n) (bound_le n hstrict) + have hsquare : n ≤ n ^ 2 := by nlinarith + have hmerge : (Q + 1) * n * 2 ^ (n - 3 * Nat.log2 n) ≤ + (Q + 1) * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) := by gcongr + have htotal : Q * n * bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) + (n - 5 * Nat.log2 n) ≤ (Q + 3) * 2 ^ n := by + nlinarith only [hmain, herr, hpoly, hbound, hmerge] + dsimp [Q] at htotal + nlinarith only [htotal] + +/-- Transport `synthesis` along `k + d = n`. -/ +private theorem exists_circuit_of_split {n k d s : ℕ} (h : k + d = n) (hs : 0 < s) + (f : BooleanFunction n) : ∃ g ≤ bound k d s, ∃ c : Circuit signature n g 1, + c.Computes interpretation f := by + subst n + exact (synthesis f hs).exists_circuit + +/-- Lupanov's upper bound: every Boolean function on `n` inputs has a De Morgan circuit +with at most `(1 + ε) 2ⁿ/n` gates, uniformly for sufficiently large `n`. + +Pick a natural number `P > 1 / ε`, so that `(P + 1) / P < 1 + ε`; then the threshold `N` +comes from `eventually_bound_le P`. -/ +theorem exists_circuit (ε : ℝ) (hε : 0 < ε) : + ∃ N : ℕ, ∀ n ≥ N, ∀ f : BooleanFunction n, + ∃ g, ∃ c : Circuit signature n g 1, + c.Computes interpretation f ∧ (c.size : ℝ) ≤ (1 + ε) * 2 ^ n / n := by + apply eventually_atTop.mp + obtain ⟨P, hP⟩ := exists_nat_gt (1 / ε) + have hP0 : (0 : ℝ) < P := lt_trans (by positivity) hP + have hcoefficient : (P : ℝ) + 1 ≤ (1 + ε) * P := by + have := (div_lt_iff₀ hε).mp hP + nlinarith + filter_upwards [eventually_bound_le P, Nat.eventually_mul_log2_le 6, + eventually_ge_atTop 2] with n hb hl hn + intro f + have hlog : 0 < Nat.log2 n := (Nat.le_log2 (by omega)).mpr (by simpa using hn) + have hsplit : 3 * Nat.log2 n + (n - 3 * Nat.log2 n) = n := by omega + obtain ⟨g, hg, c, hc⟩ := exists_circuit_of_split (s := n - 5 * Nat.log2 n) + hsplit (by omega) f + refine ⟨g, c, hc, ?_⟩ + have hcost : (P : ℝ) * n * g ≤ (P + 1 : ℝ) * 2 ^ n := by + exact_mod_cast (Nat.mul_le_mul_left (P * n) hg).trans hb + apply (le_div_iff₀ (by exact_mod_cast (by omega : 0 < n) : (0 : ℝ) < n)).mpr + apply (mul_le_mul_iff_right₀ hP0).mp + calc + (P : ℝ) * (g * n) = P * n * g := by ring + _ ≤ (P + 1) * 2 ^ n := hcost + _ ≤ P * ((1 + ε) * 2 ^ n) := by + nlinarith [mul_le_mul_of_nonneg_right hcoefficient (by positivity : (0 : ℝ) ≤ 2 ^ n)] + +end Cslib.Circuits.Boolean.Lupanov diff --git a/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean b/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean new file mode 100644 index 000000000..9b006964f --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Synthesis + +import Mathlib.Algebra.BigOperators.Fin + +/-! +# Lupanov's block construction + +This file is the finite, parametrised core of Lupanov's upper bound. Its purpose is to give a +gate budget `bound k d s` that is valid for every Boolean function on `k + d` inputs and every +positive block size `s`, and to prove (`synthesis`) that the budget suffices. The asymptotic file +`Lupanov.lean` then chooses `k`, `d`, and `s` as functions of `n` and shows that the budget is +`(1 + ε) 2 ^ n / n`. No asymptotics happen here. + +## Why not the disjunctive normal form? + +Writing `f` as the disjunction of its true minterms uses up to `2 ^ n` minterms of `n` +literals each, so roughly `n 2 ^ n` gates. The waste is that nothing is shared between +minterms. Lupanov's construction shares almost everything. + +## The picture + +Split the `n = k + d` inputs into `k` *address* bits and `d` *data* bits, and view the truth +table of `f` as a `2 ^ k × 2 ^ d` matrix: row `a` is an address assignment, column `b` is a +data assignment, and the entry is `f (a ++ b)`. Cut the rows into blocks of `s` consecutive +rows. Inside one block every column is a bit string of length `s`, its *pattern* in that +block; there are only `2 ^ s` possible patterns, however many columns there are. + +For each block `B` and pattern `v` define two functions: + +* `left B v`, of the address bits only: true at `a` when row `a` lies in `B` and `v` has a + `1` at the position of `a` within `B`; +* `right f B v`, of the data bits only: true at `b` when column `b` has pattern `v` in `B`. + +Both are functions of the full input that ignore the other half of it. Then +`left B v a ∧ right f B v b` holds exactly when `a` lies in `B`, `v` is the pattern of +column `b` inside `B`, and the entry `f (a ++ b)` is `true`. So `f` is the disjunction over +all pairs `(B, v)` of `left B v ∧ right f B v` (`table_eq`). + +## Counting gates + +All `2 ^ k` address minterms and `2 ^ d` data minterms are built once and shared. Each +`left B v` is a disjunction of at most `s` address minterms, so it costs `O(s)` gates, and +there are `(2 ^ k / s + 1) · 2 ^ s` of them. Each `right f B v` is a disjunction of data +minterms, one per column with pattern `v`; the columns of a block are partitioned by their +patterns (`support_card_sum`), so all the `right f B v` of one block together cost about +`2 ^ d` gates. Summing over blocks, the dominant contribution is + + `(2 ^ k / s) · 2 ^ d = 2 ^ n / s`. + +For the parameters chosen in `Lupanov.lean` the remaining terms are of lower order, and +`s ≈ n` makes this `2 ^ n / n`. The exact expression is `bound`. + +## References + +* [O. B. Lupanov, *On a Method of Circuit Synthesis*][Lupanov1958], + Section 1, equation (1.1), pp. 120-122: the original `(k, s)` representation. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012], + Theorem 1.15: a modern exposition. +* [C. E. Shannon, *The Synthesis of Two-Terminal Switching Circuits*][Shannon1949], + Section 3(d), pp. 73-77: the earlier universal-network method for relay contacts. +-/ + +@[expose] public section + +namespace Cslib.Circuits.Boolean.Lupanov + +variable {k d s : ℕ} + +/-! ### Minterms -/ + +/-- An assignment to `k` Boolean variables. Address assignments index the rows of the truth +table and data assignments index its columns. -/ +private abbrev Assignment (k : ℕ) := Fin k → Bool + +/-- Number the address assignments as rows `0, …, 2 ^ k - 1`, interpreting the bits as +binary digits with the least significant bit first. -/ +private def index (k : ℕ) : Assignment k ≃ Fin (2 ^ k) := + (Equiv.arrowCongr (Equiv.refl (Fin k)) finTwoEquiv.symm).trans finFunctionFinEquiv + +/-- The minterm testing that the address bits equal `a` (`.inl a`) or that the data bits +equal `b` (`.inr b`). Both kinds are built once and shared by every block. -/ +private def minterm : Assignment k ⊕ Assignment d → BooleanFunction (k + d) + | .inl a => fun x => decide ((fun i => x (Fin.castAdd d i)) = a) + | .inr b => fun x => decide ((fun i => x (Fin.natAdd k i)) = b) + +/-- Build every address and data minterm from the inputs. Each costs `2 (k + d) + 1` gates +by `synthesis_minterm`. -/ +private theorem minterms_synthesis : + Synthesis interpretation (inputs (k + d)) (Set.range (minterm (k := k) (d := d))) + ((2 ^ k + 2 ^ d) * (2 * (k + d) + 1)) := by + have h (a : Assignment k ⊕ Assignment d) : + Synthesis interpretation (inputs (k + d)) {minterm a} (2 * (k + d) + 1) := by + cases a with + | inl a => + exact (synthesis_minterm (Fin.castAdd d) a).mono + Set.Subset.rfl Set.Subset.rfl (by omega) + | inr b => + exact (synthesis_minterm (Fin.natAdd k) b).mono + Set.Subset.rfl Set.Subset.rfl (by omega) + simpa using Synthesis.family minterm (fun _ => 2 * (k + d) + 1) h + +/-- Once the minterms have been built, each of them is free. -/ +private theorem minterm_available (a : Assignment k ⊕ Assignment d) : + Synthesis interpretation (Set.range minterm) {minterm a} 0 := + Synthesis.of_subset (by rintro _ rfl; exact ⟨a, rfl⟩) + +/-! ### The block decomposition + +Rows `block * s, …, block * s + s - 1` form block number `block`. The final block may be +partial, and when `s ∣ 2 ^ k` there is an empty extra block; rows past `2 ^ k` are read as +`false` throughout. -/ + +/-- The pattern of column `data` inside block `block`: the `s` entries of the truth table in +the block's rows, read down the column. -/ +private def column (f : BooleanFunction (k + d)) (block : ℕ) (data : Assignment d) : + Assignment s := + fun offset => if h : block * s + offset.val < 2 ^ k then + f (Fin.append ((index k).symm ⟨block * s + offset.val, h⟩) data) else false + +/-- The contribution of the row at `offset` within `block` to `left`: the address minterm of +that row when `pattern` is `1` there, and the constant `false` otherwise. -/ +private def leftRow (block : ℕ) (pattern : Assignment s) (offset : Fin s) : + BooleanFunction (k + d) := + if pattern offset then + if h : block * s + offset.val < 2 ^ k then + minterm (.inl ((index k).symm ⟨block * s + offset.val, h⟩)) + else fun _ => false + else fun _ => false + +/-- The address-only function of a block and pattern: true when the address lies in the +block, at an offset where the pattern is `1`. -/ +private def left (block : ℕ) (pattern : Assignment s) : BooleanFunction (k + d) := + fun x => decide (∃ offset, leftRow (d := d) block pattern offset x = true) + +/-- `left` is true exactly at inputs whose address is a row of the block, at an offset where +the pattern is `1`. -/ +private theorem left_eq_true (block : ℕ) (pattern : Assignment s) (x : Assignment (k + d)) : + left block pattern x = true ↔ ∃ offset : Fin s, + ∃ h : block * s + offset.val < 2 ^ k, + (index k).symm ⟨block * s + offset.val, h⟩ = (fun i => x (Fin.castAdd d i)) ∧ + pattern offset = true := by + simp only [left, decide_eq_true_eq] + apply exists_congr + intro offset + by_cases h : block * s + offset.val < 2 ^ k <;> + cases hp : pattern offset <;> simp [leftRow, hp, h, minterm, eq_comm] + +/-- The columns whose pattern inside `block` is `pattern`. For a fixed block, these sets +partition the columns. -/ +private def support (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) : + Finset (Assignment d) := Finset.univ.filter fun data => column f block data = pattern + +/-- The data-only function of a block and pattern: true when the data bits name a column +whose pattern inside the block is `pattern`. -/ +private def right (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) : + BooleanFunction (k + d) := + fun x => decide (∃ data ∈ support f block pattern, minterm (.inr data) x = true) + +/-- `right` is true exactly at inputs whose data bits name a column with the given pattern +inside the block. -/ +private theorem right_eq_true (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) + (x : Assignment (k + d)) : + right f block pattern x = true ↔ column f block (fun i => x (Fin.natAdd k i)) = pattern := by + simp [right, support, minterm, eq_comm] + +/-! ### Gate counts -/ + +/-- The supports of one block partition the `2 ^ d` columns. This is why all the `right` +parts of a block together cost only about `2 ^ d` gates. -/ +private theorem support_card_sum (f : BooleanFunction (k + d)) (block : ℕ) : + ∑ pattern : Assignment s, (support f block pattern).card = 2 ^ d := by + simpa [support] using (Finset.card_eq_sum_card_fiberwise + (s := Finset.univ) (t := Finset.univ) (f := column (s := s) f block) (by simp)).symm + +/-- A `left` part costs `2 s + 1` gates once the minterms are available: at most one gate per +row (a shared minterm costs nothing, a padding row needs a constant), one OR per row, and one +constant for the empty disjunction. -/ +private theorem left_synthesis (block : ℕ) (pattern : Assignment s) : + Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {left block pattern} (2 * s + 1) := by + have h (offset : Fin s) : + Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {leftRow block pattern offset} 1 := by + unfold leftRow + split + · split + · exact (minterm_available _).mono + Set.Subset.rfl Set.Subset.rfl (by omega : 0 ≤ 1) + · exact Synthesis.const false + · exact Synthesis.const false + change Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {fun x => decide (∃ offset, leftRow block pattern offset x = true)} (2 * s + 1) + simpa [Nat.mul_comm] using Synthesis.exists_mem Finset.univ + (leftRow (d := d) block pattern) (fun _ => 1) (fun i _ => h i) + +/-- A `right` part costs one OR per column in its support, plus one constant for the empty +disjunction, once the minterms are available. -/ +private theorem right_synthesis (f : BooleanFunction (k + d)) (block : ℕ) + (pattern : Assignment s) : + Synthesis interpretation (Set.range minterm) {right f block pattern} + ((support f block pattern).card + 1) := by + change Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {fun x => decide (∃ data ∈ support f block pattern, minterm (.inr data) x = true)} _ + simpa using Synthesis.exists_mem (support f block pattern) + (fun data => minterm (.inr data)) (fun _ => 0) + (fun data _ => minterm_available (.inr data)) + +/-! ### Correctness -/ + +/-- The disjunction over all blocks and patterns of `left ∧ right`. Block numbers range over +`2 ^ k / s + 1` values to include a partial final block. -/ +private def table (f : BooleanFunction (k + d)) (s : ℕ) : BooleanFunction (k + d) := + fun x => decide (∃ pair : Fin (2 ^ k / s + 1) × Assignment s, + (left pair.1.val pair.2 x && right f pair.1.val pair.2 x) = true) + +/-- The block decomposition reconstructs `f`. At an input `a ++ b` with `f (a ++ b) = true`, +the witnessing pair is the block containing row `a` and the pattern of column `b` in that +block. -/ +private theorem table_eq (f : BooleanFunction (k + d)) (hs : 0 < s) : table f s = f := by + funext x + apply Bool.eq_iff_iff.mpr + simp only [table, decide_eq_true_eq, Prod.exists, Bool.and_eq_true, + left_eq_true, right_eq_true] + constructor + · rintro ⟨block, pattern, ⟨offset, hrow, haddress, hbit⟩, hpattern⟩ + rw [← hpattern] at hbit + simpa [column, hrow, haddress, Fin.append_castAdd_natAdd] using hbit + · intro hx + let address := index k (fun i => x (Fin.castAdd d i)) + let block : Fin (2 ^ k / s + 1) := + ⟨address.val / s, Nat.lt_succ_of_le (Nat.div_le_div_right address.isLt.le)⟩ + let offset : Fin s := ⟨address.val % s, Nat.mod_lt _ hs⟩ + have hrow : block.val * s + offset.val = address.val := Nat.div_add_mod' _ _ + have hvalid : block.val * s + offset.val < 2 ^ k := hrow ▸ address.isLt + have haddress : (index k).symm ⟨block.val * s + offset.val, hvalid⟩ = + (fun i => x (Fin.castAdd d i)) := by + rw [show (⟨block.val * s + offset.val, hvalid⟩ : Fin (2 ^ k)) = address by + exact Fin.ext hrow] + exact (index k).symm_apply_apply _ + refine ⟨block, column f block.val (fun i => x (Fin.natAdd k i)), + ⟨offset, hvalid, haddress, ?_⟩, rfl⟩ + simpa [column, hvalid, haddress, Fin.append_castAdd_natAdd] using hx + +/-! ### The bound -/ + +/-- Gate budget for `k` address bits, `d` data bits, and blocks of `s` rows, as spent by +`synthesis`. In order: the shared minterms; then for each of the `2 ^ k / s + 1` blocks +(a partial final block, or an empty extra block when `s ∣ 2 ^ k`), `2 s + 4` gates per +pattern, namely `2 s + 1` for its `left` part, the constant starting its `right` part, the +conjunction of the two, and the OR into the running disjunction, plus `2 ^ d` gates in total +for the ORs inside the `right` parts of the block, one per column; and one constant for the +empty outer disjunction. The leading term is `(2 ^ k / s) · 2 ^ d ≈ 2 ^ n / s`. -/ +def bound (k d s : ℕ) : ℕ := + (2 ^ k + 2 ^ d) * (2 * (k + d) + 1) + + (2 ^ k / s + 1) * (2 ^ s * (2 * s + 4) + 2 ^ d) + 1 + +/-- Every Boolean function on `k + d` inputs can be built from the input projections within +`bound k d s` gates: build all minterms, then the disjunction over block-pattern pairs of +`left ∧ right`, which equals `f` by `table_eq`. -/ +theorem synthesis (f : BooleanFunction (k + d)) (hs : 0 < s) : + Synthesis interpretation (inputs (k + d)) {f} (bound k d s) := by + have hpair (pair : Fin (2 ^ k / s + 1) × Assignment s) := + (left_synthesis (d := d) pair.1.val pair.2).and (right_synthesis f pair.1.val pair.2) + have h := Synthesis.exists_mem Finset.univ + (fun pair : Fin (2 ^ k / s + 1) × Assignment s => + fun x => left pair.1.val pair.2 x && right f pair.1.val pair.2 x) + (fun pair => (2 * s + 1) + ((support f pair.1.val pair.2).card + 1) + 1) + (fun pair _ => hpair pair) + have hsum : (∑ pair : Fin (2 ^ k / s + 1) × Assignment s, + ((2 * s + 1) + ((support f pair.1.val pair.2).card + 1) + 1 + 1)) = + (2 ^ k / s + 1) * (2 ^ s * (2 * s + 4) + 2 ^ d) := by + simp_rw [show ∀ a : ℕ, (2 * s + 1) + (a + 1) + 1 + 1 = (2 * s + 4) + a by omega] + simp [Fintype.sum_prod_type, Finset.sum_add_distrib, support_card_sum, Nat.mul_add, + Nat.mul_assoc] + simp only [Finset.mem_univ, true_and, hsum] at h + change Synthesis interpretation _ {table f s} _ at h + rw [table_eq f hs] at h + simpa [bound, Nat.add_assoc] using minterms_synthesis.comp + (h.mono Set.subset_union_right Set.Subset.rfl le_rfl) + +end Cslib.Circuits.Boolean.Lupanov diff --git a/Cslib/Computability/Circuit/Boolean/Synthesis.lean b/Cslib/Computability/Circuit/Boolean/Synthesis.lean new file mode 100644 index 000000000..a9e021a6c --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Synthesis.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Synthesis +public import Mathlib.Data.Fintype.Card + +/-! +# Boolean synthesis + +The generic synthesis rules specialize to the De Morgan basis: constants, negation, conjunction, +and disjunction. Finite conjunctions and disjunctions use the generic fold bound, and +`synthesis_minterm` combines literals to test a specified tuple of input bits. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +open Boolean + +universe u +variable {n : ℕ} {ι : Type u} + +namespace Synthesis + +variable {s : Set (BooleanFunction n)} {a b : ℕ} {f g : BooleanFunction n} + +/-- Constants cost one gate. -/ +theorem const (value : Bool) : Synthesis interpretation s {fun _ => value} 1 := + nullary (I := interpretation) (.const value) rfl + +/-- Apply negation to a synthesized function. -/ +theorem not (h : Synthesis interpretation s {f} a) : + Synthesis interpretation s {fun x => !f x} (a + 1) := + h.unary .not + +/-- Binary conjunction costs one gate beyond its arguments. -/ +theorem and (hf : Synthesis interpretation s {f} a) (hg : Synthesis interpretation s {g} b) : + Synthesis interpretation s {fun x => f x && g x} (a + b + 1) := by + simpa [interpretation] using hf.binary hg .and + +/-- Binary disjunction costs one gate beyond its arguments. -/ +theorem or (hf : Synthesis interpretation s {f} a) (hg : Synthesis interpretation s {g} b) : + Synthesis interpretation s {fun x => f x || g x} (a + b + 1) := by + simpa [interpretation] using hf.binary hg .or + +/-- Disjoin a finite family of functions. The extra gate supplies the empty disjunction. -/ +theorem exists_mem (indices : Finset ι) (f : ι → BooleanFunction n) (cost : ι → ℕ) + (h : ∀ i ∈ indices, Synthesis interpretation s {f i} (cost i)) : + Synthesis interpretation s {fun x => decide (∃ i ∈ indices, f i x = true)} + ((∑ i ∈ indices, (cost i + 1)) + 1) := by + have hop (f g : BooleanFunction n) : + Synthesis interpretation {f, g} {fun x => f x || g x} 1 := by + simpa [interpretation] using gate (I := interpretation) (s := {f, g}) .or + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + have heq : (fun x => indices.fold Bool.or false (fun i => f i x)) = + (fun x => decide (∃ i ∈ indices, f i x = true)) := by + funext x + apply Bool.eq_iff_iff.mpr + simpa using Finset.fold_op_rel_iff_or (op := Bool.or) + (r := fun _ v : Bool => v = true) (by simp) (c := true) + (s := indices) (f := fun i => f i x) (b := false) + simpa only [heq] using finset_fold Bool.or 1 hop indices f cost + (fun _ => false) (const false) h + +/-- Conjoin a finite family of functions. The extra gate supplies the empty conjunction. -/ +theorem forall_mem (indices : Finset ι) (f : ι → BooleanFunction n) (cost : ι → ℕ) + (h : ∀ i ∈ indices, Synthesis interpretation s {f i} (cost i)) : + Synthesis interpretation s {fun x => decide (∀ i ∈ indices, f i x = true)} + ((∑ i ∈ indices, (cost i + 1)) + 1) := by + have hop (f g : BooleanFunction n) : + Synthesis interpretation {f, g} {fun x => f x && g x} 1 := by + simpa [interpretation] using gate (I := interpretation) (s := {f, g}) .and + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + have heq : (fun x => indices.fold Bool.and true (fun i => f i x)) = + (fun x => decide (∀ i ∈ indices, f i x = true)) := by + funext x + apply Bool.eq_iff_iff.mpr + simpa using Finset.fold_op_rel_iff_and (op := Bool.and) + (r := fun _ v : Bool => v = true) (by simp) (c := true) + (s := indices) (f := fun i => f i x) (b := true) + simpa only [heq] using finset_fold Bool.and 1 hop indices f cost + (fun _ => true) (const true) h + +end Synthesis + +namespace Boolean + +/-- A conjunction testing a specified tuple of input bits. -/ +theorem synthesis_minterm {k : ℕ} (wires : Fin k → Fin n) (value : Fin k → Bool) : + Synthesis interpretation (inputs n) {fun x => decide ((fun i => x (wires i)) = value)} + (2 * k + 1) := by + have literal (i : Fin k) : + Synthesis interpretation (inputs n) {fun x => decide (x (wires i) = value i)} 1 := by + have h : Synthesis interpretation (inputs n) {fun x => x (wires i)} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨wires i, rfl⟩) + cases hv : value i + · simpa [hv] using h.not + · simpa [hv] using h.mono Set.Subset.rfl Set.Subset.rfl (by omega : 0 ≤ 1) + have h := Synthesis.forall_mem Finset.univ + (fun i x => decide (x (wires i) = value i)) (fun _ => 1) (fun i _ => literal i) + simpa [funext_iff, Nat.mul_comm] using h + +end Boolean +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Synthesis.lean b/Cslib/Computability/Circuit/Synthesis.lean new file mode 100644 index 000000000..7362f013d --- /dev/null +++ b/Cslib/Computability/Circuit/Synthesis.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +public import Mathlib.Algebra.BigOperators.Group.Finset.Basic +public import Mathlib.Data.Finset.Fold +public import Mathlib.Data.Fintype.Basic +public import Mathlib.Data.Set.BooleanAlgebra +public import Mathlib.Data.Set.Lattice.Bounded + +/-! +# Simultaneous circuit synthesis + +`Synthesis I sources targets cost` bounds the number of additional gates needed to compute +`targets` from `sources` under an interpretation `I`. Every function already available in the +starting program remains available, so successive constructions can share intermediate results. +The signature and its carrier are arbitrary; neither needs to be finite or decidable. + +The core rules compose bounds, combine finite families, and apply operations of the signature. +The fold rules accept a bound for combining two arguments, which may itself use several gates. +`Synthesis.exists_circuit_family` selects any finite family of outputs without adding gates; +`Synthesis.exists_circuit` specializes this to a single output. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +universe v u w +variable {σ : Signature.{v}} {U : Type u} {n : ℕ} {ι : Type w} +variable {I : Interpretation σ U} + +/-- The coordinate projections supplied by the circuit's inputs. -/ +def inputs (n : ℕ) : Set ((Fin n → U) → U) := Set.range fun i x => x i + +/-- The functions computed by the wires of `p`, whether input wires or internal +gates. -/ +def available (I : Interpretation σ U) {g : ℕ} (p : Program σ n g) : Set ((Fin n → U) → U) := + Set.range (p.wireFunction I) + +/-- A function is available exactly when some wire computes it pointwise. -/ +theorem mem_available {g : ℕ} {p : Program σ n g} {f : (Fin n → U) → U} : + f ∈ available I p ↔ ∃ w, ∀ x, p.trace I x w = f x := by + simp [available, Program.wireFunction, funext_iff] + +/-- The input projections are available in every program. -/ +theorem inputs_subset_available {g : ℕ} (p : Program σ n g) : + inputs n ⊆ available I p := by + rintro _ ⟨i, rfl⟩ + exact ⟨Wire.input i, p.wireFunction_input I i⟩ + +/-- `Synthesis I sources targets cost` says that `targets` can be computed from `sources` +using at most `cost` additional gates, without losing anything already computed. + +Precisely: for every program `p₁` on whose wires every function in `sources` is available, +there is a program `p₂` such that +* `p₂` has at most `cost` more gates than `p₁`, +* every function available in `p₁` is still available in `p₂`, and +* every function in `targets` is available in `p₂`. + +Quantifying over an arbitrary starting program, rather than the empty one, is what lets +constructions share intermediate results: `Synthesis.comp` adds budgets because the second +construction may reuse wires built by the first. -/ +def Synthesis (I : Interpretation σ U) (sources targets : Set ((Fin n → U) → U)) + (cost : ℕ) : Prop := + ∀ (g₁ : ℕ) (p₁ : Program σ n g₁), sources ⊆ available I p₁ → + ∃ (g₂ : ℕ) (p₂ : Program σ n g₂), g₂ ≤ g₁ + cost ∧ + available I p₁ ⊆ available I p₂ ∧ targets ⊆ available I p₂ + +namespace Synthesis + +variable {s t t₁ : Set ((Fin n → U) → U)} {a b : ℕ} {f g : (Fin n → U) → U} + +/-- Available functions require no additional gates. -/ +theorem of_subset (h : t ⊆ s) : Synthesis I s t 0 := + fun g p hp => ⟨g, p, by omega, Set.Subset.rfl, h.trans hp⟩ + +/-- Enlarge the source family, narrow the target family, or increase the budget. -/ +theorem mono (h : Synthesis I s t a) {s' t' : Set ((Fin n → U) → U)} + (hs : s ⊆ s') (ht : t' ⊆ t) (hab : a ≤ b) : Synthesis I s' t' b := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hkeep, hout⟩ := h g₁ p (hs.trans hp) + exact ⟨g₂, q, by omega, hkeep, ht.trans hout⟩ + +/-- Successive constructions add their gate budgets. -/ +theorem comp (h : Synthesis I s t a) (h' : Synthesis I (s ∪ t) t₁ b) : + Synthesis I s t₁ (a + b) := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hpq, ht⟩ := h g₁ p hp + obtain ⟨g₃, r, hr, hqr, hu⟩ := h' g₂ q (Set.union_subset (hp.trans hpq) ht) + exact ⟨g₃, r, by omega, hpq.trans hqr, hu⟩ + +/-- Combine two target families, preserving the first while constructing the second. -/ +theorem union (h : Synthesis I s t a) (h' : Synthesis I s t₁ b) : + Synthesis I s (t ∪ t₁) (a + b) := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hpq, ht⟩ := h g₁ p hp + obtain ⟨g₃, r, hr, hqr, hu⟩ := h' g₂ q (hp.trans hpq) + exact ⟨g₃, r, by omega, hpq.trans hqr, Set.union_subset (ht.trans hqr) hu⟩ + +/-- Synthesize an operation whose arguments are already available. -/ +theorem gate (op : σ.Op) (args : Fin (σ.Arity op) → (Fin n → U) → U) + (hargs : ∀ i, args i ∈ s) : + Synthesis I s {fun x => I op (fun i => args i x)} 1 := by + classical + intro g₁ p hp + choose wires hw using fun i => mem_available.mp (hp (hargs i)) + let line : Line σ n g₁ := ⟨op, wires⟩ + refine ⟨g₁ + 1, p.gate line, le_rfl, ?_, ?_⟩ + · intro f hf + obtain ⟨w, hw'⟩ := mem_available.mp hf + exact mem_available.mpr + ⟨w.castSucc, fun x => (Program.trace_gate_castSucc _ _ _ _ _).trans (hw' x)⟩ + · rw [Set.singleton_subset_iff, mem_available] + refine ⟨Fin.last (n + g₁), fun x => ?_⟩ + rw [Program.trace_gate_last] + change I op (fun i => p.trace I x (wires i)) = _ + simp only [hw] + +/-- Combine a finite family of target sets, retaining all earlier results. -/ +theorem biUnion (indices : Finset ι) (targets : ι → Set ((Fin n → U) → U)) + (cost : ι → ℕ) (h : ∀ i ∈ indices, Synthesis I s (targets i) (cost i)) : + Synthesis I s (⋃ i ∈ indices, targets i) (∑ i ∈ indices, cost i) := by + classical + induction indices using Finset.induction_on with + | empty => exact of_subset (by simp) + | @insert i indices hi ih => + simpa [Finset.sum_insert hi] using + (h i (by simp)).union (ih (fun j hj => h j (by simp [hj]))) + +/-- Combine target sets indexed by a finite type. -/ +theorem iUnion [Fintype ι] (targets : ι → Set ((Fin n → U) → U)) (cost : ι → ℕ) + (h : ∀ i, Synthesis I s (targets i) (cost i)) : + Synthesis I s (⋃ i, targets i) (∑ i, cost i) := by + simpa using biUnion Finset.univ targets cost (fun i _ => h i) + +/-- Simultaneously synthesize an indexed finite family of functions. -/ +theorem family [Fintype ι] (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (h : ∀ i, Synthesis I s {f i} (cost i)) : + Synthesis I s (Set.range f) (∑ i, cost i) := by + simpa using iUnion (fun i => {f i}) cost h + +/-- Synthesize every argument, then apply an operation with one further gate. -/ +theorem gate_of_syntheses (op : σ.Op) (args : Fin (σ.Arity op) → (Fin n → U) → U) + (cost : Fin (σ.Arity op) → ℕ) (h : ∀ i, Synthesis I s {args i} (cost i)) : + Synthesis I s {fun x => I op (fun i => args i x)} ((∑ i, cost i) + 1) := + (family args cost h).comp (gate op args (fun i => Set.mem_union_right _ ⟨i, rfl⟩)) + +/-- A nullary operation supplies its interpreted constant with one gate. -/ +theorem nullary (op : σ.Op) (arity : σ.Arity op = 0) : + Synthesis I s {fun _ => I op (fun i => Fin.elim0 (Fin.cast arity i))} 1 := + gate op (fun i _ => Fin.elim0 (Fin.cast arity i)) (fun i => Fin.elim0 (Fin.cast arity i)) + +/-- Feed a synthesized function to every argument of an operation, using one further gate. +In particular, this applies a unary operation. -/ +theorem unary (h : Synthesis I s {f} a) (op : σ.Op) : + Synthesis I s {fun x => I op (fun _ => f x)} (a + 1) := + h.comp (gate op (fun _ => f) (by simp)) + +/-- Feed `f` to argument zero and `g` to the remaining arguments, using one further gate. +For a binary operation, these are its two arguments. -/ +theorem binary (hf : Synthesis I s {f} a) (hg : Synthesis I s {g} b) (op : σ.Op) : + Synthesis I s {fun x => I op (fun i => if i.val = 0 then f x else g x)} + (a + b + 1) := by + simpa only [ite_apply] using (hf.union hg).comp + (gate op (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp)) + +/-- Apply a synthesis bound to two previously synthesized arguments. The combining +construction can use several gates and can reuse either argument. -/ +theorem combine {result : (Fin n → U) → U} {c : ℕ} + (hf : Synthesis I s {f} a) (hg : Synthesis I s {g} b) + (h : Synthesis I {f, g} {result} c) : Synthesis I s {result} (a + b + c) := by + apply (hf.union hg).comp + apply h.mono ?_ Set.Subset.rfl le_rfl + intro k hk + exact Set.mem_union_right _ (by simpa [or_comm] using hk) + +/-- Fold an ordered list of synthesized functions. No algebraic laws are needed for the +combining operation. The seed and the combining construction have their own gate budgets. -/ +theorem foldr (op : U → U → U) (combineCost : ℕ) + (hop : ∀ f g : (Fin n → U) → U, + Synthesis I {f, g} {fun x => op (f x) (g x)} combineCost) + (indices : List ι) (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (seed : (Fin n → U) → U) (hseed : Synthesis I s {seed} a) + (h : ∀ i ∈ indices, Synthesis I s {f i} (cost i)) : + Synthesis I s {fun x => indices.foldr (fun i acc => op (f i x) acc) (seed x)} + ((indices.map fun i => cost i + combineCost).sum + a) := by + induction indices with + | nil => simpa using hseed + | cons i indices ih => + have step := (h i (by simp)).combine + (ih (fun j hj => h j (by simp [hj]))) (hop _ _) + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using step + +/-- Fold a finite set of synthesized functions with a commutative associative operation. +The seed need not be an identity or a constant, and the combining construction may use +several gates. -/ +theorem finset_fold (op : U → U → U) [Std.Commutative op] [Std.Associative op] + (combineCost : ℕ) (hop : ∀ f g : (Fin n → U) → U, + Synthesis I {f, g} {fun x => op (f x) (g x)} combineCost) + (indices : Finset ι) (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (seed : (Fin n → U) → U) (hseed : Synthesis I s {seed} a) + (h : ∀ i ∈ indices, Synthesis I s {f i} (cost i)) : + Synthesis I s {fun x => indices.fold op (seed x) (fun i => f i x)} + ((∑ i ∈ indices, (cost i + combineCost)) + a) := by + classical + induction indices using Finset.induction_on with + | empty => simpa using hseed + | @insert i indices hi ih => + have step := (h i (by simp)).combine + (ih (fun j hj => h j (by simp [hj]))) (hop _ _) + simpa [Finset.fold_insert hi, Finset.sum_insert hi, + Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using step + +/-- Select a finite family of outputs from a synthesis bound. Selecting outputs, including +repeated outputs or an empty family, requires no additional gates. -/ +theorem exists_circuit_family {m cost : ℕ} {f : Fin m → (Fin n → U) → U} + (h : Synthesis I (inputs n) (Set.range f) cost) : + ∃ g ≤ cost, ∃ c : Circuit σ n g m, ∀ x j, c.eval I x j = f j x := by + classical + obtain ⟨g, p, hg, _, hout⟩ := h 0 .empty (inputs_subset_available _) + choose wires hw using fun j => mem_available.mp (hout ⟨j, rfl⟩) + exact ⟨g, by simpa using hg, ⟨p, wires⟩, fun x j => hw j x⟩ + +/-- Extract a single-output circuit from a synthesis bound on the input projections. -/ +theorem exists_circuit {cost : ℕ} (h : Synthesis I (inputs n) {f} cost) : + ∃ g ≤ cost, ∃ c : Circuit σ n g 1, c.Computes I f := by + have h' : Synthesis I (inputs n) (Set.range fun _ : Fin 1 => f) cost := by + simpa using h + obtain ⟨g, hg, c, hc⟩ := h'.exists_circuit_family + exact ⟨g, hg, c, fun x => hc x 0⟩ + +end Synthesis +end Cslib.Circuits diff --git a/Cslib/Foundations/Data/Nat/Asymptotics.lean b/Cslib/Foundations/Data/Nat/Asymptotics.lean new file mode 100644 index 000000000..1570051da --- /dev/null +++ b/Cslib/Foundations/Data/Nat/Asymptotics.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Init +public import Mathlib.Data.Nat.Log +public import Mathlib.Order.Filter.AtTopBot.Defs +import Mathlib.Analysis.SpecificLimits.Normed + +/-! +# Asymptotic bounds on natural numbers + +For any natural base greater than one, exponentials eventually dominate fixed multiples of +powers, and fixed multiples of logarithms are eventually at most the input. The inequalities +are stated in `ℕ`; the polynomial bound specializes Mathlib's +`isLittleO_pow_const_const_pow_of_one_lt`. +-/ + +public section + +open Filter + +namespace Nat + +/-- Every fixed multiple of a power is eventually at most an exponential of base greater +than one. -/ +theorem eventually_mul_pow_le_pow (c k : ℕ) {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, c * n ^ k ≤ b ^ n := by + have hbR : (1 : ℝ) < b := by exact_mod_cast hb + have h := Asymptotics.isLittleO_iff_nat_mul_le.mp + (isLittleO_pow_const_const_pow_of_one_lt (R := ℝ) k hbR) c + filter_upwards [h] with n hn + exact_mod_cast (by simpa using hn : (c : ℝ) * n ^ k ≤ (b : ℝ) ^ n) + +/-- Every fixed multiple of the logarithm in a base greater than one is eventually at most +the input. -/ +theorem eventually_mul_log_le (c : ℕ) {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, c * log b n ≤ n := by + obtain ⟨N, hN⟩ := eventually_atTop.mp (eventually_mul_pow_le_pow c 1 hb) + filter_upwards [eventually_ge_atTop (b ^ N)] with n hn + have hn0 : n ≠ 0 := ne_of_gt ((pow_pos (by omega) N).trans_le hn) + have hh : c * log b n ≤ b ^ log b n := by + simpa using hN (log b n) (le_log_of_pow_le hb hn) + exact hh.trans (pow_log_le_self b hn0) + +/-- Every fixed multiple of the binary logarithm is eventually at most the input. -/ +theorem eventually_mul_log2_le (c : ℕ) : + ∀ᶠ n : ℕ in atTop, c * log2 n ≤ n := by + simpa only [log2_eq_log_two] using eventually_mul_log_le c one_lt_two + +end Nat diff --git a/CslibTests.lean b/CslibTests.lean index 016de8648..c40d862e5 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -1,4 +1,5 @@ import CslibTests.Bisimulation +import CslibTests.BooleanCircuits import CslibTests.CCS import CslibTests.CCS.VendingMachine import CslibTests.CLL @@ -25,3 +26,4 @@ import CslibTests.MultiTapeComplexity import CslibTests.PACLearning import CslibTests.Reduction import CslibTests.StatefulProcesses +import CslibTests.Synthesis diff --git a/CslibTests/BooleanCircuits.lean b/CslibTests/BooleanCircuits.lean new file mode 100644 index 000000000..ea0945538 --- /dev/null +++ b/CslibTests/BooleanCircuits.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Boolean.Lupanov + +/-! +# Boolean synthesis tests + +Zero-input constants, zero-gate projections, and shared AND/NAND outputs. +-/ + +namespace CslibTests.BooleanCircuits + +open Cslib.Circuits Cslib.Circuits.Boolean + +example (value : Bool) : + ∃ g ≤ 1, ∃ c : Circuit signature 0 g 1, c.Computes interpretation (fun _ => value) := + (Synthesis.const (s := inputs 0) value).exists_circuit + +example {n : ℕ} (i : Fin n) : + ∃ g ≤ 0, ∃ c : Circuit signature n g 1, c.Computes interpretation (fun x => x i) := by + have h : Synthesis interpretation (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + exact h.exists_circuit + +example : ¬ (Circuit.id signature 1).Computes interpretation (fun x => !x 0) := by + intro h + have := h (fun _ => true) + simp at this + +private def conjunction : BooleanFunction 2 := fun x => x 0 && x 1 + +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 2, + ∀ x, c.eval interpretation x 0 = conjunction x ∧ + c.eval interpretation x 1 = !conjunction x := by + have hand : Synthesis interpretation (inputs 2) {conjunction} 1 := + Synthesis.gate (I := interpretation) .and (fun i x => x i) (fun i => ⟨i, rfl⟩) + have hkeep : Synthesis interpretation (inputs 2 ∪ {conjunction}) {conjunction} 0 := + Synthesis.of_subset Set.subset_union_right + have h := hand.comp (hkeep.union hkeep.not) + have hout : Synthesis interpretation (inputs 2) + (Set.range fun i : Fin 2 => if i = 0 then conjunction else fun x => !conjunction x) 2 := + h.mono Set.Subset.rfl (by rintro _ ⟨i, rfl⟩; dsimp only; split <;> simp) le_rfl + obtain ⟨g, hg, c, hc⟩ := hout.exists_circuit_family + exact ⟨g, hg, c, fun x => ⟨by simpa using hc x 0, by simpa using hc x 1⟩⟩ + +end CslibTests.BooleanCircuits diff --git a/CslibTests/Synthesis.lean b/CslibTests/Synthesis.lean new file mode 100644 index 000000000..de05f1718 --- /dev/null +++ b/CslibTests/Synthesis.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Synthesis +import Mathlib.Data.Fintype.Card + +/-! +# Generic synthesis tests + +These examples use arbitrary carriers and an infinite arithmetic signature with unbounded +arities. They exercise shared outputs, ordered and unordered folds, and empty constructions. +-/ + +namespace CslibTests.Synthesis + +open Cslib.Circuits + +universe v u + +example {σ : Signature.{v}} {U : Type u} (I : Interpretation σ U) {n : ℕ} (i : Fin n) : + ∃ g ≤ 0, ∃ c : Circuit σ n g 1, c.Computes I (fun x => x i) := by + have h : Synthesis I (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + exact h.exists_circuit + +example {σ : Signature.{v}} {U : Type u} (I : Interpretation σ U) : + ∃ g ≤ 0, ∃ c : Circuit σ 0 g 0, ∀ x j, c.eval I x j = Fin.elim0 j := by + have h : Synthesis I (inputs 0) (Set.range fun (j : Fin 0) (_ : Fin 0 → U) => Fin.elim0 j) + 0 := Synthesis.of_subset (by rintro _ ⟨j, rfl⟩; exact Fin.elim0 j) + exact h.exists_circuit_family + +inductive Op where + | const (value : ℕ) + | add + | mul + | sub + | total (arity : ℕ) + +abbrev signature : Signature where + Op := Op + Arity + | .const _ => 0 + | .add | .mul | .sub => 2 + | .total k => k + +def interpretation : Interpretation signature ℕ + | .const value, _ => value + | .add, x => x 0 + x 1 + | .mul, x => x 0 * x 1 + | .sub, x => x 0 - x 1 + | .total _, x => ∑ i, x i + +private theorem projection {n : ℕ} (i : Fin n) : + Synthesis interpretation (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + +private theorem add_available {n : ℕ} (f g : (Fin n → ℕ) → ℕ) : + Synthesis interpretation {f, g} {fun x => f x + g x} 1 := by + simpa [interpretation] using Synthesis.gate (I := interpretation) (s := {f, g}) .add + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + +private theorem sub_available {n : ℕ} (f g : (Fin n → ℕ) → ℕ) : + Synthesis interpretation {f, g} {fun x => f x - g x} 1 := by + simpa [interpretation] using Synthesis.gate (I := interpretation) (s := {f, g}) .sub + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + +example (value : ℕ) : + ∃ g ≤ 1, ∃ c : Circuit signature 0 g 1, c.Computes interpretation (fun _ => value) := + (Synthesis.nullary (I := interpretation) (s := inputs 0) (.const value) rfl).exists_circuit + +example (n : ℕ) : + ∃ g ≤ 1, ∃ c : Circuit signature n g 1, + c.Computes interpretation (fun x => ∑ i, x i) := by + have h := Synthesis.gate_of_syntheses (I := interpretation) (.total n) + (fun i x => x i) (fun _ => 0) projection + simpa [interpretation] using h.exists_circuit + +private def product (x : Fin 2 → ℕ) : ℕ := x 0 * x 1 + +private def sharedOutputs (i : Fin 3) (x : Fin 2 → ℕ) : ℕ := + if i = 1 then product x + x 0 else product x + +-- The product is computed once, used by the sum, and selected twice as an output. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 3, + ∀ x i, c.eval interpretation x i = sharedOutputs i x := by + have hproduct : Synthesis interpretation (inputs 2) {product} 1 := + Synthesis.gate (I := interpretation) .mul (fun i x => x i) (fun i => ⟨i, rfl⟩) + have hkeep : Synthesis interpretation (inputs 2 ∪ {product}) {product} 0 := + Synthesis.of_subset Set.subset_union_right + have hinput : Synthesis interpretation (inputs 2 ∪ {product}) {fun x => x 0} 0 := + (projection 0).mono Set.subset_union_left Set.Subset.rfl le_rfl + have hsum : Synthesis interpretation (inputs 2 ∪ {product}) {fun x => product x + x 0} 1 := by + simpa [interpretation] using hkeep.binary hinput .add + have h := hproduct.comp (hkeep.union hsum) + have hout : Synthesis interpretation (inputs 2) (Set.range sharedOutputs) 2 := + h.mono Set.Subset.rfl (by rintro _ ⟨i, rfl⟩; unfold sharedOutputs; split <;> simp) le_rfl + exact hout.exists_circuit_family + +-- Subtraction is neither commutative nor associative; the list determines the order. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 1, + c.Computes interpretation (fun x => x 0 - (x 1 - x 0)) := by + have h := Synthesis.foldr (I := interpretation) (· - ·) 1 sub_available + ([0, 1] : List (Fin 2)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +-- A finite-set fold may start from an available, nonconstant seed. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 1, + c.Computes interpretation + (fun x => Finset.univ.fold (· + ·) (x 0) (fun i : Fin 2 => x i)) := by + have h := Synthesis.finset_fold (I := interpretation) (· + ·) 1 add_available + (Finset.univ : Finset (Fin 2)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +example : ∃ g ≤ 0, ∃ c : Circuit signature 1 g 1, + c.Computes interpretation (fun x => x 0) := by + have h := Synthesis.finset_fold (I := interpretation) (· + ·) 1 add_available + (∅ : Finset (Fin 1)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +end CslibTests.Synthesis diff --git a/references.bib b/references.bib index 72051ea9c..46a4b5ed0 100644 --- a/references.bib +++ b/references.bib @@ -428,6 +428,41 @@ @article{ ShepherdsonSturgis1963 address = {New York, NY, USA} } +@article{Shannon1949, + author = {Claude E. Shannon}, + title = {The Synthesis of Two-Terminal Switching Circuits}, + journal = {Bell System Technical Journal}, + volume = {28}, + number = {1}, + pages = {59--98}, + year = {1949}, + doi = {10.1002/j.1538-7305.1949.tb03624.x}, + url = {https://deeplearning.cs.cmu.edu/F24/document/readings/Shannon49.pdf} +} + +@article{Lupanov1958, + author = {Oleg B. Lupanov}, + title = {On a Method of Circuit Synthesis}, + journal = {Izvestiya Vysshikh Uchebnykh Zavedenii. Radiofizika}, + volume = {1}, + number = {1}, + pages = {120--140}, + year = {1958}, + note = {In Russian}, + url = {https://radiophysics.unn.ru/sites/default/files/papers/1958_1_120.pdf} +} + +@book{Jukna2012, + author = {Stasys Jukna}, + title = {Boolean Function Complexity: Advances and Frontiers}, + series = {Algorithms and Combinatorics}, + volume = {27}, + publisher = {Springer}, + year = {2012}, + doi = {10.1007/978-3-642-24508-4}, + url = {https://web.vu.lt/mif/s.jukna/boolean/index.html} +} + @inproceedings{Valiant1984, author = {Valiant, L. G.}, title = {A Theory of the Learnable}, From ba09df87dc2d28c353fc1a0e9c9180db9dc2238d Mon Sep 17 00:00:00 2001 From: Ching-Tsun Chou Date: Sun, 20 Sep 2026 01:09:07 +0000 Subject: [PATCH 89/93] feat(Language): characterizing regular languages using syntactic monoids (#903) This PR develops yet another characterization of regular languages: a language is regular if and only if its syntactic monoid is finite. The syntactic monoid is the quotient of the free monoid by the Myhill congruence, which is a two-sided congruence on finite words that is finer than the Nerode congruence used in the Myhill-Nerode theorem. As part of this PR, both left and two-sided congruences on finite words are defined and all congruences on finite words are moved from the namespace `Cslib` to the more appropriate namespace `Language`. --- Cslib.lean | 4 +- Cslib/Computability/Automata/DA/Congr.lean | 29 +++-- .../Languages/Congruences/Basic.lean | 65 ++++++++++ .../Congruences/BuchiCongruence.lean | 5 +- .../Congruences/MyhillCongruence.lean | 113 ++++++++++++++++++ .../Congruences/RightCongruence.lean | 41 ------- .../Computability/Languages/MyhillNerode.lean | 2 +- .../Languages/RegularLanguage.lean | 3 +- .../Languages/SyntacticMonoid.lean | 48 ++++++++ Cslib/Foundations/Semantics/FLTS/Basic.lean | 4 + references.bib | 10 ++ 11 files changed, 269 insertions(+), 55 deletions(-) create mode 100644 Cslib/Computability/Languages/Congruences/Basic.lean create mode 100644 Cslib/Computability/Languages/Congruences/MyhillCongruence.lean delete mode 100644 Cslib/Computability/Languages/Congruences/RightCongruence.lean create mode 100644 Cslib/Computability/Languages/SyntacticMonoid.lean diff --git a/Cslib.lean b/Cslib.lean index 212283054..dcbf713a9 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -51,8 +51,9 @@ public import Cslib.Computability.Distributed.FLP.Impossibility public import Cslib.Computability.Distributed.FLP.OnePseudoConsensus public import Cslib.Computability.Distributed.FLP.PseudoConsensus public import Cslib.Computability.Distributed.FLP.ZeroConsensus +public import Cslib.Computability.Languages.Congruences.Basic public import Cslib.Computability.Languages.Congruences.BuchiCongruence -public import Cslib.Computability.Languages.Congruences.RightCongruence +public import Cslib.Computability.Languages.Congruences.MyhillCongruence public import Cslib.Computability.Languages.ExampleEventuallyZero public import Cslib.Computability.Languages.Language public import Cslib.Computability.Languages.LanguageHom @@ -61,6 +62,7 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness +public import Cslib.Computability.Languages.SyntacticMonoid public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound public import Cslib.Computability.Machines.Turing.MultiTape.Configuration diff --git a/Cslib/Computability/Automata/DA/Congr.lean b/Cslib/Computability/Automata/DA/Congr.lean index d4c435637..25937ab90 100644 --- a/Cslib/Computability/Automata/DA/Congr.lean +++ b/Cslib/Computability/Automata/DA/Congr.lean @@ -7,17 +7,17 @@ Authors: Ching-Tsun Chou module public import Cslib.Computability.Automata.DA.Basic -public import Cslib.Computability.Languages.Congruences.RightCongruence +public import Cslib.Computability.Languages.Congruences.Basic /-! # Deterministic automaton corresponding to a right congruence. -/ @[expose] public section -namespace Cslib +variable {Symbol : Type*} -open scoped FLTS RightCongruence +namespace Language -variable {Symbol : Type*} +open Cslib /-- Every right congruence gives rise to a DA whose states are the equivalence classes of the right congruence, whose start state is the empty word, and whose transition functiuon @@ -28,11 +28,16 @@ def RightCongruence.toDA [c : RightCongruence Symbol] : Automata.DA (Quotient c. tr s x := Quotient.lift (fun u ↦ ⟦ u ++ [x] ⟧) (by intro u v h_eq apply Quotient.sound - exact right_cov.elim [x] h_eq + exact c.right_cov.elim [x] h_eq ) s start := ⟦ [] ⟧ -namespace Automata.DA +end Language + +namespace Cslib.Automata.DA + +open Language +open scoped FLTS RightCongruence variable [c : RightCongruence Symbol] @@ -49,6 +54,14 @@ theorem congr_mtr_eq {xs : List Symbol} : specialize h_ind (xs := ys.reverse) (by grind) grind [Quotient.lift_mk] +/-- After consuming a finite word `ys` from the state `⟦ xs ⟧`, `c.toDA` reaches +the state `⟦ xs ++ ys ⟧`. -/ +@[simp, scoped grind =] +theorem congr_mtr_append {xs ys : List Symbol} : + c.toDA.mtr ⟦ xs ⟧ ys = ⟦ xs ++ ys ⟧ := by + nth_rewrite 1 [← congr_mtr_eq, ← FLTS.mtr_append_eq] + rw [congr_mtr_eq] + namespace FinAcc open Acceptor RightCongruence @@ -66,6 +79,4 @@ theorem congr_language_eq {a : Quotient c.eq} : language (FinAcc.mk c.toDA {a}) end FinAcc -end Automata.DA - -end Cslib +end Cslib.Automata.DA diff --git a/Cslib/Computability/Languages/Congruences/Basic.lean b/Cslib/Computability/Languages/Congruences/Basic.lean new file mode 100644 index 000000000..a895216e3 --- /dev/null +++ b/Cslib/Computability/Languages/Congruences/Basic.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Init +public import Mathlib.Computability.Language + +/-! +# Right Congruence + +This file contains basic definitions about left, right, and (two-sided) congruences +on finite sequences. +-/ + +@[expose] public section + +namespace Language + +variable {α : Type*} + +/-- A right congruence is an equivalence relation on finite sequences (represented by lists) +that is preserved by concatenation on the right. The equivalence relation is represented +by a setoid to to enable ready access to the quotient construction. -/ +class RightCongruence (α : Type*) extends eq : Setoid (List α) where + right_cov : CovariantClass _ _ (fun x y => y ++ x) eq + +namespace RightCongruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : RightCongruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end RightCongruence + +/-- A left congruence is an equivalence relation on finite sequences (represented by lists) +that is preserved by concatenation on the left. The equivalence relation is represented +by a setoid to to enable ready access to the quotient construction. -/ +class LeftCongruence (α : Type*) extends eq : Setoid (List α) where + left_cov : CovariantClass _ _ (fun x y => x ++ y) eq + +namespace LeftCongruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : LeftCongruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end LeftCongruence + +/-- A (two-sided) congruence is an equivalence relation on finite sequences (represented by lists) +that is both a left-congruence and a right-congruence. -/ +class Congruence (α : Type*) extends LeftCongruence α, RightCongruence α where + +namespace Congruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : Congruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end Congruence + +end Language diff --git a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean index c9855f073..0444cd330 100644 --- a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean +++ b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean @@ -22,6 +22,7 @@ of ω-regular languages under complementation. namespace Cslib.Automata.NA.Buchi open Function Set Filter ωAcceptor ωLanguage ωSequence +open _root_.Language RightCongruence variable {Symbol : Type*} {State : Type} @@ -186,14 +187,14 @@ theorem buchiFamily_saturation [Inhabited Symbol] : obtain ⟨ss, ⟨h_init, h_exec⟩, h_acc⟩ := h_lang let f (k : ℕ) := xl.length + xls.cumLen k let ts := ωSequence.mk (fun k ↦ ss (f k)) - have (k : ℕ) : xls k ≠ [] := by grind [Language.mem_sub_one] + have (k : ℕ) : xls k ≠ [] := by grind have h_xls_p (k : ℕ) : (xls k).length > 0 := List.length_pos_iff.mpr (this k) have h_xls_e (k : ℕ) : xls k ∈ na.pairLang (ts k) (ts (k + 1)) := by grind [LTS.OmegaExecution.extract_mTr h_exec (?_ : f k ≤ f (k + 1)), LTS.mem_pairLang, extract_append_right_right, add_tsub_cancel_left] have h_yls (k : ℕ) := buchiCongruence_transfer ((h_xls_c k).left) ((h_yls_c k).left) (h_xls_e k) choose sls h_yls_e h_yls_a using h_yls - have (k : ℕ) : yls k ≠ [] := by grind [Language.mem_sub_one] + have (k : ℕ) : yls k ≠ [] := by grind have h_yls_p (k : ℕ) : (yls k).length > 0 := List.length_pos_iff.mpr (this k) obtain ⟨ss1, h_ss1_run, h_ss1_seg⟩ := LTS.OmegaExecution.flatten_execution h_yls_e h_yls_p suffices ∃ᶠ (k : ℕ) in atTop, ss1 k ∈ na.accept by diff --git a/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean b/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean new file mode 100644 index 000000000..6dfaa1f2b --- /dev/null +++ b/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Computability.Languages.MyhillNerode + +/-! # Myhill congruence + +The Myhill congruence of a language `l` is a two-sided congruence that is finer than +the Nerode congruence of the same language `l` (which is a right congruence). It will be +used to define the syntactic monoid of `l`. + +## References + +[Holcombe1982] Holcombe, W.M.L. (1982). Algebraic automata theory. Section 5.3 +-/ + +@[expose] public section + +variable {α : Type} + +namespace Language + +open Cslib Language Automata DA FinAcc Acceptor +open scoped RightCongruence + +/-- The Myhill congruence of a language `l` is the two-sided congruence on finite words +such that two words are related iff all their two-sided extensions are either both in `l` +or both not in `l`. -/ +@[implicit_reducible] +def MyhillCongruence (l : Language α) : Congruence α where + r x y := ∀ w z, w ++ x ++ z ∈ l ↔ w ++ y ++ z ∈ l + iseqv.refl := by grind + iseqv.symm := by grind + iseqv.trans := by grind + right_cov.elim := by grind [Covariant] + left_cov.elim := by grind [Covariant] + +/-- The Myhill quotient of a language `l` is the quotient of its Myhill congruence. -/ +abbrev MyhillQuotient (l : Language α) := Quotient l.MyhillCongruence.eq + +/-- Given a language `l` and a finite word `x`, the Nerode map is a map from the Nerode quotient +to itself induced by the `x`-transition of the Nerode congruence deterministic automaton of `l`. -/ +def nerodeMap (l : Language α) (x : List α) : l.NerodeQuotient → l.NerodeQuotient := + fun q ↦ l.NerodeCongruenceDA.mtr q x + +theorem nerodeMap_append (l : Language α) (x y : List α) : + l.nerodeMap (x ++ y) = l.nerodeMap y ∘ l.nerodeMap x := by + ext q + simp [nerodeMap, FLTS.mtr_append_eq] + +theorem nerodeMap_accept (l : Language α) (x : List α) : + x ∈ l ↔ l.nerodeMap x l.NerodeCongruenceDA.start ∈ l.NerodeCongruenceDA.accept := by + nth_rewrite 1 [← nerodeCongruenceDA_language_eq l] + constructor <;> intro <;> assumption + +/-- The Myhill congruence is in fact the congruence induced by the Nerode map. -/ +theorem myhillCongruence_iff (l : Language α) (x y : List α) : + l.MyhillCongruence.r x y ↔ l.nerodeMap x = l.nerodeMap y := by + constructor <;> intro h + · ext q + obtain ⟨w, rfl⟩ := Quotient.mk_surjective q + simp only [nerodeMap, NerodeCongruenceDA, congr_mtr_append, Quotient.eq_iff_equiv] + exact h w + · intro w z + simp [nerodeMap_accept, nerodeMap_append, h] + +/-- The Myhill quotient of a regular language is finite. -/ +theorem IsRegular.finite_myhillQuotient {l : Language α} + (h : l.IsRegular) : Finite (l.MyhillQuotient) := by + have h1 : l.MyhillCongruence.eq = Setoid.ker l.nerodeMap := by + ext + exact myhillCongruence_iff _ _ _ + rw [MyhillQuotient, h1] + have := IsRegular.finite_nerodeQuotient h + have : Finite (l.NerodeQuotient → l.NerodeQuotient) := inferInstance + exact Finite.of_injective _ (Setoid.kerLift_injective l.nerodeMap) + +/-- The deterministic automaton corresponding to the Myhill congruence of a language `l`. -/ +def myhillCongruenceDA (l : Language α) : DA.FinAcc (l.MyhillQuotient) α := + FinAcc.mk l.MyhillCongruence.toDA ((⟦·⟧) '' l) + +/-- The deterministic automaton corresponding to the Myhill congruence of a language `l` +accepts the same language `l`. -/ +theorem myhillCongruenceDA_language_eq (l : Language α) : + language (l.myhillCongruenceDA) = l := by + ext x + simp only [myhillCongruenceDA, language, Acceptor.Accepts, + congr_mtr_eq (c := l.MyhillCongruence.toRightCongruence)] + constructor + · rintro ⟨y, hy, heq⟩ + have h1 := Quotient.eq.mp heq [] [] + simp only [List.append_nil, List.nil_append] at h1 + simpa [← h1] + · intro hx + use x, hx + congr + +/-- A language is regular if and only if its Myhill quotient is finite. -/ +theorem IsRegular.iff_finite_myhillQuotient (l : Language α) : + l.IsRegular ↔ Finite (l.MyhillQuotient) := by + apply Iff.intro + case mp => exact IsRegular.finite_myhillQuotient + case mpr => + intro h + apply IsRegular.iff_dfa.mpr + use l.MyhillQuotient, h, l.myhillCongruenceDA, myhillCongruenceDA_language_eq l + +end Language diff --git a/Cslib/Computability/Languages/Congruences/RightCongruence.lean b/Cslib/Computability/Languages/Congruences/RightCongruence.lean deleted file mode 100644 index b1da41a95..000000000 --- a/Cslib/Computability/Languages/Congruences/RightCongruence.lean +++ /dev/null @@ -1,41 +0,0 @@ -/- -Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Ching-Tsun Chou --/ - -module - -public import Cslib.Init -public import Mathlib.Computability.Language - -/-! -# Right Congruence - -This file contains basic definitions about right congruences on finite sequences. - -NOTE: Left congruences and two-sided congruences can be similarly defined. -But they are left to future work because they are not needed for now. --/ - -@[expose] public section - -namespace Cslib - -/-- A right congruence is an equivalence relation on finite sequences (represented by lists) -that is preserved by concatenation on the right. The equivalence relation is represented -by a setoid to to enable ready access to the quotient construction. -/ -class RightCongruence (α : Type*) extends eq : Setoid (List α) where - right_cov : CovariantClass _ _ (fun x y => y ++ x) eq - -namespace RightCongruence - -variable {α : Type*} - -/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ -abbrev eqvCls [c : RightCongruence α] (a : Quotient c.eq) : Language α := - (Quotient.mk c.eq) ⁻¹' {a} - -end RightCongruence - -end Cslib diff --git a/Cslib/Computability/Languages/MyhillNerode.lean b/Cslib/Computability/Languages/MyhillNerode.lean index 9823cbe59..568a37452 100644 --- a/Cslib/Computability/Languages/MyhillNerode.lean +++ b/Cslib/Computability/Languages/MyhillNerode.lean @@ -161,7 +161,7 @@ end Language namespace Cslib.Automata.DA.FinAcc open Cslib Cslib.Language Automata DA FinAcc Acceptor -open scoped RightCongruence +open _root_.Language RightCongruence /-- The minimal DFA accepting `l` has the same number of states as the number of equivalence classes of the Nerode congruence on `l`. -/ diff --git a/Cslib/Computability/Languages/RegularLanguage.lean b/Cslib/Computability/Languages/RegularLanguage.lean index f14436718..c38577a31 100644 --- a/Cslib/Computability/Languages/RegularLanguage.lean +++ b/Cslib/Computability/Languages/RegularLanguage.lean @@ -29,7 +29,7 @@ public import Mathlib.Data.Set.Card namespace Cslib.Language -open Set List Prod Automata Acceptor RightCongruence +open Set List Prod Automata Acceptor open scoped Computability FLTS DA NA DA.FinAcc NA.FinAcc variable {Symbol Symbol' : Type*} @@ -202,6 +202,7 @@ theorem IsRegular.kstar {l : Language Symbol} obtain ⟨State, h_fin, nfa, rfl⟩ := h use Unit ⊕ Option State, inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l +open _root_.Language RightCongruence in /-- If a right congruence is of finite index, then each of its equivalence classes is regular. -/ @[simp] theorem IsRegular.congr_fin_index {Symbol : Type} diff --git a/Cslib/Computability/Languages/SyntacticMonoid.lean b/Cslib/Computability/Languages/SyntacticMonoid.lean new file mode 100644 index 000000000..00a89e8f5 --- /dev/null +++ b/Cslib/Computability/Languages/SyntacticMonoid.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Computability.Languages.Congruences.MyhillCongruence + +/-! # Syntactic monoid + +This file defines the syntactic monoid of a language `l` and shows that +`l` is regular if and only if its syntactic monoid is finite. + +## References + +[Holcombe1982] Holcombe, W.M.L. (1982). Algebraic automata theory. Section 5.3 +-/ + +@[expose] public section + +variable {α : Type} + +namespace Language + +open Cslib.Language + +/-- Converting a (two-sided) congruence `c` on finite words to a congruence relation +on the (multiplicative) free monoid. -/ +def Congruence.toCon [c : Congruence α] : Con (FreeMonoid α) where + r := c.r + iseqv := c.iseqv + mul' {w x y z} h_wx h_yz := by + have h_wyxy : c.eq (w * y) (x * y) := c.right_cov.elim y h_wx + have h_xyxz : c.eq (x * y) (x * z) := c.left_cov.elim x h_yz + exact c.iseqv.trans h_wyxy h_xyxz + +/-- The syntactic monoid of a language `l` is the quotient of the free monoid +by the Myhill congruence of `l`. -/ +abbrev SyntacticMonoid (l : Language α) := l.MyhillCongruence.toCon.Quotient + +/-- A language `l` is regular if and only if its syntactic monoid is finite. -/ +theorem IsRegular.iff_finite_syntacticMonoid (l : Language α) : + l.IsRegular ↔ Finite (l.SyntacticMonoid) := + IsRegular.iff_finite_myhillQuotient l + +end Language diff --git a/Cslib/Foundations/Semantics/FLTS/Basic.lean b/Cslib/Foundations/Semantics/FLTS/Basic.lean index fcae4dcbe..2a20e25e4 100644 --- a/Cslib/Foundations/Semantics/FLTS/Basic.lean +++ b/Cslib/Foundations/Semantics/FLTS/Basic.lean @@ -53,6 +53,10 @@ theorem mtr_concat_eq {flts : FLTS State Label} {s : State} {μs : List Label} { flts.mtr s (μs ++ [μ]) = flts.tr (flts.mtr s μs) μ := by grind +theorem mtr_append_eq {flts : FLTS State Label} {s : State} {μs1 μs2 : List Label} : + flts.mtr s (μs1 ++ μs2) = flts.mtr (flts.mtr s μs1) μs2 := by + simp [mtr] + end FLTS end Cslib diff --git a/references.bib b/references.bib index 46a4b5ed0..afbe3d9b0 100644 --- a/references.bib +++ b/references.bib @@ -255,6 +255,16 @@ @article{ Hennessy1985 bibsource = {dblp computer science bibliography, https://dblp.org} } +@book{Holcombe1982, + title={Algebraic automata theory}, + author={Holcombe, W. M. L.}, + volume={1}, + series={Cambridge Studies in Advanced Mathematics}, + year={1982}, + publisher={Cambridge University Press}, + isbn={0-521-60492-3} +} + @book{ KatzLindell2020, author = {Jonathan Katz and Yehuda Lindell}, From e68a7a7a2566ea0230468d731b7e79eaa8adb3d4 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Mon, 21 Sep 2026 12:41:10 +0000 Subject: [PATCH 90/93] feat(Governance): add Samuel Schlesinger to maintainers (#930) Adds Samuel Schlesinger to the area maintainers for complexity, crypto, and learning theory. --- GOVERNANCE.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GOVERNANCE.md b/GOVERNANCE.md index b9b9a147c..7eeeed33d 100644 --- a/GOVERNANCE.md +++ b/GOVERNANCE.md @@ -45,6 +45,7 @@ Area maintainers are trusted contributors who take ownership of specific areas o - Chris Henson (@chenson2018), Drexel University. Areas: Lambda calculus, metaprogramming. - Kim Morrison (@kim-em), Lean FRO. Areas: Continuous Integration and Deployment (CI/CD) with upstream (Lean, mathlib). - Alexandre Rademaker (@arademaker), Renaissance Philanthropy and Getulio Vargas Foundation. Areas: logic. +- Samuel Schlesinger (@SamuelSchlesinger), Google. Areas: complexity, cryptography, and learning theory. - Sorrachai Yingchareonthawornchai (@sorrachai), ETH Zurich. Areas: algorithms and data structures. ## Reviewers @@ -53,7 +54,6 @@ Reviewers are trusted contributors who provide regular reviewing and technical g - Ching-Tsun Chou (@ctchou). - Christian Reitwiessner (@crei). -- Samuel Schlesinger (@SamuelSchlesinger). - Thomas Waring (@thomaskwaring). - Eric Wieser (@eric-wieser), Google DeepMind. - Xueying Qin (@XYUnknown), FORM, University of Southern Denmark. From c906ed2866bdb69bd6f263a0c0499c7d2b2ae3c5 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Mon, 21 Sep 2026 17:19:56 +0000 Subject: [PATCH 91/93] feat(Circuit): prove Shannon lower bound (#891) Add semantic normalization and counting to prove the worst-case 2^n/n lower bound for De Morgan circuits. Assisted by Codex, adapted from https://github.com/samuelSchlesinger/algebraic-circuits. --------- Co-authored-by: Christian Reitwiessner --- Cslib.lean | 7 + Cslib/Computability/Circuit/Basic.lean | 9 + .../Computability/Circuit/Boolean/Basic.lean | 8 +- .../Circuit/Boolean/Counting.lean | 47 ++++ .../Circuit/Boolean/Shannon.lean | 31 +++ Cslib/Computability/Circuit/Counting.lean | 210 ++++++++++++++++++ Cslib/Computability/Circuit/Finite.lean | 84 +++++++ .../Computability/Circuit/Normalization.lean | 71 ++++++ Cslib/Computability/Circuit/Program.lean | 47 ++++ Cslib/Computability/Circuit/Shannon.lean | 148 ++++++++++++ Cslib/Foundations/Data/Nat/Asymptotics.lean | 9 + Cslib/Foundations/Data/Nat/Factorial.lean | 31 +++ CslibTests.lean | 1 + CslibTests/BooleanCircuits.lean | 26 ++- CslibTests/CircuitCounting.lean | 120 ++++++++++ 15 files changed, 846 insertions(+), 3 deletions(-) create mode 100644 Cslib/Computability/Circuit/Boolean/Counting.lean create mode 100644 Cslib/Computability/Circuit/Boolean/Shannon.lean create mode 100644 Cslib/Computability/Circuit/Counting.lean create mode 100644 Cslib/Computability/Circuit/Finite.lean create mode 100644 Cslib/Computability/Circuit/Normalization.lean create mode 100644 Cslib/Computability/Circuit/Shannon.lean create mode 100644 Cslib/Foundations/Data/Nat/Factorial.lean create mode 100644 CslibTests/CircuitCounting.lean diff --git a/Cslib.lean b/Cslib.lean index dcbf713a9..924d7e8b1 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -35,11 +35,17 @@ public import Cslib.Computability.Automata.TwoWayNA.ComplToNA public import Cslib.Computability.Automata.TwoWayNA.OfNA public import Cslib.Computability.Circuit.Basic public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Boolean.Counting public import Cslib.Computability.Circuit.Boolean.Lupanov public import Cslib.Computability.Circuit.Boolean.LupanovConstruction +public import Cslib.Computability.Circuit.Boolean.Shannon public import Cslib.Computability.Circuit.Boolean.Synthesis +public import Cslib.Computability.Circuit.Counting +public import Cslib.Computability.Circuit.Finite public import Cslib.Computability.Circuit.Homomorphism +public import Cslib.Computability.Circuit.Normalization public import Cslib.Computability.Circuit.Program +public import Cslib.Computability.Circuit.Shannon public import Cslib.Computability.Circuit.Signature public import Cslib.Computability.Circuit.Synthesis public import Cslib.Computability.Circuit.Wire @@ -105,6 +111,7 @@ public import Cslib.Foundations.Data.FinFun.Update public import Cslib.Foundations.Data.HasFresh public import Cslib.Foundations.Data.List.IsChainFromTo public import Cslib.Foundations.Data.Nat.Asymptotics +public import Cslib.Foundations.Data.Nat.Factorial public import Cslib.Foundations.Data.Nat.Segment public import Cslib.Foundations.Data.OmegaSequence.Defs public import Cslib.Foundations.Data.OmegaSequence.Flatten diff --git a/Cslib/Computability/Circuit/Basic.lean b/Cslib/Computability/Circuit/Basic.lean index 9671903cf..2f003728d 100644 --- a/Cslib/Computability/Circuit/Basic.lean +++ b/Cslib/Computability/Circuit/Basic.lean @@ -50,6 +50,15 @@ structure Circuit (σ : Signature) (inputCount gateCount outputCount : Nat) wher /-- The input or internal-gate wire carrying each output. -/ outputs : Fin outputCount → Wire inputCount gateCount +/-- A circuit consists of its program and its tuple of output wires. -/ +def Circuit.equiv (σ : Signature) (inputCount gateCount outputCount : Nat) : + Circuit σ inputCount gateCount outputCount ≃ + Program σ inputCount gateCount × (Fin outputCount → Wire inputCount gateCount) where + toFun c := (c.program, c.outputs) + invFun c := ⟨c.1, c.2⟩ + left_inv _ := rfl + right_inv _ := rfl + /-- The zero-gate identity circuit, whose outputs are its inputs. -/ def Circuit.id (σ : Signature) (inputCount : Nat) : Circuit σ inputCount 0 inputCount where program := .empty diff --git a/Cslib/Computability/Circuit/Boolean/Basic.lean b/Cslib/Computability/Circuit/Boolean/Basic.lean index 7dcdc4eee..722f0d8ab 100644 --- a/Cslib/Computability/Circuit/Boolean/Basic.lean +++ b/Cslib/Computability/Circuit/Boolean/Basic.lean @@ -6,6 +6,9 @@ Authors: Samuel Schlesinger module public import Cslib.Computability.Circuit.Basic +public import Mathlib.Data.Fintype.Card +public import Mathlib.Data.Fintype.Sum +public import Mathlib.Tactic.DeriveFintype /-! # Boolean circuits @@ -34,7 +37,10 @@ inductive Op where | and /-- Binary disjunction. -/ | or - deriving DecidableEq + deriving DecidableEq, Fintype + +/-- The De Morgan basis has five operation symbols, counting its two constants. -/ +@[simp] theorem Op.card : Fintype.card Op = 5 := rfl /-- The De Morgan signature. -/ abbrev signature : Signature where diff --git a/Cslib/Computability/Circuit/Boolean/Counting.lean b/Cslib/Computability/Circuit/Boolean/Counting.lean new file mode 100644 index 000000000..ce965ee83 --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Counting.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Counting + +import Mathlib.Tactic.Linarith + +/-! +# Counting De Morgan circuits + +This file specializes the generic circuit counting bound to the five De Morgan operations, +all of arity at most two. The resulting factorial correction is used in Shannon's lower bound. +-/ + +@[expose] public section + +namespace Cslib.Circuits.Boolean + +variable {n s : ℕ} + +/-- Boolean functions on `n` inputs computable with at most `s` De Morgan gates. -/ +noncomputable abbrev computableFunctions (n s : ℕ) : Finset (BooleanFunction n) := + Circuits.computableFunctions interpretation n s + +theorem mem_computableFunctions {f : BooleanFunction n} : + f ∈ computableFunctions n s ↔ ∃ g ≤ s, ∃ c : Circuit signature n g 1, + c.Computes interpretation f := + Circuits.mem_computableFunctions + +/-- The De Morgan counting bound, accounting for gate relabelings. -/ +theorem card_computableFunctions_mul_factorial_le (n s : ℕ) : + (computableFunctions n s).card * s.factorial ≤ + (s + 1) * (5 * (n + s + 1) ^ 2) ^ s * (n + s) := by + apply Circuits.card_computableFunctions_mul_factorial_le interpretation n s + · nlinarith [Nat.le_mul_self (n + s + 1)] + · intro g hg + have h := Line.card_le (σ := signature) n g 2 (fun op => by cases op <;> simp) + simp only [Op.card] at h + exact h.trans (Nat.mul_le_mul_left 5 + (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) 2)) + +end Cslib.Circuits.Boolean diff --git a/Cslib/Computability/Circuit/Boolean/Shannon.lean b/Cslib/Computability/Circuit/Boolean/Shannon.lean new file mode 100644 index 000000000..33901b156 --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Shannon.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Shannon + +/-! +# Shannon's lower bound for De Morgan circuits + +This is the De Morgan specialization of `Cslib.Circuits.Shannon.exists_hard_function`. +Together with Lupanov's construction, it gives the asymptotically sharp gate count `2ⁿ/n`. +-/ + +public section + +namespace Cslib.Circuits.Boolean.Shannon + +/-- For all sufficiently large `n`, some Boolean function on `n` inputs requires +more than `2ⁿ/n` De Morgan gates, counting constants and negations. -/ +theorem exists_hard_function : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : BooleanFunction n, + ∀ {g} (c : Circuit signature n g 1), + c.Computes interpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Circuits.Shannon.exists_hard_function interpretation (fun op => by cases op <;> simp) + +end Cslib.Circuits.Boolean.Shannon diff --git a/Cslib/Computability/Circuit/Counting.lean b/Cslib/Computability/Circuit/Counting.lean new file mode 100644 index 000000000..441369d89 --- /dev/null +++ b/Cslib/Computability/Circuit/Counting.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Finite +public import Cslib.Computability.Circuit.Normalization +public import Mathlib.Data.Finset.Card +public import Mathlib.Data.Nat.Factorial.Basic +public import Mathlib.Tactic.ToAdditive + +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.Order.BigOperators.Group.Finset +import Mathlib.Data.Fintype.BigOperators +import Mathlib.Data.Fintype.Perm +import Mathlib.Tactic.GCongr +import Mathlib.Tactic.NormNum + +/-! +# Counting functions computed by finite circuits + +For a finite signature, only finitely many functions can be computed with a fixed gate budget, +even when the carrier is infinite. We enumerate circuit syntax and collect its scalar functions. +Semantic equality and normalization use classical reasoning; the syntax enumeration is computable. + +After merging gates that compute the same function, a circuit with `g` gates has `g!` distinct +labeled presentations. This factorial correction sharpens the count used in Shannon's lower bound. +The main bound accepts any uniform bound on the number of lines; +`card_computableFunctions_mul_factorial_le_of_arity_le` specializes it to operation arities. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +open scoped BigOperators + +universe v u +variable {σ : Signature.{v}} [Fintype σ.Op] {U : Type u} +variable {I : Interpretation σ U} {n g s : ℕ} + +/-- Scalar functions computable with at most `s` gates. Enumerating circuit syntax makes +this family finite without requiring a finite carrier. -/ +noncomputable def computableFunctions (I : Interpretation σ U) (n s : ℕ) : + Finset ((Fin n → U) → U) := + open scoped Classical in + (Finset.range (s + 1)).biUnion fun g => + Finset.univ.image fun c : Circuit σ n g 1 => fun x => c.eval I x 0 + +@[simp] theorem mem_computableFunctions {f : (Fin n → U) → U} : + f ∈ computableFunctions I n s ↔ ∃ g ≤ s, ∃ c : Circuit σ n g 1, c.Computes I f := by + classical + simp [computableFunctions, Circuit.Computes, funext_iff, Nat.lt_succ_iff] + +/-- Functions computed by circuits with exactly `g` pairwise semantically distinct gates. +Each such function has `g!` distinct presentations obtained by relabeling its chosen circuit. -/ +noncomputable def irredundantFunctions (I : Interpretation σ U) (n g : ℕ) : + Finset ((Fin n → U) → U) := + open scoped Classical in + (Finset.univ.filter fun c : Circuit σ n g 1 => c.Irredundant I).image + fun c => fun x => c.eval I x 0 + +@[simp] theorem mem_irredundantFunctions {f : (Fin n → U) → U} : + f ∈ irredundantFunctions I n g ↔ ∃ c : Circuit σ n g 1, + c.Computes I f ∧ c.Irredundant I := by + classical + simp [irredundantFunctions, Circuit.Computes, funext_iff, and_comm] + +section Relabeling + +omit [Fintype σ.Op] + +-- Gate equations and an output wire, without a topological ordering. +private abbrev Presentation (n g : ℕ) := (Fin g → Line σ n g) × Wire n g + +private def relabel (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) : + Presentation (σ := σ) n g := + (fun a => (c.program.lines (π.symm a)).mapWires (Wire.Renaming.ofPermutation π), + Wire.Renaming.ofPermutation π (c.outputs 0)) + +private theorem relabel_line_eval (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) (v : Fin g → U) (a : Fin g) : + ((relabel c π).1 a).eval I x v = + (c.program.lines (π.symm a)).eval I x (v ∘ π) := by + apply Line.eval_mapRenaming + intro gate + simp [Wire.Renaming.ofPermutation] + +private theorem relabel_unique (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) (v : Fin g → U) + (h : ∀ a, ((relabel c π).1 a).eval I x v = v a) : + v = c.program.eval I x ∘ π.symm := by + have hv : v ∘ π = c.program.eval I x := + c.program.eq_eval_of_forall_lines_eval I x _ (fun a => by + simpa [relabel_line_eval] using h (π a)) + funext a + simpa using congrFun hv (π.symm a) + +private theorem relabel_output (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) : + Fin.addCases x (c.program.eval I x ∘ π.symm) (relabel c π).2 = + c.eval I x 0 := by + apply Wire.Renaming.value_apply + intro gate + simp [Wire.Renaming.ofPermutation, Function.comp_def] + +end Relabeling + +private noncomputable def representative (f : irredundantFunctions I n g) : + Circuit σ n g 1 := + (mem_irredundantFunctions.mp f.property).choose + +private theorem representative_spec (f : irredundantFunctions I n g) : + (representative f).Computes I f ∧ + (representative f).Irredundant I := + (mem_irredundantFunctions.mp f.property).choose_spec + +-- Equal presentations determine the function; distinct gate functions determine the labels. +private theorem relabel_injective : Function.Injective + (fun p : irredundantFunctions I n g × Equiv.Perm (Fin g) => + relabel (representative p.1) p.2) := by + rintro ⟨f, π⟩ ⟨f', τ⟩ heq + dsimp only at heq + have hvalues (x : Fin n → U) : + (representative f).program.eval I x ∘ π.symm = + (representative f').program.eval I x ∘ τ.symm := by + apply relabel_unique + intro a + rw [← heq, relabel_line_eval] + simpa [Function.comp_def] using + (representative f).program.lines_eval I x (π.symm a) + have hfunction : f = f' := by + apply Subtype.ext + funext x + rw [← (representative_spec f).1 x, ← (representative_spec f').1 x, + ← relabel_output _ π, ← relabel_output _ τ, heq, hvalues] + subst f' + have hpermutation : π.symm = τ.symm := by + apply Equiv.ext + intro a + apply (representative_spec f).2 + funext x + exact congrFun (hvalues x) a + exact Prod.ext rfl (by simpa using congrArg Equiv.symm hpermutation) + +/-- Distinct functions and permutations of their irredundant gates give distinct presentations. -/ +theorem card_irredundantFunctions_mul_factorial_le (I : Interpretation σ U) (n g : ℕ) : + (irredundantFunctions I n g).card * g.factorial ≤ + Fintype.card (Line σ n g) ^ g * (n + g) := by + classical + have h := Fintype.card_le_of_injective _ (relabel_injective (I := I) (n := n) (g := g)) + simpa only [Fintype.card_prod, Fintype.card_coe, Fintype.card_perm, Fintype.card_fin, + Fintype.card_fun] using h + +/-- Normalizing a circuit places its function in one of the irredundant families. -/ +theorem card_computableFunctions_le_sum (I : Interpretation σ U) (n s : ℕ) : + (computableFunctions I n s).card ≤ + ∑ g ∈ Finset.range (s + 1), (irredundantFunctions I n g).card := by + classical + apply le_trans (Finset.card_le_card (t := + (Finset.range (s + 1)).biUnion (irredundantFunctions I n)) ?_) Finset.card_biUnion_le + intro f hf + obtain ⟨g, hg, c, hc⟩ := mem_computableFunctions.mp hf + obtain ⟨k, hk, d, hd, hinj⟩ := c.exists_irredundant I + apply Finset.mem_biUnion.mpr + refine ⟨k, Finset.mem_range.mpr (by omega), mem_irredundantFunctions.mpr ⟨d, ?_, hinj⟩⟩ + simpa only [Circuit.Computes, hd] using hc + +/-- Bound the number of computable functions using a uniform line count `B`. The condition +`s ≤ B` absorbs the extra factorial factors from circuits with fewer than `s` gates. -/ +theorem card_computableFunctions_mul_factorial_le (I : Interpretation σ U) (n s B : ℕ) + (hB : s ≤ B) (hlines : ∀ g ≤ s, Fintype.card (Line σ n g) ≤ B) : + (computableFunctions I n s).card * s.factorial ≤ + (s + 1) * B ^ s * (n + s) := by + have hterm (g : ℕ) (hg : g ≤ s) : + (irredundantFunctions I n g).card * s.factorial ≤ B ^ s * (n + s) := by + calc + (irredundantFunctions I n g).card * s.factorial = + ((irredundantFunctions I n g).card * g.factorial) * + (g + 1).ascFactorial (s - g) := by + rw [mul_assoc, Nat.factorial_mul_ascFactorial, Nat.add_sub_of_le hg] + _ ≤ (Fintype.card (Line σ n g) ^ g * (n + g)) * s ^ (s - g) := + Nat.mul_le_mul (card_irredundantFunctions_mul_factorial_le I n g) + (by simpa [Nat.add_sub_of_le hg] using Nat.ascFactorial_le_pow_add g (s - g)) + _ ≤ (B ^ g * (n + s)) * B ^ (s - g) := by gcongr; exact hlines g hg + _ = B ^ s * (n + s) := by rw [mul_right_comm, ← pow_add, Nat.add_sub_of_le hg] + calc + (computableFunctions I n s).card * s.factorial ≤ + (∑ g ∈ Finset.range (s + 1), (irredundantFunctions I n g).card) * s.factorial := + Nat.mul_le_mul_right _ (card_computableFunctions_le_sum I n s) + _ ≤ ∑ _g ∈ Finset.range (s + 1), B ^ s * (n + s) := by + rw [Finset.sum_mul] + exact Finset.sum_le_sum fun g hg => hterm g (Nat.le_of_lt_succ (Finset.mem_range.mp hg)) + _ = (s + 1) * B ^ s * (n + s) := by simp [mul_assoc] + +/-- A cardinality bound for any finite signature with bounded arities. The maximum also +covers empty signatures and signatures containing only nullary operations. -/ +theorem card_computableFunctions_mul_factorial_le_of_arity_le + (I : Interpretation σ U) (n s r : ℕ) (arity_le : ∀ op, σ.Arity op ≤ r) : + (computableFunctions I n s).card * s.factorial ≤ + (s + 1) * (max s (Fintype.card σ.Op * (n + s + 1) ^ r)) ^ s * (n + s) := by + apply card_computableFunctions_mul_factorial_le I n s _ (Nat.le_max_left _ _) + intro g hg + exact (Line.card_le n g r arity_le).trans + ((Nat.mul_le_mul_left _ (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) r)).trans + (Nat.le_max_right _ _)) + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Finite.lean b/Cslib/Computability/Circuit/Finite.lean new file mode 100644 index 000000000..32850f9b5 --- /dev/null +++ b/Cslib/Computability/Circuit/Finite.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +public import Mathlib.Data.Fintype.BigOperators + +import Mathlib.Algebra.Order.BigOperators.Group.Finset + +/-! +# Finite circuit syntax + +A finite signature gives computable enumerations of lines, programs, and circuits of each +fixed size. Their cardinalities count syntax and are independent of any interpretation or +carrier. `Line.card_le` bounds the number of lines when all operation arities are bounded. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +universe v +variable {σ : Signature.{v}} [Fintype σ.Op] + +instance Line.instFintype (n g : ℕ) : Fintype (Line σ n g) := + Fintype.ofEquiv _ (Line.equiv σ n g).symm + +instance Program.instFintype (n : ℕ) : (g : ℕ) → Fintype (Program σ n g) + | 0 => Fintype.ofEquiv PUnit (Program.emptyEquiv σ n).symm + | g + 1 => + letI := Program.instFintype n g + Fintype.ofEquiv _ (Program.gateEquiv σ n g).symm + +instance Circuit.instFintype (n g m : ℕ) : Fintype (Circuit σ n g m) := + Fintype.ofEquiv _ (Circuit.equiv σ n g m).symm + +/-- For each operation, choose one wire for each of its arguments. -/ +theorem Line.card (n g : ℕ) : + Fintype.card (Line σ n g) = ∑ op : σ.Op, (n + g) ^ σ.Arity op := by + rw [Fintype.card_congr (Line.equiv σ n g), Fintype.card_sigma] + simp + +/-- A uniform arity bound gives a uniform bound on the number of lines, including when +there are no available wires. -/ +theorem Line.card_le (n g r : ℕ) (arity_le : ∀ op, σ.Arity op ≤ r) : + Fintype.card (Line σ n g) ≤ Fintype.card σ.Op * (n + g + 1) ^ r := by + rw [Line.card] + calc + ∑ op : σ.Op, (n + g) ^ σ.Arity op ≤ ∑ _op : σ.Op, (n + g + 1) ^ r := by + apply Finset.sum_le_sum + intro op _ + exact (Nat.pow_le_pow_left (by omega : n + g ≤ n + g + 1) _).trans + (Nat.pow_le_pow_right (by omega) (arity_le op)) + _ = _ := by simp + +/-- There is one empty program, regardless of the signature or number of inputs. -/ +@[simp] theorem Program.card_zero (n : ℕ) : Fintype.card (Program σ n 0) = 1 := by + rw [Fintype.card_congr (Program.emptyEquiv σ n)] + simp + +/-- Choose a prefix program and then its last line. -/ +theorem Program.card_succ (n g : ℕ) : + Fintype.card (Program σ n (g + 1)) = + Fintype.card (Program σ n g) * Fintype.card (Line σ n g) := by + rw [Fintype.card_congr (Program.gateEquiv σ n g), Fintype.card_prod] + +/-- The line at each position may refer to the inputs and all preceding gates. -/ +theorem Program.card (n g : ℕ) : + Fintype.card (Program σ n g) = + ∏ j ∈ Finset.range g, ∑ op : σ.Op, (n + j) ^ σ.Arity op := by + induction g with + | zero => simp + | succ g ih => simp [Program.card_succ, ih, Line.card, Finset.prod_range_succ] + +/-- Each output independently selects an input or internal-gate wire. -/ +theorem Circuit.card (n g m : ℕ) : + Fintype.card (Circuit σ n g m) = Fintype.card (Program σ n g) * (n + g) ^ m := by + rw [Fintype.card_congr (Circuit.equiv σ n g m), Fintype.card_prod] + simp + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Normalization.lean b/Cslib/Computability/Circuit/Normalization.lean new file mode 100644 index 000000000..24f71e119 --- /dev/null +++ b/Cslib/Computability/Circuit/Normalization.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +import Mathlib.Data.Fin.Tuple.Basic + +/-! +# Semantic circuit normalization + +Merging gates that compute the same function preserves wire values and does not +increase circuit size. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +variable {σ : Signature} {n g m : ℕ} {U : Type*} + +/-- Distinct gates compute distinct scalar functions. Gates may still duplicate input +functions or be unused by the outputs. -/ +def Program.Irredundant (p : Program σ n g) (i : Interpretation σ U) : Prop := + Function.Injective (p.gateFunction i) + +/-- A circuit is irredundant when its internal gates compute pairwise distinct functions. -/ +def Circuit.Irredundant (c : Circuit σ n g m) (i : Interpretation σ U) : Prop := + c.program.Irredundant i + +/-- A program can be rebuilt with distinct gate functions, preserving every wire's value. -/ +theorem Program.exists_irredundant (p : Program σ n g) (i : Interpretation σ U) : + ∃ k ≤ g, ∃ q : Program σ n k, ∃ ρ : Wire.Renaming n g k, + (∀ x w, q.trace i x (ρ w) = p.trace i x w) ∧ + q.Irredundant i := by + classical + induction p with + | empty => + exact ⟨0, le_rfl, .empty, .id, by simp, fun w => Fin.elim0 w⟩ + | @gate g p line ih => + obtain ⟨k, hk, q, ρ, hρ, hq⟩ := ih + let l := line.mapWires ρ + have hl (x) : l.eval i x (q.eval i x) = line.eval i x (p.eval i x) := + line.eval_mapWires ρ i x x (p.eval i x) (q.eval i x) (hρ x) + by_cases h : ∃ w, q.gateFunction i w = fun x => l.eval i x (q.eval i x) + · obtain ⟨w, hw⟩ := h + refine ⟨k, by omega, q, ρ.skipLast (Wire.gate w), ?_, hq⟩ + intro x v + refine Fin.lastCases ?_ (fun v => ?_) v + · simpa using (congrFun hw x).trans (hl x) + · simpa using hρ x v + · refine ⟨k + 1, by omega, q.gate l, ρ.appendLast, ?_, ?_⟩ + · intro x v + refine Fin.lastCases ?_ (fun v => ?_) v + · simpa using hl x + · simpa using hρ x v + · change Function.Injective ((q.gate l).gateFunction i) + convert Fin.snoc_injective_of_injective hq h using 1 + ext gate x + refine Fin.lastCases ?_ (fun gate => ?_) gate <;> simp + +/-- Every circuit has an equivalent circuit with distinct gate functions and no more gates. -/ +theorem Circuit.exists_irredundant (c : Circuit σ n g m) (i : Interpretation σ U) : + ∃ k ≤ g, ∃ d : Circuit σ n k m, + d.eval i = c.eval i ∧ d.Irredundant i := by + obtain ⟨k, hk, q, ρ, hρ, hq⟩ := c.program.exists_irredundant i + exact ⟨k, hk, ⟨q, ρ ∘ c.outputs⟩, funext fun x => funext fun o => hρ x (c.outputs o), hq⟩ + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Program.lean b/Cslib/Computability/Circuit/Program.lean index 47de25b02..28a5622c0 100644 --- a/Cslib/Computability/Circuit/Program.lean +++ b/Cslib/Computability/Circuit/Program.lean @@ -46,6 +46,14 @@ structure Line (σ : Signature) (inputCount gateCount : Nat) where /-- The wire supplying each argument of the operation. -/ wires : Fin (σ.Arity op) → Wire inputCount gateCount +/-- A line is an operation symbol together with a tuple of argument wires. -/ +def Line.equiv (σ : Signature) (inputCount gateCount : Nat) : + Line σ inputCount gateCount ≃ Σ op : σ.Op, Fin (σ.Arity op) → Wire inputCount gateCount where + toFun line := ⟨line.op, line.wires⟩ + invFun line := ⟨line.1, line.2⟩ + left_inv _ := rfl + right_inv _ := rfl + /-- Apply a function to every wire read by a line. -/ def Line.mapWires (line : Line σ sourceInputCount sourceGateCount) @@ -72,6 +80,22 @@ inductive Program (σ : Signature.{v}) (inputCount : Nat) : Nat → Type v where Program σ inputCount gateCount → Line σ inputCount gateCount → Program σ inputCount (gateCount + 1) +/-- The empty program is the only program with no gates. -/ +def Program.emptyEquiv (σ : Signature) (inputCount : Nat) : Program σ inputCount 0 ≃ PUnit.{1} where + toFun _ := PUnit.unit + invFun _ := .empty + left_inv p := by cases p; rfl + right_inv x := by cases x; rfl + +/-- A nonempty program is a prefix followed by its last gate. -/ +def Program.gateEquiv (σ : Signature) (inputCount gateCount : Nat) : + Program σ inputCount (gateCount + 1) ≃ + Program σ inputCount gateCount × Line σ inputCount gateCount where + toFun | .gate p line => (p, line) + invFun p := p.1.gate p.2 + left_inv p := by cases p; rfl + right_inv _ := rfl + /-- Every gate in a program has at most `r` arguments. -/ def Program.FanInAtMost {gateCount : Nat} : (program : Program σ inputCount gateCount) → Nat → Prop | .empty, _ => True @@ -403,4 +427,27 @@ theorem Program.lines_eval · simp only [Program.lines_gate_castSucc, Program.eval_gate_castSucc] exact (evalWidened (program.lines priorGate)).trans (ih priorGate) +/-- A valuation satisfying every gate equation is the program's evaluation. -/ +theorem Program.eq_eval_of_forall_lines_eval + (p : Program σ inputCount gateCount) (i : Interpretation σ U) (x : Fin inputCount → U) + (values : Fin gateCount → U) + (h : ∀ gate, (p.lines gate).eval i x values = values gate) : + values = p.eval i x := by + induction p with + | empty => exact Subsingleton.elim _ _ + | @gate g p line ih => + have hmap (l : Line σ inputCount g) : + (l.mapWires Wire.Renaming.castSucc).eval i x values = + l.eval i x (values ∘ Fin.castSucc) := by + apply Line.eval_mapWires + intro w + refine Fin.addCases (fun a => ?_) (fun b => ?_) w <;> + simp [Wire.Renaming.castSucc, Function.comp_def] + have hp : values ∘ Fin.castSucc = p.eval i x := + ih _ (fun gate => by simpa [hmap] using h gate.castSucc) + funext gate + refine Fin.lastCases ?_ (fun gate => ?_) gate + · simpa [hmap, hp] using (h (Fin.last g)).symm + · simpa using congrFun hp gate + end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Shannon.lean b/Cslib/Computability/Circuit/Shannon.lean new file mode 100644 index 000000000..38f7a3032 --- /dev/null +++ b/Cslib/Computability/Circuit/Shannon.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Counting +public import Mathlib.Basic.Real.Basic +public import Mathlib.SetTheory.Cardinal.Finite + +import Cslib.Foundations.Data.Nat.Asymptotics +import Cslib.Foundations.Data.Nat.Factorial +import Mathlib.Analysis.SpecialFunctions.Log.Basic +import Mathlib.Order.Filter.AtTopBot.Basic + +/-! +# Shannon's lower bound for finite carriers and binary bases + +For any fixed finite signature with operation arities at most two, interpreted on a finite +carrier `U` with `q ≥ 2` elements, some function on `n` inputs requires more than `qⁿ/n` gates +for all sufficiently large `n`. The threshold may depend on the signature and carrier. +For the De Morgan basis on `Bool`, this matches Lupanov's upper bound asymptotically. + +The logarithm of the counting bound is at most `s log s + O(s)` for `n + 1 ≤ s`. +At `s = ⌊qⁿ/n⌋`, this is smaller than the logarithm of the `q^(qⁿ)` functions. +This extends the Boolean counting argument in the references to finite carriers. + +## References + +* [Claude E. Shannon, *The Synthesis of Two-Terminal Switching Circuits*][Shannon1949]: + Theorem 7, Section 3(e), pp. 77-79, the original counting argument for switching circuits. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012]: + Lemma 1.12 and Theorem 1.14, a modern treatment of Boolean circuit counting. +-/ + +public section + +namespace Cslib.Circuits.Shannon + +open Filter + +universe v u +variable {σ : Signature.{v}} {U : Type u} + +private theorem exists_card_le_exp [Fintype σ.Op] (I : Interpretation σ U) + (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∃ C : ℝ, ∀ n s : ℕ, n + 1 ≤ s → + ((computableFunctions I n s).card : ℝ) ≤ Real.exp ((s : ℝ) * Real.log s + C * s) := by + let q := Fintype.card σ.Op + 1 + have hq : 1 ≤ q := Nat.succ_le_succ (Nat.zero_le _) + refine ⟨Real.log (4 * (q : ℝ)) + 5, fun n s hn => ?_⟩ + let a := (computableFunctions I n s).card + by_cases ha : a = 0 + · simp only [show (computableFunctions I n s).card = 0 from ha, Nat.cast_zero] + positivity + have ha : (0 : ℝ) < a := by exact_mod_cast (Nat.pos_of_ne_zero ha) + have hs : (1 : ℝ) ≤ s := by exact_mod_cast (by omega : 1 ≤ s) + have hn' : (n : ℝ) + 1 ≤ s := by exact_mod_cast hn + have hB : s ≤ q * (n + s + 1) ^ 2 := by + calc + s ≤ (n + s + 1) ^ 2 := by nlinarith [Nat.le_mul_self (n + s + 1)] + _ ≤ q * (n + s + 1) ^ 2 := by + simpa only [one_mul] using Nat.mul_le_mul_right ((n + s + 1) ^ 2) hq + have hlines (g : ℕ) (hg : g ≤ s) : Fintype.card (Line σ n g) ≤ q * (n + s + 1) ^ 2 := + (Line.card_le n g 2 arity_le).trans (Nat.mul_le_mul (Nat.le_succ _) + (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) 2)) + have hcount : (a : ℝ) * s.factorial ≤ + (2 * (s : ℝ)) ^ 2 * (4 * (q : ℝ) * (s : ℝ) ^ 2) ^ s := by + calc + (a : ℝ) * s.factorial ≤ + ((s : ℝ) + 1) * ((q : ℝ) * ((n : ℝ) + s + 1) ^ 2) ^ s * (n + s) := by + exact_mod_cast card_computableFunctions_mul_factorial_le I n s _ hB hlines + _ ≤ (2 * s) * ((q : ℝ) * (2 * (s : ℝ)) ^ 2) ^ s * (2 * s) := by + gcongr <;> linarith + _ = _ := by rw [show (q : ℝ) * (2 * (s : ℝ)) ^ 2 = 4 * q * s ^ 2 by ring]; ring + have hlog : Real.log a + Real.log s.factorial ≤ + 2 * (Real.log 2 + Real.log s) + s * (Real.log (4 * (q : ℝ)) + 2 * Real.log s) := by + simpa [Real.log_mul, Real.log_pow, ne_of_gt ha, Nat.factorial_ne_zero, + ne_of_gt (zero_lt_one.trans_le hs)] using + (Real.log_le_log (by positivity : 0 < (a : ℝ) * s.factorial) hcount) + apply (Real.log_le_iff_le_exp ha).mp + have hfactorial := Nat.mul_log_sub_le_log_factorial s + have hlogtwo := Real.log_le_sub_one_of_pos (by norm_num : (0 : ℝ) < 2) + have hlogs := Real.log_le_self (by positivity : (0 : ℝ) ≤ s) + nlinarith + +private theorem eventually_card_lt [Fintype σ.Op] [Fintype U] [Nontrivial U] + (I : Interpretation σ U) (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∀ᶠ n : ℕ in atTop, (computableFunctions I n (Fintype.card U ^ n / n)).card < + Fintype.card U ^ (Fintype.card U ^ n) := by + let q := Fintype.card U + have hq : 1 < q := Fintype.one_lt_card + have hqR : (1 : ℝ) < q := by exact_mod_cast hq + have hlogq : 0 < Real.log q := Real.log_pos hqR + obtain ⟨C, hC⟩ := exists_card_le_exp I arity_le + obtain ⟨t, ht⟩ := exists_nat_gt (C / Real.log q) + have hgap : C < t * Real.log q := (div_lt_iff₀ hlogq).mp ht + filter_upwards [Nat.eventually_add_one_le_pow_div hq, eventually_ge_atTop t, + eventually_ge_atTop (q ^ t)] with n hn htn hlarge + let s := q ^ n / n + have hs : (0 : ℝ) < s := by exact_mod_cast (by dsimp [s]; omega : 0 < s) + have hshift : s ≤ q ^ (n - t) := by + apply Nat.div_le_of_le_mul + calc + q ^ n = q ^ t * q ^ (n - t) := by rw [← pow_add, Nat.add_sub_of_le htn] + _ ≤ n * q ^ (n - t) := Nat.mul_le_mul_right _ hlarge + have hlog : Real.log s ≤ ((n : ℝ) - t) * Real.log q := by + have h := Real.log_le_log hs (show (s : ℝ) ≤ (q : ℝ) ^ (n - t) by exact_mod_cast hshift) + simpa [Real.log_pow, Nat.cast_sub htn] using h + have hsize : (n : ℝ) * s ≤ (q : ℝ) ^ n := by + exact_mod_cast (Nat.mul_div_le (q ^ n) n) + have hexponent : (s : ℝ) * Real.log s + C * s < + (q : ℝ) ^ n * Real.log q := by + nlinarith only [mul_le_mul_of_nonneg_left hlog hs.le, + mul_le_mul_of_nonneg_right hsize hlogq.le, mul_lt_mul_of_pos_right hgap hs] + have hcount : ((computableFunctions I n s).card : ℝ) < (q : ℝ) ^ (q ^ n : ℕ) := by + calc + _ ≤ Real.exp ((s : ℝ) * Real.log s + C * s) := hC n s hn + _ < Real.exp ((q : ℝ) ^ n * Real.log q) := Real.exp_lt_exp.mpr hexponent + _ = (q : ℝ) ^ (q ^ n : ℕ) := by + rw [show (q : ℝ) ^ n = ((q ^ n : ℕ) : ℝ) by norm_cast, + Real.exp_nat_mul, Real.exp_log (zero_lt_one.trans hqR)] + exact_mod_cast hcount + +/-- For all sufficiently large `n`, some function on `n` inputs over `U` requires more than +`|U|ⁿ/n` gates over the fixed finite signature, whose operations have arity at most two. -/ +theorem exists_hard_function [Finite σ.Op] [Finite U] [Nontrivial U] + (I : Interpretation σ U) (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → U) → U, + ∀ {g} (c : Circuit σ n g 1), + c.Computes I f → (Nat.card U : ℝ) ^ n / n < (c.size : ℝ) := by + classical + let := Fintype.ofFinite σ.Op + let := Fintype.ofFinite U + simp only [Nat.card_eq_fintype_card] + apply eventually_atTop.mp + filter_upwards [eventually_card_lt I arity_le, eventually_ge_atTop 1] with n hn hn0 + obtain ⟨f, _, hf⟩ := Finset.exists_mem_notMem_of_card_lt_card + (s := computableFunctions I n (Fintype.card U ^ n / n)) (t := Finset.univ) + (by simpa only [Fintype.card_fun, Fintype.card_fin, Finset.card_univ] using hn) + refine ⟨f, fun {g} c hc => ?_⟩ + have hg : Fintype.card U ^ n / n < g := lt_of_not_ge fun hg => + hf (mem_computableFunctions.mpr ⟨g, hg, c, hc⟩) + apply (div_lt_iff₀ (by exact_mod_cast (by omega : 0 < n) : (0 : ℝ) < n)).mpr + exact_mod_cast (Nat.div_lt_iff_lt_mul (by omega : 0 < n)).mp hg + +end Cslib.Circuits.Shannon diff --git a/Cslib/Foundations/Data/Nat/Asymptotics.lean b/Cslib/Foundations/Data/Nat/Asymptotics.lean index 1570051da..b852c7f38 100644 --- a/Cslib/Foundations/Data/Nat/Asymptotics.lean +++ b/Cslib/Foundations/Data/Nat/Asymptotics.lean @@ -9,6 +9,7 @@ public import Cslib.Init public import Mathlib.Data.Nat.Log public import Mathlib.Order.Filter.AtTopBot.Defs import Mathlib.Analysis.SpecificLimits.Normed +import Mathlib.Tactic.Linarith /-! # Asymptotic bounds on natural numbers @@ -35,6 +36,14 @@ theorem eventually_mul_pow_le_pow (c k : ℕ) {b : ℕ} (hb : 1 < b) : filter_upwards [h] with n hn exact_mod_cast (by simpa using hn : (c : ℝ) * n ^ k ≤ (b : ℝ) ^ n) +/-- The quotient of an exponential of base greater than one by the input is eventually +at least the input plus one. -/ +theorem eventually_add_one_le_pow_div {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, n + 1 ≤ b ^ n / n := by + filter_upwards [eventually_mul_pow_le_pow 2 2 hb, eventually_ge_atTop 1] with n hn hn0 + apply (Nat.le_div_iff_mul_le (by omega)).mpr + nlinarith + /-- Every fixed multiple of the logarithm in a base greater than one is eventually at most the input. -/ theorem eventually_mul_log_le (c : ℕ) {b : ℕ} (hb : 1 < b) : diff --git a/Cslib/Foundations/Data/Nat/Factorial.lean b/Cslib/Foundations/Data/Nat/Factorial.lean new file mode 100644 index 000000000..bc72f1157 --- /dev/null +++ b/Cslib/Foundations/Data/Nat/Factorial.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Init +public import Mathlib.Analysis.SpecialFunctions.Log.Basic + +/-! +# A logarithmic lower bound for the factorial + +Bounding one term of the exponential series gives `n log n - n ≤ log (n!)`, including at zero. +-/ + +public section + +namespace Nat + +/-- The logarithm of the factorial is at least `n log n - n`. -/ +theorem mul_log_sub_le_log_factorial (n : ℕ) : + (n : ℝ) * Real.log n - n ≤ Real.log n.factorial := by + obtain rfl | hn := n.eq_zero_or_pos + · simp + have h := Real.log_le_log (by positivity : 0 < (n : ℝ) ^ n / n.factorial) + (Real.pow_div_factorial_le_exp (n : ℝ) (by positivity) n) + rw [Real.log_div (by positivity) (by positivity), Real.log_pow, Real.log_exp] at h + linarith + +end Nat diff --git a/CslibTests.lean b/CslibTests.lean index c40d862e5..ee14990d3 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -3,6 +3,7 @@ import CslibTests.BooleanCircuits import CslibTests.CCS import CslibTests.CCS.VendingMachine import CslibTests.CLL +import CslibTests.CircuitCounting import CslibTests.Circuits import CslibTests.Commitment import CslibTests.Complexity.Combinators diff --git a/CslibTests/BooleanCircuits.lean b/CslibTests/BooleanCircuits.lean index ea0945538..6a8545347 100644 --- a/CslibTests/BooleanCircuits.lean +++ b/CslibTests/BooleanCircuits.lean @@ -4,12 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE. Authors: Samuel Schlesinger -/ +import Cslib.Computability.Circuit.Boolean.Counting import Cslib.Computability.Circuit.Boolean.Lupanov +import Cslib.Computability.Circuit.Boolean.Shannon /-! -# Boolean synthesis tests +# Boolean circuit tests -Zero-input constants, zero-gate projections, and shared AND/NAND outputs. +Zero-input constants, zero-gate projections, shared outputs, and compatibility of the +Shannon and Lupanov bounds. -/ namespace CslibTests.BooleanCircuits @@ -47,4 +50,23 @@ example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 2, obtain ⟨g, hg, c, hc⟩ := hout.exists_circuit_family exact ⟨g, hg, c, fun x => ⟨by simpa using hc x 0, by simpa using hc x 1⟩⟩ +example : computableFunctions 0 0 = ∅ := by + apply Finset.card_eq_zero.mp + simpa using card_computableFunctions_mul_factorial_le 0 0 + +example : (fun x : Fin 1 → Bool => x 0) ∈ computableFunctions 1 0 := by + exact mem_computableFunctions.mpr ⟨0, le_rfl, Circuit.id signature 1, by intro x; rfl⟩ + +example (ε : ℝ) (hε : 0 < ε) : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : BooleanFunction n, + (∀ {g} (c : Circuit signature n g 1), + c.Computes interpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ)) ∧ + ∃ g, ∃ c : Circuit signature n g 1, + c.Computes interpretation f ∧ (c.size : ℝ) ≤ (1 + ε) * 2 ^ n / n := by + obtain ⟨N, hN⟩ := Shannon.exists_hard_function + obtain ⟨M, hM⟩ := Lupanov.exists_circuit ε hε + refine ⟨max N M, fun n hn => ?_⟩ + obtain ⟨f, hf⟩ := hN n ((le_max_left N M).trans hn) + exact ⟨f, hf, hM n ((le_max_right N M).trans hn) f⟩ + end CslibTests.BooleanCircuits diff --git a/CslibTests/CircuitCounting.lean b/CslibTests/CircuitCounting.lean new file mode 100644 index 000000000..dbc70fdd4 --- /dev/null +++ b/CslibTests/CircuitCounting.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Shannon +import Mathlib.Data.Fintype.Sum +import Mathlib.Tactic.DeriveFintype + +/-! +# Generic circuit counting tests + +These tests exercise computable syntax enumeration, semantic counting on an infinite carrier, +normalization of distinct symbols with the same interpretation, and empty or nullary signatures. +The Shannon theorem is also instantiated on the NAND basis and a three-valued carrier. +-/ + +namespace CslibTests.CircuitCounting + +open Cslib.Circuits + +inductive ArithmeticOp where + | zero (tag : Bool) + | add + deriving DecidableEq, Fintype + +abbrev arithmeticSignature : Signature where + Op := ArithmeticOp + Arity + | .zero _ => 0 + | .add => 2 + +def arithmeticInterpretation : Interpretation arithmeticSignature ℕ + | .zero _, _ => 0 + | .add, input => input 0 + input 1 + +-- Syntax enumeration computes even with no input wires and operations of mixed arities. +example : Fintype.card (Line arithmeticSignature 0 0) = 2 := by decide +example : Fintype.card (Line arithmeticSignature 2 1) = 11 := by decide +example : Fintype.card (Program arithmeticSignature 0 2) = 6 := by decide +example : Fintype.card (Circuit arithmeticSignature 0 0 0) = 1 := by decide +example : Fintype.card (Circuit arithmeticSignature 0 0 1) = 0 := by decide + +def addition : Circuit arithmeticSignature 2 1 1 where + program := .gate .empty ⟨.add, fun i => Wire.input i⟩ + outputs := fun _ => Wire.gate 0 + +example : (fun x => x 0 + x 1) ∈ computableFunctions arithmeticInterpretation 2 1 := + (mem_computableFunctions (I := arithmeticInterpretation)).mpr + ⟨1, le_rfl, addition, fun _ => rfl⟩ + +def redundant : Circuit arithmeticSignature 0 2 2 where + program := .gate (.gate .empty ⟨.zero false, Fin.elim0⟩) ⟨.zero true, Fin.elim0⟩ + outputs := Wire.gate + +example : ¬ redundant.Irredundant arithmeticInterpretation := by + intro h + have : (0 : Fin 2) = 1 := h (by rfl) + contradiction + +-- Normalization preserves all outputs together over the infinite carrier. +example : ∃ k ≤ 2, ∃ c : Circuit arithmeticSignature 0 k 2, + (∀ x j, c.eval arithmeticInterpretation x j = 0) ∧ + c.Irredundant arithmeticInterpretation := by + obtain ⟨k, hk, c, hc, hi⟩ := redundant.exists_irredundant arithmeticInterpretation + refine ⟨k, hk, c, ?_, hi⟩ + intro x j + rw [hc] + fin_cases j <;> rfl + +abbrev emptySignature : Signature where + Op := Empty + Arity := Empty.elim + +def emptyInterpretation : Interpretation emptySignature ℕ := fun op => nomatch op + +example : Fintype.card (Program emptySignature 1 1) = 0 := by decide + +example : (fun x : Fin 1 → ℕ => x 0) ∈ computableFunctions emptyInterpretation 1 0 := + (mem_computableFunctions (I := emptyInterpretation)).mpr + ⟨0, le_rfl, Circuit.id emptySignature 1, fun _ => rfl⟩ + +example (s : ℕ) : (computableFunctions emptyInterpretation 0 s).card * s.factorial ≤ + (s + 1) * s ^ s * s := by + simpa using card_computableFunctions_mul_factorial_le_of_arity_le emptyInterpretation + 0 s 0 (fun op => nomatch op) + +abbrev nullarySignature : Signature where + Op := Unit + Arity := fun _ => 0 + +def nullaryInterpretation : Interpretation nullarySignature ℕ := fun _ _ => 0 + +example (s : ℕ) : (computableFunctions nullaryInterpretation 0 s).card * s.factorial ≤ + (s + 1) * (max s 1) ^ s * s := by + simpa using card_computableFunctions_mul_factorial_le_of_arity_le nullaryInterpretation + 0 s 0 (fun _ => le_rfl) + +abbrev binarySignature : Signature where + Op := Unit + Arity := fun _ => 2 + +def nandInterpretation : Interpretation binarySignature Bool := fun _ x => !(x 0 && x 1) + +example : ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → Bool) → Bool, + ∀ {g} (c : Circuit binarySignature n g 1), + c.Computes nandInterpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Shannon.exists_hard_function nandInterpretation (fun _ => le_rfl) + +def ternaryInterpretation : Interpretation binarySignature (Fin 3) := fun _ x => x 0 + x 1 + +example : ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → Fin 3) → Fin 3, + ∀ {g} (c : Circuit binarySignature n g 1), + c.Computes ternaryInterpretation f → 3 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Shannon.exists_hard_function ternaryInterpretation (fun _ => le_rfl) + +end CslibTests.CircuitCounting From 4635aeb8412acb0c600d725fa341745f38458ce2 Mon Sep 17 00:00:00 2001 From: Fabrizio Montesi Date: Mon, 21 Sep 2026 19:27:19 +0000 Subject: [PATCH 92/93] feat(CODEOWNERS): add SamuelSchlesinger as a code owner (#932) Allows Samuel Schlesinger to accept PRs. (I had previously forgotten to do this in the PR adding him as maintainer.) --- .github/CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index e82728faf..c27b306d1 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,5 +1,5 @@ # For an overview of the governance model of cslib, please refer to /GOVERNANCE.md and /DECISION_MAKING.md -* @fmontesi @chenson2018 @kim-em @arademaker @sorrachai +* @fmontesi @chenson2018 @kim-em @arademaker @SamuelSchlesinger @sorrachai /.github/CODEOWNERS @fmontesi /DECISION_MAKING.md @fmontesi From 133d92d4b159304c99def4dae7b7e15a50ac4699 Mon Sep 17 00:00:00 2001 From: "mathlib-nightly-testing[bot]" <258991302+mathlib-nightly-testing[bot]@users.noreply.github.com> Date: Mon, 21 Sep 2026 20:01:32 +0000 Subject: [PATCH 93/93] chore: bump mathlib to 1cae91f, fix breaking changes (#934) I (@chenson2018) have intervened manually here because of the cache issue, manually doing a `lake update` (and making the one line Mathlib adaptation). Closes #933 --------- Co-authored-by: mathlib-nightly-testing[bot] Co-authored-by: Chris Henson --- Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean | 2 +- lake-manifest.json | 8 ++++---- lakefile.toml | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean index e1051929f..89bea80d0 100644 --- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean +++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean @@ -154,7 +154,7 @@ instance : SetLike (Fact P) P where coe := Fact.carrier coe_injective _ _ _ := by grind only [cases Fact] -instance : PartialOrder (Fact P) := PartialOrder.ofSetLike (Fact P) P +instance : PartialOrder (Fact P) := PartialOrder.ofSetLike (Fact P) instance : HasSubset (Fact P) := ⟨fun A B => (A : Set P) ⊆ (B : Set P)⟩ diff --git a/lake-manifest.json b/lake-manifest.json index 625b52fc3..c151aba62 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "065356127b1dc0016f66b7283ce0ce2c4055aa55", + "rev": "1cae91f0957ccf8847f22a6239fa0c032a9e28c6", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "v4.35.0-rc2", + "inputRev": "1cae91f0957ccf8847f22a6239fa0c032a9e28c6", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "10930f8138f0462dbd744a91fc03a16fae0e046f", + "rev": "f8e94c24111148c9ad1b866212a6e1a0fabb5e76", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "ed9b316aabe389fec1ef43c3326ab48c7e59be42", + "rev": "167242e0621ba382fd6f7b2a7e932ce0811f9ab1", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.toml b/lakefile.toml index f12bbee14..98e060d7c 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "v4.35.0-rc2" +rev = "1cae91f0957ccf8847f22a6239fa0c032a9e28c6" [[lean_lib]] name = "Cslib"