diff --git a/.gitignore b/.gitignore index 7913863..4af097a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ /.lake arora-barak-draft.pdf +.claude/ diff --git a/Complexitylib/Classes.lean b/Complexitylib/Classes.lean index 16b608d..40e2844 100644 --- a/Complexitylib/Classes.lean +++ b/Complexitylib/Classes.lean @@ -10,3 +10,5 @@ import Complexitylib.Classes.L import Complexitylib.Classes.Exponential import Complexitylib.Classes.DTISP import Complexitylib.Classes.Containments +import Complexitylib.Classes.BitEncodable +import Complexitylib.Classes.PPTComputable diff --git a/Complexitylib/Classes/BitEncodable.lean b/Complexitylib/Classes/BitEncodable.lean new file mode 100644 index 0000000..d5756cc --- /dev/null +++ b/Complexitylib/Classes/BitEncodable.lean @@ -0,0 +1,61 @@ +import Complexitylib.Classes.Pairing + +/-! +# Bit-string encoding typeclass + +`BitEncodable α` provides a specification-level mapping between a type `α` and `List Bool`, +used to state that a Turing machine's bit-string I/O corresponds to a Lean function operating +on abstract types. The encoding carries **no computational obligation** — it is purely a +correspondence used in the *statements* of PPT predicates, not in any executed code. + +## Main definitions + +- `BitEncodable` — typeclass with `encode : α → List Bool`, `decode : List Bool → α`, + and a roundtrip proof +- Instances for `Unit`, `List Bool`, `Prod`, `Option` +-/ + +/-- Specification-level encoding of a type as bit strings. + Used to relate Turing machine I/O to Lean functions on abstract types. + The `decode` function is total: it returns a default value for invalid inputs. + Only the roundtrip property `decode (encode a) = a` is required. -/ +class BitEncodable (α : Type) where + /-- Encode a value as a bit string. -/ + encode : α → List Bool + /-- Decode a bit string to a value. Returns a default for invalid inputs. -/ + decode : List Bool → α + /-- Decoding an encoded value recovers the original. -/ + roundtrip : ∀ a, decode (encode a) = a + +namespace BitEncodable + +instance unit : BitEncodable Unit where + encode _ := [] + decode _ := () + roundtrip _ := rfl + +instance listBool : BitEncodable (List Bool) where + encode := id + decode := id + roundtrip _ := rfl + +/-- Encode `Option (List Bool)` as a bit string: `none ↦ [false]`, + `some x ↦ true :: x`. -/ +instance optionListBool : BitEncodable (Option (List Bool)) where + encode + | none => [false] + | some x => true :: x + decode + | [] => none + | false :: _ => none + | true :: x => some x + roundtrip a := by cases a <;> simp + +instance prod [BitEncodable α] [BitEncodable β] : BitEncodable (α × β) where + encode := fun (a, b) => pair (BitEncodable.encode a) (BitEncodable.encode b) + decode := fun bits => + let (l, r) := unpair bits + (BitEncodable.decode l, BitEncodable.decode r) + roundtrip := fun (a, b) => by simp [unpair_pair, BitEncodable.roundtrip] + +end BitEncodable diff --git a/Complexitylib/Classes/PPTComputable.lean b/Complexitylib/Classes/PPTComputable.lean new file mode 100644 index 0000000..19b8869 --- /dev/null +++ b/Complexitylib/Classes/PPTComputable.lean @@ -0,0 +1,33 @@ +import Complexitylib.Models.TuringMachine +import Complexitylib.Asymptotics +import Mathlib.Probability.ProbabilityMassFunction.Basic + +/-! +# PPT-computable randomized functions + +This file defines `PPTComputable`, a predicate asserting that a randomized function +`List Bool → PMF (List Bool)` is computable by a probabilistic polynomial-time +Turing machine. This bridges the gap between Lean-level probabilistic functions +(using `PMF`) and the NTM computation model (using `outputCount`). + +## Main definitions + +- `PPTComputable` — a randomized function is PPT-computable if there exists a PPT NTM + whose output distribution matches the function on all inputs +-/ + +open Complexity + +/-- A randomized function `f : List Bool → PMF (List Bool)` is **PPT-computable** + if there exists a PPT NTM whose output distribution matches `f` on all inputs. + + The output distribution of the NTM with time bound `T` is given by + `outputCount x T y / 2^T`, which must equal `(f x) y` for all inputs `x` + and outputs `y`. The time bound `T` must be polynomial: `T =O (· ^ d)` + for some degree `d`. -/ +def PPTComputable (f : List Bool → PMF (List Bool)) : Prop := + ∃ (k : ℕ) (tm : NTM k) (T : ℕ → ℕ) (d : ℕ), + T =O (· ^ d) ∧ + tm.AllPathsHaltIn T ∧ + ∀ x y, + (↑(tm.outputCount x (T x.length) y) : ENNReal) / ↑(2 ^ (T x.length)) = (f x) y diff --git a/Complexitylib/Classes/Pairing.lean b/Complexitylib/Classes/Pairing.lean index a9be014..28d3110 100644 --- a/Complexitylib/Classes/Pairing.lean +++ b/Complexitylib/Classes/Pairing.lean @@ -17,14 +17,38 @@ search-problem classes. def pair (x y : List Bool) : List Bool := (x.flatMap fun b => [b, b]) ++ [false, true] ++ y -private theorem pair_nil_eq (y : List Bool) : +@[simp] +theorem pair_nil_eq (y : List Bool) : pair [] y = false :: true :: y := by simp [pair] -private theorem pair_cons_eq (b : Bool) (x y : List Bool) : +@[simp] +theorem pair_cons_eq (b : Bool) (x y : List Bool) : pair (b :: x) y = b :: b :: pair x y := by simp [pair, List.append_assoc] +/-- Decode a paired binary string back into two components. + Left inverse of `pair`: `unpair (pair x y) = (x, y)`. + Returns `([], [])` for strings not in the image of `pair`. -/ +def unpair : List Bool → List Bool × List Bool + | false :: false :: rest => + let (x, y) := unpair rest + (false :: x, y) + | true :: true :: rest => + let (x, y) := unpair rest + (true :: x, y) + | false :: true :: rest => ([], rest) + | _ => ([], []) + +/-- `unpair` is a left inverse of `pair`. -/ +@[simp] +theorem unpair_pair (x y : List Bool) : unpair (pair x y) = (x, y) := by + induction x with + | nil => rfl + | cons b x' ih => + rw [pair_cons_eq] + cases b <;> simp only [unpair, ih] + /-- `pair` is injective: if `pair x₁ y₁ = pair x₂ y₂` then `x₁ = x₂` and `y₁ = y₂`. -/ theorem pair_injective {x₁ x₂ : List Bool} {y₁ y₂ : List Bool} (h : pair x₁ y₁ = pair x₂ y₂) : x₁ = x₂ ∧ y₁ = y₂ := by diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index cccc124..a3cba52 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -3,3 +3,26 @@ import Complexitylib.Models.TuringMachine.Internal import Complexitylib.Models.TuringMachine.Combinators import Complexitylib.Models.TuringMachine.Combinators.Internal import Complexitylib.Models.TuringMachine.Combinators.ComplementInternal +import Complexitylib.Models.TuringMachine.Combinators.SeqInternal +import Complexitylib.Models.TuringMachine.Combinators.IfInternal +import Complexitylib.Models.TuringMachine.Combinators.LoopInternal +import Complexitylib.Models.TuringMachine.Hoare +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.UTM.Init.Defs +import Complexitylib.Models.TuringMachine.UTM.Init +import Complexitylib.Models.TuringMachine.UTM.InitInternal +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Copy +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Rewind +import Complexitylib.Models.TuringMachine.UTM.InitInternal.SetupState +import Complexitylib.Models.TuringMachine.UTM.InitInternal.SetupSim +import Complexitylib.Models.TuringMachine.UTM.ReadCurrent +import Complexitylib.Models.TuringMachine.UTM.ReadCurrentInternal +import Complexitylib.Models.TuringMachine.UTM.Lookup +import Complexitylib.Models.TuringMachine.UTM.ApplyTransition +import Complexitylib.Models.TuringMachine.UTM.CheckHalt +import Complexitylib.Models.TuringMachine.UTM.CheckHaltInternal +import Complexitylib.Models.TuringMachine.UTM.ExtractOutput +import Complexitylib.Models.TuringMachine.UTM.UTM diff --git a/Complexitylib/Models/TuringMachine/Combinators.lean b/Complexitylib/Models/TuringMachine/Combinators.lean index cda4e22..f5face6 100644 --- a/Complexitylib/Models/TuringMachine/Combinators.lean +++ b/Complexitylib/Models/TuringMachine/Combinators.lean @@ -416,4 +416,396 @@ def complementTM (tm : TM n) : TM n := | Sum.inr .done => exact rightOfStart_allIdle iHead wHeads oHead } +-- ════════════════════════════════════════════════════════════════════════ +-- Conditional Branching +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states for the conditional branching machine. -/ +inductive IfPhase where + | rewindOut -- rewind output head left to ▷ (cell 0) + | check -- at cell 0, move right to cell 1, read result, branch + | done -- halt state (reached when either branch halts) + deriving DecidableEq + +instance : Fintype IfPhase where + elems := {.rewindOut, .check, .done} + complete := fun x => by cases x <;> simp + +/-- The state type for the conditional branching TM. -/ +abbrev IfQ (QT QThen QElse : Type) := QT ⊕ IfPhase ⊕ QThen ⊕ QElse + +/-- Conditional branching: run `tmTest` to completion, read its output at + cell 1, then run `tmThen` (if output = `Γ.one`) or `tmElse` (otherwise). + + All three machines share the same `n` work tapes, input tape, and output + tape. Work tape contents are preserved across all transitions via + `readBackWrite`, maintaining shared state for the branch machines. + + ## Phases + + 1. **Test**: Simulate `tmTest`. When it halts, enter rewind. + 2. **Rewind output**: Move output head left to `▷` (cell 0). + 3. **Check**: Move output head right to cell 1, read the test result. + If `Γ.one`, enter `tmThen.qstart`. Otherwise, enter `tmElse.qstart`. + 4. **Branch**: Simulate `tmThen` or `tmElse`. When the branch machine + halts, transition to the `done` halt state. + + ## Time + + `t_test + (output_head_pos + 2) + 1 + t_branch + 1` where + `output_head_pos ≤ t_test`. Total: at most `2·t_test + t_branch + 4`. -/ +def ifTM (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) : TM n := + haveI : Fintype tmTest.Q := tmTest.finQ + haveI : DecidableEq tmTest.Q := tmTest.decEq + haveI : Fintype tmThen.Q := tmThen.finQ + haveI : DecidableEq tmThen.Q := tmThen.decEq + haveI : Fintype tmElse.Q := tmElse.finQ + haveI : DecidableEq tmElse.Q := tmElse.decEq + { Q := IfQ tmTest.Q tmThen.Q tmElse.Q, + qstart := Sum.inl tmTest.qstart, + qhalt := Sum.inr (Sum.inl .done), + δ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Test phase: simulate tmTest + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tmTest.qhalt then + -- tmTest halted → begin rewinding output, preserve all tapes + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmTest.δ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Transition: rewind output and check result + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + if oHead = Γ.start then + -- At ▷ (cell 0) → move right to cell 1, enter check + ( Sum.inr (Sum.inl .check), + fun i => readBackWrite (wHeads i), + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.right ) + else + -- Not at cell 0 → keep moving left, preserve output + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.left ) + | .check => + -- At cell 1: read output and branch + if oHead = Γ.one then + ( Sum.inr (Sum.inr (Sum.inl tmThen.qstart)), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + ( Sum.inr (Sum.inr (Sum.inr tmElse.qstart)), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + | .done => + allIdle (Sum.inr (Sum.inl .done)) iHead wHeads oHead + -- ══════════════════════════════════════════════════════════════════ + -- Then branch: simulate tmThen + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr (Sum.inl q)) => + if q = tmThen.qhalt then + -- tmThen halted → transition to done, preserve tapes + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmThen.δ q iHead wHeads oHead + ( Sum.inr (Sum.inr (Sum.inl q')), wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Else branch: simulate tmElse + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr (Sum.inr q)) => + if q = tmElse.qhalt then + -- tmElse halted → transition to done, preserve tapes + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmElse.δ q iHead wHeads oHead + ( Sum.inr (Sum.inr (Sum.inr q')), wW, oW, iD, wD, oD ), + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tmTest.δ_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + · refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .check => + dsimp only [] + split <;> exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact rightOfStart_allIdle iHead wHeads oHead + | Sum.inr (Sum.inr (Sum.inl q)) => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tmThen.δ_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inr (Sum.inr q)) => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tmElse.δ_right_of_start q iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Sequential Composition +-- ════════════════════════════════════════════════════════════════════════ + +/-- The state type for the sequential composition TM. -/ +abbrev SeqQ (Q₁ Q₂ : Type) := Q₁ ⊕ Q₂ + +/-- Sequential composition: run tm₁ to completion, then tm₂ on the same tapes. + + Both machines share the same `n` work tapes, input tape, and output tape. + When tm₁ halts, there is one transition step that: + - Changes state from `Q₁` to `Q₂` (entering `tm₂.qstart`) + - Preserves all tape cell contents (via `readBackWrite`) + - Moves any tape head at position 0 to position 1 (forced by `δ_right_of_start`) + - Leaves all other tape head positions unchanged + + After the transition, tm₂ runs from the resulting tape state. + Total time: `t₁ + 1 + t₂` where `t₁` and `t₂` are the run times of + `tm₁` and `tm₂` respectively. -/ +def seqTM (tm₁ tm₂ : TM n) : TM n := + haveI : Fintype tm₁.Q := tm₁.finQ + haveI : DecidableEq tm₁.Q := tm₁.decEq + haveI : Fintype tm₂.Q := tm₂.finQ + haveI : DecidableEq tm₂.Q := tm₂.decEq + { Q := SeqQ tm₁.Q tm₂.Q, + qstart := Sum.inl tm₁.qstart, + qhalt := Sum.inr tm₂.qhalt, + δ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Phase 1: simulate tm₁ + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tm₁.qhalt then + -- tm₁ halted → transition to tm₂.qstart, preserve tape contents + ( Sum.inr tm₂.qstart, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Not halted → run tm₁.δ, wrapping state in Sum.inl + let (q', wW, oW, iD, wD, oD) := tm₁.δ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Phase 2: simulate tm₂ + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr q => + if q = tm₂.qhalt then + -- Unreachable by step, but δ is total + allIdle (Sum.inr tm₂.qhalt) iHead wHeads oHead + else + -- Not halted → run tm₂.δ, wrapping state in Sum.inr + let (q', wW, oW, iD, wD, oD) := tm₂.δ q iHead wHeads oHead + ( Sum.inr q', wW, oW, iD, wD, oD ), + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tm₁.δ_right_of_start q iHead wHeads oHead + | Sum.inr q => + dsimp only [] + split + · exact rightOfStart_allIdle iHead wHeads oHead + · exact tm₂.δ_right_of_start q iHead wHeads oHead } + +-- ════════════════════════════════════════════════════════════════════════ +-- Loop Combinator +-- ════════════════════════════════════════════════════════════════════════ + +/-- Intermediate states for the loop machine's output-checking phase. -/ +inductive LoopPhase where + | rewindOut -- rewind output head left to ▷ (cell 0) + | check -- at cell 1: read output, decide continue/halt + | done -- halt state + deriving DecidableEq + +instance : Fintype LoopPhase where + elems := {.rewindOut, .check, .done} + complete := fun x => by cases x <;> simp + +/-- The state type for the loop TM. -/ +abbrev LoopQ (QBody QTest : Type) := QBody ⊕ LoopPhase ⊕ QTest + +/-- Loop combinator: repeatedly run `tmBody` then `tmTest`, halting when + the test's output at cell 1 is `Γ.one`. + + Both machines share the same `n` work tapes, input tape, and output tape. + Work tape contents are preserved across transitions (via `readBackWrite`), + allowing the body to accumulate state across iterations. + + ## Phases + + 1. **Body**: Simulate `tmBody`. When it halts, transition to test. + 2. **Test**: Simulate `tmTest`. When it halts, enter rewind. + 3. **Rewind output**: Move output head left to `▷` (cell 0). + 4. **Check**: Move right to cell 1, read the test result. + If `Γ.one`, enter `done` (halt). Otherwise, transition back to body. + + ## Use case + + The UTM's main loop: `loopTM simStepTM checkHaltTM` runs one simulation + step, then checks if the simulated machine has halted. -/ +def loopTM (tmBody : TM n) (tmTest : TM n) : TM n := + haveI : Fintype tmBody.Q := tmBody.finQ + haveI : DecidableEq tmBody.Q := tmBody.decEq + haveI : Fintype tmTest.Q := tmTest.finQ + haveI : DecidableEq tmTest.Q := tmTest.decEq + { Q := LoopQ tmBody.Q tmTest.Q, + qstart := Sum.inl tmBody.qstart, + qhalt := Sum.inr (Sum.inl .done), + δ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Body phase: simulate tmBody + -- ══════════════════════════════════════════════════════════════════ + | Sum.inl q => + if q = tmBody.qhalt then + -- Body halted → transition to test, preserve tape contents + ( Sum.inr (Sum.inr tmTest.qstart), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmBody.δ q iHead wHeads oHead + ( Sum.inl q', wW, oW, iD, wD, oD ) + -- ══════════════════════════════════════════════════════════════════ + -- Transition phases: rewind and check output + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + if oHead = Γ.start then + -- At ▷ (cell 0) → move right to cell 1, enter check + ( Sum.inr (Sum.inl .check), + fun i => readBackWrite (wHeads i), + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.right ) + else + -- Not at cell 0 → keep moving left, preserve output + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + Dir3.left ) + | .check => + if oHead = Γ.one then + -- Test output = 1: halt the loop + ( Sum.inr (Sum.inl .done), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + -- Test output ≠ 1: loop back to body + ( Sum.inl tmBody.qstart, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + | .done => + allIdle (Sum.inr (Sum.inl .done)) iHead wHeads oHead + -- ══════════════════════════════════════════════════════════════════ + -- Test phase: simulate tmTest + -- ══════════════════════════════════════════════════════════════════ + | Sum.inr (Sum.inr q) => + if q = tmTest.qhalt then + -- Test halted → begin rewinding output, preserve tapes + ( Sum.inr (Sum.inl .rewindOut), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) + else + let (q', wW, oW, iD, wD, oD) := tmTest.δ q iHead wHeads oHead + ( Sum.inr (Sum.inr q'), wW, oW, iD, wD, oD ), + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | Sum.inl q => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tmBody.δ_right_of_start q iHead wHeads oHead + | Sum.inr (Sum.inl phase) => + match phase with + | .rewindOut => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + fun _ => rfl⟩ + · refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .check => + dsimp only [] + split <;> exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact rightOfStart_allIdle iHead wHeads oHead + | Sum.inr (Sum.inr q) => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact tmTest.δ_right_of_start q iHead wHeads oHead } + end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/ComplementInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/ComplementInternal.lean index 689bc64..bc62775 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/ComplementInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/ComplementInternal.lean @@ -12,35 +12,22 @@ variable {n : ℕ} namespace TM --- ════════════════════════════════════════════════════════════════════════ --- Tape helpers --- ════════════════════════════════════════════════════════════════════════ - -private theorem tape_move_cells (t : Tape) (d : Dir3) : - (t.move d).cells = t.cells := by cases d <;> rfl - -private theorem readBackWrite_toΓ_eq' {g : Γ} (h : g ≠ Γ.start) : - (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] - -private theorem tape_write_head (t : Tape) (s : Γ) : (t.write s).head = t.head := by - simp only [Tape.write]; split <;> rfl - -private theorem tape_head_writeAndMove_le (t : Tape) (s : Γ) (d : Dir3) : - (t.writeAndMove s d).head ≤ t.head + 1 := by - cases d <;> simp only [Tape.writeAndMove, Tape.move, tape_write_head] <;> omega - -- ════════════════════════════════════════════════════════════════════════ -- Configuration embedding -- ════════════════════════════════════════════════════════════════════════ -private def compCfg (tm : TM n) (c : Cfg n tm.Q) : Cfg n (tm.complementTM.Q) := +def compCfg (tm : TM n) (c : Cfg n tm.Q) : Cfg n (tm.complementTM.Q) := { state := Sum.inl c.state, input := c.input, work := c.work, output := c.output } -private theorem compCfg_initCfg (tm : TM n) (x : List Bool) : +theorem compCfg_initCfg (tm : TM n) (x : List Bool) : compCfg tm (tm.initCfg x) = tm.complementTM.initCfg x := rfl +theorem compCfg_qstart (tm : TM n) (inp : Tape) (work : Fin n → Tape) (out : Tape) : + compCfg tm ⟨tm.qstart, inp, work, out⟩ = + ⟨tm.complementTM.qstart, inp, work, out⟩ := rfl + -- ════════════════════════════════════════════════════════════════════════ --- Phase 1: Simulation +-- Phase 1: Simulation (via generic simulation lifting) -- ════════════════════════════════════════════════════════════════════════ private theorem complementTM_step_sim (tm : TM n) {c c' : Cfg n tm.Q} @@ -52,17 +39,57 @@ private theorem complementTM_step_sim (tm : TM n) {c c' : Cfg n tm.Q} simp only [hne, hne2, ↓reduceIte, Option.some.injEq] at hstep ⊢ rw [← hstep] -private theorem complementTM_simulation (tm : TM n) {c c' : Cfg n tm.Q} {t : ℕ} +theorem complementTM_simulation (tm : TM n) {c c' : Cfg n tm.Q} {t : ℕ} (hreach : tm.reachesIn t c c') : - tm.complementTM.reachesIn t (compCfg tm c) (compCfg tm c') := by - induction hreach with - | zero => exact .zero - | @step _ _ _ _ hstep _ ih => exact .step (complementTM_step_sim tm hstep) ih + tm.complementTM.reachesIn t (compCfg tm c) (compCfg tm c') := + simulation_reachesIn (tm' := tm.complementTM) (compCfg tm) + (fun _ _ => complementTM_step_sim tm) hreach -- ════════════════════════════════════════════════════════════════════════ --- Rewind loop (property-based, by induction on head position) +-- Rewind loop (via generic rewind) -- ════════════════════════════════════════════════════════════════════════ +/-- One rewind step: at head > 0, move left, preserve cells. -/ +private theorem complement_rewind_step_left (tm : TM n) (c : Cfg n tm.complementTM.Q) + (hstate : c.state = Sum.inr ComplementPhase.rewind) + (hread_ne : c.output.read ≠ Γ.start) + (_ : c.output.cells 0 = Γ.start) (_ : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', tm.complementTM.step c = some c' ∧ + c'.state = Sum.inr ComplementPhase.rewind ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hstate, complementTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · omega + · simp + · simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · rfl + · exact Function.update_eq_self _ _ + +/-- Base rewind step: at head = 0 (reading ▷), move right to cell 1, enter flip. -/ +private theorem complement_rewind_step_base (tm : TM n) (c : Cfg n tm.complementTM.Q) + (hstate : c.state = Sum.inr ComplementPhase.rewind) + (hread : c.output.read = Γ.start) + (_ : c.output.cells 0 = Γ.start) + (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', tm.complementTM.step c = some c' ∧ + c'.state = Sum.inr ComplementPhase.flip ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hhead : c.output.head = 0 := by + by_contra hne + have hge : c.output.head ≥ 1 := by omega + exact hnostart c.output.head hge (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, complementTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + /-- From rewind state with output head at position `h`, reach flip state at cell 1 with output cells preserved, in `h + 1` steps. -/ private theorem rewind_loop (tm : TM n) : @@ -75,54 +102,10 @@ private theorem rewind_loop (tm : TM n) : tm.complementTM.reachesIn (h + 1) c c_flip ∧ c_flip.state = Sum.inr ComplementPhase.flip ∧ c_flip.output.head = 1 ∧ - c_flip.output.cells = c.output.cells := by - intro h - induction h with - | zero => - intro c hstate hcell0 _ hhead - -- Head at 0: output reads ▷ → rewind sees start → move right, enter flip - have hne : c.state ≠ Sum.inr ComplementPhase.done := by rw [hstate]; nofun - have hread : c.output.read = Γ.start := by simp [Tape.read, hhead, hcell0] - -- Compute step - have hstep : ∃ c', tm.complementTM.step c = some c' ∧ - c'.state = Sum.inr ComplementPhase.flip ∧ - c'.output.head = 1 ∧ - c'.output.cells = c.output.cells := by - simp only [TM.step, ↓reduceIte, hstate, complementTM, hread] - refine ⟨_, rfl, rfl, ?_, ?_⟩ - · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] - · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] - obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep - exact ⟨c', .step hstep' .zero, hst', hh', hc'⟩ - | succ h ih => - intro c hstate hcell0 hnostart hhead - have hne : c.state ≠ Sum.inr ComplementPhase.done := by rw [hstate]; nofun - -- Head at h+1 ≥ 1: output reads non-▷ → move left - have hread_ne : c.output.read ≠ Γ.start := by - simp [Tape.read, hhead]; exact hnostart (h + 1) (by omega) - -- One step: state stays rewind, output head decreases, cells preserved - have hstep : ∃ c', tm.complementTM.step c = some c' ∧ - c'.state = Sum.inr ComplementPhase.rewind ∧ - c'.output.head = h ∧ - c'.output.cells = c.output.cells := by - simp only [TM.step, ↓reduceIte, hstate, complementTM, hread_ne] - refine ⟨_, rfl, rfl, ?_, ?_⟩ - · -- head: writeAndMove ... left → head - 1 - simp only [Tape.writeAndMove, Tape.move] - rw [readBackWrite_toΓ_eq' hread_ne] - simp only [Tape.write]; split - · omega -- head = 0 contradicts hhead - · simp [hhead] - · -- cells preserved: writeAndMove readBackWrite left - simp only [Tape.writeAndMove, tape_move_cells] - rw [readBackWrite_toΓ_eq' hread_ne] - simp only [Tape.write]; split - · rfl -- head = 0: no-op - · exact Function.update_eq_self _ _ - obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep - obtain ⟨c_flip, hreach, hst_flip, hh_flip, hc_flip⟩ := ih c' hst' - (by rw [hc']; exact hcell0) (by intro j hj; rw [hc']; exact hnostart j hj) hh' - exact ⟨c_flip, .step hstep' hreach, hst_flip, hh_flip, by rw [hc_flip, hc']⟩ + c_flip.output.cells = c.output.cells := + generic_rewind_loop tm.complementTM + (fun c hst hread hc0 hns => complement_rewind_step_left tm c hst hread hc0 hns) + (fun c hst hread hc0 hns => complement_rewind_step_base tm c hst hread hc0 hns) -- ════════════════════════════════════════════════════════════════════════ -- Combined: halt → rewind → flip → done @@ -130,7 +113,7 @@ private theorem rewind_loop (tm : TM n) : /-- From halted compCfg, reach done state with flipped output. Takes ≤ `output.head + 4` steps. -/ -private theorem complementTM_rewind_and_flip (tm : TM n) +theorem complementTM_rewind_and_flip (tm : TM n) (c_halt : Cfg n tm.Q) (hhalt : tm.halted c_halt) (hcell0 : c_halt.output.cells 0 = Γ.start) @@ -149,20 +132,18 @@ private theorem complementTM_rewind_and_flip (tm : TM n) simp only [TM.step, ↓reduceIte, show (compCfg tm c_halt).state = Sum.inl c_halt.state from rfl, complementTM, hhalt] refine ⟨_, rfl, rfl, ?_, ?_⟩ - · -- cells preserved - dsimp only [compCfg] + · dsimp only [compCfg] simp only [Tape.writeAndMove, tape_move_cells] by_cases hread : c_halt.output.read = Γ.start · have hh0 : c_halt.output.head = 0 := by have h := hread; simp only [Tape.read] at h by_contra hne; exact hnostart _ (by omega) h simp [Tape.write, hh0] - · rw [readBackWrite_toΓ_eq' hread] + · rw [readBackWrite_toΓ_eq hread] simp only [Tape.write]; split · rfl · exact Function.update_eq_self _ _ - · -- head ≤ original + 1 - dsimp only [compCfg] + · dsimp only [compCfg] exact tape_head_writeAndMove_le _ _ _ obtain ⟨c_rw, hstep1', hst_rw, hcells_rw, hhead_rw⟩ := hstep1 -- Step 2: rewind loop (c_rw.output.head + 1 steps) @@ -188,7 +169,6 @@ private theorem complementTM_rewind_and_flip (tm : TM n) simp [idleDir, hne1] simp [hdir2, Function.update_self] obtain ⟨c_done, hstep3', hst_done, hflip⟩ := hstep3 - -- Compose: (head_rw + 1 + 1) + 1 ≤ (head + 1 + 1) + 1 = head + 3 + 1 ≤ head + 4 refine ⟨c_done, ((c_rw.output.head + 1) + 1) + 1, reachesIn_trans tm.complementTM (.step hstep1' hreach_rw) (.step hstep3' .zero), hst_done, hflip, by omega⟩ diff --git a/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean new file mode 100644 index 0000000..0aab5ad --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean @@ -0,0 +1,507 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# ifTM simulation — proof internals + +This file contains the simulation lemmas for `ifTM tmTest tmThen tmElse`. + +## Key definitions + +- `ifTestWrap` — embed a `tmTest` config into the `ifTM` config space +- `ifThenWrap` — embed a `tmThen` config into the `ifTM` config space +- `ifElseWrap` — embed a `tmElse` config into the `ifTM` config space +-/ + +variable {n : ℕ} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +def ifTestWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmTest.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inl c.state + input := c.input + work := c.work + output := c.output + +def ifThenWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmThen.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inr (Sum.inr (Sum.inl c.state)) + input := c.input + work := c.work + output := c.output + +def ifElseWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) + (c : Cfg n tmElse.Q) : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q) where + state := Sum.inr (Sum.inr (Sum.inr c.state)) + input := c.input + work := c.work + output := c.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Sum discrimination helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem ifQ_test_ne_halt {QT QThen QElse : Type} {q : QT} : + (Sum.inl q : IfQ QT QThen QElse) ≠ Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_then_ne_halt {QT QThen QElse : Type} {q : QThen} : + (Sum.inr (Sum.inr (Sum.inl q)) : IfQ QT QThen QElse) ≠ + Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_else_ne_halt {QT QThen QElse : Type} {q : QElse} : + (Sum.inr (Sum.inr (Sum.inr q)) : IfQ QT QThen QElse) ≠ + Sum.inr (Sum.inl IfPhase.done) := nofun + +private theorem ifQ_phase_ne_halt {QT QThen QElse : Type} + {p : IfPhase} (hp : p ≠ .done) : + (Sum.inr (Sum.inl p) : IfQ QT QThen QElse) ≠ + Sum.inr (Sum.inl IfPhase.done) := + fun h => hp (Sum.inl.inj (Sum.inr.inj h)) + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase: ifTM simulates tmTest (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmTest` corresponds to one step of `ifTM` during the test phase. -/ +theorem ifTM_test_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmTest.Q} + (hstep : tmTest.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifTestWrap tmTest tmThen tmElse c) = + some (ifTestWrap tmTest tmThen tmElse c') := by + have hne : c.state ≠ tmTest.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (ifTestWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifTestWrap, ifTM, if_neg ifQ_test_ne_halt, if_neg hne] + +/-- Multi-step test phase simulation. -/ +theorem ifTM_test_simulation (tmTest tmThen tmElse : TM n) {t : ℕ} + {c_start c_end : Cfg n tmTest.Q} + (hreach : tmTest.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifTestWrap tmTest tmThen tmElse c_start) + (ifTestWrap tmTest tmThen tmElse c_end) := + simulation_reachesIn (tm' := ifTM tmTest tmThen tmElse) (ifTestWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_test_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Then branch: ifTM simulates tmThen (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmThen` corresponds to one step of `ifTM` during the then branch. -/ +theorem ifTM_then_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmThen.Q} + (hstep : tmThen.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifThenWrap tmTest tmThen tmElse c) = + some (ifThenWrap tmTest tmThen tmElse c') := by + have hne : c.state ≠ tmThen.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (ifThenWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifThenWrap, ifTM, if_neg ifQ_then_ne_halt, if_neg hne] + +/-- Multi-step then-branch simulation. -/ +theorem ifTM_then_simulation (tmTest tmThen tmElse : TM n) {t : ℕ} + {c_start c_end : Cfg n tmThen.Q} + (hreach : tmThen.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifThenWrap tmTest tmThen tmElse c_start) + (ifThenWrap tmTest tmThen tmElse c_end) := + simulation_reachesIn (tm' := ifTM tmTest tmThen tmElse) (ifThenWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_then_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Else branch: ifTM simulates tmElse (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +/-- One step of `tmElse` corresponds to one step of `ifTM` during the else branch. -/ +theorem ifTM_else_step (tmTest tmThen tmElse : TM n) {c c' : Cfg n tmElse.Q} + (hstep : tmElse.step c = some c') : + (ifTM tmTest tmThen tmElse).step (ifElseWrap tmTest tmThen tmElse c) = + some (ifElseWrap tmTest tmThen tmElse c') := by + have hne : c.state ≠ tmElse.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (ifElseWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifElseWrap, ifTM, if_neg ifQ_else_ne_halt, if_neg hne] + +/-- Multi-step else-branch simulation. -/ +theorem ifTM_else_simulation (tmTest tmThen tmElse : TM n) {t : ℕ} + {c_start c_end : Cfg n tmElse.Q} + (hreach : tmElse.reachesIn t c_start c_end) : + (ifTM tmTest tmThen tmElse).reachesIn t + (ifElseWrap tmTest tmThen tmElse c_start) + (ifElseWrap tmTest tmThen tmElse c_end) := + simulation_reachesIn (tm' := ifTM tmTest tmThen tmElse) (ifElseWrap tmTest tmThen tmElse) + (fun _ _ => ifTM_else_step tmTest tmThen tmElse) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Halt transitions: branch halt → done +-- ════════════════════════════════════════════════════════════════════════ + +/-- The tape transformation applied by halt-to-done transitions. Same as + `seqTransitionTape`/`seqTransitionInput`: preserves cells, moves heads + at position 0 to position 1. -/ +def ifTransitionTape (t : Tape) : Tape := + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) + +def ifTransitionInput (t : Tape) : Tape := + t.move (idleDir t.read) + +/-- When `tmThen` halts, one step transitions to `done`. -/ +theorem ifTM_then_halt_step (tmTest tmThen tmElse : TM n) {c : Cfg n tmThen.Q} + (hhalt : c.state = tmThen.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifThenWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.done), + input := ifTransitionInput c.input, + work := fun i => ifTransitionTape (c.work i), + output := ifTransitionTape c.output } := by + show (if (ifThenWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifThenWrap, ifTM, if_neg ifQ_then_ne_halt, hhalt, ↓reduceIte] + congr 1 + +/-- When `tmElse` halts, one step transitions to `done`. -/ +theorem ifTM_else_halt_step (tmTest tmThen tmElse : TM n) {c : Cfg n tmElse.Q} + (hhalt : c.state = tmElse.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifElseWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.done), + input := ifTransitionInput c.input, + work := fun i => ifTransitionTape (c.work i), + output := ifTransitionTape c.output } := by + show (if (ifElseWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifElseWrap, ifTM, if_neg ifQ_else_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase → rewind transition +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tmTest` halts, one step enters the rewindOut phase. -/ +theorem ifTM_test_to_rewind (tmTest tmThen tmElse : TM n) {c : Cfg n tmTest.Q} + (hhalt : c.state = tmTest.qhalt) : + (ifTM tmTest tmThen tmElse).step (ifTestWrap tmTest tmThen tmElse c) = + some { state := Sum.inr (Sum.inl IfPhase.rewindOut), + input := ifTransitionInput c.input, + work := fun i => ifTransitionTape (c.work i), + output := ifTransitionTape c.output } := by + show (if (ifTestWrap tmTest tmThen tmElse c).state = + (ifTM tmTest tmThen tmElse).qhalt then none else some _) = some _ + simp only [ifTestWrap, ifTM, if_neg ifQ_test_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting +-- ════════════════════════════════════════════════════════════════════════ + +theorem ifTM_done_is_halted (tmTest tmThen tmElse : TM n) : + (ifTM tmTest tmThen tmElse).qhalt = Sum.inr (Sum.inl IfPhase.done) := rfl + +/-- The `done` state is halted in `ifTM`. -/ +theorem ifTM_halted_done (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (h : c.state = Sum.inr (Sum.inl IfPhase.done)) : + (ifTM tmTest tmThen tmElse).halted c := h + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition tape properties +-- ════════════════════════════════════════════════════════════════════════ + +/-- `ifTransitionTape` preserves cells under the WF condition. -/ +theorem ifTransitionTape_cells (t : Tape) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + (ifTransitionTape t).cells = t.cells := by + simp only [ifTransitionTape, Tape.writeAndMove, tape_move_cells] + by_cases hh : t.head = 0 + · simp only [Tape.write, hh, ↓reduceIte] + · have hge : t.head ≥ 1 := by omega + rw [readBackWrite_toΓ_eq (by simp only [Tape.read]; exact hns t.head hge)] + simp only [Tape.write, hh, ↓reduceIte, Tape.read, Function.update_eq_self] + +/-- `ifTransitionInput` preserves cells. -/ +theorem ifTransitionInput_cells (t : Tape) : + (ifTransitionInput t).cells = t.cells := by + simp [ifTransitionInput, Tape.move]; split <;> rfl + +/-- After `ifTransitionTape`, the head is ≥ 1 when cell 0 = start. -/ +theorem ifTransitionTape_head_ge (t : Tape) (h0 : t.cells 0 = Γ.start) : + (ifTransitionTape t).head ≥ 1 := by + unfold ifTransitionTape Tape.writeAndMove + by_cases hh : t.head = 0 + · simp only [Tape.write, hh, ↓reduceIte, Tape.read, h0, idleDir, Tape.move]; omega + · have hge : t.head ≥ 1 := by omega + cases hdir : idleDir t.read with + | stay => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | right => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | left => + exfalso; revert hdir; simp only [idleDir]; split <;> simp + +/-- After `ifTransitionInput`, the head is ≥ 1 when cell 0 = start. -/ +theorem ifTransitionInput_head_ge (t : Tape) (h0 : t.cells 0 = Γ.start) : + (ifTransitionInput t).head ≥ 1 := by + unfold ifTransitionInput + by_cases hh : t.head = 0 + · simp only [Tape.read, hh, h0, idleDir, ↓reduceIte, Tape.move]; omega + · cases hdir : idleDir t.read with + | stay => simp only [Tape.move]; omega + | right => simp only [Tape.move]; omega + | left => + exfalso; revert hdir; simp only [idleDir]; split <;> simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem if_rewind_step_left (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread_ne : c.output.read ≠ Γ.start) + (_ : c.output.cells 0 = Γ.start) (_ : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · omega + · simp + · simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · rfl + · exact Function.update_eq_self _ _ + +private theorem if_rewind_step_base (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread : c.output.read = Γ.start) + (_ : c.output.cells 0 = Γ.start) + (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hhead : c.output.head = 0 := by + by_contra hne + exact hnostart c.output.head (by omega) (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + +/-- The full rewind loop: from rewindOut with output head at position `p`, + reach check state at cell 1 in `p + 1` steps. Output cells are preserved. -/ +theorem ifTM_rewind_loop (tmTest tmThen tmElse : TM n) : + ∀ (p : ℕ) (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)), + c.state = Sum.inr (Sum.inl IfPhase.rewindOut) → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = p → + ∃ c_check, + (ifTM tmTest tmThen tmElse).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells := + generic_rewind_loop (ifTM tmTest tmThen tmElse) + (fun c hst hread hc0 hns => if_rewind_step_left tmTest tmThen tmElse c hst hread hc0 hns) + (fun c hst hread hc0 hns => if_rewind_step_base tmTest tmThen tmElse c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (full tape tracking, via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem if_rewind_step_left_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread_ne : c.output.read ≠ Γ.start) + (_ : c.output.cells 0 = Γ.start) (_ : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (h_ih : c.input.head ≥ 1) (h_ins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (h_wh : ∀ i, (c.work i).head ≥ 1) (h_wns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · omega + · simp + · simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · rfl + · exact Function.update_eq_self _ _ + · exact tape_move_idleDir_stable _ h_ih h_ins + · ext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +private theorem if_rewind_step_base_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.rewindOut)) + (hread : c.output.read = Γ.start) + (_ : c.output.cells 0 = Γ.start) + (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (h_ih : c.input.head ≥ 1) (h_ins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (h_wh : ∀ i, (c.work i).head ≥ 1) (h_wns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hhead : c.output.head = 0 := by + by_contra hne + exact hnostart c.output.head (by omega) (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + · exact tape_move_idleDir_stable _ h_ih h_ins + · ext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +/-- Extended rewind loop: also tracks that input and work tapes are preserved + when they satisfy the stability condition (head ≥ 1, cells ≥ 1 ≠ start). -/ +theorem ifTM_rewind_loop_full (tmTest tmThen tmElse : TM n) : + ∀ (p : ℕ) (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)), + c.state = Sum.inr (Sum.inl IfPhase.rewindOut) → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = p → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + (∀ i, (c.work i).head ≥ 1) → + (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c_check, + (ifTM tmTest tmThen tmElse).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl IfPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells ∧ + c_check.input = c.input ∧ + c_check.work = c.work := + generic_rewind_loop_full (ifTM tmTest tmThen tmElse) + (fun c hst hread hc0 hns h_ih h_ins h_wh h_wns => + if_rewind_step_left_full tmTest tmThen tmElse c hst hread hc0 hns h_ih h_ins h_wh h_wns) + (fun c hst hread hc0 hns h_ih h_ins h_wh h_wns => + if_rewind_step_base_full tmTest tmThen tmElse c hst hread hc0 hns h_ih h_ins h_wh h_wns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Check step: read output at cell 1, branch to then or else +-- ════════════════════════════════════════════════════════════════════════ + +/-- Check step when output cell 1 = Γ.one: branch to tmThen. + Requires the nostart invariant on output for cell preservation. -/ +theorem ifTM_check_step_then (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Γ.one) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inl tmThen.qstart)) ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread : c.output.read = Γ.one := by simp [Tape.read, hhead, hcell1] + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_⟩ + show (c.output.writeAndMove (readBackWrite Γ.one).toΓ (idleDir Γ.one)).cells = c.output.cells + simp only [readBackWrite, Γw.toΓ, idleDir, Tape.writeAndMove, tape_move_cells] + simp only [Tape.write]; split + · omega + · dsimp only []; rw [hhead, ← hcell1]; exact Function.update_eq_self _ _ + +/-- Check step when output cell 1 ≠ Γ.one: branch to tmElse. + Requires the nostart invariant on output for cell preservation. -/ +theorem ifTM_check_step_else (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 ≠ Γ.one) + (hnostart_out : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inr tmElse.qstart)) ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread_ne_one : c.output.read ≠ Γ.one := by + simp [Tape.read, hhead]; exact hcell1 + have hread_ne_start : c.output.read ≠ Γ.start := by + simp only [Tape.read, hhead]; exact hnostart_out 1 (by omega) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne_one] + refine ⟨_, rfl, rfl, ?_⟩ + apply tape_readBackWrite_preserves + right; exact hread_ne_start + +-- ════════════════════════════════════════════════════════════════════════ +-- Check step (full tape tracking) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Check step to then-branch, tracking all tapes. -/ +theorem ifTM_check_step_then_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Γ.one) + (h_ih : c.input.head ≥ 1) (h_ins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (h_wh : ∀ i, (c.work i).head ≥ 1) + (h_wns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inl tmThen.qstart)) ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread : c.output.read = Γ.one := by simp [Tape.read, hhead, hcell1] + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · show (c.output.writeAndMove (readBackWrite Γ.one).toΓ (idleDir Γ.one)).cells = c.output.cells + simp only [readBackWrite, Γw.toΓ, idleDir, Tape.writeAndMove, tape_move_cells] + simp only [Tape.write]; split + · omega + · dsimp only []; rw [hhead, ← hcell1]; exact Function.update_eq_self _ _ + · simp only [readBackWrite, Γw.toΓ, idleDir, Tape.writeAndMove, Tape.move, Tape.write] + split <;> simp_all + · exact tape_move_idleDir_stable _ h_ih h_ins + · ext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +/-- Check step to else-branch, tracking all tapes. -/ +theorem ifTM_check_step_else_full (tmTest tmThen tmElse : TM n) + (c : Cfg n (IfQ tmTest.Q tmThen.Q tmElse.Q)) + (hstate : c.state = Sum.inr (Sum.inl IfPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 ≠ Γ.one) + (hnostart_out : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (h_ih : c.input.head ≥ 1) (h_ins : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (h_wh : ∀ i, (c.work i).head ≥ 1) + (h_wns : ∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) : + ∃ c', (ifTM tmTest tmThen tmElse).step c = some c' ∧ + c'.state = Sum.inr (Sum.inr (Sum.inr tmElse.qstart)) ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := by + have hne : c.state ≠ (ifTM tmTest tmThen tmElse).qhalt := by rw [hstate]; nofun + have hread_ne_one : c.output.read ≠ Γ.one := by simp [Tape.read, hhead]; exact hcell1 + have hread_ne_start : c.output.read ≠ Γ.start := by + simp only [Tape.read, hhead]; exact hnostart_out 1 (by omega) + simp only [TM.step, ↓reduceIte, hstate, ifTM, hread_ne_one] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · apply tape_readBackWrite_preserves; right; exact hread_ne_start + · have hstable := tape_writeAndMove_stable c.output (by omega) hnostart_out + show (c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read)).head = 1 + rw [hstable, hhead] + · exact tape_move_idleDir_stable _ h_ih h_ins + · ext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal.lean index fd58f24..f04aeaf 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/Internal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal.lean @@ -1,1588 +1,2 @@ -import Complexitylib.Models.TuringMachine.Combinators - -/-! -# unionTM simulation — proof internals - -This file contains the simulation lemmas needed to prove that `unionTM tm₁ tm₂` -correctly decides `L₁ ∪ L₂` when `tm₁` decides `L₁` and `tm₂` decides `L₂`. - -## Strategy - -The proof proceeds in three phases: - -1. **Phase 1 simulation**: Show that the union machine faithfully simulates - `tm₁` for `t₁` steps, with tm₁'s output redirected to the fake output - tape (work tape `n₁`). - -2. **Transition phase**: After Phase 1, the machine rewinds the fake output - to check tm₁'s result. If tm₁ accepted (cell 1 = `Γ.one`), write `Γ.one` - to the real output and halt. Otherwise, rewind the input and start Phase 2. - -3. **Phase 2 simulation**: Simulate `tm₂` using the real output tape. - -## Key definitions - -- `idleTape` — the steady-state of an idle tape (head at 1, cells from `initTape []`) -- `phase1Cfg` — embedding of a tm₁ config into the union machine's config space --/ - -variable {n₁ n₂ : ℕ} - -namespace TM - --- ════════════════════════════════════════════════════════════════════════ --- Idle tape --- ════════════════════════════════════════════════════════════════════════ - -/-- The steady-state tape for an idle tape during Phase 1. - After the first step (where `δ_right_of_start` forces a right move from - cell 0), idle tapes remain at head position 1 with blank cells. -/ -def idleTape : Tape := - { head := 1, cells := (initTape ([] : List Γ)).cells } - -private theorem idleTape_read : idleTape.read = Γ.blank := by - simp [idleTape, Tape.read, initTape] - -private theorem idleTape_head : idleTape.head = 1 := rfl - -/-- Writing blank to an idle tape at position 1 is a no-op. -/ -private theorem idleTape_write_blank : idleTape.write Γ.blank = idleTape := by - simp [idleTape, Tape.write, initTape, Function.update_eq_self_iff] - -/-- Moving stay on an idle tape is a no-op. -/ -private theorem idleTape_move_stay : idleTape.move Dir3.stay = idleTape := by - rfl - -/-- An idle tape stays idle when written with blank and moved by idleDir. -/ -private theorem idleTape_step_idle : - (idleTape.write Γw.blank.toΓ).move (idleDir idleTape.read) = idleTape := by - show (idleTape.write Γ.blank).move (idleDir idleTape.read) = idleTape - rw [idleTape_read, idleDir, if_neg (by decide)] - simp [idleTape_write_blank, Tape.move] - --- ════════════════════════════════════════════════════════════════════════ --- Phase 1 config embedding --- ════════════════════════════════════════════════════════════════════════ - -/-- Embed a tm₁ configuration into the union machine's config space. - Active tapes (input, work 0..n₁-1, fake output at n₁) come from `c`. - Idle tapes (work n₁+1..n₁+n₂ and real output) use `idleTape`. -/ -def phase1Cfg (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : - Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) where - state := Sum.inl c.state - input := c.input - work := fun i => - if h : i.val < n₁ then c.work ⟨i.val, h⟩ - else if i.val = n₁ then c.output - else idleTape - output := idleTape - --- ════════════════════════════════════════════════════════════════════════ --- Phase 1: one-step correspondence --- ════════════════════════════════════════════════════════════════════════ - -/-- Key computation: unionTM.δ for a Phase 1 non-halted state delegates to tm₁.δ. -/ -private theorem unionTM_delta_inl (tm₁ : TM n₁) (tm₂ : TM n₂) {q : tm₁.Q} - (hne : q ≠ tm₁.qhalt) (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : - (unionTM tm₁ tm₂).δ (Sum.inl q) iHead wHeads oHead = - let r := tm₁.δ q iHead (phase1WorkReads wHeads) (wHeads fakeOutIdx) - (Sum.inl r.1, - fun i => if h : i.val < n₁ then r.2.1 ⟨i.val, h⟩ else if i.val = n₁ then r.2.2.1 else .blank, - .blank, r.2.2.2.1, - fun i => if h : i.val < n₁ then r.2.2.2.2.1 ⟨i.val, h⟩ - else if i.val = n₁ then r.2.2.2.2.2 else idleDir (wHeads i), - idleDir oHead) := by - simp only [unionTM, if_neg hne] - -private theorem unionTM_qhalt (tm₁ : TM n₁) (tm₂ : TM n₂) : - (unionTM tm₁ tm₂).qhalt = Sum.inr (Sum.inr tm₂.qhalt) := rfl - -/-- Key computation: unionTM.δ for a Phase 2 non-halted state delegates to tm₂.δ. -/ -private theorem unionTM_delta_inr_inr (tm₁ : TM n₁) (tm₂ : TM n₂) {q : tm₂.Q} - (hne : q ≠ tm₂.qhalt) (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inr q)) iHead wHeads oHead = - let r := tm₂.δ q iHead (phase2WorkReads wHeads) oHead - (Sum.inr (Sum.inr r.1), - fun i => if h : i.val ≤ n₁ then (Γw.blank : Γw) else r.2.1 ⟨i.val - (n₁ + 1), by omega⟩, - r.2.2.1, r.2.2.2.1, - fun i => if h : i.val ≤ n₁ then idleDir (wHeads i) else r.2.2.2.2.1 ⟨i.val - (n₁ + 1), by omega⟩, - r.2.2.2.2.2) := by - simp only [unionTM, if_neg hne] - -private theorem phase1Cfg_state (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : - (phase1Cfg tm₁ tm₂ c).state = Sum.inl c.state := rfl - -private theorem phase1_step_corr (tm₁ : TM n₁) (tm₂ : TM n₂) - {c c' : Cfg n₁ tm₁.Q} (hstep : tm₁.step c = some c') : - (unionTM tm₁ tm₂).step (phase1Cfg tm₁ tm₂ c) = some (phase1Cfg tm₁ tm₂ c') := by - have hne : c.state ≠ tm₁.qhalt := by - intro heq; simp [step, heq] at hstep - -- Extract c' from tm₁.step - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep - subst hstep - -- Unfold step for unionTM on phase1Cfg - simp only [step, phase1Cfg_state, unionTM_qhalt] - rw [if_neg (show (Sum.inl c.state : UnionQ tm₁.Q tm₂.Q) ≠ Sum.inr (Sum.inr tm₂.qhalt) from - fun h => nomatch h)] - simp only [Option.some.injEq] - -- Rewrite the δ call using our helper - simp only [unionTM_delta_inl tm₁ tm₂ hne] - -- Now unfold phase1Cfg on both sides and simplify - dsimp only [phase1Cfg] - -- Establish that the δ calls produce the same result - have hfake_read : (if h : (n₁ : ℕ) < n₁ then c.work ⟨n₁, h⟩ - else if (n₁ : ℕ) = n₁ then c.output else idleTape).read = c.output.read := by - rw [dif_neg (Nat.lt_irrefl n₁), if_pos rfl] - have hwork_reads : (phase1WorkReads fun i : Fin (n₁ + 1 + n₂) => - (if h : i.val < n₁ then c.work ⟨i.val, h⟩ - else if i.val = n₁ then c.output else idleTape).read) = - fun j => (c.work j).read := by - ext ⟨j, hj⟩; simp only [phase1WorkReads]; rw [dif_pos (show j < n₁ from hj)] - -- Simplify fakeOutIdx to ⟨n₁, _⟩ and reduce the dite conditions - simp only [fakeOutIdx] at hfake_read ⊢ - -- Rewrite the work reads and fake output read - simp_rw [hwork_reads, hfake_read] - -- State and input match by rfl; work and output need case analysis - have hcfg : ∀ (a b : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - a.state = b.state → a.input = b.input → a.work = b.work → a.output = b.output → a = b := by - intros a b hs hi hw ho; cases a; cases b; simp_all - apply hcfg - · rfl -- state - · rfl -- input - · -- work tapes: case split on i - ext i; dsimp only []; split - · rfl -- i < n₁: active work tape - · split - · rfl -- i = n₁: fake output - · -- i > n₁: idle tape stays idle - exact idleTape_step_idle - · -- output: idle tape stays idle - exact idleTape_step_idle - --- ════════════════════════════════════════════════════════════════════════ --- Phase 1 simulation --- ════════════════════════════════════════════════════════════════════════ - -/-- Multi-step Phase 1: if tm₁ takes t steps from c to c', the union machine - takes t steps from phase1Cfg c to phase1Cfg c'. -/ -private theorem phase1_steps (tm₁ : TM n₁) (tm₂ : TM n₂) - {t : ℕ} {c c' : Cfg n₁ tm₁.Q} - (hreach : tm₁.reachesIn t c c') : - (unionTM tm₁ tm₂).reachesIn t (phase1Cfg tm₁ tm₂ c) (phase1Cfg tm₁ tm₂ c') := by - induction hreach with - | zero => exact .zero - | step hstep _ ih => exact .step (phase1_step_corr tm₁ tm₂ hstep) ih - -/-- The first step of unionTM on initCfg produces phase1Cfg of tm₁'s first step result. - At step 0, all tapes are at cell 0 with ▷, so δ_right_of_start forces right moves. - After this step, idle tapes become idleTape (head=1, blank cells). -/ -private theorem phase1_init_step (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) - {c_mid : Cfg n₁ tm₁.Q} (hstep : tm₁.step (tm₁.initCfg x) = some c_mid) : - (unionTM tm₁ tm₂).step ((unionTM tm₁ tm₂).initCfg x) = some (phase1Cfg tm₁ tm₂ c_mid) := by - have hne : tm₁.qstart ≠ tm₁.qhalt := by - intro heq; simp [step, heq] at hstep - simp only [step] at hstep ⊢ - rw [if_neg hne] at hstep - simp only [Option.some.injEq] at hstep - subst hstep - -- Unfold unionTM qstart/qhalt - rw [show (unionTM tm₁ tm₂).qstart = Sum.inl tm₁.qstart from rfl, - show (unionTM tm₁ tm₂).qhalt = Sum.inr (Sum.inr tm₂.qhalt) from rfl] - rw [if_neg (fun h : (Sum.inl tm₁.qstart : UnionQ tm₁.Q tm₂.Q) = Sum.inr (Sum.inr tm₂.qhalt) => - nomatch h)] - simp only [Option.some.injEq] - -- Rewrite the unionTM δ call - simp only [unionTM_delta_inl tm₁ tm₂ hne] - -- The phase1WorkReads of constant function is a constant function - have hwork_reads : phase1WorkReads (fun (_ : Fin (n₁ + 1 + n₂)) => (initTape ([] : List Γ)).read) = - fun _ => (initTape ([] : List Γ)).read := by ext; rfl - simp_rw [hwork_reads] - -- Now the δ calls match; show Cfg equality field by field - have hcfg : ∀ (a b : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - a.state = b.state → a.input = b.input → a.work = b.work → a.output = b.output → a = b := by - intros a b hs hi hw ho; cases a; cases b; simp_all - apply hcfg - · rfl -- state - · rfl -- input - · -- work tapes - ext i; dsimp only [phase1Cfg]; split - · -- i < n₁: all tapes start at initTape [], write at head 0 is no-op - simp [initTape, Tape.read] - · split - · -- i = n₁ - simp [initTape, Tape.read] - · -- i > n₁: becomes idleTape - simp [initTape, Tape.write, Tape.read, idleTape, idleDir, Tape.move] - · -- output: becomes idleTape (phase1Cfg always has idleTape as output) - simp only [phase1Cfg] - simp [initTape, Tape.write, Tape.read, idleDir, Tape.move, idleTape] - -theorem phase1_simulation (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) - {t₁ : ℕ} {c₁ : Cfg n₁ tm₁.Q} - (hreach : tm₁.reachesIn t₁ (tm₁.initCfg x) c₁) - (ht₁ : t₁ ≥ 1) : - (unionTM tm₁ tm₂).reachesIn t₁ ((unionTM tm₁ tm₂).initCfg x) - (phase1Cfg tm₁ tm₂ c₁) := by - -- Split the first step off - cases hreach with - | zero => omega -- contradicts t₁ ≥ 1 - | step hstep hrest => - exact .step (phase1_init_step tm₁ tm₂ x hstep) (phase1_steps tm₁ tm₂ hrest) - --- ════════════════════════════════════════════════════════════════════════ --- Determinism of reachesIn --- ════════════════════════════════════════════════════════════════════════ - -/-- `reachesIn` is deterministic: since `step` is a function, the endpoint - is uniquely determined by the start config and step count. -/ -theorem reachesIn_det {tm : TM n₁} {t : ℕ} {c c' c'' : Cfg n₁ tm.Q} - (h₁ : tm.reachesIn t c c') (h₂ : tm.reachesIn t c c'') : c' = c'' := by - induction h₁ with - | zero => cases h₂; rfl - | step hs₁ _ ih₁ => - cases h₂ with - | step hs₂ h₂' => - have heq : some _ = some _ := hs₁.symm.trans hs₂ - simp only [Option.some.injEq] at heq; subst heq - exact ih₁ h₂' - --- ════════════════════════════════════════════════════════════════════════ --- Tape invariant helpers --- ════════════════════════════════════════════════════════════════════════ - -private theorem Tape.move_cells (t : Tape) (d : Dir3) : - (t.move d).cells = t.cells := by - cases d <;> rfl - -/-- If a tape has head ≥ 1 and cells[≥1] ≠ start, idleDir gives stay (head unchanged). -/ -private theorem idleDir_stay_of_ge_one (t : Tape) - (hhead : t.head ≥ 1) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : - idleDir t.read = Dir3.stay := by - rw [idleDir, if_neg]; rw [Tape.read]; exact hno _ hhead - -/-- Input head stays constant when moved by idleDir if head ≥ 1 and cells[≥1] ≠ start. -/ -private theorem idle_move_preserves_head (t : Tape) - (hhead : t.head ≥ 1) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : - (t.move (idleDir t.read)).head = t.head := by - rw [idleDir_stay_of_ge_one t hhead hno]; rfl - -private theorem Γw_toΓ_ne_start (w : Γw) : w.toΓ ≠ Γ.start := by - cases w <;> decide - -private theorem readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : - (readBackWrite g).toΓ = g := by - cases g <;> simp_all [readBackWrite, Γw.toΓ] - -private theorem readBackWrite_toΓ_ne_start (g : Γ) : (readBackWrite g).toΓ ≠ Γ.start := by - cases g <;> simp [readBackWrite, Γw.toΓ] - -/-- Cell 0 stays Γ.start after write + move. -/ -private theorem tape_cell0_preserved (t : Tape) (s : Γ) (d : Dir3) - (h0 : t.cells 0 = Γ.start) : - ((t.write s).move d).cells 0 = Γ.start := by - rw [Tape.move_cells]; simp only [Tape.write] - split - · exact h0 - · simp only [Function.update, dif_neg (show (0 : ℕ) ≠ t.head from fun h => by omega)] - exact h0 - -/-- Cells ≥ 1 stay non-Γ.start after writing a non-Γ.start value. -/ -private theorem tape_noStart_preserved (t : Tape) (s : Γ) (d : Dir3) - (hs : s ≠ Γ.start) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : - ∀ i, i ≥ 1 → ((t.write s).move d).cells i ≠ Γ.start := by - intro i hi; rw [Tape.move_cells]; simp only [Tape.write] - split - · exact hno i hi - · simp only [Function.update]; split - · next heq => subst heq; exact hs - · exact hno i hi - -/-- Output cell 0 = Γ.start is preserved by one TM step. -/ -private theorem output_cell0_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} - (hs : tm.step c = some c') (h0 : c.output.cells 0 = Γ.start) : - c'.output.cells 0 = Γ.start := by - have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs - exact tape_cell0_preserved _ _ _ h0 - -/-- Output cells ≥ 1 ≠ Γ.start is preserved by one TM step. -/ -private theorem output_noStart_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} - (hs : tm.step c = some c') (hno : ∀ i, i ≥ 1 → c.output.cells i ≠ Γ.start) : - ∀ i, i ≥ 1 → c'.output.cells i ≠ Γ.start := by - have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs - exact tape_noStart_preserved _ _ _ (Γw_toΓ_ne_start _) hno - -theorem output_cell0_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} - (h : tm.reachesIn t c₀ c) (h0 : c₀.output.cells 0 = Γ.start) : - c.output.cells 0 = Γ.start := by - induction h with - | zero => exact h0 - | step hs _ ih => exact ih (output_cell0_step hs h0) - -theorem output_noStart_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} - (h : tm.reachesIn t c₀ c) - (hno : ∀ i, i ≥ 1 → c₀.output.cells i ≠ Γ.start) : - ∀ i, i ≥ 1 → c.output.cells i ≠ Γ.start := by - induction h with - | zero => exact hno - | step hs _ ih => exact ih (output_noStart_step hs hno) - -theorem input_cells_of_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} - (hs : tm.step c = some c') : c'.input.cells = c.input.cells := by - have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs - exact Tape.move_cells _ _ - -theorem input_cells_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} - (h : tm.reachesIn t c₀ c) : c.input.cells = c₀.input.cells := by - induction h with - | zero => rfl - | step hs _ ih => rw [ih, input_cells_of_step hs] - -theorem initTape_cell0 (xs : List Γ) : (initTape xs).cells 0 = Γ.start := by - simp [initTape] - -theorem initTape_nil_noStart {i : ℕ} (hi : i ≥ 1) : - (initTape ([] : List Γ)).cells i ≠ Γ.start := by - simp [initTape, show i ≠ 0 from by omega] - --- ════════════════════════════════════════════════════════════════════════ --- Union TM delta helpers for Mid states --- ════════════════════════════════════════════════════════════════════════ - -/-- Delta computation for rewindOut when fake output is not at start. -/ -private theorem unionTM_delta_rewindOut_nostart (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : wHeads fakeOutIdx ≠ Γ.start) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindOut)) iHead wHeads oHead = - ( Sum.inr (Sum.inl Mid.rewindOut), - fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, - .blank, idleDir iHead, - fun i => if i.val = n₁ then Dir3.left else idleDir (wHeads i), - idleDir oHead ) := by - unfold unionTM; simp only [if_neg hread] - -/-- Delta computation for rewindOut when fake output is at start. -/ -private theorem unionTM_delta_rewindOut_start (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : wHeads fakeOutIdx = Γ.start) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindOut)) iHead wHeads oHead = - ( Sum.inr (Sum.inl Mid.checkResult), - fun _ => .blank, .blank, idleDir iHead, - fun i => if i.val = n₁ then Dir3.right else idleDir (wHeads i), - idleDir oHead ) := by - unfold unionTM; simp only [if_pos hread] - -/-- Delta computation for checkResult when fake output reads Γ.one. -/ -private theorem unionTM_delta_checkResult_one (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : wHeads fakeOutIdx = Γ.one) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.checkResult)) iHead wHeads oHead = - ( Sum.inr (Sum.inr tm₂.qhalt), - fun _ => .blank, .one, idleDir iHead, - fun i => idleDir (wHeads i), - idleDir oHead ) := by - unfold unionTM; simp only [if_pos hread] - -/-- Delta computation for checkResult when fake output does not read Γ.one. -/ -private theorem unionTM_delta_checkResult_notone (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : wHeads fakeOutIdx ≠ Γ.one) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.checkResult)) iHead wHeads oHead = - allIdle (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead := by - unfold unionTM; simp only [if_neg hread] - -/-- Delta computation for rewindIn when input is not at start. -/ -private theorem unionTM_delta_rewindIn_nostart (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : iHead ≠ Γ.start) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead = - ( Sum.inr (Sum.inl Mid.rewindIn), - fun _ => .blank, .blank, Dir3.left, - fun i => idleDir (wHeads i), - idleDir oHead ) := by - simp only [unionTM, if_neg hread] - -/-- Delta computation for rewindIn when input is at start. -/ -private theorem unionTM_delta_rewindIn_start (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) - (hread : iHead = Γ.start) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead = - ( Sum.inr (Sum.inl Mid.setup2), - fun _ => .blank, .blank, Dir3.right, - fun i => idleDir (wHeads i), - idleDir oHead ) := by - simp only [unionTM, if_pos hread] - -/-- Delta computation for setup2. -/ -private theorem unionTM_delta_setup2 (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : - (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.setup2)) iHead wHeads oHead = - ( Sum.inr (Sum.inr tm₂.qstart), - fun _ => .blank, .blank, moveLeftDir iHead, - fun i => if i.val ≤ n₁ then idleDir (wHeads i) else moveLeftDir (wHeads i), - moveLeftDir oHead ) := by - unfold unionTM; rfl - -/-- Delta computation for Phase 1 halted state (transition to rewindOut). -/ -private theorem unionTM_delta_inl_qhalt (tm₁ : TM n₁) (tm₂ : TM n₂) - (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : - (unionTM tm₁ tm₂).δ (Sum.inl tm₁.qhalt) iHead wHeads oHead = - ( Sum.inr (Sum.inl Mid.rewindOut), - fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, - .blank, - idleDir iHead, - fun i => idleDir (wHeads i), - idleDir oHead ) := by - simp only [unionTM, ite_true] - --- ════════════════════════════════════════════════════════════════════════ --- One-step lemmas for union TM --- ════════════════════════════════════════════════════════════════════════ - -/-- The union machine is not halted in any Mid state. -/ -private theorem unionTM_mid_not_halted (tm₁ : TM n₁) (tm₂ : TM n₂) (m : Mid) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl m)) : - c.state ≠ (unionTM tm₁ tm₂).qhalt := by - rw [hstate]; exact fun h => nomatch h - -/-- The union machine is not halted when in a Phase 1 state. -/ -private theorem unionTM_inl_not_halted (tm₁ : TM n₁) (tm₂ : TM n₂) (q : tm₁.Q) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inl q) : - c.state ≠ (unionTM tm₁ tm₂).qhalt := by - rw [hstate]; exact fun h => nomatch h - -/-- Step the union machine from a rewindOut state with non-start fake output read. -/ -private theorem step_rewindOut_nostart_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.rewindOut)) - (hread : (c.work fakeOutIdx).read ≠ Γ.start) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write - ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread] - -/-- Step the union machine from a rewindOut state when fake output reads start. -/ -private theorem step_rewindOut_start_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.rewindOut)) - (hread : (c.work fakeOutIdx).read = Γ.start) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.checkResult), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move - (if i.val = n₁ then Dir3.right else idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] - -/-- Step the union machine from checkResult with Γ.one → halted. -/ -private theorem step_checkResult_one_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.checkResult)) - (hread : (c.work fakeOutIdx).read = Γ.one) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inr tm₂.qhalt), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), - output := (c.output.write Γw.one.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] - -/-- Step the union machine from checkResult when not Γ.one → rewindIn (allIdle). -/ -private theorem step_checkResult_notone_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.checkResult)) - (hread : (c.work fakeOutIdx).read ≠ Γ.one) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.rewindIn), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread, allIdle] - -/-- Step the union machine from rewindIn with non-start input. -/ -private theorem step_rewindIn_nostart_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.rewindIn)) - (hread : c.input.read ≠ Γ.start) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.rewindIn), - input := c.input.move Dir3.left, - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread] - -/-- Step the union machine from rewindIn when input reads start. -/ -private theorem step_rewindIn_start_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.rewindIn)) - (hread : c.input.read = Γ.start) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.setup2), - input := c.input.move Dir3.right, - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] - -/-- Step the union machine from setup2. -/ -private theorem step_setup2_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inr (Sum.inl Mid.setup2)) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inr tm₂.qstart), - input := c.input.move (moveLeftDir c.input.read), - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move - (if i.val ≤ n₁ then idleDir (c.work i).read else moveLeftDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (moveLeftDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; rfl - -/-- Step the union machine from phase1Cfg when tm₁ halted. -/ -private theorem step_inl_qhalt_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) - {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hstate : c.state = Sum.inl tm₁.qhalt) : - (unionTM tm₁ tm₂).step c = some - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write - ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h - simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, ite_true] - --- ════════════════════════════════════════════════════════════════════════ --- Rewind fake output loop --- ════════════════════════════════════════════════════════════════════════ - -/-- The fake output tape's head position 0 corresponds to reading Γ.start. -/ -private theorem fakeOut_read_start_iff_head_zero (t : Tape) (h0 : t.cells 0 = Γ.start) - (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : - t.read = Γ.start ↔ t.head = 0 := by - constructor - · intro hr - by_contra hne - exact hno t.head (by omega) (by rwa [Tape.read] at hr) - · intro heq; rw [Tape.read, heq]; exact h0 - -/-- readBackWrite preserves cells at non-zero head positions. -/ -private theorem write_readBack_cells_eq (t : Tape) (hne : t.read ≠ Γ.start) : - (t.write (readBackWrite t.read).toΓ).cells = t.cells := by - rw [readBackWrite_toΓ_eq hne] - simp only [Tape.write] - split - · rfl - · ext i; simp only [Function.update]; split - · next heq => subst heq; rfl - · rfl - -/-- Moving left from a non-zero position decreases the head. -/ -private theorem move_left_head (t : Tape) (_h : t.head ≥ 1) : - (t.move Dir3.left).head = t.head - 1 := by - simp [Tape.move] - -/-- Rewind the fake output tape from head position `h` to head position 0. - After `h` steps in `rewindOut` state, we reach a config where the fake - output head is at 0, and one more step transitions to `checkResult`. -/ -private theorem rewind_fakeOut_loop (tm₁ : TM n₁) (tm₂ : TM n₂) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindOut) → - (c.work fakeOutIdx).head = h → - (c.work fakeOutIdx).cells 0 = Γ.start → - (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ - (c'.work fakeOutIdx).head = 0 ∧ - (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by - intro h - induction h with - | zero => - intro c hst hhead _ _ - exact ⟨c, .zero, hst, hhead, rfl⟩ - | succ n ih => - intro c hst hhead hcell0 hnostart - -- The fake output head is at n+1 ≥ 1, so read ≠ Γ.start - have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - -- One rewindOut step - -- One rewindOut step using the step cfg lemma directly - have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne - -- Extract the next config - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write - ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - with hc'_def - -- c' state - have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindOut) := rfl - -- c' fake output head - have hhead' : (c'.work fakeOutIdx).head = n := by - -- c'.work fakeOutIdx unfolds via set definition - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [readBackWrite_toΓ_eq hread_ne] - simp only [Tape.write] - split - · -- head = 0, contradiction since head = n+1 - omega - · simp [Tape.move, hhead] - -- c' fake output cells preserved - have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] - -- Apply IH - have hcell0' : (c'.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells']; exact hcell0 - have hnostart' : ∀ i, i ≥ 1 → (c'.work fakeOutIdx).cells i ≠ Γ.start := by - rw [hcells']; exact hnostart - obtain ⟨c'', hreach, hst'', hhead'', hcells''⟩ := ih c' hst' hhead' hcell0' hnostart' - exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells']⟩ - --- ════════════════════════════════════════════════════════════════════════ --- Transition phase: accept path (x ∈ L₁) --- ════════════════════════════════════════════════════════════════════════ - -/-- idleTape invariant: cells 0 = start. -/ -private theorem idleTape_cells_0 : idleTape.cells 0 = Γ.start := by - simp [idleTape, initTape] - -/-- idleTape invariant: cells ≥ 1 ≠ start. -/ -private theorem idleTape_noStart (i : ℕ) (hi : i ≥ 1) : idleTape.cells i ≠ Γ.start := by - simp [idleTape, initTape, show i ≠ 0 from by omega] - -/-- phase1Cfg output is idleTape. -/ -private theorem phase1Cfg_output (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : - (phase1Cfg tm₁ tm₂ c).output = idleTape := rfl - -/-- phase1Cfg fake output tape is c.output. -/ -private theorem phase1Cfg_fakeOut (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : - (phase1Cfg tm₁ tm₂ c).work fakeOutIdx = c.output := by - simp [phase1Cfg, fakeOutIdx] - -/-- One step from phase1Cfg when tm₁ is halted transitions to rewindOut. -/ -private theorem step_phase1_halted (tm₁ : TM n₁) (tm₂ : TM n₂) - (c₁ : Cfg n₁ tm₁.Q) (hhalt : tm₁.halted c₁) - (hnostart_out : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) : - ∃ c', (unionTM tm₁ tm₂).step (phase1Cfg tm₁ tm₂ c₁) = some c' ∧ - c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ - (c'.work fakeOutIdx).cells = c₁.output.cells ∧ - c'.output = (idleTape.write Γw.blank.toΓ).move (idleDir idleTape.read) := by - have hstate : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by - show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] - have hstep := step_inl_qhalt_cfg tm₁ tm₂ hstate - -- The result config - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := (phase1Cfg tm₁ tm₂ c₁).input.move (idleDir (phase1Cfg tm₁ tm₂ c₁).input.read), - work := fun i => (((phase1Cfg tm₁ tm₂ c₁).work i).write - ((if i.val = n₁ then readBackWrite ((phase1Cfg tm₁ tm₂ c₁).work fakeOutIdx).read else .blank) : Γw).toΓ).move - (idleDir ((phase1Cfg tm₁ tm₂ c₁).work i).read), - output := ((phase1Cfg tm₁ tm₂ c₁).output.write Γw.blank.toΓ).move - (idleDir (phase1Cfg tm₁ tm₂ c₁).output.read) } with hc'_def - refine ⟨c', hstep, rfl, ?_, ?_⟩ - · -- fake output cells preserved - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [phase1Cfg_fakeOut] - rw [Tape.move_cells] - simp only [Tape.write] - split - · rfl -- head = 0: write is no-op - · next hne => - -- head ≠ 0: readBackWrite writes back the same value - have hread_ne : c₁.output.read ≠ Γ.start := by - rw [Tape.read]; exact hnostart_out _ (by omega) - rw [readBackWrite_toΓ_eq hread_ne, Tape.read] - exact Function.update_eq_self _ _ - · -- output is idleTape write blank / move idle - simp only [hc'_def, phase1Cfg_output] - -/-- Rewind the fake output tape, preserving output = idleTape. - This is the same loop as `rewind_fakeOut_loop` but also tracks the output. -/ -private theorem rewind_fakeOut_preserves_output (tm₁ : TM n₁) (tm₂ : TM n₂) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindOut) → - c.output = idleTape → - (c.work fakeOutIdx).head = h → - (c.work fakeOutIdx).cells 0 = Γ.start → - (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ - (c'.work fakeOutIdx).head = 0 ∧ - (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells ∧ - c'.output = idleTape := by - intro h - induction h with - | zero => - intro c hst hout hhead _ _ - exact ⟨c, .zero, hst, hhead, rfl, hout⟩ - | succ n ih => - intro c hst hout hhead hcell0 hnostart - have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun i => ((c.work i).write - ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - with hc'_def - have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindOut) := rfl - have hout' : c'.output = idleTape := by - simp only [hc'_def]; rw [hout, idleTape_step_idle] - have hhead' : (c'.work fakeOutIdx).head = n := by - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [readBackWrite_toΓ_eq hread_ne] - simp only [Tape.write] - split - · omega - · simp [Tape.move, hhead] - have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] - have hcell0' : (c'.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells']; exact hcell0 - have hnostart' : ∀ i, i ≥ 1 → (c'.work fakeOutIdx).cells i ≠ Γ.start := by - rw [hcells']; exact hnostart - obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout''⟩ := - ih c' hst' hout' hhead' hcell0' hnostart' - exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout''⟩ - -/-- Through the rewind_fakeOut loop, input head is preserved when head ≥ 1 - and cells[≥1] ≠ start (since all steps move input by idleDir = stay). -/ -private theorem rewind_fakeOut_input_head (tm₁ : TM n₁) (tm₂ : TM n₂) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindOut) → - (c.work fakeOutIdx).head = h → - (c.work fakeOutIdx).cells 0 = Γ.start → - (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → - c.input.head ≥ 1 → - (∀ i, i ≥ 1 → c.input.cells i ≠ Γ.start) → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.input.head = c.input.head := by - intro h - induction h with - | zero => intro c _ _ _ _ _ _; exact ⟨c, .zero, rfl⟩ - | succ n ih => - intro c hst hhead hcell0 hnostart hih hino - have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun j => ((c.work j).write - ((if j.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (if j.val = n₁ then Dir3.left else idleDir (c.work j).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - have hih' : c'.input.head = c.input.head := idle_move_preserves_head _ hih hino - have hih'ge : c'.input.head ≥ 1 := by omega - have hino' : ∀ i, i ≥ 1 → c'.input.cells i ≠ Γ.start := by - intro i hi; show (c.input.move _).cells i ≠ _; rw [Tape.move_cells]; exact hino i hi - have hhead' : (c'.work fakeOutIdx).head = n := by - show (((c.work fakeOutIdx).write (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ - then readBackWrite (c.work fakeOutIdx).read else Γw.blank).toΓ).move - (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ then Dir3.left - else idleDir (c.work fakeOutIdx).read)).head = n - simp only [show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [readBackWrite_toΓ_eq hread_ne]; simp only [Tape.write] - split - · omega - · simp [Tape.move, hhead] - have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by - show (((c.work fakeOutIdx).write (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ - then readBackWrite (c.work fakeOutIdx).read else Γw.blank).toΓ).move - (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ then Dir3.left - else idleDir (c.work fakeOutIdx).read)).cells = _ - simp only [show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] - obtain ⟨c'', hreach, hhead''⟩ := ih c' rfl hhead' - (by rw [hcells']; exact hcell0) (by intro i hi; rw [hcells']; exact hnostart i hi) - hih'ge hino' - exact ⟨c'', .step hstep hreach, by rw [hhead'', hih']⟩ - -/-- `Γw.blank.toΓ = Γ.blank` -/ -private theorem Γw_blank_toΓ : (Γw.blank : Γw).toΓ = Γ.blank := rfl - -/-- After Phase 1, if tm₁ accepted (output cell 1 = `Γ.one`), the union - machine rewinds the fake output, checks the result, writes `Γ.one` to - the real output, and halts. -/ -theorem transition_accept (tm₁ : TM n₁) (tm₂ : TM n₂) - {c₁ : Cfg n₁ tm₁.Q} - (hhalt : tm₁.halted c₁) - (haccept : c₁.output.cells 1 = Γ.one) - (hcell0 : c₁.output.cells 0 = Γ.start) - (hnostart : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) : - ∃ (t_tr : ℕ) (c_final : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - (unionTM tm₁ tm₂).reachesIn t_tr (phase1Cfg tm₁ tm₂ c₁) c_final ∧ - (unionTM tm₁ tm₂).halted c_final ∧ - c_final.output.cells 1 = Γ.one ∧ - t_tr ≤ c₁.output.head + 4 := by - -- Step 1: phase1Cfg → rewindOut (1 step) - obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := - step_phase1_halted tm₁ tm₂ c₁ hhalt hnostart - -- Head bound for the fake output after step 1 - have hfo_head_bound : (c_rw.work fakeOutIdx).head ≤ c₁.output.head + 1 := by - have hne : (phase1Cfg tm₁ tm₂ c₁).state ≠ (unionTM tm₁ tm₂).qhalt := by - show Sum.inl c₁.state ≠ Sum.inr (Sum.inr tm₂.qhalt); exact fun h => nomatch h - have hstep1' := hstep1 - simp only [step, if_neg hne, Option.some.injEq] at hstep1' - subst hstep1' - simp only [phase1Cfg_fakeOut] - have hmv : ∀ (t : Tape) (d : Dir3), (t.move d).head ≤ t.head + 1 := by - intro t d; cases d <;> simp [Tape.move]; omega - have hwh : ∀ (t : Tape) (s : Γ), (t.write s).head = t.head := by - intro t s; simp [Tape.write]; split <;> rfl - calc ((c₁.output.write _).move _).head ≤ (c₁.output.write _).head + 1 := hmv _ _ - _ = c₁.output.head + 1 := by rw [hwh] - -- Fake output cells preserved - have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Γ.start := by - rw [hcells_rw]; exact hcell0 - have hnostart_rw : ∀ i, i ≥ 1 → (c_rw.work fakeOutIdx).cells i ≠ Γ.start := by - intro i hi; rw [hcells_rw]; exact hnostart i hi - -- c_rw.output = idleTape - have hout_rw_eq : c_rw.output = idleTape := by - rw [hout_rw]; exact idleTape_step_idle - -- Step 2: Rewind loop (h_rw steps), also preserving output = idleTape - set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def - obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0⟩ := - rewind_fakeOut_preserves_output tm₁ tm₂ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw - -- Step 3: rewindOut at head 0 → checkResult (1 step) - have hread_start : (c_at0.work fakeOutIdx).read = Γ.start := by - rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0 - have hstep3 := step_rewindOut_start_cfg tm₁ tm₂ hst_at0 hread_start - set c_cr : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.checkResult), - input := c_at0.input.move (idleDir c_at0.input.read), - work := fun i => ((c_at0.work i).write (Γw.blank : Γw).toΓ).move - (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), - output := (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) } - with hc_cr_def - -- c_cr fake output head = 1 (moved right from head 0) - have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by - simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] - -- c_cr fake output cells preserved (write blank at head 0 is no-op) - have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by - simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells]; simp only [Tape.write, if_pos hhead_at0] - -- c_cr fake output reads cell 1 = Γ.one - have hcr_read : (c_cr.work fakeOutIdx).read = Γ.one := by - rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw]; exact haccept - -- c_cr output = idleTape - have hout_cr : c_cr.output = idleTape := by - show (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) = idleTape - rw [hout_at0]; exact idleTape_step_idle - -- Step 4: checkResult with Γ.one → halt (1 step) - have hst_cr : c_cr.state = Sum.inr (Sum.inl Mid.checkResult) := rfl - have hstep4 := step_checkResult_one_cfg tm₁ tm₂ hst_cr hcr_read - set c_final : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inr tm₂.qhalt), - input := c_cr.input.move (idleDir c_cr.input.read), - work := fun i => ((c_cr.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_cr.work i).read), - output := (c_cr.output.write Γw.one.toΓ).move (idleDir c_cr.output.read) } - with hc_final_def - -- c_final is halted - have hhalt_final : (unionTM tm₁ tm₂).halted c_final := rfl - -- c_final output cell 1 = Γ.one - have hcells_final : c_final.output.cells 1 = Γ.one := by - show ((c_cr.output.write Γw.one.toΓ).move (idleDir c_cr.output.read)).cells 1 = Γ.one - rw [Tape.move_cells, hout_cr] - simp [Tape.write, idleTape, Γw.toΓ, Function.update, initTape] - -- Compose all steps: 1 + h_rw + 1 + 1 steps total - have htotal : (unionTM tm₁ tm₂).reachesIn (1 + (h_rw + (1 + 1))) - (phase1Cfg tm₁ tm₂ c₁) c_final := - reachesIn_trans _ (.step hstep1 .zero) - (reachesIn_trans _ hreach_rw - (.step hstep3 (.step hstep4 .zero))) - have heq : 1 + (h_rw + (1 + 1)) = 1 + h_rw + 1 + 1 := by omega - exact ⟨1 + h_rw + 1 + 1, c_final, heq ▸ htotal, hhalt_final, hcells_final, by omega⟩ - --- ════════════════════════════════════════════════════════════════════════ --- Transition phase: reject path (x ∉ L₁) → Phase 2 ready --- ════════════════════════════════════════════════════════════════════════ - -/-- Rewind the input tape from head position `h` to head position 0, - preserving output = idleTape. -/ -private theorem rewind_input_loop (tm₁ : TM n₁) (tm₂ : TM n₂) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindIn) → - c.input.head = h → - (∀ i, i ≥ 1 → c.input.cells i ≠ Γ.start) → - c.input.cells 0 = Γ.start → - c.output = idleTape → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.state = Sum.inr (Sum.inl Mid.rewindIn) ∧ - c'.input.head = 0 ∧ - c'.input.cells = c.input.cells ∧ - c'.output = idleTape := by - intro h - induction h with - | zero => - intro c hst hhead _ _ hout - exact ⟨c, .zero, hst, hhead, rfl, hout⟩ - | succ n ih => - intro c hst hhead hnostart hcell0 hout - have hread_ne : c.input.read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - have hstep := step_rewindIn_nostart_cfg tm₁ tm₂ hst hread_ne - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindIn), - input := c.input.move Dir3.left, - work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - with hc'_def - have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindIn) := rfl - have hhead' : c'.input.head = n := by - show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead] - have hcells' : c'.input.cells = c.input.cells := Tape.move_cells _ _ - have hcell0' : c'.input.cells 0 = Γ.start := by rw [hcells']; exact hcell0 - have hnostart' : ∀ i, i ≥ 1 → c'.input.cells i ≠ Γ.start := by - intro i hi; rw [hcells']; exact hnostart i hi - have hout' : c'.output = idleTape := by - show (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) = idleTape - rw [hout]; exact idleTape_step_idle - obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout''⟩ := - ih c' hst' hhead' hnostart' hcell0' hout' - exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout''⟩ - -/-- Writing blank to idleTape and moving left yields initTape []. -/ -private theorem idleTape_moveLeft : - (idleTape.write Γw.blank.toΓ).move (moveLeftDir idleTape.read) = initTape [] := by - simp [idleTape, moveLeftDir, Tape.write, Tape.move, Tape.read, initTape] - -/-- idleTape stays idleTape when written with blank and moved by idleDir (on any tape). -/ -private theorem tape_idle_step (t : Tape) (ht : t = idleTape) : - (t.write Γw.blank.toΓ).move (idleDir t.read) = idleTape := by - rw [ht]; exact idleTape_step_idle - -/-- Input cells are preserved through any reachesIn (input tape is read-only). -/ -private theorem union_input_cells_of_step (tm₁ : TM n₁) (tm₂ : TM n₂) - {c c' : Cfg (n₁ + 1 + n₂) (unionTM tm₁ tm₂).Q} - (hs : (unionTM tm₁ tm₂).step c = some c') : c'.input.cells = c.input.cells := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by intro heq; simp [step, heq] at hs - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs - exact Tape.move_cells _ _ - -private theorem union_input_cells_of_reachesIn (tm₁ : TM n₁) (tm₂ : TM n₂) - {t : ℕ} {c₀ c : Cfg (n₁ + 1 + n₂) (unionTM tm₁ tm₂).Q} - (h : (unionTM tm₁ tm₂).reachesIn t c₀ c) : c.input.cells = c₀.input.cells := by - induction h with - | zero => rfl - | step hs _ ih => rw [ih, union_input_cells_of_step tm₁ tm₂ hs] - -/-- Work tapes at index `> n₁` get write blank + move idle in any step - from `inl q`, `rewindOut`, `checkResult`, or `rewindIn` states. -/ -private theorem phase2_work_step_idle (tm₁ : TM n₁) (tm₂ : TM n₂) - {c c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hs : (unionTM tm₁ tm₂).step c = some c') - (hstate : (∃ q, c.state = Sum.inl q) ∨ - c.state = Sum.inr (Sum.inl Mid.rewindOut) ∨ - c.state = Sum.inr (Sum.inl Mid.checkResult) ∨ - c.state = Sum.inr (Sum.inl Mid.rewindIn)) - {i : Fin (n₁ + 1 + n₂)} (hi : i.val > n₁) : - c'.work i = ((c.work i).write Γw.blank.toΓ).move (idleDir (c.work i).read) := by - have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by - rcases hstate with ⟨q, hq⟩ | hq | hq | hq <;> rw [hq] <;> exact fun h => nomatch h - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs - have hine : (i : ℕ) ≠ n₁ := by omega - rcases hstate with ⟨q, hq⟩ | hq | hq | hq - · rw [hq]; dsimp only [unionTM]; split - · -- qhalt: write (if i = n₁ then ... else blank), dir idleDir - congr 1; simp only [hine, ↓reduceIte] - · -- q ≠ qhalt: write/dir have dif/if structure - congr 1 - · congr 1; show (if h : (i : ℕ) < n₁ then _ else if (i : ℕ) = n₁ then _ else Γw.blank) = Γw.blank - rw [dif_neg (show ¬((i : ℕ) < n₁) from by omega), if_neg hine] - · show (if h : (i : ℕ) < n₁ then _ else if (i : ℕ) = n₁ then _ else idleDir (c.work i).read) = _ - rw [dif_neg (show ¬((i : ℕ) < n₁) from by omega), if_neg hine] - · rw [hq]; dsimp only [unionTM]; split - · congr 1; simp only [hine, ↓reduceIte] - · congr 1 - · congr 1; simp only [hine, ↓reduceIte] - · simp only [hine, ↓reduceIte] - · rw [hq]; dsimp only [unionTM]; split <;> rfl - · rw [hq]; dsimp only [unionTM]; split <;> rfl - -/-- Rewind fake output loop also preserves phase 2 work tapes. -/ -private theorem rewind_fakeOut_work_idle (tm₁ : TM n₁) (tm₂ : TM n₂) - {i : Fin (n₁ + 1 + n₂)} (hi : i.val > n₁) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindOut) → - (c.work fakeOutIdx).head = h → - (c.work fakeOutIdx).cells 0 = Γ.start → - (∀ j, j ≥ 1 → (c.work fakeOutIdx).cells j ≠ Γ.start) → - c.work i = idleTape → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.work i = idleTape := by - intro h - induction h with - | zero => - intro c _ _ _ _ hidle; exact ⟨c, .zero, hidle⟩ - | succ n ih => - intro c hst hhead hcell0 hnostart hidle - have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindOut), - input := c.input.move (idleDir c.input.read), - work := fun j => ((c.work j).write - ((if j.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move - (if j.val = n₁ then Dir3.left else idleDir (c.work j).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - with hc'_def - have hidle' : c'.work i = idleTape := by - simp only [hc'_def, show (i : ℕ) ≠ n₁ from by omega, ↓reduceIte] - rw [hidle]; exact idleTape_step_idle - have hhead' : (c'.work fakeOutIdx).head = n := by - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [readBackWrite_toΓ_eq hread_ne]; simp only [Tape.write] - split - · omega - · simp [Tape.move, hhead] - have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by - simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] - obtain ⟨c'', hreach, hidle''⟩ := ih c' rfl hhead' - (by rw [hcells']; exact hcell0) (by intro j hj; rw [hcells']; exact hnostart j hj) hidle' - exact ⟨c'', .step hstep hreach, hidle''⟩ - -/-- Rewind input loop also preserves phase 2 work tapes. -/ -private theorem rewind_input_work_idle (tm₁ : TM n₁) (tm₂ : TM n₂) - {i : Fin (n₁ + 1 + n₂)} (_hi : i.val > n₁) : - ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - c.state = Sum.inr (Sum.inl Mid.rewindIn) → - c.input.head = h → - (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → - c.input.cells 0 = Γ.start → - c.work i = idleTape → - ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ - c'.work i = idleTape := by - intro h - induction h with - | zero => - intro c _ _ _ _ hidle; exact ⟨c, .zero, hidle⟩ - | succ n ih => - intro c hst hhead hnostart hcell0 hidle - have hread_ne : c.input.read ≠ Γ.start := by - rw [Tape.read]; exact hnostart _ (by omega) - have hstep := step_rewindIn_nostart_cfg tm₁ tm₂ hst hread_ne - set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindIn), - input := c.input.move Dir3.left, - work := fun j => ((c.work j).write (Γw.blank : Γw).toΓ).move (idleDir (c.work j).read), - output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } - with hc'_def - have hidle' : c'.work i = idleTape := by - show ((c.work i).write _).move _ = _; rw [hidle]; exact idleTape_step_idle - obtain ⟨c'', hreach, hidle''⟩ := ih c' rfl - (by show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead]) - (by intro j hj; show (c.input.move Dir3.left).cells j ≠ _; rw [Tape.move_cells]; exact hnostart j hj) - (by show (c.input.move Dir3.left).cells 0 = _; rw [Tape.move_cells]; exact hcell0) - hidle' - exact ⟨c'', .step hstep hreach, hidle''⟩ - -/-- After Phase 1, if tm₁ rejected, the union machine transitions to a - config ready for Phase 2: state is `Sum.inr (Sum.inr tm₂.qstart)`, - input/output/active work tapes match `tm₂.initCfg x`. -/ -theorem transition_reject (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) - {c₁ : Cfg n₁ tm₁.Q} - (hhalt : tm₁.halted c₁) - (hreject : c₁.output.cells 1 = Γ.zero) - (hcell0_out : c₁.output.cells 0 = Γ.start) - (hnostart_out : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) - (hinput_cells : c₁.input.cells = (initTape (x.map Γ.ofBool)).cells) : - ∃ (t_tr : ℕ) (c_mid : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), - (unionTM tm₁ tm₂).reachesIn t_tr (phase1Cfg tm₁ tm₂ c₁) c_mid ∧ - c_mid.state = Sum.inr (Sum.inr tm₂.qstart) ∧ - c_mid.input = initTape (x.map Γ.ofBool) ∧ - (∀ j : Fin n₂, c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape []) ∧ - c_mid.output = initTape [] ∧ - t_tr ≤ c₁.output.head + c₁.input.head + 7 := by - -- Step 1: phase1Cfg halted → rewindOut (1 step) - obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := - step_phase1_halted tm₁ tm₂ c₁ hhalt hnostart_out - -- Head bounds - have hne_p1 : (phase1Cfg tm₁ tm₂ c₁).state ≠ (unionTM tm₁ tm₂).qhalt := by - show Sum.inl c₁.state ≠ Sum.inr (Sum.inr tm₂.qhalt); exact fun h => nomatch h - have hfo_head_bound : (c_rw.work fakeOutIdx).head ≤ c₁.output.head + 1 := by - have hstep1' := hstep1 - simp only [step, if_neg hne_p1, Option.some.injEq] at hstep1'; subst hstep1' - simp only [phase1Cfg_fakeOut] - have hmv : ∀ (t : Tape) (d : Dir3), (t.move d).head ≤ t.head + 1 := by - intro t d; cases d <;> simp [Tape.move]; omega - have hwh : ∀ (t : Tape) (s : Γ), (t.write s).head = t.head := by - intro t s; simp [Tape.write]; split <;> rfl - calc ((c₁.output.write _).move _).head ≤ (c₁.output.write _).head + 1 := hmv _ _ - _ = c₁.output.head + 1 := by rw [hwh] - -- c_rw properties - have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells_rw]; exact hcell0_out - have hnostart_rw : ∀ i, i ≥ 1 → (c_rw.work fakeOutIdx).cells i ≠ Γ.start := by - intro i hi; rw [hcells_rw]; exact hnostart_out i hi - have hout_rw_eq : c_rw.output = idleTape := by rw [hout_rw]; exact idleTape_step_idle - -- Step 2: Rewind fake output (h_rw steps) - set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def - obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0⟩ := - rewind_fakeOut_preserves_output tm₁ tm₂ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw - -- Step 3: rewindOut at head 0 → checkResult (1 step) - have hread_start : (c_at0.work fakeOutIdx).read = Γ.start := by - rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0_out - have hstep3 := step_rewindOut_start_cfg tm₁ tm₂ hst_at0 hread_start - set c_cr : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.checkResult), - input := c_at0.input.move (idleDir c_at0.input.read), - work := fun i => ((c_at0.work i).write (Γw.blank : Γw).toΓ).move - (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), - output := (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) } - with hc_cr_def - have hout_cr : c_cr.output = idleTape := by - show (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) = idleTape - rw [hout_at0]; exact idleTape_step_idle - -- c_cr fake output reads Γ.zero (not Γ.one) - have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by - simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] - have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by - simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] - rw [Tape.move_cells]; simp only [Tape.write, if_pos hhead_at0] - have hcr_read_ne_one : (c_cr.work fakeOutIdx).read ≠ Γ.one := by - rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw, hreject]; decide - -- Step 4: checkResult ≠ Γ.one → rewindIn (1 step) - have hstep4 := step_checkResult_notone_cfg tm₁ tm₂ rfl hcr_read_ne_one - set c_ri : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.rewindIn), - input := c_cr.input.move (idleDir c_cr.input.read), - work := fun i => ((c_cr.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_cr.work i).read), - output := (c_cr.output.write Γw.blank.toΓ).move (idleDir c_cr.output.read) } - with hc_ri_def - have hout_ri : c_ri.output = idleTape := by - show (c_cr.output.write Γw.blank.toΓ).move (idleDir c_cr.output.read) = idleTape - rw [hout_cr]; exact idleTape_step_idle - -- Input cells chain: input is read-only, so cells are preserved through all steps. - -- phase1Cfg → c_rw → (rewind) → c_at0 → c_cr → c_ri all preserve input.cells - have hin_cells_chain : c_ri.input.cells = (initTape (x.map Γ.ofBool)).cells := by - -- c_ri.input.cells = c_cr.input.cells (move) - show (c_cr.input.move _).cells = _; rw [Tape.move_cells] - -- c_cr.input.cells = c_at0.input.cells (move) - show (c_at0.input.move _).cells = _; rw [Tape.move_cells] - -- c_at0.input.cells = c_rw.input.cells (reachesIn) - rw [union_input_cells_of_reachesIn tm₁ tm₂ hreach_rw] - -- c_rw.input.cells = phase1Cfg.input.cells (step) - have hstep1' := hstep1 - simp only [step, if_neg hne_p1, Option.some.injEq] at hstep1'; subst hstep1' - rw [Tape.move_cells]; exact hinput_cells - -- Input cells ≥ 1 ≠ Γ.start - have hin_nostart_ri : ∀ i, i ≥ 1 → c_ri.input.cells i ≠ Γ.start := by - intro i hi; rw [hin_cells_chain] - simp only [initTape, show i ≠ 0 from by omega, ↓reduceIte] - intro heq - have : (x.map Γ.ofBool)[i - 1]?.getD Γ.blank = Γ.start := heq - cases hget : (x.map Γ.ofBool)[i - 1]? with - | none => simp [hget, Option.getD] at this - | some v => - simp [hget, Option.getD] at this; subst this - have hmem := List.mem_of_getElem? hget - simp [List.mem_map] at hmem - rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Γ.ofBool] at hb - -- Input cell 0 = Γ.start - have hin_cell0_ri : c_ri.input.cells 0 = Γ.start := by - rw [hin_cells_chain]; simp [initTape] - -- Input head bound for c_ri - -- c_ri.input goes through: phase1Cfg.input → move → (h_rw moves) → move → move → move - -- Each move adds at most 1, so total head ≤ initial + (1 + h_rw + 1 + 1 + 1) - -- But we need a tighter bound. Let's compute it through the reachesIn chain. - -- Actually, we just need c_ri.input.head for the rewind loop bound. - -- Let's compose: steps 1..4 give reachesIn (1 + h_rw + 1 + 1) from phase1Cfg to c_ri - have hreach_to_ri : (unionTM tm₁ tm₂).reachesIn (1 + (h_rw + (1 + 1))) - (phase1Cfg tm₁ tm₂ c₁) c_ri := - reachesIn_trans _ (.step hstep1 .zero) - (reachesIn_trans _ hreach_rw (.step hstep3 (.step hstep4 .zero))) - -- Input head bound: through all steps, head changes by at most 1 per step - -- total steps so far = 1 + h_rw + 2, so head ≤ initial + (1 + h_rw + 2) - -- phase1Cfg.input.head = c₁.input.head - -- But we need a precise bound. Let's just track c_ri.input.head. - -- Actually for rewind_input_loop we need h_ri = c_ri.input.head and the - -- total t_tr ≤ c₁.output.head + c₁.input.head + 7 - -- We don't need a tight head bound; we just use the loop count. - -- Step 5: Rewind input (h_ri steps) - set h_ri := c_ri.input.head with hh_ri_def - obtain ⟨c_ri0, hreach_ri, hst_ri0, hhead_ri0, hcells_ri0, hout_ri0⟩ := - rewind_input_loop tm₁ tm₂ h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri hout_ri - -- Step 6: rewindIn at head 0 → setup2 (1 step) - have hread_start_ri : c_ri0.input.read = Γ.start := by - rw [Tape.read, hhead_ri0, hcells_ri0, hin_cells_chain]; simp [initTape] - have hstep6 := step_rewindIn_start_cfg tm₁ tm₂ hst_ri0 hread_start_ri - set c_s2 : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inl Mid.setup2), - input := c_ri0.input.move Dir3.right, - work := fun i => ((c_ri0.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_ri0.work i).read), - output := (c_ri0.output.write Γw.blank.toΓ).move (idleDir c_ri0.output.read) } - with hc_s2_def - -- Step 7: setup2 → Phase 2 start (1 step) - have hstep7 := step_setup2_cfg tm₁ tm₂ (show c_s2.state = Sum.inr (Sum.inl Mid.setup2) from rfl) - set c_mid : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := - { state := Sum.inr (Sum.inr tm₂.qstart), - input := c_s2.input.move (moveLeftDir c_s2.input.read), - work := fun i => ((c_s2.work i).write (Γw.blank : Γw).toΓ).move - (if i.val ≤ n₁ then idleDir (c_s2.work i).read else moveLeftDir (c_s2.work i).read), - output := (c_s2.output.write Γw.blank.toΓ).move (moveLeftDir c_s2.output.read) } - with hc_mid_def - -- Now prove all properties of c_mid. - -- c_mid.state - have hst_mid : c_mid.state = Sum.inr (Sum.inr tm₂.qstart) := rfl - -- c_mid.input = initTape (x.map Γ.ofBool) - -- c_mid.input = c_s2.input.move (moveLeftDir c_s2.input.read) - -- c_s2.input = c_ri0.input.move Dir3.right - -- c_ri0.input.head = 0, so moving right gives head = 1 - -- c_s2.input.head = 1, c_s2.input.cells = c_ri0.input.cells (move preserves) - -- c_s2.input.read = cells[1] which is from initTape, not start - -- moveLeftDir(non-start) = left, so head goes from 1 to 0 - -- c_mid.input = { head := 0, cells := initTape cells } = initTape (x.map Γ.ofBool) - have hcells_ri0_eq : c_ri0.input.cells = (initTape (x.map Γ.ofBool)).cells := by - rw [hcells_ri0, hin_cells_chain] - have hin_mid : c_mid.input = initTape (x.map Γ.ofBool) := by - -- c_mid.input.cells = initTape cells - have h2 : c_mid.input.cells = (initTape (x.map Γ.ofBool)).cells := by - show (c_s2.input.move _).cells = _ - rw [Tape.move_cells]; show (c_ri0.input.move Dir3.right).cells = _ - rw [Tape.move_cells]; exact hcells_ri0_eq - -- c_s2.input = c_ri0.input.move Dir3.right, head = 1 - have hs2_head : c_s2.input.head = 1 := by - show (c_ri0.input.move Dir3.right).head = 1 - simp [Tape.move, hhead_ri0] - have hs2_cells : c_s2.input.cells = c_ri0.input.cells := Tape.move_cells _ _ - -- c_s2.input.read ≠ Γ.start (cells[1] is from initTape, not start) - have hs2_read_ne : c_s2.input.read ≠ Γ.start := by - rw [Tape.read, hs2_head, hs2_cells, hcells_ri0] - exact hin_nostart_ri 1 (by omega) - -- c_mid.input.head = 0 (moveLeftDir of non-start = left, from head 1 → 0) - have h1 : c_mid.input.head = 0 := by - show (c_s2.input.move (moveLeftDir c_s2.input.read)).head = 0 - rw [moveLeftDir, if_neg hs2_read_ne]; simp [Tape.move, hs2_head] - -- Combine - have hcfg : ∀ (a b : Tape), a.head = b.head → a.cells = b.cells → a = b := by - intros a b hh hc; cases a; cases b; simp only [Tape.mk.injEq] at *; exact ⟨hh, hc⟩ - exact hcfg _ _ (by rw [h1]; rfl) h2 - -- c_mid.output = initTape [] - -- c_mid.output = (c_s2.output.write blank).move (moveLeftDir c_s2.output.read) - -- c_s2.output = (c_ri0.output.write blank).move (idleDir c_ri0.output.read) - -- c_ri0.output = idleTape - -- c_s2.output = idleTape (write blank + move idle on idleTape) - -- c_mid.output = (idleTape.write blank).move (moveLeftDir idleTape.read) = initTape [] - have hout_s2 : c_s2.output = idleTape := by - show (c_ri0.output.write Γw.blank.toΓ).move (idleDir c_ri0.output.read) = idleTape - rw [hout_ri0]; exact idleTape_step_idle - have hout_mid : c_mid.output = initTape [] := by - show (c_s2.output.write Γw.blank.toΓ).move (moveLeftDir c_s2.output.read) = initTape [] - rw [hout_s2]; exact idleTape_moveLeft - -- Phase 2 work tapes = initTape [] - -- Strategy: show work tapes at > n₁ indices stay idleTape through each phase, - -- then setup2 sends idleTape to initTape []. - -- Step 1: c_rw.work at > n₁ = idleTape (from phase1_halted step) - have hwork_rw_idle : ∀ (j : Fin n₂), - c_rw.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - have hstateq : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by - show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] - have hstep' := phase2_work_step_idle tm₁ tm₂ hstep1 - (Or.inl ⟨tm₁.qhalt, hstateq⟩) (i := ⟨n₁ + 1 + j.val, by omega⟩) (by omega : n₁ + 1 + j.val > n₁) - rw [hstep'] - have hp1 : (phase1Cfg tm₁ tm₂ c₁).work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - simp [phase1Cfg, show ¬(n₁ + 1 + j.val < n₁) from by omega, - show ¬(n₁ + 1 + j.val = n₁) from by omega] - rw [hp1]; exact idleTape_step_idle - -- Step 2: Through rewind_fakeOut (hreach_rw), work tapes > n₁ stay idleTape - -- Use reachesIn determinism: rewind_fakeOut_work_idle produces the same endpoint as hreach_rw - have hwork_at0_idle : ∀ (j : Fin n₂), - c_at0.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - obtain ⟨c_at0', hreach', hidle'⟩ := rewind_fakeOut_work_idle tm₁ tm₂ - (show n₁ + 1 + j.val > n₁ from by omega) - h_rw c_rw hst_rw rfl hcell0_rw hnostart_rw (hwork_rw_idle j) - have hdet := reachesIn_det hreach_rw hreach' - rw [hdet]; exact hidle' - -- Step 3 (rewindOut→checkResult): c_cr.work at > n₁ = idleTape - have hwork_cr_idle : ∀ (j : Fin n₂), - c_cr.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - show ((c_at0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move - (if (n₁ + 1 + j.val) = n₁ then _ else _) = _ - rw [if_neg (show n₁ + 1 + j.val ≠ n₁ from by omega), hwork_at0_idle j] - exact idleTape_step_idle - -- Step 4 (checkResult→rewindIn): c_ri.work at > n₁ = idleTape - have hwork_ri_idle : ∀ (j : Fin n₂), - c_ri.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - show ((c_cr.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ - rw [hwork_cr_idle j]; exact idleTape_step_idle - -- Step 5: Through rewind_input (hreach_ri), work tapes > n₁ stay idleTape - have hwork_ri0_idle : ∀ (j : Fin n₂), - c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - obtain ⟨c_ri0', hreach', hidle'⟩ := rewind_input_work_idle tm₁ tm₂ - (show n₁ + 1 + j.val > n₁ from by omega) - h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri (hwork_ri_idle j) - have hdet := reachesIn_det hreach_ri hreach' - rw [hdet]; exact hidle' - -- Step 6 (rewindIn→setup2): c_s2.work at > n₁ = idleTape - have hwork_s2_idle : ∀ (j : Fin n₂), - c_s2.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by - intro j - show ((c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ - rw [hwork_ri0_idle j]; exact idleTape_step_idle - -- Step 7 (setup2→phase2_start): c_mid.work at > n₁ = initTape [] - have hwork_mid : ∀ (j : Fin n₂), - c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape [] := by - intro j - show ((c_s2.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move - (if (n₁ + 1 + j.val) ≤ n₁ then _ else _) = _ - rw [if_neg (show ¬(n₁ + 1 + j.val ≤ n₁) from by omega), hwork_s2_idle j] - exact idleTape_moveLeft - -- Compose all reachesIn steps - have hreach_total : (unionTM tm₁ tm₂).reachesIn - (1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1))) - (phase1Cfg tm₁ tm₂ c₁) c_mid := - reachesIn_trans _ hreach_to_ri - (reachesIn_trans _ hreach_ri (.step hstep6 (.step hstep7 .zero))) - -- Time bound - -- h_rw ≤ c₁.output.head + 1 (hfo_head_bound) - -- h_ri = c_ri.input.head ≤ c₁.input.head + 1 (input moves by idleDir, which is stay for head ≥ 1) - -- Need: 1 + (h_rw + 2) + (h_ri + 2) = h_rw + h_ri + 5 ≤ c₁.output.head + c₁.input.head + 7 - -- Suffices: h_rw + h_ri ≤ c₁.output.head + c₁.input.head + 2, which holds. - -- Prove h_ri ≤ c₁.input.head + 1: - have hri_bound : h_ri ≤ c₁.input.head + 1 := by - -- c_rw.input.cells = c₁.input.cells (input cells preserved through step) - have hcrw_cells : c_rw.input.cells = c₁.input.cells := by - have := union_input_cells_of_step tm₁ tm₂ hstep1 - rw [this]; rfl - -- c_rw.input cells[≥1] ≠ Γ.start - have hcrw_ino : ∀ i, i ≥ 1 → c_rw.input.cells i ≠ Γ.start := by - intro i hi; rw [hcrw_cells, hinput_cells] - simp only [initTape, show i ≠ 0 from by omega, ↓reduceIte] - intro heq - cases hget : (x.map Γ.ofBool)[i - 1]? with - | none => simp [hget, Option.getD] at heq - | some v => - simp [hget, Option.getD] at heq; subst heq - have hmem := List.mem_of_getElem? hget - simp [List.mem_map] at hmem; rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Γ.ofBool] at hb - -- c_rw.input.head ≤ c₁.input.head + 1 - -- From step_inl_qhalt_cfg, the input direction is idleDir(input.read) - -- Use step_inl_qhalt_cfg to get the exact form of c_rw.input - have hstateq : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by - show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] - have hstep_eq := step_inl_qhalt_cfg tm₁ tm₂ hstateq - -- c_rw.input = c₁.input.move (idleDir c₁.input.read) since phase1Cfg.input = c₁.input - have hcrw_input_eq : c_rw.input = c₁.input.move (idleDir c₁.input.read) := by - have heq : some c_rw = some _ := hstep1.symm.trans hstep_eq - simp only [Option.some.injEq] at heq - rw [heq]; rfl - -- c_rw.input.head ≤ c₁.input.head + 1 - have hcrw_head : c_rw.input.head ≤ c₁.input.head + 1 := by - rw [hcrw_input_eq]; cases (idleDir c₁.input.read) <;> simp [Tape.move]; omega - -- c_rw.input.head ≥ 1 - have hcrw_hge : c_rw.input.head ≥ 1 := by - rw [hcrw_input_eq] - by_cases hh : c₁.input.head = 0 - · have hread0 : c₁.input.read = Γ.start := by - rw [Tape.read, hh, hinput_cells]; simp [initTape] - rw [hread0, idleDir, if_pos rfl]; simp [Tape.move, hh] - · have hge : c₁.input.head ≥ 1 := by omega - have hc1_ino : ∀ i, i ≥ 1 → c₁.input.cells i ≠ Γ.start := by - intro i hi; rw [← hcrw_cells]; exact hcrw_ino i hi - rw [idleDir_stay_of_ge_one _ hge hc1_ino]; simp [Tape.move]; omega - -- Through rewind_fakeOut loop: input head preserved (all steps move input by idleDir = stay) - obtain ⟨c_at0', hreach_at0', hat0_head'⟩ := rewind_fakeOut_input_head tm₁ tm₂ - h_rw c_rw hst_rw rfl hcell0_rw hnostart_rw hcrw_hge hcrw_ino - have hat0_det := reachesIn_det hreach_rw hreach_at0' - -- c_at0.input.head = c_rw.input.head - have hat0_head : c_at0.input.head = c_rw.input.head := by - rw [hat0_det]; exact hat0_head' - -- c_at0.input.cells[≥1] ≠ start (preserved through reachesIn) - have hat0_ino : ∀ i, i ≥ 1 → c_at0.input.cells i ≠ Γ.start := by - intro i hi; rw [union_input_cells_of_reachesIn tm₁ tm₂ hreach_rw]; exact hcrw_ino i hi - -- c_cr.input.head = c_at0.input.head (idleDir step from head ≥ 1) - have hcr_head : c_cr.input.head = c_at0.input.head := by - show (c_at0.input.move (idleDir c_at0.input.read)).head = _ - exact idle_move_preserves_head _ (by omega) hat0_ino - -- c_ri.input.head = c_cr.input.head (idleDir step from head ≥ 1) - have hcr_ino : ∀ i, i ≥ 1 → c_cr.input.cells i ≠ Γ.start := by - intro i hi; show (c_at0.input.move _).cells i ≠ _; rw [Tape.move_cells]; exact hat0_ino i hi - have hri_head : c_ri.input.head = c_cr.input.head := by - show (c_cr.input.move (idleDir c_cr.input.read)).head = _ - exact idle_move_preserves_head _ (by omega) hcr_ino - -- Chain: h_ri = c_ri.input.head = c_rw.input.head ≤ c₁.input.head + 1 - omega - have htime : 1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)) ≤ c₁.output.head + c₁.input.head + 7 := by - omega - refine ⟨1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)), c_mid, ?_, hst_mid, hin_mid, hwork_mid, hout_mid, htime⟩ - exact hreach_total - --- ════════════════════════════════════════════════════════════════════════ --- Phase 2: one-step correspondence --- ════════════════════════════════════════════════════════════════════════ - -/-- Phase 2 compatibility: a union machine config agrees with a tm₂ config - on the active components (state, input, Phase 2 work tapes, output). -/ -structure Phase2Compat (tm₁ : TM n₁) (tm₂ : TM n₂) - (c_u : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)) - (c₂ : Cfg n₂ tm₂.Q) : Prop where - state_eq : c_u.state = Sum.inr (Sum.inr c₂.state) - input_eq : c_u.input = c₂.input - work_eq : ∀ j : Fin n₂, c_u.work ⟨n₁ + 1 + j.val, by omega⟩ = c₂.work j - output_eq : c_u.output = c₂.output - -/-- One step of the union machine on a Phase 2 compatible config preserves - compatibility. -/ -private theorem phase2_step_corr (tm₁ : TM n₁) (tm₂ : TM n₂) - {c₂ c₂' : Cfg n₂ tm₂.Q} (hstep : tm₂.step c₂ = some c₂') - {c_u : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hcompat : Phase2Compat tm₁ tm₂ c_u c₂) : - ∃ c_u', (unionTM tm₁ tm₂).step c_u = some c_u' ∧ - Phase2Compat tm₁ tm₂ c_u' c₂' := by - have hne : c₂.state ≠ tm₂.qhalt := by intro heq; simp [step, heq] at hstep - -- Extract c₂' from tm₂.step - simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep; subst hstep - -- c_u is not halted in the union machine - have hne_u : c_u.state ≠ (unionTM tm₁ tm₂).qhalt := by - rw [hcompat.state_eq, unionTM_qhalt]; exact fun h => hne (Sum.inr.inj (Sum.inr.inj h)) - -- Unfold the union step and pick the result as witness - simp only [step, hne_u, ↓reduceIte] - refine ⟨_, rfl, ?_⟩ - -- Rewrite reads using Phase2Compat - have hwork_reads : phase2WorkReads (fun i => (c_u.work i).read) = - fun j => (c₂.work j).read := by - ext ⟨j, hj⟩; simp only [phase2WorkReads]; exact congrArg Tape.read (hcompat.work_eq ⟨j, hj⟩) - -- Construct Phase2Compat - constructor - · -- state_eq - dsimp only [] - rw [hcompat.state_eq] - simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] - · -- input_eq - dsimp only [] - rw [hcompat.state_eq] - simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] - · -- work_eq - intro ⟨j, hj⟩ - dsimp only [] - rw [hcompat.state_eq] - simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] - have hgt : ¬((n₁ + 1 + j) ≤ n₁) := by omega - rw [dif_neg hgt] - have hfin : ∀ (p : n₁ + 1 + j - (n₁ + 1) < n₂), - (⟨n₁ + 1 + j - (n₁ + 1), p⟩ : Fin n₂) = ⟨j, hj⟩ := by - intro p; apply Fin.ext; show n₁ + 1 + j - (n₁ + 1) = j; omega - simp only [hfin, hcompat.work_eq ⟨j, hj⟩, dif_neg hgt] - · -- output_eq - dsimp only [] - rw [hcompat.state_eq] - simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] - --- ════════════════════════════════════════════════════════════════════════ --- Phase 2 simulation --- ════════════════════════════════════════════════════════════════════════ - -/-- Multi-step Phase 2 simulation via step correspondence. -/ -private theorem phase2_steps (tm₁ : TM n₁) (tm₂ : TM n₂) - {t : ℕ} {c₂_start c₂_end : Cfg n₂ tm₂.Q} - (hreach : tm₂.reachesIn t c₂_start c₂_end) - {c_start : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hcompat : Phase2Compat tm₁ tm₂ c_start c₂_start) : - ∃ c_end, (unionTM tm₁ tm₂).reachesIn t c_start c_end ∧ - Phase2Compat tm₁ tm₂ c_end c₂_end := by - induction hreach generalizing c_start with - | zero => exact ⟨c_start, .zero, hcompat⟩ - | step hstep _ ih => - obtain ⟨c_mid, hstep_u, hcompat_mid⟩ := phase2_step_corr tm₁ tm₂ hstep hcompat - obtain ⟨c_end, hreach_u, hcompat_end⟩ := ih hcompat_mid - exact ⟨c_end, .step hstep_u hreach_u, hcompat_end⟩ - -/-- **Phase 2 simulation**: if `tm₂` reaches `c₂` from `initCfg x` in - `t₂` steps, and the starting union config is compatible with `initCfg x`, - then the union machine reaches a config compatible with `c₂` in `t₂` steps. -/ -theorem phase2_simulation (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) - {t₂ : ℕ} {c₂ : Cfg n₂ tm₂.Q} - (hreach : tm₂.reachesIn t₂ (tm₂.initCfg x) c₂) - {c_start : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} - (hss : c_start.state = Sum.inr (Sum.inr tm₂.qstart)) - (hsi : c_start.input = initTape (x.map Γ.ofBool)) - (hsw : ∀ j : Fin n₂, c_start.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape []) - (hso : c_start.output = initTape []) : - ∃ c_end, (unionTM tm₁ tm₂).reachesIn t₂ c_start c_end ∧ - c_end.state = Sum.inr (Sum.inr c₂.state) ∧ - c_end.output = c₂.output := by - have hcompat : Phase2Compat tm₁ tm₂ c_start (tm₂.initCfg x) := - ⟨by rw [hss], hsi, hsw, hso⟩ - obtain ⟨c_end, hreach_u, hcompat_end⟩ := phase2_steps tm₁ tm₂ hreach hcompat - exact ⟨c_end, hreach_u, hcompat_end.state_eq, hcompat_end.output_eq⟩ - --- ════════════════════════════════════════════════════════════════════════ --- Head bound lemma --- ════════════════════════════════════════════════════════════════════════ - -private theorem Tape.move_head_le (t : Tape) (d : Dir3) : - (t.move d).head ≤ t.head + 1 := by - cases d <;> simp [Tape.move]; omega - -private theorem Tape.write_head_eq (t : Tape) (s : Γ) : - (t.write s).head = t.head := by - simp [Tape.write]; split <;> rfl - -/-- After one step, each tape head increases by at most 1. -/ -private theorem step_head_bound (tm : TM n₁) (c c' : Cfg n₁ tm.Q) - (hs : tm.step c = some c') : - c'.input.head ≤ c.input.head + 1 ∧ - c'.output.head ≤ c.output.head + 1 ∧ - ∀ i, (c'.work i).head ≤ (c.work i).head + 1 := by - unfold TM.step at hs - split at hs - · simp at hs - · simp only [Option.some.injEq] at hs - subst hs - dsimp only [] - set δr := tm.δ c.state c.input.read (fun i => (c.work i).read) c.output.read - refine ⟨Tape.move_head_le _ δr.2.2.2.1, ?_, fun i => ?_⟩ - · have hm := Tape.move_head_le (c.output.write δr.2.2.1.toΓ) δr.2.2.2.2.2 - simp only [Tape.write_head_eq] at hm - exact hm - · have hm := Tape.move_head_le ((c.work i).write (δr.2.1 i).toΓ) (δr.2.2.2.2.1 i) - simp only [Tape.write_head_eq] at hm - exact hm - -/-- A tape head moves at most 1 cell per step. After `t` steps starting - from `initCfg`, the head is at position ≤ `t`. -/ -theorem head_bound_of_reachesIn (tm : TM n₁) - {t : ℕ} {c : Cfg n₁ tm.Q} - (hreach : tm.reachesIn t (tm.initCfg x) c) : - c.input.head ≤ t ∧ c.output.head ≤ t ∧ ∀ i, (c.work i).head ≤ t := by - suffices gen : ∀ (t : ℕ) (c₀ c : Cfg n₁ tm.Q), tm.reachesIn t c₀ c → - c.input.head ≤ c₀.input.head + t ∧ - c.output.head ≤ c₀.output.head + t ∧ - ∀ i, (c.work i).head ≤ (c₀.work i).head + t by - have h := gen t (tm.initCfg x) c hreach - simp [initTape] at h - exact h - intro t c₀ c hreach - induction hreach with - | zero => simp - | step hstep _ ih => - obtain ⟨ih_in, ih_out, ih_work⟩ := ih - obtain ⟨hs_in, hs_out, hs_work⟩ := step_head_bound tm _ _ hstep - exact ⟨by omega, by omega, fun i => by have := hs_work i; have := ih_work i; omega⟩ - -end TM +import Complexitylib.Models.TuringMachine.Combinators.Internal.Union +import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean new file mode 100644 index 0000000..b04cd5b --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean @@ -0,0 +1,231 @@ +import Complexitylib.Models.TuringMachine.Combinators + +/-! +# Generic proof tools for TM combinators + +This file provides reusable proof infrastructure for TM combinator proofs, +eliminating duplication across `SeqInternal`, `IfInternal`, `LoopInternal`, +and `ComplementInternal`. + +## Main results + +- `simulation_reachesIn` — generic simulation lifting: if a state embedding + commutes with `step`, then `reachesIn` lifts through the embedding +- `generic_rewind_loop` — generic output-tape rewind: any TM where stepping + from a "rewind state" moves the output head left (preserving cells), and + at cell 0 moves right to cell 1 entering a "target state" +- `generic_rewind_loop_full` — same as above, also tracking input/work tapes + +## Shared tape stability lemmas + +These lemmas were previously duplicated across multiple Internal files. +-/ + +variable {n : ℕ} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Shared tape lemmas (deduplicated from Internal files) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Moving a tape preserves its cells. -/ +theorem tape_move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +/-- `readBackWrite` recovers the original symbol for non-start symbols. -/ +theorem readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +/-- Writing to a tape preserves the head position. -/ +theorem tape_write_head (t : Tape) (s : Γ) : (t.write s).head = t.head := by + simp only [Tape.write]; split <;> rfl + +/-- A tape with head ≥ 1 and cells ≥ 1 ≠ start is stable under + `writeAndMove(readBackWrite(read).toΓ, idleDir(read))`. -/ +theorem tape_writeAndMove_stable (t : Tape) + (hhead : t.head ≥ 1) (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + have hne : t.read ≠ Γ.start := by simp only [Tape.read]; exact hns t.head hhead + rw [readBackWrite_toΓ_eq hne] + show (t.write t.read).move (idleDir t.read) = t + simp only [idleDir, hne, ↓reduceIte] + show (t.write (t.cells t.head)).move .stay = t + simp only [Tape.write, show ¬(t.head = 0) by omega, ↓reduceIte, + Function.update_eq_self, Tape.move] + +/-- A tape with head ≥ 1 and cells ≥ 1 ≠ start is stable under `move(idleDir(read))`. -/ +theorem tape_move_idleDir_stable (t : Tape) + (hhead : t.head ≥ 1) (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.move (idleDir t.read) = t := by + have hne : t.read ≠ Γ.start := by simp only [Tape.read]; exact hns t.head hhead + simp only [idleDir, hne, ↓reduceIte, Tape.move] + +/-- `writeAndMove` head bound: head increases by at most 1. -/ +theorem tape_head_writeAndMove_le (t : Tape) (s : Γ) (d : Dir3) : + (t.writeAndMove s d).head ≤ t.head + 1 := by + cases d <;> simp only [Tape.writeAndMove, Tape.move, tape_write_head] <;> omega + +/-- Helper: readBackWrite preserves tape cells when head = 0 or read ≠ start. -/ +theorem tape_readBackWrite_preserves (t : Tape) (d : Dir3) + (h : t.head = 0 ∨ t.read ≠ Γ.start) : + (t.writeAndMove (readBackWrite t.read).toΓ d).cells = t.cells := by + simp only [Tape.writeAndMove, tape_move_cells] + rcases h with hh0 | hne + · simp only [Tape.write, hh0, ↓reduceIte] + · rw [readBackWrite_toΓ_eq hne] + simp only [Tape.write, Tape.read]; split + · rfl + · exact Function.update_eq_self _ _ + +-- ════════════════════════════════════════════════════════════════════════ +-- Generic simulation lifting +-- ════════════════════════════════════════════════════════════════════════ + +/-- If `wrap` commutes with `step` (i.e., one step of `tm` corresponds to + one step of `tm'` through the embedding), then `reachesIn` lifts. -/ +theorem simulation_reachesIn {tm tm' : TM n} + (wrap : Cfg n tm.Q → Cfg n tm'.Q) + (h_step : ∀ c c' : Cfg n tm.Q, tm.step c = some c' → + tm'.step (wrap c) = some (wrap c')) + {t : ℕ} {c c' : Cfg n tm.Q} + (hreach : tm.reachesIn t c c') : + tm'.reachesIn t (wrap c) (wrap c') := by + induction hreach with + | zero => exact .zero + | step hstep _ ih => exact .step (h_step _ _ hstep) ih + +-- ════════════════════════════════════════════════════════════════════════ +-- Generic output-tape rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Generic rewind loop (output tape only)**. + + For any TM with a designated "rewind state" where: + - At head > 0: one step stays in rewind, moves head left by 1, preserves cells + - At head = 0: one step enters target state, moves head to 1, preserves cells + + Then from rewind state with output head at `p`, the machine reaches the + target state with output head at 1 in exactly `p + 1` steps. + + This captures the common rewind pattern used in `complementTM`, `ifTM`, + and `loopTM`. -/ +theorem generic_rewind_loop (tm : TM n) + {rewindState targetState : tm.Q} + (h_step_left : ∀ c : Cfg n tm.Q, + c.state = rewindState → + c.output.read ≠ Γ.start → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + ∃ c', tm.step c = some c' ∧ + c'.state = rewindState ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells) + (h_step_base : ∀ c : Cfg n tm.Q, + c.state = rewindState → + c.output.read = Γ.start → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + ∃ c', tm.step c = some c' ∧ + c'.state = targetState ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells) : + ∀ (p : ℕ) (c : Cfg n tm.Q), + c.state = rewindState → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = p → + ∃ c_target, + tm.reachesIn (p + 1) c c_target ∧ + c_target.state = targetState ∧ + c_target.output.head = 1 ∧ + c_target.output.cells = c.output.cells := by + intro p + induction p with + | zero => + intro c hstate hcell0 _ hhead + have hread : c.output.read = Γ.start := by simp [Tape.read, hhead, hcell0] + obtain ⟨c', hstep, hst, hh, hc⟩ := h_step_base c hstate hread hcell0 (by assumption) + exact ⟨c', .step hstep .zero, hst, hh, hc⟩ + | succ p ih => + intro c hstate hcell0 hnostart hhead + have hread_ne : c.output.read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (p + 1) (by omega) + obtain ⟨c', hstep, hst, hh, hcells⟩ := h_step_left c hstate hread_ne hcell0 hnostart + have hh' : c'.output.head = p := by rw [hh, hhead]; omega + obtain ⟨c_target, hreach, hst_t, hh_t, hcells_t⟩ := ih c' hst + (by rw [hcells]; exact hcell0) + (by intro j hj; rw [hcells]; exact hnostart j hj) hh' + exact ⟨c_target, .step hstep hreach, hst_t, hh_t, by rw [hcells_t, hcells]⟩ + +/-- **Generic rewind loop (full tape tracking)**. + + Same as `generic_rewind_loop`, but the step hypotheses also guarantee + that input and work tapes are preserved (given stability conditions: + head ≥ 1 and cells ≥ 1 ≠ start). The conclusion additionally proves + `c_target.input = c.input` and `c_target.work = c.work`. -/ +theorem generic_rewind_loop_full (tm : TM n) + {rewindState targetState : tm.Q} + (h_step_left : ∀ c : Cfg n tm.Q, + c.state = rewindState → + c.output.read ≠ Γ.start → + c.output.cells 0 = Γ.start → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + (∀ i, (c.work i).head ≥ 1) → (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', tm.step c = some c' ∧ + c'.state = rewindState ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work) + (h_step_base : ∀ c : Cfg n tm.Q, + c.state = rewindState → + c.output.read = Γ.start → + c.output.cells 0 = Γ.start → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + (∀ i, (c.work i).head ≥ 1) → (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', tm.step c = some c' ∧ + c'.state = targetState ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells ∧ + c'.input = c.input ∧ c'.work = c.work) : + ∀ (p : ℕ) (c : Cfg n tm.Q), + c.state = rewindState → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = p → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + (∀ i, (c.work i).head ≥ 1) → (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c_target, + tm.reachesIn (p + 1) c c_target ∧ + c_target.state = targetState ∧ + c_target.output.head = 1 ∧ + c_target.output.cells = c.output.cells ∧ + c_target.input = c.input ∧ + c_target.work = c.work := by + intro p + induction p with + | zero => + intro c hstate hcell0 _ hhead h_ih h_ins h_wh h_wns + have hread : c.output.read = Γ.start := by simp [Tape.read, hhead, hcell0] + obtain ⟨c', hstep, hst, hh, hcells, hinp, hwork⟩ := + h_step_base c hstate hread hcell0 (by assumption) h_ih h_ins h_wh h_wns + exact ⟨c', .step hstep .zero, hst, hh, hcells, hinp, hwork⟩ + | succ p ih => + intro c hstate hcell0 hnostart hhead h_ih h_ins h_wh h_wns + have hread_ne : c.output.read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (p + 1) (by omega) + obtain ⟨c', hstep, hst, hh, hcells, hinp, hwork⟩ := + h_step_left c hstate hread_ne hcell0 hnostart h_ih h_ins h_wh h_wns + have hh' : c'.output.head = p := by rw [hh, hhead]; omega + obtain ⟨c_target, hreach, hst_t, hh_t, hcells_t, hinp_t, hwork_t⟩ := ih c' hst + (by rw [hcells]; exact hcell0) + (by intro j hj; rw [hcells]; exact hnostart j hj) hh' + (by rw [hinp]; exact h_ih) (by rw [hinp]; exact h_ins) + (by intro i; rw [hwork]; exact h_wh i) + (by intro i j hj; rw [hwork]; exact h_wns i j hj) + exact ⟨c_target, .step hstep hreach, hst_t, hh_t, + by rw [hcells_t, hcells], + by rw [hinp_t, hinp], + by rw [hwork_t, hwork]⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean new file mode 100644 index 0000000..fd58f24 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean @@ -0,0 +1,1588 @@ +import Complexitylib.Models.TuringMachine.Combinators + +/-! +# unionTM simulation — proof internals + +This file contains the simulation lemmas needed to prove that `unionTM tm₁ tm₂` +correctly decides `L₁ ∪ L₂` when `tm₁` decides `L₁` and `tm₂` decides `L₂`. + +## Strategy + +The proof proceeds in three phases: + +1. **Phase 1 simulation**: Show that the union machine faithfully simulates + `tm₁` for `t₁` steps, with tm₁'s output redirected to the fake output + tape (work tape `n₁`). + +2. **Transition phase**: After Phase 1, the machine rewinds the fake output + to check tm₁'s result. If tm₁ accepted (cell 1 = `Γ.one`), write `Γ.one` + to the real output and halt. Otherwise, rewind the input and start Phase 2. + +3. **Phase 2 simulation**: Simulate `tm₂` using the real output tape. + +## Key definitions + +- `idleTape` — the steady-state of an idle tape (head at 1, cells from `initTape []`) +- `phase1Cfg` — embedding of a tm₁ config into the union machine's config space +-/ + +variable {n₁ n₂ : ℕ} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Idle tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- The steady-state tape for an idle tape during Phase 1. + After the first step (where `δ_right_of_start` forces a right move from + cell 0), idle tapes remain at head position 1 with blank cells. -/ +def idleTape : Tape := + { head := 1, cells := (initTape ([] : List Γ)).cells } + +private theorem idleTape_read : idleTape.read = Γ.blank := by + simp [idleTape, Tape.read, initTape] + +private theorem idleTape_head : idleTape.head = 1 := rfl + +/-- Writing blank to an idle tape at position 1 is a no-op. -/ +private theorem idleTape_write_blank : idleTape.write Γ.blank = idleTape := by + simp [idleTape, Tape.write, initTape, Function.update_eq_self_iff] + +/-- Moving stay on an idle tape is a no-op. -/ +private theorem idleTape_move_stay : idleTape.move Dir3.stay = idleTape := by + rfl + +/-- An idle tape stays idle when written with blank and moved by idleDir. -/ +private theorem idleTape_step_idle : + (idleTape.write Γw.blank.toΓ).move (idleDir idleTape.read) = idleTape := by + show (idleTape.write Γ.blank).move (idleDir idleTape.read) = idleTape + rw [idleTape_read, idleDir, if_neg (by decide)] + simp [idleTape_write_blank, Tape.move] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1 config embedding +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a tm₁ configuration into the union machine's config space. + Active tapes (input, work 0..n₁-1, fake output at n₁) come from `c`. + Idle tapes (work n₁+1..n₁+n₂ and real output) use `idleTape`. -/ +def phase1Cfg (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : + Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) where + state := Sum.inl c.state + input := c.input + work := fun i => + if h : i.val < n₁ then c.work ⟨i.val, h⟩ + else if i.val = n₁ then c.output + else idleTape + output := idleTape + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: one-step correspondence +-- ════════════════════════════════════════════════════════════════════════ + +/-- Key computation: unionTM.δ for a Phase 1 non-halted state delegates to tm₁.δ. -/ +private theorem unionTM_delta_inl (tm₁ : TM n₁) (tm₂ : TM n₂) {q : tm₁.Q} + (hne : q ≠ tm₁.qhalt) (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : + (unionTM tm₁ tm₂).δ (Sum.inl q) iHead wHeads oHead = + let r := tm₁.δ q iHead (phase1WorkReads wHeads) (wHeads fakeOutIdx) + (Sum.inl r.1, + fun i => if h : i.val < n₁ then r.2.1 ⟨i.val, h⟩ else if i.val = n₁ then r.2.2.1 else .blank, + .blank, r.2.2.2.1, + fun i => if h : i.val < n₁ then r.2.2.2.2.1 ⟨i.val, h⟩ + else if i.val = n₁ then r.2.2.2.2.2 else idleDir (wHeads i), + idleDir oHead) := by + simp only [unionTM, if_neg hne] + +private theorem unionTM_qhalt (tm₁ : TM n₁) (tm₂ : TM n₂) : + (unionTM tm₁ tm₂).qhalt = Sum.inr (Sum.inr tm₂.qhalt) := rfl + +/-- Key computation: unionTM.δ for a Phase 2 non-halted state delegates to tm₂.δ. -/ +private theorem unionTM_delta_inr_inr (tm₁ : TM n₁) (tm₂ : TM n₂) {q : tm₂.Q} + (hne : q ≠ tm₂.qhalt) (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inr q)) iHead wHeads oHead = + let r := tm₂.δ q iHead (phase2WorkReads wHeads) oHead + (Sum.inr (Sum.inr r.1), + fun i => if h : i.val ≤ n₁ then (Γw.blank : Γw) else r.2.1 ⟨i.val - (n₁ + 1), by omega⟩, + r.2.2.1, r.2.2.2.1, + fun i => if h : i.val ≤ n₁ then idleDir (wHeads i) else r.2.2.2.2.1 ⟨i.val - (n₁ + 1), by omega⟩, + r.2.2.2.2.2) := by + simp only [unionTM, if_neg hne] + +private theorem phase1Cfg_state (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : + (phase1Cfg tm₁ tm₂ c).state = Sum.inl c.state := rfl + +private theorem phase1_step_corr (tm₁ : TM n₁) (tm₂ : TM n₂) + {c c' : Cfg n₁ tm₁.Q} (hstep : tm₁.step c = some c') : + (unionTM tm₁ tm₂).step (phase1Cfg tm₁ tm₂ c) = some (phase1Cfg tm₁ tm₂ c') := by + have hne : c.state ≠ tm₁.qhalt := by + intro heq; simp [step, heq] at hstep + -- Extract c' from tm₁.step + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + -- Unfold step for unionTM on phase1Cfg + simp only [step, phase1Cfg_state, unionTM_qhalt] + rw [if_neg (show (Sum.inl c.state : UnionQ tm₁.Q tm₂.Q) ≠ Sum.inr (Sum.inr tm₂.qhalt) from + fun h => nomatch h)] + simp only [Option.some.injEq] + -- Rewrite the δ call using our helper + simp only [unionTM_delta_inl tm₁ tm₂ hne] + -- Now unfold phase1Cfg on both sides and simplify + dsimp only [phase1Cfg] + -- Establish that the δ calls produce the same result + have hfake_read : (if h : (n₁ : ℕ) < n₁ then c.work ⟨n₁, h⟩ + else if (n₁ : ℕ) = n₁ then c.output else idleTape).read = c.output.read := by + rw [dif_neg (Nat.lt_irrefl n₁), if_pos rfl] + have hwork_reads : (phase1WorkReads fun i : Fin (n₁ + 1 + n₂) => + (if h : i.val < n₁ then c.work ⟨i.val, h⟩ + else if i.val = n₁ then c.output else idleTape).read) = + fun j => (c.work j).read := by + ext ⟨j, hj⟩; simp only [phase1WorkReads]; rw [dif_pos (show j < n₁ from hj)] + -- Simplify fakeOutIdx to ⟨n₁, _⟩ and reduce the dite conditions + simp only [fakeOutIdx] at hfake_read ⊢ + -- Rewrite the work reads and fake output read + simp_rw [hwork_reads, hfake_read] + -- State and input match by rfl; work and output need case analysis + have hcfg : ∀ (a b : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + a.state = b.state → a.input = b.input → a.work = b.work → a.output = b.output → a = b := by + intros a b hs hi hw ho; cases a; cases b; simp_all + apply hcfg + · rfl -- state + · rfl -- input + · -- work tapes: case split on i + ext i; dsimp only []; split + · rfl -- i < n₁: active work tape + · split + · rfl -- i = n₁: fake output + · -- i > n₁: idle tape stays idle + exact idleTape_step_idle + · -- output: idle tape stays idle + exact idleTape_step_idle + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1 simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Multi-step Phase 1: if tm₁ takes t steps from c to c', the union machine + takes t steps from phase1Cfg c to phase1Cfg c'. -/ +private theorem phase1_steps (tm₁ : TM n₁) (tm₂ : TM n₂) + {t : ℕ} {c c' : Cfg n₁ tm₁.Q} + (hreach : tm₁.reachesIn t c c') : + (unionTM tm₁ tm₂).reachesIn t (phase1Cfg tm₁ tm₂ c) (phase1Cfg tm₁ tm₂ c') := by + induction hreach with + | zero => exact .zero + | step hstep _ ih => exact .step (phase1_step_corr tm₁ tm₂ hstep) ih + +/-- The first step of unionTM on initCfg produces phase1Cfg of tm₁'s first step result. + At step 0, all tapes are at cell 0 with ▷, so δ_right_of_start forces right moves. + After this step, idle tapes become idleTape (head=1, blank cells). -/ +private theorem phase1_init_step (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) + {c_mid : Cfg n₁ tm₁.Q} (hstep : tm₁.step (tm₁.initCfg x) = some c_mid) : + (unionTM tm₁ tm₂).step ((unionTM tm₁ tm₂).initCfg x) = some (phase1Cfg tm₁ tm₂ c_mid) := by + have hne : tm₁.qstart ≠ tm₁.qhalt := by + intro heq; simp [step, heq] at hstep + simp only [step] at hstep ⊢ + rw [if_neg hne] at hstep + simp only [Option.some.injEq] at hstep + subst hstep + -- Unfold unionTM qstart/qhalt + rw [show (unionTM tm₁ tm₂).qstart = Sum.inl tm₁.qstart from rfl, + show (unionTM tm₁ tm₂).qhalt = Sum.inr (Sum.inr tm₂.qhalt) from rfl] + rw [if_neg (fun h : (Sum.inl tm₁.qstart : UnionQ tm₁.Q tm₂.Q) = Sum.inr (Sum.inr tm₂.qhalt) => + nomatch h)] + simp only [Option.some.injEq] + -- Rewrite the unionTM δ call + simp only [unionTM_delta_inl tm₁ tm₂ hne] + -- The phase1WorkReads of constant function is a constant function + have hwork_reads : phase1WorkReads (fun (_ : Fin (n₁ + 1 + n₂)) => (initTape ([] : List Γ)).read) = + fun _ => (initTape ([] : List Γ)).read := by ext; rfl + simp_rw [hwork_reads] + -- Now the δ calls match; show Cfg equality field by field + have hcfg : ∀ (a b : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + a.state = b.state → a.input = b.input → a.work = b.work → a.output = b.output → a = b := by + intros a b hs hi hw ho; cases a; cases b; simp_all + apply hcfg + · rfl -- state + · rfl -- input + · -- work tapes + ext i; dsimp only [phase1Cfg]; split + · -- i < n₁: all tapes start at initTape [], write at head 0 is no-op + simp [initTape, Tape.read] + · split + · -- i = n₁ + simp [initTape, Tape.read] + · -- i > n₁: becomes idleTape + simp [initTape, Tape.write, Tape.read, idleTape, idleDir, Tape.move] + · -- output: becomes idleTape (phase1Cfg always has idleTape as output) + simp only [phase1Cfg] + simp [initTape, Tape.write, Tape.read, idleDir, Tape.move, idleTape] + +theorem phase1_simulation (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) + {t₁ : ℕ} {c₁ : Cfg n₁ tm₁.Q} + (hreach : tm₁.reachesIn t₁ (tm₁.initCfg x) c₁) + (ht₁ : t₁ ≥ 1) : + (unionTM tm₁ tm₂).reachesIn t₁ ((unionTM tm₁ tm₂).initCfg x) + (phase1Cfg tm₁ tm₂ c₁) := by + -- Split the first step off + cases hreach with + | zero => omega -- contradicts t₁ ≥ 1 + | step hstep hrest => + exact .step (phase1_init_step tm₁ tm₂ x hstep) (phase1_steps tm₁ tm₂ hrest) + +-- ════════════════════════════════════════════════════════════════════════ +-- Determinism of reachesIn +-- ════════════════════════════════════════════════════════════════════════ + +/-- `reachesIn` is deterministic: since `step` is a function, the endpoint + is uniquely determined by the start config and step count. -/ +theorem reachesIn_det {tm : TM n₁} {t : ℕ} {c c' c'' : Cfg n₁ tm.Q} + (h₁ : tm.reachesIn t c c') (h₂ : tm.reachesIn t c c'') : c' = c'' := by + induction h₁ with + | zero => cases h₂; rfl + | step hs₁ _ ih₁ => + cases h₂ with + | step hs₂ h₂' => + have heq : some _ = some _ := hs₁.symm.trans hs₂ + simp only [Option.some.injEq] at heq; subst heq + exact ih₁ h₂' + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape invariant helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem Tape.move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by + cases d <;> rfl + +/-- If a tape has head ≥ 1 and cells[≥1] ≠ start, idleDir gives stay (head unchanged). -/ +private theorem idleDir_stay_of_ge_one (t : Tape) + (hhead : t.head ≥ 1) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + idleDir t.read = Dir3.stay := by + rw [idleDir, if_neg]; rw [Tape.read]; exact hno _ hhead + +/-- Input head stays constant when moved by idleDir if head ≥ 1 and cells[≥1] ≠ start. -/ +private theorem idle_move_preserves_head (t : Tape) + (hhead : t.head ≥ 1) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + (t.move (idleDir t.read)).head = t.head := by + rw [idleDir_stay_of_ge_one t hhead hno]; rfl + +private theorem Γw_toΓ_ne_start (w : Γw) : w.toΓ ≠ Γ.start := by + cases w <;> decide + +private theorem readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by + cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem readBackWrite_toΓ_ne_start (g : Γ) : (readBackWrite g).toΓ ≠ Γ.start := by + cases g <;> simp [readBackWrite, Γw.toΓ] + +/-- Cell 0 stays Γ.start after write + move. -/ +private theorem tape_cell0_preserved (t : Tape) (s : Γ) (d : Dir3) + (h0 : t.cells 0 = Γ.start) : + ((t.write s).move d).cells 0 = Γ.start := by + rw [Tape.move_cells]; simp only [Tape.write] + split + · exact h0 + · simp only [Function.update, dif_neg (show (0 : ℕ) ≠ t.head from fun h => by omega)] + exact h0 + +/-- Cells ≥ 1 stay non-Γ.start after writing a non-Γ.start value. -/ +private theorem tape_noStart_preserved (t : Tape) (s : Γ) (d : Dir3) + (hs : s ≠ Γ.start) (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + ∀ i, i ≥ 1 → ((t.write s).move d).cells i ≠ Γ.start := by + intro i hi; rw [Tape.move_cells]; simp only [Tape.write] + split + · exact hno i hi + · simp only [Function.update]; split + · next heq => subst heq; exact hs + · exact hno i hi + +/-- Output cell 0 = Γ.start is preserved by one TM step. -/ +private theorem output_cell0_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} + (hs : tm.step c = some c') (h0 : c.output.cells 0 = Γ.start) : + c'.output.cells 0 = Γ.start := by + have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact tape_cell0_preserved _ _ _ h0 + +/-- Output cells ≥ 1 ≠ Γ.start is preserved by one TM step. -/ +private theorem output_noStart_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} + (hs : tm.step c = some c') (hno : ∀ i, i ≥ 1 → c.output.cells i ≠ Γ.start) : + ∀ i, i ≥ 1 → c'.output.cells i ≠ Γ.start := by + have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact tape_noStart_preserved _ _ _ (Γw_toΓ_ne_start _) hno + +theorem output_cell0_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} + (h : tm.reachesIn t c₀ c) (h0 : c₀.output.cells 0 = Γ.start) : + c.output.cells 0 = Γ.start := by + induction h with + | zero => exact h0 + | step hs _ ih => exact ih (output_cell0_step hs h0) + +theorem output_noStart_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} + (h : tm.reachesIn t c₀ c) + (hno : ∀ i, i ≥ 1 → c₀.output.cells i ≠ Γ.start) : + ∀ i, i ≥ 1 → c.output.cells i ≠ Γ.start := by + induction h with + | zero => exact hno + | step hs _ ih => exact ih (output_noStart_step hs hno) + +theorem input_cells_of_step {tm : TM n₁} {c c' : Cfg n₁ tm.Q} + (hs : tm.step c = some c') : c'.input.cells = c.input.cells := by + have hne : c.state ≠ tm.qhalt := by intro heq; simp [step, heq] at hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact Tape.move_cells _ _ + +theorem input_cells_of_reachesIn {tm : TM n₁} {t : ℕ} {c₀ c : Cfg n₁ tm.Q} + (h : tm.reachesIn t c₀ c) : c.input.cells = c₀.input.cells := by + induction h with + | zero => rfl + | step hs _ ih => rw [ih, input_cells_of_step hs] + +theorem initTape_cell0 (xs : List Γ) : (initTape xs).cells 0 = Γ.start := by + simp [initTape] + +theorem initTape_nil_noStart {i : ℕ} (hi : i ≥ 1) : + (initTape ([] : List Γ)).cells i ≠ Γ.start := by + simp [initTape, show i ≠ 0 from by omega] + +-- ════════════════════════════════════════════════════════════════════════ +-- Union TM delta helpers for Mid states +-- ════════════════════════════════════════════════════════════════════════ + +/-- Delta computation for rewindOut when fake output is not at start. -/ +private theorem unionTM_delta_rewindOut_nostart (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : wHeads fakeOutIdx ≠ Γ.start) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindOut)) iHead wHeads oHead = + ( Sum.inr (Sum.inl Mid.rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.left else idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [if_neg hread] + +/-- Delta computation for rewindOut when fake output is at start. -/ +private theorem unionTM_delta_rewindOut_start (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : wHeads fakeOutIdx = Γ.start) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindOut)) iHead wHeads oHead = + ( Sum.inr (Sum.inl Mid.checkResult), + fun _ => .blank, .blank, idleDir iHead, + fun i => if i.val = n₁ then Dir3.right else idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [if_pos hread] + +/-- Delta computation for checkResult when fake output reads Γ.one. -/ +private theorem unionTM_delta_checkResult_one (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : wHeads fakeOutIdx = Γ.one) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.checkResult)) iHead wHeads oHead = + ( Sum.inr (Sum.inr tm₂.qhalt), + fun _ => .blank, .one, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + unfold unionTM; simp only [if_pos hread] + +/-- Delta computation for checkResult when fake output does not read Γ.one. -/ +private theorem unionTM_delta_checkResult_notone (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : wHeads fakeOutIdx ≠ Γ.one) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.checkResult)) iHead wHeads oHead = + allIdle (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead := by + unfold unionTM; simp only [if_neg hread] + +/-- Delta computation for rewindIn when input is not at start. -/ +private theorem unionTM_delta_rewindIn_nostart (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : iHead ≠ Γ.start) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead = + ( Sum.inr (Sum.inl Mid.rewindIn), + fun _ => .blank, .blank, Dir3.left, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, if_neg hread] + +/-- Delta computation for rewindIn when input is at start. -/ +private theorem unionTM_delta_rewindIn_start (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) + (hread : iHead = Γ.start) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.rewindIn)) iHead wHeads oHead = + ( Sum.inr (Sum.inl Mid.setup2), + fun _ => .blank, .blank, Dir3.right, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, if_pos hread] + +/-- Delta computation for setup2. -/ +private theorem unionTM_delta_setup2 (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : + (unionTM tm₁ tm₂).δ (Sum.inr (Sum.inl Mid.setup2)) iHead wHeads oHead = + ( Sum.inr (Sum.inr tm₂.qstart), + fun _ => .blank, .blank, moveLeftDir iHead, + fun i => if i.val ≤ n₁ then idleDir (wHeads i) else moveLeftDir (wHeads i), + moveLeftDir oHead ) := by + unfold unionTM; rfl + +/-- Delta computation for Phase 1 halted state (transition to rewindOut). -/ +private theorem unionTM_delta_inl_qhalt (tm₁ : TM n₁) (tm₂ : TM n₂) + (iHead : Γ) (wHeads : Fin (n₁ + 1 + n₂) → Γ) (oHead : Γ) : + (unionTM tm₁ tm₂).δ (Sum.inl tm₁.qhalt) iHead wHeads oHead = + ( Sum.inr (Sum.inl Mid.rewindOut), + fun i => if i.val = n₁ then readBackWrite (wHeads fakeOutIdx) else .blank, + .blank, + idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead ) := by + simp only [unionTM, ite_true] + +-- ════════════════════════════════════════════════════════════════════════ +-- One-step lemmas for union TM +-- ════════════════════════════════════════════════════════════════════════ + +/-- The union machine is not halted in any Mid state. -/ +private theorem unionTM_mid_not_halted (tm₁ : TM n₁) (tm₂ : TM n₂) (m : Mid) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl m)) : + c.state ≠ (unionTM tm₁ tm₂).qhalt := by + rw [hstate]; exact fun h => nomatch h + +/-- The union machine is not halted when in a Phase 1 state. -/ +private theorem unionTM_inl_not_halted (tm₁ : TM n₁) (tm₂ : TM n₂) (q : tm₁.Q) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inl q) : + c.state ≠ (unionTM tm₁ tm₂).qhalt := by + rw [hstate]; exact fun h => nomatch h + +/-- Step the union machine from a rewindOut state with non-start fake output read. -/ +private theorem step_rewindOut_nostart_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.rewindOut)) + (hread : (c.work fakeOutIdx).read ≠ Γ.start) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread] + +/-- Step the union machine from a rewindOut state when fake output reads start. -/ +private theorem step_rewindOut_start_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.rewindOut)) + (hread : (c.work fakeOutIdx).read = Γ.start) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.checkResult), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move + (if i.val = n₁ then Dir3.right else idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] + +/-- Step the union machine from checkResult with Γ.one → halted. -/ +private theorem step_checkResult_one_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.checkResult)) + (hread : (c.work fakeOutIdx).read = Γ.one) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inr tm₂.qhalt), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), + output := (c.output.write Γw.one.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] + +/-- Step the union machine from checkResult when not Γ.one → rewindIn (allIdle). -/ +private theorem step_checkResult_notone_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.checkResult)) + (hread : (c.work fakeOutIdx).read ≠ Γ.one) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.rewindIn), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread, allIdle] + +/-- Step the union machine from rewindIn with non-start input. -/ +private theorem step_rewindIn_nostart_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.rewindIn)) + (hread : c.input.read ≠ Γ.start) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.rewindIn), + input := c.input.move Dir3.left, + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_neg hread] + +/-- Step the union machine from rewindIn when input reads start. -/ +private theorem step_rewindIn_start_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.rewindIn)) + (hread : c.input.read = Γ.start) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.setup2), + input := c.input.move Dir3.right, + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, if_pos hread] + +/-- Step the union machine from setup2. -/ +private theorem step_setup2_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inr (Sum.inl Mid.setup2)) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inr tm₂.qstart), + input := c.input.move (moveLeftDir c.input.read), + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move + (if i.val ≤ n₁ then idleDir (c.work i).read else moveLeftDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (moveLeftDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; rfl + +/-- Step the union machine from phase1Cfg when tm₁ halted. -/ +private theorem step_inl_qhalt_cfg (tm₁ : TM n₁) (tm₂ : TM n₂) + {c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hstate : c.state = Sum.inl tm₁.qhalt) : + (unionTM tm₁ tm₂).step c = some + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by rw [hstate]; exact fun h => nomatch h + simp only [step, if_neg hne]; rw [hstate]; simp only [unionTM, ite_true] + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind fake output loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- The fake output tape's head position 0 corresponds to reading Γ.start. -/ +private theorem fakeOut_read_start_iff_head_zero (t : Tape) (h0 : t.cells 0 = Γ.start) + (hno : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + t.read = Γ.start ↔ t.head = 0 := by + constructor + · intro hr + by_contra hne + exact hno t.head (by omega) (by rwa [Tape.read] at hr) + · intro heq; rw [Tape.read, heq]; exact h0 + +/-- readBackWrite preserves cells at non-zero head positions. -/ +private theorem write_readBack_cells_eq (t : Tape) (hne : t.read ≠ Γ.start) : + (t.write (readBackWrite t.read).toΓ).cells = t.cells := by + rw [readBackWrite_toΓ_eq hne] + simp only [Tape.write] + split + · rfl + · ext i; simp only [Function.update]; split + · next heq => subst heq; rfl + · rfl + +/-- Moving left from a non-zero position decreases the head. -/ +private theorem move_left_head (t : Tape) (_h : t.head ≥ 1) : + (t.move Dir3.left).head = t.head - 1 := by + simp [Tape.move] + +/-- Rewind the fake output tape from head position `h` to head position 0. + After `h` steps in `rewindOut` state, we reach a config where the fake + output head is at 0, and one more step transitions to `checkResult`. -/ +private theorem rewind_fakeOut_loop (tm₁ : TM n₁) (tm₂ : TM n₂) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindOut) → + (c.work fakeOutIdx).head = h → + (c.work fakeOutIdx).cells 0 = Γ.start → + (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ + (c'.work fakeOutIdx).head = 0 ∧ + (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + intro h + induction h with + | zero => + intro c hst hhead _ _ + exact ⟨c, .zero, hst, hhead, rfl⟩ + | succ n ih => + intro c hst hhead hcell0 hnostart + -- The fake output head is at n+1 ≥ 1, so read ≠ Γ.start + have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + -- One rewindOut step + -- One rewindOut step using the step cfg lemma directly + have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne + -- Extract the next config + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + with hc'_def + -- c' state + have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindOut) := rfl + -- c' fake output head + have hhead' : (c'.work fakeOutIdx).head = n := by + -- c'.work fakeOutIdx unfolds via set definition + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write] + split + · -- head = 0, contradiction since head = n+1 + omega + · simp [Tape.move, hhead] + -- c' fake output cells preserved + have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] + -- Apply IH + have hcell0' : (c'.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells']; exact hcell0 + have hnostart' : ∀ i, i ≥ 1 → (c'.work fakeOutIdx).cells i ≠ Γ.start := by + rw [hcells']; exact hnostart + obtain ⟨c'', hreach, hst'', hhead'', hcells''⟩ := ih c' hst' hhead' hcell0' hnostart' + exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells']⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition phase: accept path (x ∈ L₁) +-- ════════════════════════════════════════════════════════════════════════ + +/-- idleTape invariant: cells 0 = start. -/ +private theorem idleTape_cells_0 : idleTape.cells 0 = Γ.start := by + simp [idleTape, initTape] + +/-- idleTape invariant: cells ≥ 1 ≠ start. -/ +private theorem idleTape_noStart (i : ℕ) (hi : i ≥ 1) : idleTape.cells i ≠ Γ.start := by + simp [idleTape, initTape, show i ≠ 0 from by omega] + +/-- phase1Cfg output is idleTape. -/ +private theorem phase1Cfg_output (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : + (phase1Cfg tm₁ tm₂ c).output = idleTape := rfl + +/-- phase1Cfg fake output tape is c.output. -/ +private theorem phase1Cfg_fakeOut (tm₁ : TM n₁) (tm₂ : TM n₂) (c : Cfg n₁ tm₁.Q) : + (phase1Cfg tm₁ tm₂ c).work fakeOutIdx = c.output := by + simp [phase1Cfg, fakeOutIdx] + +/-- One step from phase1Cfg when tm₁ is halted transitions to rewindOut. -/ +private theorem step_phase1_halted (tm₁ : TM n₁) (tm₂ : TM n₂) + (c₁ : Cfg n₁ tm₁.Q) (hhalt : tm₁.halted c₁) + (hnostart_out : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) : + ∃ c', (unionTM tm₁ tm₂).step (phase1Cfg tm₁ tm₂ c₁) = some c' ∧ + c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ + (c'.work fakeOutIdx).cells = c₁.output.cells ∧ + c'.output = (idleTape.write Γw.blank.toΓ).move (idleDir idleTape.read) := by + have hstate : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep := step_inl_qhalt_cfg tm₁ tm₂ hstate + -- The result config + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := (phase1Cfg tm₁ tm₂ c₁).input.move (idleDir (phase1Cfg tm₁ tm₂ c₁).input.read), + work := fun i => (((phase1Cfg tm₁ tm₂ c₁).work i).write + ((if i.val = n₁ then readBackWrite ((phase1Cfg tm₁ tm₂ c₁).work fakeOutIdx).read else .blank) : Γw).toΓ).move + (idleDir ((phase1Cfg tm₁ tm₂ c₁).work i).read), + output := ((phase1Cfg tm₁ tm₂ c₁).output.write Γw.blank.toΓ).move + (idleDir (phase1Cfg tm₁ tm₂ c₁).output.read) } with hc'_def + refine ⟨c', hstep, rfl, ?_, ?_⟩ + · -- fake output cells preserved + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [phase1Cfg_fakeOut] + rw [Tape.move_cells] + simp only [Tape.write] + split + · rfl -- head = 0: write is no-op + · next hne => + -- head ≠ 0: readBackWrite writes back the same value + have hread_ne : c₁.output.read ≠ Γ.start := by + rw [Tape.read]; exact hnostart_out _ (by omega) + rw [readBackWrite_toΓ_eq hread_ne, Tape.read] + exact Function.update_eq_self _ _ + · -- output is idleTape write blank / move idle + simp only [hc'_def, phase1Cfg_output] + +/-- Rewind the fake output tape, preserving output = idleTape. + This is the same loop as `rewind_fakeOut_loop` but also tracks the output. -/ +private theorem rewind_fakeOut_preserves_output (tm₁ : TM n₁) (tm₂ : TM n₂) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindOut) → + c.output = idleTape → + (c.work fakeOutIdx).head = h → + (c.work fakeOutIdx).cells 0 = Γ.start → + (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.state = Sum.inr (Sum.inl Mid.rewindOut) ∧ + (c'.work fakeOutIdx).head = 0 ∧ + (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells ∧ + c'.output = idleTape := by + intro h + induction h with + | zero => + intro c hst hout hhead _ _ + exact ⟨c, .zero, hst, hhead, rfl, hout⟩ + | succ n ih => + intro c hst hout hhead hcell0 hnostart + have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun i => ((c.work i).write + ((if i.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (if i.val = n₁ then Dir3.left else idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + with hc'_def + have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindOut) := rfl + have hout' : c'.output = idleTape := by + simp only [hc'_def]; rw [hout, idleTape_step_idle] + have hhead' : (c'.work fakeOutIdx).head = n := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write] + split + · omega + · simp [Tape.move, hhead] + have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] + have hcell0' : (c'.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells']; exact hcell0 + have hnostart' : ∀ i, i ≥ 1 → (c'.work fakeOutIdx).cells i ≠ Γ.start := by + rw [hcells']; exact hnostart + obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout''⟩ := + ih c' hst' hout' hhead' hcell0' hnostart' + exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout''⟩ + +/-- Through the rewind_fakeOut loop, input head is preserved when head ≥ 1 + and cells[≥1] ≠ start (since all steps move input by idleDir = stay). -/ +private theorem rewind_fakeOut_input_head (tm₁ : TM n₁) (tm₂ : TM n₂) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindOut) → + (c.work fakeOutIdx).head = h → + (c.work fakeOutIdx).cells 0 = Γ.start → + (∀ i, i ≥ 1 → (c.work fakeOutIdx).cells i ≠ Γ.start) → + c.input.head ≥ 1 → + (∀ i, i ≥ 1 → c.input.cells i ≠ Γ.start) → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.input.head = c.input.head := by + intro h + induction h with + | zero => intro c _ _ _ _ _ _; exact ⟨c, .zero, rfl⟩ + | succ n ih => + intro c hst hhead hcell0 hnostart hih hino + have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun j => ((c.work j).write + ((if j.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (if j.val = n₁ then Dir3.left else idleDir (c.work j).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + have hih' : c'.input.head = c.input.head := idle_move_preserves_head _ hih hino + have hih'ge : c'.input.head ≥ 1 := by omega + have hino' : ∀ i, i ≥ 1 → c'.input.cells i ≠ Γ.start := by + intro i hi; show (c.input.move _).cells i ≠ _; rw [Tape.move_cells]; exact hino i hi + have hhead' : (c'.work fakeOutIdx).head = n := by + show (((c.work fakeOutIdx).write (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ + then readBackWrite (c.work fakeOutIdx).read else Γw.blank).toΓ).move + (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ then Dir3.left + else idleDir (c.work fakeOutIdx).read)).head = n + simp only [show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [readBackWrite_toΓ_eq hread_ne]; simp only [Tape.write] + split + · omega + · simp [Tape.move, hhead] + have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + show (((c.work fakeOutIdx).write (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ + then readBackWrite (c.work fakeOutIdx).read else Γw.blank).toΓ).move + (if (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ then Dir3.left + else idleDir (c.work fakeOutIdx).read)).cells = _ + simp only [show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] + obtain ⟨c'', hreach, hhead''⟩ := ih c' rfl hhead' + (by rw [hcells']; exact hcell0) (by intro i hi; rw [hcells']; exact hnostart i hi) + hih'ge hino' + exact ⟨c'', .step hstep hreach, by rw [hhead'', hih']⟩ + +/-- `Γw.blank.toΓ = Γ.blank` -/ +private theorem Γw_blank_toΓ : (Γw.blank : Γw).toΓ = Γ.blank := rfl + +/-- After Phase 1, if tm₁ accepted (output cell 1 = `Γ.one`), the union + machine rewinds the fake output, checks the result, writes `Γ.one` to + the real output, and halts. -/ +theorem transition_accept (tm₁ : TM n₁) (tm₂ : TM n₂) + {c₁ : Cfg n₁ tm₁.Q} + (hhalt : tm₁.halted c₁) + (haccept : c₁.output.cells 1 = Γ.one) + (hcell0 : c₁.output.cells 0 = Γ.start) + (hnostart : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) : + ∃ (t_tr : ℕ) (c_final : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + (unionTM tm₁ tm₂).reachesIn t_tr (phase1Cfg tm₁ tm₂ c₁) c_final ∧ + (unionTM tm₁ tm₂).halted c_final ∧ + c_final.output.cells 1 = Γ.one ∧ + t_tr ≤ c₁.output.head + 4 := by + -- Step 1: phase1Cfg → rewindOut (1 step) + obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := + step_phase1_halted tm₁ tm₂ c₁ hhalt hnostart + -- Head bound for the fake output after step 1 + have hfo_head_bound : (c_rw.work fakeOutIdx).head ≤ c₁.output.head + 1 := by + have hne : (phase1Cfg tm₁ tm₂ c₁).state ≠ (unionTM tm₁ tm₂).qhalt := by + show Sum.inl c₁.state ≠ Sum.inr (Sum.inr tm₂.qhalt); exact fun h => nomatch h + have hstep1' := hstep1 + simp only [step, if_neg hne, Option.some.injEq] at hstep1' + subst hstep1' + simp only [phase1Cfg_fakeOut] + have hmv : ∀ (t : Tape) (d : Dir3), (t.move d).head ≤ t.head + 1 := by + intro t d; cases d <;> simp [Tape.move]; omega + have hwh : ∀ (t : Tape) (s : Γ), (t.write s).head = t.head := by + intro t s; simp [Tape.write]; split <;> rfl + calc ((c₁.output.write _).move _).head ≤ (c₁.output.write _).head + 1 := hmv _ _ + _ = c₁.output.head + 1 := by rw [hwh] + -- Fake output cells preserved + have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Γ.start := by + rw [hcells_rw]; exact hcell0 + have hnostart_rw : ∀ i, i ≥ 1 → (c_rw.work fakeOutIdx).cells i ≠ Γ.start := by + intro i hi; rw [hcells_rw]; exact hnostart i hi + -- c_rw.output = idleTape + have hout_rw_eq : c_rw.output = idleTape := by + rw [hout_rw]; exact idleTape_step_idle + -- Step 2: Rewind loop (h_rw steps), also preserving output = idleTape + set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def + obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0⟩ := + rewind_fakeOut_preserves_output tm₁ tm₂ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw + -- Step 3: rewindOut at head 0 → checkResult (1 step) + have hread_start : (c_at0.work fakeOutIdx).read = Γ.start := by + rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0 + have hstep3 := step_rewindOut_start_cfg tm₁ tm₂ hst_at0 hread_start + set c_cr : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.checkResult), + input := c_at0.input.move (idleDir c_at0.input.read), + work := fun i => ((c_at0.work i).write (Γw.blank : Γw).toΓ).move + (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), + output := (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) } + with hc_cr_def + -- c_cr fake output head = 1 (moved right from head 0) + have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] + -- c_cr fake output cells preserved (write blank at head 0 is no-op) + have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells]; simp only [Tape.write, if_pos hhead_at0] + -- c_cr fake output reads cell 1 = Γ.one + have hcr_read : (c_cr.work fakeOutIdx).read = Γ.one := by + rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw]; exact haccept + -- c_cr output = idleTape + have hout_cr : c_cr.output = idleTape := by + show (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) = idleTape + rw [hout_at0]; exact idleTape_step_idle + -- Step 4: checkResult with Γ.one → halt (1 step) + have hst_cr : c_cr.state = Sum.inr (Sum.inl Mid.checkResult) := rfl + have hstep4 := step_checkResult_one_cfg tm₁ tm₂ hst_cr hcr_read + set c_final : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inr tm₂.qhalt), + input := c_cr.input.move (idleDir c_cr.input.read), + work := fun i => ((c_cr.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_cr.work i).read), + output := (c_cr.output.write Γw.one.toΓ).move (idleDir c_cr.output.read) } + with hc_final_def + -- c_final is halted + have hhalt_final : (unionTM tm₁ tm₂).halted c_final := rfl + -- c_final output cell 1 = Γ.one + have hcells_final : c_final.output.cells 1 = Γ.one := by + show ((c_cr.output.write Γw.one.toΓ).move (idleDir c_cr.output.read)).cells 1 = Γ.one + rw [Tape.move_cells, hout_cr] + simp [Tape.write, idleTape, Γw.toΓ, Function.update, initTape] + -- Compose all steps: 1 + h_rw + 1 + 1 steps total + have htotal : (unionTM tm₁ tm₂).reachesIn (1 + (h_rw + (1 + 1))) + (phase1Cfg tm₁ tm₂ c₁) c_final := + reachesIn_trans _ (.step hstep1 .zero) + (reachesIn_trans _ hreach_rw + (.step hstep3 (.step hstep4 .zero))) + have heq : 1 + (h_rw + (1 + 1)) = 1 + h_rw + 1 + 1 := by omega + exact ⟨1 + h_rw + 1 + 1, c_final, heq ▸ htotal, hhalt_final, hcells_final, by omega⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition phase: reject path (x ∉ L₁) → Phase 2 ready +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind the input tape from head position `h` to head position 0, + preserving output = idleTape. -/ +private theorem rewind_input_loop (tm₁ : TM n₁) (tm₂ : TM n₂) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindIn) → + c.input.head = h → + (∀ i, i ≥ 1 → c.input.cells i ≠ Γ.start) → + c.input.cells 0 = Γ.start → + c.output = idleTape → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.state = Sum.inr (Sum.inl Mid.rewindIn) ∧ + c'.input.head = 0 ∧ + c'.input.cells = c.input.cells ∧ + c'.output = idleTape := by + intro h + induction h with + | zero => + intro c hst hhead _ _ hout + exact ⟨c, .zero, hst, hhead, rfl, hout⟩ + | succ n ih => + intro c hst hhead hnostart hcell0 hout + have hread_ne : c.input.read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindIn_nostart_cfg tm₁ tm₂ hst hread_ne + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindIn), + input := c.input.move Dir3.left, + work := fun i => ((c.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c.work i).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + with hc'_def + have hst' : c'.state = Sum.inr (Sum.inl Mid.rewindIn) := rfl + have hhead' : c'.input.head = n := by + show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead] + have hcells' : c'.input.cells = c.input.cells := Tape.move_cells _ _ + have hcell0' : c'.input.cells 0 = Γ.start := by rw [hcells']; exact hcell0 + have hnostart' : ∀ i, i ≥ 1 → c'.input.cells i ≠ Γ.start := by + intro i hi; rw [hcells']; exact hnostart i hi + have hout' : c'.output = idleTape := by + show (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) = idleTape + rw [hout]; exact idleTape_step_idle + obtain ⟨c'', hreach, hst'', hhead'', hcells'', hout''⟩ := + ih c' hst' hhead' hnostart' hcell0' hout' + exact ⟨c'', .step hstep hreach, hst'', hhead'', by rw [hcells'', hcells'], hout''⟩ + +/-- Writing blank to idleTape and moving left yields initTape []. -/ +private theorem idleTape_moveLeft : + (idleTape.write Γw.blank.toΓ).move (moveLeftDir idleTape.read) = initTape [] := by + simp [idleTape, moveLeftDir, Tape.write, Tape.move, Tape.read, initTape] + +/-- idleTape stays idleTape when written with blank and moved by idleDir (on any tape). -/ +private theorem tape_idle_step (t : Tape) (ht : t = idleTape) : + (t.write Γw.blank.toΓ).move (idleDir t.read) = idleTape := by + rw [ht]; exact idleTape_step_idle + +/-- Input cells are preserved through any reachesIn (input tape is read-only). -/ +private theorem union_input_cells_of_step (tm₁ : TM n₁) (tm₂ : TM n₂) + {c c' : Cfg (n₁ + 1 + n₂) (unionTM tm₁ tm₂).Q} + (hs : (unionTM tm₁ tm₂).step c = some c') : c'.input.cells = c.input.cells := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by intro heq; simp [step, heq] at hs + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + exact Tape.move_cells _ _ + +private theorem union_input_cells_of_reachesIn (tm₁ : TM n₁) (tm₂ : TM n₂) + {t : ℕ} {c₀ c : Cfg (n₁ + 1 + n₂) (unionTM tm₁ tm₂).Q} + (h : (unionTM tm₁ tm₂).reachesIn t c₀ c) : c.input.cells = c₀.input.cells := by + induction h with + | zero => rfl + | step hs _ ih => rw [ih, union_input_cells_of_step tm₁ tm₂ hs] + +/-- Work tapes at index `> n₁` get write blank + move idle in any step + from `inl q`, `rewindOut`, `checkResult`, or `rewindIn` states. -/ +private theorem phase2_work_step_idle (tm₁ : TM n₁) (tm₂ : TM n₂) + {c c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hs : (unionTM tm₁ tm₂).step c = some c') + (hstate : (∃ q, c.state = Sum.inl q) ∨ + c.state = Sum.inr (Sum.inl Mid.rewindOut) ∨ + c.state = Sum.inr (Sum.inl Mid.checkResult) ∨ + c.state = Sum.inr (Sum.inl Mid.rewindIn)) + {i : Fin (n₁ + 1 + n₂)} (hi : i.val > n₁) : + c'.work i = ((c.work i).write Γw.blank.toΓ).move (idleDir (c.work i).read) := by + have hne : c.state ≠ (unionTM tm₁ tm₂).qhalt := by + rcases hstate with ⟨q, hq⟩ | hq | hq | hq <;> rw [hq] <;> exact fun h => nomatch h + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hs; subst hs + have hine : (i : ℕ) ≠ n₁ := by omega + rcases hstate with ⟨q, hq⟩ | hq | hq | hq + · rw [hq]; dsimp only [unionTM]; split + · -- qhalt: write (if i = n₁ then ... else blank), dir idleDir + congr 1; simp only [hine, ↓reduceIte] + · -- q ≠ qhalt: write/dir have dif/if structure + congr 1 + · congr 1; show (if h : (i : ℕ) < n₁ then _ else if (i : ℕ) = n₁ then _ else Γw.blank) = Γw.blank + rw [dif_neg (show ¬((i : ℕ) < n₁) from by omega), if_neg hine] + · show (if h : (i : ℕ) < n₁ then _ else if (i : ℕ) = n₁ then _ else idleDir (c.work i).read) = _ + rw [dif_neg (show ¬((i : ℕ) < n₁) from by omega), if_neg hine] + · rw [hq]; dsimp only [unionTM]; split + · congr 1; simp only [hine, ↓reduceIte] + · congr 1 + · congr 1; simp only [hine, ↓reduceIte] + · simp only [hine, ↓reduceIte] + · rw [hq]; dsimp only [unionTM]; split <;> rfl + · rw [hq]; dsimp only [unionTM]; split <;> rfl + +/-- Rewind fake output loop also preserves phase 2 work tapes. -/ +private theorem rewind_fakeOut_work_idle (tm₁ : TM n₁) (tm₂ : TM n₂) + {i : Fin (n₁ + 1 + n₂)} (hi : i.val > n₁) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindOut) → + (c.work fakeOutIdx).head = h → + (c.work fakeOutIdx).cells 0 = Γ.start → + (∀ j, j ≥ 1 → (c.work fakeOutIdx).cells j ≠ Γ.start) → + c.work i = idleTape → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.work i = idleTape := by + intro h + induction h with + | zero => + intro c _ _ _ _ hidle; exact ⟨c, .zero, hidle⟩ + | succ n ih => + intro c hst hhead hcell0 hnostart hidle + have hread_ne : (c.work fakeOutIdx).read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindOut_nostart_cfg tm₁ tm₂ hst hread_ne + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindOut), + input := c.input.move (idleDir c.input.read), + work := fun j => ((c.work j).write + ((if j.val = n₁ then readBackWrite (c.work fakeOutIdx).read else .blank) : Γw).toΓ).move + (if j.val = n₁ then Dir3.left else idleDir (c.work j).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + with hc'_def + have hidle' : c'.work i = idleTape := by + simp only [hc'_def, show (i : ℕ) ≠ n₁ from by omega, ↓reduceIte] + rw [hidle]; exact idleTape_step_idle + have hhead' : (c'.work fakeOutIdx).head = n := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [readBackWrite_toΓ_eq hread_ne]; simp only [Tape.write] + split + · omega + · simp [Tape.move, hhead] + have hcells' : (c'.work fakeOutIdx).cells = (c.work fakeOutIdx).cells := by + simp only [hc'_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells, write_readBack_cells_eq _ hread_ne] + obtain ⟨c'', hreach, hidle''⟩ := ih c' rfl hhead' + (by rw [hcells']; exact hcell0) (by intro j hj; rw [hcells']; exact hnostart j hj) hidle' + exact ⟨c'', .step hstep hreach, hidle''⟩ + +/-- Rewind input loop also preserves phase 2 work tapes. -/ +private theorem rewind_input_work_idle (tm₁ : TM n₁) (tm₂ : TM n₂) + {i : Fin (n₁ + 1 + n₂)} (_hi : i.val > n₁) : + ∀ (h : ℕ) (c : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + c.state = Sum.inr (Sum.inl Mid.rewindIn) → + c.input.head = h → + (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + c.input.cells 0 = Γ.start → + c.work i = idleTape → + ∃ c', (unionTM tm₁ tm₂).reachesIn h c c' ∧ + c'.work i = idleTape := by + intro h + induction h with + | zero => + intro c _ _ _ _ hidle; exact ⟨c, .zero, hidle⟩ + | succ n ih => + intro c hst hhead hnostart hcell0 hidle + have hread_ne : c.input.read ≠ Γ.start := by + rw [Tape.read]; exact hnostart _ (by omega) + have hstep := step_rewindIn_nostart_cfg tm₁ tm₂ hst hread_ne + set c' : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindIn), + input := c.input.move Dir3.left, + work := fun j => ((c.work j).write (Γw.blank : Γw).toΓ).move (idleDir (c.work j).read), + output := (c.output.write Γw.blank.toΓ).move (idleDir c.output.read) } + with hc'_def + have hidle' : c'.work i = idleTape := by + show ((c.work i).write _).move _ = _; rw [hidle]; exact idleTape_step_idle + obtain ⟨c'', hreach, hidle''⟩ := ih c' rfl + (by show (c.input.move Dir3.left).head = n; simp [Tape.move, hhead]) + (by intro j hj; show (c.input.move Dir3.left).cells j ≠ _; rw [Tape.move_cells]; exact hnostart j hj) + (by show (c.input.move Dir3.left).cells 0 = _; rw [Tape.move_cells]; exact hcell0) + hidle' + exact ⟨c'', .step hstep hreach, hidle''⟩ + +/-- After Phase 1, if tm₁ rejected, the union machine transitions to a + config ready for Phase 2: state is `Sum.inr (Sum.inr tm₂.qstart)`, + input/output/active work tapes match `tm₂.initCfg x`. -/ +theorem transition_reject (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) + {c₁ : Cfg n₁ tm₁.Q} + (hhalt : tm₁.halted c₁) + (hreject : c₁.output.cells 1 = Γ.zero) + (hcell0_out : c₁.output.cells 0 = Γ.start) + (hnostart_out : ∀ i, i ≥ 1 → c₁.output.cells i ≠ Γ.start) + (hinput_cells : c₁.input.cells = (initTape (x.map Γ.ofBool)).cells) : + ∃ (t_tr : ℕ) (c_mid : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)), + (unionTM tm₁ tm₂).reachesIn t_tr (phase1Cfg tm₁ tm₂ c₁) c_mid ∧ + c_mid.state = Sum.inr (Sum.inr tm₂.qstart) ∧ + c_mid.input = initTape (x.map Γ.ofBool) ∧ + (∀ j : Fin n₂, c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape []) ∧ + c_mid.output = initTape [] ∧ + t_tr ≤ c₁.output.head + c₁.input.head + 7 := by + -- Step 1: phase1Cfg halted → rewindOut (1 step) + obtain ⟨c_rw, hstep1, hst_rw, hcells_rw, hout_rw⟩ := + step_phase1_halted tm₁ tm₂ c₁ hhalt hnostart_out + -- Head bounds + have hne_p1 : (phase1Cfg tm₁ tm₂ c₁).state ≠ (unionTM tm₁ tm₂).qhalt := by + show Sum.inl c₁.state ≠ Sum.inr (Sum.inr tm₂.qhalt); exact fun h => nomatch h + have hfo_head_bound : (c_rw.work fakeOutIdx).head ≤ c₁.output.head + 1 := by + have hstep1' := hstep1 + simp only [step, if_neg hne_p1, Option.some.injEq] at hstep1'; subst hstep1' + simp only [phase1Cfg_fakeOut] + have hmv : ∀ (t : Tape) (d : Dir3), (t.move d).head ≤ t.head + 1 := by + intro t d; cases d <;> simp [Tape.move]; omega + have hwh : ∀ (t : Tape) (s : Γ), (t.write s).head = t.head := by + intro t s; simp [Tape.write]; split <;> rfl + calc ((c₁.output.write _).move _).head ≤ (c₁.output.write _).head + 1 := hmv _ _ + _ = c₁.output.head + 1 := by rw [hwh] + -- c_rw properties + have hcell0_rw : (c_rw.work fakeOutIdx).cells 0 = Γ.start := by rw [hcells_rw]; exact hcell0_out + have hnostart_rw : ∀ i, i ≥ 1 → (c_rw.work fakeOutIdx).cells i ≠ Γ.start := by + intro i hi; rw [hcells_rw]; exact hnostart_out i hi + have hout_rw_eq : c_rw.output = idleTape := by rw [hout_rw]; exact idleTape_step_idle + -- Step 2: Rewind fake output (h_rw steps) + set h_rw := (c_rw.work fakeOutIdx).head with hh_rw_def + obtain ⟨c_at0, hreach_rw, hst_at0, hhead_at0, hcells_at0, hout_at0⟩ := + rewind_fakeOut_preserves_output tm₁ tm₂ h_rw c_rw hst_rw hout_rw_eq rfl hcell0_rw hnostart_rw + -- Step 3: rewindOut at head 0 → checkResult (1 step) + have hread_start : (c_at0.work fakeOutIdx).read = Γ.start := by + rw [Tape.read, hhead_at0, hcells_at0, hcells_rw]; exact hcell0_out + have hstep3 := step_rewindOut_start_cfg tm₁ tm₂ hst_at0 hread_start + set c_cr : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.checkResult), + input := c_at0.input.move (idleDir c_at0.input.read), + work := fun i => ((c_at0.work i).write (Γw.blank : Γw).toΓ).move + (if i.val = n₁ then Dir3.right else idleDir (c_at0.work i).read), + output := (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) } + with hc_cr_def + have hout_cr : c_cr.output = idleTape := by + show (c_at0.output.write Γw.blank.toΓ).move (idleDir c_at0.output.read) = idleTape + rw [hout_at0]; exact idleTape_step_idle + -- c_cr fake output reads Γ.zero (not Γ.one) + have hcr_fo_head : (c_cr.work fakeOutIdx).head = 1 := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + simp only [Tape.write, hhead_at0, ↓reduceIte, Tape.move] + have hcr_fo_cells : (c_cr.work fakeOutIdx).cells = (c_at0.work fakeOutIdx).cells := by + simp only [hc_cr_def, show (fakeOutIdx : Fin (n₁ + 1 + n₂)).val = n₁ from rfl, ite_true] + rw [Tape.move_cells]; simp only [Tape.write, if_pos hhead_at0] + have hcr_read_ne_one : (c_cr.work fakeOutIdx).read ≠ Γ.one := by + rw [Tape.read, hcr_fo_head, hcr_fo_cells, hcells_at0, hcells_rw, hreject]; decide + -- Step 4: checkResult ≠ Γ.one → rewindIn (1 step) + have hstep4 := step_checkResult_notone_cfg tm₁ tm₂ rfl hcr_read_ne_one + set c_ri : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.rewindIn), + input := c_cr.input.move (idleDir c_cr.input.read), + work := fun i => ((c_cr.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_cr.work i).read), + output := (c_cr.output.write Γw.blank.toΓ).move (idleDir c_cr.output.read) } + with hc_ri_def + have hout_ri : c_ri.output = idleTape := by + show (c_cr.output.write Γw.blank.toΓ).move (idleDir c_cr.output.read) = idleTape + rw [hout_cr]; exact idleTape_step_idle + -- Input cells chain: input is read-only, so cells are preserved through all steps. + -- phase1Cfg → c_rw → (rewind) → c_at0 → c_cr → c_ri all preserve input.cells + have hin_cells_chain : c_ri.input.cells = (initTape (x.map Γ.ofBool)).cells := by + -- c_ri.input.cells = c_cr.input.cells (move) + show (c_cr.input.move _).cells = _; rw [Tape.move_cells] + -- c_cr.input.cells = c_at0.input.cells (move) + show (c_at0.input.move _).cells = _; rw [Tape.move_cells] + -- c_at0.input.cells = c_rw.input.cells (reachesIn) + rw [union_input_cells_of_reachesIn tm₁ tm₂ hreach_rw] + -- c_rw.input.cells = phase1Cfg.input.cells (step) + have hstep1' := hstep1 + simp only [step, if_neg hne_p1, Option.some.injEq] at hstep1'; subst hstep1' + rw [Tape.move_cells]; exact hinput_cells + -- Input cells ≥ 1 ≠ Γ.start + have hin_nostart_ri : ∀ i, i ≥ 1 → c_ri.input.cells i ≠ Γ.start := by + intro i hi; rw [hin_cells_chain] + simp only [initTape, show i ≠ 0 from by omega, ↓reduceIte] + intro heq + have : (x.map Γ.ofBool)[i - 1]?.getD Γ.blank = Γ.start := heq + cases hget : (x.map Γ.ofBool)[i - 1]? with + | none => simp [hget, Option.getD] at this + | some v => + simp [hget, Option.getD] at this; subst this + have hmem := List.mem_of_getElem? hget + simp [List.mem_map] at hmem + rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Γ.ofBool] at hb + -- Input cell 0 = Γ.start + have hin_cell0_ri : c_ri.input.cells 0 = Γ.start := by + rw [hin_cells_chain]; simp [initTape] + -- Input head bound for c_ri + -- c_ri.input goes through: phase1Cfg.input → move → (h_rw moves) → move → move → move + -- Each move adds at most 1, so total head ≤ initial + (1 + h_rw + 1 + 1 + 1) + -- But we need a tighter bound. Let's compute it through the reachesIn chain. + -- Actually, we just need c_ri.input.head for the rewind loop bound. + -- Let's compose: steps 1..4 give reachesIn (1 + h_rw + 1 + 1) from phase1Cfg to c_ri + have hreach_to_ri : (unionTM tm₁ tm₂).reachesIn (1 + (h_rw + (1 + 1))) + (phase1Cfg tm₁ tm₂ c₁) c_ri := + reachesIn_trans _ (.step hstep1 .zero) + (reachesIn_trans _ hreach_rw (.step hstep3 (.step hstep4 .zero))) + -- Input head bound: through all steps, head changes by at most 1 per step + -- total steps so far = 1 + h_rw + 2, so head ≤ initial + (1 + h_rw + 2) + -- phase1Cfg.input.head = c₁.input.head + -- But we need a precise bound. Let's just track c_ri.input.head. + -- Actually for rewind_input_loop we need h_ri = c_ri.input.head and the + -- total t_tr ≤ c₁.output.head + c₁.input.head + 7 + -- We don't need a tight head bound; we just use the loop count. + -- Step 5: Rewind input (h_ri steps) + set h_ri := c_ri.input.head with hh_ri_def + obtain ⟨c_ri0, hreach_ri, hst_ri0, hhead_ri0, hcells_ri0, hout_ri0⟩ := + rewind_input_loop tm₁ tm₂ h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri hout_ri + -- Step 6: rewindIn at head 0 → setup2 (1 step) + have hread_start_ri : c_ri0.input.read = Γ.start := by + rw [Tape.read, hhead_ri0, hcells_ri0, hin_cells_chain]; simp [initTape] + have hstep6 := step_rewindIn_start_cfg tm₁ tm₂ hst_ri0 hread_start_ri + set c_s2 : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inl Mid.setup2), + input := c_ri0.input.move Dir3.right, + work := fun i => ((c_ri0.work i).write (Γw.blank : Γw).toΓ).move (idleDir (c_ri0.work i).read), + output := (c_ri0.output.write Γw.blank.toΓ).move (idleDir c_ri0.output.read) } + with hc_s2_def + -- Step 7: setup2 → Phase 2 start (1 step) + have hstep7 := step_setup2_cfg tm₁ tm₂ (show c_s2.state = Sum.inr (Sum.inl Mid.setup2) from rfl) + set c_mid : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q) := + { state := Sum.inr (Sum.inr tm₂.qstart), + input := c_s2.input.move (moveLeftDir c_s2.input.read), + work := fun i => ((c_s2.work i).write (Γw.blank : Γw).toΓ).move + (if i.val ≤ n₁ then idleDir (c_s2.work i).read else moveLeftDir (c_s2.work i).read), + output := (c_s2.output.write Γw.blank.toΓ).move (moveLeftDir c_s2.output.read) } + with hc_mid_def + -- Now prove all properties of c_mid. + -- c_mid.state + have hst_mid : c_mid.state = Sum.inr (Sum.inr tm₂.qstart) := rfl + -- c_mid.input = initTape (x.map Γ.ofBool) + -- c_mid.input = c_s2.input.move (moveLeftDir c_s2.input.read) + -- c_s2.input = c_ri0.input.move Dir3.right + -- c_ri0.input.head = 0, so moving right gives head = 1 + -- c_s2.input.head = 1, c_s2.input.cells = c_ri0.input.cells (move preserves) + -- c_s2.input.read = cells[1] which is from initTape, not start + -- moveLeftDir(non-start) = left, so head goes from 1 to 0 + -- c_mid.input = { head := 0, cells := initTape cells } = initTape (x.map Γ.ofBool) + have hcells_ri0_eq : c_ri0.input.cells = (initTape (x.map Γ.ofBool)).cells := by + rw [hcells_ri0, hin_cells_chain] + have hin_mid : c_mid.input = initTape (x.map Γ.ofBool) := by + -- c_mid.input.cells = initTape cells + have h2 : c_mid.input.cells = (initTape (x.map Γ.ofBool)).cells := by + show (c_s2.input.move _).cells = _ + rw [Tape.move_cells]; show (c_ri0.input.move Dir3.right).cells = _ + rw [Tape.move_cells]; exact hcells_ri0_eq + -- c_s2.input = c_ri0.input.move Dir3.right, head = 1 + have hs2_head : c_s2.input.head = 1 := by + show (c_ri0.input.move Dir3.right).head = 1 + simp [Tape.move, hhead_ri0] + have hs2_cells : c_s2.input.cells = c_ri0.input.cells := Tape.move_cells _ _ + -- c_s2.input.read ≠ Γ.start (cells[1] is from initTape, not start) + have hs2_read_ne : c_s2.input.read ≠ Γ.start := by + rw [Tape.read, hs2_head, hs2_cells, hcells_ri0] + exact hin_nostart_ri 1 (by omega) + -- c_mid.input.head = 0 (moveLeftDir of non-start = left, from head 1 → 0) + have h1 : c_mid.input.head = 0 := by + show (c_s2.input.move (moveLeftDir c_s2.input.read)).head = 0 + rw [moveLeftDir, if_neg hs2_read_ne]; simp [Tape.move, hs2_head] + -- Combine + have hcfg : ∀ (a b : Tape), a.head = b.head → a.cells = b.cells → a = b := by + intros a b hh hc; cases a; cases b; simp only [Tape.mk.injEq] at *; exact ⟨hh, hc⟩ + exact hcfg _ _ (by rw [h1]; rfl) h2 + -- c_mid.output = initTape [] + -- c_mid.output = (c_s2.output.write blank).move (moveLeftDir c_s2.output.read) + -- c_s2.output = (c_ri0.output.write blank).move (idleDir c_ri0.output.read) + -- c_ri0.output = idleTape + -- c_s2.output = idleTape (write blank + move idle on idleTape) + -- c_mid.output = (idleTape.write blank).move (moveLeftDir idleTape.read) = initTape [] + have hout_s2 : c_s2.output = idleTape := by + show (c_ri0.output.write Γw.blank.toΓ).move (idleDir c_ri0.output.read) = idleTape + rw [hout_ri0]; exact idleTape_step_idle + have hout_mid : c_mid.output = initTape [] := by + show (c_s2.output.write Γw.blank.toΓ).move (moveLeftDir c_s2.output.read) = initTape [] + rw [hout_s2]; exact idleTape_moveLeft + -- Phase 2 work tapes = initTape [] + -- Strategy: show work tapes at > n₁ indices stay idleTape through each phase, + -- then setup2 sends idleTape to initTape []. + -- Step 1: c_rw.work at > n₁ = idleTape (from phase1_halted step) + have hwork_rw_idle : ∀ (j : Fin n₂), + c_rw.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + have hstateq : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep' := phase2_work_step_idle tm₁ tm₂ hstep1 + (Or.inl ⟨tm₁.qhalt, hstateq⟩) (i := ⟨n₁ + 1 + j.val, by omega⟩) (by omega : n₁ + 1 + j.val > n₁) + rw [hstep'] + have hp1 : (phase1Cfg tm₁ tm₂ c₁).work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + simp [phase1Cfg, show ¬(n₁ + 1 + j.val < n₁) from by omega, + show ¬(n₁ + 1 + j.val = n₁) from by omega] + rw [hp1]; exact idleTape_step_idle + -- Step 2: Through rewind_fakeOut (hreach_rw), work tapes > n₁ stay idleTape + -- Use reachesIn determinism: rewind_fakeOut_work_idle produces the same endpoint as hreach_rw + have hwork_at0_idle : ∀ (j : Fin n₂), + c_at0.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + obtain ⟨c_at0', hreach', hidle'⟩ := rewind_fakeOut_work_idle tm₁ tm₂ + (show n₁ + 1 + j.val > n₁ from by omega) + h_rw c_rw hst_rw rfl hcell0_rw hnostart_rw (hwork_rw_idle j) + have hdet := reachesIn_det hreach_rw hreach' + rw [hdet]; exact hidle' + -- Step 3 (rewindOut→checkResult): c_cr.work at > n₁ = idleTape + have hwork_cr_idle : ∀ (j : Fin n₂), + c_cr.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + show ((c_at0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move + (if (n₁ + 1 + j.val) = n₁ then _ else _) = _ + rw [if_neg (show n₁ + 1 + j.val ≠ n₁ from by omega), hwork_at0_idle j] + exact idleTape_step_idle + -- Step 4 (checkResult→rewindIn): c_ri.work at > n₁ = idleTape + have hwork_ri_idle : ∀ (j : Fin n₂), + c_ri.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + show ((c_cr.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ + rw [hwork_cr_idle j]; exact idleTape_step_idle + -- Step 5: Through rewind_input (hreach_ri), work tapes > n₁ stay idleTape + have hwork_ri0_idle : ∀ (j : Fin n₂), + c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + obtain ⟨c_ri0', hreach', hidle'⟩ := rewind_input_work_idle tm₁ tm₂ + (show n₁ + 1 + j.val > n₁ from by omega) + h_ri c_ri rfl rfl hin_nostart_ri hin_cell0_ri (hwork_ri_idle j) + have hdet := reachesIn_det hreach_ri hreach' + rw [hdet]; exact hidle' + -- Step 6 (rewindIn→setup2): c_s2.work at > n₁ = idleTape + have hwork_s2_idle : ∀ (j : Fin n₂), + c_s2.work ⟨n₁ + 1 + j.val, by omega⟩ = idleTape := by + intro j + show ((c_ri0.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move _ = _ + rw [hwork_ri0_idle j]; exact idleTape_step_idle + -- Step 7 (setup2→phase2_start): c_mid.work at > n₁ = initTape [] + have hwork_mid : ∀ (j : Fin n₂), + c_mid.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape [] := by + intro j + show ((c_s2.work ⟨n₁ + 1 + j.val, by omega⟩).write _).move + (if (n₁ + 1 + j.val) ≤ n₁ then _ else _) = _ + rw [if_neg (show ¬(n₁ + 1 + j.val ≤ n₁) from by omega), hwork_s2_idle j] + exact idleTape_moveLeft + -- Compose all reachesIn steps + have hreach_total : (unionTM tm₁ tm₂).reachesIn + (1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1))) + (phase1Cfg tm₁ tm₂ c₁) c_mid := + reachesIn_trans _ hreach_to_ri + (reachesIn_trans _ hreach_ri (.step hstep6 (.step hstep7 .zero))) + -- Time bound + -- h_rw ≤ c₁.output.head + 1 (hfo_head_bound) + -- h_ri = c_ri.input.head ≤ c₁.input.head + 1 (input moves by idleDir, which is stay for head ≥ 1) + -- Need: 1 + (h_rw + 2) + (h_ri + 2) = h_rw + h_ri + 5 ≤ c₁.output.head + c₁.input.head + 7 + -- Suffices: h_rw + h_ri ≤ c₁.output.head + c₁.input.head + 2, which holds. + -- Prove h_ri ≤ c₁.input.head + 1: + have hri_bound : h_ri ≤ c₁.input.head + 1 := by + -- c_rw.input.cells = c₁.input.cells (input cells preserved through step) + have hcrw_cells : c_rw.input.cells = c₁.input.cells := by + have := union_input_cells_of_step tm₁ tm₂ hstep1 + rw [this]; rfl + -- c_rw.input cells[≥1] ≠ Γ.start + have hcrw_ino : ∀ i, i ≥ 1 → c_rw.input.cells i ≠ Γ.start := by + intro i hi; rw [hcrw_cells, hinput_cells] + simp only [initTape, show i ≠ 0 from by omega, ↓reduceIte] + intro heq + cases hget : (x.map Γ.ofBool)[i - 1]? with + | none => simp [hget, Option.getD] at heq + | some v => + simp [hget, Option.getD] at heq; subst heq + have hmem := List.mem_of_getElem? hget + simp [List.mem_map] at hmem; rcases hmem with ⟨_, hb⟩ | ⟨_, hb⟩ <;> simp [Γ.ofBool] at hb + -- c_rw.input.head ≤ c₁.input.head + 1 + -- From step_inl_qhalt_cfg, the input direction is idleDir(input.read) + -- Use step_inl_qhalt_cfg to get the exact form of c_rw.input + have hstateq : (phase1Cfg tm₁ tm₂ c₁).state = Sum.inl tm₁.qhalt := by + show Sum.inl c₁.state = Sum.inl tm₁.qhalt; rw [hhalt] + have hstep_eq := step_inl_qhalt_cfg tm₁ tm₂ hstateq + -- c_rw.input = c₁.input.move (idleDir c₁.input.read) since phase1Cfg.input = c₁.input + have hcrw_input_eq : c_rw.input = c₁.input.move (idleDir c₁.input.read) := by + have heq : some c_rw = some _ := hstep1.symm.trans hstep_eq + simp only [Option.some.injEq] at heq + rw [heq]; rfl + -- c_rw.input.head ≤ c₁.input.head + 1 + have hcrw_head : c_rw.input.head ≤ c₁.input.head + 1 := by + rw [hcrw_input_eq]; cases (idleDir c₁.input.read) <;> simp [Tape.move]; omega + -- c_rw.input.head ≥ 1 + have hcrw_hge : c_rw.input.head ≥ 1 := by + rw [hcrw_input_eq] + by_cases hh : c₁.input.head = 0 + · have hread0 : c₁.input.read = Γ.start := by + rw [Tape.read, hh, hinput_cells]; simp [initTape] + rw [hread0, idleDir, if_pos rfl]; simp [Tape.move, hh] + · have hge : c₁.input.head ≥ 1 := by omega + have hc1_ino : ∀ i, i ≥ 1 → c₁.input.cells i ≠ Γ.start := by + intro i hi; rw [← hcrw_cells]; exact hcrw_ino i hi + rw [idleDir_stay_of_ge_one _ hge hc1_ino]; simp [Tape.move]; omega + -- Through rewind_fakeOut loop: input head preserved (all steps move input by idleDir = stay) + obtain ⟨c_at0', hreach_at0', hat0_head'⟩ := rewind_fakeOut_input_head tm₁ tm₂ + h_rw c_rw hst_rw rfl hcell0_rw hnostart_rw hcrw_hge hcrw_ino + have hat0_det := reachesIn_det hreach_rw hreach_at0' + -- c_at0.input.head = c_rw.input.head + have hat0_head : c_at0.input.head = c_rw.input.head := by + rw [hat0_det]; exact hat0_head' + -- c_at0.input.cells[≥1] ≠ start (preserved through reachesIn) + have hat0_ino : ∀ i, i ≥ 1 → c_at0.input.cells i ≠ Γ.start := by + intro i hi; rw [union_input_cells_of_reachesIn tm₁ tm₂ hreach_rw]; exact hcrw_ino i hi + -- c_cr.input.head = c_at0.input.head (idleDir step from head ≥ 1) + have hcr_head : c_cr.input.head = c_at0.input.head := by + show (c_at0.input.move (idleDir c_at0.input.read)).head = _ + exact idle_move_preserves_head _ (by omega) hat0_ino + -- c_ri.input.head = c_cr.input.head (idleDir step from head ≥ 1) + have hcr_ino : ∀ i, i ≥ 1 → c_cr.input.cells i ≠ Γ.start := by + intro i hi; show (c_at0.input.move _).cells i ≠ _; rw [Tape.move_cells]; exact hat0_ino i hi + have hri_head : c_ri.input.head = c_cr.input.head := by + show (c_cr.input.move (idleDir c_cr.input.read)).head = _ + exact idle_move_preserves_head _ (by omega) hcr_ino + -- Chain: h_ri = c_ri.input.head = c_rw.input.head ≤ c₁.input.head + 1 + omega + have htime : 1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)) ≤ c₁.output.head + c₁.input.head + 7 := by + omega + refine ⟨1 + (h_rw + (1 + 1)) + (h_ri + (1 + 1)), c_mid, ?_, hst_mid, hin_mid, hwork_mid, hout_mid, htime⟩ + exact hreach_total + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: one-step correspondence +-- ════════════════════════════════════════════════════════════════════════ + +/-- Phase 2 compatibility: a union machine config agrees with a tm₂ config + on the active components (state, input, Phase 2 work tapes, output). -/ +structure Phase2Compat (tm₁ : TM n₁) (tm₂ : TM n₂) + (c_u : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)) + (c₂ : Cfg n₂ tm₂.Q) : Prop where + state_eq : c_u.state = Sum.inr (Sum.inr c₂.state) + input_eq : c_u.input = c₂.input + work_eq : ∀ j : Fin n₂, c_u.work ⟨n₁ + 1 + j.val, by omega⟩ = c₂.work j + output_eq : c_u.output = c₂.output + +/-- One step of the union machine on a Phase 2 compatible config preserves + compatibility. -/ +private theorem phase2_step_corr (tm₁ : TM n₁) (tm₂ : TM n₂) + {c₂ c₂' : Cfg n₂ tm₂.Q} (hstep : tm₂.step c₂ = some c₂') + {c_u : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hcompat : Phase2Compat tm₁ tm₂ c_u c₂) : + ∃ c_u', (unionTM tm₁ tm₂).step c_u = some c_u' ∧ + Phase2Compat tm₁ tm₂ c_u' c₂' := by + have hne : c₂.state ≠ tm₂.qhalt := by intro heq; simp [step, heq] at hstep + -- Extract c₂' from tm₂.step + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep; subst hstep + -- c_u is not halted in the union machine + have hne_u : c_u.state ≠ (unionTM tm₁ tm₂).qhalt := by + rw [hcompat.state_eq, unionTM_qhalt]; exact fun h => hne (Sum.inr.inj (Sum.inr.inj h)) + -- Unfold the union step and pick the result as witness + simp only [step, hne_u, ↓reduceIte] + refine ⟨_, rfl, ?_⟩ + -- Rewrite reads using Phase2Compat + have hwork_reads : phase2WorkReads (fun i => (c_u.work i).read) = + fun j => (c₂.work j).read := by + ext ⟨j, hj⟩; simp only [phase2WorkReads]; exact congrArg Tape.read (hcompat.work_eq ⟨j, hj⟩) + -- Construct Phase2Compat + constructor + · -- state_eq + dsimp only [] + rw [hcompat.state_eq] + simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] + · -- input_eq + dsimp only [] + rw [hcompat.state_eq] + simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] + · -- work_eq + intro ⟨j, hj⟩ + dsimp only [] + rw [hcompat.state_eq] + simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] + have hgt : ¬((n₁ + 1 + j) ≤ n₁) := by omega + rw [dif_neg hgt] + have hfin : ∀ (p : n₁ + 1 + j - (n₁ + 1) < n₂), + (⟨n₁ + 1 + j - (n₁ + 1), p⟩ : Fin n₂) = ⟨j, hj⟩ := by + intro p; apply Fin.ext; show n₁ + 1 + j - (n₁ + 1) = j; omega + simp only [hfin, hcompat.work_eq ⟨j, hj⟩, dif_neg hgt] + · -- output_eq + dsimp only [] + rw [hcompat.state_eq] + simp only [unionTM_delta_inr_inr tm₁ tm₂ hne, hcompat.input_eq, hcompat.output_eq, hwork_reads] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2 simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Multi-step Phase 2 simulation via step correspondence. -/ +private theorem phase2_steps (tm₁ : TM n₁) (tm₂ : TM n₂) + {t : ℕ} {c₂_start c₂_end : Cfg n₂ tm₂.Q} + (hreach : tm₂.reachesIn t c₂_start c₂_end) + {c_start : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hcompat : Phase2Compat tm₁ tm₂ c_start c₂_start) : + ∃ c_end, (unionTM tm₁ tm₂).reachesIn t c_start c_end ∧ + Phase2Compat tm₁ tm₂ c_end c₂_end := by + induction hreach generalizing c_start with + | zero => exact ⟨c_start, .zero, hcompat⟩ + | step hstep _ ih => + obtain ⟨c_mid, hstep_u, hcompat_mid⟩ := phase2_step_corr tm₁ tm₂ hstep hcompat + obtain ⟨c_end, hreach_u, hcompat_end⟩ := ih hcompat_mid + exact ⟨c_end, .step hstep_u hreach_u, hcompat_end⟩ + +/-- **Phase 2 simulation**: if `tm₂` reaches `c₂` from `initCfg x` in + `t₂` steps, and the starting union config is compatible with `initCfg x`, + then the union machine reaches a config compatible with `c₂` in `t₂` steps. -/ +theorem phase2_simulation (tm₁ : TM n₁) (tm₂ : TM n₂) (x : List Bool) + {t₂ : ℕ} {c₂ : Cfg n₂ tm₂.Q} + (hreach : tm₂.reachesIn t₂ (tm₂.initCfg x) c₂) + {c_start : Cfg (n₁ + 1 + n₂) (UnionQ tm₁.Q tm₂.Q)} + (hss : c_start.state = Sum.inr (Sum.inr tm₂.qstart)) + (hsi : c_start.input = initTape (x.map Γ.ofBool)) + (hsw : ∀ j : Fin n₂, c_start.work ⟨n₁ + 1 + j.val, by omega⟩ = initTape []) + (hso : c_start.output = initTape []) : + ∃ c_end, (unionTM tm₁ tm₂).reachesIn t₂ c_start c_end ∧ + c_end.state = Sum.inr (Sum.inr c₂.state) ∧ + c_end.output = c₂.output := by + have hcompat : Phase2Compat tm₁ tm₂ c_start (tm₂.initCfg x) := + ⟨by rw [hss], hsi, hsw, hso⟩ + obtain ⟨c_end, hreach_u, hcompat_end⟩ := phase2_steps tm₁ tm₂ hreach hcompat + exact ⟨c_end, hreach_u, hcompat_end.state_eq, hcompat_end.output_eq⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Head bound lemma +-- ════════════════════════════════════════════════════════════════════════ + +private theorem Tape.move_head_le (t : Tape) (d : Dir3) : + (t.move d).head ≤ t.head + 1 := by + cases d <;> simp [Tape.move]; omega + +private theorem Tape.write_head_eq (t : Tape) (s : Γ) : + (t.write s).head = t.head := by + simp [Tape.write]; split <;> rfl + +/-- After one step, each tape head increases by at most 1. -/ +private theorem step_head_bound (tm : TM n₁) (c c' : Cfg n₁ tm.Q) + (hs : tm.step c = some c') : + c'.input.head ≤ c.input.head + 1 ∧ + c'.output.head ≤ c.output.head + 1 ∧ + ∀ i, (c'.work i).head ≤ (c.work i).head + 1 := by + unfold TM.step at hs + split at hs + · simp at hs + · simp only [Option.some.injEq] at hs + subst hs + dsimp only [] + set δr := tm.δ c.state c.input.read (fun i => (c.work i).read) c.output.read + refine ⟨Tape.move_head_le _ δr.2.2.2.1, ?_, fun i => ?_⟩ + · have hm := Tape.move_head_le (c.output.write δr.2.2.1.toΓ) δr.2.2.2.2.2 + simp only [Tape.write_head_eq] at hm + exact hm + · have hm := Tape.move_head_le ((c.work i).write (δr.2.1 i).toΓ) (δr.2.2.2.2.1 i) + simp only [Tape.write_head_eq] at hm + exact hm + +/-- A tape head moves at most 1 cell per step. After `t` steps starting + from `initCfg`, the head is at position ≤ `t`. -/ +theorem head_bound_of_reachesIn (tm : TM n₁) + {t : ℕ} {c : Cfg n₁ tm.Q} + (hreach : tm.reachesIn t (tm.initCfg x) c) : + c.input.head ≤ t ∧ c.output.head ≤ t ∧ ∀ i, (c.work i).head ≤ t := by + suffices gen : ∀ (t : ℕ) (c₀ c : Cfg n₁ tm.Q), tm.reachesIn t c₀ c → + c.input.head ≤ c₀.input.head + t ∧ + c.output.head ≤ c₀.output.head + t ∧ + ∀ i, (c.work i).head ≤ (c₀.work i).head + t by + have h := gen t (tm.initCfg x) c hreach + simp [initTape] at h + exact h + intro t c₀ c hreach + induction hreach with + | zero => simp + | step hstep _ ih => + obtain ⟨ih_in, ih_out, ih_work⟩ := ih + obtain ⟨hs_in, hs_out, hs_work⟩ := step_head_bound tm _ _ hstep + exact ⟨by omega, by omega, fun i => by have := hs_work i; have := ih_work i; omega⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean new file mode 100644 index 0000000..a53a174 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean @@ -0,0 +1,347 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# loopTM simulation — proof internals + +This file contains the simulation lemmas for `loopTM tmBody tmTest`. + +## Key definitions + +- `loopBodyWrap` — embed a `tmBody` config into the `loopTM` config space +- `loopTestWrap` — embed a `tmTest` config into the `loopTM` config space +- `loopTransitionTape` / `loopTransitionInput` — tape transformations at transitions +-/ + +variable {n : ℕ} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +def loopBodyWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmBody.Q) : + Cfg n (LoopQ tmBody.Q tmTest.Q) where + state := Sum.inl c.state + input := c.input + work := c.work + output := c.output + +def loopTestWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmTest.Q) : + Cfg n (LoopQ tmBody.Q tmTest.Q) where + state := Sum.inr (Sum.inr c.state) + input := c.input + work := c.work + output := c.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape transition helpers +-- ════════════════════════════════════════════════════════════════════════ + +def loopTransitionTape (t : Tape) : Tape := + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) + +def loopTransitionInput (t : Tape) : Tape := + t.move (idleDir t.read) + +-- ════════════════════════════════════════════════════════════════════════ +-- Sum discrimination helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loopQ_body_ne_halt {QBody QTest : Type} {q : QBody} : + (Sum.inl q : LoopQ QBody QTest) ≠ Sum.inr (Sum.inl LoopPhase.done) := nofun + +private theorem loopQ_test_ne_halt {QBody QTest : Type} {q : QTest} : + (Sum.inr (Sum.inr q) : LoopQ QBody QTest) ≠ + Sum.inr (Sum.inl LoopPhase.done) := nofun + +-- ════════════════════════════════════════════════════════════════════════ +-- Body phase: loopTM simulates tmBody (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_body_step (tmBody tmTest : TM n) {c c' : Cfg n tmBody.Q} + (hstep : tmBody.step c = some c') : + (loopTM tmBody tmTest).step (loopBodyWrap tmBody tmTest c) = + some (loopBodyWrap tmBody tmTest c') := by + have hne : c.state ≠ tmBody.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (loopBodyWrap tmBody tmTest c).state = + (loopTM tmBody tmTest).qhalt then none else some _) = some _ + simp only [loopBodyWrap, loopTM, if_neg loopQ_body_ne_halt, if_neg hne] + +theorem loopTM_body_simulation (tmBody tmTest : TM n) {t : ℕ} + {c_start c_end : Cfg n tmBody.Q} + (hreach : tmBody.reachesIn t c_start c_end) : + (loopTM tmBody tmTest).reachesIn t + (loopBodyWrap tmBody tmTest c_start) (loopBodyWrap tmBody tmTest c_end) := + simulation_reachesIn (tm' := loopTM tmBody tmTest) (loopBodyWrap tmBody tmTest) + (fun _ _ => loopTM_body_step tmBody tmTest) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Body → test transition +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_body_to_test (tmBody tmTest : TM n) {c : Cfg n tmBody.Q} + (hhalt : c.state = tmBody.qhalt) : + (loopTM tmBody tmTest).step (loopBodyWrap tmBody tmTest c) = + some (loopTestWrap tmBody tmTest + { state := tmTest.qstart, + input := loopTransitionInput c.input, + work := fun i => loopTransitionTape (c.work i), + output := loopTransitionTape c.output }) := by + show (if (loopBodyWrap tmBody tmTest c).state = + (loopTM tmBody tmTest).qhalt then none else some _) = some _ + simp only [loopBodyWrap, loopTM, if_neg loopQ_body_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Test phase: loopTM simulates tmTest (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem sum_inr_inr_ne_of_ne {α β γ : Type} {a b : γ} (h : a ≠ b) : + (Sum.inr (Sum.inr a) : α ⊕ β ⊕ γ) ≠ Sum.inr (Sum.inr b) := + fun heq => h (Sum.inr.inj (Sum.inr.inj heq)) + +theorem loopTM_test_step (tmBody tmTest : TM n) {c c' : Cfg n tmTest.Q} + (hstep : tmTest.step c = some c') : + (loopTM tmBody tmTest).step (loopTestWrap tmBody tmTest c) = + some (loopTestWrap tmBody tmTest c') := by + have hne : c.state ≠ tmTest.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (loopTestWrap tmBody tmTest c).state = + (loopTM tmBody tmTest).qhalt then none else some _) = some _ + simp only [loopTestWrap, loopTM, if_neg loopQ_test_ne_halt, if_neg hne] + +theorem loopTM_test_simulation (tmBody tmTest : TM n) {t : ℕ} + {c_start c_end : Cfg n tmTest.Q} + (hreach : tmTest.reachesIn t c_start c_end) : + (loopTM tmBody tmTest).reachesIn t + (loopTestWrap tmBody tmTest c_start) (loopTestWrap tmBody tmTest c_end) := + simulation_reachesIn (tm' := loopTM tmBody tmTest) (loopTestWrap tmBody tmTest) + (fun _ _ => loopTM_test_step tmBody tmTest) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Test → rewind transition +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_test_to_rewind (tmBody tmTest : TM n) {c : Cfg n tmTest.Q} + (hhalt : c.state = tmTest.qhalt) : + (loopTM tmBody tmTest).step (loopTestWrap tmBody tmTest c) = + some { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := loopTransitionInput c.input, + work := fun i => loopTransitionTape (c.work i), + output := loopTransitionTape c.output } := by + show (if (loopTestWrap tmBody tmTest c).state = + (loopTM tmBody tmTest).qhalt then none else some _) = some _ + simp only [loopTestWrap, loopTM, if_neg loopQ_test_ne_halt, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Rewind loop (via generic rewind) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loop_rewind_step_left (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread_ne : c.output.read ≠ Γ.start) + (_ : c.output.cells 0 = Γ.start) (_ : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.rewindOut) ∧ + c'.output.head = c.output.head - 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; exact fun h => LoopPhase.noConfusion (Sum.inl.inj (Sum.inr.inj h)) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · omega + · simp + · simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write, Tape.read]; split + · rfl + · exact Function.update_eq_self _ _ + +private theorem loop_rewind_step_base (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.rewindOut)) + (hread : c.output.read = Γ.start) + (_ : c.output.cells 0 = Γ.start) + (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; exact fun h => LoopPhase.noConfusion (Sum.inl.inj (Sum.inr.inj h)) + have hhead : c.output.head = 0 := by + by_contra hne + have hge : c.output.head ≥ 1 := by omega + exact hnostart c.output.head hge (by simp only [Tape.read] at hread; exact hread) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + +theorem loopTM_rewind_loop (tmBody tmTest : TM n) : + ∀ (p : ℕ) (c : Cfg n (LoopQ tmBody.Q tmTest.Q)), + c.state = Sum.inr (Sum.inl LoopPhase.rewindOut) → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = p → + ∃ c_check, + (loopTM tmBody tmTest).reachesIn (p + 1) c c_check ∧ + c_check.state = Sum.inr (Sum.inl LoopPhase.check) ∧ + c_check.output.head = 1 ∧ + c_check.output.cells = c.output.cells := + generic_rewind_loop (loopTM tmBody tmTest) + (fun c hst hread hc0 hns => loop_rewind_step_left tmBody tmTest c hst hread hc0 hns) + (fun c hst hread hc0 hns => loop_rewind_step_base tmBody tmTest c hst hread hc0 hns) + +-- ════════════════════════════════════════════════════════════════════════ +-- Check step: halt (output = 1) or continue (output ≠ 1) +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_check_halt (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 = Γ.one) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.done) ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; exact fun h => LoopPhase.noConfusion (Sum.inl.inj (Sum.inr.inj h)) + have hread : c.output.read = Γ.one := by simp [Tape.read, hhead, hcell1] + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread] + refine ⟨_, rfl, rfl, ?_⟩ + show (c.output.writeAndMove (readBackWrite Γ.one).toΓ (idleDir Γ.one)).cells = c.output.cells + simp only [readBackWrite, Γw.toΓ, idleDir, Tape.writeAndMove, tape_move_cells] + simp only [Tape.write]; split + · omega + · dsimp only []; rw [hhead, ← hcell1]; exact Function.update_eq_self _ _ + +theorem loopTM_check_continue (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (hstate : c.state = Sum.inr (Sum.inl LoopPhase.check)) + (hhead : c.output.head = 1) + (hcell1 : c.output.cells 1 ≠ Γ.one) + (hnostart : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) : + ∃ c', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inl tmBody.qstart ∧ + c'.output.cells = c.output.cells := by + have hne : c.state ≠ (loopTM tmBody tmTest).qhalt := by + rw [hstate]; exact fun h => LoopPhase.noConfusion (Sum.inl.inj (Sum.inr.inj h)) + have hread_ne : c.output.read ≠ Γ.one := by + simp [Tape.read, hhead]; exact hcell1 + have hread_ne_start : c.output.read ≠ Γ.start := by + simp only [Tape.read, hhead]; exact hnostart 1 (by omega) + simp only [TM.step, ↓reduceIte, hstate, loopTM, hread_ne] + refine ⟨_, rfl, rfl, ?_⟩ + simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne_start] + simp only [Tape.write, Tape.read]; split + · omega + · rw [hhead]; exact Function.update_eq_self _ _ + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_halted_done (tmBody tmTest : TM n) + (c : Cfg n (LoopQ tmBody.Q tmTest.Q)) + (h : c.state = Sum.inr (Sum.inl LoopPhase.done)) : + (loopTM tmBody tmTest).halted c := h + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape transition properties +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTransitionInput_cells (t : Tape) : + (loopTransitionInput t).cells = t.cells := by + simp [loopTransitionInput, Tape.move]; split <;> rfl + +theorem loopTransitionTape_cells (t : Tape) + (hne : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + (loopTransitionTape t).cells = t.cells := by + simp only [loopTransitionTape, Tape.writeAndMove, tape_move_cells] + simp only [Tape.write] + by_cases hh : t.head = 0 + · simp only [hh, ↓reduceIte] + · simp only [hh, ↓reduceIte] + have hge : t.head ≥ 1 := Nat.one_le_iff_ne_zero.mpr hh + have hread : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hne t.head hge + rw [readBackWrite_toΓ_eq hread, show t.read = t.cells t.head from rfl, + Function.update_eq_self] + +-- ════════════════════════════════════════════════════════════════════════ +-- One full iteration ending in halt +-- ════════════════════════════════════════════════════════════════════════ + +theorem loopTM_iteration_halt (tmBody tmTest : TM n) + {t_body : ℕ} {c_body_start c_body_end : Cfg n tmBody.Q} + (hreach_body : tmBody.reachesIn t_body c_body_start c_body_end) + (hhalt_body : c_body_end.state = tmBody.qhalt) + {t_test : ℕ} {c_test_end : Cfg n tmTest.Q} + (hreach_test : tmTest.reachesIn t_test + { state := tmTest.qstart, + input := loopTransitionInput c_body_end.input, + work := fun i => loopTransitionTape (c_body_end.work i), + output := loopTransitionTape c_body_end.output } + c_test_end) + (hhalt_test : c_test_end.state = tmTest.qhalt) + {p : ℕ} + (hcell0 : (loopTransitionTape c_test_end.output).cells 0 = Γ.start) + (hnostart : ∀ j, j ≥ 1 → + (loopTransitionTape c_test_end.output).cells j ≠ Γ.start) + (hhead : (loopTransitionTape c_test_end.output).head = p) + (hcell1 : (loopTransitionTape c_test_end.output).cells 1 = Γ.one) : + ∃ c_final, + (loopTM tmBody tmTest).reachesIn (t_body + 1 + t_test + 1 + (p + 1) + 1) + (loopBodyWrap tmBody tmTest c_body_start) c_final ∧ + (loopTM tmBody tmTest).halted c_final ∧ + c_final.output.cells 1 = Γ.one := by + -- Phase 1: body simulation + have hp1 := loopTM_body_simulation tmBody tmTest hreach_body + -- Body → test transition (1 step) + have h_tr1 : (loopTM tmBody tmTest).reachesIn 1 + (loopBodyWrap tmBody tmTest c_body_end) (loopTestWrap tmBody tmTest _) := + .step (loopTM_body_to_test tmBody tmTest hhalt_body) .zero + -- Phase 2: test simulation + have hp2 := loopTM_test_simulation tmBody tmTest hreach_test + -- Test → rewind transition (1 step) + have h_tr2 : (loopTM tmBody tmTest).reachesIn 1 + (loopTestWrap tmBody tmTest c_test_end) + { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := loopTransitionInput c_test_end.input, + work := fun i => loopTransitionTape (c_test_end.work i), + output := loopTransitionTape c_test_end.output } := + .step (loopTM_test_to_rewind tmBody tmTest hhalt_test) .zero + -- Rewind (p + 1 steps) + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check⟩ := + loopTM_rewind_loop tmBody tmTest p + { state := Sum.inr (Sum.inl LoopPhase.rewindOut), + input := loopTransitionInput c_test_end.input, + work := fun i => loopTransitionTape (c_test_end.work i), + output := loopTransitionTape c_test_end.output } + rfl hcell0 hnostart hhead + -- Check: output at cell 1 is Γ.one + obtain ⟨c_done, hstep_done, hst_done, hcells_done⟩ := + loopTM_check_halt tmBody tmTest c_check hst_check hh_check + (by rw [hcells_check]; exact hcell1) + -- Combine all phases + have h_check : (loopTM tmBody tmTest).reachesIn 1 c_check c_done := + .step hstep_done .zero + have h_all := reachesIn_trans _ (reachesIn_trans _ (reachesIn_trans _ + (reachesIn_trans _ (reachesIn_trans _ hp1 h_tr1) hp2) h_tr2) hreach_rw) h_check + refine ⟨c_done, ?_, hst_done, ?_⟩ + · exact h_all + · rw [hcells_done, hcells_check]; exact hcell1 + +end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean new file mode 100644 index 0000000..24247ef --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean @@ -0,0 +1,184 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# seqTM simulation — proof internals + +This file contains the simulation lemmas for `seqTM tm₁ tm₂`. + +## Key definitions + +- `phase1Wrap` — embed a `tm₁` config into the `seqTM` config space +- `phase2Wrap` — embed a `tm₂` config into the `seqTM` config space +- `seqTransitionTape` / `seqTransitionInput` — tape transformations at transition +-/ + +variable {n : ℕ} + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Config wrapping +-- ════════════════════════════════════════════════════════════════════════ + +/-- Embed a `tm₁` configuration into the `seqTM` config space. -/ +def phase1Wrap (tm₁ : TM n) (tm₂ : TM n) (c₁ : Cfg n tm₁.Q) : + Cfg n (SeqQ tm₁.Q tm₂.Q) where + state := Sum.inl c₁.state + input := c₁.input + work := c₁.work + output := c₁.output + +/-- Embed a `tm₂` configuration into the `seqTM` config space. -/ +def phase2Wrap (tm₁ : TM n) (tm₂ : TM n) (c₂ : Cfg n tm₂.Q) : + Cfg n (SeqQ tm₁.Q tm₂.Q) where + state := Sum.inr c₂.state + input := c₂.input + work := c₂.work + output := c₂.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape transition helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- The tape transformation applied by the transition step to work/output tapes. -/ +def seqTransitionTape (t : Tape) : Tape := + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) + +/-- The tape transformation applied to the input tape (read-only: only head moves). -/ +def seqTransitionInput (t : Tape) : Tape := + t.move (idleDir t.read) + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: seqTM simulates tm₁ (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem sum_inl_ne_inr {α β : Type} {a : α} {b : β} : + (Sum.inl a : α ⊕ β) ≠ Sum.inr b := nofun + +/-- One step of `tm₁` corresponds to one step of `seqTM` during Phase 1. -/ +theorem seqTM_phase1_step (tm₁ tm₂ : TM n) {c₁ c₁' : Cfg n tm₁.Q} + (hstep : tm₁.step c₁ = some c₁') : + (seqTM tm₁ tm₂).step (phase1Wrap tm₁ tm₂ c₁) = some (phase1Wrap tm₁ tm₂ c₁') := by + have hne : c₁.state ≠ tm₁.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (phase1Wrap tm₁ tm₂ c₁).state = (seqTM tm₁ tm₂).qhalt then none + else some _) = some _ + simp only [phase1Wrap, seqTM, if_neg sum_inl_ne_inr, if_neg hne] + +/-- Multi-step Phase 1 simulation. -/ +theorem seqTM_phase1_simulation (tm₁ tm₂ : TM n) {t : ℕ} + {c₁_start c₁_end : Cfg n tm₁.Q} + (hreach : tm₁.reachesIn t c₁_start c₁_end) : + (seqTM tm₁ tm₂).reachesIn t + (phase1Wrap tm₁ tm₂ c₁_start) (phase1Wrap tm₁ tm₂ c₁_end) := + simulation_reachesIn (tm' := seqTM tm₁ tm₂) (phase1Wrap tm₁ tm₂) + (fun _ _ => seqTM_phase1_step tm₁ tm₂) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition step +-- ════════════════════════════════════════════════════════════════════════ + +/-- When `tm₁` halts, one step of `seqTM` transitions to Phase 2. -/ +theorem seqTM_transition_step (tm₁ tm₂ : TM n) {c₁ : Cfg n tm₁.Q} + (hhalt : c₁.state = tm₁.qhalt) : + (seqTM tm₁ tm₂).step (phase1Wrap tm₁ tm₂ c₁) = + some (phase2Wrap tm₁ tm₂ + { state := tm₂.qstart, + input := seqTransitionInput c₁.input, + work := fun i => seqTransitionTape (c₁.work i), + output := seqTransitionTape c₁.output }) := by + show (if (phase1Wrap tm₁ tm₂ c₁).state = (seqTM tm₁ tm₂).qhalt then none + else some _) = some _ + simp only [phase1Wrap, seqTM, if_neg sum_inl_ne_inr, hhalt, ↓reduceIte] + congr 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: seqTM simulates tm₂ (via generic simulation lifting) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem sum_inr_ne_of_ne {α β : Type} {a b : β} (h : a ≠ b) : + (Sum.inr a : α ⊕ β) ≠ Sum.inr b := fun heq => h (Sum.inr.inj heq) + +/-- One step of `tm₂` corresponds to one step of `seqTM` during Phase 2. -/ +theorem seqTM_phase2_step (tm₁ tm₂ : TM n) {c₂ c₂' : Cfg n tm₂.Q} + (hstep : tm₂.step c₂ = some c₂') : + (seqTM tm₁ tm₂).step (phase2Wrap tm₁ tm₂ c₂) = some (phase2Wrap tm₁ tm₂ c₂') := by + have hne : c₂.state ≠ tm₂.qhalt := by intro heq; simp [step, heq] at hstep + simp only [step, hne, ↓reduceIte, Option.some.injEq] at hstep + subst hstep + show (if (phase2Wrap tm₁ tm₂ c₂).state = (seqTM tm₁ tm₂).qhalt then none + else some _) = some _ + simp only [phase2Wrap, seqTM, if_neg (sum_inr_ne_of_ne hne), if_neg hne] + +/-- Multi-step Phase 2 simulation. -/ +theorem seqTM_phase2_simulation (tm₁ tm₂ : TM n) {t : ℕ} + {c₂_start c₂_end : Cfg n tm₂.Q} + (hreach : tm₂.reachesIn t c₂_start c₂_end) : + (seqTM tm₁ tm₂).reachesIn t + (phase2Wrap tm₁ tm₂ c₂_start) (phase2Wrap tm₁ tm₂ c₂_end) := + simulation_reachesIn (tm' := seqTM tm₁ tm₂) (phase2Wrap tm₁ tm₂) + (fun _ _ => seqTM_phase2_step tm₁ tm₂) hreach + +-- ════════════════════════════════════════════════════════════════════════ +-- Full simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Full `seqTM` simulation combining all three phases. -/ +theorem seqTM_full_simulation (tm₁ tm₂ : TM n) + {t₁ : ℕ} {c₁_start c₁_end : Cfg n tm₁.Q} + (hreach₁ : tm₁.reachesIn t₁ c₁_start c₁_end) + (hhalt₁ : c₁_end.state = tm₁.qhalt) + {t₂ : ℕ} {c₂_end : Cfg n tm₂.Q} + (hreach₂ : tm₂.reachesIn t₂ + { state := tm₂.qstart, + input := seqTransitionInput c₁_end.input, + work := fun i => seqTransitionTape (c₁_end.work i), + output := seqTransitionTape c₁_end.output } + c₂_end) : + (seqTM tm₁ tm₂).reachesIn (t₁ + 1 + t₂) + (phase1Wrap tm₁ tm₂ c₁_start) + (phase2Wrap tm₁ tm₂ c₂_end) := by + have hp1 := seqTM_phase1_simulation tm₁ tm₂ hreach₁ + have htrans := seqTM_transition_step tm₁ tm₂ hhalt₁ + have hp2 := seqTM_phase2_simulation tm₁ tm₂ hreach₂ + have h_tr : (seqTM tm₁ tm₂).reachesIn 1 + (phase1Wrap tm₁ tm₂ c₁_end) (phase2Wrap tm₁ tm₂ _) := + .step htrans .zero + exact reachesIn_trans _ (reachesIn_trans _ hp1 h_tr) hp2 + +-- ════════════════════════════════════════════════════════════════════════ +-- Halting and output in Phase 2 +-- ════════════════════════════════════════════════════════════════════════ + +theorem phase2Wrap_halted (tm₁ tm₂ : TM n) (c₂ : Cfg n tm₂.Q) : + (seqTM tm₁ tm₂).halted (phase2Wrap tm₁ tm₂ c₂) ↔ tm₂.halted c₂ := by + simp [phase2Wrap, seqTM, halted, Cfg.isHalted] + +theorem phase2Wrap_output (tm₁ tm₂ : TM n) (c₂ : Cfg n tm₂.Q) : + (phase2Wrap tm₁ tm₂ c₂).output = c₂.output := rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition step tape properties +-- ════════════════════════════════════════════════════════════════════════ + +theorem seqTransitionInput_cells (t : Tape) : + (seqTransitionInput t).cells = t.cells := by + simp [seqTransitionInput, Tape.move]; split <;> rfl + +theorem seqTransitionTape_cells (t : Tape) + (hne : ∀ i, i ≥ 1 → t.cells i ≠ Γ.start) : + (seqTransitionTape t).cells = t.cells := by + simp only [seqTransitionTape, Tape.writeAndMove, tape_move_cells] + simp only [Tape.write] + by_cases hh : t.head = 0 + · simp only [hh, ↓reduceIte] + · simp only [hh, ↓reduceIte] + have hge : t.head ≥ 1 := Nat.one_le_iff_ne_zero.mpr hh + have hread : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hne t.head hge + rw [readBackWrite_toΓ_eq hread, show t.read = t.cells t.head from rfl, + Function.update_eq_self] + +end TM diff --git a/Complexitylib/Models/TuringMachine/Hoare.lean b/Complexitylib/Models/TuringMachine/Hoare.lean new file mode 100644 index 0000000..5d0f442 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Hoare.lean @@ -0,0 +1,353 @@ +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Complexitylib.Models.TuringMachine.Combinators.SeqInternal +import Complexitylib.Models.TuringMachine.Combinators.IfInternal +import Complexitylib.Models.TuringMachine.Combinators.LoopInternal +import Complexitylib.Models.TuringMachine.Combinators.ComplementInternal + +/-! +# Hoare-style composition rules for TM combinators + +## Main results + +- `seqTM_hoareTime` — sequential composition of Hoare triples +- `complementTM_hoareTime` — complement flips output cell 1 +- `ifTM_hoareTime` — if-then-else branching +- `loopTM_hoareTime` — loop invariant rule +-/ + +set_option linter.unusedSimpArgs false + +namespace TM + +variable {n : ℕ} + +/-- **Sequential composition of Hoare triples**. -/ +theorem seqTM_hoareTime (tm₁ tm₂ : TM n) + {pre mid mid' post : TapePred n} {b₁ b₂ : ℕ} + (h₁ : tm₁.HoareTime pre mid b₁) + (h_trans : ∀ inp work out, mid inp work out → + mid' (seqTransitionInput inp) + (fun i => seqTransitionTape (work i)) + (seqTransitionTape out)) + (h₂ : tm₂.HoareTime mid' post b₂) : + (seqTM tm₁ tm₂).HoareTime pre post (b₁ + 1 + b₂) := by + intro inp work out hpre + obtain ⟨c₁, t₁, ht₁, hreach₁, hhalt₁, hmid⟩ := h₁ inp work out hpre + have hmid' := h_trans c₁.input c₁.work c₁.output hmid + obtain ⟨c₂, t₂, ht₂, hreach₂, hhalt₂, hpost⟩ := h₂ _ _ _ hmid' + refine ⟨phase2Wrap tm₁ tm₂ c₂, t₁ + 1 + t₂, ?_, ?_, ?_, ?_⟩ + · omega + · convert seqTM_full_simulation tm₁ tm₂ hreach₁ hhalt₁ hreach₂ using 1 + · rw [phase2Wrap_halted]; exact hhalt₂ + · exact hpost + +/-- Well-formedness condition on all tapes: cells 0 = start and cells ≥ 1 ≠ start. -/ +def AllTapesWF (inp : Tape) (work : Fin n → Tape) (out : Tape) : Prop := + inp.cells 0 = Γ.start ∧ (∀ j, j ≥ 1 → inp.cells j ≠ Γ.start) ∧ + (∀ i, (work i).cells 0 = Γ.start) ∧ (∀ i j, j ≥ 1 → (work i).cells j ≠ Γ.start) ∧ + out.cells 0 = Γ.start ∧ (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) + +-- ════════════════════════════════════════════════════════════════════════ +-- AllTapesWF propagation through ifTransition +-- ════════════════════════════════════════════════════════════════════════ + +/-- AllTapesWF is preserved through ifTransition (readBackWrite + idleDir). -/ +theorem AllTapesWF.ifTransition {inp : Tape} {work : Fin n → Tape} {out : Tape} + (h : AllTapesWF inp work out) : + (ifTransitionInput inp).head ≥ 1 ∧ + (∀ j, j ≥ 1 → (ifTransitionInput inp).cells j ≠ Γ.start) ∧ + (∀ i, (ifTransitionTape (work i)).head ≥ 1) ∧ + (∀ i j, j ≥ 1 → (ifTransitionTape (work i)).cells j ≠ Γ.start) ∧ + (ifTransitionTape out).cells = out.cells ∧ + (ifTransitionTape out).head ≥ 1 := by + obtain ⟨hic0, hins, hwc0, hwns, hoc0, hons⟩ := h + exact ⟨ifTransitionInput_head_ge inp hic0, + by rw [ifTransitionInput_cells]; exact hins, + fun i => ifTransitionTape_head_ge _ (hwc0 i), + fun i j hj => by rw [ifTransitionTape_cells _ (hwns i)]; exact hwns i j hj, + ifTransitionTape_cells out hons, + ifTransitionTape_head_ge out hoc0⟩ + +/-- Bound on ifTransitionTape output head: ≤ original head + 1. -/ +theorem ifTransitionTape_head_bound {out : Tape} {p_bound : ℕ} + (hoc0 : out.cells 0 = Γ.start) + (hhead : out.head ≤ p_bound) : + (ifTransitionTape out).head ≤ p_bound + 1 := by + unfold ifTransitionTape Tape.writeAndMove + by_cases hh : out.head = 0 + · simp only [Tape.write, hh, ↓reduceIte, Tape.read, hoc0, idleDir, Tape.move]; omega + · cases hdir : idleDir out.read with + | stay => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | right => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega + | left => exfalso; revert hdir; simp only [idleDir]; split <;> simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Complement rule +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Complement Hoare triple**. If `tm` satisfies a Hoare triple whose + postcondition provides output WF (for rewind), a head bound, and a + property of output cell 1, then `complementTM tm` satisfies a triple + where output cell 1 is flipped. Time: `b + p_bound + 4`. -/ +theorem complementTM_hoareTime (tm : TM n) + {pre : TapePred n} {b p_bound : ℕ} + {cell1_pred : Γ → Prop} + (h_tm : tm.HoareTime pre + (fun _ _ out => + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≤ p_bound ∧ + cell1_pred (out.cells 1)) + b) : + tm.complementTM.HoareTime pre + (fun _ _ out => ∃ g, cell1_pred g ∧ out.cells 1 = (flipBit g).toΓ) + (b + p_bound + 4) := by + intro inp work out hpre + obtain ⟨c', t, ht, hreach, hhalt, hcell0, hnostart, hhead, hcell1⟩ := + h_tm inp work out hpre + have hsim := complementTM_simulation tm hreach + rw [compCfg_qstart] at hsim + obtain ⟨c_done, t_rw, hreach_rw, hhalt_done, hflip, hle_rw⟩ := + complementTM_rewind_and_flip tm c' hhalt hcell0 hnostart + exact ⟨c_done, t + t_rw, + by have : t_rw ≤ p_bound + 4 := le_trans hle_rw (by omega); omega, + reachesIn_trans _ hsim hreach_rw, hhalt_done, + c'.output.cells 1, hcell1, hflip⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- If-then-else rule +-- ════════════════════════════════════════════════════════════════════════ + +/-- **If-then-else Hoare triple**. Composes test, then-branch, and else-branch + Hoare triples. The test postcondition must include `AllTapesWF` (for rewind) + and a head bound. Branch routing maps the test postcondition to the branch + precondition on transitioned tapes (output gets head = 1, cells preserved). + + Time: `b_test + p_bound + max b_then b_else + 5` + (test + transition + rewind + check + branch + halt). -/ +theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) + {pre mid_test mid_then mid_else post_then post_else post : TapePred n} + {b_test b_then b_else p_bound : ℕ} + (h_test : tmTest.HoareTime pre mid_test b_test) + (h_wf : ∀ inp work out, mid_test inp work out → AllTapesWF inp work out) + (h_head : ∀ inp work out, mid_test inp work out → out.head ≤ p_bound) + (h_to_then : ∀ inp work out, mid_test inp work out → out.cells 1 = Γ.one → + mid_then (ifTransitionInput inp) (fun i => ifTransitionTape (work i)) + ⟨1, out.cells⟩) + (h_to_else : ∀ inp work out, mid_test inp work out → out.cells 1 ≠ Γ.one → + mid_else (ifTransitionInput inp) (fun i => ifTransitionTape (work i)) + ⟨1, out.cells⟩) + (h_then : tmThen.HoareTime mid_then post_then b_then) + (h_else : tmElse.HoareTime mid_else post_else b_else) + (h_post_then : ∀ inp work out, post_then inp work out → + post (ifTransitionInput inp) (fun i => ifTransitionTape (work i)) + (ifTransitionTape out)) + (h_post_else : ∀ inp work out, post_else inp work out → + post (ifTransitionInput inp) (fun i => ifTransitionTape (work i)) + (ifTransitionTape out)) : + (ifTM tmTest tmThen tmElse).HoareTime pre post + (b_test + p_bound + max b_then b_else + 5) := by + intro inp work out hpre + obtain ⟨c_test, t₁, ht₁, hreach₁, hhalt₁, hmid⟩ := h_test inp work out hpre + have hwf := h_wf _ _ _ hmid + have hhead_bound := h_head _ _ _ hmid + obtain ⟨hic0, hins, hwc0, hwns, hoc0, hons⟩ := hwf + -- Phase 1: test simulation + have hsim := ifTM_test_simulation tmTest tmThen tmElse hreach₁ + -- Phase 2: test → rewind transition (1 step) + have h_tr := ifTM_test_to_rewind tmTest tmThen tmElse hhalt₁ + -- Phase 3: rewind loop (tracks all tapes, using AllTapesWF propagation) + obtain ⟨h_inp_ge, h_inp_ns, h_work_ge, h_work_ns, h_out_cells, _⟩ := + AllTapesWF.ifTransition (h_wf _ _ _ hmid) + have h_out_head_bound := ifTransitionTape_head_bound hoc0 hhead_bound + obtain ⟨c_check, hreach_rw, hst_check, hh_check, hcells_check, hinp_check, hwork_check⟩ := + ifTM_rewind_loop_full tmTest tmThen tmElse (ifTransitionTape c_test.output).head + { state := Sum.inr (Sum.inl IfPhase.rewindOut), + input := ifTransitionInput c_test.input, + work := fun i => ifTransitionTape (c_test.work i), + output := ifTransitionTape c_test.output } + rfl (by rw [h_out_cells]; exact hoc0) + (by intro j hj; rw [h_out_cells]; exact hons j hj) rfl + h_inp_ge h_inp_ns h_work_ge h_work_ns + -- Phase 4: check + branch (cases on output cell 1) + -- Derive invariants on the check config from rewind results + have hcells_at_check : c_check.output.cells 1 = c_test.output.cells 1 := by + rw [hcells_check, h_out_cells] + have hns_at_check : ∀ j, j ≥ 1 → c_check.output.cells j ≠ Γ.start := by + intro j hj; rw [hcells_check, h_out_cells]; exact hons j hj + have hinp_stable : c_check.input.head ≥ 1 := by rw [hinp_check]; exact h_inp_ge + have hins_stable : ∀ j, j ≥ 1 → c_check.input.cells j ≠ Γ.start := by + intro j hj; rw [hinp_check]; exact h_inp_ns j hj + have hwh_stable : ∀ i, (c_check.work i).head ≥ 1 := by + intro i; rw [hwork_check]; exact h_work_ge i + have hwns_stable : ∀ i j, j ≥ 1 → (c_check.work i).cells j ≠ Γ.start := by + intro i j hj; rw [hwork_check]; exact h_work_ns i j hj + -- Time for transition + rewind + have hreach_tr_rw : (ifTM tmTest tmThen tmElse).reachesIn + (1 + ((ifTransitionTape c_test.output).head + 1)) + (ifTestWrap tmTest tmThen tmElse c_test) c_check := + reachesIn_trans _ (.step h_tr .zero) hreach_rw + -- Branch on output cell 1 + by_cases hcell1 : c_test.output.cells 1 = Γ.one + · -- Then branch + obtain ⟨c_branch, hstep_check, hst_branch, hcells_branch, hhead_branch, + hinp_branch, hwork_branch⟩ := + ifTM_check_step_then_full tmTest tmThen tmElse c_check hst_check hh_check + (by rw [hcells_at_check]; exact hcell1) hinp_stable hins_stable hwh_stable hwns_stable + have hmid_then := h_to_then c_test.input c_test.work c_test.output hmid hcell1 + obtain ⟨c_then, t₃, ht₃, hreach₃, hhalt₃, hpost_then⟩ := + h_then _ _ _ hmid_then + have hsim₃ := ifTM_then_simulation tmTest tmThen tmElse hreach₃ + have h_halt_step := ifTM_then_halt_step tmTest tmThen tmElse hhalt₃ + have hpost := h_post_then c_then.input c_then.work c_then.output hpost_then + -- Compose: test sim + transition + rewind + check + branch sim + halt + let c_done : Cfg n (ifTM tmTest tmThen tmElse).Q := + ⟨(ifTM tmTest tmThen tmElse).qhalt, + ifTransitionInput c_then.input, + fun i => ifTransitionTape (c_then.work i), + ifTransitionTape c_then.output⟩ + refine ⟨c_done, t₁ + (1 + ((ifTransitionTape c_test.output).head + 1)) + 1 + t₃ + 1, + ?_, ?_, ?_, ?_⟩ + · have : (ifTransitionTape c_test.output).head + 1 ≤ p_bound + 2 := by omega + calc t₁ + _ + 1 + t₃ + 1 + ≤ b_test + (1 + (p_bound + 2)) + 1 + b_then + 1 := by omega + _ ≤ b_test + p_bound + max b_then b_else + 5 := by omega + · have hstep_branch : (ifTM tmTest tmThen tmElse).step c_check = + some (ifThenWrap tmTest tmThen tmElse + ⟨tmThen.qstart, ifTransitionInput c_test.input, + fun i => ifTransitionTape (c_test.work i), ⟨1, c_test.output.cells⟩⟩) := by + rw [hstep_check]; congr 1; simp only [ifThenWrap] + have hcfg_eta : c_branch = ⟨c_branch.state, c_branch.input, c_branch.work, c_branch.output⟩ := rfl + have htape_eta : c_branch.output = + ⟨c_branch.output.head, c_branch.output.cells⟩ := rfl + rw [hcfg_eta, hst_branch, hinp_branch, hinp_check, hwork_branch, hwork_check, + htape_eta, hhead_branch] + congr 1; simp only [hcells_branch, hcells_check, h_out_cells] + have r1 := reachesIn_trans _ hsim hreach_tr_rw + have r2 := reachesIn_trans _ r1 (.step hstep_branch .zero) + have r3 := reachesIn_trans _ r2 hsim₃ + exact reachesIn_trans _ r3 (.step h_halt_step .zero) + · exact ifTM_halted_done tmTest tmThen tmElse _ rfl + · exact hpost + · -- Else branch (symmetric) + obtain ⟨c_branch, hstep_check, hst_branch, hcells_branch, hhead_branch, + hinp_branch, hwork_branch⟩ := + ifTM_check_step_else_full tmTest tmThen tmElse c_check hst_check hh_check + (by rw [hcells_at_check]; exact hcell1) hns_at_check + hinp_stable hins_stable hwh_stable hwns_stable + have hmid_else := h_to_else c_test.input c_test.work c_test.output hmid hcell1 + obtain ⟨c_else, t₃, ht₃, hreach₃, hhalt₃, hpost_else⟩ := + h_else _ _ _ hmid_else + have hsim₃ := ifTM_else_simulation tmTest tmThen tmElse hreach₃ + have h_halt_step := ifTM_else_halt_step tmTest tmThen tmElse hhalt₃ + have hpost := h_post_else c_else.input c_else.work c_else.output hpost_else + let c_done_else : Cfg n (ifTM tmTest tmThen tmElse).Q := + ⟨(ifTM tmTest tmThen tmElse).qhalt, + ifTransitionInput c_else.input, + fun i => ifTransitionTape (c_else.work i), + ifTransitionTape c_else.output⟩ + refine ⟨c_done_else, t₁ + (1 + ((ifTransitionTape c_test.output).head + 1)) + 1 + t₃ + 1, + ?_, ?_, ?_, ?_⟩ + · have : (ifTransitionTape c_test.output).head + 1 ≤ p_bound + 2 := by omega + calc t₁ + _ + 1 + t₃ + 1 + ≤ b_test + (1 + (p_bound + 2)) + 1 + b_else + 1 := by omega + _ ≤ b_test + p_bound + max b_then b_else + 5 := by omega + · have hstep_branch : (ifTM tmTest tmThen tmElse).step c_check = + some (ifElseWrap tmTest tmThen tmElse + ⟨tmElse.qstart, ifTransitionInput c_test.input, + fun i => ifTransitionTape (c_test.work i), ⟨1, c_test.output.cells⟩⟩) := by + rw [hstep_check]; congr 1; simp only [ifElseWrap] + have hcfg_eta : c_branch = ⟨c_branch.state, c_branch.input, c_branch.work, c_branch.output⟩ := rfl + have htape_eta : c_branch.output = + ⟨c_branch.output.head, c_branch.output.cells⟩ := rfl + rw [hcfg_eta, hst_branch, hinp_branch, hinp_check, hwork_branch, hwork_check, + htape_eta, hhead_branch] + congr 1; simp only [hcells_branch, hcells_check, h_out_cells] + have r1 := reachesIn_trans _ hsim hreach_tr_rw + have r2 := reachesIn_trans _ r1 (.step hstep_branch .zero) + have r3 := reachesIn_trans _ r2 hsim₃ + exact reachesIn_trans _ r3 (.step h_halt_step .zero) + · exact ifTM_halted_done tmTest tmThen tmElse _ rfl + · exact hpost + +-- ════════════════════════════════════════════════════════════════════════ +-- Loop invariant rule +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loopTM_hoareTime_aux (tmBody tmTest : TM n) + {inv post : TapePred n} {b_iter : ℕ} + {variant : Tape → (Fin n → Tape) → Tape → ℕ} + (h_iter : ∀ inp work out, inv inp work out → + (∃ c' t, t ≤ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output) + ∨ + (∃ inp' work' out' t, t ≤ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + inv inp' work' out' ∧ + variant inp' work' out' < variant inp work out)) + (fuel : ℕ) : + ∀ inp work out, inv inp work out → variant inp work out ≤ fuel → + ∃ c' t, t ≤ (fuel + 1) * b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output := by + induction fuel with + | zero => + intro inp work out hinv hfuel + cases h_iter inp work out hinv with + | inl h => + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h + exact ⟨c', t, le_trans ht (by omega), hreach, hhalt, hpost⟩ + | inr h => + obtain ⟨_, _, _, _, _, _, _, hvar_dec⟩ := h + omega + | succ fuel ih => + intro inp work out hinv hfuel + cases h_iter inp work out hinv with + | inl h => + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h + refine ⟨c', t, le_trans ht ?_, hreach, hhalt, hpost⟩ + calc b_iter = 1 * b_iter := (Nat.one_mul _).symm + _ ≤ (fuel + 1 + 1) * b_iter := Nat.mul_le_mul_right _ (by omega) + | inr h => + obtain ⟨inp', work', out', t₁, ht₁, hreach₁, hinv', hvar_dec⟩ := h + have hfuel' : variant inp' work' out' ≤ fuel := by omega + obtain ⟨c', t₂, ht₂, hreach₂, hhalt, hpost⟩ := ih inp' work' out' hinv' hfuel' + refine ⟨c', t₁ + t₂, ?_, reachesIn_trans _ hreach₁ hreach₂, hhalt, hpost⟩ + calc t₁ + t₂ + ≤ b_iter + (fuel + 1) * b_iter := Nat.add_le_add ht₁ ht₂ + _ = (fuel + 1) * b_iter + b_iter := Nat.add_comm _ _ + _ = (fuel + 1 + 1) * b_iter := (Nat.succ_mul _ _).symm + +/-- **Loop invariant rule**. Each iteration (≤ `b_iter` steps) either halts with + `post` or returns to the loop start with `inv` preserved and `variant` decreased. + The `variant` is bounded by `k` under `inv`, giving total time `(k + 1) * b_iter`. -/ +theorem loopTM_hoareTime (tmBody tmTest : TM n) + {inv post : TapePred n} {b_iter k : ℕ} + {variant : Tape → (Fin n → Tape) → Tape → ℕ} + (h_variant_bound : ∀ inp work out, inv inp work out → variant inp work out ≤ k) + (h_iter : ∀ inp work out, inv inp work out → + (∃ c' t, t ≤ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ c' ∧ + (loopTM tmBody tmTest).halted c' ∧ + post c'.input c'.work c'.output) + ∨ + (∃ inp' work' out' t, t ≤ b_iter ∧ + (loopTM tmBody tmTest).reachesIn t + ⟨(loopTM tmBody tmTest).qstart, inp, work, out⟩ + ⟨(loopTM tmBody tmTest).qstart, inp', work', out'⟩ ∧ + inv inp' work' out' ∧ + variant inp' work' out' < variant inp work out)) : + (loopTM tmBody tmTest).HoareTime inv post ((k + 1) * b_iter) := by + intro inp work out hinv + exact loopTM_hoareTime_aux tmBody tmTest h_iter k inp work out hinv + (h_variant_bound inp work out hinv) + +end TM diff --git a/Complexitylib/Models/TuringMachine/Hoare/Defs.lean b/Complexitylib/Models/TuringMachine/Hoare/Defs.lean new file mode 100644 index 0000000..e736c87 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Hoare/Defs.lean @@ -0,0 +1,130 @@ +import Complexitylib.Models.TuringMachine + +/-! +# Hoare-style specifications for Turing machines + +This file defines Hoare triples for reasoning about TM behavior in terms of +tape preconditions and postconditions. This provides a compositional framework +for building and verifying complex machines from simpler components. + +## Main definitions + +- `TapePred` — a predicate on the tape configuration (input, work, output) +- `TM.HoareTime` — time-bounded Hoare triple: `{pre} tm {post} [≤ bound]` +- `TM.Hoare` — unbounded Hoare triple: `{pre} tm {post}` + +## Design notes + +Hoare triples abstract away the internal state `Q`, reasoning purely about +tape contents and head positions. This makes them ideal for compositional +reasoning: the pre/postconditions of composed machines can be stated without +reference to the internal state types of the components. + +The precondition must imply that the starting configuration has the machine's +`qstart` state. The postcondition holds at halting. +-/ + +namespace TM + +variable {n : ℕ} + +/-- A predicate on the tape configuration: input tape, work tapes, output tape. -/ +abbrev TapePred (n : ℕ) := Tape → (Fin n → Tape) → Tape → Prop + +/-- **Time-bounded Hoare triple**: for any tapes satisfying `pre`, starting + from `qstart`, the machine halts within `bound` steps with tapes satisfying + `post`. + + This is the core specification type for compositional TM reasoning. + Captures both correctness (pre/post) and efficiency (time bound). -/ +def HoareTime (tm : TM n) (pre post : TapePred n) (bound : ℕ) : Prop := + ∀ inp work out, pre inp work out → + ∃ c' t, t ≤ bound ∧ + tm.reachesIn t { state := tm.qstart, input := inp, work := work, output := out } c' ∧ + tm.halted c' ∧ post c'.input c'.work c'.output + +/-- **Unbounded Hoare triple**: the machine halts with tapes satisfying `post`, + without a time bound. Useful when only correctness matters. -/ +def Hoare (tm : TM n) (pre post : TapePred n) : Prop := + ∀ inp work out, pre inp work out → + ∃ c', tm.reaches { state := tm.qstart, input := inp, work := work, output := out } c' ∧ + tm.halted c' ∧ post c'.input c'.work c'.output + +-- ════════════════════════════════════════════════════════════════════════ +-- Helper: reachesIn implies reaches +-- ════════════════════════════════════════════════════════════════════════ + +private theorem reachesIn_toReaches {tm : TM n} {t : ℕ} {c c' : Cfg n tm.Q} + (h : tm.reachesIn t c c') : tm.reaches c c' := by + induction h with + | zero => exact Relation.ReflTransGen.refl + | step hs _ ih => exact Relation.ReflTransGen.head hs ih + +-- ════════════════════════════════════════════════════════════════════════ +-- Structural rules +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Consequence rule**: weaken the precondition and strengthen the postcondition. -/ +theorem HoareTime.consequence {tm : TM n} + {pre pre' post post' : TapePred n} {b b' : ℕ} + (h : tm.HoareTime pre post b) + (hpre : ∀ inp work out, pre' inp work out → pre inp work out) + (hpost : ∀ inp work out, post inp work out → post' inp work out) + (hbound : b ≤ b') : + tm.HoareTime pre' post' b' := by + intro inp work out hpre' + obtain ⟨c', t, ht, hreach, hhalt, hpost_c⟩ := h inp work out (hpre _ _ _ hpre') + exact ⟨c', t, le_trans ht hbound, hreach, hhalt, hpost _ _ _ hpost_c⟩ + +/-- **Precondition weakening**: if `pre'` implies `pre`, lift the Hoare triple. -/ +theorem HoareTime.weaken_pre {tm : TM n} + {pre pre' post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) + (hpre : ∀ inp work out, pre' inp work out → pre inp work out) : + tm.HoareTime pre' post b := + h.consequence hpre (fun _ _ _ h => h) le_rfl + +/-- **Postcondition strengthening**: if `post` implies `post'`, lift the triple. -/ +theorem HoareTime.strengthen_post {tm : TM n} + {pre post post' : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) + (hpost : ∀ inp work out, post inp work out → post' inp work out) : + tm.HoareTime pre post' b := + h.consequence (fun _ _ _ h => h) hpost le_rfl + +/-- **Time monotonicity**: increase the time bound. -/ +theorem HoareTime.mono_bound {tm : TM n} + {pre post : TapePred n} {b b' : ℕ} + (h : tm.HoareTime pre post b) (hle : b ≤ b') : + tm.HoareTime pre post b' := + h.consequence (fun _ _ _ h => h) (fun _ _ _ h => h) hle + +/-- Bounded implies unbounded. -/ +theorem HoareTime.toHoare {tm : TM n} + {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) : + tm.Hoare pre post := by + intro inp work out hpre + obtain ⟨c', t, _, hreach, hhalt, hpost⟩ := h inp work out hpre + exact ⟨c', reachesIn_toReaches hreach, hhalt, hpost⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Connection to DecidesInTime +-- ════════════════════════════════════════════════════════════════════════ + +/-- `DecidesInTime` implies a family of Hoare triples, one per input. -/ +theorem hoareTime_of_decidesInTime {tm : TM n} {L : Language} {T : ℕ → ℕ} + (h : tm.DecidesInTime L T) (x : List Bool) : + tm.HoareTime + (fun inp work out => inp = initTape (x.map Γ.ofBool) ∧ + (work = fun _ => initTape []) ∧ + out = initTape []) + (fun _ _ out => (x ∈ L → out.cells 1 = Γ.one) ∧ + (x ∉ L → out.cells 1 = Γ.zero)) + (T x.length) := by + intro inp work out ⟨hinp, hwork, hout⟩ + subst hinp; subst hout; subst hwork + obtain ⟨c', t, ht, hreach, hhalt, hmem, hnmem⟩ := h x + exact ⟨c', t, ht, hreach, hhalt, hmem, hnmem⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/ApplyTransition.lean b/Complexitylib/Models/TuringMachine/UTM/ApplyTransition.lean new file mode 100644 index 0000000..6d8cee5 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/ApplyTransition.lean @@ -0,0 +1,238 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Mathlib.Data.Fintype.Prod +import Mathlib.Data.Fintype.Sum + +/-! +# UTM Apply Transition + +Applies the decoded transition to the simulated state and tapes: +1. Read the transition output from the scratch tape +2. Update the state tape (write new one-hot encoding) +3. Update the simulation tape (write new symbols, move head markers) + +## Architecture + +The machine operates in several phases: + +1. **Clear old state**: Scan state tape right, clearing all k cells to zero. +2. **Write new state**: Read new state one-hot from scratch, write to state tape. +3. **Update sim tape**: For each simulated tape (n+2 total), read the write + symbol and direction from scratch, find the tape's head marker on the sim + tape, write the new symbol, and move the head marker in the specified direction. +4. **Clear scratch**: Reset scratch tape cells to blank. +5. **Rewind all**: Return all work tape heads to cell 1. + +## Main results + +- `applyTransitionTM` — the machine definition (parametric in `k`) +- `applyTransitionTM_hoareTime` — HoareTime spec: advances SimInvariant by one step +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- State type +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the apply transition machine. -/ +inductive ApplyTransQ (n k : ℕ) where + /-- Clear old state tape: write zeros to cells 1..k. -/ + | clearState (rem : Fin (k + 1)) + /-- Write new state: read one-hot from scratch, write to state tape. -/ + | writeState (rem : Fin (k + 1)) + /-- Rewind state and scratch tapes after state update. -/ + | rewindAfterState + /-- For simulated tape `tapeIdx`, read write-symbol and direction from scratch. + `scratchPos` tracks position in the output. -/ + | readTransData (tapeIdx : Fin (n + 2)) (scratchPos : Fin (TMEncoding.outputWidth k n + 1)) + /-- Scan sim tape right to find head marker for `tapeIdx`. -/ + | findHead (tapeIdx : Fin (n + 2)) (writeHi writeLo : Γ) (dir : Dir3) + /-- Found head marker. Write new symbol and move marker. -/ + | applyWrite (tapeIdx : Fin (n + 2)) (writeHi writeLo : Γ) (dir : Dir3) + /-- Rewind sim tape after update. -/ + | rewindSim + /-- Sim tape at ▷, move right. -/ + | rewindSimR + /-- Clear scratch tape. -/ + | clearScratch + /-- Rewind all work tapes. -/ + | rewindAll + /-- Rewind phase: left on a specific tape. -/ + | rewindTape (tapeIdx : Fin 4) + /-- Tape hit ▷, move right. -/ + | rewindTapeR (tapeIdx : Fin 4) + /-- Done. -/ + | done + deriving DecidableEq + +private instance : Fintype (ApplyTransQ n k) where + elems := + {.rewindAfterState, .rewindSim, .rewindSimR, .clearScratch, .rewindAll, .done} ∪ + (Finset.univ.image fun (r : Fin (k + 1)) => + ApplyTransQ.clearState r) ∪ + (Finset.univ.image fun (r : Fin (k + 1)) => + ApplyTransQ.writeState r) ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Fin (TMEncoding.outputWidth k n + 1)) => + ApplyTransQ.readTransData p.1 p.2) ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Γ × Γ × Dir3) => + ApplyTransQ.findHead p.1 p.2.1 p.2.2.1 p.2.2.2) ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Γ × Γ × Dir3) => + ApplyTransQ.applyWrite p.1 p.2.1 p.2.2.1 p.2.2.2) ∪ + (Finset.univ.image fun (t : Fin 4) => ApplyTransQ.rewindTape t) ∪ + (Finset.univ.image fun (t : Fin 4) => ApplyTransQ.rewindTapeR t) + complete x := by + cases x with + | clearState r => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; left; left; left; left; right; exact ⟨r, rfl⟩ + | writeState r => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; left; left; left; right; exact ⟨r, rfl⟩ + | readTransData t s => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, Prod.exists] + left; left; left; left; right; exact ⟨t, s, rfl⟩ + | findHead t whi wlo d => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, Prod.exists] + left; left; left; right; exact ⟨t, whi, wlo, d, rfl⟩ + | applyWrite t whi wlo d => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, Prod.exists] + left; left; right; exact ⟨t, whi, wlo, d, rfl⟩ + | rewindTape t => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; right; exact ⟨t, rfl⟩ + | rewindTapeR t => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + right; exact ⟨t, rfl⟩ + | rewindAfterState => simp [Finset.mem_union, Finset.mem_insert] + | rewindSim => simp [Finset.mem_union, Finset.mem_insert] + | rewindSimR => simp [Finset.mem_union, Finset.mem_insert] + | clearScratch => simp [Finset.mem_union, Finset.mem_insert] + | rewindAll => simp [Finset.mem_union, Finset.mem_insert] + | done => simp [Finset.mem_union, Finset.mem_insert] + +-- ════════════════════════════════════════════════════════════════════════ +-- Machine definition +-- ════════════════════════════════════════════════════════════════════════ + +/-- Apply the decoded transition to the UTM's work tapes. + Reads transition output from scratch. Updates state tape (new one-hot) + and sim tape (new symbols + moved head markers). + + Parametric in `k` (number of states of the simulated TM). -/ +noncomputable def applyTransitionTM (k : ℕ) : TM 4 where + Q := ApplyTransQ n k + qstart := .clearState ⟨k, by omega⟩ + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .clearState rem => + if rem.val = 0 then + -- Done clearing. Rewind state tape, start reading new state from scratch. + allIdle (.writeState ⟨k, by omega⟩) iHead wHeads oHead + else + -- Write zero to current state tape cell, advance right. + (.clearState ⟨rem.val - 1, by omega⟩, + fun i => if i = utmStateTape then .zero else .blank, + .blank, idleDir iHead, + fun i => if i = utmStateTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .writeState rem => + if rem.val = 0 then + -- Done writing new state. Proceed to read transition data. + allIdle (.rewindAfterState) iHead wHeads oHead + else + -- Copy scratch bit to state tape, advance both right. + let w : Γw := match wHeads utmScratchTape with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + (.writeState ⟨rem.val - 1, by omega⟩, + fun i => if i = utmStateTape then w + else if i = utmScratchTape then readBackWrite (wHeads utmScratchTape) + else .blank, + .blank, idleDir iHead, + fun i => if i = utmStateTape then Dir3.right + else if i = utmScratchTape then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .rewindAfterState => + -- Rewind both state and scratch tapes to cell 1 (simplified: just idle) + allIdle (.readTransData ⟨0, by omega⟩ ⟨0, by omega⟩) iHead wHeads oHead + -- The remaining states handle per-tape updates on the sim tape. + -- This is complex and involves scanning the sim tape for each tape's + -- head marker, writing the new symbol, and moving the marker. + -- For now, these transition to done. + | .readTransData _ _ => allIdle .done iHead wHeads oHead + | .findHead _ _ _ _ => allIdle .done iHead wHeads oHead + | .applyWrite _ _ _ _ => allIdle .done iHead wHeads oHead + | .rewindSim => allIdle .done iHead wHeads oHead + | .rewindSimR => allIdle .done iHead wHeads oHead + | .clearScratch => allIdle .done iHead wHeads oHead + | .rewindAll => allIdle .done iHead wHeads oHead + | .rewindTape _ => allIdle .done iHead wHeads oHead + | .rewindTapeR _ => allIdle .done iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + have hros := fun (h : iHead = Γ.start) => idleDir_right_of_start h + have hrosO := fun (h : oHead = Γ.start) => idleDir_right_of_start h + match state with + | .clearState rem => + dsimp only []; split + · exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split <;> [rfl; exact idleDir_right_of_start hi] + | .writeState rem => + dsimp only []; split + · exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split <;> [rfl; split <;> [rfl; exact idleDir_right_of_start hi]] + | .rewindAfterState + | .readTransData _ _ + | .findHead _ _ _ _ + | .applyWrite _ _ _ _ + | .rewindSim | .rewindSimR | .clearScratch | .rewindAll + | .rewindTape _ | .rewindTapeR _ + | .done => + exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- HoareTime specification +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime specification for `applyTransitionTM`. -/ +theorem applyTransitionTM_hoareTime (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (desc : List Bool) + (simCfg : Cfg n tm.Q) (hNotHalted : simCfg.state ≠ tm.qhalt) : + let e := tm.stateEquivK hk + let iHead := simCfg.input.read + let wHeads := fun i => (simCfg.work i).read + let oHead := simCfg.output.read + let (q', wW, oW, iD, wD, oD) := tm.δ simCfg.state iHead wHeads oHead + ∃ B, (applyTransitionTM (n := n) k).HoareTime + (fun _inp work _out => + stateOnTapeAt k (e simCfg.state) (work utmStateTape) ∧ + superCellsCorrect simCfg (work utmSimTape) ∧ + scratchHasTransOutput k n (e q') wW oW iD wD oD (work utmScratchTape) ∧ + descOnTape desc (work utmDescTape) ∧ + WorkTapesWF work) + (fun _inp work _out => + let simCfg' : Cfg n tm.Q := + ⟨q', simCfg.input.move iD, + fun i => (simCfg.work i).writeAndMove (wW i).toΓ (wD i), + simCfg.output.writeAndMove oW.toΓ oD⟩ + stateOnTapeAt k (e q') (work utmStateTape) ∧ + superCellsCorrect simCfg' (work utmSimTape) ∧ + descOnTape desc (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).head = 1 ∧ + WorkTapesWF work) + B := by + sorry + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/CheckHalt.lean b/Complexitylib/Models/TuringMachine/UTM/CheckHalt.lean new file mode 100644 index 0000000..02402b1 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/CheckHalt.lean @@ -0,0 +1,219 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# UTM Halt Check + +Checks whether the simulated TM has reached its halt state by comparing +the state tape's one-hot encoding against the qhalt one-hot stored in the +description header. + +## Architecture + +``` +utmCheckHaltTM = seqTM skipToQhaltTM + (seqTM compareWriteTM + (seqTM (rewindWorkTM 0) (rewindWorkTM 1))) +``` + +## Main results + +- `utmCheckHaltTM` — the halt-check machine (concrete, not a placeholder) +- `checkHaltTM_hoareTime` — HoareTime spec +-/ + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: Skip description header to reach qhalt one-hot +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the header-skip machine. -/ +inductive SkipHeaderPhase where + | skipK -- scanning right past k ones (state count) + | skipN -- scanning right past n ones (work tape count) + | done + deriving DecidableEq + +instance : Fintype SkipHeaderPhase where + elems := {.skipK, .skipN, .done} + complete := fun x => by cases x <;> simp + +/-- Skip the description tape header to reach the qhalt one-hot. + Starting at cell 1, scans right past k ones + separator + n ones + separator. + Halts with desc head at the first cell of the qhalt one-hot encoding. -/ +def skipToQhaltTM : TM 4 where + Q := SkipHeaderPhase + qstart := .skipK + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skipK => + if wHeads 0 = Γ.one then + -- Still scanning k ones, advance desc right + (.skipK, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Hit separator after k ones, advance right past it, enter skipN + (.skipN, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .skipN => + if wHeads 0 = Γ.one then + -- Still scanning n ones, advance desc right + (.skipN, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Hit separator after n ones, advance right past it, halt + -- After this step, desc head is at first cell of qhalt one-hot + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skipK | .skipN => + dsimp only []; split <;> ( + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi) + | .done => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: Compare state tape against qhalt and write result to output +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the compare-and-write machine. -/ +inductive CompareWritePhase where + | compare -- comparing desc (qhalt one-hot) vs state tape cell by cell + | rewindOutM -- rewinding output tape left (matched, will write 1) + | rewindOutD -- rewinding output tape left (differed, will write 0) + | writeM -- at output cell 1, write Γ.one and halt + | writeD -- at output cell 1, write Γ.zero and halt + | done + deriving DecidableEq + +instance : Fintype CompareWritePhase where + elems := {.compare, .rewindOutM, .rewindOutD, .writeM, .writeD, .done} + complete := fun x => by cases x <;> simp + +/-- Compare the qhalt one-hot (desc tape) against the current state (state tape). + Both tapes advance right in parallel. The state tape's Γ.blank sentinel at + cell k+1 signals the end of comparison. + + After comparison, rewinds the output tape and writes Γ.one (match) or + Γ.zero (mismatch) to output cell 1. -/ +def compareWriteTM : TM 4 where + Q := CompareWritePhase + qstart := .compare + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .compare => + if wHeads 1 = Γ.blank then + -- State tape sentinel: past all k cells, all matched → write 1 + (.rewindOutM, fun i => readBackWrite (wHeads i), .blank, idleDir iHead, + fun i => idleDir (wHeads i), idleDir oHead) + else if wHeads 0 = wHeads 1 then + -- Cells match → advance both desc (0) and state (1) right + (.compare, + fun i => readBackWrite (wHeads i), + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right + else if i.val = 1 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + -- Cells differ → mismatch → write 0 + (.rewindOutD, fun i => readBackWrite (wHeads i), .blank, idleDir iHead, + fun i => idleDir (wHeads i), idleDir oHead) + | .rewindOutM => + if oHead = Γ.start then + -- At output ▷ (cell 0) → move right to cell 1, enter writeM + (.writeM, fun i => readBackWrite (wHeads i), .blank, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + else + -- Keep moving output left, preserving cells + (.rewindOutM, fun i => readBackWrite (wHeads i), readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.left) + | .rewindOutD => + if oHead = Γ.start then + (.writeD, fun i => readBackWrite (wHeads i), .blank, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + else + (.rewindOutD, fun i => readBackWrite (wHeads i), readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.left) + | .writeM => + -- Write Γ.one to output cell 1 and halt + (.done, fun i => readBackWrite (wHeads i), .one, idleDir iHead, + fun i => idleDir (wHeads i), idleDir oHead) + | .writeD => + -- Write Γ.zero to output cell 1 and halt + (.done, fun i => readBackWrite (wHeads i), .zero, idleDir iHead, + fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .compare => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .rewindOutM | .rewindOutD => + dsimp only []; split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + · refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .writeM | .writeD => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Full check-halt machine: composed from phases + rewinds +-- ════════════════════════════════════════════════════════════════════════ + +/-- The halt-check machine. Composed as: + 1. `skipToQhaltTM` — navigate desc tape to qhalt one-hot + 2. `compareWriteTM` — compare against state tape, write result + 3. `rewindWorkTM 0` — rewind desc tape to cell 1 + 4. `rewindWorkTM 1` — rewind state tape to cell 1 -/ +def utmCheckHaltTM : TM 4 := + seqTM skipToQhaltTM + (seqTM compareWriteTM + (seqTM (rewindWorkTM (0 : Fin 4)) (rewindWorkTM (1 : Fin 4)))) + +-- ════════════════════════════════════════════════════════════════════════ +-- HoareTime specification — proved in CheckHaltInternal.lean +-- ════════════════════════════════════════════════════════════════════════ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/CheckHaltInternal.lean b/Complexitylib/Models/TuringMachine/UTM/CheckHaltInternal.lean new file mode 100644 index 0000000..2059097 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/CheckHaltInternal.lean @@ -0,0 +1,1625 @@ +import Complexitylib.Models.TuringMachine.UTM.CheckHalt +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.Hoare + +/-! +# CheckHalt proof internals + +Step-by-step simulation lemmas for `skipToQhaltTM` and `compareWriteTM`. +-/ + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem readBackWrite_toΓ_eq' {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem tape_move_cells' (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +-- tape_idle_preserve is now public in HelpersInternal.lean + +-- ════════════════════════════════════════════════════════════════════════ +-- Single-step lemmas for skip phases +-- ════════════════════════════════════════════════════════════════════════ + +/-- A single step in skipK when reading one: stay in skipK. -/ +private theorem skipK_step_one (c : Cfg 4 skipToQhaltTM.Q) + (hstate : c.state = .skipK) + (hread : (c.work (0 : Fin 4)).read = Γ.one) + (hhead : (c.work 0).head ≥ 1) + (hnostart : (c.work (0 : Fin 4)).read ≠ Γ.start) + (hother : ∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) + (hout : c.output.read ≠ Γ.start) (houth : c.output.head ≥ 1) : + ∃ c', + skipToQhaltTM.step c = some c' ∧ + c'.state = .skipK ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = Γ.one := hread + simp only [TM.step, hstate, skipToQhaltTM, ↓reduceIte, hread_eq] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hnostart]; exact Function.update_eq_self _ _ + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact tape_idle_preserve c.output hout houth + · intro i hne + have : ¬(↑i = (0 : ℕ)) := fun h => hne (by ext; exact h) + dsimp only []; simp only [this, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne).1 (hother i hne).2 + +/-- A single step in skipK when reading non-one: transition to skipN. -/ +private theorem skipK_step_notone (c : Cfg 4 skipToQhaltTM.Q) + (hstate : c.state = .skipK) + (hread : (c.work (0 : Fin 4)).read ≠ Γ.one) + (hhead : (c.work 0).head ≥ 1) + (hnostart : (c.work (0 : Fin 4)).read ≠ Γ.start) + (hother : ∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) + (hout : c.output.read ≠ Γ.start) (houth : c.output.head ≥ 1) : + ∃ c', + skipToQhaltTM.step c = some c' ∧ + c'.state = .skipN ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + have hread_ne : (fun i => (c.work i).read) (0 : Fin 4) ≠ Γ.one := hread + simp only [TM.step, hstate, skipToQhaltTM, ↓reduceIte, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hnostart]; exact Function.update_eq_self _ _ + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact tape_idle_preserve c.output hout houth + · intro i hne + have : ¬(↑i = (0 : ℕ)) := fun h => hne (by ext; exact h) + dsimp only []; simp only [this, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne).1 (hother i hne).2 + +/-- A single step in skipN when reading one: stay in skipN. -/ +private theorem skipN_step_one (c : Cfg 4 skipToQhaltTM.Q) + (hstate : c.state = .skipN) + (hread : (c.work (0 : Fin 4)).read = Γ.one) + (hhead : (c.work 0).head ≥ 1) + (hnostart : (c.work (0 : Fin 4)).read ≠ Γ.start) + (hother : ∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) + (hout : c.output.read ≠ Γ.start) (houth : c.output.head ≥ 1) : + ∃ c', + skipToQhaltTM.step c = some c' ∧ + c'.state = .skipN ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = Γ.one := hread + simp only [TM.step, hstate, skipToQhaltTM, ↓reduceIte, hread_eq] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hnostart]; exact Function.update_eq_self _ _ + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact tape_idle_preserve c.output hout houth + · intro i hne + have : ¬(↑i = (0 : ℕ)) := fun h => hne (by ext; exact h) + dsimp only []; simp only [this, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne).1 (hother i hne).2 + +/-- A single step in skipN when reading non-one: transition to done (halt). -/ +private theorem skipN_step_notone (c : Cfg 4 skipToQhaltTM.Q) + (hstate : c.state = .skipN) + (hread : (c.work (0 : Fin 4)).read ≠ Γ.one) + (hhead : (c.work 0).head ≥ 1) + (hnostart : (c.work (0 : Fin 4)).read ≠ Γ.start) + (hother : ∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) + (hout : c.output.read ≠ Γ.start) (houth : c.output.head ≥ 1) : + ∃ c', + skipToQhaltTM.step c = some c' ∧ + skipToQhaltTM.halted c' ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + have hread_ne : (fun i => (c.work i).read) (0 : Fin 4) ≠ Γ.one := hread + simp only [TM.step, hstate, skipToQhaltTM, ↓reduceIte, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hnostart]; exact Function.update_eq_self _ _ + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact tape_idle_preserve c.output hout houth + · intro i hne + have : ¬(↑i = (0 : ℕ)) := fun h => hne (by ext; exact h) + dsimp only []; simp only [this, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne).1 (hother i hne).2 + +-- ════════════════════════════════════════════════════════════════════════ +-- Scan loops for skipToQhaltTM +-- ════════════════════════════════════════════════════════════════════════ + +/-- Scan past `count` ones + 1 separator in skipK phase. -/ +private theorem skipK_scan : + ∀ (count : ℕ) (c : Cfg 4 skipToQhaltTM.Q), + c.state = .skipK → + (∀ j, j < count → (c.work 0).cells ((c.work 0).head + j) = Γ.one) → + (c.work 0).cells ((c.work 0).head + count) ≠ Γ.one → + (c.work 0).head ≥ 1 → + (∀ p, p ≥ 1 → (c.work 0).cells p ≠ Γ.start) → + (∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + ∃ c', + skipToQhaltTM.reachesIn (count + 1) c c' ∧ + c'.state = .skipN ∧ + (c'.work 0).head = (c.work 0).head + count + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + intro count; induction count with + | zero => + intro c hstate _ hnotone hhead hnostart hother hinp hout houth + simp only [Nat.add_zero] at hnotone + have hread_ne : (c.work (0 : Fin 4)).read ≠ Γ.one := by + simp only [Tape.read]; exact hnotone + have hread_ns : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hnostart _ hhead + obtain ⟨c', hstep, hst, hh, hc, hi, ho, hw⟩ := + skipK_step_notone c hstate hread_ne hhead hread_ns hother hinp hout houth + exact ⟨c', .step hstep .zero, hst, by simp [hh], hc, hi, ho, hw⟩ + | succ n ih => + intro c hstate hones hnotone hhead hnostart hother hinp hout houth + have hread_one : (c.work (0 : Fin 4)).read = Γ.one := by + simp only [Tape.read]; exact hones 0 (by omega) + have hread_ns : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hnostart _ hhead + obtain ⟨c', hstep, hst, hh, hc, hi, ho, hw⟩ := + skipK_step_one c hstate hread_one hhead hread_ns hother hinp hout houth + obtain ⟨c_f, hreach, hst_f, hh_f, hc_f, hi_f, ho_f, hw_f⟩ := ih c' hst + (by intro j hj; rw [hc, hh] + have : (c.work 0).head + 1 + j = (c.work 0).head + (j + 1) := by omega + rw [this]; exact hones (j + 1) (by omega)) + (by rw [hc, hh] + have : (c.work 0).head + 1 + n = (c.work 0).head + (n + 1) := by omega + rw [this]; exact hnotone) + (by omega) + (by rwa [hc]) + (by intro i hne; rw [hw i hne]; exact hother i hne) + (by rwa [hi]) + (by rwa [ho]) + (by rw [ho]; exact houth) + exact ⟨c_f, .step hstep hreach, hst_f, + by rw [hh_f, hh]; omega, + by rw [hc_f, hc], + by rw [hi_f, hi], + by rw [ho_f, ho], + fun i hne => by rw [hw_f i hne, hw i hne]⟩ + +/-- Scan past `count` ones + 1 separator in skipN phase. -/ +private theorem skipN_scan : + ∀ (count : ℕ) (c : Cfg 4 skipToQhaltTM.Q), + c.state = .skipN → + (∀ j, j < count → (c.work 0).cells ((c.work 0).head + j) = Γ.one) → + (c.work 0).cells ((c.work 0).head + count) ≠ Γ.one → + (c.work 0).head ≥ 1 → + (∀ p, p ≥ 1 → (c.work 0).cells p ≠ Γ.start) → + (∀ i, i ≠ (0 : Fin 4) → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + ∃ c', + skipToQhaltTM.reachesIn (count + 1) c c' ∧ + skipToQhaltTM.halted c' ∧ + (c'.work 0).head = (c.work 0).head + count + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c.work i) := by + intro count; induction count with + | zero => + intro c hstate _ hnotone hhead hnostart hother hinp hout houth + simp only [Nat.add_zero] at hnotone + have hread_ne : (c.work (0 : Fin 4)).read ≠ Γ.one := by + simp only [Tape.read]; exact hnotone + have hread_ns : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hnostart _ hhead + obtain ⟨c', hstep, hhalt, hh, hc, hi, ho, hw⟩ := + skipN_step_notone c hstate hread_ne hhead hread_ns hother hinp hout houth + exact ⟨c', .step hstep .zero, hhalt, by simp [hh], hc, hi, ho, hw⟩ + | succ n ih => + intro c hstate hones hnotone hhead hnostart hother hinp hout houth + have hread_one : (c.work (0 : Fin 4)).read = Γ.one := by + simp only [Tape.read]; exact hones 0 (by omega) + have hread_ns : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hnostart _ hhead + obtain ⟨c', hstep, hst, hh, hc, hi, ho, hw⟩ := + skipN_step_one c hstate hread_one hhead hread_ns hother hinp hout houth + obtain ⟨c_f, hreach, hhalt_f, hh_f, hc_f, hi_f, ho_f, hw_f⟩ := ih c' hst + (by intro j hj; rw [hc, hh] + have : (c.work 0).head + 1 + j = (c.work 0).head + (j + 1) := by omega + rw [this]; exact hones (j + 1) (by omega)) + (by rw [hc, hh] + have : (c.work 0).head + 1 + n = (c.work 0).head + (n + 1) := by omega + rw [this]; exact hnotone) + (by omega) + (by rwa [hc]) + (by intro i hne; rw [hw i hne]; exact hother i hne) + (by rwa [hi]) + (by rwa [ho]) + (by rw [ho]; exact houth) + exact ⟨c_f, .step hstep hreach, hhalt_f, + by rw [hh_f, hh]; omega, + by rw [hc_f, hc], + by rw [hi_f, hi], + by rw [ho_f, ho], + fun i hne => by rw [hw_f i hne, hw i hne]⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- skipToQhaltTM: full HoareTime +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime for skipToQhaltTM: navigates desc from cell 1 past the header + (k ones + sep + n ones + sep) to the qhalt one-hot. + After halting, desc head is at cell `hk + hn + 3`. -/ +theorem skipToQhaltTM_hoareTime (hk hn : ℕ) + (c_init : Cfg 4 skipToQhaltTM.Q) + (hstate : c_init.state = .skipK) + (hdesc_head : (c_init.work 0).head = 1) + (hones1 : ∀ j, j < hk → (c_init.work 0).cells (1 + j) = Γ.one) + (hsep1 : (c_init.work 0).cells (1 + hk) ≠ Γ.one) + (hones2 : ∀ j, j < hn → (c_init.work 0).cells (hk + 2 + j) = Γ.one) + (hsep2 : (c_init.work 0).cells (hk + 2 + hn) ≠ Γ.one) + (hnostart : ∀ p, p ≥ 1 → (c_init.work 0).cells p ≠ Γ.start) + (hother : ∀ i, i ≠ (0 : Fin 4) → (c_init.work i).read ≠ Γ.start ∧ (c_init.work i).head ≥ 1) + (hinp : c_init.input.read ≠ Γ.start) + (hout : c_init.output.read ≠ Γ.start) (houth : c_init.output.head ≥ 1) : + ∃ c', + skipToQhaltTM.reachesIn (hk + hn + 2) c_init c' ∧ + skipToQhaltTM.halted c' ∧ + (c'.work 0).head = hk + hn + 3 ∧ + (c'.work 0).cells = (c_init.work 0).cells ∧ + c'.input = c_init.input ∧ c'.output = c_init.output ∧ + (∀ i, i ≠ (0 : Fin 4) → c'.work i = c_init.work i) := by + -- Phase 1: skipK scans past k ones + obtain ⟨c_mid, hreach1, hst_mid, hhead_mid, hcells_mid, hinp_mid, hout_mid, hwork_mid⟩ := + skipK_scan hk c_init hstate + (by intro j hj; rw [hdesc_head]; exact hones1 j hj) + (by rw [hdesc_head]; exact hsep1) + (by omega) + hnostart hother hinp hout houth + -- Phase 2: skipN scans past n ones + obtain ⟨c_final, hreach2, hhalt, hhead_final, hcells_final, hinp_f, hout_f, hwork_f⟩ := + skipN_scan hn c_mid hst_mid + (by intro j hj; rw [hcells_mid, hhead_mid, hdesc_head] + have : 1 + hk + 1 + j = hk + 2 + j := by omega + rw [this]; exact hones2 j hj) + (by rw [hcells_mid, hhead_mid, hdesc_head] + have : 1 + hk + 1 + hn = hk + 2 + hn := by omega + rw [this]; exact hsep2) + (by omega) + (by rwa [hcells_mid]) + (by intro i hne; rw [hwork_mid i hne]; exact hother i hne) + (by rwa [hinp_mid]) + (by rwa [hout_mid]) + (by rw [hout_mid]; exact houth) + refine ⟨c_final, ?_, hhalt, + by rw [hhead_final, hhead_mid, hdesc_head]; omega, + by rw [hcells_final, hcells_mid], + by rw [hinp_f, hinp_mid], + by rw [hout_f, hout_mid], + fun i hne => by rw [hwork_f i hne, hwork_mid i hne]⟩ + have : hk + 1 + (hn + 1) = hk + hn + 2 := by omega + rw [← this] + exact reachesIn_trans _ hreach1 hreach2 + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWriteTM: tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Output head is preserved when writing blank with idleDir (stay). -/ +private theorem output_head_idle (out : Tape) (hns : out.read ≠ Γ.start) + (_hh : out.head ≥ 1) : + (out.writeAndMove Γw.blank.toΓ (idleDir out.read)).head = out.head := by + simp only [Tape.writeAndMove, Γw.toΓ, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split <;> rfl + +/-- Output cells 0 is preserved when writing blank with idleDir (head ≥ 1). -/ +private theorem output_cells0_idle (out : Tape) (hns : out.read ≠ Γ.start) + (hh : out.head ≥ 1) : + (out.writeAndMove Γw.blank.toΓ (idleDir out.read)).cells 0 = out.cells 0 := by + simp only [Tape.writeAndMove, Γw.toΓ, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · rfl + · show (Function.update out.cells out.head Γ.blank) 0 = out.cells 0 + rw [Function.update_of_ne (by omega : (0 : ℕ) ≠ out.head)] + +/-- Output cells ≥ 1 remain ≠ ▷ after writing blank with idleDir. -/ +private theorem output_cellsNS_idle (out : Tape) (hns : out.read ≠ Γ.start) + (_hh : out.head ≥ 1) (hons : ∀ j, j ≥ 1 → out.cells j ≠ Γ.start) : + ∀ j, j ≥ 1 → (out.writeAndMove Γw.blank.toΓ (idleDir out.read)).cells j ≠ Γ.start := by + intro j hj + simp only [Tape.writeAndMove, Γw.toΓ, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · exact hons j hj + · show (Function.update out.cells out.head Γ.blank) j ≠ Γ.start + by_cases heq : j = out.head + · subst heq; rw [Function.update_self]; decide + · rw [Function.update_of_ne heq]; exact hons j hj + +/-- Output read ≠ ▷ after writing blank with idleDir. -/ +private theorem output_readNS_idle (out : Tape) (hns : out.read ≠ Γ.start) + (_hh : out.head ≥ 1) (_hons : ∀ j, j ≥ 1 → out.cells j ≠ Γ.start) : + (out.writeAndMove Γw.blank.toΓ (idleDir out.read)).read ≠ Γ.start := by + have hns' : out.cells out.head ≠ Γ.start := by rw [← Tape.read]; exact hns + have hdir : idleDir (out.cells out.head) = Dir3.stay := by simp [idleDir, hns'] + simp only [Tape.read, Tape.writeAndMove, Γw.toΓ, hdir, Tape.move, Tape.write, + show out.head ≠ 0 from by omega, ↓reduceIte] + show (Function.update out.cells out.head Γ.blank) out.head ≠ Γ.start + rw [Function.update_self]; decide + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWriteTM: compare scan (all match → rewindOutM) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Comparison loop: scan past `count` matching cells, then sentinel → rewindOutM. + Both desc (work 0) and state (work 1) advance right together. -/ +private theorem compare_match_scan : + ∀ (count : ℕ) (c : Cfg 4 compareWriteTM.Q), + c.state = .compare → + (∀ j, j < count → (c.work (0 : Fin 4)).cells ((c.work 0).head + j) = + (c.work (1 : Fin 4)).cells ((c.work 1).head + j)) → + (∀ j, j < count → (c.work (1 : Fin 4)).cells ((c.work 1).head + j) ≠ Γ.blank) → + (c.work (1 : Fin 4)).cells ((c.work 1).head + count) = Γ.blank → + (c.work (0 : Fin 4)).head ≥ 1 → + (c.work (1 : Fin 4)).head ≥ 1 → + (∀ p, p ≥ 1 → (c.work (0 : Fin 4)).cells p ≠ Γ.start) → + (∀ p, p ≥ 1 → (c.work (1 : Fin 4)).cells p ≠ Γ.start) → + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + ∃ c', + compareWriteTM.reachesIn (count + 1) c c' ∧ + c'.state = .rewindOutM ∧ + (c'.work (0 : Fin 4)).cells = (c.work 0).cells ∧ + (c'.work (1 : Fin 4)).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + (c'.work (0 : Fin 4)).head = (c.work (0 : Fin 4)).head + count ∧ + (c'.work (1 : Fin 4)).head = (c.work (1 : Fin 4)).head + count ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + intro count; induction count with + | zero => + intro c hstate _ _ hsentinel hh0 hh1 hns0 hns1 hother hinp hout houth hoc0 hons + simp only [Nat.add_zero] at hsentinel + have hns_r0 : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns0 _ hh0 + have hns_r1 : (c.work (1 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns1 _ hh1 + have hread1_blank : (fun i => (c.work i).read) (1 : Fin 4) = Γ.blank := by + simp only [Tape.read]; exact hsentinel + -- Prove the step produces the right configuration + have hstep : ∃ c', + compareWriteTM.step c = some c' ∧ + c'.state = .rewindOutM ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + (c'.work 1).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + (c'.work (0 : Fin 4)).head = (c.work (0 : Fin 4)).head ∧ + (c'.work (1 : Fin 4)).head = (c.work (1 : Fin 4)).head ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread1_blank] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + rw [tape_idle_preserve (c.work 0) hns_r0 hh0] + · dsimp only [] + rw [tape_idle_preserve (c.work 1) hns_r1 hh1] + · dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · dsimp only []; exact output_head_idle c.output hout houth + · dsimp only []; exact (output_cells0_idle c.output hout houth).trans hoc0 + · dsimp only []; exact output_cellsNS_idle c.output hout houth hons + · dsimp only []; show _ = (c.work 0).head + rw [tape_idle_preserve (c.work 0) hns_r0 hh0] + · dsimp only []; show _ = (c.work 1).head + rw [tape_idle_preserve (c.work 1) hns_r1 hh1] + · intro i hne0 hne1; dsimp only [] + exact tape_idle_preserve (c.work i) (hother i hne0 hne1).1 (hother i hne0 hne1).2 + obtain ⟨c', hstep_eq, hst, hc0, hc1, hinp', hoh, hoc0', hons', hh0_eq, hh1_eq, hw⟩ := hstep + exact ⟨c', .step hstep_eq .zero, hst, hc0, hc1, hinp', hoh, hoc0', hons', + by simp [hh0_eq], by simp [hh1_eq], hw⟩ + | succ n ih => + intro c hstate hmatch hnotblank hsentinel hh0 hh1 hns0 hns1 hother hinp hout houth hoc0 hons + have hns_r0 : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns0 _ hh0 + have hns_r1 : (c.work (1 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns1 _ hh1 + -- State tape reads non-blank (not sentinel yet) + have hread1_ne : (fun i => (c.work i).read) (1 : Fin 4) ≠ Γ.blank := by + simp only [Tape.read]; exact hnotblank 0 (by omega) + -- Both tapes match at current position + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = + (fun i => (c.work i).read) (1 : Fin 4) := by + simp only [Tape.read]; exact hmatch 0 (by omega) + -- Prove the match step + have hstep : ∃ c', + compareWriteTM.step c = some c' ∧ + c'.state = .compare ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + (c'.work 1).head = (c.work 1).head + 1 ∧ + (c'.work 1).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + c'.output.read ≠ Γ.start ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread1_ne, hread_eq] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- work 0 head + dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · -- work 0 cells + dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hns_r0]; exact Function.update_eq_self _ _ + · -- work 1 head + dsimp only [] + simp only [show (↑(1 : Fin 4) : ℕ) = 1 from rfl, + show ¬((1 : ℕ) = 0) from by omega, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · -- work 1 cells + dsimp only [] + simp only [show (↑(1 : Fin 4) : ℕ) = 1 from rfl, + show ¬((1 : ℕ) = 0) from by omega, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hns_r1]; exact Function.update_eq_self _ _ + · -- input + dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · -- output head + dsimp only []; exact output_head_idle c.output hout houth + · -- output cells 0 + dsimp only []; exact (output_cells0_idle c.output hout houth).trans hoc0 + · -- output cells ≥ 1 ≠ start + dsimp only []; exact output_cellsNS_idle c.output hout houth hons + · -- output read ≠ start + dsimp only []; exact output_readNS_idle c.output hout houth hons + · -- other work tapes + intro i hne0 hne1; dsimp only [] + have : ¬(↑i = (0 : ℕ)) := fun h => hne0 (by ext; exact h) + have : ¬(↑i = (1 : ℕ)) := fun h => hne1 (by ext; exact h) + simp only [*, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne0 hne1).1 (hother i hne0 hne1).2 + obtain ⟨c', hstep_eq, hst', hh0', hc0', hh1', hc1', hinp', hoh', hoc0'', hons'', hout_ns', hw'⟩ := hstep + -- Apply IH to c' + obtain ⟨c_f, hreach_f, hst_f, hcf0, hcf1, hinp_f, hoh_f, hoc0_f, hons_f, hh0_f, hh1_f, hw_f⟩ := ih c' hst' + (by intro j hj; rw [hc0', hh0', hc1', hh1'] + have : (c.work 0).head + 1 + j = (c.work 0).head + (j + 1) := by omega + have : (c.work 1).head + 1 + j = (c.work 1).head + (j + 1) := by omega + rw [‹(c.work 0).head + 1 + j = _›, ‹(c.work 1).head + 1 + j = _›] + exact hmatch (j + 1) (by omega)) + (by intro j hj; rw [hc1', hh1'] + have : (c.work 1).head + 1 + j = (c.work 1).head + (j + 1) := by omega + rw [this]; exact hnotblank (j + 1) (by omega)) + (by rw [hc1', hh1'] + have : (c.work 1).head + 1 + n = (c.work 1).head + (n + 1) := by omega + rw [this]; exact hsentinel) + (by omega) (by omega) + (by rwa [hc0']) + (by rwa [hc1']) + (by intro i hne0 hne1; rw [hw' i hne0 hne1]; exact hother i hne0 hne1) + (by rwa [hinp']) + hout_ns' (by rw [hoh']; exact houth) + hoc0'' hons'' + exact ⟨c_f, .step hstep_eq hreach_f, hst_f, + by rw [hcf0, hc0'], + by rw [hcf1, hc1'], + by rw [hinp_f, hinp'], + by rw [hoh_f, hoh'], + hoc0_f, hons_f, + by rw [hh0_f, hh0']; omega, by rw [hh1_f, hh1']; omega, + fun i hne0 hne1 => by rw [hw_f i hne0 hne1, hw' i hne0 hne1]⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWriteTM: rewind output + write +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind output tape from head position h to cell 1, then write sym and halt. + Covers both match (rewindOutM → writeM → done, sym = .one) and + mismatch (rewindOutD → writeD → done, sym = .zero) cases. -/ +private theorem compareWriteTM_rewind_write + (is_match : Bool) (c : Cfg 4 compareWriteTM.Q) + (hstate : c.state = if is_match then .rewindOutM else .rewindOutD) + (hoc0 : c.output.cells 0 = Γ.start) + (hons : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hns_work : ∀ i : Fin 4, (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) : + ∃ c', + compareWriteTM.reachesIn (c.output.head + 2) c c' ∧ + compareWriteTM.halted c' ∧ + c'.output.cells 1 = (if is_match then Γ.one else Γ.zero) ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ + (∀ i : Fin 4, c'.work i = c.work i) ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) := by + -- Rewind output tape to cell 0 (reading ▷), then move right to cell 1, then write + -- Phase 1: rewind loop (output.head steps to reach cell 0) + suffices h_rewind : ∀ (h : ℕ) (c : Cfg 4 compareWriteTM.Q), + c.state = (if is_match then .rewindOutM else .rewindOutD) → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = h → + (∀ i : Fin 4, (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + c.input.read ≠ Γ.start → + ∃ c', + compareWriteTM.reachesIn (h + 2) c c' ∧ + compareWriteTM.halted c' ∧ + c'.output.cells 1 = (if is_match then Γ.one else Γ.zero) ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ + (∀ i : Fin 4, c'.work i = c.work i) ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) by + exact h_rewind c.output.head c hstate hoc0 hons rfl hns_work hinp + intro h + induction h with + | zero => + intro c hstate hcell0 hnostart hhead hns_work hinp + -- At cell 0: output reads ▷ → move right to cell 1, then write + have hread_start : c.output.read = Γ.start := by + simp [Tape.read, hhead, hcell0] + -- Step 1: rewindOut{M,D} → write{M,D} (move right) + have hstep1 : ∃ c₁, + compareWriteTM.step c = some c₁ ∧ + c₁.state = (if is_match then .writeM else .writeD) ∧ + c₁.output.head = 1 ∧ + c₁.output.cells = c.output.cells ∧ + c₁.input = c.input ∧ + (∀ i : Fin 4, c₁.work i = c.work i) := by + cases is_match <;> ( + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread_start, Bool.false_eq_true] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · dsimp only [] + simp [Tape.writeAndMove, tape_move_cells', Tape.write, hhead] + · dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · intro i; dsimp only [] + exact tape_idle_preserve (c.work i) (hns_work i).1 (hns_work i).2) + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hinp1, hwork1⟩ := hstep1 + -- Step 2: write{M,D} → done (write sym at cell 1 and halt) + have hns1 : c₁.output.cells 1 ≠ Γ.start := by + rw [hcells1]; exact hnostart 1 (by omega) + have hout_read : c₁.output.read ≠ Γ.start := by + simp [Tape.read, hhead1, hcells1]; exact hnostart 1 (by omega) + have hns_work1 : ∀ i : Fin 4, (c₁.work i).read ≠ Γ.start ∧ (c₁.work i).head ≥ 1 := by + intro i; rw [hwork1]; exact hns_work i + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hstep2 : ∃ c₂, + compareWriteTM.step c₁ = some c₂ ∧ + compareWriteTM.halted c₂ ∧ + c₂.output.cells 1 = (if is_match then Γ.one else Γ.zero) ∧ + c₂.output.head = 1 ∧ + c₂.input = c₁.input ∧ + (∀ i : Fin 4, c₂.work i = c₁.work i) ∧ + c₂.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c₂.output.cells j ≠ Γ.start) := by + cases is_match <;> ( + simp only [TM.step, hst1, compareWriteTM, ↓reduceIte, Bool.false_eq_true] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- cells 1 = sym + dsimp only [] + simp only [Tape.writeAndMove, idleDir, hout_read, ↓reduceIte, + Tape.move, Tape.write, show c₁.output.head ≠ 0 from by omega] + rw [hhead1, Function.update_self]; rfl + · -- head = 1 + dsimp only [] + simp [Tape.writeAndMove, idleDir, hout_read, Tape.move, Tape.write, hhead1] + · -- input + dsimp only []; simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · -- work + intro i; dsimp only [] + exact tape_idle_preserve (c₁.work i) (hns_work1 i).1 (hns_work1 i).2 + · -- cells 0 + dsimp only [] + simp only [Tape.writeAndMove, idleDir, hout_read, ↓reduceIte, + Tape.move, Tape.write, show c₁.output.head ≠ 0 from by omega] + rw [Function.update_of_ne (by omega : (0 : ℕ) ≠ c₁.output.head)] + rw [hcells1]; exact hcell0 + · -- cells ≥ 1 ≠ start + intro j hj; dsimp only [] + simp only [Tape.writeAndMove, idleDir, hout_read, ↓reduceIte, + Tape.move, Tape.write, show c₁.output.head ≠ 0 from by omega] + by_cases heq : j = c₁.output.head + · subst heq; rw [Function.update_self]; decide + · rw [Function.update_of_ne heq, hcells1]; exact hnostart j hj) + obtain ⟨c₂, hstep2', hhalt, hcell, hhead2, hinp2, hwork2, hoc0', hons'⟩ := hstep2 + exact ⟨c₂, .step hstep1' (.step hstep2' .zero), hhalt, hcell, hhead2, + by rw [hinp2, hinp1], + fun i => by rw [hwork2 i, hwork1 i], + hoc0', hons'⟩ + | succ h ih => + intro c hstate hcell0 hnostart hhead hns_work hinp + -- Not at cell 0: output reads non-▷ → keep moving left + have hread_ne : c.output.read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (h + 1) (by omega) + have hstep : ∃ c₁, + compareWriteTM.step c = some c₁ ∧ + c₁.state = (if is_match then .rewindOutM else .rewindOutD) ∧ + c₁.output.head = h ∧ + c₁.output.cells = c.output.cells ∧ + c₁.input = c.input ∧ + (∀ i : Fin 4, c₁.work i = c.work i) := by + cases is_match <;> ( + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread_ne, Bool.false_eq_true] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_⟩ + · -- output head + dsimp only [] + simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq' hread_ne] + simp only [Tape.write]; split + · omega + · simp [hhead] + · -- output cells + dsimp only [] + simp only [Tape.writeAndMove, tape_move_cells'] + rw [readBackWrite_toΓ_eq' hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · -- input + dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · -- work + intro i; dsimp only [] + exact tape_idle_preserve (c.work i) (hns_work i).1 (hns_work i).2) + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hinp1, hwork1⟩ := hstep + obtain ⟨c_f, hreach_f, hhalt_f, hcell_f, hhead_f, hinp_f, hwork_f, hoc0_f, hons_f⟩ := + ih c₁ hst1 (by rw [hcells1]; exact hcell0) (by intro j hj; rw [hcells1]; exact hnostart j hj) + hhead1 (by intro i; rw [hwork1]; exact hns_work i) (by rw [hinp1]; exact hinp) + exact ⟨c_f, .step hstep' hreach_f, hhalt_f, hcell_f, hhead_f, + by rw [hinp_f, hinp1], + fun i => by rw [hwork_f i, hwork1 i], + hoc0_f, hons_f⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWriteTM: mismatch scan (all match for prefix, then mismatch) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Comparison loop variant for MISMATCH: scan past `count` matching non-blank cells, + then a mismatch (non-blank cells that differ) → rewindOutD. -/ +private theorem compare_mismatch_scan : + ∀ (count : ℕ) (c : Cfg 4 compareWriteTM.Q), + c.state = .compare → + (∀ j, j < count → (c.work (0 : Fin 4)).cells ((c.work 0).head + j) = + (c.work (1 : Fin 4)).cells ((c.work 1).head + j)) → + (∀ j, j ≤ count → (c.work (1 : Fin 4)).cells ((c.work 1).head + j) ≠ Γ.blank) → + (c.work (0 : Fin 4)).cells ((c.work 0).head + count) ≠ + (c.work (1 : Fin 4)).cells ((c.work 1).head + count) → + (c.work (0 : Fin 4)).head ≥ 1 → + (c.work (1 : Fin 4)).head ≥ 1 → + (∀ p, p ≥ 1 → (c.work (0 : Fin 4)).cells p ≠ Γ.start) → + (∀ p, p ≥ 1 → (c.work (1 : Fin 4)).cells p ≠ Γ.start) → + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + ∃ c', + compareWriteTM.reachesIn (count + 1) c c' ∧ + c'.state = .rewindOutD ∧ + (c'.work (0 : Fin 4)).cells = (c.work 0).cells ∧ + (c'.work (1 : Fin 4)).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + (c'.work (0 : Fin 4)).head = (c.work (0 : Fin 4)).head + count ∧ + (c'.work (1 : Fin 4)).head = (c.work (1 : Fin 4)).head + count ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + intro count; induction count with + | zero => + intro c hstate _ hnotblank hmismatch hh0 hh1 hns0 hns1 hother hinp hout houth hoc0 hons + have hns_r0 : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns0 _ hh0 + have hns_r1 : (c.work (1 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns1 _ hh1 + have hread1_ne_blank : (fun i => (c.work i).read) (1 : Fin 4) ≠ Γ.blank := by + simp only [Tape.read]; exact hnotblank 0 (by omega) + have hread_neq : (fun i => (c.work i).read) (0 : Fin 4) ≠ + (fun i => (c.work i).read) (1 : Fin 4) := by + simp only [Tape.read, Nat.add_zero] at hmismatch ⊢; exact hmismatch + have hstep : ∃ c', + compareWriteTM.step c = some c' ∧ + c'.state = .rewindOutD ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + (c'.work 1).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + (c'.work (0 : Fin 4)).head = (c.work (0 : Fin 4)).head ∧ + (c'.work (1 : Fin 4)).head = (c.work (1 : Fin 4)).head ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread1_ne_blank, hread_neq] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only []; rw [tape_idle_preserve (c.work 0) hns_r0 hh0] + · dsimp only []; rw [tape_idle_preserve (c.work 1) hns_r1 hh1] + · dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · dsimp only []; exact output_head_idle c.output hout houth + · dsimp only []; exact (output_cells0_idle c.output hout houth).trans hoc0 + · dsimp only []; exact output_cellsNS_idle c.output hout houth hons + · dsimp only []; show _ = (c.work 0).head + rw [tape_idle_preserve (c.work 0) hns_r0 hh0] + · dsimp only []; show _ = (c.work 1).head + rw [tape_idle_preserve (c.work 1) hns_r1 hh1] + · intro i hne0 hne1; dsimp only [] + exact tape_idle_preserve (c.work i) (hother i hne0 hne1).1 (hother i hne0 hne1).2 + obtain ⟨c', hstep_eq, hst, hc0, hc1, hinp', hoh, hoc0', hons', hh0_eq, hh1_eq, hw⟩ := hstep + exact ⟨c', .step hstep_eq .zero, hst, hc0, hc1, hinp', hoh, hoc0', hons', + by simp [hh0_eq], by simp [hh1_eq], hw⟩ + | succ n ih => + intro c hstate hmatch hnotblank hmismatch hh0 hh1 hns0 hns1 hother hinp hout houth hoc0 hons + have hns_r0 : (c.work (0 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns0 _ hh0 + have hns_r1 : (c.work (1 : Fin 4)).read ≠ Γ.start := by + simp only [Tape.read]; exact hns1 _ hh1 + have hread1_ne : (fun i => (c.work i).read) (1 : Fin 4) ≠ Γ.blank := by + simp only [Tape.read]; exact hnotblank 0 (by omega) + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = + (fun i => (c.work i).read) (1 : Fin 4) := by + simp only [Tape.read]; exact hmatch 0 (by omega) + -- Match step (same as compare_match_scan succ case) + have hstep : ∃ c', + compareWriteTM.step c = some c' ∧ + c'.state = .compare ∧ + (c'.work 0).head = (c.work 0).head + 1 ∧ + (c'.work 0).cells = (c.work 0).cells ∧ + (c'.work 1).head = (c.work 1).head + 1 ∧ + (c'.work 1).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + c'.output.head = c.output.head ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + c'.output.read ≠ Γ.start ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) := by + simp only [TM.step, hstate, compareWriteTM, ↓reduceIte, hread1_ne, hread_eq] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(0 : Fin 4) : ℕ) = 0 from rfl, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hns_r0]; exact Function.update_eq_self _ _ + · dsimp only [] + simp only [show (↑(1 : Fin 4) : ℕ) = 1 from rfl, + show ¬((1 : ℕ) = 0) from by omega, ↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + split <;> (first | omega | rfl) + · dsimp only [] + simp only [show (↑(1 : Fin 4) : ℕ) = 1 from rfl, + show ¬((1 : ℕ) = 0) from by omega, ↓reduceIte, + Tape.writeAndMove, tape_move_cells', Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hns_r1]; exact Function.update_eq_self _ _ + · dsimp only []; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · dsimp only []; exact output_head_idle c.output hout houth + · dsimp only []; exact (output_cells0_idle c.output hout houth).trans hoc0 + · dsimp only []; exact output_cellsNS_idle c.output hout houth hons + · dsimp only []; exact output_readNS_idle c.output hout houth hons + · intro i hne0 hne1; dsimp only [] + have : ¬(↑i = (0 : ℕ)) := fun h => hne0 (by ext; exact h) + have : ¬(↑i = (1 : ℕ)) := fun h => hne1 (by ext; exact h) + simp only [*, ↓reduceIte] + exact tape_idle_preserve (c.work i) (hother i hne0 hne1).1 (hother i hne0 hne1).2 + obtain ⟨c', hstep_eq, hst', hh0', hc0', hh1', hc1', hinp', hoh', hoc0'', hons'', hout_ns', hw'⟩ := hstep + obtain ⟨c_f, hreach_f, hst_f, hcf0, hcf1, hinp_f, hoh_f, hoc0_f, hons_f, hh0_f, hh1_f, hw_f⟩ := ih c' hst' + (by intro j hj; rw [hc0', hh0', hc1', hh1'] + have : (c.work 0).head + 1 + j = (c.work 0).head + (j + 1) := by omega + have : (c.work 1).head + 1 + j = (c.work 1).head + (j + 1) := by omega + rw [‹(c.work 0).head + 1 + j = _›, ‹(c.work 1).head + 1 + j = _›] + exact hmatch (j + 1) (by omega)) + (by intro j hj; rw [hc1', hh1'] + have : (c.work 1).head + 1 + j = (c.work 1).head + (j + 1) := by omega + rw [this]; exact hnotblank (j + 1) (by omega)) + (by rw [hc0', hh0', hc1', hh1'] + have : (c.work 0).head + 1 + n = (c.work 0).head + (n + 1) := by omega + have : (c.work 1).head + 1 + n = (c.work 1).head + (n + 1) := by omega + rw [‹(c.work 0).head + 1 + n = _›, ‹(c.work 1).head + 1 + n = _›] + exact hmismatch) + (by omega) (by omega) + (by rwa [hc0']) + (by rwa [hc1']) + (by intro i hne0 hne1; rw [hw' i hne0 hne1]; exact hother i hne0 hne1) + (by rwa [hinp']) + hout_ns' (by rw [hoh']; exact houth) + hoc0'' hons'' + exact ⟨c_f, .step hstep_eq hreach_f, hst_f, + by rw [hcf0, hc0'], + by rw [hcf1, hc1'], + by rw [hinp_f, hinp'], + by rw [hoh_f, hoh'], + hoc0_f, hons_f, + by rw [hh0_f, hh0']; omega, by rw [hh1_f, hh1']; omega, + fun i hne0 hne1 => by rw [hw_f i hne0 hne1, hw' i hne0 hne1]⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWriteTM: full simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Full simulation of compareWriteTM. Compares two one-hot patterns: + desc tape at `desc_pos` and state tape at cell 1, each of width `k`. + If patterns match (q_desc = q_state), writes Γ.one to output cell 1. + If they differ, writes Γ.zero. -/ +private theorem compareWriteTM_simulation (k : ℕ) (q_desc q_state : Fin k) + (desc_pos B : ℕ) + (c : Cfg 4 compareWriteTM.Q) + (hstate : c.state = .compare) + (hdh : (c.work (0 : Fin 4)).head = desc_pos) (hh0 : desc_pos ≥ 1) + (hsh : (c.work (1 : Fin 4)).head = 1) + -- desc tape has one-hot for q_desc at desc_pos + (hdesc : ∀ j, j < k → (c.work (0 : Fin 4)).cells (desc_pos + j) = + if j = q_desc.val then Γ.one else Γ.zero) + -- state tape has one-hot for q_state + (hstate_enc : stateOnTapeAt k q_state (c.work (1 : Fin 4))) + -- output WF + (hoc0 : c.output.cells 0 = Γ.start) + (hons : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hoh : c.output.head ≤ B) + -- Work tape WF + (hns0 : ∀ p, p ≥ 1 → (c.work (0 : Fin 4)).cells p ≠ Γ.start) + (hns1 : ∀ p, p ≥ 1 → (c.work (1 : Fin 4)).cells p ≠ Γ.start) + (hother : ∀ i : Fin 4, i ≠ 0 → i ≠ 1 → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hinp : c.input.read ≠ Γ.start) + (hout_ns : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) : + ∃ c' t, t ≤ k + B + 3 ∧ compareWriteTM.reachesIn t c c' ∧ + compareWriteTM.halted c' ∧ + (q_desc = q_state → c'.output.cells 1 = Γ.one) ∧ + (q_desc ≠ q_state → c'.output.cells 1 = Γ.zero) ∧ + c'.output.head = 1 ∧ + (c'.work (0 : Fin 4)).cells = (c.work 0).cells ∧ + (c'.work (1 : Fin 4)).cells = (c.work 1).cells ∧ + c'.input = c.input ∧ + (∀ i : Fin 4, i ≠ 0 → i ≠ 1 → c'.work i = c.work i) ∧ + c'.output.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ + (c'.work (0 : Fin 4)).head ≥ 1 ∧ + (c'.work (1 : Fin 4)).head ≥ 1 ∧ + (c'.work (0 : Fin 4)).head ≤ desc_pos + k ∧ + (c'.work (1 : Fin 4)).head ≤ 1 + k := by + -- Extract state tape structure + obtain ⟨hst0, hst_bits, hst_sentinel⟩ := hstate_enc + -- Helper: convert between j + 1 and 1 + j for state tape + have hst_bits' : ∀ j, j < k → (c.work 1).cells (1 + j) = + if j = q_state.val then Γ.one else Γ.zero := by + intro j hj; rw [show 1 + j = j + 1 from by omega]; exact hst_bits j hj + have hst_sentinel' : (c.work 1).cells (1 + k) = Γ.blank := by + rw [show 1 + k = k + 1 from by omega]; exact hst_sentinel + by_cases heq : q_desc = q_state + · -- MATCH case: all k cells match, sentinel at k → rewindOutM + have hmatch_cells : ∀ j, j < k → + (c.work 0).cells ((c.work 0).head + j) = + (c.work 1).cells ((c.work 1).head + j) := by + intro j hj; rw [hdh, hsh, hdesc j hj, hst_bits' j hj, heq] + have hnotblank : ∀ j, j < k → + (c.work 1).cells ((c.work 1).head + j) ≠ Γ.blank := by + intro j hj; rw [hsh, hst_bits' j hj]; split <;> decide + have hsentinel : (c.work 1).cells ((c.work 1).head + k) = Γ.blank := by + rw [hsh]; exact hst_sentinel' + obtain ⟨c_mid, hreach1, hst_mid, hc0_mid, hc1_mid, hinp_mid, hoh_mid, + hoc0_mid, hons_mid, hh0_mid_eq, hh1_mid_eq, hw_mid⟩ := + compare_match_scan k c hstate hmatch_cells hnotblank hsentinel + (by omega) (by omega) hns0 hns1 hother hinp hout_ns hout_h hoc0 hons + have hh0_mid_ge : (c_mid.work (0 : Fin 4)).head ≥ 1 := by rw [hh0_mid_eq]; omega + have hh1_mid_ge : (c_mid.work (1 : Fin 4)).head ≥ 1 := by rw [hh1_mid_eq]; omega + have hns_work_mid : ∀ i : Fin 4, (c_mid.work i).read ≠ Γ.start ∧ (c_mid.work i).head ≥ 1 := by + intro i + by_cases h0 : i = 0 + · subst h0 + exact ⟨by simp only [Tape.read]; rw [hc0_mid]; exact hns0 _ hh0_mid_ge, hh0_mid_ge⟩ + · by_cases h1 : i = 1 + · subst h1 + exact ⟨by simp only [Tape.read]; rw [hc1_mid]; exact hns1 _ hh1_mid_ge, hh1_mid_ge⟩ + · rw [hw_mid i h0 h1]; exact hother i h0 h1 + obtain ⟨c_done, hreach2, hhalt, hcell1, hhead_done, hinp_done, hwork_done, + hoc0_done, hons_done⟩ := + compareWriteTM_rewind_write true c_mid hst_mid hoc0_mid hons_mid hns_work_mid + (by rw [hinp_mid]; exact hinp) + refine ⟨c_done, k + 1 + (c_mid.output.head + 2), by rw [hoh_mid]; omega, + reachesIn_trans _ hreach1 hreach2, hhalt, ?_, ?_, hhead_done, + ?_, ?_, by rw [hinp_done, hinp_mid], ?_, hoc0_done, hons_done, + by rw [hwork_done 0]; exact hh0_mid_ge, + by rw [hwork_done 1]; exact hh1_mid_ge, + by rw [hwork_done 0, hh0_mid_eq, hdh], + by rw [hwork_done 1, hh1_mid_eq, hsh]⟩ + · intro _; exact hcell1 + · intro hne; exact absurd heq hne + · rw [hwork_done 0, hc0_mid] + · rw [hwork_done 1, hc1_mid] + · intro i hne0 hne1; rw [hwork_done i]; exact hw_mid i hne0 hne1 + · -- MISMATCH case: first mismatch at position min(q_desc, q_state) + let m := min q_desc.val q_state.val + have hm_lt : m < k := Nat.lt_of_le_of_lt (Nat.min_le_left _ _) q_desc.isLt + -- Cells at positions 0..m-1 all match (both are Γ.zero) + have hmatch_prefix : ∀ j, j < m → + (c.work 0).cells ((c.work 0).head + j) = + (c.work 1).cells ((c.work 1).head + j) := by + intro j hj; rw [hdh, hsh, hdesc j (by omega), hst_bits' j (by omega)] + have : j ≠ q_desc.val := by omega + have : j ≠ q_state.val := by omega + simp [*] + -- All state tape cells in 0..m are non-blank + have hnotblank_prefix : ∀ j, j ≤ m → + (c.work 1).cells ((c.work 1).head + j) ≠ Γ.blank := by + intro j hj; rw [hsh, hst_bits' j (by omega)]; split <;> decide + -- At position m: cells differ (one is 1, other is 0) + have hmismatch_at_m : + (c.work 0).cells ((c.work 0).head + m) ≠ + (c.work 1).cells ((c.work 1).head + m) := by + rw [hdh, hsh, hdesc m hm_lt, hst_bits' m hm_lt] + simp only [m, Nat.min_def] + split + · -- q_desc.val ≤ q_state.val, so min = q_desc.val + simp only [↓reduceIte] + have : q_desc.val ≠ q_state.val := fun h => heq (Fin.ext h) + simp [this] + · -- q_state.val < q_desc.val, so min = q_state.val + rename_i hgt + have : q_state.val ≠ q_desc.val := by omega + have : q_desc.val ≠ q_state.val := fun h => heq (Fin.ext h) + simp [*] + obtain ⟨c_mid, hreach1, hst_mid, hc0_mid, hc1_mid, hinp_mid, hoh_mid, + hoc0_mid, hons_mid, hh0_mid_eq, hh1_mid_eq, hw_mid⟩ := + compare_mismatch_scan m c hstate hmatch_prefix hnotblank_prefix hmismatch_at_m + (by omega) (by omega) hns0 hns1 hother hinp hout_ns hout_h hoc0 hons + have hh0_mid_ge : (c_mid.work (0 : Fin 4)).head ≥ 1 := by rw [hh0_mid_eq]; omega + have hh1_mid_ge : (c_mid.work (1 : Fin 4)).head ≥ 1 := by rw [hh1_mid_eq]; omega + have hns_work_mid : ∀ i : Fin 4, (c_mid.work i).read ≠ Γ.start ∧ (c_mid.work i).head ≥ 1 := by + intro i + by_cases h0 : i = 0 + · subst h0 + exact ⟨by simp only [Tape.read]; rw [hc0_mid]; exact hns0 _ hh0_mid_ge, hh0_mid_ge⟩ + · by_cases h1 : i = 1 + · subst h1 + exact ⟨by simp only [Tape.read]; rw [hc1_mid]; exact hns1 _ hh1_mid_ge, hh1_mid_ge⟩ + · rw [hw_mid i h0 h1]; exact hother i h0 h1 + obtain ⟨c_done, hreach2, hhalt, hcell1, hhead_done, hinp_done, hwork_done, + hoc0_done, hons_done⟩ := + compareWriteTM_rewind_write false c_mid hst_mid hoc0_mid hons_mid hns_work_mid + (by rw [hinp_mid]; exact hinp) + refine ⟨c_done, m + 1 + (c_mid.output.head + 2), by rw [hoh_mid]; omega, + reachesIn_trans _ hreach1 hreach2, hhalt, ?_, ?_, hhead_done, + ?_, ?_, by rw [hinp_done, hinp_mid], ?_, hoc0_done, hons_done, + by rw [hwork_done 0]; exact hh0_mid_ge, + by rw [hwork_done 1]; exact hh1_mid_ge, + by rw [hwork_done 0, hh0_mid_eq, hdh]; exact Nat.add_le_add_left (le_of_lt hm_lt) _, + by rw [hwork_done 1, hh1_mid_eq, hsh]; exact Nat.add_le_add_left (le_of_lt hm_lt) _⟩ + · intro heq_contra; exact absurd heq_contra heq + · intro _; exact hcell1 + · rw [hwork_done 0, hc0_mid] + · rw [hwork_done 1, hc1_mid] + · intro i hne0 hne1; rw [hwork_done i]; exact hw_mid i hne0 hne1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Rich HoareTime specs for sub-machines (for composition) +-- ════════════════════════════════════════════════════════════════════════ + +variable {n : ℕ} + +/-- HoareTime wrapper for skipToQhaltTM. Navigates desc tape from cell 1 + past header to qhalt one-hot position. Preserves all other tapes. -/ +private theorem skipToQhaltTM_asHoareTime (k' n' : ℕ) (desc : List Bool) + (q : Fin k') + -- Header structure on the desc tape + (hones1 : ∀ j, j < k' → desc[j]? = some true) + (hsep1 : desc[k']? = some false) + (hones2 : ∀ j, j < n' → desc[k' + 1 + j]? = some true) + (hsep2 : desc[k' + 1 + n']? = some false) + (hdesc_long : k' + 1 + n' + 1 ≤ desc.length) + {B_out : ℕ} : + skipToQhaltTM.HoareTime + (fun inp work out => + descOnTape desc (work (0 : Fin 4)) ∧ + stateOnTapeAt k' q (work (1 : Fin 4)) ∧ + (work (0 : Fin 4)).head = 1 ∧ + (work (1 : Fin 4)).head = 1 ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, (work i).head ≥ 1) ∧ + out.head ≤ B_out) + (fun inp work out => + descOnTape desc (work (0 : Fin 4)) ∧ + stateOnTapeAt k' q (work (1 : Fin 4)) ∧ + (work (0 : Fin 4)).head = k' + n' + 3 ∧ + (work (1 : Fin 4)).head = 1 ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, (work i).head ≥ 1) ∧ + out.head ≤ B_out) + (k' + n' + 2) := by + intro inp work out ⟨hdesc_tape, hstate_tape, hdh, hsh, hoc0, hons, hwf, hinp, hout_ns, hout_h, hheads, hout_le⟩ + -- Derive the header structure on the tape from descOnTape + desc structure + have hones1_tape : ∀ j, j < k' → (work (0 : Fin 4)).cells (1 + j) = Γ.one := by + intro j hj + obtain ⟨_, hbits, _⟩ := hdesc_tape + have hlen : j < desc.length := by omega + have heq : j + 1 = 1 + j := by omega + rw [show (1 : ℕ) + j = j + 1 from by omega, hbits j hlen] + have := hones1 j hj + simp only [List.getElem?_eq_getElem hlen] at this + injection this with h; rw [h]; rfl + have hsep1_tape : (work (0 : Fin 4)).cells (1 + k') ≠ Γ.one := by + obtain ⟨_, hbits, _⟩ := hdesc_tape + have hlen : k' < desc.length := by omega + rw [show (1 : ℕ) + k' = k' + 1 from by omega, hbits k' hlen] + have := hsep1 + simp only [List.getElem?_eq_getElem hlen] at this + injection this with h; rw [h]; decide + have hones2_tape : ∀ j, j < n' → (work (0 : Fin 4)).cells (k' + 2 + j) = Γ.one := by + intro j hj + obtain ⟨_, hbits, _⟩ := hdesc_tape + have hlen : k' + 1 + j < desc.length := by omega + rw [show k' + 2 + j = (k' + 1 + j) + 1 from by omega, hbits (k' + 1 + j) hlen] + have := hones2 j hj + simp only [List.getElem?_eq_getElem hlen] at this + injection this with h; rw [h]; rfl + have hsep2_tape : (work (0 : Fin 4)).cells (k' + 2 + n') ≠ Γ.one := by + obtain ⟨_, hbits, _⟩ := hdesc_tape + have hlen : k' + 1 + n' < desc.length := by omega + rw [show k' + 2 + n' = (k' + 1 + n') + 1 from by omega, hbits (k' + 1 + n') hlen] + have := hsep2 + simp only [List.getElem?_eq_getElem hlen] at this + injection this with h; rw [h]; decide + -- Other tapes read ≠ ▷ and head ≥ 1 + have hother : ∀ i, i ≠ (0 : Fin 4) → (work i).read ≠ Γ.start ∧ (work i).head ≥ 1 := by + intro i hne + refine ⟨?_, hheads i⟩ + simp only [Tape.read] + exact hwf.2 i _ (hheads i) + -- Apply the existing simulation lemma + obtain ⟨c', hreach, hhalt, hh', hcells', hinp', hout', hwork'⟩ := + skipToQhaltTM_hoareTime k' n' + { state := skipToQhaltTM.qstart, input := inp, work := work, output := out } + rfl hdh hones1_tape hsep1_tape hones2_tape hsep2_tape + (fun p hp => hwf.2 0 p hp) hother hinp hout_ns hout_h + -- Reduce struct field projections + change (c'.work 0).cells = (work 0).cells at hcells' + change c'.input = inp at hinp' + change c'.output = out at hout' + change ∀ i, i ≠ (0 : Fin 4) → c'.work i = work i at hwork' + refine ⟨c', k' + n' + 2, le_rfl, hreach, hhalt, ?_⟩ + refine ⟨?_, ?_, hh', ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- descOnTape preserved (cells unchanged) + obtain ⟨h0, hbits, hblank⟩ := hdesc_tape + refine ⟨?_, ?_, ?_⟩ + · rw [show (c'.work (0 : Fin 4)).cells 0 = (work 0).cells 0 from by rw [hcells']]; exact h0 + · intro i hi + rw [show (c'.work (0 : Fin 4)).cells (i + 1) = (work 0).cells (i + 1) from by rw [hcells']] + exact hbits i hi + · rw [show (c'.work (0 : Fin 4)).cells (desc.length + 1) = (work 0).cells (desc.length + 1) + from by rw [hcells']] + exact hblank + · -- stateOnTapeAt preserved (tape unchanged) + rw [hwork' 1 (by decide)]; exact hstate_tape + · -- state head preserved + rw [hwork' 1 (by decide)]; exact hsh + · -- output cells 0 preserved + rw [hout']; exact hoc0 + · -- output cells ≥ 1 ≠ ▷ + intro j hj; rw [hout']; exact hons j hj + · -- WorkTapesWF preserved + constructor + · intro i + by_cases h : i = 0 + · subst h; rw [hcells']; exact hwf.1 0 + · rw [hwork' i h]; exact hwf.1 i + · intro i j hj + by_cases h : i = 0 + · subst h; rw [hcells']; exact hwf.2 0 j hj + · rw [hwork' i h]; exact hwf.2 i j hj + · -- input preserved + rw [hinp']; exact hinp + · -- output read ≠ ▷ + rw [hout']; exact hout_ns + · -- output head ≥ 1 + rw [hout']; exact hout_h + · -- all heads ≥ 1 + intro i + by_cases h : i = 0 + · subst h; rw [hh']; omega + · rw [hwork' i h]; exact hheads i + · -- output head bound preserved + rw [hout']; exact hout_le + +/-- HoareTime for compareWriteTM with rich postcondition. -/ +private theorem compareWriteTM_asHoareTime (tm : TM n) (k : ℕ) + (e : tm.Q ≃ Fin k) (desc : List Bool) (q : Fin k) (B : ℕ) + (he_val : ∀ q : tm.Q, (e q).val = (tm.stateEquiv q).val) + -- qhalt encoding on desc at position k+n+3 + (hqhalt : ∀ j, j < k → desc[k + 2 + n + j]? = some (decide (j = (e tm.qhalt).val))) + (hdesc_long : k + 2 + n + k ≤ desc.length) : + compareWriteTM.HoareTime + (fun inp work out => + descOnTape desc (work (0 : Fin 4)) ∧ + stateOnTapeAt k q (work (1 : Fin 4)) ∧ + (work (0 : Fin 4)).head = k + n + 3 ∧ + (work (1 : Fin 4)).head = 1 ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≤ B ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, (work i).head ≥ 1)) + (fun inp work out => + descOnTape desc (work (0 : Fin 4)) ∧ + stateOnTapeAt k q (work (1 : Fin 4)) ∧ + (q = e tm.qhalt → out.cells 1 = Γ.one) ∧ + (q ≠ e tm.qhalt → out.cells 1 = Γ.zero) ∧ + out.head = 1 ∧ out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, (work i).head ≥ 1) ∧ + (work (0 : Fin 4)).head ≤ 2 * k + n + 3 ∧ + (work (1 : Fin 4)).head ≤ k + 1) + (k + B + 3) := by + intro inp work out ⟨hdesc_tape, hstate_tape, hdh, hsh, hoc0, hons, hoh, hwf, hinp, hout_ns, hout_h, hheads⟩ + have hh0 : k + n + 3 ≥ 1 := by omega + -- Desc tape one-hot for qhalt at position k+n+3 + have hdesc_qhalt : ∀ j, j < k → (work (0 : Fin 4)).cells (k + n + 3 + j) = + if j = (e tm.qhalt).val then Γ.one else Γ.zero := by + intro j hj + obtain ⟨_, hbits, _⟩ := hdesc_tape + have hlen : k + 2 + n + j < desc.length := by omega + rw [show k + n + 3 + j = (k + 2 + n + j) + 1 from by omega, hbits (k + 2 + n + j) hlen] + have := hqhalt j hj + simp only [List.getElem?_eq_getElem hlen] at this + injection this with h; rw [h]; simp [Γ.ofBool]; split <;> simp_all + obtain ⟨c', t, ht, hreach, hhalt, hq_eq, hq_ne, hhead1, hcw0, hcw1, hinp', hw_other, + hoc0', hons', hh0_ge, hh1_ge, hh0_le, hh1_le⟩ := + compareWriteTM_simulation k (e tm.qhalt) q (k + n + 3) B + { state := compareWriteTM.qstart, input := inp, work := work, output := out } + rfl hdh hh0 hsh hdesc_qhalt hstate_tape hoc0 hons hoh + (fun p hp => hwf.2 0 p hp) (fun p hp => hwf.2 1 p hp) + (fun i h0 h1 => ⟨by simp only [Tape.read]; exact hwf.2 i _ (hheads i), hheads i⟩) + (by simp only [Tape.read]; exact hinp) hout_ns hout_h + change (c'.work 0).cells = (work 0).cells at hcw0 + change (c'.work 1).cells = (work 1).cells at hcw1 + change c'.input = inp at hinp' + refine ⟨c', t, ht, hreach, hhalt, ?_⟩ + refine ⟨?_, ?_, fun h => hq_eq h.symm, fun h => hq_ne (fun h' => h h'.symm), + hhead1, hoc0', hons', ?_, by rw [hinp']; exact hinp, + by simp only [Tape.read, hhead1]; exact hons' 1 (by omega), + by rw [hhead1], ?_⟩ + · obtain ⟨h0, hbits, hblank⟩ := hdesc_tape + exact ⟨by rw [hcw0]; exact h0, + fun i hi => by rw [hcw0]; exact hbits i hi, + by rw [hcw0]; exact hblank⟩ + · obtain ⟨h0, hbits, hsentinel⟩ := hstate_tape + exact ⟨by rw [hcw1]; exact h0, + fun j hj => by rw [hcw1]; exact hbits j hj, + by rw [hcw1]; exact hsentinel⟩ + · constructor + · intro i + by_cases h0 : i = 0 + · subst h0; rw [hcw0]; exact hwf.1 0 + · by_cases h1 : i = 1 + · subst h1; rw [hcw1]; exact hwf.1 1 + · rw [hw_other i h0 h1]; exact hwf.1 i + · intro i j hj + by_cases h0 : i = 0 + · subst h0; rw [hcw0]; exact hwf.2 0 j hj + · by_cases h1 : i = 1 + · subst h1; rw [hcw1]; exact hwf.2 1 j hj + · rw [hw_other i h0 h1]; exact hwf.2 i j hj + · refine ⟨?_, ?_, ?_⟩ + · intro i + by_cases h0 : i = 0 + · subst h0; exact hh0_ge + · by_cases h1 : i = 1 + · subst h1; exact hh1_ge + · rw [hw_other i h0 h1]; exact hheads i + · -- desc head ≤ 2*k + n + 3 + have := hh0_le; omega + · -- state head ≤ k + 1 + have := hh1_le; omega + +-- rewindWorkTM_rich_hoareTime is now public in HelpersInternal.lean + +-- ════════════════════════════════════════════════════════════════════════ +-- Encoding structure lemmas (derived from encodeTM definition) +-- ════════════════════════════════════════════════════════════════════════ + +private theorem encodeTM_ones1 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + ∀ j, j < k → desc[j]? = some true := by + subst hdesc; intro j hj + have hj' : j < Fintype.card tm.Q := hk ▸ hj + show (TMEncoding.encodeTM tm)[j]? = some true + unfold TMEncoding.encodeTM + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_append_left (by simp; omega)] + rw [List.getElem?_replicate, if_pos hj'] + +private theorem encodeTM_sep1 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + desc[k]? = some false := by + subst hdesc; subst hk + show (TMEncoding.encodeTM tm)[Fintype.card tm.Q]? = some false + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + simp [List.length_replicate, List.length_map, List.length_finRange] + +private theorem encodeTM_ones2 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + ∀ j, j < n → desc[k + 1 + j]? = some true := by + subst hdesc; subst hk; intro j hj + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + -- Peel right appends until we reach (replicate k ++ [false] ++ replicate n) + rw [List.getElem?_append_left (by simp; omega)] -- peel transTable + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel map qstart + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel map qhalt + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + -- Now: ((replicate k ++ [false]) ++ replicate n)[k+1+j]? + have hlen : (List.replicate (Fintype.card tm.Q) true ++ [false]).length ≤ Fintype.card tm.Q + 1 + j := by + simp + rw [List.getElem?_append_right hlen] + simp only [List.length_append, List.length_replicate, List.length_cons, List.length_nil] + rw [show Fintype.card tm.Q + 1 + j - (Fintype.card tm.Q + 1) = j from by omega] + rw [List.getElem?_replicate, if_pos hj] + +private theorem encodeTM_sep2 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + desc[k + 1 + n]? = some false := by + subst hdesc; subst hk + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + rw [List.getElem?_append_left (by simp; omega)] -- peel transTable + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel map qstart + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel map qhalt + -- Now: (((replicate k ++ [false]) ++ replicate n) ++ [false])[k+1+n]? + have hlen : ((List.replicate (Fintype.card tm.Q) true ++ [false]) ++ List.replicate n true).length ≤ Fintype.card tm.Q + 1 + n := by + simp; omega + rw [List.getElem?_append_right hlen] + have : Fintype.card tm.Q + 1 + n - (List.replicate (Fintype.card tm.Q) true ++ [false] ++ List.replicate n true).length = 0 := by + simp; omega + rw [this] + simp + +private theorem encodeTM_long1 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + k + 1 + n + 1 ≤ desc.length := by + subst hdesc; subst hk + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + simp only [List.length_append, List.length_replicate, List.length_map, List.length_finRange, + List.length_cons, List.length_nil] + omega + +private theorem encodeTM_qhalt (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) + {e : tm.Q ≃ Fin k} + (he_val : ∀ q : tm.Q, (e q).val = (tm.stateEquiv q).val) : + ∀ j, j < k → desc[k + 2 + n + j]? = some (decide (j = (e tm.qhalt).val)) := by + subst hdesc; intro j hj + have hj' : j < Fintype.card tm.Q := hk ▸ hj + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + -- Peel right appends: transTable, [false], map qstart, [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel transTable + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + rw [List.getElem?_append_left (by simp; omega)] -- peel map qstart + rw [List.getElem?_append_left (by simp; omega)] -- peel [false] + -- Now: (replicate k ++ [false] ++ replicate n ++ [false] ++ map...qhalt)[k+2+n+j]? + have hlen : (List.replicate (Fintype.card tm.Q) true ++ [false] ++ List.replicate n true ++ [false]).length ≤ k + 2 + n + j := by + simp; omega + rw [List.getElem?_append_right hlen] + have hidx : k + 2 + n + j - (List.replicate (Fintype.card tm.Q) true ++ [false] ++ List.replicate n true ++ [false]).length = j := by + simp; omega + rw [hidx] + -- Goal: (map (fun i => i == tm.stateEquiv tm.qhalt) (finRange k'))[j]? = some (decide (j = (e tm.qhalt).val)) + rw [List.getElem?_map] + have hfr : (List.finRange (Fintype.card tm.Q))[j]? = some ⟨j, hj'⟩ := by + rw [List.getElem?_eq_some_iff] + exact ⟨by simp [hj'], by simp [List.getElem_finRange]⟩ + rw [hfr] + dsimp only [Option.map] + congr 1 + -- Goal: (⟨j, hj'⟩ == tm.stateEquiv tm.qhalt) = decide (j = (e tm.qhalt).val) + rw [Bool.beq_eq_decide_eq] + simp only [Fin.ext_iff] + rw [he_val] + +private theorem encodeTM_long2 (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) : + k + 2 + n + k ≤ desc.length := by + subst hdesc; subst hk + unfold TMEncoding.encodeTM + simp only [TMEncoding.encodeStateOneHot] + simp only [List.length_append, List.length_replicate, List.length_map, List.length_finRange, + List.length_cons, List.length_nil] + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- Full checkHaltTM_hoareTime +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime specification for `utmCheckHaltTM`. + + **Pre**: Desc tape has valid encoding; state tape has one-hot of q; + output tape is WF; heads at 1. + **Post**: Output cell 1 = Γ.one iff q = e(qhalt), Γ.zero otherwise. + Desc, state tapes preserved. Heads at 1. + + **Time**: O(k + n + B). -/ +theorem checkHaltTM_hoareTime (tm : TM n) (k : ℕ) + (e : tm.Q ≃ Fin k) (desc : List Bool) (q : Fin k) (B : ℕ) + -- Encoding structure + (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) + (he_val : ∀ q : tm.Q, (e q).val = (tm.stateEquiv q).val) : + utmCheckHaltTM.HoareTime + (fun inp work out => + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k q (work utmStateTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).head = 1 ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≤ B ∧ + WorkTapesWF work ∧ + -- Input tape WF (needed for seqTransition identity) + inp.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → inp.cells j ≠ Γ.start) ∧ + inp.head ≥ 1 ∧ + -- All heads ≥ 1 and output head ≥ 1 (needed for idle preservation) + (∀ i, (work i).head ≥ 1) ∧ + out.head ≥ 1) + (fun _inp work out => + -- Read-only tapes preserved + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k q (work utmStateTape) ∧ + -- Halt check result + (q = e tm.qhalt → out.cells 1 = Γ.one) ∧ + (q ≠ e tm.qhalt → out.cells 1 = Γ.zero) ∧ + -- Output head at cell 1 (after rewind + write) + out.head = 1 ∧ + -- Heads restored + (work utmDescTape).head = 1 ∧ + (work utmStateTape).head = 1 ∧ + WorkTapesWF work) + (5 * k + 2 * n + B + 20) := by + -- ── Step 1: Derive encoding structure ─────────────────────────────── + have hones1 := encodeTM_ones1 tm hk hdesc + have hsep1 := encodeTM_sep1 tm hk hdesc + have hones2 := encodeTM_ones2 tm hk hdesc + have hsep2 := encodeTM_sep2 tm hk hdesc + have hdesc_long1 := encodeTM_long1 tm hk hdesc + have hqhalt := encodeTM_qhalt tm hk hdesc he_val + have hdesc_long2 := encodeTM_long2 tm hk hdesc + -- ── Step 2: Unfold HoareTime and run each phase ──────────────────── + intro inp work out ⟨hdesc_tape, hstate_tape, hdh, hsh, hoc0, hons, hoh_le, hwf, + hinp_c0, hinp_ns, hinp_h, hheads, hout_h⟩ + -- Derive read-level facts + have hinp_read : inp.read ≠ Γ.start := by + simp only [Tape.read]; exact hinp_ns _ hinp_h + have hout_read : out.read ≠ Γ.start := by + simp only [Tape.read]; exact hons _ hout_h + -- ── Phase 1: skipToQhaltTM ───────────────────────────────────────── + obtain ⟨c1, t1, ht1, hreach1, hhalt1, hdesc1, hstate1, hdh1, hsh1, + hoc01, hons1, hwf1, hinp1, hout1, houth1, hheads1, hoh1_le⟩ := + skipToQhaltTM_asHoareTime (B_out := B) k n desc q hones1 hsep1 hones2 hsep2 hdesc_long1 + inp work out + ⟨hdesc_tape, hstate_tape, hdh, hsh, hoc0, hons, hwf, + hinp_read, hout_read, hout_h, hheads, hoh_le⟩ + -- seqTransition identity + have hseq1_w := seqTransition_work_id hwf1 hheads1 + have hseq1_i := seqTransitionInput_id hinp1 + have hseq1_o := seqTransitionTape_id hout1 houth1 + -- ── Phase 2: compareWriteTM ──────────────────────────────────────── + -- skip preserves output, so c1.output.head = out.head ≤ B + -- (the skip raw simulation gives c'.output = c_init.output, which is + -- embedded in the postcondition: houth1 ≥ 1, but we also need ≤ B. + -- The skip postcondition preserves output head, so we need ≤ B.) + -- We pass hoh_le through: skip only touches desc tape (tape 0). + -- After skip, output head = original output head (skip idles output). + -- houth1 : c1.output.head ≥ 1 — this is our output head after skip. + -- The skip postcondition doesn't carry ≤ B, but the output is preserved. + -- We work around this by noting skip preserves output. + -- Actually, skipToQhaltTM_asHoareTime doesn't expose out.head ≤ B. + -- We need to modify skip or pass B through. For now, we observe that + -- houth1 ≤ B because skip preserves output head = out.head ≤ B. + -- TODO: this follows from skip preserving output, not yet in postcondition. + -- skip preserves output head: skipToQhaltTM_asHoareTime internally uses + -- skipToQhaltTM_hoareTime which proves c'.output = c_init.output. + -- We recover this by rerunning the raw simulation on the config c1. + -- But more efficiently: the skip postcondition preserves all output properties. + -- We know c1.output.cells 0 = Γ.start (hoc01) and ∀ j ≥ 1, ... (hons1) + -- and c1.output.head ≥ 1 (houth1). Since skip only touches work tape 0, + -- c1.output = out, giving c1.output.head = out.head ≤ B. + -- For now, derive via the raw simulation: + -- hoh1_le : c1.output.head ≤ B (from skip postcondition, output preserved) + obtain ⟨c2, t2, ht2, hreach2, hhalt2, hdesc2, hstate2, hq_eq2, hq_ne2, + hoh2, hoc02, hons2, hwf2, hinp2, hout2, houth2, hheads2, + hdh2_le, hsh2_le⟩ := + compareWriteTM_asHoareTime tm k e desc q B he_val hqhalt hdesc_long2 + (seqTransitionInput c1.input) (fun i => seqTransitionTape (c1.work i)) + (seqTransitionTape c1.output) + (by rw [hseq1_w, hseq1_i, hseq1_o] + exact ⟨hdesc1, hstate1, hdh1, hsh1, hoc01, hons1, + hoh1_le, hwf1, hinp1, hout1, houth1, hheads1⟩) + -- seqTransition identity + have hseq2_w := seqTransition_work_id hwf2 hheads2 + have hseq2_i := seqTransitionInput_id hinp2 + have hseq2_o := seqTransitionTape_id hout2 houth2 + -- ── Phase 3: rewindWorkTM 0 (desc tape) ──────────────────────────── + obtain ⟨c3, t3, ht3, hreach3, hhalt3, hpost3⟩ := + rewindWorkTM_rich_hoareTime (0 : Fin 4) (2 * k + n + 3) + (P := fun inp' work' out' => + descOnTape desc (work' 0) ∧ stateOnTapeAt k q (work' 1) ∧ + (q = e tm.qhalt → out'.cells 1 = Γ.one) ∧ + (q ≠ e tm.qhalt → out'.cells 1 = Γ.zero) ∧ + out'.head = 1 ∧ out'.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out'.cells j ≠ Γ.start) ∧ WorkTapesWF work' ∧ + inp'.read ≠ Γ.start ∧ out'.read ≠ Γ.start ∧ out'.head ≥ 1 ∧ + (∀ i, (work' i).head ≥ 1) ∧ (work' 1).head ≤ k + 1) + (by -- Frame preservation for rewind 0: P is stable under rewind of tape 0 + intro _ w0 o0 _ w1 o1 hP hc0 hh0 hot heq_i heq_oc heq_oh + obtain ⟨hd, hs, hqe, hqn, ho, hoc, hon, hw, hi, hor, hoh', hhe, hsl⟩ := hP + refine ⟨⟨?_, ?_, ?_⟩, ?_, ?_, ?_, ?_, ?_, ?_, ⟨?_, ?_⟩, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hc0]; exact hd.1 + · intro i hi'; rw [hc0]; exact hd.2.1 i hi' + · rw [hc0]; exact hd.2.2 + · rw [hot 1 (by decide)]; exact hs + · intro h; rw [heq_oc]; exact hqe h + · intro h; rw [heq_oc]; exact hqn h + · rw [heq_oh]; exact ho + · rw [heq_oc]; exact hoc + · intro j hj; rw [heq_oc]; exact hon j hj + · intro i; by_cases h : i = 0 + · subst h; rw [hc0]; exact hw.1 0 + · rw [hot i h]; exact hw.1 i + · intro i j hj; by_cases h : i = 0 + · subst h; rw [hc0]; exact hw.2 0 j hj + · rw [hot i h]; exact hw.2 i j hj + · rw [heq_i]; exact hi + · simp only [Tape.read, heq_oh, heq_oc]; rw [ho]; exact hon 1 (by omega) + · rw [heq_oh]; exact hoh' + · intro i; by_cases h : i = 0 + · subst h; rw [hh0] + · rw [hot i h]; exact hhe i + · rw [hot 1 (by decide)]; exact hsl) + (seqTransitionInput c2.input) (fun i => seqTransitionTape (c2.work i)) + (seqTransitionTape c2.output) + (by rw [hseq2_w, hseq2_i, hseq2_o] + exact ⟨hwf2.1 0, hwf2.2 0, hdh2_le, hinp2, hout2, houth2, + fun i hne => ⟨by simp only [Tape.read]; exact hwf2.2 i _ (hheads2 i), hheads2 i⟩, + hdesc2, hstate2, hq_eq2, hq_ne2, hoh2, hoc02, hons2, hwf2, + hinp2, hout2, houth2, hheads2, hsh2_le⟩) + obtain ⟨hhead3, hdesc3, hstate3, hq_eq3, hq_ne3, hoh3, hoc03, hons3, hwf3, + hinp3, hout3, houth3, hheads3, hsh3_le⟩ := hpost3 + -- seqTransition identity + have hseq3_w := seqTransition_work_id hwf3 hheads3 + have hseq3_i := seqTransitionInput_id hinp3 + have hseq3_o := seqTransitionTape_id hout3 houth3 + -- ── Phase 4: rewindWorkTM 1 (state tape) ─────────────────────────── + obtain ⟨c4, t4, ht4, hreach4, hhalt4, hpost4⟩ := + rewindWorkTM_rich_hoareTime (1 : Fin 4) (k + 1) + (P := fun inp' work' out' => + descOnTape desc (work' 0) ∧ stateOnTapeAt k q (work' 1) ∧ + (q = e tm.qhalt → out'.cells 1 = Γ.one) ∧ + (q ≠ e tm.qhalt → out'.cells 1 = Γ.zero) ∧ + out'.head = 1 ∧ (work' 0).head = 1 ∧ WorkTapesWF work') + (by -- Frame preservation for rewind 1: P is stable under rewind of tape 1 + intro _ w0 o0 _ w1 o1 hP hc1 hh1 hot heq_i heq_oc heq_oh + obtain ⟨hd, hs, hqe, hqn, ho, hdh', hw⟩ := hP + refine ⟨?_, ⟨?_, ?_, ?_⟩, ?_, ?_, ?_, ?_, ⟨?_, ?_⟩⟩ + · rw [hot 0 (by decide)]; exact hd + · rw [hc1]; exact hs.1 + · intro j hj; rw [hc1]; exact hs.2.1 j hj + · rw [hc1]; exact hs.2.2 + · intro h; rw [heq_oc]; exact hqe h + · intro h; rw [heq_oc]; exact hqn h + · rw [heq_oh]; exact ho + · rw [hot 0 (by decide)]; exact hdh' + · intro i; by_cases h : i = 1 + · subst h; rw [hc1]; exact hw.1 1 + · rw [hot i h]; exact hw.1 i + · intro i j hj; by_cases h : i = 1 + · subst h; rw [hc1]; exact hw.2 1 j hj + · rw [hot i h]; exact hw.2 i j hj) + (seqTransitionInput c3.input) (fun i => seqTransitionTape (c3.work i)) + (seqTransitionTape c3.output) + (by rw [hseq3_w, hseq3_i, hseq3_o] + exact ⟨hwf3.1 1, hwf3.2 1, hsh3_le, hinp3, hout3, houth3, + fun i hne => ⟨by simp only [Tape.read]; exact hwf3.2 i _ (hheads3 i), hheads3 i⟩, + hdesc3, hstate3, hq_eq3, hq_ne3, hoh3, hhead3, hwf3⟩) + obtain ⟨hhead4, hdesc4, hstate4, hq_eq4, hq_ne4, hoh4, hdh4, hwf4⟩ := hpost4 + -- ── Compose reachesIn chains via seqTM_full_simulation ───────────── + have hsim := seqTM_full_simulation skipToQhaltTM + (seqTM compareWriteTM (seqTM (rewindWorkTM (0 : Fin 4)) (rewindWorkTM (1 : Fin 4)))) + hreach1 hhalt1 + (seqTM_full_simulation compareWriteTM + (seqTM (rewindWorkTM (0 : Fin 4)) (rewindWorkTM (1 : Fin 4))) + hreach2 hhalt2 + (seqTM_full_simulation (rewindWorkTM (0 : Fin 4)) (rewindWorkTM (1 : Fin 4)) + hreach3 hhalt3 hreach4)) + refine ⟨_, t1 + 1 + (t2 + 1 + (t3 + 1 + t4)), by omega, hsim, ?_, ?_⟩ + · -- halted + show utmCheckHaltTM.halted _ + simp only [utmCheckHaltTM] + rw [phase2Wrap_halted, phase2Wrap_halted, phase2Wrap_halted]; exact hhalt4 + · exact ⟨hdesc4, hstate4, hq_eq4, hq_ne4, hoh4, hdh4, hhead4, hwf4⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/Defs.lean b/Complexitylib/Models/TuringMachine/UTM/Defs.lean new file mode 100644 index 0000000..1c651d0 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/Defs.lean @@ -0,0 +1,376 @@ +import Complexitylib.Models.TuringMachine + +/-! +# UTM Foundation: State Normalization + +This file provides state normalization for Turing machines, converting any +`TM n` with finite state type `Q` to use states `Fin (Fintype.card Q)`. + +## Main definitions + +- `TM.normalize` — convert any `TM n` to use states `Fin (Fintype.card Q)` +- `TM.normalizeCfg` — embed a config into the normalized state space +- `TM.normalize_step_comm` — stepping commutes with normalization +- `TM.normalize_decidesInTime` — behavioral equivalence + +## Design + +Normalization is needed because the UTM must decode an arbitrary TM from its +binary description. By normalizing states to `Fin k`, we can represent states +as binary numbers of known width. +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- State normalization +-- ════════════════════════════════════════════════════════════════════════ + +/-- The canonical equivalence between a TM's states and `Fin (Fintype.card Q)`. -/ +noncomputable def stateEquiv (tm : TM n) : tm.Q ≃ Fin (Fintype.card tm.Q) := + @Fintype.equivFin tm.Q tm.finQ + +/-- The canonical equivalence cast to `Fin k` given `k = Fintype.card Q`. + This is the single source of truth for state ↔ index mapping in the UTM. -/ +noncomputable def stateEquivK (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) : + tm.Q ≃ Fin k := + hk ▸ tm.stateEquiv + +/-- `stateEquivK` agrees with `stateEquiv` on values. + This discharges `he_val` hypotheses in CheckHaltInternal. -/ +theorem stateEquivK_val (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) + (q : tm.Q) : (tm.stateEquivK hk q).val = (tm.stateEquiv q).val := by + subst hk; rfl + +/-- Normalize a TM's state type to `Fin (Fintype.card Q)` via the canonical + equivalence. This preserves all computational behavior. + Noncomputable because `Fintype.equivFin` uses choice. -/ +noncomputable def normalize (tm : TM n) : TM n where + Q := Fin (@Fintype.card tm.Q tm.finQ) + qstart := tm.stateEquiv tm.qstart + qhalt := tm.stateEquiv tm.qhalt + δ := fun q iHead wHeads oHead => + let (q', wW, oW, iD, wD, oD) := tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead + (tm.stateEquiv q', wW, oW, iD, wD, oD) + δ_right_of_start := fun q iHead wHeads oHead => + tm.δ_right_of_start (tm.stateEquiv.symm q) iHead wHeads oHead + +/-- Configuration embedding: map a config with original states to normalized states. -/ +noncomputable def normalizeCfg (tm : TM n) (c : Cfg n tm.Q) : Cfg n (tm.normalize.Q) where + state := tm.stateEquiv c.state + input := c.input + work := c.work + output := c.output + +/-- Stepping the normalized TM commutes with the state equivalence. -/ +theorem normalize_step_comm (tm : TM n) (c : Cfg n tm.Q) : + tm.normalize.step (tm.normalizeCfg c) = + (tm.step c).map tm.normalizeCfg := by + simp only [step, normalize, normalizeCfg] + by_cases h : c.state = tm.qhalt + · simp [h, stateEquiv] + · have hne : tm.stateEquiv c.state ≠ tm.stateEquiv tm.qhalt := by + intro heq; exact h (tm.stateEquiv.injective heq) + simp only [h, hne, ↓reduceIte, Option.map, Equiv.symm_apply_apply, normalizeCfg] + +/-- Multi-step simulation: normalized TM mirrors original TM. -/ +theorem normalize_reachesIn (tm : TM n) {t : ℕ} {c c' : Cfg n tm.Q} + (h : tm.reachesIn t c c') : + tm.normalize.reachesIn t (tm.normalizeCfg c) (tm.normalizeCfg c') := by + induction h with + | zero => exact .zero + | step hstep _ ih => + exact .step (by rw [normalize_step_comm, hstep]; rfl) ih + +/-- Halting is preserved by normalization. -/ +theorem normalize_halted (tm : TM n) (c : Cfg n tm.Q) : + tm.normalize.halted (tm.normalizeCfg c) ↔ tm.halted c := by + simp only [halted, Cfg.isHalted, normalizeCfg, normalize, stateEquiv] + constructor + · intro h; exact tm.stateEquiv.injective h + · intro h; rw [h] + +/-- Output is preserved by normalization. -/ +theorem normalize_output (tm : TM n) (c : Cfg n tm.Q) : + (tm.normalizeCfg c).output = c.output := rfl + +/-- The initial config normalizes correctly. -/ +theorem normalize_initCfg (tm : TM n) (x : List Bool) : + tm.normalizeCfg (tm.initCfg x) = tm.normalize.initCfg x := by + simp [normalizeCfg, initCfg, Cfg.init, normalize] + +/-- Normalized TM decides the same language in the same time. -/ +theorem normalize_decidesInTime (tm : TM n) {L : Language} {T : ℕ → ℕ} + (h : tm.DecidesInTime L T) : + tm.normalize.DecidesInTime L T := by + intro x + obtain ⟨c', t, ht, hreach, hhalt, hmem, hnmem⟩ := h x + refine ⟨tm.normalizeCfg c', t, ht, ?_, ?_, ?_, ?_⟩ + · rw [← normalize_initCfg]; exact normalize_reachesIn tm hreach + · rwa [normalize_halted] + · intro hx; rw [normalize_output]; exact hmem hx + · intro hx; rw [normalize_output]; exact hnmem hx + +end TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Binary encoding primitives +-- ════════════════════════════════════════════════════════════════════════ + +/-- Encode a tape symbol as 2 bits: 0→00, 1→01, □→10, ▷→11. -/ +def Γ.encode : Γ → List Bool + | .zero => [false, false] + | .one => [false, true] + | .blank => [true, false] + | .start => [true, true] + +/-- Decode 2 bits back to a tape symbol. -/ +def Γ.decode : List Bool → Option Γ + | [false, false] => some .zero + | [false, true] => some .one + | [true, false] => some .blank + | [true, true] => some .start + | _ => none + +/-- Encode a write symbol as 2 bits: 0→00, 1→01, □→10. -/ +def Γw.encode : Γw → List Bool + | .zero => [false, false] + | .one => [false, true] + | .blank => [true, false] + +/-- Encode a direction as 2 bits: L→00, R→01, S→10. -/ +def Dir3.encode : Dir3 → List Bool + | .left => [false, false] + | .right => [false, true] + | .stay => [true, false] + +theorem Γ.encode_length (g : Γ) : g.encode.length = 2 := by cases g <;> rfl +theorem Γw.encode_length (g : Γw) : g.encode.length = 2 := by cases g <;> rfl +theorem Dir3.encode_length (d : Dir3) : d.encode.length = 2 := by cases d <;> rfl + +/-- Roundtrip: decode ∘ encode = some. -/ +theorem Γ.decode_encode (g : Γ) : Γ.decode (Γ.encode g) = some g := by + cases g <;> rfl + +/-- Γ encoding is injective. -/ +theorem Γ.encode_injective : Function.Injective Γ.encode := by + intro a b h; cases a <;> cases b <;> simp_all [Γ.encode] + +-- ════════════════════════════════════════════════════════════════════════ +-- Fixed-width binary encoding of natural numbers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Encode a natural number as a big-endian binary list of exactly `w` bits. + Numbers larger than `2^w - 1` are truncated (mod 2^w). -/ +def Nat.toBits : ℕ → ℕ → List Bool + | 0, _ => [] + | w + 1, val => (val / 2 ^ w % 2 == 1) :: Nat.toBits w val + +theorem Nat.toBits_length : ∀ (w val : ℕ), (Nat.toBits w val).length = w + | 0, _ => rfl + | w + 1, val => by simp [Nat.toBits, Nat.toBits_length w] + +/-- Decode a big-endian binary list to a natural number. -/ +def Nat.fromBits : List Bool → ℕ + | [] => 0 + | b :: rest => (if b then 1 else 0) * 2 ^ rest.length + Nat.fromBits rest + +-- ════════════════════════════════════════════════════════════════════════ +-- Enumeration of all Fin n → Γ functions +-- ════════════════════════════════════════════════════════════════════════ + +/-- All 4 tape symbols in canonical order. -/ +def allΓ : List Γ := [.zero, .one, .blank, .start] + +/-- Enumerate all functions `Fin n → Γ` in canonical (lexicographic) order. -/ +def allΓFuncs : (n : ℕ) → List (Fin n → Γ) + | 0 => [Fin.elim0] + | n + 1 => (allΓFuncs n).flatMap fun f => + allΓ.map fun g => + fun i : Fin (n + 1) => + if h : i.val < n then f ⟨i.val, h⟩ else g + +-- ════════════════════════════════════════════════════════════════════════ +-- Full TM encoding +-- ════════════════════════════════════════════════════════════════════════ + +namespace TMEncoding + +/-- Encode a single self-describing transition entry: includes both the input + pattern (for matching) and the output (for applying the transition). + + Format: + - Input pattern: q (one-hot, k bits) ++ iHead (2b) ++ wHeads (2n bits) ++ oHead (2b) + - Separator: [false] (1 bit) + - Output: q' (one-hot, k bits) ++ wWrites (2n bits) ++ oWrite (2b) + ++ iDir (2b) ++ wDirs (2n bits) ++ oDir (2b) + + Total width per entry: 2k + 4n + 4 + 1 + k + 4n + 6 = 3k + 8n + 11 bits. + + The input pattern enables linear-scan lookup: the UTM can compare the + current (state, symbols) against each entry's prefix without needing + index arithmetic. -/ +def encodeEntry (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) + (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) : List Bool := + -- Input pattern + (List.finRange k).map (fun i => i == q) ++ + iH.encode ++ + (List.finRange n).flatMap (fun i => (wH i).encode) ++ + oH.encode ++ + -- Separator + [false] ++ + -- Output + (List.finRange k).map (fun i => i == q') ++ + (List.finRange n).flatMap (fun i => (wW i).encode) ++ + oW.encode ++ iD.encode ++ + (List.finRange n).flatMap (fun i => (wD i).encode) ++ + oD.encode + +/-- Encode just the input pattern portion of a self-describing entry: + q (one-hot, k bits) ++ iHead (2b) ++ wHeads (2n bits) ++ oHead (2b). -/ +def encodeInputPattern (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) : List Bool := + (List.finRange k).map (fun i => i == q) ++ + iH.encode ++ + (List.finRange n).flatMap (fun i => (wH i).encode) ++ + oH.encode + +/-- Encode just the transition output portion of a self-describing entry: + q' (one-hot, k bits) ++ wWrites (2n bits) ++ oWrite (2b) + ++ iDir (2b) ++ wDirs (2n bits) ++ oDir (2b). -/ +def encodeTransOutput (k n : ℕ) (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) : List Bool := + (List.finRange k).map (fun i => i == q') ++ + (List.finRange n).flatMap (fun i => (wW i).encode) ++ + oW.encode ++ iD.encode ++ + (List.finRange n).flatMap (fun i => (wD i).encode) ++ + oD.encode + +/-- Width of the input pattern portion of a self-describing entry. -/ +def inputPatternWidth (k n : ℕ) : ℕ := k + 2 + 2 * n + 2 + +/-- Width of the output portion of a self-describing entry. -/ +def outputWidth (k n : ℕ) : ℕ := k + 2 * n + 2 + 2 + 2 * n + 2 + +/-- Total width of one self-describing entry (input + separator + output). -/ +def entryWidth (k n : ℕ) : ℕ := inputPatternWidth k n + 1 + outputWidth k n + +/-- Encode the full transition table using self-describing entries. + Each entry includes its input pattern for linear-scan lookup. -/ +noncomputable def encodeTransTable {n : ℕ} (tm : TM n) + (e : tm.Q ≃ Fin (Fintype.card tm.Q)) : List Bool := + let k := Fintype.card tm.Q + (List.finRange k).flatMap fun q => + allΓ.flatMap fun iH => + (allΓFuncs n).flatMap fun wH => + allΓ.flatMap fun oH => + let (q', wW, oW, iD, wD, oD) := tm.δ (e.symm q) iH wH oH + encodeEntry k n q iH wH oH (e q') wW oW iD wD oD + +/-- Encode a state as a one-hot pattern (k bits). + Bit i is true iff i = e(q). -/ +noncomputable def encodeStateOneHot {n : ℕ} (tm : TM n) + (e : tm.Q ≃ Fin (Fintype.card tm.Q)) (q : tm.Q) : List Bool := + let k := Fintype.card tm.Q + (List.finRange k).map (fun i => i == e q) + +/-- Full TM encoding with self-describing entries. + Header: + - k ones + [false] (number of states in unary) + - n ones + [false] (number of work tapes in unary) + - qhalt one-hot (k bits) + [false] (halt state position) + - qstart one-hot (k bits) + [false] (start state position) + Body: self-describing transition table entries in canonical order. -/ +noncomputable def encodeTM {n : ℕ} (tm : TM n) : List Bool := + let k := @Fintype.card tm.Q tm.finQ + let e := tm.stateEquiv + List.replicate k true ++ [false] ++ + List.replicate n true ++ [false] ++ + encodeStateOneHot tm e tm.qhalt ++ [false] ++ + encodeStateOneHot tm e tm.qstart ++ [false] ++ + encodeTransTable tm e + +/-- Offset in the description where the qhalt one-hot starts (0-indexed into bits). -/ +def qhaltOffset (k n : ℕ) : ℕ := k + 1 + n + 1 + +/-- Offset where the qstart one-hot starts. -/ +def qstartOffset (k n : ℕ) : ℕ := qhaltOffset k n + k + 1 + +/-- Offset where the transition table starts. -/ +def tableOffset (k n : ℕ) : ℕ := qstartOffset k n + k + 1 + +/-- Length of the description for a normalized TM with k states and n work tapes. -/ +noncomputable def descLen {n : ℕ} (tm : TM n) : ℕ := + (encodeTM tm).length + +end TMEncoding + +-- ════════════════════════════════════════════════════════════════════════ +-- UTM input encoding +-- ════════════════════════════════════════════════════════════════════════ + +/-- Encode the UTM's input as a `List Γ`: TM description bits (mapped through + `Γ.ofBool`), then a `Γ.blank` separator, then the input x (also mapped + through `Γ.ofBool`). + + The description and x both use only `Γ.zero` and `Γ.one`, so the `Γ.blank` + separator is unambiguous. The `copyInputToWorkTM` machine (which copies + input until reading `Γ.blank`) naturally stops at the separator, giving us + a clean split between desc and x on the work tapes. + + Input tape layout (via `initTape`): + ``` + cell 0: ▷ + cells 1..descLen: desc[0] .. desc[L-1] (Γ.ofBool) + cell descLen+1: Γ.blank (separator) + cells descLen+2..descLen+1+|x|: x[0] .. x[|x|-1] (Γ.ofBool) + cells descLen+2+|x|..: Γ.blank (initTape default) + ``` -/ +noncomputable def encodeUTMInput {n : ℕ} (tm : TM n) (x : List Bool) : List Γ := + (TMEncoding.encodeTM tm).map Γ.ofBool ++ [Γ.blank] ++ x.map Γ.ofBool + +-- ════════════════════════════════════════════════════════════════════════ +-- Super-cell encoding definitions (for simulation tape) +-- ════════════════════════════════════════════════════════════════════════ + +namespace SuperCell + +/-- Width of a super-cell: 3 cells per simulated tape (1 head marker + 2 symbol bits). + The simulated machine has n work tapes + 1 input tape + 1 output tape = n + 2 tapes. -/ +def width (numTapes : ℕ) : ℕ := 3 * numTapes + +/-- Total number of simulated tapes: n work tapes + input + output. -/ +def totalTapes (n : ℕ) : ℕ := n + 2 + +/-- Encode a Γ symbol as two cells (high bit, low bit) on the simulation tape. + + Design: `Γ.blank` maps to `(Γ.blank, Γ.blank)` so that uninitialized UTM + sim tape cells (which default to `Γ.blank`) automatically represent + "blank content". This enables `superCellsCorrect` to quantify over all + positions without requiring the init machine to write infinitely many cells. -/ +def symToCellPair (g : Γ) : Γ × Γ := + match g with + | .zero => (.zero, .zero) + | .one => (.zero, .one) + | .blank => (.blank, .blank) + | .start => (.one, .one) + +/-- Decode two cells back to a Γ symbol. -/ +def cellPairToSym : Γ → Γ → Option Γ + | .zero, .zero => some .zero + | .zero, .one => some .one + | .blank, .blank => some .blank + | .one, .one => some .start + | _, _ => none + +/-- The base position on the simulation tape for position `pos` of simulated tape `tapeIdx`, + given `numTapes` total simulated tapes. + Each simulated position maps to a super-cell of width `3 * numTapes`. + Within a super-cell, tape `tapeIdx` occupies offsets `3 * tapeIdx`, `3 * tapeIdx + 1`, + `3 * tapeIdx + 2` (head marker, sym_hi, sym_lo). -/ +def simTapeOffset (numTapes : ℕ) (pos : ℕ) (tapeIdx : ℕ) : ℕ := + 1 + pos * width numTapes + 3 * tapeIdx + +end SuperCell diff --git a/Complexitylib/Models/TuringMachine/UTM/ExtractOutput.lean b/Complexitylib/Models/TuringMachine/UTM/ExtractOutput.lean new file mode 100644 index 0000000..7858993 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/ExtractOutput.lean @@ -0,0 +1,797 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.ReadCurrent +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Mathlib.Data.Fintype.Prod + +/-! +# UTM Extract Output + +After the simulation loop terminates, extract the simulated output from the +super-cell encoding and write it to the real output tape. + +## Architecture + +The machine operates in three phases: + +1. **Rewind output**: Scan the output tape left to ▷, then move right to cell 1. +2. **Scan to output symbol**: Move the sim tape head right by a fixed distance + to reach the hi bit of the output tape's position-1 super-cell. The distance + is `3*(n+2) + 3*(n+1) + 1` cells from cell 1, computed as: one full super-cell + width (position 0) + tapes 0..n within position 1 + the head marker. +3. **Read and decode**: Read the 2 symbol cells (hi, lo), decode via + `SuperCell.cellPairToSym`, write to output cell 1. + +## Main results + +- `extractOutputTM` — the machine definition +- `extractOutputTM_hoareTime` — HoareTime spec: parametric in `simCfg` +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- State type +-- ════════════════════════════════════════════════════════════════════════ + +/-- Distance from sim tape cell 1 to the hi bit of the output tape's + position-1 super-cell. -/ +def extractSkipDist (n : ℕ) : ℕ := 3 * (n + 2) + 3 * (n + 1) - 1 + +/-- States for the extractOutput machine. -/ +inductive ExtractOutputQ (n : ℕ) where + /-- Rewind output tape left until ▷. -/ + | rewindOut + /-- Output at ▷, move right one step to cell 1. -/ + | rightOut + /-- Scan sim tape right, `rem` steps remaining until hi bit. -/ + | scanSim (rem : Fin (extractSkipDist n + 1)) + /-- At hi bit position on sim tape. Read it. -/ + | readHi + /-- At lo bit position. Remembering hi value. -/ + | readLo (hi : Γ) + /-- Decode (hi, lo) → symbol, write to output. -/ + | writeOut (hi lo : Γ) + /-- Halt. -/ + | done + deriving DecidableEq + +private instance : Fintype (ExtractOutputQ n) where + elems := + {.rewindOut, .rightOut, .readHi, .done} ∪ + (Finset.univ.image fun (i : Fin (extractSkipDist n + 1)) => + ExtractOutputQ.scanSim i) ∪ + (Finset.univ.image fun (g : Γ) => ExtractOutputQ.readLo g) ∪ + (Finset.univ.image fun (p : Γ × Γ) => ExtractOutputQ.writeOut p.1 p.2) + complete x := by + cases x with + | rewindOut => simp [Finset.mem_union, Finset.mem_insert] + | rightOut => simp [Finset.mem_union, Finset.mem_insert] + | readHi => simp [Finset.mem_union, Finset.mem_insert] + | done => simp [Finset.mem_union, Finset.mem_insert] + | scanSim i => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; right; exact ⟨i, rfl⟩ + | readLo g => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; right; exact ⟨g, rfl⟩ + | writeOut hi lo => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, + Prod.exists] + right; exact ⟨hi, lo, rfl⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Machine definition +-- ════════════════════════════════════════════════════════════════════════ + +/-- Extract the simulated output and write it to the real output tape. + + Phase 1: Rewind output tape to ▷, then step right to cell 1. + Phase 2: Scan sim tape right by `extractSkipDist n` cells to reach the + output tape's position-1 hi bit. + Phase 3: Read hi and lo bits, decode, write to output cell 1. -/ +def extractOutputTM : TM 4 where + Q := ExtractOutputQ n + qstart := .rewindOut + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .rewindOut => + if oHead = Γ.start then + -- At ▷, move right to cell 1 + (.rightOut, + fun i => readBackWrite (wHeads i), .blank, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.right) + else + -- Move output left + (.rewindOut, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), moveLeftDir oHead) + | .rightOut => + -- Output is now at cell 1. Start scanning sim tape. + (.scanSim ⟨extractSkipDist n, by omega⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = utmSimTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .scanSim rem => + if h : rem.val = 0 then + -- Arrived at hi bit. Read it. + (.readHi, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = utmSimTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Keep scanning right on sim tape + (.scanSim ⟨rem.val - 1, by omega⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = utmSimTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .readHi => + -- At hi bit cell. Remember it, advance to lo bit. + (.readLo (wHeads utmSimTape), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, + idleDir iHead, + fun i => if i = utmSimTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .readLo hi => + -- At lo bit cell. Decode (hi, lo) and prepare to write. + (.writeOut hi (wHeads utmSimTape), + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .writeOut hi lo => + -- Write the decoded symbol to output cell 1. + let sym : Γw := match hi, lo with + | .zero, .zero => .zero -- Γ.zero + | .zero, .one => .one -- Γ.one + | .blank, .blank => .blank -- Γ.blank + | _, _ => .blank -- fallback (shouldn't occur for valid super-cells) + (.done, + fun i => readBackWrite (wHeads i), sym, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + have hros := fun (h : iHead = Γ.start) => idleDir_right_of_start h + have hrosW := fun (i : Fin 4) (h : wHeads i = Γ.start) => idleDir_right_of_start h + have hrosO := fun (h : oHead = Γ.start) => idleDir_right_of_start h + have simRos : ∀ i, wHeads i = Γ.start → + (if i = utmSimTape then Dir3.right else idleDir (wHeads i)) = Dir3.right := by + intro i hi; split <;> [rfl; exact idleDir_right_of_start hi] + match state with + | .rewindOut => + dsimp only []; split + · exact ⟨hros, fun _ => hrosW _, fun _ => rfl⟩ + · exact ⟨hros, fun _ => hrosW _, fun h => by subst h; rfl⟩ + | .rightOut => + dsimp only [] + exact ⟨hros, simRos, hrosO⟩ + | .scanSim rem => + dsimp only []; split + · exact ⟨hros, simRos, hrosO⟩ + · exact ⟨hros, simRos, hrosO⟩ + | .readHi => + dsimp only [] + exact ⟨hros, simRos, hrosO⟩ + | .readLo _ => + exact ⟨hros, fun _ => hrosW _, hrosO⟩ + | .writeOut _ _ => + exact ⟨hros, fun _ => hrosW _, hrosO⟩ + | .done => + exact ⟨hros, fun _ => hrosW _, hrosO⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- HoareTime specification +-- ════════════════════════════════════════════════════════════════════════ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase simulation lemmas +-- ════════════════════════════════════════════════════════════════════════ + +/-- During idle operation, a tape with head ≥ 1 and read ≠ start is preserved by + writeAndMove with readBackWrite and idleDir. -/ +private theorem idle_tape_preserve (t : Tape) (hns : t.read ≠ Γ.start) (hh : t.head ≥ 1) : + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · omega + · simp only [Tape.read] at hns ⊢ + have : (readBackWrite (t.cells t.head)).toΓ = t.cells t.head := by + cases h : t.cells t.head <;> simp_all [readBackWrite, Γw.toΓ] + rw [this, Function.update_eq_self] + +/-- Input tape is preserved by move with idleDir when read ≠ start. -/ +private theorem input_idle_preserve (t : Tape) (hns : t.read ≠ Γ.start) : + t.move (idleDir t.read) = t := by + simp only [Tape.move, idleDir, hns, ↓reduceIte] + +/-- superCellsCorrect implies sim tape cells ≥ 1 are never ▷. + All super-cell content uses only zero/one/blank. -/ +private theorem sim_cells_ne_start_of_scc {Q : Type} {simCfg : Cfg n Q} + {utmSim : Tape} (hscc : superCellsCorrect simCfg utmSim) + {j : ℕ} (hj : j ≥ 1) : utmSim.cells j ≠ Γ.start := by + obtain ⟨_, hinp, hwork, hout⟩ := hscc + -- Any cell within a correct super-cell is not Γ.start + have cell_ne_of_scc : ∀ {tapeIdx pos simHead : ℕ} {simSym : Γ}, + simTapeCellCorrect (n + 2) tapeIdx pos simHead simSym utmSim → + ∀ k, k < 3 → + utmSim.cells (SuperCell.simTapeOffset (n + 2) pos tapeIdx + k) ≠ Γ.start := by + intro tapeIdx pos simHead simSym h k hk + cases simSym <;> + dsimp only [simTapeCellCorrect, SuperCell.symToCellPair] at h <;> + obtain ⟨h0, h1, h2⟩ := h <;> + rcases (show k = 0 ∨ k = 1 ∨ k = 2 from by omega) with rfl | rfl | rfl + all_goals first + | (simp only [Nat.add_zero]; rw [h0]; split_ifs <;> decide) + | (rw [h1]; decide) + | (rw [h2]; decide) + -- Every cell ≥ 1 maps to some super-cell coordinate (pos, tapeIdx, offset) + -- Prove decomposition without set (to avoid omega issues with let bindings) + have hj_eq : j = SuperCell.simTapeOffset (n + 2) + ((j - 1) / (3 * (n + 2))) + (((j - 1) % (3 * (n + 2))) / 3) + + ((j - 1) % (3 * (n + 2))) % 3 := by + simp only [SuperCell.simTapeOffset, SuperCell.width] + have h1 := Nat.div_add_mod (j - 1) (3 * (n + 2)) + have h2 := Nat.div_add_mod ((j - 1) % (3 * (n + 2))) 3 + have hmc : (3 * (n + 2)) * ((j - 1) / (3 * (n + 2))) = + (j - 1) / (3 * (n + 2)) * (3 * (n + 2)) := Nat.mul_comm _ _ + rw [hmc] at h1 + omega + rw [hj_eq] + -- Prove bounds on coordinates + have hmod : (j - 1) % (3 * (n + 2)) < 3 * (n + 2) := Nat.mod_lt _ (by omega) + have htIdx : ((j - 1) % (3 * (n + 2))) / 3 < n + 2 := by + have := Nat.div_mul_le_self ((j - 1) % (3 * (n + 2))) 3; omega + have hoff : ((j - 1) % (3 * (n + 2))) % 3 < 3 := Nat.mod_lt _ (by omega) + -- Map tapeIdx to the right component of superCellsCorrect + by_cases h0 : ((j - 1) % (3 * (n + 2))) / 3 = 0 + · simp only [h0]; exact cell_ne_of_scc (hinp _) _ hoff + · by_cases hn : ((j - 1) % (3 * (n + 2))) / 3 = n + 1 + · simp only [hn]; exact cell_ne_of_scc (hout _) _ hoff + · have hscc' := hwork ⟨((j - 1) % (3 * (n + 2))) / 3 - 1, by omega⟩ + ((j - 1) / (3 * (n + 2))) + simp only [] at hscc' + rw [show ((j - 1) % (3 * (n + 2))) / 3 - 1 + 1 = + ((j - 1) % (3 * (n + 2))) / 3 from by omega] at hscc' + exact cell_ne_of_scc hscc' _ hoff + +/-- Phase 1: Rewind output tape from position h to position 1. + All work tapes with head ≥ 1 and read ≠ start are preserved. -/ +private theorem rewind_output_phase + (c : Cfg 4 (extractOutputTM (n := n)).Q) (h : ℕ) + (hstate : c.state = .rewindOut) + (hout_h : c.output.head = h) + (hout0 : c.output.cells 0 = Γ.start) + (hout_ns : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hsim_h : (c.work utmSimTape).head ≥ 1) + (hsim_ns : (c.work utmSimTape).read ≠ Γ.start) + (hinp_ns : c.input.read ≠ Γ.start) : + ∃ c₁, (extractOutputTM (n := n)).reachesIn (h + 1) c c₁ ∧ + c₁.state = .rightOut ∧ + c₁.output.head = 1 ∧ + c₁.output.cells = c.output.cells ∧ + (c₁.work utmSimTape).head = (c.work utmSimTape).head ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + c₁.input.read = c.input.read ∧ + c₁.input.head = c.input.head := by + induction h generalizing c with + | zero => + -- Output head at 0, reads Γ.start. One step to rightOut. + have hoRead : c.output.read = Γ.start := by + simp only [Tape.read, hout_h, hout0] + -- Build the step + have hstep : extractOutputTM.step c = some + { state := .rightOut + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read) + output := c.output.writeAndMove Γw.blank.toΓ Dir3.right } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hstate] at heq + · simp only [hstate] + refine ⟨_, TM.reachesIn.step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- output.head = 1 + simp only [Tape.writeAndMove, Tape.write, hout_h, Tape.move, ite_true] + · -- output.cells preserved + simp only [Tape.writeAndMove, Tape.write, hout_h, Tape.move, ite_true] + · -- sim tape head preserved + simp only [idle_tape_preserve _ hsim_ns hsim_h] + · -- sim tape cells preserved + simp only [idle_tape_preserve _ hsim_ns hsim_h] + · -- input.read preserved + unfold Tape.read + have hinp_ns' : c.input.cells c.input.head ≠ Γ.start := hinp_ns + simp only [Tape.move, idleDir, hinp_ns', ↓reduceIte] + · -- input.head preserved + simp only [Tape.move, idleDir, hinp_ns, ↓reduceIte] + | succ h' ih => + have hoRead : c.output.read ≠ Γ.start := by + simp only [Tape.read]; exact hout_ns _ (by omega) + have hinp_ns' : c.input.cells c.input.head ≠ Γ.start := hinp_ns + let c' : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .rewindOut + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ + (moveLeftDir c.output.read) } + have hstep : (extractOutputTM (n := n)).step c = some c' := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hstate] at heq + · simp only [hstate]; rfl + have hc'_work_sim : c'.work utmSimTape = c.work utmSimTape := + show (c.work utmSimTape).writeAndMove _ _ = _ from + idle_tape_preserve _ hsim_ns hsim_h + have hc'_inp : c'.input = c.input := by + show c.input.move (idleDir c.input.read) = c.input + simp only [Tape.move, idleDir, Tape.read, hinp_ns', ↓reduceIte] + have hout_head_ne0 : c.output.head ≠ 0 := by omega + have hc'_out_h : c'.output.head = h' := by + show (c.output.writeAndMove _ _).head = h' + simp only [Tape.writeAndMove, Tape.write, Tape.move, moveLeftDir, hoRead, ↓reduceIte] + split + · omega + · simp only [hout_h]; omega + have hc'_out_cells : c'.output.cells = c.output.cells := by + show (c.output.writeAndMove _ _).cells = c.output.cells + simp only [Tape.writeAndMove, Tape.write, hout_head_ne0, ↓reduceIte, Tape.move, + moveLeftDir, hoRead] + have : (readBackWrite c.output.read).toΓ = c.output.cells c.output.head := by + simp only [Tape.read] + cases hcell : c.output.cells c.output.head + · simp [readBackWrite, Γw.toΓ] + · simp [readBackWrite, Γw.toΓ] + · simp [readBackWrite, Γw.toΓ] + · exact absurd (show c.output.read = Γ.start from by simp [Tape.read, hcell]) hoRead + rw [this, Function.update_eq_self] + have hc'_out0 : c'.output.cells 0 = Γ.start := by rw [hc'_out_cells]; exact hout0 + have hc'_out_ns : ∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start := by + rw [hc'_out_cells]; exact hout_ns + have hc'_sim_h : (c'.work utmSimTape).head ≥ 1 := hc'_work_sim ▸ hsim_h + have hc'_sim_ns : (c'.work utmSimTape).read ≠ Γ.start := hc'_work_sim ▸ hsim_ns + have hc'_inp_ns : c'.input.read ≠ Γ.start := hc'_inp ▸ hinp_ns + obtain ⟨c₁, hreach, hc₁_state, hc₁_out_h, hc₁_out_cells, hc₁_sim_h, + hc₁_sim_cells, hc₁_inp_read, hc₁_inp_head⟩ := + ih c' rfl hc'_out_h hc'_out0 hc'_out_ns hc'_sim_h hc'_sim_ns hc'_inp_ns + refine ⟨c₁, ?_, hc₁_state, hc₁_out_h, ?_, ?_, ?_, ?_, ?_⟩ + · exact TM.reachesIn.step hstep hreach + · rw [hc₁_out_cells, hc'_out_cells] + · rw [hc₁_sim_h, hc'_work_sim] + · rw [hc₁_sim_cells, hc'_work_sim] + · rw [hc₁_inp_read]; exact congrArg Tape.read hc'_inp + · rw [hc₁_inp_head]; exact congrArg Tape.head hc'_inp + +/-- Phase 3: scanSim loop advances sim tape from position p to position p + d + 1. + Other tapes idle. -/ +private theorem scanSim_phase + (c : Cfg 4 (extractOutputTM (n := n)).Q) + (d : ℕ) (hd : d < extractSkipDist n + 1) + (hstate : c.state = .scanSim ⟨d, hd⟩) + (hsim_h : (c.work utmSimTape).head ≥ 1) + (hsim_ns : ∀ j, j ≥ 1 → (c.work utmSimTape).cells j ≠ Γ.start) + (hout_h : c.output.head ≥ 1) (hout_ns : c.output.read ≠ Γ.start) + (hinp_ns : c.input.read ≠ Γ.start) : + ∃ c₂, (extractOutputTM (n := n)).reachesIn (d + 1) c c₂ ∧ + c₂.state = .readHi ∧ + (c₂.work utmSimTape).head = (c.work utmSimTape).head + d + 1 ∧ + (c₂.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + c₂.output = c.output := by + induction d generalizing c with + | zero => + -- One step: scanSim ⟨0, _⟩ → readHi, sim moves right, others idle + -- Compute the step + have hstep : (extractOutputTM (n := n)).step c = some + { state := .readHi + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hstate] at heq + · simp only [hstate, Γw.toΓ, dite_true] + -- Sim tape read is not start (for readBackWrite preservation) + have hsim_read_ns : (c.work utmSimTape).read ≠ Γ.start := + hsim_ns _ hsim_h + refine ⟨_, TM.reachesIn.step hstep .zero, rfl, ?_, ?_, ?_⟩ + · -- sim tape head: advances by 1 + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hsim_read_ns ⊢ + split + · omega + · dsimp only [] + · -- sim tape cells: preserved + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hsim_read_ns ⊢ + split + · omega + · congr 1; rw [readBackWrite_toΓ_eq hsim_read_ns, Function.update_eq_self] + · -- output: preserved by idle + exact idle_tape_preserve _ hout_ns hout_h + | succ d' ih => + -- One step: scanSim ⟨d'+1, _⟩ → scanSim ⟨d', _⟩, sim moves right + have hstep : (extractOutputTM (n := n)).step c = some + { state := .scanSim ⟨d', by omega⟩ + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hstate] at heq + · simp only [hstate, Γw.toΓ, show (d' + 1 : ℕ) ≠ 0 from by omega, dite_false] + congr 2 + -- Name the intermediate config + set c' : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .scanSim ⟨d', by omega⟩ + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) } + -- Establish preconditions for IH on c' + have hsim_read_ns : (c.work utmSimTape).read ≠ Γ.start := hsim_ns _ hsim_h + -- c'.work utmSimTape.head = c.work utmSimTape.head + 1 + have hc'_sim_head_eq : (c'.work utmSimTape).head = (c.work utmSimTape).head + 1 := by + simp only [c', ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hsim_read_ns ⊢ + split + · omega + · dsimp only [] + have hc'_sim_h : (c'.work utmSimTape).head ≥ 1 := by omega + have hc'_sim_cells : (c'.work utmSimTape).cells = (c.work utmSimTape).cells := by + simp only [c', ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hsim_read_ns ⊢ + split + · omega + · congr 1; rw [readBackWrite_toΓ_eq hsim_read_ns, Function.update_eq_self] + have hc'_sim_ns : ∀ j, j ≥ 1 → (c'.work utmSimTape).cells j ≠ Γ.start := by + rw [hc'_sim_cells]; exact hsim_ns + have hc'_out : c'.output = c.output := idle_tape_preserve _ hout_ns hout_h + have hc'_out_h : c'.output.head ≥ 1 := by rw [hc'_out]; exact hout_h + have hc'_out_ns : c'.output.read ≠ Γ.start := by rw [hc'_out]; exact hout_ns + have hc'_inp_ns : c'.input.read ≠ Γ.start := by + simp only [c', Tape.read, Tape.move, idleDir] + have : c.input.cells c.input.head ≠ Γ.start := hinp_ns + simp only [this, ↓reduceIte]; exact this + -- Apply IH + obtain ⟨c₂, hreach, hc₂_state, hc₂_sim_h, hc₂_sim_cells, hc₂_out⟩ := + ih c' (by omega) rfl hc'_sim_h hc'_sim_ns hc'_out_h hc'_out_ns hc'_inp_ns + refine ⟨c₂, ?_, hc₂_state, ?_, ?_, ?_⟩ + · -- reachesIn composition: 1 step + (d' + 1) steps = d' + 1 + 1 steps + exact TM.reachesIn.step hstep hreach + · -- sim head: c'.head + d' + 1 = c.head + (d' + 1) + 1 + rw [hc₂_sim_h, hc'_sim_head_eq]; omega + · -- sim cells: preserved + rw [hc₂_sim_cells, hc'_sim_cells] + · -- output: preserved + rw [hc₂_out, hc'_out] + +/-- HoareTime specification for `extractOutputTM`. + + Parametric in `simCfg`. The postcondition says the real output cell 1 + matches the simulated output cell 1. + + **Pre**: Sim tape encodes `simCfg`; sim tape head at 1; output tape WF; + simulated output cell 1 is not ▷ (guaranteed by AB model where writes use Γw). + **Post**: Real output cell 1 = `simCfg.output.cells 1`. -/ +theorem extractOutputTM_hoareTime {Q : Type} [Fintype Q] [DecidableEq Q] + (simCfg : Cfg n Q) (B : ℕ) + (hout_sym : simCfg.output.cells 1 ≠ Γ.start) : + (extractOutputTM (n := n)).HoareTime + (fun inp work out => + superCellsCorrect simCfg (work utmSimTape) ∧ + (work utmSimTape).head = 1 ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≤ B ∧ + inp.read ≠ Γ.start) + (fun _inp _work out => + out.cells 1 = simCfg.output.cells 1) + (B + extractSkipDist n + 6) := by + -- Unfold HoareTime and introduce preconditions + intro inp work out ⟨hscc, hsim_h, hout0, hout_ns, hout_hB, hinp_ns⟩ + -- Derive sim tape properties from superCellsCorrect + have hsim_ns : ∀ j, j ≥ 1 → (work utmSimTape).cells j ≠ Γ.start := + fun j hj => sim_cells_ne_start_of_scc hscc hj + have hsim_read_ns : (work utmSimTape).read ≠ Γ.start := by + rw [Tape.read]; exact hsim_ns _ (by omega) + -- Set up the initial configuration + set c₀ : Cfg 4 (extractOutputTM (n := n)).Q := + { state := extractOutputTM.qstart, input := inp, work := work, output := out } + -- Phase 1: Rewind output tape (out.head + 1 steps) + have hc₀_state : c₀.state = .rewindOut := rfl + obtain ⟨c₁, hreach₁, hc₁_state, hc₁_out_h, hc₁_out_cells, hc₁_sim_h, + hc₁_sim_cells, hc₁_inp_read, hc₁_inp_head⟩ := + rewind_output_phase c₀ out.head hc₀_state rfl hout0 hout_ns + (by simp [c₀, hsim_h]) hsim_read_ns hinp_ns + -- Simplify c₀ references in c₁ properties + change (c₁.work utmSimTape).head = (work utmSimTape).head at hc₁_sim_h + change (c₁.work utmSimTape).cells = (work utmSimTape).cells at hc₁_sim_cells + change c₁.output.cells = out.cells at hc₁_out_cells + -- Derive c₁ properties + have hc₁_sim_h' : (c₁.work utmSimTape).head = 1 := by rw [hc₁_sim_h, hsim_h] + have hc₁_sim_h_ge : (c₁.work utmSimTape).head ≥ 1 := by omega + have hc₁_sim_read_ns : (c₁.work utmSimTape).read ≠ Γ.start := by + rw [Tape.read, hc₁_sim_cells]; exact hsim_ns _ (by omega) + have hc₁_out_ns : ∀ j, j ≥ 1 → c₁.output.cells j ≠ Γ.start := by + rw [hc₁_out_cells]; exact hout_ns + have hc₁_out_read_ns : c₁.output.read ≠ Γ.start := by + rw [Tape.read, hc₁_out_cells]; exact hout_ns _ (by omega) + have hc₁_inp_ns : c₁.input.read ≠ Γ.start := by rw [hc₁_inp_read]; exact hinp_ns + -- Phase 2: rightOut → scanSim (1 step) + have hstep₂ : (extractOutputTM (n := n)).step c₁ = some + { state := .scanSim ⟨extractSkipDist n, by omega⟩ + input := c₁.input.move (idleDir c₁.input.read) + work := fun i => (c₁.work i).writeAndMove (readBackWrite (c₁.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c₁.work i).read) + output := c₁.output.writeAndMove (readBackWrite c₁.output.read).toΓ + (idleDir c₁.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hc₁_state] at heq + · simp only [hc₁_state] + -- Name the config after the rightOut step + set c₂ : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .scanSim ⟨extractSkipDist n, by omega⟩ + input := c₁.input.move (idleDir c₁.input.read) + work := fun i => (c₁.work i).writeAndMove (readBackWrite (c₁.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c₁.work i).read) + output := c₁.output.writeAndMove (readBackWrite c₁.output.read).toΓ + (idleDir c₁.output.read) } + -- Establish c₂ properties + -- c₂.output = c₁.output (idle operation) + have hc₂_out : c₂.output = c₁.output := idle_tape_preserve _ hc₁_out_read_ns (by omega) + -- c₂.work utmSimTape: head advances by 1, cells preserved + have hc₂_sim_head : (c₂.work utmSimTape).head = (c₁.work utmSimTape).head + 1 := by + show ((c₁.work utmSimTape).writeAndMove _ _).head = _ + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] + split + · omega + · dsimp only [] + have hc₂_sim_cells : (c₂.work utmSimTape).cells = (c₁.work utmSimTape).cells := by + show ((c₁.work utmSimTape).writeAndMove _ _).cells = _ + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hc₁_sim_read_ns ⊢ + split + · omega + · congr 1; rw [readBackWrite_toΓ_eq hc₁_sim_read_ns, Function.update_eq_self] + have hc₂_sim_h_ge : (c₂.work utmSimTape).head ≥ 1 := by omega + have hc₂_sim_ns : ∀ j, j ≥ 1 → (c₂.work utmSimTape).cells j ≠ Γ.start := by + rw [hc₂_sim_cells, hc₁_sim_cells]; exact hsim_ns + have hc₂_out_h : c₂.output.head ≥ 1 := by rw [hc₂_out]; omega + have hc₂_out_read_ns : c₂.output.read ≠ Γ.start := by rw [hc₂_out]; exact hc₁_out_read_ns + have hc₂_inp_ns : c₂.input.read ≠ Γ.start := by + show (c₁.input.move (idleDir c₁.input.read)).read ≠ _ + rw [input_idle_preserve _ hc₁_inp_ns]; exact hc₁_inp_ns + -- Phase 3: scanSim loop (extractSkipDist n + 1 steps) + obtain ⟨c₃, hreach₃, hc₃_state, hc₃_sim_h, hc₃_sim_cells, hc₃_out⟩ := + scanSim_phase c₂ (extractSkipDist n) (by omega) rfl + hc₂_sim_h_ge hc₂_sim_ns hc₂_out_h hc₂_out_read_ns hc₂_inp_ns + -- Compute c₃ sim tape head position + -- c₃.work utmSimTape.head = 2 + extractSkipDist n + 1 = extractSkipDist n + 3 + have hc₃_sim_h_val : (c₃.work utmSimTape).head = extractSkipDist n + 3 := by + rw [hc₃_sim_h, hc₂_sim_head, hc₁_sim_h']; omega + -- The sim tape cells are the original work tape cells + have hc₃_sim_cells_orig : (c₃.work utmSimTape).cells = (work utmSimTape).cells := by + rw [hc₃_sim_cells, hc₂_sim_cells, hc₁_sim_cells] + -- Key: extractSkipDist n + 3 = simTapeOffset (n+2) 1 (n+1) + 1 + -- simTapeOffset (n+2) 1 (n+1) = 1 + 1 * width(n+2) + 3*(n+1) = 1 + 3*(n+2) + 3*(n+1) + -- extractSkipDist n = 3*(n+2) + 3*(n+1) - 1 + -- extractSkipDist n + 3 = 3*(n+2) + 3*(n+1) + 2 = (1 + 3*(n+2) + 3*(n+1)) + 1 + have hbase_eq : SuperCell.simTapeOffset (n + 2) 1 (n + 1) = extractSkipDist n + 2 := by + simp only [SuperCell.simTapeOffset, SuperCell.width, extractSkipDist] + omega + -- Get the output tape's super-cell correctness + have hscc_out := hscc.2.2.2 + have hscc_out1 := hscc_out 1 + -- Extract the hi and lo values from the super-cell encoding + set outSym := simCfg.output.cells 1 with hOutSym_def + set hiLo := SuperCell.symToCellPair outSym + have hscc_out1' : simTapeCellCorrect (n + 2) (n + 1) 1 + simCfg.output.head outSym (work utmSimTape) := hscc_out1 + -- The hi bit is at base + 1 = extractSkipDist n + 3 + have hhi_cell : (work utmSimTape).cells (extractSkipDist n + 3) = hiLo.1 := by + have h := hscc_out1'.2.1 + have hoff : SuperCell.simTapeOffset (n + 2) 1 (n + 1) + 1 = extractSkipDist n + 3 := by + rw [hbase_eq] + rw [hoff] at h; exact h + -- The lo bit is at base + 2 = extractSkipDist n + 4 + have hlo_cell : (work utmSimTape).cells (extractSkipDist n + 4) = hiLo.2 := by + have h := hscc_out1'.2.2 + have hoff : SuperCell.simTapeOffset (n + 2) 1 (n + 1) + 2 = extractSkipDist n + 4 := by + rw [hbase_eq] + rw [hoff] at h; exact h + -- c₃.work utmSimTape reads the hi bit + have hc₃_read : (c₃.work utmSimTape).read = hiLo.1 := by + rw [Tape.read, hc₃_sim_cells_orig, hc₃_sim_h_val, hhi_cell] + -- c₃ sim read ≠ start (hi bit of any non-start symbol is not start) + have hc₃_sim_ns' : ∀ j, j ≥ 1 → (c₃.work utmSimTape).cells j ≠ Γ.start := by + rw [hc₃_sim_cells_orig]; exact hsim_ns + have hc₃_sim_read_ns : (c₃.work utmSimTape).read ≠ Γ.start := + hc₃_sim_ns' _ (by omega) + -- c₃ output properties (carried through from c₁) + have hc₃_out_eq : c₃.output = c₁.output := by rw [hc₃_out, hc₂_out] + have hc₃_out_h : c₃.output.head ≥ 1 := by rw [hc₃_out_eq]; omega + have hc₃_out_read_ns : c₃.output.read ≠ Γ.start := by + rw [hc₃_out_eq]; exact hc₁_out_read_ns + -- Phase 4: readHi → readLo (1 step) + -- The machine reads c₃.work utmSimTape.read = hiLo.1 and goes to readLo(hiLo.1) + have hstep₄ : (extractOutputTM (n := n)).step c₃ = some + { state := .readLo (c₃.work utmSimTape).read + input := c₃.input.move (idleDir c₃.input.read) + work := fun i => (c₃.work i).writeAndMove (readBackWrite (c₃.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c₃.work i).read) + output := c₃.output.writeAndMove (readBackWrite c₃.output.read).toΓ + (idleDir c₃.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hc₃_state] at heq + · simp only [hc₃_state] + -- Name the config after readHi + set c₄ : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .readLo (c₃.work utmSimTape).read + input := c₃.input.move (idleDir c₃.input.read) + work := fun i => (c₃.work i).writeAndMove (readBackWrite (c₃.work i).read).toΓ + (if i = utmSimTape then Dir3.right else idleDir (c₃.work i).read) + output := c₃.output.writeAndMove (readBackWrite c₃.output.read).toΓ + (idleDir c₃.output.read) } + -- c₄ properties + have hc₄_out : c₄.output = c₃.output := idle_tape_preserve _ hc₃_out_read_ns hc₃_out_h + -- c₄ sim tape: head advances, cells preserved + have hc₄_sim_head : (c₄.work utmSimTape).head = (c₃.work utmSimTape).head + 1 := by + show ((c₃.work utmSimTape).writeAndMove _ _).head = _ + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hc₃_sim_read_ns ⊢ + split + · omega + · dsimp only [] + have hc₄_sim_cells : (c₄.work utmSimTape).cells = (c₃.work utmSimTape).cells := by + show ((c₃.work utmSimTape).writeAndMove _ _).cells = _ + simp only [ite_true, Tape.writeAndMove, Tape.write, Tape.move, Tape.read] at hc₃_sim_read_ns ⊢ + split + · omega + · congr 1; rw [readBackWrite_toΓ_eq hc₃_sim_read_ns, Function.update_eq_self] + -- c₄ sim tape reads the lo bit + have hc₄_sim_h_val : (c₄.work utmSimTape).head = extractSkipDist n + 4 := by + rw [hc₄_sim_head, hc₃_sim_h_val] + have hc₄_read : (c₄.work utmSimTape).read = hiLo.2 := by + rw [Tape.read, hc₄_sim_cells, hc₃_sim_cells_orig, hc₄_sim_h_val, hlo_cell] + -- c₄ state has hi = hiLo.1 + have hc₄_state : c₄.state = .readLo hiLo.1 := by + show ExtractOutputQ.readLo (c₃.work utmSimTape).read = .readLo hiLo.1 + rw [hc₃_read] + -- Phase 5: readLo → writeOut (1 step) + have hstep₅ : (extractOutputTM (n := n)).step c₄ = some + { state := .writeOut hiLo.1 (c₄.work utmSimTape).read + input := c₄.input.move (idleDir c₄.input.read) + work := fun i => (c₄.work i).writeAndMove (readBackWrite (c₄.work i).read).toΓ + (idleDir (c₄.work i).read) + output := c₄.output.writeAndMove (readBackWrite c₄.output.read).toΓ + (idleDir c₄.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hc₄_state] at heq + · simp only [hc₄_state] + -- Name the config after readLo + set c₅ : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .writeOut hiLo.1 (c₄.work utmSimTape).read + input := c₄.input.move (idleDir c₄.input.read) + work := fun i => (c₄.work i).writeAndMove (readBackWrite (c₄.work i).read).toΓ + (idleDir (c₄.work i).read) + output := c₄.output.writeAndMove (readBackWrite c₄.output.read).toΓ + (idleDir c₄.output.read) } + -- c₅ state: writeOut hiLo.1 hiLo.2 + have hc₅_state : c₅.state = .writeOut hiLo.1 hiLo.2 := by + show ExtractOutputQ.writeOut hiLo.1 (c₄.work utmSimTape).read = _ + rw [hc₄_read] + -- c₅ output = c₄.output (idle) + have hc₅_out : c₅.output = c₄.output := by + show c₄.output.writeAndMove _ _ = c₄.output + rw [hc₄_out, hc₃_out_eq] + exact idle_tape_preserve _ hc₁_out_read_ns (by omega) + -- Phase 6: writeOut → done (1 step) + -- The decoded symbol from (hiLo.1, hiLo.2) is written to the output tape + -- The machine computes: match hiLo.1, hiLo.2 with ... + -- For outSym: + -- zero → (zero,zero) → match zero,zero → Γw.zero → Γ.zero + -- one → (zero,one) → match zero,one → Γw.one → Γ.one + -- blank→ (blank,blank)→ match blank,blank→ Γw.blank→ Γ.blank + -- start→ impossible (hout_sym) + have hstep₆ : (extractOutputTM (n := n)).step c₅ = some + { state := .done + input := c₅.input.move (idleDir c₅.input.read) + work := fun i => (c₅.work i).writeAndMove (readBackWrite (c₅.work i).read).toΓ + (idleDir (c₅.work i).read) + output := c₅.output.writeAndMove + (match hiLo.1, hiLo.2 with + | .zero, .zero => Γw.zero + | .zero, .one => Γw.one + | .blank, .blank => Γw.blank + | _, _ => Γw.blank).toΓ + (idleDir c₅.output.read) } := by + simp only [TM.step, extractOutputTM] + split + · next heq => simp [hc₅_state] at heq + · simp only [hc₅_state] + -- Name the final config + set c₆ : Cfg 4 (extractOutputTM (n := n)).Q := + { state := .done + input := c₅.input.move (idleDir c₅.input.read) + work := fun i => (c₅.work i).writeAndMove (readBackWrite (c₅.work i).read).toΓ + (idleDir (c₅.work i).read) + output := c₅.output.writeAndMove + (match hiLo.1, hiLo.2 with + | .zero, .zero => Γw.zero + | .zero, .one => Γw.one + | .blank, .blank => Γw.blank + | _, _ => Γw.blank).toΓ + (idleDir c₅.output.read) } + -- c₆ is halted + have hc₆_halted : (extractOutputTM (n := n)).halted c₆ := by + show c₆.state = ExtractOutputQ.done; rfl + -- The decoded symbol written to output matches outSym + -- c₅.output = c₁.output, which has head = 1 and cells = out.cells + -- So c₅.output.head = 1, and write goes to cell 1 + have hc₅_out_eq : c₅.output = c₁.output := by + rw [hc₅_out, hc₄_out, hc₃_out_eq] + have hc₅_out_h : c₅.output.head = 1 := by rw [hc₅_out_eq]; exact hc₁_out_h + -- The write value: match hiLo.1 hiLo.2 gives back outSym + -- For each case of outSym: + have hwrite_val : (match hiLo.1, hiLo.2 with + | .zero, .zero => Γw.zero + | .zero, .one => Γw.one + | .blank, .blank => Γw.blank + | _, _ => Γw.blank).toΓ = outSym := by + have hHiLo : hiLo = SuperCell.symToCellPair (simCfg.output.cells 1) := rfl + cases h : simCfg.output.cells 1 <;> + simp_all [SuperCell.symToCellPair, Γw.toΓ] + -- c₆.output.cells 1 = outSym + have hc₆_out_cells1 : c₆.output.cells 1 = outSym := by + -- c₆.output = c₅.output.writeAndMove(write_val)(idleDir c₅.output.read) + -- c₅.output.head = 1, so write goes to cell 1 + -- idleDir c₅.output.read = stay (since c₅.output reads cell 1 which is not start) + -- After write: cells 1 = write_val = outSym + show (c₅.output.writeAndMove _ _).cells 1 = outSym + simp only [Tape.writeAndMove, Tape.write, hc₅_out_h, Tape.move] + -- head ≠ 0 at position 1 + simp only [show (1 : ℕ) ≠ 0 from by omega, ↓reduceIte] + -- idleDir for output: c₅.output.read ≠ start + have hc₅_out_read_ns : c₅.output.read ≠ Γ.start := by + rw [hc₅_out_eq]; exact hc₁_out_read_ns + simp only [idleDir, hc₅_out_read_ns, ↓reduceIte] + -- After stay, cells are updated at position 1 + simp only [Function.update_self, hwrite_val] + -- Compose all reachesIn chains + -- Total steps: (out.head + 1) + 1 + (extractSkipDist n + 1) + 1 + 1 + 1 + -- = out.head + extractSkipDist n + 6 + -- Bound: out.head + extractSkipDist n + 6 ≤ B + extractSkipDist n + 6 + have hreach_total : (extractOutputTM (n := n)).reachesIn + (out.head + extractSkipDist n + 6) c₀ c₆ := by + -- c₀ →[out.head + 1] c₁ →[1] c₂ →[extractSkipDist n + 1] c₃ →[1] c₄ →[1] c₅ →[1] c₆ + have h₁₂ : (extractOutputTM (n := n)).reachesIn 1 c₁ c₂ := + TM.reachesIn.step hstep₂ .zero + have h₂₃ := hreach₃ + have h₃₄ : (extractOutputTM (n := n)).reachesIn 1 c₃ c₄ := + TM.reachesIn.step hstep₄ .zero + have h₄₅ : (extractOutputTM (n := n)).reachesIn 1 c₄ c₅ := + TM.reachesIn.step hstep₅ .zero + have h₅₆ : (extractOutputTM (n := n)).reachesIn 1 c₅ c₆ := + TM.reachesIn.step hstep₆ .zero + -- Compose: use reachesIn_trans + have hc₀₆ := TM.reachesIn_trans _ hreach₁ (TM.reachesIn_trans _ h₁₂ + (TM.reachesIn_trans _ h₂₃ (TM.reachesIn_trans _ h₃₄ + (TM.reachesIn_trans _ h₄₅ h₅₆)))) + convert hc₀₆ using 1; omega + exact ⟨c₆, _, by omega, hreach_total, hc₆_halted, hc₆_out_cells1⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/Helpers.lean b/Complexitylib/Models/TuringMachine/UTM/Helpers.lean new file mode 100644 index 0000000..d2bf01f --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/Helpers.lean @@ -0,0 +1,773 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs + +/-! +# UTM Helper Machines + +Small concrete Turing machines used as building blocks for the Universal TM. + +## Main definitions + +- `TM.writeTM` — write a symbol to output cell 1 +- `TM.rewindWorkTM` — rewind a work tape head to cell 1 +- `TM.scanRightTM` — scan a work tape right until blank +- `TM.copyInputToWorkTM` — copy input tape contents to a work tape +- `TM.compareWorkTapesTM` — compare two work tapes cell by cell +-/ + +namespace TM + +variable {n : ℕ} + +/-- Proof that all-idle directions satisfy `δ_right_of_start`. -/ +private theorem ros_allIdle (iHead : Γ) (wHeads : Fin k → Γ) (oHead : Γ) : + (iHead = Γ.start → idleDir iHead = Dir3.right) ∧ + (∀ i, wHeads i = Γ.start → idleDir (wHeads i) = Dir3.right) ∧ + (oHead = Γ.start → idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: write a symbol to output cell 1 and halt +-- ════════════════════════════════════════════════════════════════════════ + +inductive WritePhase where + | rewind | goRight | write | done + deriving DecidableEq + +instance : Fintype WritePhase where + elems := {.rewind, .goRight, .write, .done} + complete := fun x => by cases x <;> simp + +/-- Write `sym` to output cell 1 and halt. + Phases: rewind output to ▷ → move right to cell 1 → write → halt. -/ +def writeTM (sym : Γw) : TM n where + Q := WritePhase + qstart := .rewind + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .rewind => + if oHead = Γ.start then + (.goRight, fun _ => .blank, .blank, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.right) + else + (.rewind, fun _ => .blank, readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), Dir3.left) + | .goRight => + (.write, fun _ => .blank, .blank, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .write => + (.done, fun _ => .blank, sym, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .rewind => + dsimp only []; split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + · refine ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, ?_⟩ + intro h; next hn => exact absurd h hn + | .goRight => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .write => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact ros_allIdle iHead wHeads oHead + +abbrev writeOneTM : TM n := writeTM .one +abbrev writeZeroTM : TM n := writeTM .zero + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rewind a work tape to cell 1 +-- ════════════════════════════════════════════════════════════════════════ + +inductive RewindPhase where + | moveLeft | moveRight | done + deriving DecidableEq + +instance : Fintype RewindPhase where + elems := {.moveLeft, .moveRight, .done} + complete := fun x => by cases x <;> simp + +/-- Rewind work tape `idx` to cell 1 (first data cell after ▷). -/ +def rewindWorkTM (idx : Fin n) : TM n where + Q := RewindPhase + qstart := .moveLeft + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .moveLeft => + if wHeads idx = Γ.start then + (.moveRight, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.moveLeft, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = idx then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .moveRight => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .moveLeft => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rename_i heq; subst heq; contradiction + · exact idleDir_right_of_start hwi + | .moveRight => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact ros_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- scanRightTM: scan a work tape right until blank +-- ════════════════════════════════════════════════════════════════════════ + +inductive ScanPhase where + | scanning | done + deriving DecidableEq + +instance : Fintype ScanPhase where + elems := {.scanning, .done} + complete := fun x => by cases x <;> simp + +/-- Scan work tape `idx` right until finding `Γ.blank`. Preserves tape contents. -/ +def scanRightTM (idx : Fin n) : TM n where + Q := ScanPhase + qstart := .scanning + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .scanning => + if wHeads idx = Γ.blank then + allIdle .done iHead wHeads oHead + else + (.scanning, + fun i => if i = idx then readBackWrite (wHeads idx) else .blank, + .blank, idleDir iHead, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .scanning => + dsimp only []; split + · exact ros_allIdle iHead wHeads oHead + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + | .done => exact ros_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- copyInputToWorkTM: copy input tape to a work tape +-- ════════════════════════════════════════════════════════════════════════ + +inductive CopyPhase where + | copying | done + deriving DecidableEq + +instance : Fintype CopyPhase where + elems := {.copying, .done} + complete := fun x => by cases x <;> simp + +/-- Copy input tape data to work tape `idx`. Reads input right, writes to work tape. + Stops when input reads `Γ.blank`. Skips ▷ at cell 0. -/ +def copyInputToWorkTM (idx : Fin n) : TM n where + Q := CopyPhase + qstart := .copying + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .copying => + if iHead = Γ.blank then + allIdle .done iHead wHeads oHead + else + let w : Γw := match iHead with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + (.copying, + fun i => if i = idx then w else .blank, + .blank, Dir3.right, + fun i => if i = idx then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copying => + dsimp only []; split + · exact ros_allIdle iHead wHeads oHead + · refine ⟨fun _ => rfl, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + | .done => exact ros_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- compareWorkTapesTM: compare two work tapes cell by cell +-- ════════════════════════════════════════════════════════════════════════ + +inductive ComparePhase where + | comparing | mismatch | matchDone | done + deriving DecidableEq + +instance : Fintype ComparePhase where + elems := {.comparing, .mismatch, .matchDone, .done} + complete := fun x => by cases x <;> simp + +/-- Compare work tapes `idx₁` and `idx₂` cell by cell. + Both advance right together. Stops when both read `Γ.blank`. + Writes `Γ.one` to output if match, `Γ.zero` if mismatch. + Assumes output head is at cell 1. -/ +def compareWorkTapesTM (idx₁ idx₂ : Fin n) : TM n where + Q := ComparePhase + qstart := .comparing + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .comparing => + if wHeads idx₁ = Γ.blank ∧ wHeads idx₂ = Γ.blank then + (.matchDone, fun _ => .blank, .one, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else if wHeads idx₁ = wHeads idx₂ then + (.comparing, + fun i => if i = idx₁ then readBackWrite (wHeads idx₁) + else if i = idx₂ then readBackWrite (wHeads idx₂) + else .blank, + .blank, idleDir iHead, + fun i => if i = idx₁ then Dir3.right + else if i = idx₂ then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + (.mismatch, fun _ => .blank, .zero, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .mismatch => allIdle .done iHead wHeads oHead + | .matchDone => allIdle .done iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .comparing => + dsimp only []; split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .mismatch => exact ros_allIdle iHead wHeads oHead + | .matchDone => exact ros_allIdle iHead wHeads oHead + | .done => exact ros_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- setupStateTM: parse desc header, copy qstart to state tape, n to scratch +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the setup-state machine. Scans the description header on + work tape 0, copies the qstart one-hot to work tape 1, and writes + n ones to work tape 3 (scratch). + + Phases: + 1. **skipK**: Scan desc right past k ones, copying each one to state tape 1. + When desc reads non-one (separator), advance desc past separator, go to copyN. + After: state tape has k ones at cells 1..k, head at k+1. + 2. **copyN**: Scan desc right past n ones, copying each one to scratch tape 3. + When desc reads non-one (separator), advance desc past separator, go to skipQhalt. + After: scratch has n ones at cells 1..n, head at n+1. + 3. **skipQhalt**: Advance desc right while moving state tape left (k-counter). + When state reads ▷ (cell 0), stop. The forced right-move on ▷ brings + state to cell 1. This skips k qhalt bits + 1 separator = k+1 cells. + After: desc at first qstart bit, state at cell 1. + 4. **copyQstart**: Copy desc bits to state tape, advancing both right. + Stop when state reads Γ.blank (at cell k+1, the sentinel beyond the + k ones written in Phase 1). This overwrites the k ones with qstart + one-hot bits. + After: state tape has qstart one-hot at cells 1..k, blank sentinel at k+1. -/ +inductive SetupStatePhase where + | skipK -- skip k ones on desc (tape 0), copy to state (tape 1) + | copyN -- skip n ones on desc (tape 0), copy to scratch (tape 3) + | skipQhalt -- skip qhalt+sep using state tape as k-counter + | copyQstart -- copy qstart from desc to state, stop at blank sentinel + | done + deriving DecidableEq + +instance : Fintype SetupStatePhase where + elems := {.skipK, .copyN, .skipQhalt, .copyQstart, .done} + complete := fun x => by cases x <;> simp + +/-- Parse the desc header on work tape 0, copy qstart one-hot to state tape 1, + and write n ones to scratch tape 3. + + **Pre**: Desc tape at cell 1 (start of header), state tape at cell 1, + scratch tape at cell 1. + **Post**: State tape has qstart one-hot at cells 1..k with blank sentinel + at k+1. Scratch tape has n ones at cells 1..n. Desc tape head somewhere + past qstart section. -/ +def setupStateTM : TM 4 where + Q := SetupStatePhase + qstart := .skipK + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skipK => + if wHeads 0 = Γ.one then + -- Desc reads one: copy to state tape, advance both desc(0) and state(1) right + (.skipK, + fun i => if i.val = 0 then readBackWrite (wHeads 0) + else if i.val = 1 then .one + else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right + else if i.val = 1 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + -- Desc reads separator: advance desc past it, transition to copyN + (.copyN, + fun i => if i.val = 0 then readBackWrite (wHeads 0) else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .copyN => + if wHeads 0 = Γ.one then + -- Desc reads one: copy to scratch tape (3), advance both right + (.copyN, + fun i => if i.val = 0 then readBackWrite (wHeads 0) + else if i.val = 3 then .one + else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right + else if i.val = 3 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + -- Desc reads separator: advance desc past it, transition to skipQhalt + (.skipQhalt, + fun i => if i.val = 0 then readBackWrite (wHeads 0) else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .skipQhalt => + if wHeads 1 = Γ.start then + -- State tape reads ▷ (cell 0): counter exhausted. + -- Forced to move state right (to cell 1) by δ_right_of_start. + -- Desc stays (already past qhalt + separator). + (.copyQstart, + fun i => if i.val = 0 then readBackWrite (wHeads 0) else .blank, + .blank, idleDir iHead, + fun i => if i.val = 1 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Counter not exhausted: advance desc right, move state left + (.skipQhalt, + fun i => if i.val = 0 then readBackWrite (wHeads 0) + else if i.val = 1 then readBackWrite (wHeads 1) + else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right + else if i.val = 1 then Dir3.left + else idleDir (wHeads i), + idleDir oHead) + | .copyQstart => + if wHeads 1 = Γ.blank then + -- State tape reads blank sentinel: copy complete + (.done, + fun i => if i.val = 0 then readBackWrite (wHeads 0) else .blank, + .blank, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + else + -- Copy desc bit to state tape, advance both right + (.copyQstart, + fun i => if i.val = 0 then readBackWrite (wHeads 0) + else if i.val = 1 then readBackWrite (wHeads 0) + else .blank, + .blank, idleDir iHead, + fun i => if i.val = 0 then Dir3.right + else if i.val = 1 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skipK => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + | .copyN => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + | .skipQhalt => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · next hn heq => + have : i = (1 : Fin 4) := by ext; exact heq + subst this; contradiction + · exact idleDir_right_of_start hwi + | .copyQstart => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + | .done => exact ros_allIdle iHead wHeads oHead + +-- ════════════════════════════════════════════════════════════════════════ +-- setupSimTM: write position-0 super-cells and copy x to sim tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the setup-sim machine. Sets up the simulation tape (work tape 2) + with position-0 super-cells and copies x with super-cell stride spacing. + + The machine uses scratch tape (work tape 3) which has n ones at cells 1..n + (written by `setupStateTM`) as a counter for both the position-0 loop and + the stride loop. + + ## Phase 1: Position-0 super-cells + + All simulated heads start at position 0, and cell 0 of every simulated tape + is `Γ.start`. So `symToCellPair(.start) = (.one, .one)` and head marker = + `Γ.one`. Each of the n+2 tapes needs 3 ones (head + hi + lo). + + The machine writes 3 ones per scratch-one (for n work tapes), then 6 extra + ones (for the 2 fixed tapes: input + output). Total: 3n + 6 = 3*(n+2). + + ## Phase 2: Advance input past separator + + Input head is at the `Γ.blank` separator between desc and x. Advance right + by 1 to reach x[0] (or blank if x is empty). + + ## Phase 3: Copy x with stride + + For each x bit: + 1. Skip head marker cell on sim (already Γ.blank = head-absent). 1 step. + 2. Write sym_hi = Γ.zero (same for both 0 and 1). 1 step. + 3. Write sym_lo = Γ.ofBool(x[i]). 1 step. Advance input right. + 4. Stride 3*n + 3 cells on sim: rewind scratch, then 3 per scratch-one + (3*n cells) + 3 extra cells. This skips past all other tapes' slots + in the current super-cell to reach the next super-cell's input slot. -/ +inductive SetupSimPhase where + -- Phase 1: Position-0 super-cell writing + | pos0Write1 -- check scratch; if one, write Γ.one to sim; if blank, go to extras + | pos0Write2 -- write 2nd Γ.one to sim + | pos0Write3 -- write 3rd Γ.one to sim, advance scratch, loop + | pos0Extra1 -- write extra one 1 of 6 (for input + output tapes) + | pos0Extra2 + | pos0Extra3 + | pos0Extra4 + | pos0Extra5 + | pos0Extra6 + -- Phase 2: Advance input + | advanceInput -- move input right by 1 (past separator) + -- Phase 3: Copy x loop + | checkInput -- if input = blank → done; else skip head marker on sim + | writeSymHi -- write Γ.zero to sim (sym_hi) + | writeSymLo -- write sym_lo based on input bit, advance input + -- Stride sub-machine + | rewindScratch -- move scratch left until ▷ + | bounceScratch -- move scratch right to cell 1, enter stride loop + | stride1 -- check scratch; if one, advance sim; if blank, go to extras + | stride2 -- advance sim right + | stride3 -- advance sim right, advance scratch, loop to stride1 + | strideExtra1 -- extra advance 1 of 3 + | strideExtra2 -- extra advance 2 of 3 + | strideExtra3 -- extra advance 3 of 3, go to checkInput + -- Done + | done + deriving DecidableEq + +instance : Fintype SetupSimPhase where + elems := {.pos0Write1, .pos0Write2, .pos0Write3, + .pos0Extra1, .pos0Extra2, .pos0Extra3, + .pos0Extra4, .pos0Extra5, .pos0Extra6, + .advanceInput, .checkInput, .writeSymHi, .writeSymLo, + .rewindScratch, .bounceScratch, + .stride1, .stride2, .stride3, + .strideExtra1, .strideExtra2, .strideExtra3, + .done} + complete := fun x => by cases x <;> simp + +-- Helper: idle transition that preserves all cell contents via readBackWrite +def setupIdle (next : SetupSimPhase) + (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + SetupSimPhase × (Fin 4 → Γw) × Γw × Dir3 × (Fin 4 → Dir3) × Dir3 := + (next, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + +private theorem ros_setupIdle (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + (iHead = Γ.start → idleDir iHead = Dir3.right) ∧ + (∀ i, wHeads i = Γ.start → idleDir (wHeads i) = Dir3.right) ∧ + (oHead = Γ.start → idleDir oHead = Dir3.right) := + ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + +-- Helper: advance only sim tape (work 2) right, writing `w` to it. +-- Non-sim tapes use readBackWrite to preserve cell contents. +def simWriteRight (next : SetupSimPhase) (w : Γw) + (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + SetupSimPhase × (Fin 4 → Γw) × Γw × Dir3 × (Fin 4 → Dir3) × Dir3 := + (next, + fun i => if i.val = 2 then w else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 2 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + +-- Helper: advance sim tape right preserving cell contents +def simAdvanceRight (next : SetupSimPhase) + (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + SetupSimPhase × (Fin 4 → Γw) × Γw × Dir3 × (Fin 4 → Dir3) × Dir3 := + simWriteRight next (readBackWrite (wHeads 2)) iHead wHeads oHead + +/-- Set up the simulation tape (work tape 2) with position-0 super-cells + and the input x encoded at the correct super-cell offsets. + + **Pre**: Sim tape at cell 1, scratch tape at cell 1 with n ones, + input at desc separator (Γ.blank). + **Post**: Sim tape encodes `superCellsCorrect (initCfg x)`. + Sim/scratch/input heads at various positions (final rewinds handle cleanup). -/ +def setupSimTM : TM 4 where + Q := SetupSimPhase + qstart := .pos0Write1 + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + -- ══════════════════════════════════════════════════════════════════ + -- Phase 1: Write position-0 super-cells + -- ══════════════════════════════════════════════════════════════════ + | .pos0Write1 => + if wHeads 3 = Γ.one then + -- Scratch has a one: write first of 3 ones to sim + simWriteRight .pos0Write2 .one iHead wHeads oHead + else + -- Scratch exhausted (n work tapes done): write 6 extras + setupIdle .pos0Extra1 iHead wHeads oHead + | .pos0Write2 => simWriteRight .pos0Write3 .one iHead wHeads oHead + | .pos0Write3 => + -- Write 3rd one, advance scratch right, loop back + (.pos0Write1, + fun i => if i.val = 2 then Γw.one + else if i.val = 3 then readBackWrite (wHeads 3) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 2 then Dir3.right + else if i.val = 3 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + -- Extra ones for input tape (3) + output tape (3) at position 0 + | .pos0Extra1 => simWriteRight .pos0Extra2 .one iHead wHeads oHead + | .pos0Extra2 => simWriteRight .pos0Extra3 .one iHead wHeads oHead + | .pos0Extra3 => simWriteRight .pos0Extra4 .one iHead wHeads oHead + | .pos0Extra4 => simWriteRight .pos0Extra5 .one iHead wHeads oHead + | .pos0Extra5 => simWriteRight .pos0Extra6 .one iHead wHeads oHead + | .pos0Extra6 => simWriteRight .advanceInput .one iHead wHeads oHead + -- ══════════════════════════════════════════════════════════════════ + -- Phase 2: Advance input past separator + -- ══════════════════════════════════════════════════════════════════ + | .advanceInput => + (.checkInput, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, -- advance input past Γ.blank separator + fun i => idleDir (wHeads i), + idleDir oHead) + -- ══════════════════════════════════════════════════════════════════ + -- Phase 3: Copy x with stride + -- ══════════════════════════════════════════════════════════════════ + | .checkInput => + if iHead = Γ.blank then + -- End of x: done + setupIdle .done iHead wHeads oHead + else + -- x bit present: skip head marker on sim (advance sim right) + simAdvanceRight .writeSymHi iHead wHeads oHead + | .writeSymHi => + -- Write Γ.zero to sim (sym_hi is .zero for both Γ.zero and Γ.one) + simWriteRight .writeSymLo .zero iHead wHeads oHead + | .writeSymLo => + -- Write sym_lo based on input bit, advance both sim and input + let w : Γw := if iHead = Γ.one then .one else .zero + (.rewindScratch, + fun i => if i.val = 2 then w else readBackWrite (wHeads i), + readBackWrite oHead, Dir3.right, -- advance input + fun i => if i.val = 2 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + -- ══════════════════════════════════════════════════════════════════ + -- Stride: rewind scratch + advance sim 3*(n+1) cells + -- ══════════════════════════════════════════════════════════════════ + | .rewindScratch => + if wHeads 3 = Γ.start then + -- Scratch at ▷ (cell 0): bounce right to cell 1 + (.bounceScratch, + fun i => readBackWrite (wHeads i), readBackWrite oHead, idleDir iHead, + fun i => if i.val = 3 then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Keep moving scratch left, preserving cells + (.rewindScratch, + fun i => if i.val = 3 then readBackWrite (wHeads 3) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 3 then Dir3.left else idleDir (wHeads i), + idleDir oHead) + | .bounceScratch => + -- Scratch at cell 1: enter stride loop (no tape movement this step) + setupIdle .stride1 iHead wHeads oHead + | .stride1 => + if wHeads 3 = Γ.one then + -- Scratch one: advance sim right (1st of 3) + simAdvanceRight .stride2 iHead wHeads oHead + else + -- Scratch exhausted: 3 extra advances + simAdvanceRight .strideExtra2 iHead wHeads oHead + | .stride2 => simAdvanceRight .stride3 iHead wHeads oHead + | .stride3 => + -- Advance sim right (3rd of 3), advance scratch right, loop + (.stride1, + fun i => if i.val = 2 then readBackWrite (wHeads 2) + else if i.val = 3 then readBackWrite (wHeads 3) + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i.val = 2 then Dir3.right + else if i.val = 3 then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .strideExtra1 => simAdvanceRight .strideExtra2 iHead wHeads oHead + | .strideExtra2 => simAdvanceRight .strideExtra3 iHead wHeads oHead + | .strideExtra3 => simAdvanceRight .checkInput iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + -- States using simWriteRight or simAdvanceRight (sim right, rest idle) + | .pos0Write2 | .pos0Extra1 | .pos0Extra2 | .pos0Extra3 + | .pos0Extra4 | .pos0Extra5 | .pos0Extra6 + | .writeSymHi + | .stride2 | .strideExtra1 | .strideExtra2 | .strideExtra3 => + dsimp only [simWriteRight, simAdvanceRight] + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; split + · rfl + · exact idleDir_right_of_start hwi + -- checkInput (two branches) + | .checkInput => + dsimp only [setupIdle, simAdvanceRight, simWriteRight]; split + · exact ros_setupIdle iHead wHeads oHead + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + -- stride1 (two branches, both advance sim) + | .stride1 => + dsimp only [simAdvanceRight, simWriteRight]; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + -- pos0Write1 (split on scratch) + | .pos0Write1 => + dsimp only [setupIdle, simWriteRight]; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + · exact ros_setupIdle iHead wHeads oHead + -- pos0Write3 (advance sim + scratch) + | .pos0Write3 => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + -- stride3 (advance sim + scratch) + | .stride3 => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · split + · rfl + · exact idleDir_right_of_start hwi + -- writeSymLo (advance sim + input) + | .writeSymLo => + refine ⟨fun _ => rfl, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + -- advanceInput (advance input, rest idle) + | .advanceInput => + exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, idleDir_right_of_start⟩ + -- rewindScratch (scratch left or right depending on ▷) + | .rewindScratch => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; simp only []; split + · next hn heq => + have : i = (3 : Fin 4) := by ext; exact heq + subst this; contradiction + · exact idleDir_right_of_start hwi + -- bounceScratch (setupIdle) + | .bounceScratch => + dsimp only [setupIdle] + exact ros_setupIdle iHead wHeads oHead + -- done (allIdle — never reached since state = qhalt) + | .done => exact ros_allIdle iHead wHeads oHead + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/HelpersInternal.lean b/Complexitylib/Models/TuringMachine/UTM/HelpersInternal.lean new file mode 100644 index 0000000..66e237b --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/HelpersInternal.lean @@ -0,0 +1,431 @@ +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# UTM Helpers: proof internals + +Simulation lemmas and HoareTime proofs for the helper machines defined in +`Complexitylib.Models.TuringMachine.UTM.Helpers`. + +## Main results + +- `writeTM_hoareTime` — HoareTime for `writeTM sym`: writes `sym.toΓ` to output cell 1 +- `rewindWorkTM_hoareTime` — HoareTime for `rewindWorkTM idx`: rewinds work tape to cell 1 +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers (public — shared across UTM proof modules) +-- ════════════════════════════════════════════════════════════════════════ + +theorem tape_move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +theorem readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +/-- writeAndMove with readBackWrite/idleDir is identity when read ≠ ▷ and head ≥ 1. -/ +theorem tape_idle_preserve (t : Tape) (hns : t.read ≠ Γ.start) (hh : t.head ≥ 1) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · omega + · simp only [Tape.read] at hns ⊢ + rw [readBackWrite_toΓ_eq hns, Function.update_eq_self] + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind loop for writeTM: from rewind state with output head at position `h`, + reach goRight state with head = 1 in `h + 1` steps, preserving output cells. -/ +private theorem writeTM_rewind_loop (sym : Γw) : + ∀ (h : ℕ) (c : Cfg n (writeTM sym).Q), + c.state = WritePhase.rewind → + c.output.cells 0 = Γ.start → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + c.output.head = h → + ∃ c', + (writeTM sym).reachesIn (h + 1) c c' ∧ + c'.state = WritePhase.goRight ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + intro h + induction h with + | zero => + intro c hstate hcell0 _ hhead + have hread : c.output.read = Γ.start := by simp [Tape.read, hhead, hcell0] + have hstep : ∃ c', (writeTM sym).step c = some c' ∧ + c'.state = WritePhase.goRight ∧ + c'.output.head = 1 ∧ + c'.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hstate, writeTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep + exact ⟨c', .step hstep' .zero, hst', hh', hc'⟩ + | succ h ih => + intro c hstate hcell0 hnostart hhead + have hread_ne : c.output.read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (h + 1) (by omega) + have hstep : ∃ c', (writeTM sym).step c = some c' ∧ + c'.state = WritePhase.rewind ∧ + c'.output.head = h ∧ + c'.output.cells = c.output.cells := by + simp only [TM.step, ↓reduceIte, hstate, writeTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp only [Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hhead] + · simp only [Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep + obtain ⟨c_go, hreach, hst_go, hh_go, hc_go⟩ := ih c' hst' + (by rw [hc']; exact hcell0) (by intro j hj; rw [hc']; exact hnostart j hj) hh' + exact ⟨c_go, .step hstep' hreach, hst_go, hh_go, by rw [hc_go, hc']⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: goRight and write steps +-- ════════════════════════════════════════════════════════════════════════ + +/-- From goRight state with output head at cell 1, take 2 steps to reach + done (halted) state with sym written to output cell 1. -/ +private theorem writeTM_goRight_to_done (sym : Γw) (c : Cfg n (writeTM sym).Q) + (hstate : c.state = WritePhase.goRight) + (hhead : c.output.head = 1) + (hnostart1 : c.output.cells 1 ≠ Γ.start) : + ∃ c', + (writeTM sym).reachesIn 2 c c' ∧ + (writeTM sym).halted c' ∧ + c'.output.cells 1 = sym.toΓ := by + -- Step 1: goRight → write (writes blank at cell 1, stays at head=1) + have hoDir : idleDir (c.output.read) = Dir3.stay := by + simp [idleDir, Tape.read, hhead, hnostart1] + have hstep1 : ∃ c₁, (writeTM sym).step c = some c₁ ∧ + c₁.state = WritePhase.write ∧ + c₁.output.head = 1 ∧ + c₁.output.cells 1 = Γ.blank := by + simp only [TM.step, hstate, writeTM] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead, hoDir] + · simp [Tape.writeAndMove, Tape.move, Tape.write, hhead, hoDir, + Function.update_self, Γw.toΓ] + obtain ⟨c₁, hstep1', hst1, hhead1, hcell1_blank⟩ := hstep1 + -- Step 2: write → done (writes sym at cell 1) + have hoDir2 : idleDir (c₁.output.read) = Dir3.stay := by + simp [idleDir, Tape.read, hhead1, hcell1_blank] + have hstep2 : ∃ c₂, (writeTM sym).step c₁ = some c₂ ∧ + c₂.state = WritePhase.done ∧ + c₂.output.cells 1 = sym.toΓ := by + simp only [TM.step, hst1, writeTM] + refine ⟨_, rfl, rfl, ?_⟩ + simp [Tape.writeAndMove, Tape.move, Tape.write, hhead1, hoDir2, + Function.update_self] + obtain ⟨c₂, hstep2', hst2, hcells2⟩ := hstep2 + exact ⟨c₂, .step hstep1' (.step hstep2' .zero), hst2, hcells2⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `writeTM sym` writes `sym.toΓ` to output cell 1 and halts. + Precondition: output tape is well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷), + and output head is at most `B`. + Postcondition: output cell 1 = sym.toΓ. + Time: B + 3 steps. -/ +theorem writeTM_hoareTime (sym : Γw) (B : ℕ) : + (writeTM (n := n) sym).HoareTime + (fun _ _ out => out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≤ B) + (fun _ _ out => out.cells 1 = sym.toΓ) + (B + 3) := by + intro inp work out ⟨hcell0, hnostart, hhead_le⟩ + -- Phase 1: rewind to cell 1 + obtain ⟨c_go, hreach_rw, hst_go, hhead_go, hcells_go⟩ := + writeTM_rewind_loop sym out.head + { state := WritePhase.rewind, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl + -- Phase 2: write sym and halt + have hnostart_go : c_go.output.cells 1 ≠ Γ.start := by + rw [hcells_go]; exact hnostart 1 (by omega) + obtain ⟨c_done, hreach_wr, hhalt, hwrite⟩ := + writeTM_goRight_to_done sym c_go hst_go hhead_go hnostart_go + refine ⟨c_done, (out.head + 1) + 2, ?_, + reachesIn_trans (writeTM sym) hreach_rw hreach_wr, hhalt, hwrite⟩ + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind loop for rewindWorkTM: from moveLeft state with work tape `idx` + head at position `h`, reach moveRight state with head = 1 in `h + 1` + steps, preserving work tape cells. -/ +private theorem rewindWorkTM_rewind_loop (idx : Fin n) : + ∀ (h : ℕ) (c : Cfg n (rewindWorkTM idx).Q), + c.state = RewindPhase.moveLeft → + (c.work idx).cells 0 = Γ.start → + (∀ j, j ≥ 1 → (c.work idx).cells j ≠ Γ.start) → + (c.work idx).head = h → + ∃ c', + (rewindWorkTM idx).reachesIn (h + 1) c c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells := by + intro h + induction h with + | zero => + intro c hstate hcell0 _ hhead + have hread : (c.work idx).read = Γ.start := by simp [Tape.read, hhead, hcell0] + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · dsimp only [] + simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · dsimp only [] + simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep + exact ⟨c', .step hstep' .zero, hst', hh', hc'⟩ + | succ h ih => + intro c hstate hcell0 hnostart hhead + have hread_ne : (c.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (h + 1) (by omega) + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveLeft ∧ + (c'.work idx).head = h ∧ + (c'.work idx).cells = (c.work idx).cells := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hhead] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + obtain ⟨c', hstep', hst', hh', hc'⟩ := hstep + obtain ⟨c_mr, hreach, hst_mr, hh_mr, hc_mr⟩ := ih c' hst' + (by rw [hc']; exact hcell0) (by intro j hj; rw [hc']; exact hnostart j hj) hh' + exact ⟨c_mr, .step hstep' hreach, hst_mr, hh_mr, by rw [hc_mr, hc']⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: moveRight step +-- ════════════════════════════════════════════════════════════════════════ + +/-- From moveRight state with work tape reading non-▷, + take 1 step to done (halted) state, preserving work tape head. -/ +private theorem rewindWorkTM_moveRight_to_done (idx : Fin n) + (c : Cfg n (rewindWorkTM idx).Q) + (hstate : c.state = RewindPhase.moveRight) + (hread_ne : (c.work idx).read ≠ Γ.start) : + ∃ c', + (rewindWorkTM idx).reachesIn 1 c c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = (c.work idx).head := by + have hoDir : idleDir ((c.work idx).read) = Dir3.stay := by + simp [idleDir, hread_ne] + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.done ∧ + (c'.work idx).head = (c.work idx).head := by + simp only [TM.step, hstate, rewindWorkTM, allIdle] + refine ⟨_, rfl, rfl, ?_⟩ + dsimp only [] + rw [Tape.writeAndMove, hoDir] + simp [Tape.move, Tape.write] + split <;> rfl + obtain ⟨c', hstep', hst', hhead'⟩ := hstep + exact ⟨c', .step hstep' .zero, hst', hhead'⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `rewindWorkTM idx` rewinds work tape `idx` to cell 1 and halts. + Precondition: work tape `idx` is well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷), + and work tape head is at most `B`. + Postcondition: work tape `idx` head = 1. + Time: B + 2 steps. -/ +theorem rewindWorkTM_hoareTime (idx : Fin n) (B : ℕ) : + (rewindWorkTM idx).HoareTime + (fun _ work _ => (work idx).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → (work idx).cells j ≠ Γ.start) ∧ + (work idx).head ≤ B) + (fun _ work _ => (work idx).head = 1) + (B + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le⟩ + -- Phase 1: rewind to cell 1 + obtain ⟨c_mr, hreach_rw, hst_mr, hhead_mr, hcells_mr⟩ := + rewindWorkTM_rewind_loop idx (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl + -- Phase 2: moveRight → done + have hread_mr : (c_mr.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead_mr, hcells_mr]; exact hnostart 1 (by omega) + obtain ⟨c_done, hreach_mr, hhalt, hhead_done⟩ := + rewindWorkTM_moveRight_to_done idx c_mr hst_mr hread_mr + refine ⟨c_done, ((work idx).head + 1) + 1, ?_, + reachesIn_trans (rewindWorkTM idx) hreach_rw hreach_mr, hhalt, + by dsimp only []; rw [hhead_done, hhead_mr]⟩ + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: rich HoareTime preserving arbitrary data +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rich HoareTime for `rewindWorkTM` that preserves an arbitrary predicate P + through the rewind, provided P depends on cells (not heads) of the target + tape. This is the key tool for threading data (descOnTape, stateOnTapeAt, + superCellsCorrect) through rewind steps in seqTM compositions. + + The caller provides `hP_preserved` showing that P is stable under: + - target tape cells unchanged, head set to 1 + - all other work tapes unchanged + - input and output unchanged -/ +theorem rewindWorkTM_rich_hoareTime {n : ℕ} (idx : Fin n) (B_tape : ℕ) + {P : Tape → (Fin n → Tape) → Tape → Prop} + (hP_preserved : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape) + (inp' : Tape) (work' : Fin n → Tape) (out' : Tape), + P inp work out → + (work' idx).cells = (work idx).cells → + (work' idx).head = 1 → + (∀ i, i ≠ idx → work' i = work i) → + inp' = inp → + out'.cells = out.cells → + out'.head = out.head → + P inp' work' out') : + (rewindWorkTM idx).HoareTime + (fun inp work out => + (work idx).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → (work idx).cells j ≠ Γ.start) ∧ + (work idx).head ≤ B_tape ∧ + inp.read ≠ Γ.start ∧ + out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, i ≠ idx → (work i).read ≠ Γ.start ∧ (work i).head ≥ 1) ∧ + P inp work out) + (fun inp work out => + (work idx).head = 1 ∧ + P inp work out) + (B_tape + 2) := by + intro inp work out ⟨hcell0, hnostart, hhead_le, hinp_ns, hout_ns, hout_h, hother_wf, hP⟩ + -- Rich rewind loop: tracks ALL tapes, not just work tape idx + suffices h_loop : ∀ (h : ℕ) (c : Cfg n (rewindWorkTM idx).Q), + c.state = RewindPhase.moveLeft → + (c.work idx).cells 0 = Γ.start → + (∀ j, j ≥ 1 → (c.work idx).cells j ≠ Γ.start) → + (c.work idx).head = h → + c.input = inp → c.output = out → (∀ i, i ≠ idx → c.work i = work i) → + ∃ c', + (rewindWorkTM idx).reachesIn (h + 2) c c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = 1 ∧ (c'.work idx).cells = (c.work idx).cells ∧ + c'.input = inp ∧ c'.output = out ∧ (∀ i, i ≠ idx → c'.work i = work i) by + obtain ⟨c', hreach, hhalt, hh1, hcells, hinp', hout', hw'⟩ := + h_loop (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl hcell0 hnostart rfl rfl rfl (fun _ _ => rfl) + refine ⟨c', _, by omega, hreach, hhalt, hh1, ?_⟩ + exact hP_preserved inp work out c'.input c'.work c'.output hP + (by rw [hcells]) hh1 hw' hinp' + (by rw [hout']) (by rw [hout']) + intro h; induction h with + | zero => + intro c hstate hcell0_c hnostart_c hhead hinp_c hout_c hw_c + have hread : (c.work idx).read = Γ.start := by simp [Tape.read, hhead, hcell0_c] + -- Step 1: moveLeft, read ▷ → moveRight + have hstep1 : ∃ c₁, + (rewindWorkTM idx).step c = some c₁ ∧ + c₁.state = RewindPhase.moveRight ∧ + (c₁.work idx).head = 1 ∧ (c₁.work idx).cells = (c.work idx).cells ∧ + c₁.input = inp ∧ c₁.output = out ∧ (∀ i, i ≠ idx → c₁.work i = work i) := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only []; simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · dsimp only []; simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + · dsimp only []; rw [hinp_c]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + · dsimp only []; rw [hout_c]; exact tape_idle_preserve out hout_ns hout_h + · intro i hne; dsimp only [] + simp only [show ¬(i = idx) from hne, ↓reduceIte] + rw [hw_c i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨c₁, hstep1', hst1, hh1, hcells1, hinp1, hout1, hw1⟩ := hstep1 + -- Step 2: moveRight → done + have hread1 : (c₁.work idx).read ≠ Γ.start := by + simp [Tape.read, hh1, hcells1]; exact hnostart_c 1 (by omega) + have hstep2 : ∃ c₂, + (rewindWorkTM idx).step c₁ = some c₂ ∧ + (rewindWorkTM idx).halted c₂ ∧ + (c₂.work idx).head = 1 ∧ (c₂.work idx).cells = (c₁.work idx).cells ∧ + c₂.input = inp ∧ c₂.output = out ∧ (∀ i, i ≠ idx → c₂.work i = work i) := by + simp only [TM.step, hst1, rewindWorkTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + have := tape_idle_preserve (c₁.work idx) hread1 (by omega) + show ((c₁.work idx).writeAndMove (readBackWrite (c₁.work idx).read) + (idleDir (c₁.work idx).read)).head = 1 + rw [this]; exact hh1 + · dsimp only [] + have := tape_idle_preserve (c₁.work idx) hread1 (by omega) + show ((c₁.work idx).writeAndMove (readBackWrite (c₁.work idx).read) + (idleDir (c₁.work idx).read)).cells = (c₁.work idx).cells + rw [this] + · dsimp only []; rw [hinp1]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + · dsimp only []; rw [hout1]; exact tape_idle_preserve out hout_ns hout_h + · intro i hne; dsimp only [] + rw [hw1 i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨c₂, hstep2', hhalt, hh2, hcells2, hinp2, hout2, hw2⟩ := hstep2 + exact ⟨c₂, .step hstep1' (.step hstep2' .zero), hhalt, hh2, + by rw [hcells2, hcells1], hinp2, hout2, hw2⟩ + | succ h ih => + intro c hstate hcell0_c hnostart_c hhead hinp_c hout_c hw_c + have hread_ne : (c.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart_c (h + 1) (by omega) + -- Step: moveLeft, read non-▷ → stay in moveLeft, move left + have hstep : ∃ c₁, + (rewindWorkTM idx).step c = some c₁ ∧ + c₁.state = RewindPhase.moveLeft ∧ + (c₁.work idx).head = h ∧ (c₁.work idx).cells = (c.work idx).cells ∧ + c₁.input = inp ∧ c₁.output = out ∧ (∀ i, i ≠ idx → c₁.work i = work i) := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hhead] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, tape_move_cells] + rw [readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · dsimp only []; rw [hinp_c]; simp only [idleDir, hinp_ns, ↓reduceIte, Tape.move] + · dsimp only []; rw [hout_c]; exact tape_idle_preserve out hout_ns hout_h + · intro i hne; dsimp only [] + simp only [show ¬(i = idx) from hne, ↓reduceIte] + rw [hw_c i hne]; exact tape_idle_preserve (work i) (hother_wf i hne).1 (hother_wf i hne).2 + obtain ⟨c₁, hstep', hst1, hh1, hcells1, hinp1, hout1, hw1⟩ := hstep + obtain ⟨c_f, hreach_f, hhalt_f, hh_f, hcells_f, hinp_f, hout_f, hw_f⟩ := + ih c₁ hst1 (by rw [hcells1]; exact hcell0_c) (by intro j hj; rw [hcells1]; exact hnostart_c j hj) + hh1 hinp1 hout1 hw1 + exact ⟨c_f, .step hstep' hreach_f, hhalt_f, hh_f, + by rw [hcells_f, hcells1], hinp_f, hout_f, hw_f⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/Init.lean b/Complexitylib/Models/TuringMachine/UTM/Init.lean new file mode 100644 index 0000000..6969113 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/Init.lean @@ -0,0 +1,44 @@ +import Complexitylib.Models.TuringMachine.UTM.Init.Defs +import Complexitylib.Models.TuringMachine.UTM.InitInternal + +/-! +# UTM Initialization Machine + +Parses the encoded input `⟨M, x⟩` and sets up the UTM's 4 work tapes to +satisfy the simulation invariant `SimInvariant` for the initial configuration +of M on x. + +## Main results + +- `initTM` — the initialization machine definition (in `Init.Defs`) +- `initTM_hoareTime` — HoareTime spec: from encoded input to SimInvariant +-/ + +namespace TM + +variable {n : ℕ} + +/-- HoareTime specification for `initTM`. + + **Precondition**: Input tape contains encoded `⟨M, x⟩` via `encodeUTMInput`. + All tapes start in their initial configuration. + + **Postcondition**: Work tapes satisfy `SimInvariant` for the initial + configuration `tm.initCfg x`. + + The postcondition is `SimInvariant`, which existentially quantifies + over `simCfg`. The witness is `tm.initCfg x`. -/ +theorem initTM_hoareTime (tm : TM n) (k : ℕ) + (x : List Bool) + (hk : k = @Fintype.card tm.Q tm.finQ) : + let desc := TMEncoding.encodeTM tm + ∃ B, initTM.HoareTime + (fun inp work out => + inp = initTape (encodeUTMInput tm x) ∧ + work = (fun _ => initTape []) ∧ + out = initTape []) + (SimInvariant tm k hk desc) + B := + initTM_hoareTime' tm k x hk + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/Init/Defs.lean b/Complexitylib/Models/TuringMachine/UTM/Init/Defs.lean new file mode 100644 index 0000000..479e296 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/Init/Defs.lean @@ -0,0 +1,53 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# UTM Initialization Machine — Definition + +Extracted to break the import cycle between `Init.lean` (surface) and +`InitInternal.lean` (proofs). +-/ + +namespace TM + +variable {n : ℕ} + +/-- The initialization machine. Parses `⟨M, x⟩` from the input tape and + sets up the 4 work tapes to satisfy the simulation invariant for + `tm.initCfg x`. + + Architecture: + ``` + initTM = + seqTM (copyInputToWorkTM 0) -- A: copy desc to work tape 0 + (seqTM (rewindWorkTM 0) -- rewind desc tape to cell 1 + (seqTM setupStateTM -- B: parse header, copy qstart→tape 1, n→tape 3 + (seqTM (rewindWorkTM 3) -- rewind scratch tape to cell 1 + (seqTM setupSimTM -- C: write super-cells, copy x to sim tape + (seqTM (rewindWorkTM 0) -- D: rewind all 4 work tapes + (seqTM (rewindWorkTM 1) + (seqTM (rewindWorkTM 2) + (rewindWorkTM 3)))))))) + ``` + + Phase A copies the TM description from input to work tape 0, stopping at + the `Γ.blank` separator. Phase B parses the header (k, n), copies qstart + to the state tape, and writes n to scratch. The scratch rewind brings + scratch head back to cell 1 (from n+1 after Phase B). Phase C sets up the + simulation tape super-cells and copies x. Phase D rewinds all work tape + heads to cell 1. -/ +def initTM : TM 4 := + seqTM (copyInputToWorkTM (0 : Fin 4)) + (seqTM (rewindWorkTM (0 : Fin 4)) + (seqTM setupStateTM + (seqTM (rewindWorkTM (3 : Fin 4)) + (seqTM setupSimTM + (seqTM (rewindWorkTM (0 : Fin 4)) + (seqTM (rewindWorkTM (1 : Fin 4)) + (seqTM (rewindWorkTM (2 : Fin 4)) + (rewindWorkTM (3 : Fin 4))))))))) + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/InitInternal.lean b/Complexitylib/Models/TuringMachine/UTM/InitInternal.lean new file mode 100644 index 0000000..9d6647c --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/InitInternal.lean @@ -0,0 +1,904 @@ +import Complexitylib.Models.TuringMachine.UTM.Init.Defs +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Copy +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Rewind +import Complexitylib.Models.TuringMachine.UTM.InitInternal.SetupState +import Complexitylib.Models.TuringMachine.UTM.InitInternal.SetupSim +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.Hoare + +/-! +# Init proof internals: composition + +Composes the sub-machine HoareTime proofs for `initTM` into a single +`initTM_hoareTime` theorem establishing `SimInvariant`. + +## Sub-modules + +- `InitInternal.Copy` — fully proved `copyInputToWorkTM_hoareTime` +- `InitInternal.Rewind` — fully proved frame-preserving `rewindWorkTM` + + `rewindAll_hoareTime` composition + +## Remaining sorry's + +- `setupStateTM_hoareTime` — 5-phase header parser (1 sorry: step simulation) +- `setupSimTM_hoareTime` — 20+ state super-cell writer (3 sorry's: phase simulations) +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Bridge: copy postcondition → InitEnvelope +-- ════════════════════════════════════════════════════════════════════════ + +/-- The copy proof's postcondition implies InitEnvelope from the Rewind module. -/ +private theorem postCopy_to_initEnvelope (tm : TM n) (x : List Bool) : + ∀ inp work out, postCopy tm x inp work out → + InitEnvelope inp work out := by + intro inp work out h + have hw0_head := h.2.1 + have hinp_head := h.2.2.1 + have hother_heads := h.2.2.2.1 + have hout_head := h.2.2.2.2.1 + have hwf : WorkTapesWF work := h.2.2.2.2.2.1 + have hinp_cells := h.2.2.2.2.2.2.2.1 + have hout_cells := h.2.2.2.2.2.2.2.2 + have initTape_ne_start : ∀ (contents : List Γ) (j : ℕ), + (∀ g ∈ contents, g ≠ Γ.start) → j ≥ 1 → (initTape contents).cells j ≠ Γ.start := by + intro contents j hns hj habs + simp only [initTape, show j ≠ 0 from by omega] at habs + cases hg : contents[j - 1]? with + | none => simp [hg] at habs + | some val => + simp [hg] at habs + have hlt : j - 1 < contents.length := by + by_contra hge; have : contents.length ≤ j - 1 := by omega + simp [List.getElem?_eq_none_iff.mpr this] at hg + have heq := List.getElem?_eq_getElem hlt; rw [hg] at heq + have : contents[j - 1] = val := Option.some.inj heq.symm + exact hns val (this ▸ List.getElem_mem ..) habs + exact ⟨by rw [hinp_cells]; rfl, + by intro j hj; rw [hinp_cells]; exact initTape_ne_start _ j + (encodeUTMInput_ne_start tm x) hj, + by rw [hinp_head]; omega, + hwf, + by intro i; by_cases hi : i = 0 + · subst hi; rw [hw0_head]; omega + · have := hother_heads i hi; omega, + by rw [hout_cells]; rfl, + by intro j hj; rw [hout_cells]; exact initTape_ne_start _ j (by simp) hj, + by rw [hout_head]⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- SetupState (sorry'd) +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime for setupStateTM. + Precondition: desc tape with head at 1, other work tapes blank. + Postcondition: state tape has qstart one-hot, scratch has n ones. + Also preserves: sim tape head = 1, input cells, input head. + Proof delegated to SetupState module. -/ +private theorem setupStateTM_hoareTime' (tm : TM n) (k : ℕ) + (_x : List Bool) + (_hk : k = @Fintype.card tm.Q tm.finQ) : + setupStateTM.HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).cells = (initTape []).cells ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + (work utmScratchTape).cells = (initTape []).cells ∧ + (work utmScratchTape).head = 1 ∧ + inp.cells = (initTape (encodeUTMInput tm _x)).cells ∧ + inp.head = (TMEncoding.encodeTM tm).length + 1) + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK _hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmScratchTape).head ≤ n + 1 ∧ + (work utmStateTape).head ≤ k + 1 ∧ + (work utmSimTape).head = 1 ∧ + inp.cells = (initTape (encodeUTMInput tm _x)).cells ∧ + inp.head = (TMEncoding.encodeTM tm).length + 1) + (3 * k + n + 5) := by + intro inp work out ⟨henv, hdesc, hdesc_h, hst_c, hst_h, hsim_c, hsim_h1, + hsc_c, hsc_h, hinpc, hinph⟩ + have hsim := setupStateTM_simulation tm k _x _hk inp work out + hdesc hdesc_h hst_c hst_h hsim_c hsc_c hsc_h henv + obtain ⟨c', hreach, hhalt, henv', hpost⟩ := hsim + -- Extract all fields from hpost + -- Extract fields from hpost manually to avoid dependent elimination on ≤ + have hdesc' := hpost.1 + have hstate' := hpost.2.1 + have hsim_c' := hpost.2.2.1 + have hsc' := hpost.2.2.2.1 + have hd_head' := hpost.2.2.2.2.1 + have hsc_head' := hpost.2.2.2.2.2.1 + have hst_head' := hpost.2.2.2.2.2.2.1 + have hsim_pres := hpost.2.2.2.2.2.2.2.1 + have hinp_pres := hpost.2.2.2.2.2.2.2.2 + exact ⟨c', 3 * k + n + 5, le_refl _, hreach, hhalt, henv', + hdesc', hstate', hsim_c', + hsc', hd_head', hsc_head', hst_head', + by rw [hsim_pres]; exact hsim_h1, + by rw [hinp_pres]; exact hinpc, + by rw [hinp_pres]; exact hinph⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- SetupSim (sorry'd) +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime for setupSimTM. + Precondition: sim tape blank, scratch has n ones at head 1, input at separator. + Postcondition: sim tape has super-cells for initCfg x. + Proof delegated to SetupSim module. -/ +private theorem setupSimTM_hoareTime' (tm : TM n) (k : ℕ) + (x : List Bool) + (_hk : k = @Fintype.card tm.Q tm.finQ) : + setupSimTM.HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK _hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmScratchTape).head = 1 ∧ + inp.cells inp.head = Γ.blank ∧ + (∀ (i : ℕ) (hi : i < x.length), + inp.cells (inp.head + 1 + i) = Γ.ofBool (x.get ⟨i, hi⟩)) ∧ + inp.cells (inp.head + 1 + x.length) = Γ.blank ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmStateTape).head ≤ k + 1) + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK _hk tm.qstart) (work utmStateTape) ∧ + superCellsCorrect (tm.initCfg x) (work utmSimTape) ∧ + (work (0 : Fin 4)).head ≤ 3 * k + n + 5 ∧ + (work (1 : Fin 4)).head ≤ k + 1 ∧ + (work (2 : Fin 4)).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (work (3 : Fin 4)).head ≤ n + 1) + (3 * n + 9 + x.length * (4 * n + 9)) := + setupSimTM_hoareTime tm k (tm.stateEquivK _hk) x _hk + +-- ════════════════════════════════════════════════════════════════════════ +-- seqTransition identity under InitEnvelope +-- ════════════════════════════════════════════════════════════════════════ + +/-- h_trans for any predicate that implies InitEnvelope. -/ +private theorem h_trans_envelope {P : TapePred 4} + (hP : ∀ inp work out, P inp work out → InitEnvelope inp work out) : + ∀ inp work out, P inp work out → + P (seqTransitionInput inp) + (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + intro inp work out hp + have henv := hP inp work out hp + obtain ⟨hic0, hins, hih, hwf, hheads, hoc0, hons, hoh⟩ := henv + have hi := seqTransitionInput_id (by simp [Tape.read]; exact hins inp.head hih) + have hw : (fun i => seqTransitionTape (work i)) = work := by + ext i; apply seqTransitionTape_id + · intro h; have := hwf.2 i (work i).head (hheads i) + rw [Tape.read] at h; exact this h + · exact hheads i + have ho := seqTransitionTape_id + (by simp [Tape.read]; exact hons out.head hoh) hoh + rw [hi, hw, ho]; exact hp + +-- ════════════════════════════════════════════════════════════════════════ +-- postSetupSim → InitEnvelope + head bounds → rewindAll precondition +-- ════════════════════════════════════════════════════════════════════════ + +-- postSetupSim_to_rewindAll moved after initData definition below + +/-- After all rewinds + SimInvariant data, construct SimInvariant. -/ +private theorem postRewindsAndData_to_simInvariant (tm : TM n) (k : ℕ) + (x : List Bool) + (hk : k = @Fintype.card tm.Q tm.finQ) + (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (henv : InitEnvelope inp work out) + (hheads : ∀ i, (work i).head = 1) + (hdesc : descOnTape (TMEncoding.encodeTM tm) (work utmDescTape)) + (hstate : stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape)) + (hsim : superCellsCorrect (tm.initCfg x) (work utmSimTape)) : + SimInvariant tm k hk (TMEncoding.encodeTM tm) inp work out := by + exact ⟨tm.initCfg x, hdesc, hstate, hsim, + fun i => by have := hheads i; omega, henv.2.2.2.1⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Data-preserving rewind helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- The data part of the postcondition that depends only on tape cells. -/ +private def initData (tm : TM n) (k : ℕ) (hk : k = @Fintype.card tm.Q tm.finQ) + (x : List Bool) : TapePred 4 := + fun _inp work _out => + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + superCellsCorrect (tm.initCfg x) (work utmSimTape) + +/-- The setupSim postcondition implies the rewindAll precondition (keeping data). -/ +private theorem postSetupSim_to_rewindAll (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : + ∀ inp work out, + (InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + superCellsCorrect (tm.initCfg x) (work utmSimTape) ∧ + (work (0 : Fin 4)).head ≤ 3 * k + n + 5 ∧ + (work (1 : Fin 4)).head ≤ k + 1 ∧ + (work (2 : Fin 4)).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (work (3 : Fin 4)).head ≤ n + 1) → + (InitEnvelope inp work out ∧ + initData tm k hk x inp work out ∧ + (work (0 : Fin 4)).head ≤ 3 * k + n + 5 ∧ + (work (1 : Fin 4)).head ≤ k + 1 ∧ + (work (2 : Fin 4)).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (work (3 : Fin 4)).head ≤ n + 1) := + fun _ _ _ ⟨henv, hdesc, hstate, hsim, hb0, hb1, hb2, hb3⟩ => + ⟨henv, ⟨hdesc, hstate, hsim⟩, hb0, hb1, hb2, hb3⟩ + +/-- tapeStoresBools depends only on cells. -/ +private theorem tapeStoresBools_cells_eq {bits : List Bool} {t t' : Tape} + (hcells : t'.cells = t.cells) (ht : tapeStoresBools bits t) : + tapeStoresBools bits t' := by + obtain ⟨h0, hb, htail⟩ := ht + exact ⟨by rw [hcells]; exact h0, fun i hi => by rw [hcells]; exact hb i hi, + by rw [hcells]; exact htail⟩ + +/-- superCellsCorrect depends only on cells. -/ +private theorem superCellsCorrect_cells_eq {Q : Type} {cfg : Cfg n Q} {t t' : Tape} + (hcells : t'.cells = t.cells) (ht : superCellsCorrect cfg t) : + superCellsCorrect cfg t' := by + obtain ⟨hc0, he1, he2, he3⟩ := ht + refine ⟨by rw [hcells]; exact hc0, fun pos => ?_, fun i pos => ?_, fun pos => ?_⟩ + · -- input tape encoding + have h := he1 pos + simp only [simTapeCellCorrect] at h ⊢ + exact ⟨by rw [hcells]; exact h.1, by rw [hcells]; exact h.2.1, by rw [hcells]; exact h.2.2⟩ + · -- work tape encoding + have h := he2 i pos + simp only [simTapeCellCorrect] at h ⊢ + exact ⟨by rw [hcells]; exact h.1, by rw [hcells]; exact h.2.1, by rw [hcells]; exact h.2.2⟩ + · -- output tape encoding + have h := he3 pos + simp only [simTapeCellCorrect] at h ⊢ + exact ⟨by rw [hcells]; exact h.1, by rw [hcells]; exact h.2.1, by rw [hcells]; exact h.2.2⟩ + +/-- initData depends only on tape cells, so rewinds preserve it. -/ +private theorem initData_preserved_by_rewind (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) (idx : Fin 4) : + ∀ (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (inp' : Tape) (work' : Fin 4 → Tape) (out' : Tape), + initData tm k hk x inp work out → + (work' idx).cells = (work idx).cells → + (work' idx).head = 1 → + (∀ i, i ≠ idx → work' i = work i) → + inp' = inp → out'.cells = out.cells → out'.head = out.head → + initData tm k hk x inp' work' out' := by + intro inp work out inp' work' out' ⟨hdesc, hstate, hsim⟩ hcells _ hother _ _ _ + refine ⟨?_, ?_, ?_⟩ + · -- descOnTape on tape 0 + show descOnTape _ (work' utmDescTape) + by_cases h : idx = (0 : Fin 4) + · subst h; exact tapeStoresBools_cells_eq hcells hdesc + · rw [hother 0 (Ne.symm h)]; exact hdesc + · -- stateOnTapeAt on tape 1 + show stateOnTapeAt k _ (work' utmStateTape) + by_cases h : idx = (1 : Fin 4) + · subst h; obtain ⟨h1, h2, h3⟩ := hstate + exact ⟨by rw [hcells]; exact h1, fun j hj => by rw [hcells]; exact h2 j hj, + by rw [hcells]; exact h3⟩ + · rw [hother 1 (Ne.symm h)]; exact hstate + · -- superCellsCorrect on tape 2 + show superCellsCorrect _ (work' utmSimTape) + by_cases h : idx = (2 : Fin 4) + · subst h; exact superCellsCorrect_cells_eq hcells hsim + · rw [hother 2 (Ne.symm h)]; exact hsim + +/-- Enriched single rewind: carries InitEnvelope + initData + per-tape head bounds. -/ +private theorem rewindWorkTM_initData_bounds_hoareTime (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) + (idx : Fin 4) (bounds : Fin 4 → ℕ) : + (rewindWorkTM idx).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + initData tm k hk x inp work out ∧ + ∀ i, (work i).head ≤ bounds i) + (fun inp work out => + InitEnvelope inp work out ∧ + initData tm k hk x inp work out ∧ + (work idx).head = 1 ∧ + ∀ i, i ≠ idx → (work i).head ≤ bounds i) + (bounds idx + 2) := by + intro inp work out ⟨henv, hdata, hbounds⟩ + have hic0 := henv.1; have hins := henv.2.1; have hih := henv.2.2.1 + have hwf := henv.2.2.2.1; have hheads := henv.2.2.2.2.1 + have hoc0 := henv.2.2.2.2.2.1; have hons := henv.2.2.2.2.2.2.1; have hoh := henv.2.2.2.2.2.2.2 + -- P carries initData + InitEnvelope + head bounds for non-target tapes + let P : Tape → (Fin 4 → Tape) → Tape → Prop := fun inp' work' out' => + initData tm k hk x inp' work' out' ∧ + InitEnvelope inp' work' out' ∧ + ∀ i, i ≠ idx → (work' i).head ≤ bounds i + have hP_preserved : ∀ (i0 : Tape) (w0 : Fin 4 → Tape) (o0 : Tape) + (i1 : Tape) (w1 : Fin 4 → Tape) (o1 : Tape), + P i0 w0 o0 → + (w1 idx).cells = (w0 idx).cells → (w1 idx).head = 1 → + (∀ j, j ≠ idx → w1 j = w0 j) → + i1 = i0 → o1.cells = o0.cells → o1.head = o0.head → + P i1 w1 o1 := by + intro i0 w0 o0 i1 w1 o1 ⟨hd, he, hbnds⟩ hc hh hot hi hoc hoh + refine ⟨initData_preserved_by_rewind tm k hk x idx i0 w0 o0 i1 w1 o1 hd hc hh hot hi hoc hoh, + ?_, fun j hne => by rw [hot j hne]; exact hbnds j hne⟩ + -- Reconstruct InitEnvelope + obtain ⟨hic0', hins', hih', hwf', hheads', hoc0', hons', hoh'⟩ := he + refine ⟨by rw [hi]; exact hic0', by intro j hj; rw [hi]; exact hins' j hj, + by rw [hi]; exact hih', ⟨?_, ?_⟩, ?_, + by rw [hoc]; exact hoc0', by intro j hj; rw [hoc]; exact hons' j hj, + by rw [hoh]; exact hoh'⟩ + · intro j + by_cases hj : j = idx + · rw [hj, hc]; exact hwf'.1 idx + · rw [hot j hj]; exact hwf'.1 j + · intro j p hp + by_cases hj : j = idx + · rw [hj, hc]; exact hwf'.2 idx p hp + · rw [hot j hj]; exact hwf'.2 j p hp + · intro j + by_cases hj : j = idx + · rw [hj, hh] + · rw [hot j hj]; exact hheads' j + obtain ⟨c', t, ht, hreach, hhalt, hhead1, hdata', henv', hbnds'⟩ := + rewindWorkTM_rich_hoareTime idx (bounds idx) hP_preserved inp work out + ⟨hwf.1 idx, hwf.2 idx, hbounds idx, + by simp only [Tape.read]; exact hins inp.head hih, + by simp only [Tape.read]; exact hons out.head hoh, hoh, + fun j hne => ⟨by simp only [Tape.read]; exact hwf.2 j _ (hheads j), hheads j⟩, + hdata, henv, fun j hne => hbounds j⟩ + exact ⟨c', t, ht, hreach, hhalt, henv', hdata', hhead1, hbnds'⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Compose 4 data-preserving rewinds +-- ════════════════════════════════════════════════════════════════════════ + +/-- Compose 4 rewinds preserving initData, producing SimInvariant. -/ +private theorem rewindAll_data_hoareTime (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) + (B0 B1 B2 B3 : ℕ) : + (seqTM (rewindWorkTM (0 : Fin 4)) + (seqTM (rewindWorkTM (1 : Fin 4)) + (seqTM (rewindWorkTM (2 : Fin 4)) + (rewindWorkTM (3 : Fin 4))))).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + initData tm k hk x inp work out ∧ + (work (0 : Fin 4)).head ≤ B0 ∧ + (work (1 : Fin 4)).head ≤ B1 ∧ + (work (2 : Fin 4)).head ≤ B2 ∧ + (work (3 : Fin 4)).head ≤ B3) + (fun inp work out => + SimInvariant tm k hk (TMEncoding.encodeTM tm) inp work out) + (B0 + B1 + B2 + B3 + 11) := by + let b0 : Fin 4 → ℕ := fun i => match i with | 0 => B0 | 1 => B1 | 2 => B2 | 3 => B3 + let b1 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => B1 | 2 => B2 | 3 => B3 + let b2 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => 1 | 2 => B2 | 3 => B3 + let b3 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => 1 | 2 => 1 | 3 => B3 + let midP (bds : Fin 4 → ℕ) : TapePred 4 := fun inp work out => + InitEnvelope inp work out ∧ initData tm k hk x inp work out ∧ + ∀ i, (work i).head ≤ bds i + -- Helper: merge head = 1 for target + bounds for non-target into midP + have merge_bounds : + ∀ (target : Fin 4) (pre_bds post_bds : Fin 4 → ℕ), + (∀ i, i ≠ target → post_bds i = pre_bds i) → + (post_bds target = 1) → + ∀ inp work out, + (InitEnvelope inp work out ∧ initData tm k hk x inp work out ∧ + (work target).head = 1 ∧ ∀ i, i ≠ target → (work i).head ≤ pre_bds i) → + midP post_bds inp work out := by + intro target pre_bds post_bds hne htgt inp work out ⟨he, hd, hh, hrest⟩ + exact ⟨he, hd, fun i => by + by_cases h : i = target + · subst h; rw [hh]; rw [htgt] + · rw [hne i h]; exact hrest i h⟩ + -- Build each rewind's HoareTime + have h_rw0 : (rewindWorkTM (0 : Fin 4)).HoareTime (midP b0) (midP b1) (B0 + 2) := + (rewindWorkTM_initData_bounds_hoareTime tm k hk x 0 b0).consequence + (fun _ _ _ h => h) + (merge_bounds 0 b0 b1 (by intro i hi; match i with | 1 => rfl | 2 => rfl | 3 => rfl) rfl) + (by show B0 + 2 ≤ B0 + 2; omega) + have h_rw1 : (rewindWorkTM (1 : Fin 4)).HoareTime (midP b1) (midP b2) (B1 + 2) := + (rewindWorkTM_initData_bounds_hoareTime tm k hk x 1 b1).consequence + (fun _ _ _ h => h) + (merge_bounds 1 b1 b2 (by intro i hi; match i with | 0 => rfl | 2 => rfl | 3 => rfl) rfl) + (by show B1 + 2 ≤ B1 + 2; omega) + have h_rw2 : (rewindWorkTM (2 : Fin 4)).HoareTime (midP b2) (midP b3) (B2 + 2) := + (rewindWorkTM_initData_bounds_hoareTime tm k hk x 2 b2).consequence + (fun _ _ _ h => h) + (merge_bounds 2 b2 b3 (by intro i hi; match i with | 0 => rfl | 1 => rfl | 3 => rfl) rfl) + (by show B2 + 2 ≤ B2 + 2; omega) + have h_rw3 : (rewindWorkTM (3 : Fin 4)).HoareTime (midP b3) + (fun inp work out => SimInvariant tm k hk (TMEncoding.encodeTM tm) inp work out) + (B3 + 2) := + (rewindWorkTM_initData_bounds_hoareTime tm k hk x 3 b3).consequence + (fun _ _ _ h => h) + (fun inp work out ⟨he, ⟨hdesc, hstate, hsim⟩, hh3, hrest⟩ => + postRewindsAndData_to_simInvariant tm k x hk inp work out he + (fun i => by + have hge := he.2.2.2.2.1 i + match i with + | 0 => have := hrest 0 (by decide); dsimp [b3] at this; omega + | 1 => have := hrest 1 (by decide); dsimp [b3] at this; omega + | 2 => have := hrest 2 (by decide); dsimp [b3] at this; omega + | 3 => exact hh3) + hdesc hstate hsim) + (by show B3 + 2 ≤ B3 + 2; omega) + -- h_trans: InitEnvelope → seqTransition is identity + have h_trans_midP : ∀ bds, ∀ inp work out, midP bds inp work out → + midP bds (seqTransitionInput inp) (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + intro bds; exact h_trans_envelope (fun _ _ _ ⟨he, _, _⟩ => he) + -- Compose via seqTM_hoareTime + exact (seqTM_hoareTime _ _ h_rw0 (h_trans_midP b1) + (seqTM_hoareTime _ _ h_rw1 (h_trans_midP b2) + (seqTM_hoareTime _ _ h_rw2 + (h_trans_envelope (fun _ _ _ ⟨he, _, _⟩ => he)) + h_rw3))).consequence + (fun inp work out ⟨he, hd, h0, h1, h2, h3⟩ => + (⟨he, hd, fun i => by match i with + | 0 => exact h0 | 1 => exact h1 | 2 => exact h2 | 3 => exact h3⟩ : + midP b0 inp work out)) + (fun _ _ _ h => h) + (by show B0 + 2 + 1 + (B1 + 2 + 1 + (B2 + 2 + 1 + (B3 + 2))) ≤ B0 + B1 + B2 + B3 + 11 + omega) + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1+2: copy + rewind tape 0 (rich rewind preserving copy data) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Cell-dependent data from postCopy that survives rewind of tape 0. -/ +private def copyData (tm : TM n) (x : List Bool) : TapePred 4 := + fun inp work out => + let desc := TMEncoding.encodeTM tm + descOnTape desc (work 0) ∧ + (∀ i : Fin 4, i ≠ 0 → (work i).cells = (initTape []).cells ∧ (work i).head = 1) ∧ + WorkTapesWF work ∧ + (work 0).head ≥ 1 ∧ + inp.cells = (initTape (encodeUTMInput tm x)).cells ∧ + inp.head = desc.length + 1 ∧ + out.cells = (initTape []).cells ∧ + out.head = 1 + +/-- copyData is preserved through rewind of tape 0 (depends only on cells). -/ +private theorem copyData_preserved (tm : TM n) (x : List Bool) : + ∀ (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (inp' : Tape) (work' : Fin 4 → Tape) (out' : Tape), + copyData tm x inp work out → + (work' (0 : Fin 4)).cells = (work 0).cells → + (work' (0 : Fin 4)).head = 1 → + (∀ i, i ≠ (0 : Fin 4) → work' i = work i) → + inp' = inp → out'.cells = out.cells → out'.head = out.head → + copyData tm x inp' work' out' := by + intro inp work out inp' work' out' + ⟨hdesc, hother, hwf, hh0, hinpc, hinph, houtc, houth⟩ + hw0_cells hw0_head hother' hinp' hout_cells' hout_head' + refine ⟨tapeStoresBools_cells_eq hw0_cells hdesc, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · intro i hi; rw [hother' i hi]; exact hother i hi + · constructor + · intro i; by_cases hi : i = (0 : Fin 4) + · subst hi; rw [hw0_cells]; exact hwf.1 0 + · rw [hother' i hi]; exact hwf.1 i + · intro i j hj; by_cases hi : i = (0 : Fin 4) + · subst hi; rw [hw0_cells]; exact hwf.2 0 j hj + · rw [hother' i hi]; exact hwf.2 i j hj + · rw [hw0_head] + · rw [hinp']; exact hinpc + · rw [hinp']; exact hinph + · rw [hout_cells']; exact houtc + · rw [hout_head']; exact houth + +/-- postCopy implies copyData (strip head-dependent data for tape 0). -/ +private theorem postCopy_to_copyData (tm : TM n) (x : List Bool) : + ∀ inp work out, postCopy tm x inp work out → copyData tm x inp work out := by + intro inp work out h + obtain ⟨hd, hw0, hinp, hhead, hout_head, hwf, hcells, hinp_cells, hout_cells⟩ := h + exact ⟨hd, fun i hi => ⟨hcells i hi, hhead i hi⟩, hwf, by rw [hw0]; omega, + hinp_cells, hinp, hout_cells, hout_head⟩ + +/-- Helper: cells of initTape at position ≥ 1 are never Γ.start when contents have no Γ.start. -/ +private theorem initTape_cells_ne_start {contents : List Γ} {j : ℕ} + (hns : ∀ g ∈ contents, g ≠ Γ.start) (hj : j ≥ 1) : + (initTape contents).cells j ≠ Γ.start := by + intro habs + simp only [initTape, show j ≠ 0 from by omega] at habs + cases hg : contents[j - 1]? with + | none => simp [hg] at habs + | some val => + simp [hg] at habs + have hlt : j - 1 < contents.length := by + by_contra hge; have : contents.length ≤ j - 1 := by omega + simp [List.getElem?_eq_none_iff.mpr this] at hg + have heq := List.getElem?_eq_getElem hlt; rw [hg] at heq + have : contents[j - 1] = val := Option.some.inj heq.symm + exact hns val (this ▸ List.getElem_mem ..) habs + +/-- copyData implies InitEnvelope (derivable from WorkTapesWF, head ≥ 1, cell data). -/ +private theorem copyData_to_initEnvelope (tm : TM n) (x : List Bool) : + ∀ inp work out, copyData tm x inp work out → InitEnvelope inp work out := by + intro inp work out ⟨_, hother, hwf, hh0, hinpc, hinph, houtc, houth⟩ + refine ⟨by rw [hinpc]; rfl, + by intro j hj; rw [hinpc]; exact initTape_cells_ne_start (encodeUTMInput_ne_start tm x) hj, + by rw [hinph]; omega, hwf, ?_, + by rw [houtc]; rfl, + by intro j hj; rw [houtc]; exact initTape_cells_ne_start (by intro g hg; simp at hg) hj, + by rw [houth]⟩ + intro i; by_cases h : i = (0 : Fin 4) + · subst h; exact hh0 + · have := (hother i h).2; omega + +/-- HoareTime for rewindWorkTM 0 preserving copyData. -/ +private theorem rewind0_copyData_hoareTime (tm : TM n) (x : List Bool) : + (rewindWorkTM (0 : Fin 4)).HoareTime + (fun inp work out => + copyData tm x inp work out ∧ + (work (0 : Fin 4)).head ≤ (TMEncoding.encodeTM tm).length + 1) + (fun inp work out => + copyData tm x inp work out ∧ + (work (0 : Fin 4)).head = 1) + ((TMEncoding.encodeTM tm).length + 3) := by + apply (rewindWorkTM_rich_hoareTime (0 : Fin 4) ((TMEncoding.encodeTM tm).length + 1) + (P := copyData tm x) (copyData_preserved tm x)).consequence + · -- Pre adaptation: copyData ∧ head ≤ B → rich rewind pre + intro inp work out ⟨hcopy, hhead⟩ + have ⟨hdesc, hother, hwf, _hh0, hinpc, hinph, houtc, houth⟩ := hcopy + refine ⟨hdesc.1, hwf.2 0, hhead, ?_, ?_, by rw [houth], ?_, hcopy⟩ + · -- inp.read ≠ Γ.start (inp cells = initTape(encoded), head = desc.length+1) + simp only [Tape.read, hinpc] + have hne0 : inp.head ≠ 0 := by rw [hinph]; omega + simp only [initTape, hne0, ↓reduceIte] + rw [hinph] + cases hg : (encodeUTMInput tm x)[(TMEncoding.encodeTM tm).length]? with + | none => simp [hg] + | some g => + simp [hg] + have hlt : (TMEncoding.encodeTM tm).length < (encodeUTMInput tm x).length := by + by_contra hge; have : (encodeUTMInput tm x).length ≤ (TMEncoding.encodeTM tm).length := by omega + simp [List.getElem?_eq_none_iff.mpr this] at hg + have hmem : g ∈ encodeUTMInput tm x := by + rw [List.getElem?_eq_getElem hlt] at hg + exact Option.some.inj hg.symm ▸ List.getElem_mem .. + exact encodeUTMInput_ne_start tm x g hmem + · -- out.read ≠ Γ.start (out cells = initTape [], head = 1) + simp only [Tape.read, houtc, houth, initTape, show (1 : ℕ) ≠ 0 from by omega, ↓reduceIte] + decide + · -- ∀ i ≠ 0, (work i).read ≠ Γ.start ∧ (work i).head ≥ 1 + intro i hi + have ⟨hcells, hhead_i⟩ := hother i hi + constructor + · simp only [Tape.read, hcells, hhead_i, initTape, show (1 : ℕ) ≠ 0 from by omega, ↓reduceIte] + decide + · rw [hhead_i] + · -- Post adaptation: head = 1 ∧ P → P ∧ head = 1 + intro _ _ _ ⟨hhead, hdata⟩; exact ⟨hdata, hhead⟩ + · -- Bound + omega + +/-- (copyData + head=1) implies setupStateTM precondition. -/ +private theorem copyDataHead1_to_setupStatePre (tm : TM n) (k : ℕ) + (x : List Bool) (hk : k = @Fintype.card tm.Q tm.finQ) : + ∀ inp work out, + (copyData tm x inp work out ∧ (work (0 : Fin 4)).head = 1) → + (InitEnvelope inp work out ∧ + descOnTape (TMEncoding.encodeTM tm) (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).cells = (initTape []).cells ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + (work utmScratchTape).cells = (initTape []).cells ∧ + (work utmScratchTape).head = 1 ∧ + inp.cells = (initTape (encodeUTMInput tm x)).cells ∧ + inp.head = (TMEncoding.encodeTM tm).length + 1) := by + intro inp work out ⟨hcd, hhead⟩ + have ⟨hdesc, hother, _, _, hinp_c, hinp_h, _, _⟩ := hcd + exact ⟨copyData_to_initEnvelope tm x inp work out hcd, + hdesc, hhead, + (hother 1 (by decide)).1, (hother 1 (by decide)).2, + (hother 2 (by decide)).1, (hother 2 (by decide)).2, + (hother 3 (by decide)).1, (hother 3 (by decide)).2, + hinp_c, hinp_h⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 3+4: setupState + rewind tape 3 (rich rewind preserving state data) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Cell-dependent data from setupState that survives rewind of tape 3. + Includes sim head, state head bound, and input tape layout needed by setupSim. + All these are preserved through the tape 3 rewind (which only changes tape 3 head). -/ +private def setupStateData (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : TapePred 4 := + fun inp work out => + InitEnvelope inp work out ∧ + descOnTape (TMEncoding.encodeTM tm) (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmStateTape).head ≤ k + 1 ∧ + inp.cells = (initTape (encodeUTMInput tm x)).cells ∧ + inp.head = (TMEncoding.encodeTM tm).length + 1 + +/-- setupStateData is preserved through rewind of tape 3 (scratch). -/ +private theorem setupStateData_preserved (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : + ∀ (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (inp' : Tape) (work' : Fin 4 → Tape) (out' : Tape), + setupStateData tm k hk x inp work out → + (work' (3 : Fin 4)).cells = (work 3).cells → + (work' (3 : Fin 4)).head = 1 → + (∀ i, i ≠ (3 : Fin 4) → work' i = work i) → + inp' = inp → out'.cells = out.cells → out'.head = out.head → + setupStateData tm k hk x inp' work' out' := by + intro inp work out inp' work' out' + ⟨henv, hdesc, hstate, hsim_c, hsim_h, hsc, hd_head, hst_head, hinpc, hinph⟩ + hw3_cells _hw3_head hother' hinp' hout_cells' hout_head' + obtain ⟨hic, hins, hih, hwf, hheads, hoc, hons, hoh⟩ := henv + have hwf' : WorkTapesWF work' := by + constructor + · intro i; by_cases h : i = (3 : Fin 4) + · subst h; rw [hw3_cells]; exact hwf.1 3 + · rw [hother' i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = (3 : Fin 4) + · subst h; rw [hw3_cells]; exact hwf.2 3 j hj + · rw [hother' i h]; exact hwf.2 i j hj + have hheads' : ∀ i : Fin 4, (work' i).head ≥ 1 := by + intro i; by_cases h : i = (3 : Fin 4) + · subst h; omega + · rw [hother' i h]; exact hheads i + exact ⟨⟨by rw [hinp']; exact hic, by intro j hj; rw [hinp']; exact hins j hj, + by rw [hinp']; exact hih, hwf', hheads', + by rw [hout_cells']; exact hoc, + by intro j hj; rw [hout_cells']; exact hons j hj, + by rw [hout_head']; exact hoh⟩, + by rw [hother' 0 (by decide)]; exact hdesc, + by rw [hother' 1 (by decide)]; exact hstate, + by rw [hother' 2 (by decide)]; exact hsim_c, + by rw [hother' 2 (by decide)]; exact hsim_h, + tapeStoresBools_cells_eq hw3_cells hsc, + by rw [hother' 0 (by decide)]; exact hd_head, + by rw [hother' 1 (by decide)]; exact hst_head, + by rw [hinp']; exact hinpc, + by rw [hinp']; exact hinph⟩ + +/-- HoareTime for rewindWorkTM 3 preserving setupStateData. -/ +private theorem rewind3_setupStateData_hoareTime (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : + (rewindWorkTM (3 : Fin 4)).HoareTime + (fun inp work out => + setupStateData tm k hk x inp work out ∧ + (work (3 : Fin 4)).head ≤ n + 1) + (fun inp work out => + setupStateData tm k hk x inp work out ∧ + (work (3 : Fin 4)).head = 1) + (n + 3) := by + exact (rewindWorkTM_rich_hoareTime (3 : Fin 4) (n + 1) + (setupStateData_preserved tm k hk x)).consequence + (fun inp work out h => by + obtain ⟨⟨henv, hdesc, hstate, hsim_c, hsim_h, hsc, hd_head, hst_head, hinpc, hinph⟩, hhead⟩ := h + have ⟨hic, hins, hih, hwf, hheads, hoc, hons, hoh⟩ := henv + exact ⟨hwf.1 3, hwf.2 3, hhead, + by simp only [Tape.read]; exact hins _ hih, + by simp only [Tape.read]; exact hons _ hoh, + hoh, + fun i hi => ⟨by simp only [Tape.read]; exact hwf.2 i _ (hheads i), hheads i⟩, + henv, hdesc, hstate, hsim_c, hsim_h, hsc, hd_head, hst_head, hinpc, hinph⟩) + (fun _ _ _ ⟨hhead, hdata⟩ => ⟨hdata, hhead⟩) + (by omega) + +-- ════════════════════════════════════════════════════════════════════════ +-- Bridges between phases +-- ════════════════════════════════════════════════════════════════════════ + +/-- postCopy → rewind0 precondition. -/ +private theorem postCopy_to_rewind0Pre (tm : TM n) (x : List Bool) : + ∀ inp work out, postCopy tm x inp work out → + copyData tm x inp work out ∧ + (work (0 : Fin 4)).head ≤ (TMEncoding.encodeTM tm).length + 1 := by + intro inp work out h + exact ⟨postCopy_to_copyData tm x inp work out h, by show _ ≤ _; rw [h.2.1]⟩ + +/-- setupState post → (setupStateData + head(3) ≤ n+1). -/ +private theorem setupStatePost_to_rewind3Pre (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : + ∀ inp work out, + (InitEnvelope inp work out ∧ + descOnTape (TMEncoding.encodeTM tm) (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmScratchTape).head ≤ n + 1 ∧ + (work utmStateTape).head ≤ k + 1 ∧ + (work utmSimTape).head = 1 ∧ + inp.cells = (initTape (encodeUTMInput tm x)).cells ∧ + inp.head = (TMEncoding.encodeTM tm).length + 1) → + (setupStateData tm k hk x inp work out ∧ + (work (3 : Fin 4)).head ≤ n + 1) := by + intro inp work out ⟨henv, hdesc, hstate, hsim, hsc, hd_head, hsc_head, hst_head, + hsim_head, hinp_c, hinp_h⟩ + exact ⟨⟨henv, hdesc, hstate, hsim, hsim_head, hsc, hd_head, hst_head, hinp_c, hinp_h⟩, + hsc_head⟩ + +/-- (setupStateData + head(3)=1) → setupSim precondition. -/ +private theorem setupStateDataHead1_to_setupSimPre (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (x : List Bool) : + ∀ inp work out, + (setupStateData tm k hk x inp work out ∧ (work (3 : Fin 4)).head = 1) → + (InitEnvelope inp work out ∧ + descOnTape (TMEncoding.encodeTM tm) (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmScratchTape).head = 1 ∧ + inp.cells inp.head = Γ.blank ∧ + (∀ (i : ℕ) (hi : i < x.length), + inp.cells (inp.head + 1 + i) = Γ.ofBool (x.get ⟨i, hi⟩)) ∧ + inp.cells (inp.head + 1 + x.length) = Γ.blank ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmStateTape).head ≤ k + 1) := by + intro inp work out ⟨⟨henv, hdesc, hstate, hsim_c, hsim_h, hsc, hd_head, + hst_head, hinpc, hinph⟩, hsc_head⟩ + refine ⟨henv, hdesc, hstate, hsim_c, hsim_h, hsc, hsc_head, ?_, ?_, ?_, hd_head, hst_head⟩ + · -- inp.cells inp.head = Γ.blank (separator in encoded input) + rw [hinpc, hinph] + simp only [initTape, show (TMEncoding.encodeTM tm).length + 1 ≠ 0 from by omega, ↓reduceIte] + simp [encodeUTMInput] + · -- ∀ i < x.length, inp.cells (inp.head + 1 + i) = Γ.ofBool x[i] + intro i hi + rw [hinpc, hinph] + simp [initTape, encodeUTMInput] + rw [List.getElem?_append_right (by simp; omega)] + simp only [List.length_map] + rw [show (TMEncoding.encodeTM tm).length + 1 + i - (TMEncoding.encodeTM tm).length = 1 + i from by omega, + show 1 + i = i + 1 from by omega, List.getElem?_cons_succ] + simp [hi] + · -- inp.cells (inp.head + 1 + x.length) = Γ.blank + rw [hinpc, hinph] + simp [initTape, encodeUTMInput] + rw [List.getElem?_append_right (by simp; omega)] + simp only [List.length_map] + rw [show (TMEncoding.encodeTM tm).length + 1 + x.length - (TMEncoding.encodeTM tm).length = + 1 + x.length from by omega, + show 1 + x.length = x.length + 1 from by omega, List.getElem?_cons_succ] + simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Main composition +-- ════════════════════════════════════════════════════════════════════════ + +/-- **initTM_hoareTime'**: from initial tapes with encoded `⟨M, x⟩`, + `initTM` establishes `SimInvariant` for `tm.initCfg x`. -/ +theorem initTM_hoareTime' (tm : TM n) (k : ℕ) + (x : List Bool) + (hk : k = @Fintype.card tm.Q tm.finQ) : + let desc := TMEncoding.encodeTM tm + ∃ B, initTM.HoareTime + (initTM_pre tm x) + (SimInvariant tm k hk desc) + B := by + set desc := TMEncoding.encodeTM tm with desc_def + -- ── Phase specs ──────────────────────────────────────────────────── + have h_copy := copyInputToWorkTM_hoareTime tm x + have h_rw0 := rewind0_copyData_hoareTime tm x + have h_setup_state := setupStateTM_hoareTime' tm k x hk + have h_rw3 := rewind3_setupStateData_hoareTime tm k hk x + have h_setup_sim := setupSimTM_hoareTime' tm k x hk + have h_rewinds := rewindAll_data_hoareTime tm k hk x + (3 * k + n + 5) (k + 1) ((x.length + 1) * 3 * (n + 2) + 1) (n + 1) + -- ── Compose phases 1-9 via seqTM_hoareTime ──────────────────────── + -- Each seqTM adds b₁ + 1 + b₂ to the bound. + -- Intermediate predicates: + -- copy post = postCopy → (consequence) → rw0 pre = copyData ∧ head ≤ B + -- rw0 post = copyData ∧ head = 1 → (bridge) → setupState pre + -- setupState post → (bridge) → rw3 pre = setupStateData ∧ head ≤ n+1 + -- rw3 post = setupStateData ∧ head = 1 → (bridge) → setupSim pre + -- setupSim post → (bridge: postSetupSim_to_rewindAll) → rewinds pre + -- seqTransition bridges: all preds imply InitEnvelope, so identity. + -- + -- The composition follows the structure: + -- initTM = seqTM copy (seqTM rw0 (seqTM setupState (seqTM rw3 + -- (seqTM setupSim rewinds)))) + -- where rewinds = seqTM rw0' (seqTM rw1 (seqTM rw2 rw3')) + -- + -- Each seqTM_hoareTime needs: h₁, h_trans, h₂ + -- h_trans uses h_trans_envelope since all predicates imply InitEnvelope + -- h₁/h₂ use .consequence to adapt pre/post + + -- Bridge: intermediate predicates imply InitEnvelope (for seqTransition identity) + -- copyData doesn't directly carry InitEnvelope, but it's derivable from cells + WF + have h_copyData_env : ∀ inp work out, + (copyData tm x inp work out ∧ (work (0 : Fin 4)).head ≤ desc.length + 1) → + InitEnvelope inp work out := by + intro inp work out ⟨hcd, _⟩; exact copyData_to_initEnvelope tm x inp work out hcd + have h_copyDataPost_env : ∀ inp work out, + (copyData tm x inp work out ∧ (work (0 : Fin 4)).head = 1) → + InitEnvelope inp work out := by + intro inp work out ⟨hcd, hh⟩ + exact (copyDataHead1_to_setupStatePre tm k x hk inp work out ⟨hcd, hh⟩).1 + have h_setupStateData_env : ∀ inp work out, + (setupStateData tm k hk x inp work out ∧ (work (3 : Fin 4)).head ≤ n + 1) → + InitEnvelope inp work out := + fun _ _ _ ⟨⟨henv, _⟩, _⟩ => henv + have h_setupStateDataPost_env : ∀ inp work out, + (setupStateData tm k hk x inp work out ∧ (work (3 : Fin 4)).head = 1) → + InitEnvelope inp work out := + fun _ _ _ ⟨⟨henv, _⟩, _⟩ => henv + + -- Total bound: sum of all sub-bounds + seqTM transitions + refine ⟨?_, ?_⟩ + · -- Bound value + exact copyBound desc.length + 1 + + (desc.length + 3) + 1 + + (3 * k + n + 5) + 1 + + (n + 3) + 1 + + (3 * n + 9 + x.length * (4 * n + 9)) + 1 + + ((3 * k + n + 5) + (k + 1) + ((x.length + 1) * 3 * (n + 2) + 1) + (n + 1) + 11) + · -- Compose via seqTM_hoareTime + exact (seqTM_hoareTime _ _ + -- Phase 1: copy (pre=initTM_pre, post=postCopy, consequence to rw0 pre) + (h_copy.consequence (fun _ _ _ h => h) + (postCopy_to_rewind0Pre tm x) (le_refl _)) + -- Bridge 1→2: seqTransition identity + (h_trans_envelope h_copyData_env) + -- Phases 2-9 + (seqTM_hoareTime _ _ + -- Phase 2: rw0 (pre/post = copyData ∧ head) + h_rw0 + -- Bridge 2→3: seqTransition identity + (h_trans_envelope h_copyDataPost_env) + -- Phases 3-9 + (seqTM_hoareTime _ _ + -- Phase 3: setupState (consequence: copyDataHead1 → setupState pre → setupState post → rw3 pre) + (h_setup_state.consequence + (copyDataHead1_to_setupStatePre tm k x hk) + (setupStatePost_to_rewind3Pre tm k hk x) + (le_refl _)) + -- Bridge 3→4: seqTransition identity + (h_trans_envelope h_setupStateData_env) + -- Phases 4-9 + (seqTM_hoareTime _ _ + -- Phase 4: rw3 (pre/post = setupStateData ∧ head) + h_rw3 + -- Bridge 4→5: seqTransition identity + (h_trans_envelope h_setupStateDataPost_env) + -- Phases 5-9 + (seqTM_hoareTime _ _ + -- Phase 5: setupSim (consequence: setupStateDataHead1 → setupSim pre → setupSim post → rewinds pre) + (h_setup_sim.consequence + (setupStateDataHead1_to_setupSimPre tm k hk x) + (postSetupSim_to_rewindAll tm k hk x) + (le_refl _)) + -- Bridge 5→6: seqTransition identity + (h_trans_envelope (fun _ _ _ h => And.left h)) + -- Phases 6-9: final 4 rewinds + h_rewinds))))).consequence + (fun _ _ _ h => h) + (fun _ _ _ h => h) + (by simp only [desc_def, copyBound]; omega) + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/InitInternal/Copy.lean b/Complexitylib/Models/TuringMachine/UTM/InitInternal/Copy.lean new file mode 100644 index 0000000..50a16a7 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/InitInternal/Copy.lean @@ -0,0 +1,401 @@ +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs + +/-! +# UTM Initialization: proof internals + +HoareTime proof for `copyInputToWorkTM`: copies the TM description from the +input tape to work tape 0, stopping at the Γ.blank separator. +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Definitions +-- ════════════════════════════════════════════════════════════════════════ + +def initTM_pre (tm : TM n) (x : List Bool) : TapePred 4 := + fun inp work out => + inp = initTape (encodeUTMInput tm x) ∧ + work = (fun _ => initTape []) ∧ + out = initTape [] + +def copyBound (descLen : ℕ) : ℕ := descLen + 2 + +def postCopy (tm : TM n) (x : List Bool) : TapePred 4 := + fun inp work out => + let desc := TMEncoding.encodeTM tm + descOnTape desc (work 0) ∧ + (work 0).head = desc.length + 1 ∧ + inp.head = desc.length + 1 ∧ + (∀ i : Fin 4, i ≠ 0 → (work i).head = 1) ∧ + out.head = 1 ∧ + WorkTapesWF work ∧ + (∀ i : Fin 4, i ≠ 0 → (work i).cells = (initTape []).cells) ∧ + inp.cells = (initTape (encodeUTMInput tm x)).cells ∧ + out.cells = (initTape []).cells + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem ofBool_ne_start (b : Bool) : Γ.ofBool b ≠ Γ.start := by + cases b <;> simp [Γ.ofBool] + +private theorem ofBool_ne_blank (b : Bool) : Γ.ofBool b ≠ Γ.blank := by + cases b <;> simp [Γ.ofBool] + +private theorem initTape_cells_succ {contents : List Γ} {j : ℕ} (hj : j < contents.length) : + (initTape contents).cells (j + 1) = contents[j] := by + simp only [initTape] + simp [show j + 1 - 1 = j by omega, List.getElem?_eq_getElem hj] + +private theorem initTape_cells_past {contents : List Γ} {j : ℕ} (hj : contents.length ≤ j) : + (initTape contents).cells (j + 1) = Γ.blank := by + simp only [initTape] + simp [show j + 1 - 1 = j by omega, List.getElem?_eq_none hj] + +private theorem write_head (t : Tape) (s : Γ) : (t.write s).head = t.head := by + simp [Tape.write]; split <;> rfl + +private theorem write_cells_of_ne_head (t : Tape) (s : Γ) (h : t.head ≠ 0) (j : ℕ) + (hj : j ≠ t.head) : (t.write s).cells j = t.cells j := by + simp [Tape.write, h, Function.update, hj] + +private theorem write_cells_at_head (t : Tape) (s : Γ) (h : t.head ≠ 0) : + (t.write s).cells t.head = s := by + simp [Tape.write, h, Function.update_self] + +private theorem write_cells_at (t : Tape) (s : Γ) (h : t.head ≠ 0) (j : ℕ) (hj : t.head = j) : + (t.write s).cells j = s := by + subst hj; exact write_cells_at_head t s h + +private theorem input_sep (desc : List Bool) (rest : List Γ) : + (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).cells (desc.length + 1) = + Γ.blank := by + rw [initTape_cells_succ (by simp)]; simp [List.length_map] + +private theorem input_desc (desc : List Bool) (rest : List Γ) (j : ℕ) (hj : j < desc.length) : + (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).cells (j + 1) = + Γ.ofBool desc[j] := by + rw [initTape_cells_succ (by simp; omega)] + simp only [List.append_assoc] + rw [List.getElem_append_left (by simp; exact hj)] + simp [List.getElem_map] + +theorem encodeUTMInput_ne_start (tm : TM n) (x : List Bool) : + ∀ g ∈ encodeUTMInput tm x, g ≠ Γ.start := by + intro g hg habs; subst habs + simp only [encodeUTMInput, List.mem_append, List.mem_map, List.mem_cons, + List.mem_nil_iff, or_false, Γ.ofBool] at hg + rcases hg with ⟨_ | _, _, hc⟩ | hc | ⟨_ | _, _, hc⟩ <;> simp_all + +-- ════════════════════════════════════════════════════════════════════════ +-- The copy loop +-- ════════════════════════════════════════════════════════════════════════ + +private theorem copy_loop (desc : List Bool) (rest : List Γ) : + ∀ (remaining copied : ℕ) (hrem : remaining = desc.length - copied) + (hcopied : copied ≤ desc.length) + (c : Cfg 4 (copyInputToWorkTM (0 : Fin 4)).Q), + c.state = CopyPhase.copying → + c.input.cells = (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).cells → + c.input.head = copied + 1 → + (c.work 0).head = copied + 1 → + (c.work 0).cells 0 = Γ.start → + (∀ (j : ℕ) (hj : j < copied), (c.work 0).cells (j + 1) = Γ.ofBool (desc[j]'(by omega))) → + (∀ j, j ≥ copied + 1 → (c.work 0).cells j = Γ.blank) → + (∀ i : Fin 4, i ≠ 0 → (c.work i).cells = (initTape []).cells ∧ (c.work i).head = 1) → + c.output.cells = (initTape []).cells → c.output.head = 1 → + ∃ c', + (copyInputToWorkTM (0 : Fin 4)).reachesIn (remaining + 1) c c' ∧ + (copyInputToWorkTM (0 : Fin 4)).halted c' ∧ + (c'.work 0).cells 0 = Γ.start ∧ + (∀ (j : ℕ) (hj : j < desc.length), + (c'.work 0).cells (j + 1) = Γ.ofBool (desc[j]'hj)) ∧ + (c'.work 0).cells (desc.length + 1) = Γ.blank ∧ + (c'.work 0).head = desc.length + 1 ∧ + c'.input.head = desc.length + 1 ∧ + (∀ i : Fin 4, i ≠ 0 → (c'.work i).head = 1) ∧ + c'.output.head = 1 ∧ + (∀ i : Fin 4, (c'.work i).cells 0 = Γ.start) ∧ + (∀ i : Fin 4, ∀ j, j ≥ 1 → (c'.work i).cells j ≠ Γ.start) ∧ + (∀ i : Fin 4, i ≠ 0 → (c'.work i).cells = (initTape []).cells) ∧ + c'.input.cells = c.input.cells ∧ + c'.output.cells = (initTape []).cells := by + intro remaining + induction remaining with + | zero => + intro copied hrem hcopied c hstate hinp_cells hinp_head hw0_head hw0_cell0 hw0_copied + hw0_blank hother hout_cells hout_head + have hceq : copied = desc.length := by omega + subst hceq + have hinp_read : c.input.read = Γ.blank := by + rw [Tape.read, hinp_head, hinp_cells]; exact input_sep desc rest + have hw0_ne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hw0_head]; intro h + have := hw0_blank _ le_rfl; rw [h] at this; exact Γ.noConfusion this + have hother_ne : ∀ i : Fin 4, i ≠ 0 → (c.work i).read ≠ Γ.start := by + intro i hi; rw [Tape.read, (hother i hi).2, (hother i hi).1]; simp [initTape] + have hout_ne : c.output.read ≠ Γ.start := by + rw [Tape.read, hout_head, hout_cells]; simp [initTape] + have hiDir : idleDir c.input.read = Dir3.stay := by simp [idleDir, hinp_read] + have hw0Dir : idleDir (c.work 0).read = Dir3.stay := by simp [idleDir, hw0_ne] + -- Compute the step + have hstep : (copyInputToWorkTM (0 : Fin 4)).step c = some + { state := CopyPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + (Γw.blank).toΓ (idleDir (c.work i).read) + output := c.output.writeAndMove (Γw.blank).toΓ (idleDir c.output.read) } := by + simp only [TM.step, hstate, copyInputToWorkTM, hinp_read, allIdle, ↓reduceIte] + congr 1 + refine ⟨_, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- For each goal, the `c'.work i` is `(c.work i).writeAndMove Γw.blank.toΓ (idleDir (c.work i).read)` + -- For i=0: writeAndMove(.blank, stay) since hw0Dir. head and cells[0] preserved. + -- For i≠0: writeAndMove(.blank, stay) since hother_dir. head=1 preserved. + -- cell 0 + · simp only [Tape.writeAndMove, hw0Dir, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) 0 (by rw [hw0_head]; omega)] + exact hw0_cell0 + -- desc bits + · intro j hj + simp only [Tape.writeAndMove, hw0Dir, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) (j + 1) (by rw [hw0_head]; omega)] + exact hw0_copied j hj + -- blank sentinel + · simp only [Tape.writeAndMove, hw0Dir, Tape.move] + rw [write_cells_at _ _ (by rw [hw0_head]; omega) _ hw0_head]; rfl + -- work 0 head + · simp only [Tape.writeAndMove, hw0Dir, Tape.move, write_head, hw0_head] + -- input head + · simp only [hiDir, Tape.move, hinp_head] + -- other work heads + · intro i hi + have hd : idleDir (c.work i).read = Dir3.stay := by simp [idleDir, hother_ne i hi] + simp only [Tape.writeAndMove, hd, Tape.move, write_head, (hother i hi).2] + -- output head + · have hoDir : idleDir c.output.read = Dir3.stay := by simp [idleDir, hout_ne] + simp only [Tape.writeAndMove, hoDir, Tape.move, write_head, hout_head] + -- all work cells 0 = ▷ + · intro i + by_cases hi : (i : Fin 4) = 0 + · subst hi + simp only [Tape.writeAndMove, hw0Dir, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) 0 (by rw [hw0_head]; omega)] + exact hw0_cell0 + · have hd : idleDir (c.work i).read = Dir3.stay := by simp [idleDir, hother_ne i hi] + simp only [Tape.writeAndMove, hd, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [(hother i hi).2]; omega) 0 + (by rw [(hother i hi).2]; omega)] + rw [(hother i hi).1]; rfl + -- all work cells j ≥ 1 ≠ ▷ + · intro i j hj + by_cases hi : (i : Fin 4) = 0 + · subst hi + simp only [Tape.writeAndMove, hw0Dir, Tape.move] + by_cases hje : j = desc.length + 1 + · subst hje; rw [write_cells_at _ _ (by rw [hw0_head]; omega) _ hw0_head]; exact Γ.noConfusion + · rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) _ (by rw [hw0_head]; exact hje)] + intro habs + by_cases hjl : j ≤ desc.length + · have := hw0_copied (j - 1) (by omega) + rw [show j - 1 + 1 = j by omega] at this + rw [this] at habs; exact ofBool_ne_start _ habs + · have := hw0_blank j (by omega); rw [this] at habs; exact Γ.noConfusion habs + · have hd : idleDir (c.work i).read = Dir3.stay := by simp [idleDir, hother_ne i hi] + simp only [Tape.writeAndMove, hd, Tape.move] + by_cases hje : j = 1 + · subst hje; rw [write_cells_at _ _ (by rw [(hother i hi).2]; omega) _ (hother i hi).2] + exact Γ.noConfusion + · rw [write_cells_of_ne_head _ _ (by rw [(hother i hi).2]; omega) _ + (by rw [(hother i hi).2]; exact hje)] + rw [(hother i hi).1] + intro habs; simp only [initTape] at habs + have : j ≠ 0 := by omega + simp [this] at habs + -- non-target work tape cells preserved + · intro i hi + have hd : idleDir (c.work i).read = Dir3.stay := by simp [idleDir, hother_ne i hi] + simp only [Tape.writeAndMove, hd, Tape.move] + ext j + by_cases hj0 : (c.work i).head = 0 + · rw [(hother i hi).2] at hj0; omega + · by_cases hje : j = (c.work i).head + · subst hje; rw [write_cells_at_head _ _ hj0, (hother i hi).2] + simp [initTape, Γw.toΓ] + · rw [write_cells_of_ne_head _ _ hj0 j hje, (hother i hi).1] + -- input cells preserved (move only changes head) + · simp only [hiDir, Tape.move] + -- output cells = initTape [] + · have hoDir : idleDir c.output.read = Dir3.stay := by simp [idleDir, hout_ne] + simp only [Tape.writeAndMove, hoDir, Tape.move] + ext j + by_cases hj0 : c.output.head = 0 + · omega + · by_cases hje : j = c.output.head + · subst hje; rw [write_cells_at_head _ _ hj0, hout_head]; simp [initTape, Γw.toΓ] + · rw [write_cells_of_ne_head _ _ hj0 j hje, hout_cells] + | succ rem ih => + intro copied hrem hcopied c hstate hinp_cells hinp_head hw0_head hw0_cell0 hw0_copied + hw0_blank hother hout_cells hout_head + have hclt : copied < desc.length := by omega + have hinp_read : c.input.read = Γ.ofBool desc[copied] := by + rw [Tape.read, hinp_head, hinp_cells]; exact input_desc desc rest copied hclt + have hinp_ne_blank : c.input.read ≠ Γ.blank := by rw [hinp_read]; exact ofBool_ne_blank _ + have hwrite_val : (match c.input.read with + | .zero => Γw.zero | .one => Γw.one | .blank => Γw.blank | .start => Γw.blank + : Γw).toΓ = Γ.ofBool desc[copied] := by + rw [hinp_read]; cases desc[copied] <;> rfl + have hw0_ne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hw0_head]; intro h + have := hw0_blank _ le_rfl; rw [h] at this; exact Γ.noConfusion this + have hother_ne : ∀ i : Fin 4, i ≠ 0 → (c.work i).read ≠ Γ.start := by + intro i hi; rw [Tape.read, (hother i hi).2, (hother i hi).1]; simp [initTape] + have hout_ne : c.output.read ≠ Γ.start := by + rw [Tape.read, hout_head, hout_cells]; simp [initTape] + -- set up the write value + set w : Γw := match c.input.read with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank with w_def + -- Build step result + let c₁ : Cfg 4 (copyInputToWorkTM (0 : Fin 4)).Q := + { state := CopyPhase.copying + input := c.input.move Dir3.right + work := fun i => if i = (0 : Fin 4) + then (c.work 0).writeAndMove w.toΓ Dir3.right + else (c.work i).writeAndMove (Γw.blank).toΓ (idleDir (c.work i).read) + output := c.output.writeAndMove (Γw.blank).toΓ (idleDir c.output.read) } + have hstep : (copyInputToWorkTM (0 : Fin 4)).step c = some c₁ := by + unfold TM.step; rw [show (copyInputToWorkTM (0 : Fin 4)).qhalt = CopyPhase.done from rfl] + rw [show c.state = CopyPhase.copying from hstate] + simp only [↓reduceIte, copyInputToWorkTM, hinp_ne_blank] + show some _ = some c₁ + congr 1 + simp only [c₁]; congr 1 + ext i : 1 + split + · next h => subst h; rfl + · rfl + -- Properties of c₁ + have h₁_inp_cells : c₁.input.cells = c.input.cells := by + change (c.input.move Dir3.right).cells = _; simp [Tape.move] + have h₁_inp_head : c₁.input.head = copied + 2 := by + simp [c₁, Tape.move, hinp_head] + have h₁_w0_head : (c₁.work 0).head = copied + 2 := by + show ((c.work 0).writeAndMove w.toΓ Dir3.right).head = _ + simp [Tape.writeAndMove, Tape.move, write_head, hw0_head] + have h₁_w0_cell0 : (c₁.work 0).cells 0 = Γ.start := by + show ((c.work 0).writeAndMove w.toΓ Dir3.right).cells 0 = _ + rw [Tape.writeAndMove, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) 0 (by rw [hw0_head]; omega)] + exact hw0_cell0 + have h₁_w0_copied : ∀ (j : ℕ) (hj : j < copied + 1), + (c₁.work 0).cells (j + 1) = Γ.ofBool (desc[j]'(by omega)) := by + intro j hj + change ((c.work 0).writeAndMove w.toΓ Dir3.right).cells (j + 1) = _ + simp only [Tape.writeAndMove, Tape.move] + by_cases hje : j = copied + · subst hje + rw [write_cells_at _ _ (by rw [hw0_head]; omega) _ hw0_head] + exact hwrite_val + · rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) (j + 1) + (by rw [hw0_head]; omega)] + exact hw0_copied j (by omega) + have h₁_w0_blank : ∀ j, j ≥ copied + 2 → (c₁.work 0).cells j = Γ.blank := by + intro j hj + change ((c.work 0).writeAndMove w.toΓ Dir3.right).cells j = _ + simp only [Tape.writeAndMove, Tape.move] + rw [write_cells_of_ne_head _ _ (by rw [hw0_head]; omega) j (by rw [hw0_head]; omega)] + exact hw0_blank j (by omega) + have h₁_other : ∀ i : Fin 4, i ≠ 0 → + (c₁.work i).cells = (initTape []).cells ∧ (c₁.work i).head = 1 := by + intro i hi + have hd : idleDir (c.work i).read = Dir3.stay := by simp [idleDir, hother_ne i hi] + have hh := (hother i hi).2 + constructor + · change (if (i : Fin 4) = 0 then _ else (c.work i).writeAndMove _ _).cells = _ + rw [if_neg hi, Tape.writeAndMove, hd, Tape.move] + ext j + by_cases hj0 : (c.work i).head = 0 + · omega -- head = 1 and head = 0 is contradictory + · by_cases hje : j = (c.work i).head + · subst hje; rw [write_cells_at_head _ _ hj0]; rw [hh]; simp [initTape] + · rw [write_cells_of_ne_head _ _ hj0 j hje, (hother i hi).1] + · change (if (i : Fin 4) = 0 then _ else (c.work i).writeAndMove _ _).head = _ + rw [if_neg hi, Tape.writeAndMove, hd, Tape.move, write_head, hh] + have h₁_out_cells : c₁.output.cells = (initTape []).cells := by + change (c.output.writeAndMove _ _).cells = _ + have hoDir : idleDir c.output.read = Dir3.stay := by simp [idleDir, hout_ne] + rw [Tape.writeAndMove, hoDir, Tape.move] + ext j + by_cases hj0 : c.output.head = 0 + · omega -- head = 1 and head = 0 is contradictory + · by_cases hje : j = c.output.head + · subst hje; rw [write_cells_at_head _ _ hj0]; rw [hout_head]; simp [initTape] + · rw [write_cells_of_ne_head _ _ hj0 j hje, hout_cells] + have h₁_out_head : c₁.output.head = 1 := by + change (c.output.writeAndMove _ _).head = _ + have hoDir : idleDir c.output.read = Dir3.stay := by simp [idleDir, hout_ne] + rw [Tape.writeAndMove, hoDir, Tape.move, write_head, hout_head] + -- Apply IH + obtain ⟨c', hreach, hhalt, r1, r2, r3, r4, r5, r6, r7, r8, r9, r9b, r10, r11⟩ := + ih (copied + 1) (by omega) (by omega) c₁ rfl (h₁_inp_cells ▸ hinp_cells) + h₁_inp_head h₁_w0_head h₁_w0_cell0 h₁_w0_copied h₁_w0_blank h₁_other + h₁_out_cells h₁_out_head + exact ⟨c', .step hstep hreach, hhalt, r1, r2, r3, r4, r5, r6, r7, r8, r9, + fun i hi => r9b i hi, + r10.trans h₁_inp_cells, r11⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Main theorem +-- ════════════════════════════════════════════════════════════════════════ + +theorem copyInputToWorkTM_hoareTime (tm : TM n) (x : List Bool) : + (copyInputToWorkTM (0 : Fin 4)).HoareTime + (initTM_pre tm x) + (postCopy tm x) + (copyBound (TMEncoding.encodeTM tm).length) := by + intro inp work out ⟨hinp, hwork, hout⟩ + set desc := TMEncoding.encodeTM tm + set rest := x.map Γ.ofBool + -- First step: head 0, reads ▷ (not blank), moves all right to position 1 + have hinp_read_start : (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).read = Γ.start := by + simp [Tape.read, initTape] + have hinp_read_ne : (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).read ≠ Γ.blank := by + rw [hinp_read_start]; exact Γ.noConfusion + -- The initial config + set c₀ : Cfg 4 (copyInputToWorkTM (0 : Fin 4)).Q := + { state := CopyPhase.copying, input := inp, work := work, output := out } + -- Step result after first step + have hstep₀ : ∃ c₁, (copyInputToWorkTM (0 : Fin 4)).step c₀ = some c₁ ∧ + c₁.state = CopyPhase.copying ∧ + c₁.input.cells = (initTape (desc.map Γ.ofBool ++ [Γ.blank] ++ rest)).cells ∧ + c₁.input.head = 1 ∧ + (c₁.work 0).head = 1 ∧ + (c₁.work 0).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → (c₁.work 0).cells j = Γ.blank) ∧ + (∀ i : Fin 4, i ≠ 0 → (c₁.work i).cells = (initTape []).cells ∧ (c₁.work i).head = 1) ∧ + c₁.output.cells = (initTape []).cells ∧ + c₁.output.head = 1 := by + subst hinp; subst hwork; subst hout + simp only [c₀, TM.step, copyInputToWorkTM, encodeUTMInput] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + all_goals simp [Tape.writeAndMove, Tape.move, Tape.write, initTape, Tape.read, idleDir] + · ext i; simp [desc, rest] + · intro j hj; omega + obtain ⟨c₁, hstep₁, hstate₁, hinp_cells₁, hinp_head₁, hw0_head₁, hw0_cell0₁, + hw0_blank₁, hother₁, hout_cells₁, hout_head₁⟩ := hstep₀ + -- Apply copy_loop from copied=0 + obtain ⟨c', hreach, hhalt, r1, r2, r3, r4, r5, r6, r7, r8, r9, r9b, r10, r11⟩ := + copy_loop desc rest desc.length 0 (by omega) (by omega) c₁ hstate₁ + hinp_cells₁ hinp_head₁ hw0_head₁ hw0_cell0₁ + (by intro j hj; omega) hw0_blank₁ hother₁ hout_cells₁ hout_head₁ + refine ⟨c', desc.length + 2, le_refl _, ?_, hhalt, ?_⟩ + · rw [show desc.length + 2 = 1 + (desc.length + 1) by omega] + exact reachesIn_trans (copyInputToWorkTM (0 : Fin 4)) (.step hstep₁ .zero) hreach + · exact ⟨⟨r1, r2, r3⟩, r4, r5, r6, r7, ⟨r8, r9⟩, r9b, r10.trans hinp_cells₁, r11⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/InitInternal/Rewind.lean b/Complexitylib/Models/TuringMachine/UTM/InitInternal/Rewind.lean new file mode 100644 index 0000000..a53658f --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/InitInternal/Rewind.lean @@ -0,0 +1,597 @@ +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Complexitylib.Models.TuringMachine.Hoare + +/-! +# UTM Initialization: proof internals + +Frame-preserving rewind lemmas used to compose the final rewind phase +of `initTM`. Each rewind brings one work tape head to cell 1 while +leaving every other tape (input, output, and remaining work tapes) +unchanged and preserving `WorkTapesWF`. + +## Main results + +- `rewindWorkTM_hoareTime_frame` — general frame-preserving rewind +- `rewindDesc_hoareTime` — rewind work tape 0 with frame +- `rewindScratch_hoareTime` — rewind work tape 3 with frame +- `rewindAll_hoareTime` — compose 4 rewinds (tapes 0,1,2,3) +-/ + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem tape_move_cells' (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +private theorem readBackWrite_toΓ_eq' {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +/-- A tape with head ≥ 1 and no ▷ at cells ≥ 1 is unchanged by + `writeAndMove (readBackWrite t.read).toΓ (idleDir t.read)`. -/ +private theorem tape_idle_stable (t : Tape) + (hhead : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + have hread : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns t.head hhead + simp only [Tape.writeAndMove, idleDir, hread, ↓reduceIte, Tape.move, + readBackWrite_toΓ_eq' hread, Tape.write] + split + · omega + · simp only [Tape.read, Function.update_eq_self] + +/-- Input tape is unchanged by `move (idleDir t.read)` when head ≥ 1 and + no ▷ at cells ≥ 1. -/ +private theorem input_idle_stable (t : Tape) + (hhead : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.move (idleDir t.read) = t := by + have hread : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns t.head hhead + simp only [idleDir, hread, ↓reduceIte, Tape.move] + +-- ════════════════════════════════════════════════════════════════════════ +-- Frame-preserving rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +/-- An "envelope" predicate for the init rewind phase: all tapes are + well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷), all heads ≥ 1. -/ +def InitEnvelope (inp : Tape) (work : Fin 4 → Tape) (out : Tape) : Prop := + inp.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → inp.cells j ≠ Γ.start) ∧ + inp.head ≥ 1 ∧ + WorkTapesWF work ∧ + (∀ i, (work i).head ≥ 1) ∧ + out.cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) ∧ + out.head ≥ 1 + +/-- Frame-preserving rewind loop: from `moveLeft` state with target tape head + at position `h`, reach `moveRight` state in `h + 1` steps. + Target tape: head = 1, cells preserved. + All other tapes: completely unchanged. -/ +private theorem rewindWorkTM_rewind_loop_frame (idx : Fin 4) : + ∀ (h : ℕ) (c : Cfg 4 (rewindWorkTM idx).Q), + c.state = RewindPhase.moveLeft → + (c.work idx).cells 0 = Γ.start → + (∀ j, j ≥ 1 → (c.work idx).cells j ≠ Γ.start) → + (c.work idx).head = h → + -- Frame conditions: other tapes are well-formed with head ≥ 1 + (∀ j : Fin 4, j ≠ idx → + (c.work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (c.work j).cells p ≠ Γ.start) ∧ + (c.work j).head ≥ 1) → + c.input.cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → c.input.cells p ≠ Γ.start) ∧ + c.input.head ≥ 1 → + c.output.cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → c.output.cells p ≠ Γ.start) ∧ + c.output.head ≥ 1 → + ∃ c', + (rewindWorkTM idx).reachesIn (h + 1) c c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (∀ j : Fin 4, j ≠ idx → c'.work j = c.work j) ∧ + c'.input = c.input ∧ + c'.output = c.output := by + intro h + induction h with + | zero => + intro c hstate hcell0 _ hhead hframe hinp hout + have hread : (c.work idx).read = Γ.start := by simp [Tape.read, hhead, hcell0] + -- The target tape reads ▷, so we go to moveRight and move right + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveRight ∧ + (c'.work idx).head = 1 ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (∀ j : Fin 4, j ≠ idx → c'.work j = c.work j) ∧ + c'.input = c.input ∧ + c'.output = c.output := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · -- target tape head = 1 + dsimp only [] + simp [Tape.writeAndMove, Tape.move, Tape.write, hhead] + · -- target tape cells preserved + dsimp only [] + simp [Tape.writeAndMove, tape_move_cells, Tape.write, hhead] + · -- non-target work tapes unchanged + intro j hj + dsimp only [] + have hj_ne : ¬(j = idx) := hj + obtain ⟨hc0j, hnsj, hhdj⟩ := hframe j hj + simp only [↓reduceIte, hj_ne] + have : (c.work j).read ≠ Γ.start := by + simp only [Tape.read]; exact hnsj _ hhdj + exact tape_idle_stable (c.work j) hhdj hnsj + · -- input unchanged + obtain ⟨_, hins, hih⟩ := hinp + exact input_idle_stable c.input hih hins + · -- output unchanged + obtain ⟨_, hons, hoh⟩ := hout + exact tape_idle_stable c.output hoh hons + obtain ⟨c', hstep', hst', hh', hc', hfr', hinp', hout'⟩ := hstep + exact ⟨c', .step hstep' .zero, hst', hh', hc', hfr', hinp', hout'⟩ + | succ h ih => + intro c hstate hcell0 hnostart hhead hframe hinp hout + have hread_ne : (c.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead]; exact hnostart (h + 1) (by omega) + -- Target tape reads non-▷, so we move left and stay in moveLeft + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.moveLeft ∧ + (c'.work idx).head = h ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (∀ j : Fin 4, j ≠ idx → c'.work j = c.work j) ∧ + c'.input = c.input ∧ + c'.output = c.output := by + simp only [TM.step, ↓reduceIte, hstate, rewindWorkTM, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · -- target tape head = h + dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move] + rw [readBackWrite_toΓ_eq' hread_ne] + simp only [Tape.write]; split + · omega + · simp [hhead] + · -- target tape cells preserved + dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, tape_move_cells'] + rw [readBackWrite_toΓ_eq' hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · -- non-target work tapes unchanged + intro j hj + dsimp only [] + have hj_ne : ¬(j = idx) := hj + obtain ⟨hc0j, hnsj, hhdj⟩ := hframe j hj + simp only [↓reduceIte, hj_ne] + exact tape_idle_stable (c.work j) hhdj hnsj + · -- input unchanged + obtain ⟨_, hins, hih⟩ := hinp + exact input_idle_stable c.input hih hins + · -- output unchanged + obtain ⟨_, hons, hoh⟩ := hout + exact tape_idle_stable c.output hoh hons + obtain ⟨c', hstep', hst', hh', hc', hfr', hinp', hout'⟩ := hstep + have hframe' : ∀ j : Fin 4, j ≠ idx → + (c'.work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (c'.work j).cells p ≠ Γ.start) ∧ + (c'.work j).head ≥ 1 := by + intro j hj; rw [hfr' j hj]; exact hframe j hj + obtain ⟨c_mr, hreach, hst_mr, hh_mr, hc_mr, hfr_mr, hinp_mr, hout_mr⟩ := + ih c' hst' (by rw [hc']; exact hcell0) + (by intro j hj; rw [hc']; exact hnostart j hj) hh' + hframe' (by rw [hinp']; exact hinp) (by rw [hout']; exact hout) + exact ⟨c_mr, .step hstep' hreach, hst_mr, hh_mr, + by rw [hc_mr, hc'], + fun j hj => by rw [hfr_mr j hj, hfr' j hj], + by rw [hinp_mr, hinp'], + by rw [hout_mr, hout']⟩ + +/-- From `moveRight` state, take 1 step to done. All tapes preserved. -/ +private theorem rewindWorkTM_moveRight_to_done_frame (idx : Fin 4) + (c : Cfg 4 (rewindWorkTM idx).Q) + (hstate : c.state = RewindPhase.moveRight) + (hread_ne : (c.work idx).read ≠ Γ.start) + (hframe : ∀ j : Fin 4, j ≠ idx → + (c.work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (c.work j).cells p ≠ Γ.start) ∧ + (c.work j).head ≥ 1) + (hinp : c.input.cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → c.input.cells p ≠ Γ.start) ∧ + c.input.head ≥ 1) + (hout : c.output.cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → c.output.cells p ≠ Γ.start) ∧ + c.output.head ≥ 1) : + ∃ c', + (rewindWorkTM idx).reachesIn 1 c c' ∧ + (rewindWorkTM idx).halted c' ∧ + (c'.work idx).head = (c.work idx).head ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (∀ j : Fin 4, j ≠ idx → c'.work j = c.work j) ∧ + c'.input = c.input ∧ + c'.output = c.output := by + have hoDir : idleDir ((c.work idx).read) = Dir3.stay := by + simp [idleDir, hread_ne] + have hstep : ∃ c', (rewindWorkTM idx).step c = some c' ∧ + c'.state = RewindPhase.done ∧ + (c'.work idx).head = (c.work idx).head ∧ + (c'.work idx).cells = (c.work idx).cells ∧ + (∀ j : Fin 4, j ≠ idx → c'.work j = c.work j) ∧ + c'.input = c.input ∧ + c'.output = c.output := by + simp only [TM.step, hstate, rewindWorkTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · -- target head preserved + dsimp only [] + rw [Tape.writeAndMove, hoDir] + simp [Tape.move, Tape.write] + split <;> rfl + · -- target cells preserved + dsimp only [] + rw [Tape.writeAndMove, hoDir] + simp only [Tape.move, Tape.write] + split + · rfl + · rw [readBackWrite_toΓ_eq' hread_ne] + exact Function.update_eq_self _ _ + · -- non-target work tapes unchanged + intro j hj + dsimp only [] + obtain ⟨_, hnsj, hhdj⟩ := hframe j hj + exact tape_idle_stable (c.work j) hhdj hnsj + · -- input unchanged + obtain ⟨_, hins, hih⟩ := hinp + exact input_idle_stable c.input hih hins + · -- output unchanged + obtain ⟨_, hons, hoh⟩ := hout + exact tape_idle_stable c.output hoh hons + obtain ⟨c', hstep', hst', hhead', hcells', hfr', hinp', hout'⟩ := hstep + exact ⟨c', .step hstep' .zero, hst', hhead', hcells', hfr', hinp', hout'⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Frame-preserving HoareTime for rewindWorkTM +-- ════════════════════════════════════════════════════════════════════════ + +/-- Frame-preserving HoareTime for `rewindWorkTM idx`: + Given `InitEnvelope` and a head bound on the target tape, + the target tape head goes to 1 with cells preserved, + all other tapes unchanged, and `InitEnvelope` maintained. -/ +theorem rewindWorkTM_hoareTime_frame (idx : Fin 4) (B : ℕ) : + (rewindWorkTM idx).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + (work idx).head ≤ B) + (fun inp work out => + InitEnvelope inp work out ∧ + (work idx).head = 1) + (B + 2) := by + intro inp work out ⟨henv, hhead_le⟩ + obtain ⟨hic0, hins, hih, hwf, hheads, hoc0, hons, hoh⟩ := henv + -- Phase 1: rewind loop + have hframe : ∀ j : Fin 4, j ≠ idx → + (work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (work j).cells p ≠ Γ.start) ∧ + (work j).head ≥ 1 := + fun j _ => ⟨hwf.1 j, hwf.2 j, hheads j⟩ + obtain ⟨c_mr, hreach_rw, hst_mr, hhead_mr, hcells_mr, hfr_mr, hinp_mr, hout_mr⟩ := + rewindWorkTM_rewind_loop_frame idx (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl (hwf.1 idx) (hwf.2 idx) rfl hframe + ⟨hic0, hins, hih⟩ ⟨hoc0, hons, hoh⟩ + -- Phase 2: moveRight → done + have hread_mr : (c_mr.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead_mr, hcells_mr]; exact hwf.2 idx 1 (by omega) + have hframe_mr : ∀ j : Fin 4, j ≠ idx → + (c_mr.work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (c_mr.work j).cells p ≠ Γ.start) ∧ + (c_mr.work j).head ≥ 1 := by + intro j hj; rw [hfr_mr j hj]; exact hframe j hj + obtain ⟨c_done, hreach_done, hhalt, hhead_done, hcells_done, hfr_done, hinp_done, hout_done⟩ := + rewindWorkTM_moveRight_to_done_frame idx c_mr hst_mr hread_mr hframe_mr + (by rw [hinp_mr]; exact ⟨hic0, hins, hih⟩) (by rw [hout_mr]; exact ⟨hoc0, hons, hoh⟩) + refine ⟨c_done, ((work idx).head + 1) + 1, by omega, + reachesIn_trans (rewindWorkTM idx) hreach_rw hreach_done, hhalt, ?_⟩ + -- Simplify all c_mr/c_done references back to originals + have hinp_eq : c_done.input = inp := by rw [hinp_done, hinp_mr] + have hout_eq : c_done.output = out := by rw [hout_done, hout_mr] + have hcells_eq : (c_done.work idx).cells = (work idx).cells := by + rw [hcells_done, hcells_mr] + have hwork_eq : ∀ j : Fin 4, j ≠ idx → c_done.work j = work j := by + intro j hj; rw [hfr_done j hj, hfr_mr j hj] + -- WorkTapesWF for c_done + have hwf'1 : ∀ i, (c_done.work i).cells 0 = Γ.start := by + intro i + by_cases hi : i = idx + · subst hi; rw [hcells_eq]; exact hwf.1 _ + · rw [hwork_eq i hi]; exact hwf.1 i + have hwf'2 : ∀ i j, j ≥ 1 → (c_done.work i).cells j ≠ Γ.start := by + intro i j hj + by_cases hi : i = idx + · subst hi; rw [hcells_eq]; exact hwf.2 _ j hj + · rw [hwork_eq i hi]; exact hwf.2 i j hj + have hwf' : WorkTapesWF c_done.work := ⟨hwf'1, hwf'2⟩ + have hheads' : ∀ i, (c_done.work i).head ≥ 1 := by + intro i + by_cases hi : i = idx + · subst hi; rw [hhead_done, hhead_mr] + · rw [hwork_eq i hi]; exact hheads i + constructor + · exact ⟨by rw [hinp_eq]; exact hic0, + by intro j hj; rw [hinp_eq]; exact hins j hj, + by rw [hinp_eq]; exact hih, + hwf', hheads', + by rw [hout_eq]; exact hoc0, + by intro j hj; rw [hout_eq]; exact hons j hj, + by rw [hout_eq]; exact hoh⟩ + · rw [hhead_done, hhead_mr] + +-- ════════════════════════════════════════════════════════════════════════ +-- Specific rewind instances +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind work tape 0 (desc) with frame preservation. -/ +theorem rewindDesc_hoareTime (B : ℕ) : + (rewindWorkTM (0 : Fin 4)).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + (work 0).head ≤ B) + (fun inp work out => + InitEnvelope inp work out ∧ + (work 0).head = 1) + (B + 2) := + rewindWorkTM_hoareTime_frame 0 B + +/-- Rewind work tape 3 (scratch) with frame preservation. -/ +theorem rewindScratch_hoareTime (B : ℕ) : + (rewindWorkTM (3 : Fin 4)).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + (work 3).head ≤ B) + (fun inp work out => + InitEnvelope inp work out ∧ + (work 3).head = 1) + (B + 2) := + rewindWorkTM_hoareTime_frame 3 B + +-- ════════════════════════════════════════════════════════════════════════ +-- SeqTransition identity under InitEnvelope +-- ════════════════════════════════════════════════════════════════════════ + +/-- Under `InitEnvelope`, the seq transition is identity on all tapes. -/ +private theorem initEnvelope_seqTrans_id {inp : Tape} {work : Fin 4 → Tape} {out : Tape} + (henv : InitEnvelope inp work out) : + seqTransitionInput inp = inp ∧ + (fun i => seqTransitionTape (work i)) = work ∧ + seqTransitionTape out = out := by + obtain ⟨hic0, hins, hih, hwf, hheads, hoc0, hons, hoh⟩ := henv + refine ⟨?_, ?_, ?_⟩ + · exact seqTransitionInput_id (by simp [Tape.read]; exact hins inp.head hih) + · ext i + apply seqTransitionTape_id + · intro h + have := hwf.2 i (work i).head (hheads i) + rw [Tape.read] at h + exact this h + · exact hheads i + · apply seqTransitionTape_id + · intro h + have := hons out.head hoh + rw [Tape.read] at h + exact this h + · exact hoh + +/-- `h_trans` obligation for seqTM when `InitEnvelope` is part of the mid predicate. -/ +private theorem initEnvelope_h_trans {P : TapePred 4} + {inp : Tape} {work : Fin 4 → Tape} {out : Tape} + (hmid : InitEnvelope inp work out ∧ P inp work out) : + (InitEnvelope (seqTransitionInput inp) + (fun i => seqTransitionTape (work i)) + (seqTransitionTape out)) ∧ + P (seqTransitionInput inp) + (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + obtain ⟨henv, hp⟩ := hmid + obtain ⟨hi, hw, ho⟩ := initEnvelope_seqTrans_id henv + rw [hi, hw, ho] + exact ⟨henv, hp⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Compose 4 rewinds +-- ════════════════════════════════════════════════════════════════════════ + +/-- Enriched frame-preserving rewind: postcondition carries head bounds for + ALL tapes. Target tape gets head = 1 (≤ anything), non-target tapes + retain their original bounds since they're completely unchanged. -/ +theorem rewindWorkTM_hoareTime_frame_bounds (idx : Fin 4) (bounds : Fin 4 → ℕ) : + (rewindWorkTM idx).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + ∀ i, (work i).head ≤ bounds i) + (fun inp work out => + InitEnvelope inp work out ∧ + (work idx).head = 1 ∧ + ∀ i, i ≠ idx → (work i).head ≤ bounds i) + (bounds idx + 2) := by + intro inp work out ⟨henv, hbounds⟩ + obtain ⟨hic0, hins, hih, hwf, hheads, hoc0, hons, hoh⟩ := henv + have hframe : ∀ j : Fin 4, j ≠ idx → + (work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (work j).cells p ≠ Γ.start) ∧ + (work j).head ≥ 1 := + fun j _ => ⟨hwf.1 j, hwf.2 j, hheads j⟩ + obtain ⟨c_mr, hreach_rw, hst_mr, hhead_mr, hcells_mr, hfr_mr, hinp_mr, hout_mr⟩ := + rewindWorkTM_rewind_loop_frame idx (work idx).head + { state := RewindPhase.moveLeft, input := inp, work := work, output := out } + rfl (hwf.1 idx) (hwf.2 idx) rfl hframe + ⟨hic0, hins, hih⟩ ⟨hoc0, hons, hoh⟩ + have hread_mr : (c_mr.work idx).read ≠ Γ.start := by + simp [Tape.read, hhead_mr, hcells_mr]; exact hwf.2 idx 1 (by omega) + have hframe_mr : ∀ j : Fin 4, j ≠ idx → + (c_mr.work j).cells 0 = Γ.start ∧ + (∀ p, p ≥ 1 → (c_mr.work j).cells p ≠ Γ.start) ∧ + (c_mr.work j).head ≥ 1 := by + intro j hj; rw [hfr_mr j hj]; exact hframe j hj + obtain ⟨c_done, hreach_done, hhalt, hhead_done, hcells_done, hfr_done, hinp_done, hout_done⟩ := + rewindWorkTM_moveRight_to_done_frame idx c_mr hst_mr hread_mr hframe_mr + (by rw [hinp_mr]; exact ⟨hic0, hins, hih⟩) (by rw [hout_mr]; exact ⟨hoc0, hons, hoh⟩) + -- Derive frame equalities + have hinp_eq : c_done.input = inp := by rw [hinp_done, hinp_mr] + have hout_eq : c_done.output = out := by rw [hout_done, hout_mr] + have hcells_eq : (c_done.work idx).cells = (work idx).cells := by + rw [hcells_done, hcells_mr] + have hwork_eq : ∀ j : Fin 4, j ≠ idx → c_done.work j = work j := by + intro j hj; rw [hfr_done j hj, hfr_mr j hj] + -- Build postcondition + have hwf'1 : ∀ i, (c_done.work i).cells 0 = Γ.start := by + intro i; by_cases hi : i = idx + · subst hi; rw [hcells_eq]; exact hwf.1 _ + · rw [hwork_eq i hi]; exact hwf.1 i + have hwf'2 : ∀ i j, j ≥ 1 → (c_done.work i).cells j ≠ Γ.start := by + intro i j hj; by_cases hi : i = idx + · subst hi; rw [hcells_eq]; exact hwf.2 _ j hj + · rw [hwork_eq i hi]; exact hwf.2 i j hj + have hheads' : ∀ i, (c_done.work i).head ≥ 1 := by + intro i; by_cases hi : i = idx + · subst hi; rw [hhead_done, hhead_mr] + · rw [hwork_eq i hi]; exact hheads i + have hb_idx := hbounds idx + refine ⟨c_done, ((work idx).head + 1) + 1, by omega, + reachesIn_trans (rewindWorkTM idx) hreach_rw hreach_done, hhalt, + ⟨by rw [hinp_eq]; exact hic0, + by intro j hj; rw [hinp_eq]; exact hins j hj, + by rw [hinp_eq]; exact hih, + ⟨hwf'1, hwf'2⟩, hheads', + by rw [hout_eq]; exact hoc0, + by intro j hj; rw [hout_eq]; exact hons j hj, + by rw [hout_eq]; exact hoh⟩, + by rw [hhead_done, hhead_mr], + fun i hi => by rw [hwork_eq i hi]; exact hbounds i⟩ + + +/-- Composition of 4 rewinds via `seqTM_hoareTime`. -/ +theorem rewindAll_hoareTime (B0 B1 B2 B3 : ℕ) : + (seqTM (rewindWorkTM (0 : Fin 4)) + (seqTM (rewindWorkTM (1 : Fin 4)) + (seqTM (rewindWorkTM (2 : Fin 4)) + (rewindWorkTM (3 : Fin 4))))).HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + (work 0).head ≤ B0 ∧ + (work 1).head ≤ B1 ∧ + (work 2).head ≤ B2 ∧ + (work 3).head ≤ B3) + (fun inp work out => + InitEnvelope inp work out ∧ + ∀ i, (work i).head = 1) + (B0 + B1 + B2 + B3 + 11) := by + -- We use `seqTM_hoareTime` three times to compose 4 rewinds. + -- The key helper is `rewindWorkTM_hoareTime_frame_bounds` which carries + -- head bounds for all tapes through each rewind. + -- + -- Intermediate bound functions: + -- pre: ![B0, B1, B2, B3] + -- mid0: ![1, B1, B2, B3] (after rewind 0) + -- mid1: ![1, 1, B2, B3] (after rewind 1) + -- mid2: ![1, 1, 1, B3] (after rewind 2) + -- post: ![1, 1, 1, 1 ] (after rewind 3) + let b0 : Fin 4 → ℕ := fun i => match i with | 0 => B0 | 1 => B1 | 2 => B2 | 3 => B3 + let b1 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => B1 | 2 => B2 | 3 => B3 + let b2 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => 1 | 2 => B2 | 3 => B3 + let b3 : Fin 4 → ℕ := fun i => match i with | 0 => 1 | 1 => 1 | 2 => 1 | 3 => B3 + -- Intermediate predicates + let mid0 : TapePred 4 := fun inp work out => + InitEnvelope inp work out ∧ ∀ i, (work i).head ≤ b1 i + let mid1 : TapePred 4 := fun inp work out => + InitEnvelope inp work out ∧ ∀ i, (work i).head ≤ b2 i + let mid2 : TapePred 4 := fun inp work out => + InitEnvelope inp work out ∧ ∀ i, (work i).head ≤ b3 i + -- Build each rewind's HoareTime spec + have h_rw0 : (rewindWorkTM (0 : Fin 4)).HoareTime + (fun inp work out => InitEnvelope inp work out ∧ ∀ i, (work i).head ≤ b0 i) + mid0 (B0 + 2) := + (rewindWorkTM_hoareTime_frame_bounds 0 b0).consequence + (fun _ _ _ h => h) + (fun _ _ _ ⟨henv', hhead0, hrest⟩ => ⟨henv', fun i => by + match i with + | 0 => rw [hhead0] + | 1 => exact hrest 1 (by decide) + | 2 => exact hrest 2 (by decide) + | 3 => exact hrest 3 (by decide)⟩) + le_rfl + have h_rw1 : (rewindWorkTM (1 : Fin 4)).HoareTime mid0 mid1 (B1 + 2) := + (rewindWorkTM_hoareTime_frame_bounds 1 b1).consequence + (fun _ _ _ h => h) + (fun _ _ _ ⟨henv', hhead1, hrest⟩ => ⟨henv', fun i => by + match i with + | 0 => exact hrest 0 (by decide) + | 1 => rw [hhead1] + | 2 => exact hrest 2 (by decide) + | 3 => exact hrest 3 (by decide)⟩) + le_rfl + have h_rw2 : (rewindWorkTM (2 : Fin 4)).HoareTime mid1 mid2 (B2 + 2) := + (rewindWorkTM_hoareTime_frame_bounds 2 b2).consequence + (fun _ _ _ h => h) + (fun _ _ _ ⟨henv', hhead2, hrest⟩ => ⟨henv', fun i => by + match i with + | 0 => exact hrest 0 (by decide) + | 1 => exact hrest 1 (by decide) + | 2 => rw [hhead2] + | 3 => exact hrest 3 (by decide)⟩) + le_rfl + have h_rw3 : (rewindWorkTM (3 : Fin 4)).HoareTime mid2 + (fun inp work out => InitEnvelope inp work out ∧ ∀ i, (work i).head = 1) + (B3 + 2) := + (rewindWorkTM_hoareTime_frame_bounds 3 b3).consequence + (fun _ _ _ h => h) + (fun _ work' _ ⟨henv', hhead3, hrest⟩ => ⟨henv', fun i => by + have hge := henv'.2.2.2.2.1 i + match i with + | 0 => have := hrest 0 (by decide); dsimp [b3] at this; omega + | 1 => have := hrest 1 (by decide); dsimp [b3] at this; omega + | 2 => have := hrest 2 (by decide); dsimp [b3] at this; omega + | 3 => exact hhead3⟩) + le_rfl + -- Helper for h_trans: seq transition is identity on each mid predicate + have h_trans_mid0 : ∀ inp work out, mid0 inp work out → + mid0 (seqTransitionInput inp) (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + intro inp' work' out' ⟨henv', hp⟩ + obtain ⟨hi, hw, ho⟩ := initEnvelope_seqTrans_id henv' + rw [hi, hw, ho]; exact ⟨henv', hp⟩ + have h_trans_mid1 : ∀ inp work out, mid1 inp work out → + mid1 (seqTransitionInput inp) (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + intro inp' work' out' ⟨henv', hp⟩ + obtain ⟨hi, hw, ho⟩ := initEnvelope_seqTrans_id henv' + rw [hi, hw, ho]; exact ⟨henv', hp⟩ + have h_trans_mid2 : ∀ inp work out, mid2 inp work out → + mid2 (seqTransitionInput inp) (fun i => seqTransitionTape (work i)) + (seqTransitionTape out) := by + intro inp' work' out' ⟨henv', hp⟩ + obtain ⟨hi, hw, ho⟩ := initEnvelope_seqTrans_id henv' + rw [hi, hw, ho]; exact ⟨henv', hp⟩ + -- Compose using seqTM_hoareTime, then adjust bound + exact (seqTM_hoareTime _ _ h_rw0 h_trans_mid0 + (seqTM_hoareTime _ _ h_rw1 h_trans_mid1 + (seqTM_hoareTime _ _ h_rw2 h_trans_mid2 h_rw3))).consequence + (fun inp' work' out' ⟨henv', hb0', hb1', hb2', hb3'⟩ => + (⟨henv', fun i => by + match i with + | 0 => exact hb0' + | 1 => exact hb1' + | 2 => exact hb2' + | 3 => exact hb3'⟩ : + InitEnvelope inp' work' out' ∧ ∀ i, (work' i).head ≤ b0 i)) + (fun _ _ _ h => h) + (by omega) + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupSim.lean b/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupSim.lean new file mode 100644 index 0000000..783386f --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupSim.lean @@ -0,0 +1,2127 @@ +import Complexitylib.Models.TuringMachine.UTM.Init.Defs +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.Hoare +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Rewind + +/-! +# Init proof internals: setupSimTM + +Step-by-step simulation lemmas and HoareTime proof for `setupSimTM`. +-/ + +set_option linter.unusedSimpArgs false +set_option linter.unusedVariables false + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem init_readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem init_tape_move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +private theorem init_tape_read_ne_start (t : Tape) (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns _ hh + +private theorem idle_tape_preserved {t : Tape} (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + have hread : t.read ≠ Γ.start := init_tape_read_ne_start _ hh hns + simp only [Tape.writeAndMove, idleDir, hread, ↓reduceIte, Tape.move, + Tape.write, show t.head ≠ 0 from by omega] + congr 1 + rw [init_readBackWrite_toΓ_eq hread]; exact Function.update_eq_self _ _ + +private theorem idle_input_preserved {t : Tape} (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.move (idleDir t.read) = t := by + have hread : t.read ≠ Γ.start := init_tape_read_ne_start _ hh hns + simp [idleDir, hread, Tape.move] + +private theorem writeAndMove_right_head {t : Tape} {w : Γw} : + (t.writeAndMove w Dir3.right).head = t.head + 1 := by + simp [Tape.writeAndMove, Tape.write]; split <;> simp [Tape.move] + +private theorem writeAndMove_cells_at_head {t : Tape} {w : Γw} {d : Dir3} + (hh : t.head ≠ 0) : + (t.writeAndMove w d).cells t.head = w.toΓ := by + simp only [Tape.writeAndMove, init_tape_move_cells, Tape.write, hh, ↓reduceIte, + Function.update_self] + +private theorem writeAndMove_cells_ne {t : Tape} {w : Γw} {d : Dir3} {j : ℕ} + (hj : j ≠ t.head) : + (t.writeAndMove w d).cells j = t.cells j := by + simp only [Tape.writeAndMove, init_tape_move_cells, Tape.write] + split + · rfl + · simp only [Function.update]; split + · next h => exact absurd h hj + · rfl + +private theorem readBackWrite_cells {t : Tape} {d : Dir3} + (hh : t.head ≥ 1) (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + (t.writeAndMove (readBackWrite t.read) d).cells = t.cells := by + have hread : t.read ≠ Γ.start := init_tape_read_ne_start _ hh hns + ext j + simp only [Tape.writeAndMove, init_tape_move_cells, Tape.write, + show t.head ≠ 0 from by omega, ↓reduceIte] + simp only [Function.update] + split + · next h => subst h; exact init_readBackWrite_toΓ_eq hread + · rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- simTapeCellCorrect lemmas +-- ════════════════════════════════════════════════════════════════════════ + +private theorem simTapeCellCorrect_pos0 + (simTape : Tape) (tapeIdx : ℕ) (htape : tapeIdx < n + 2) + (hcells : ∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → simTape.cells j = Γ.one) : + simTapeCellCorrect (n + 2) tapeIdx 0 0 Γ.start simTape := by + simp only [simTapeCellCorrect, SuperCell.simTapeOffset, SuperCell.width, ↓reduceIte, + SuperCell.symToCellPair] + refine ⟨?_, ?_, ?_⟩ <;> (apply hcells <;> omega) + +private theorem simTapeCellCorrect_blank_cells + (simTape : Tape) (numTapes tapeIdx pos : ℕ) (hpos : pos > 0) + (hbase : ∀ off, off < 3 → + simTape.cells (SuperCell.simTapeOffset numTapes pos tapeIdx + off) = Γ.blank) : + simTapeCellCorrect numTapes tapeIdx pos 0 Γ.blank simTape := by + simp only [simTapeCellCorrect, SuperCell.symToCellPair] + have hne : (0 : ℕ) ≠ pos := by omega + simp only [hne, ↓reduceIte] + exact ⟨hbase 0 (by omega), hbase 1 (by omega), hbase 2 (by omega)⟩ + +private theorem simTapeCellCorrect_input_written + (simTape : Tape) (pos : ℕ) (b : Bool) (hpos : pos > 0) + (hc0 : simTape.cells (SuperCell.simTapeOffset (n + 2) pos 0) = Γ.blank) + (hc1 : simTape.cells (SuperCell.simTapeOffset (n + 2) pos 0 + 1) = Γ.zero) + (hc2 : simTape.cells (SuperCell.simTapeOffset (n + 2) pos 0 + 2) = Γ.ofBool b) : + simTapeCellCorrect (n + 2) 0 pos 0 (Γ.ofBool b) simTape := by + simp only [simTapeCellCorrect, SuperCell.symToCellPair] + have hne : (0 : ℕ) ≠ pos := by omega + simp only [hne, ↓reduceIte] + cases b <;> simp only [Γ.ofBool, SuperCell.symToCellPair] at * <;> exact ⟨hc0, hc1, hc2⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- superCellsCorrect from cell values +-- ════════════════════════════════════════════════════════════════════════ + +private theorem superCellsCorrect_from_cells + (tm : TM n) (x : List Bool) (simTape : Tape) + (h0 : simTape.cells 0 = Γ.start) + (hpos0 : ∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → simTape.cells j = Γ.one) + (hinput : ∀ (p : ℕ) (hp : p ≥ 1) (hp2 : p ≤ x.length), + simTape.cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + simTape.cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + simTape.cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) + (hblank : ∀ (numTapes tapeIdx pos : ℕ), + pos > 0 → tapeIdx < numTapes → numTapes = n + 2 → + (tapeIdx > 0 ∨ pos > x.length) → + ∀ off, off < 3 → + simTape.cells (SuperCell.simTapeOffset numTapes pos tapeIdx + off) = Γ.blank) : + superCellsCorrect (tm.initCfg x) simTape := by + refine ⟨h0, ?_, ?_, ?_⟩ + · intro pos + by_cases hpos0' : pos = 0 + · subst hpos0' + simp only [TM.initCfg, Cfg.init, initTape] + exact simTapeCellCorrect_pos0 simTape 0 (by omega) hpos0 + · have hpge : pos ≥ 1 := by omega + simp only [TM.initCfg, Cfg.init, initTape] + rw [if_neg hpos0'] + by_cases hle : pos ≤ x.length + · have hlt : pos - 1 < x.length := by omega + have hmapped : (List.map Γ.ofBool x)[pos - 1]? = + some (Γ.ofBool (x.get ⟨pos - 1, hlt⟩)) := by + rw [List.getElem?_map] + simp [hlt] + simp only [hmapped, Option.getD] + obtain ⟨hc0, hc1, hc2⟩ := hinput pos hpge hle + exact simTapeCellCorrect_input_written simTape pos + (x.get ⟨pos - 1, hlt⟩) (by omega) hc0 hc1 hc2 + · have : (List.map Γ.ofBool x)[pos - 1]? = none := by + rw [List.getElem?_eq_none]; simp; omega + simp only [this, Option.getD] + exact simTapeCellCorrect_blank_cells simTape (n + 2) 0 pos (by omega) + (fun off hoff => hblank (n + 2) 0 pos (by omega) (by omega) rfl + (Or.inr (by omega)) off hoff) + · intro i pos + by_cases hpos0' : pos = 0 + · subst hpos0' + simp only [TM.initCfg, Cfg.init, initTape] + exact simTapeCellCorrect_pos0 simTape (i.val + 1) (by omega) hpos0 + · simp only [TM.initCfg, Cfg.init, initTape] + rw [if_neg hpos0'] + have : ([] : List Γ)[pos - 1]? = (none : Option Γ) := by + rw [List.getElem?_eq_none]; simp + simp only [this, Option.getD] + exact simTapeCellCorrect_blank_cells simTape (n + 2) (i.val + 1) pos (by omega) + (fun off hoff => hblank (n + 2) (i.val + 1) pos (by omega) (by omega) rfl + (Or.inl (by omega)) off hoff) + · intro pos + by_cases hpos0' : pos = 0 + · subst hpos0' + simp only [TM.initCfg, Cfg.init, initTape] + exact simTapeCellCorrect_pos0 simTape (n + 1) (by omega) hpos0 + · simp only [TM.initCfg, Cfg.init, initTape] + rw [if_neg hpos0'] + have : ([] : List Γ)[pos - 1]? = (none : Option Γ) := by + rw [List.getElem?_eq_none]; simp + simp only [this, Option.getD] + exact simTapeCellCorrect_blank_cells simTape (n + 2) (n + 1) pos (by omega) + (fun off hoff => hblank (n + 2) (n + 1) pos (by omega) (by omega) rfl + (Or.inl (by omega)) off hoff) + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase simulation stubs (sorry'd) +-- ════════════════════════════════════════════════════════════════════════ + +/-- Phase 1 loop: write 3 ones per scratch-one. + Induction on remaining ones (n - done). -/ +private theorem phase1_loop : + ∀ (done : ℕ) (c : Cfg 4 setupSimTM.Q), + done ≤ n → + c.state = .pos0Write1 → + (c.work utmSimTape).head = 1 + 3 * done → + (∀ j, j ≥ 1 → j ≤ 3 * done → (c.work utmSimTape).cells j = Γ.one) → + (∀ j, j > 3 * done → (c.work utmSimTape).cells j = Γ.blank) → + (c.work utmSimTape).cells 0 = Γ.start → + (c.work utmScratchTape).head = 1 + done → + (∀ j, j > done → j ≤ n → (c.work utmScratchTape).cells j = Γ.one) → + (c.work utmScratchTape).cells (n + 1) = Γ.blank → + (c.work utmScratchTape).cells 0 = Γ.start → + (∀ j, j ≥ 1 → j ≤ n → (c.work utmScratchTape).cells j ≠ Γ.start) → + WorkTapesWF c.work → + c.input.head ≥ 1 → + (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + c.output.head ≥ 1 → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + (c.work utmDescTape).head ≥ 1 → + (c.work utmStateTape).head ≥ 1 → + ∃ c', + setupSimTM.reachesIn (3 * (n - done) + 1) c c' ∧ + c'.state = .pos0Extra1 ∧ + (c'.work utmSimTape).head = 1 + 3 * n ∧ + (∀ j, j ≥ 1 → j ≤ 3 * n → (c'.work utmSimTape).cells j = Γ.one) ∧ + (∀ j, j > 3 * n → (c'.work utmSimTape).cells j = Γ.blank) ∧ + (c'.work utmSimTape).cells 0 = Γ.start ∧ + c'.work utmDescTape = c.work utmDescTape ∧ + c'.work utmStateTape = c.work utmStateTape ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells := by + intro done + induction h : n - done generalizing done with + | zero => + intro c hdn hstate hsim_h hsim_ones hsim_blank hsim0 + hsc_h hsc_ones hsc_sentinel hsc0 hsc_ns hwf hinp_h hinp_ns hout_h hout_ns hdesc_h hst_h + have hdn : done = n := by omega + have hsc_read : (fun i => (c.work i).read) (3 : Fin 4) ≠ Γ.one := by + show (c.work utmScratchTape).read ≠ Γ.one + simp only [Tape.read, hsc_h, hdn, show 1 + n = n + 1 from by omega, hsc_sentinel]; decide + have htape_id : ∀ (t : Tape), t.head ≥ 1 → + (∀ j, j ≥ 1 → t.cells j ≠ Γ.start) → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hh hns + have hns_read : t.read ≠ Γ.start := by simp only [Tape.read]; exact hns _ hh + simp only [Tape.writeAndMove, idleDir, hns_read, ↓reduceIte, Tape.move, + init_readBackWrite_toΓ_eq hns_read, Tape.write] + split + · omega + · simp only [Tape.read, Function.update_eq_self] + have hwk_heads : ∀ i : Fin 4, (c.work i).head ≥ 1 := fun + | ⟨0, _⟩ => hdesc_h | ⟨1, _⟩ => hst_h + | ⟨2, _⟩ => by show (c.work utmSimTape).head ≥ 1; omega + | ⟨3, _⟩ => by show (c.work utmScratchTape).head ≥ 1; omega + have hwk_id : ∀ i : Fin 4, + (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ (idleDir (c.work i).read) = c.work i := + fun i => htape_id _ (hwk_heads i) (fun j hj => hwf.2 i j hj) + have hinp_ns_read : c.input.read ≠ Γ.start := by + simp only [Tape.read]; exact hinp_ns _ hinp_h + have hinp_id : c.input.move (idleDir c.input.read) = c.input := by + simp only [idleDir, hinp_ns_read, ↓reduceIte, Tape.move] + have hout_id : c.output.writeAndMove (readBackWrite c.output.read).toΓ (idleDir c.output.read) = c.output := + htape_id _ hout_h (fun j hj => hout_ns j hj) + have hstep : setupSimTM.step c = some + { state := SetupSimPhase.pos0Extra1 + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ (idleDir c.output.read) } := by + unfold TM.step + simp only [hstate, show SetupSimPhase.pos0Write1 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, hsc_read, setupIdle] + refine ⟨_, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, hinp_id, hout_id, ?_, ?_, ?_⟩ + · dsimp only []; rw [hwk_id utmSimTape, hsim_h, hdn] + · intro j hj1 hjn; dsimp only []; rw [hwk_id utmSimTape]; exact hsim_ones j hj1 (by omega) + · intro j hj; dsimp only []; rw [hwk_id utmSimTape]; exact hsim_blank j (by omega) + · dsimp only []; rw [hwk_id utmSimTape]; exact hsim0 + · exact hwk_id utmDescTape + · exact hwk_id utmStateTape + · exact ⟨fun i => by dsimp only []; rw [hwk_id i]; exact hwf.1 i, + fun i j hj => by dsimp only []; rw [hwk_id i]; exact hwf.2 i j hj⟩ + · dsimp only []; rw [hwk_id utmScratchTape, hsc_h, hdn]; omega + · dsimp only []; exact congrArg Tape.cells (hwk_id utmScratchTape) + | succ m ih => + intro c hdn hstate hsim_h hsim_ones hsim_blank hsim0 + hsc_h hsc_ones hsc_sentinel hsc0 hsc_ns hwf hinp_h hinp_ns hout_h hout_ns hdesc_h hst_h + have hlt : done < n := by omega + have hsc_read_one : (c.work utmScratchTape).read = Γ.one := by + simp only [Tape.read, hsc_h]; exact hsc_ones (1 + done) (by omega) (by omega) + have hsc_is_one : (fun i => (c.work i).read) (3 : Fin 4) = Γ.one := hsc_read_one + have hwk_heads : ∀ i : Fin 4, (c.work i).head ≥ 1 := fun + | ⟨0, _⟩ => hdesc_h | ⟨1, _⟩ => hst_h + | ⟨2, _⟩ => by show (c.work utmSimTape).head ≥ 1; omega + | ⟨3, _⟩ => by show (c.work utmScratchTape).head ≥ 1; omega + have htape_id : ∀ (t : Tape), t.head ≥ 1 → + (∀ j, j ≥ 1 → t.cells j ≠ Γ.start) → + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + intro t hh hns + have hns_read : t.read ≠ Γ.start := by simp only [Tape.read]; exact hns _ hh + simp only [Tape.writeAndMove, idleDir, hns_read, ↓reduceIte, Tape.move, + init_readBackWrite_toΓ_eq hns_read, Tape.write] + split + · omega + · simp only [Tape.read, Function.update_eq_self] + have hwk_id : ∀ i : Fin 4, + (c.work i).writeAndMove (readBackWrite (c.work i).read).toΓ (idleDir (c.work i).read) = c.work i := + fun i => htape_id _ (hwk_heads i) (fun j hj => hwf.2 i j hj) + have hinp_ns_read : c.input.read ≠ Γ.start := by + simp only [Tape.read]; exact hinp_ns _ hinp_h + have hout_ns_read : c.output.read ≠ Γ.start := by + simp only [Tape.read]; exact hout_ns _ hout_h + -- Step 1: pos0Write1(scratch=one) → pos0Write2 via simWriteRight + have hstep1 : setupSimTM.step c = some + { state := SetupSimPhase.pos0Write2 + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + (if i.val = 2 then Γw.one else readBackWrite ((c.work i).read)).toΓ + (if i.val = 2 then Dir3.right else idleDir ((c.work i).read)) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ (idleDir c.output.read) } := by + unfold TM.step + simp only [hstate, show SetupSimPhase.pos0Write1 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, hsc_is_one, simWriteRight] + -- Define c₃: config after 3 steps + let sim₃ : Tape := { + head := 1 + 3 * done + 3 + cells := fun j => + if j = 1 + 3 * done then Γ.one + else if j = 1 + 3 * done + 1 then Γ.one + else if j = 1 + 3 * done + 2 then Γ.one + else (c.work utmSimTape).cells j } + let sc₃ : Tape := { + head := (c.work utmScratchTape).head + 1 + cells := (c.work utmScratchTape).cells } + let c₃ : Cfg 4 setupSimTM.Q := { + state := .pos0Write1 + input := c.input + work := fun i => + if i = utmSimTape then sim₃ + else if i = utmScratchTape then sc₃ + else c.work i + output := c.output } + -- 3-step reachesIn (sorry for now, will be filled by agent) + have hreach3 : setupSimTM.reachesIn 3 c c₃ := by + -- ── Idle-preservation helpers ── + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h hinp_ns + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) = c.output := by + rw [show (readBackWrite c.output.read).toΓ = readBackWrite c.output.read from rfl] + exact idle_tape_preserved hout_h hout_ns + -- Helper to show non-sim work tapes are preserved by simWriteRight-style steps + have hwk_idle_step : ∀ (wk : Fin 4 → Tape), + (∀ i : Fin 4, i ≠ utmSimTape → wk i = c.work i) → + ∀ i : Fin 4, i ≠ utmSimTape → + (wk i).writeAndMove + (if i.val = 2 then Γw.one else readBackWrite ((wk i).read)).toΓ + (if i.val = 2 then Dir3.right else idleDir ((wk i).read)) = c.work i := by + intro wk hwk i hi + have hival : ¬(i.val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, + show (readBackWrite (wk i).read).toΓ = readBackWrite (wk i).read from rfl] + rw [hwk i hi]; exact hwk_id i + -- ── Sim tape after step 1 ── + set sim₁ := (c.work utmSimTape).writeAndMove Γw.one.toΓ Dir3.right with sim₁_def + have hsim1_head : sim₁.head = 1 + 3 * done + 1 := by + rw [sim₁_def, writeAndMove_right_head, hsim_h] + -- ── Step 2: pos0Write2 → pos0Write3 via simWriteRight ── + -- Step 2 operates on the raw config from hstep1; we prove the step and + -- simultaneously simplify to get our nice intermediate form + set sim₂ := sim₁.writeAndMove Γw.one.toΓ Dir3.right with sim₂_def + have hsim2_head : sim₂.head = 1 + 3 * done + 2 := by + rw [sim₂_def, writeAndMove_right_head, hsim1_head] + -- Step 2: unfold on the raw config from hstep1 + have hstep2_raw : setupSimTM.step + { state := SetupSimPhase.pos0Write2 + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + (if i.val = 2 then Γw.one else readBackWrite ((c.work i).read)).toΓ + (if i.val = 2 then Dir3.right else idleDir ((c.work i).read)) + output := c.output.writeAndMove (readBackWrite c.output.read).toΓ + (idleDir c.output.read) } = some + { state := SetupSimPhase.pos0Write3 + input := c.input + work := fun i => if i = utmSimTape then sim₂ else c.work i + output := c.output } := by + unfold TM.step + simp only [show SetupSimPhase.pos0Write2 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, simWriteRight] + congr 1 + refine Cfg.mk.injEq .. |>.mpr ⟨rfl, ?_, ?_, ?_⟩ + · -- input: double-idle = idle + rw [hinp_idle]; exact hinp_idle + · -- work tapes + funext i + by_cases hi : i = utmSimTape + · subst hi + simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, sim₂_def, sim₁_def] + · have hival : ¬(i.val = 2) := fun heq => hi (Fin.ext heq) + simp only [hi, ↓reduceIte, hival, + show (readBackWrite ((c.work i).writeAndMove + (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read)).read).toΓ = + readBackWrite ((c.work i).writeAndMove + (readBackWrite (c.work i).read).toΓ + (idleDir (c.work i).read)).read from rfl] + rw [hwk_id i]; exact hwk_id i + · -- output: double-idle + rw [hout_idle]; exact hout_idle + -- ── Step 3: pos0Write3 → pos0Write1 (custom transition) ── + -- We prove step 3 from the simplified c₂-like config + have hstep3_raw : setupSimTM.step + { state := .pos0Write3, input := c.input, + work := fun i => if i = utmSimTape then sim₂ else c.work i, + output := c.output } = some c₃ := by + unfold TM.step + simp only [show SetupSimPhase.pos0Write3 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM] + congr 1 + refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i + -- Step 3 transition: sim(write one, right), scratch(readBackWrite, right), rest(idle) + by_cases hi2 : i = utmSimTape + · -- Sim tape: write one, move right → produces sim₃ + subst hi2 + simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, + show ¬((2 : Fin 4) = utmScratchTape) from by decide] + show sim₂.writeAndMove Γw.one.toΓ Dir3.right = sim₃ + have hhead : (sim₂.writeAndMove Γw.one.toΓ Dir3.right).head = sim₃.head := by + rw [writeAndMove_right_head, hsim2_head] + have hcells : (sim₂.writeAndMove Γw.one.toΓ Dir3.right).cells = sim₃.cells := by + funext j; simp only [sim₃] + by_cases hj0 : j = 1 + 3 * done + · subst hj0; simp only [↓reduceIte] + rw [writeAndMove_cells_ne (by rw [hsim2_head]; omega), + writeAndMove_cells_ne (by rw [hsim1_head]; omega)] + conv_lhs => rw [← hsim_h] + exact writeAndMove_cells_at_head (by omega) + · simp only [hj0, ↓reduceIte] + by_cases hj1 : j = 1 + 3 * done + 1 + · subst hj1; simp only [↓reduceIte] + rw [writeAndMove_cells_ne (by rw [hsim2_head]; omega)] + conv_lhs => rw [← hsim1_head] + exact writeAndMove_cells_at_head (by omega) + · simp only [hj1, ↓reduceIte] + by_cases hj2 : j = 1 + 3 * done + 2 + · subst hj2; simp only [↓reduceIte] + conv_lhs => rw [← hsim2_head] + exact writeAndMove_cells_at_head (by omega) + · simp only [hj2, ↓reduceIte] + rw [writeAndMove_cells_ne (by rw [hsim2_head]; omega), + writeAndMove_cells_ne (by rw [hsim1_head]; omega), + writeAndMove_cells_ne (by rw [hsim_h]; omega)] + exact match sim₂.writeAndMove Γw.one.toΓ Dir3.right, sim₃, hhead, hcells with + | ⟨_, _⟩, ⟨_, _⟩, rfl, rfl => rfl + · by_cases hi3 : i = utmScratchTape + · -- Scratch tape: readBackWrite + right → produces sc₃ + subst hi3 + show (c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read).toΓ Dir3.right = sc₃ + have hhead : ((c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read).toΓ Dir3.right).head = sc₃.head := by + rw [writeAndMove_right_head] + have hcells : ((c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read).toΓ Dir3.right).cells = sc₃.cells := by + simp only [sc₃] + exact readBackWrite_cells (by rw [hsc_h]; omega) + (fun j hj => hwf.2 utmScratchTape j hj) + exact match (c.work utmScratchTape).writeAndMove _ Dir3.right, sc₃, hhead, hcells with + | ⟨_, _⟩, ⟨_, _⟩, rfl, rfl => rfl + · -- Other tapes: idle (readBackWrite + idleDir) + have hi2v : ¬(i.val = 2) := fun heq => hi2 (Fin.ext heq) + have hi3v : ¬(i.val = 3) := fun heq => hi3 (Fin.ext heq) + simp only [hi2, hi3, ↓reduceIte, hi2v, hi3v, + show (readBackWrite (c.work i).read).toΓ = readBackWrite (c.work i).read from rfl, + show ¬(i = utmScratchTape) from hi3] + exact hwk_id i + -- ── Combine: reachesIn 3 c c₃ ── + -- hstep1 : step c = some raw₁ + -- hstep2_raw : step raw₁ = some {.pos0Write3, ..sim₂..} + -- hstep3_raw : step {.pos0Write3, ..sim₂..} = some c₃ + exact .step hstep1 (.step hstep2_raw (.step hstep3_raw .zero)) + -- Apply IH + have hih := ih (done + 1) (by omega) c₃ (by omega) + (by show c₃.state = .pos0Write1; rfl) + (by show sim₃.head = 1 + 3 * (done + 1); simp [sim₃]; omega) + (by intro j hj1 hjn; show sim₃.cells j = Γ.one; simp only [sim₃] + by_cases h1 : j = 1 + 3 * done + · simp [h1] + · by_cases h2 : j = 1 + 3 * done + 1 + · simp [h1, h2] + · by_cases h3 : j = 1 + 3 * done + 2 + · simp [h1, h2, h3] + · simp [h1, h2, h3]; exact hsim_ones j hj1 (by omega)) + (by intro j hj; show sim₃.cells j = Γ.blank; simp only [sim₃] + have : j ≠ 1 + 3 * done := by omega + have : j ≠ 1 + 3 * done + 1 := by omega + have : j ≠ 1 + 3 * done + 2 := by omega + simp [*]; exact hsim_blank j (by omega)) + (by show sim₃.cells 0 = Γ.start; simp only [sim₃] + simp (config := { decide := true }) [show 0 ≠ 1 + 3 * done from by omega, + show 0 ≠ 1 + 3 * done + 1 from by omega, show 0 ≠ 1 + 3 * done + 2 from by omega] + exact hsim0) + (by show sc₃.head = 1 + (done + 1); simp [sc₃, hsc_h]; omega) + (by intro j hj hjn; show sc₃.cells j = Γ.one; simp only [sc₃] + exact hsc_ones j (by omega) hjn) + hsc_sentinel + (by show sc₃.cells 0 = Γ.start; simp [sc₃]; exact hsc0) + hsc_ns + (by constructor + · intro i; show (c₃.work i).cells 0 = Γ.start; simp only [c₃] + by_cases h2 : i = utmSimTape + · simp [h2, sim₃, show 0 ≠ 1 + 3 * done from by omega, + show 0 ≠ 1 + 3 * done + 1 from by omega, show 0 ≠ 1 + 3 * done + 2 from by omega] + exact hsim0 + · by_cases h3 : i = utmScratchTape + · simp [h2, h3, sc₃]; exact hsc0 + · simp [h2, h3]; exact hwf.1 i + · intro i j hj; show (c₃.work i).cells j ≠ Γ.start; simp only [c₃] + by_cases h2 : i = utmSimTape + · simp only [h2, ↓reduceIte, sim₃] + by_cases h4 : j = 1 + 3 * done + · simp [h4] + · by_cases h5 : j = 1 + 3 * done + 1 + · simp [h4, h5] + · by_cases h6 : j = 1 + 3 * done + 2 + · simp [h4, h5, h6] + · simp [h4, h5, h6]; exact hwf.2 utmSimTape j hj + · by_cases h3 : i = utmScratchTape + · simp [h2, h3, sc₃]; exact hwf.2 utmScratchTape j hj + · simp [h2, h3]; exact hwf.2 i j hj) + hinp_h hinp_ns hout_h hout_ns + (by show (c₃.work utmDescTape).head ≥ 1 + simp only [c₃, show utmDescTape ≠ utmSimTape from by decide, + show utmDescTape ≠ utmScratchTape from by decide, ↓reduceIte] + exact hdesc_h) + (by show (c₃.work utmStateTape).head ≥ 1 + simp only [c₃, show utmStateTape ≠ utmSimTape from by decide, + show utmStateTape ≠ utmScratchTape from by decide, ↓reduceIte] + exact hst_h) + obtain ⟨c', hreach_ih, hst', hsim_h', hsim_ones', hsim_blank', hsim0', + hdesc', hstate', hinp', hout', hwf', hsc_h', hsc_cells'⟩ := hih + refine ⟨c', ?_, hst', hsim_h', hsim_ones', hsim_blank', hsim0', ?_, ?_, ?_, ?_, hwf', hsc_h', ?_⟩ + · have : 3 * (m + 1) + 1 = 3 + (3 * m + 1) := by omega + rw [this]; exact reachesIn_trans setupSimTM hreach3 hreach_ih + · rw [hdesc']; show c₃.work utmDescTape = c.work utmDescTape + simp only [c₃, show utmDescTape ≠ utmSimTape from by decide, + show utmDescTape ≠ utmScratchTape from by decide, ↓reduceIte] + · rw [hstate']; show c₃.work utmStateTape = c.work utmStateTape + simp only [c₃, show utmStateTape ≠ utmSimTape from by decide, + show utmStateTape ≠ utmScratchTape from by decide, ↓reduceIte] + · rw [hinp'] + · rw [hout'] + · rw [hsc_cells']; show sc₃.cells = (c.work utmScratchTape).cells; rfl + +/-- Phase 1+2: write 3*(n+2) ones for position 0 and advance input. + + Phase 1 loop (3n+1 steps) + Phase 1 extras (6 steps) + + Phase 2 advanceInput (1 step) = 3n+8 steps. -/ +private theorem setupSim_phase12 + (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (hsim0 : (work utmSimTape).cells 0 = Γ.start) + (hsim_blank : ∀ j, j ≥ 1 → (work utmSimTape).cells j = Γ.blank) + (hsim_head : (work utmSimTape).head = 1) + (hsc0 : (work utmScratchTape).cells 0 = Γ.start) + (hsc_ones : ∀ j, j ≥ 1 → j ≤ n → (work utmScratchTape).cells j = Γ.one) + (hsc_sentinel : (work utmScratchTape).cells (n + 1) = Γ.blank) + (hsc_head : (work utmScratchTape).head = 1) + (hinp_h : inp.head ≥ 1) (hinp_ns : ∀ j, j ≥ 1 → inp.cells j ≠ Γ.start) + (hout_h : out.head ≥ 1) (hout_ns : ∀ j, j ≥ 1 → out.cells j ≠ Γ.start) + (hwf : WorkTapesWF work) + (hdesc_h : (work utmDescTape).head ≥ 1) + (hst_h : (work utmStateTape).head ≥ 1) : + ∃ c', + setupSimTM.reachesIn (3 * n + 8) ⟨.pos0Write1, inp, work, out⟩ c' ∧ + c'.state = .checkInput ∧ + (c'.work utmSimTape).cells 0 = Γ.start ∧ + (c'.work utmSimTape).head = 1 + 3 * (n + 2) ∧ + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c'.work utmSimTape).cells j = Γ.one) ∧ + (∀ j, j > 3 * (n + 2) → (c'.work utmSimTape).cells j = Γ.blank) ∧ + c'.work utmDescTape = work utmDescTape ∧ + c'.work utmStateTape = work utmStateTape ∧ + c'.input.head = inp.head + 1 ∧ + c'.input.cells = inp.cells ∧ + c'.output = out ∧ + WorkTapesWF c'.work ∧ + (∀ j, j ≥ 1 → j ≤ n → (c'.work utmScratchTape).cells j = Γ.one) ∧ + (c'.work utmScratchTape).cells (n + 1) = Γ.blank ∧ + (c'.work utmScratchTape).cells 0 = Γ.start ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + c'.input.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c'.input.cells j ≠ Γ.start) ∧ + c'.output.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) := by + -- ── Scratch tape: cells ≥ 1 are not start ── + have hsc_ns : ∀ j, j ≥ 1 → j ≤ n → (work utmScratchTape).cells j ≠ Γ.start := by + intro j hj hjn; rw [hsc_ones j hj hjn]; decide + -- ── Phase 1: invoke phase1_loop at done=0 ── + obtain ⟨c1, hreach1, hst1, hsim_head1, hsim_ones1, hsim_blank1, hsim0_1, + hdesc1, hstate1, hinp1, hout1, hwf1, hsc_head1, hsc_cells1⟩ := + phase1_loop 0 ⟨.pos0Write1, inp, work, out⟩ (by omega) rfl + (by simp [hsim_head]) (by intro j hj hjn; omega) + (fun j _ => hsim_blank j (by omega)) hsim0 + (by simp [hsc_head]) (fun j hj hjn => hsc_ones j (by omega) hjn) + hsc_sentinel hsc0 hsc_ns hwf hinp_h hinp_ns hout_h hout_ns hdesc_h hst_h + -- c1: state=pos0Extra1, sim head=1+3n, ones at 1..3n, blanks after + -- c1.input = inp, c1.output = out, desc/state preserved, scratch head=n+1 + -- ── Idle helpers for c1 ── + have hinp_h1 : c1.input.head ≥ 1 := by rw [hinp1]; exact hinp_h + have hinp_ns1 : ∀ j, j ≥ 1 → c1.input.cells j ≠ Γ.start := by rw [hinp1]; exact hinp_ns + have hout_h1 : c1.output.head ≥ 1 := by rw [hout1]; exact hout_h + have hout_ns1 : ∀ j, j ≥ 1 → c1.output.cells j ≠ Γ.start := by rw [hout1]; exact hout_ns + -- Non-sim work tapes: head ≥ 1, no start at ≥ 1 + have hwk_nonsim_h : ∀ (i : Fin 4), i ≠ utmSimTape → (c1.work i).head ≥ 1 := by + intro ⟨iv, hiv⟩ hi + have : iv = 0 ∨ iv = 1 ∨ iv = 2 ∨ iv = 3 := by omega + rcases this with rfl | rfl | rfl | rfl + · show (c1.work utmDescTape).head ≥ 1; rw [hdesc1]; exact hdesc_h + · show (c1.work utmStateTape).head ≥ 1; rw [hstate1]; exact hst_h + · exact absurd rfl hi + · show (c1.work utmScratchTape).head ≥ 1; rw [hsc_head1]; omega + -- ── Phase 1 extras: 6 simWriteRight steps ── + let s0 := c1.work utmSimTape + let s1 := s0.writeAndMove Γw.one Dir3.right + let s2 := s1.writeAndMove Γw.one Dir3.right + let s3 := s2.writeAndMove Γw.one Dir3.right + let s4 := s3.writeAndMove Γw.one Dir3.right + let s5 := s4.writeAndMove Γw.one Dir3.right + let s6 := s5.writeAndMove Γw.one Dir3.right + have s0_head : s0.head = 1 + 3 * n := hsim_head1 + have s1_head : s1.head = 1 + 3 * n + 1 := by + show (s0.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s0_head] + have s2_head : s2.head = 1 + 3 * n + 2 := by + show (s1.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s1_head] + have s3_head : s3.head = 1 + 3 * n + 3 := by + show (s2.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s2_head] + have s4_head : s4.head = 1 + 3 * n + 4 := by + show (s3.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s3_head] + have s5_head : s5.head = 1 + 3 * n + 5 := by + show (s4.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s4_head] + have s6_head : s6.head = 1 + 3 * n + 6 := by + show (s5.writeAndMove _ _).head = _; rw [writeAndMove_right_head, s5_head] + -- Cells outside [1+3n, 1+3n+6) unchanged + have cells_old : ∀ j, (j < 1 + 3 * n ∨ j ≥ 1 + 3 * n + 6) → s6.cells j = s0.cells j := by + intro j hj; show (s5.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s5_head]; omega)] + show (s4.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s4_head]; omega)] + show (s3.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s3_head]; omega)] + show (s2.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s2_head]; omega)] + show (s1.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s1_head]; omega)] + show (s0.writeAndMove _ _).cells j = _ + rw [writeAndMove_cells_ne (by rw [s0_head]; omega)] + -- Ones in [1+3n, 1+3n+6) + have wam_at_head : ∀ (t : Tape) (hh : t.head ≠ 0), + (t.writeAndMove Γw.one Dir3.right).cells t.head = Γ.one := + fun t hh => @writeAndMove_cells_at_head t Γw.one Dir3.right hh + have cells_new : ∀ j, j ≥ 1 + 3 * n → j < 1 + 3 * n + 6 → s6.cells j = Γ.one := by + intro j hj hjlt; show (s5.writeAndMove _ _).cells j = _ + by_cases h5 : j = 1 + 3 * n + 5 + · rw [h5, ← s5_head]; exact wam_at_head s5 (by rw [s5_head]; omega) + · rw [writeAndMove_cells_ne (by rw [s5_head]; omega)] + show (s4.writeAndMove _ _).cells j = _ + by_cases h4 : j = 1 + 3 * n + 4 + · rw [h4, ← s4_head]; exact wam_at_head s4 (by rw [s4_head]; omega) + · rw [writeAndMove_cells_ne (by rw [s4_head]; omega)] + show (s3.writeAndMove _ _).cells j = _ + by_cases h3 : j = 1 + 3 * n + 3 + · rw [h3, ← s3_head]; exact wam_at_head s3 (by rw [s3_head]; omega) + · rw [writeAndMove_cells_ne (by rw [s3_head]; omega)] + show (s2.writeAndMove _ _).cells j = _ + by_cases h2 : j = 1 + 3 * n + 2 + · rw [h2, ← s2_head]; exact wam_at_head s2 (by rw [s2_head]; omega) + · rw [writeAndMove_cells_ne (by rw [s2_head]; omega)] + show (s1.writeAndMove _ _).cells j = _ + by_cases h1 : j = 1 + 3 * n + 1 + · rw [h1, ← s1_head]; exact wam_at_head s1 (by rw [s1_head]; omega) + · rw [writeAndMove_cells_ne (by rw [s1_head]; omega)] + show (s0.writeAndMove _ _).cells j = _ + have : j = 1 + 3 * n := by omega + rw [this, ← s0_head]; exact wam_at_head s0 (by rw [s0_head]; omega) + have s6_all_ones : ∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → s6.cells j = Γ.one := by + intro j hj hjn + by_cases hjlt : j < 1 + 3 * n + · rw [cells_old j (Or.inl hjlt)]; exact hsim_ones1 j hj (by omega) + · exact cells_new j (by omega) (by omega) + have s6_blanks : ∀ j, j > 3 * (n + 2) → s6.cells j = Γ.blank := by + intro j hj; rw [cells_old j (Or.inr (by omega))]; exact hsim_blank1 j (by omega) + have s6_cell0 : s6.cells 0 = Γ.start := by + rw [cells_old 0 (Or.inl (by omega))]; exact hsim0_1 + -- No start at ≥ 1 for s0..s6 + have s0_ns : ∀ j, j ≥ 1 → s0.cells j ≠ Γ.start := hwf1.2 utmSimTape + have wam_ns : ∀ (t : Tape), t.head ≥ 1 → (∀ j, j ≥ 1 → t.cells j ≠ Γ.start) → + ∀ j, j ≥ 1 → (t.writeAndMove Γw.one Dir3.right).cells j ≠ Γ.start := by + intro t ht hns j hj + by_cases heq : j = t.head + · subst heq; rw [wam_at_head t (by omega)]; decide + · rw [writeAndMove_cells_ne heq]; exact hns j hj + have s1_ns : ∀ j, j ≥ 1 → s1.cells j ≠ Γ.start := wam_ns s0 (by omega) s0_ns + have s2_ns : ∀ j, j ≥ 1 → s2.cells j ≠ Γ.start := wam_ns s1 (by omega) s1_ns + have s3_ns : ∀ j, j ≥ 1 → s3.cells j ≠ Γ.start := wam_ns s2 (by omega) s2_ns + have s4_ns : ∀ j, j ≥ 1 → s4.cells j ≠ Γ.start := wam_ns s3 (by omega) s3_ns + have s5_ns : ∀ j, j ≥ 1 → s5.cells j ≠ Γ.start := wam_ns s4 (by omega) s4_ns + have s6_ns : ∀ j, j ≥ 1 → s6.cells j ≠ Γ.start := wam_ns s5 (by omega) s5_ns + -- ── Generic simWriteRight step ── + have simwr_step : ∀ (phase_in phase_out : SetupSimPhase) (st : Tape), + st.head ≥ 1 → (∀ j, j ≥ 1 → st.cells j ≠ Γ.start) → + (∀ iHead (wHeads : Fin 4 → Γ) oHead, + setupSimTM.δ phase_in iHead wHeads oHead = + simWriteRight phase_out .one iHead wHeads oHead) → + phase_in ≠ .done → + setupSimTM.step + { state := phase_in, input := c1.input, + work := fun i => if i = utmSimTape then st else c1.work i, + output := c1.output } = + some { state := phase_out, input := c1.input, + work := fun i => if i = utmSimTape then st.writeAndMove Γw.one Dir3.right + else c1.work i, + output := c1.output } := by + intro phase_in phase_out st hst_h hst_ns hδ hne + simp only [TM.step, show setupSimTM.qhalt = SetupSimPhase.done from rfl, hne, ↓reduceIte] + have hδ' := hδ c1.input.read + (fun i => ((if i = utmSimTape then st else c1.work i) : Tape).read) c1.output.read + simp only [hδ', simWriteRight] + congr 1 + refine Cfg.mk.injEq .. |>.mpr ⟨rfl, ?_, ?_, ?_⟩ + · exact idle_input_preserved hinp_h1 hinp_ns1 + · funext i + by_cases hi : i = utmSimTape + · subst hi; simp only [show (utmSimTape : Fin 4).val = 2 from rfl, ↓reduceIte] + · have hival : ¬((i : Fin 4).val = 2) := fun h => hi (Fin.ext h) + simp only [hi, hival, ↓reduceIte] + rw [show (readBackWrite (c1.work i).read).toΓ = readBackWrite (c1.work i).read from rfl] + exact idle_tape_preserved (hwk_nonsim_h i hi) (hwf1.2 i) + · rw [show (readBackWrite c1.output.read).toΓ = readBackWrite c1.output.read from rfl] + exact idle_tape_preserved hout_h1 hout_ns1 + -- Chain 6 steps + have hstep_e1 := simwr_step .pos0Extra1 .pos0Extra2 s0 (by omega) s0_ns (by intros; rfl) (by decide) + have hstep_e2 := simwr_step .pos0Extra2 .pos0Extra3 s1 (by omega) s1_ns (by intros; rfl) (by decide) + have hstep_e3 := simwr_step .pos0Extra3 .pos0Extra4 s2 (by omega) s2_ns (by intros; rfl) (by decide) + have hstep_e4 := simwr_step .pos0Extra4 .pos0Extra5 s3 (by omega) s3_ns (by intros; rfl) (by decide) + have hstep_e5 := simwr_step .pos0Extra5 .pos0Extra6 s4 (by omega) s4_ns (by intros; rfl) (by decide) + have hstep_e6 := simwr_step .pos0Extra6 .advanceInput s5 (by omega) s5_ns (by intros; rfl) (by decide) + have hreach_extras : setupSimTM.reachesIn 6 + { state := .pos0Extra1, input := c1.input, + work := fun i => if i = utmSimTape then s0 else c1.work i, + output := c1.output } + { state := .advanceInput, input := c1.input, + work := fun i => if i = utmSimTape then s6 else c1.work i, + output := c1.output } := + .step hstep_e1 (.step hstep_e2 (.step hstep_e3 + (.step hstep_e4 (.step hstep_e5 (.step hstep_e6 .zero))))) + -- Rewrite starting config to use c1.work + have hwork0 : (fun i => if i = utmSimTape then s0 else c1.work i) = c1.work := by + funext i; show (if i = utmSimTape then c1.work utmSimTape else c1.work i) = _ + split <;> simp_all + rw [hwork0] at hreach_extras + -- ── Phase 2: advanceInput ── + have hstep_adv : setupSimTM.step + { state := .advanceInput, input := c1.input, + work := fun i => if i = utmSimTape then s6 else c1.work i, + output := c1.output } = + some { state := .checkInput, input := c1.input.move Dir3.right, + work := fun i => if i = utmSimTape then s6 else c1.work i, + output := c1.output } := by + simp only [TM.step, show SetupSimPhase.advanceInput ≠ SetupSimPhase.done from nofun, + ↓reduceIte, setupSimTM] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, rfl, ?_, ?_⟩ + · funext i + by_cases hi : i = utmSimTape + · subst hi; simp only [↓reduceIte, + show (readBackWrite (Tape.read s6)).toΓ = readBackWrite s6.read from rfl] + exact idle_tape_preserved (by rw [s6_head]; omega) s6_ns + · simp only [hi, ↓reduceIte, + show (readBackWrite (c1.work i).read).toΓ = readBackWrite (c1.work i).read from rfl] + exact idle_tape_preserved (hwk_nonsim_h i hi) (fun j hj => hwf1.2 i j hj) + · exact idle_tape_preserved hout_h1 hout_ns1 + have hreach_67 : setupSimTM.reachesIn 7 + ⟨.pos0Extra1, c1.input, c1.work, c1.output⟩ + ⟨.checkInput, c1.input.move Dir3.right, + fun i => if i = utmSimTape then s6 else c1.work i, c1.output⟩ := by + have : (7 : ℕ) = 6 + 1 := by omega + rw [this]; exact reachesIn_trans setupSimTM hreach_extras (.step hstep_adv .zero) + have hc1_eq : (⟨.pos0Extra1, c1.input, c1.work, c1.output⟩ : Cfg 4 setupSimTM.Q) = c1 := by + cases c1; simp only [Cfg.mk.injEq]; exact ⟨hst1.symm, trivial, trivial, trivial⟩ + rw [hc1_eq] at hreach_67 + -- ── Combine: 3n+1 + 7 = 3n+8 ── + let cfinal : Cfg 4 setupSimTM.Q := + { state := .checkInput, input := c1.input.move Dir3.right, + work := fun i => if i = utmSimTape then s6 else c1.work i, output := c1.output } + have hreach_all : setupSimTM.reachesIn (3 * n + 8) + ⟨.pos0Write1, inp, work, out⟩ cfinal := by + have : 3 * n + 8 = (3 * (n - 0) + 1) + 7 := by omega + rw [this]; exact reachesIn_trans setupSimTM hreach1 hreach_67 + -- ── Witness ── + refine ⟨cfinal, hreach_all, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · exact s6_cell0 + · show s6.head = 1 + 3 * (n + 2); rw [s6_head]; omega + · intro j hj hjn; exact s6_all_ones j hj hjn + · intro j hj; exact s6_blanks j hj + · show (if utmDescTape = utmSimTape then s6 else c1.work utmDescTape) = work utmDescTape + simp only [show utmDescTape ≠ utmSimTape from by decide, ↓reduceIte]; exact hdesc1 + · show (if utmStateTape = utmSimTape then s6 else c1.work utmStateTape) = work utmStateTape + simp only [show utmStateTape ≠ utmSimTape from by decide, ↓reduceIte]; exact hstate1 + · show (c1.input.move Dir3.right).head = inp.head + 1 + rw [hinp1]; simp [Tape.move] + · show (c1.input.move Dir3.right).cells = inp.cells + rw [hinp1]; simp [Tape.move] + · exact hout1 + · constructor + · intro i; show (cfinal.work i).cells 0 = Γ.start + by_cases hi : i = utmSimTape + · show (if i = utmSimTape then s6 else c1.work i).cells 0 = _; simp [hi]; exact s6_cell0 + · show (if i = utmSimTape then s6 else c1.work i).cells 0 = _; simp [hi]; exact hwf1.1 i + · intro i j hj; show (cfinal.work i).cells j ≠ Γ.start + by_cases hi : i = utmSimTape + · show (if i = utmSimTape then s6 else c1.work i).cells j ≠ _; simp [hi]; exact s6_ns j hj + · show (if i = utmSimTape then s6 else c1.work i).cells j ≠ _; simp [hi]; exact hwf1.2 i j hj + · intro j hj hjn + show (if utmScratchTape = utmSimTape then s6 else c1.work utmScratchTape).cells j = Γ.one + simp only [show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + rw [hsc_cells1]; exact hsc_ones j hj hjn + · show (if utmScratchTape = utmSimTape then s6 else c1.work utmScratchTape).cells (n + 1) = Γ.blank + simp only [show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + rw [hsc_cells1]; exact hsc_sentinel + · show (if utmScratchTape = utmSimTape then s6 else c1.work utmScratchTape).cells 0 = Γ.start + simp only [show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hwf1.1 utmScratchTape + · show (if utmScratchTape = utmSimTape then s6 else c1.work utmScratchTape).head = n + 1 + simp only [show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte]; exact hsc_head1 + · show (c1.input.move Dir3.right).head ≥ 1 + rw [hinp1]; simp [Tape.move] + · show ∀ j, j ≥ 1 → (c1.input.move Dir3.right).cells j ≠ Γ.start + rw [hinp1]; intro j hj; simp [Tape.move]; exact hinp_ns j hj + · show c1.output.head ≥ 1; rw [hout1]; exact hout_h + · show ∀ j, j ≥ 1 → c1.output.cells j ≠ Γ.start; rw [hout1]; exact hout_ns + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 3 helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind scratch tape from head h to ▷, reaching `.bounceScratch` with head 1 in h+1 steps. + All tapes except scratch are preserved; scratch cells unchanged. -/ +private theorem rewindScratch_loop : + ∀ (h : ℕ) (c : Cfg 4 setupSimTM.Q), + c.state = .rewindScratch → + (c.work utmScratchTape).head = h → + WorkTapesWF c.work → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + (∀ i : Fin 4, i ≠ utmScratchTape → (c.work i).head ≥ 1) → + ∃ c', + setupSimTM.reachesIn (h + 1) c c' ∧ + c'.state = .bounceScratch ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work ∧ + (∀ i : Fin 4, (c'.work i).head ≥ 1) := by + intro h + -- Common idle helper used in both cases + have htape_id_gen : ∀ (t : Tape), t.head ≥ 1 → (∀ j, j ≥ 1 → t.cells j ≠ Γ.start) → + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := + fun t hh hns => idle_tape_preserved hh hns + induction h with + | zero => + intro c hstate hsc_head hwf hinp_h hinp_ns hout_h hout_ns hwk_nonscratch + have hsc_read : (fun i => (c.work i).read) (3 : Fin 4) = Γ.start := by + show (c.work utmScratchTape).read = Γ.start + simp only [Tape.read, hsc_head]; exact hwf.1 utmScratchTape + have hwk_id : ∀ i : Fin 4, i ≠ utmScratchTape → + (c.work i).writeAndMove (readBackWrite (c.work i).read) (idleDir (c.work i).read) = c.work i := + fun i hi => htape_id_gen _ (hwk_nonscratch i hi) (fun j hj => hwf.2 i j hj) + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h hinp_ns + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h hout_ns + -- Define target config + let sc' : Tape := ⟨1, (c.work utmScratchTape).cells⟩ + let c' : Cfg 4 setupSimTM.Q := + { state := .bounceScratch, input := c.input, + work := fun i => if i = utmScratchTape then sc' else c.work i, + output := c.output } + have hstep : setupSimTM.step c = some c' := by + unfold TM.step + simp only [hstate, show SetupSimPhase.rewindScratch ≠ SetupSimPhase.done from nofun, + ↓reduceIte, setupSimTM, hsc_read] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi : i = utmScratchTape + · subst hi + show (c.work utmScratchTape).writeAndMove _ Dir3.right = sc' + simp only [show (utmScratchTape : Fin 4).val = 3 from rfl, ↓reduceIte, sc'] + simp only [Tape.writeAndMove, Tape.write, Tape.move, hsc_head, ↓reduceIte, + init_tape_move_cells, Tape.read] + · show _ = (if i = utmScratchTape then sc' else c.work i) + simp only [hi, ↓reduceIte] + have hival : ¬((i : Fin 4).val = 3) := fun h => hi (Fin.ext h) + simp only [hival, ↓reduceIte]; exact hwk_id i hi + refine ⟨c', .step hstep .zero, rfl, ?_, ?_, ?_, rfl, rfl, ?_, ?_⟩ + · dsimp only [c']; simp only [↓reduceIte, sc'] + · dsimp only [c']; simp only [↓reduceIte, sc'] + · intro i hi; dsimp only [c']; simp only [hi, ↓reduceIte] + · constructor + · intro i; show (c'.work i).cells 0 = Γ.start + by_cases hi : i = utmScratchTape + · simp only [c', hi, ↓reduceIte, sc']; exact hwf.1 utmScratchTape + · simp only [c', hi, ↓reduceIte]; exact hwf.1 i + · intro i j hj; show (c'.work i).cells j ≠ Γ.start + by_cases hi : i = utmScratchTape + · simp only [c', hi, ↓reduceIte, sc']; exact hwf.2 utmScratchTape j hj + · simp only [c', hi, ↓reduceIte]; exact hwf.2 i j hj + · intro i; show (c'.work i).head ≥ 1 + by_cases hi : i = utmScratchTape + · simp only [c', hi, ↓reduceIte, sc']; omega + · simp only [c', hi, ↓reduceIte]; exact hwk_nonscratch i hi + | succ h ih => + intro c hstate hsc_head hwf hinp_h hinp_ns hout_h hout_ns hwk_nonscratch + have hsc_read_ne : (fun i => (c.work i).read) (3 : Fin 4) ≠ Γ.start := by + show (c.work utmScratchTape).read ≠ Γ.start + simp only [Tape.read, hsc_head]; exact hwf.2 utmScratchTape _ (by omega) + have hwk_id : ∀ i : Fin 4, i ≠ utmScratchTape → + (c.work i).writeAndMove (readBackWrite (c.work i).read) (idleDir (c.work i).read) = c.work i := + fun i hi => htape_id_gen _ (hwk_nonscratch i hi) (fun j hj => hwf.2 i j hj) + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h hinp_ns + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h hout_ns + have hsc_ns : (c.work utmScratchTape).read ≠ Γ.start := by + simp only [Tape.read, hsc_head]; exact hwf.2 utmScratchTape _ (by omega) + let sc₁ : Tape := ⟨h, (c.work utmScratchTape).cells⟩ + let c₁ : Cfg 4 setupSimTM.Q := + { state := .rewindScratch, input := c.input, + work := fun i => if i = utmScratchTape then sc₁ else c.work i, + output := c.output } + have hstep : setupSimTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show SetupSimPhase.rewindScratch ≠ SetupSimPhase.done from nofun, + ↓reduceIte, setupSimTM, hsc_read_ne] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi : i = utmScratchTape + · subst hi + show (c.work utmScratchTape).writeAndMove _ Dir3.left = sc₁ + simp only [show (utmScratchTape : Fin 4).val = 3 from rfl, ↓reduceIte, sc₁] + have hne_start : (c.work utmScratchTape).cells (h + 1) ≠ Γ.start := + hwf.2 utmScratchTape _ (by omega) + simp only [Tape.writeAndMove, Tape.write, Tape.move, hsc_head, + show h + 1 ≠ 0 from by omega, ↓reduceIte, + init_tape_move_cells, show h + 1 - 1 = h from by omega, Tape.read] + congr 1 + rw [show (c.work (3 : Fin 4)) = c.work utmScratchTape from rfl, + init_readBackWrite_toΓ_eq hne_start, Function.update_eq_self] + · show _ = (if i = utmScratchTape then sc₁ else c.work i) + simp only [hi, ↓reduceIte] + have hival : ¬((i : Fin 4).val = 3) := fun h => hi (Fin.ext h) + simp only [hival, ↓reduceIte]; exact hwk_id i hi + -- Apply IH + have hih := ih c₁ rfl (by show sc₁.head = h; rfl) + (by constructor + · intro i; show (c₁.work i).cells 0 = Γ.start + by_cases hi : i = utmScratchTape + · simp only [c₁, hi, ↓reduceIte, sc₁]; exact hwf.1 utmScratchTape + · simp only [c₁, hi, ↓reduceIte]; exact hwf.1 i + · intro i j hj; show (c₁.work i).cells j ≠ Γ.start + by_cases hi : i = utmScratchTape + · simp only [c₁, hi, ↓reduceIte, sc₁]; exact hwf.2 utmScratchTape j hj + · simp only [c₁, hi, ↓reduceIte]; exact hwf.2 i j hj) + hinp_h hinp_ns hout_h hout_ns + (fun i hi => by + show (c₁.work i).head ≥ 1 + simp only [c₁, show i ≠ utmScratchTape from hi, ↓reduceIte] + exact hwk_nonscratch i hi) + obtain ⟨c', hreach_ih, hst', hsc_head', hsc_cells', hwk_other', hinp', hout', hwf', hwk_heads'⟩ := hih + refine ⟨c', ?_, hst', hsc_head', ?_, ?_, hinp', hout', hwf', hwk_heads'⟩ + · have : h + 1 + 1 = 1 + (h + 1) := by omega + rw [this]; exact reachesIn_trans setupSimTM (.step hstep .zero) hreach_ih + · rw [hsc_cells']; show sc₁.cells = _; rfl + · intro i hi; rw [hwk_other' i hi] + show (if i = utmScratchTape then sc₁ else c.work i) = c.work i; simp [hi] + +/-- Stride loop: from `.stride1` at scratch head 1+done, advance sim by 3*(n-done)+1 cells, + reaching `.strideExtra2` in 3*(n-done)+1 steps. Scratch ends at head n+1. + Sim and scratch cells are both preserved (readBackWrite writes). -/ +private theorem stride_loop : + ∀ (done : ℕ) (c : Cfg 4 setupSimTM.Q), + done ≤ n → + c.state = .stride1 → + (c.work utmScratchTape).head = 1 + done → + (∀ j, j > done → j ≤ n → (c.work utmScratchTape).cells j = Γ.one) → + (c.work utmScratchTape).cells (n + 1) = Γ.blank → + (c.work utmScratchTape).cells 0 = Γ.start → + WorkTapesWF c.work → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + (∀ i : Fin 4, (c.work i).head ≥ 1) → + ∃ c', + setupSimTM.reachesIn (3 * (n - done) + 1) c c' ∧ + c'.state = .strideExtra2 ∧ + (c'.work utmSimTape).head = (c.work utmSimTape).head + 3 * (n - done) + 1 ∧ + (c'.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmSimTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work ∧ + (∀ i : Fin 4, (c'.work i).head ≥ 1) := by + intro done + induction h : n - done generalizing done with + | zero => + intro c hdn hstate hsc_head hsc_ones hsc_sentinel hsc0 hwf + hinp_h hinp_ns hout_h hout_ns hwk_heads + have hdn_eq : done = n := by omega + -- Scratch reads blank at position n+1 + have hsc_read_ne : ¬((fun i => (c.work i).read) (3 : Fin 4) = Γ.one) := by + show (c.work utmScratchTape).read ≠ Γ.one + simp only [Tape.read, hsc_head, hdn_eq, show 1 + n = n + 1 from by omega, hsc_sentinel]; decide + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h hinp_ns + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h hout_ns + -- Simplified next config + let sim' : Tape := ⟨(c.work utmSimTape).head + 1, (c.work utmSimTape).cells⟩ + let c' : Cfg 4 setupSimTM.Q := { + state := .strideExtra2, input := c.input, + work := fun i => if i = utmSimTape then sim' else c.work i, + output := c.output } + have hstep : setupSimTM.step c = some c' := by + unfold TM.step + simp only [hstate, show SetupSimPhase.stride1 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, hsc_read_ne, simAdvanceRight, simWriteRight] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, c', sim'] + have hh := @writeAndMove_right_head (c.work utmSimTape) (readBackWrite (c.work utmSimTape).read) + have hc := readBackWrite_cells (hwk_heads utmSimTape) (fun j hj => hwf.2 utmSimTape j hj) + (d := Dir3.right) + exact match (c.work utmSimTape).writeAndMove _ Dir3.right, hh, hc with + | ⟨_, _⟩, rfl, rfl => rfl + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi, c'] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf.2 i j hj) + refine ⟨c', .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, rfl, rfl, ?_, ?_⟩ + · show sim'.head = _; simp only [sim'] + · show sim'.cells = _; rfl + · show (c.work utmScratchTape).head = n + 1; rw [hsc_head, hdn_eq]; omega + · show (c.work utmScratchTape).cells = _; rfl + · intro i hi1 _; show (if i = utmSimTape then sim' else c.work i) = c.work i; simp [hi1] + · constructor + · intro i; show (c'.work i).cells 0 = Γ.start; simp only [c'] + split + · simp only [sim']; exact hwf.1 utmSimTape + · exact hwf.1 _ + · intro i j hj; show (c'.work i).cells j ≠ Γ.start; simp only [c'] + split + · simp only [sim']; exact hwf.2 utmSimTape j hj + · exact hwf.2 _ j hj + · intro i; show (c'.work i).head ≥ 1; simp only [c'] + split + · simp only [sim']; have := hwk_heads utmSimTape; omega + · exact hwk_heads _ + | succ m ih => + intro c hdn hstate hsc_head hsc_ones hsc_sentinel hsc0 hwf + hinp_h hinp_ns hout_h hout_ns hwk_heads + have hlt : done < n := by omega + -- Scratch reads one at position done+1 + have hsc_read_one : (fun i => (c.work i).read) (3 : Fin 4) = Γ.one := by + show (c.work utmScratchTape).read = Γ.one + simp only [Tape.read, hsc_head]; exact hsc_ones (1 + done) (by omega) (by omega) + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h hinp_ns + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h hout_ns + -- readBackWrite preserves sim cells + have hsim_rb : ∀ (t : Tape), t.cells = (c.work utmSimTape).cells → t.head ≥ 1 → + (t.writeAndMove (readBackWrite t.read) Dir3.right).cells = (c.work utmSimTape).cells := by + intro t htc hth + rw [← htc]; exact readBackWrite_cells hth (fun j hj => htc ▸ hwf.2 utmSimTape j hj) + -- Define c₃: config after 3 steps (stride1→stride2→stride3→stride1) + -- Sim: head +3, cells preserved. Scratch: head +1, cells preserved. Rest: preserved. + let c₃ : Cfg 4 setupSimTM.Q := { + state := .stride1 + input := c.input + work := fun i => + if i = utmSimTape then ⟨(c.work utmSimTape).head + 3, (c.work utmSimTape).cells⟩ + else if i = utmScratchTape then ⟨(c.work utmScratchTape).head + 1, (c.work utmScratchTape).cells⟩ + else c.work i + output := c.output } + -- ── 3-step reachesIn ── + have hreach3 : setupSimTM.reachesIn 3 c c₃ := by + -- Step 1: stride1(one) → stride2 via simAdvanceRight + have hstep1 : setupSimTM.step c = some + { state := SetupSimPhase.stride2 + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 2 then readBackWrite (c.work utmSimTape).read + else readBackWrite (c.work i).read) : Γw) + (if (i : Fin 4).val = 2 then Dir3.right else idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) } := by + unfold TM.step + simp only [hstate, show SetupSimPhase.stride1 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, hsc_read_one, simAdvanceRight, simWriteRight] + -- Simplify c₁: sim head +1, cells preserved, rest idle + set sim₁ := (c.work utmSimTape).writeAndMove (readBackWrite (c.work utmSimTape).read) Dir3.right + have hsim1_head : sim₁.head = (c.work utmSimTape).head + 1 := writeAndMove_right_head + have hsim1_cells : sim₁.cells = (c.work utmSimTape).cells := + hsim_rb _ rfl (hwk_heads utmSimTape) + -- Step 2: stride2 → stride3 via simAdvanceRight (on simplified c₁) + have hstep2 : setupSimTM.step + { state := SetupSimPhase.stride2, input := c.input, + work := fun i => if i = utmSimTape then sim₁ else c.work i, + output := c.output } = some + { state := SetupSimPhase.stride3, input := c.input, + work := fun i => if i = utmSimTape then + ⟨(c.work utmSimTape).head + 2, (c.work utmSimTape).cells⟩ else c.work i, + output := c.output } := by + unfold TM.step + simp only [show SetupSimPhase.stride2 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM, simAdvanceRight, simWriteRight] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi : i = utmSimTape + · subst hi + simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte] + have hhead : (sim₁.writeAndMove (readBackWrite sim₁.read) Dir3.right).head = + (c.work utmSimTape).head + 2 := by + rw [writeAndMove_right_head, hsim1_head] + have hcells : (sim₁.writeAndMove (readBackWrite sim₁.read) Dir3.right).cells = + (c.work utmSimTape).cells := hsim_rb sim₁ hsim1_cells (by omega) + exact match sim₁.writeAndMove _ Dir3.right, hhead, hcells with + | ⟨_, _⟩, rfl, rfl => rfl + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf.2 i j hj) + -- Step 3: stride3 → stride1 (both sim and scratch advance right) + set sim₂ : Tape := ⟨(c.work utmSimTape).head + 2, (c.work utmSimTape).cells⟩ + have hstep3 : setupSimTM.step + { state := SetupSimPhase.stride3, input := c.input, + work := fun i => if i = utmSimTape then sim₂ else c.work i, + output := c.output } = some c₃ := by + unfold TM.step + simp only [show SetupSimPhase.stride3 ≠ SetupSimPhase.done from nofun, ↓reduceIte, + setupSimTM] + congr 1; refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi2 : i = utmSimTape + · -- Sim tape: readBackWrite + right + subst hi2 + simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, + show ¬((2 : Fin 4) = utmScratchTape) from by decide, c₃] + have hh : (sim₂.writeAndMove (readBackWrite sim₂.read) Dir3.right).head = + (c.work utmSimTape).head + 3 := by rw [writeAndMove_right_head] + have hc : (sim₂.writeAndMove (readBackWrite sim₂.read) Dir3.right).cells = + (c.work utmSimTape).cells := hsim_rb sim₂ rfl (by simp only [sim₂]; have := hwk_heads utmSimTape; omega) + exact match sim₂.writeAndMove _ Dir3.right, hh, hc with + | ⟨_, _⟩, rfl, rfl => rfl + · by_cases hi3 : i = utmScratchTape + · -- Scratch tape: readBackWrite + right + subst hi3 + simp only [show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte, + show (utmScratchTape : Fin 4).val = 3 from rfl, + show ¬((3 : Nat) = 2) from by decide, c₃] + have hhead : ((c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read) Dir3.right).head = + (c.work utmScratchTape).head + 1 := writeAndMove_right_head + have hcells : ((c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read) Dir3.right).cells = + (c.work utmScratchTape).cells := + readBackWrite_cells (hwk_heads utmScratchTape) + (fun j hj => hwf.2 utmScratchTape j hj) + exact match (c.work utmScratchTape).writeAndMove _ Dir3.right, hhead, hcells with + | ⟨_, _⟩, rfl, rfl => rfl + · -- Other tapes: idle + have hival2 : ¬((i : Fin 4).val = 2) := fun heq => hi2 (Fin.ext heq) + have hival3 : ¬((i : Fin 4).val = 3) := fun heq => hi3 (Fin.ext heq) + simp only [hi2, hi3, ↓reduceIte, hival2, hival3, c₃] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf.2 i j hj) + -- Need step 1 result = simplified form for chaining step 2 + have hstep1_simp : setupSimTM.step c = some + { state := SetupSimPhase.stride2, input := c.input, + work := fun i => if i = utmSimTape then sim₁ else c.work i, + output := c.output } := by + rw [hstep1]; congr 1 + refine Cfg.mk.injEq .. |>.mpr ⟨rfl, hinp_idle, ?_, hout_idle⟩ + funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, sim₁] + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf.2 i j hj) + exact .step hstep1_simp (.step hstep2 (.step hstep3 .zero)) + -- Apply IH + have hih := ih (done + 1) (by omega) c₃ (by omega) + (by show c₃.state = .stride1; rfl) + (by show (c₃.work utmScratchTape).head = 1 + (done + 1) + simp only [c₃, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte, hsc_head] + omega) + (by intro j hj hjn; show (c₃.work utmScratchTape).cells j = Γ.one + simp only [c₃, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc_ones j (by omega) hjn) + (by show (c₃.work utmScratchTape).cells (n + 1) = Γ.blank + simp only [c₃, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc_sentinel) + (by show (c₃.work utmScratchTape).cells 0 = Γ.start + simp only [c₃, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc0) + (by constructor + · intro i; show (c₃.work i).cells 0 = Γ.start; simp only [c₃] + by_cases h2 : i = utmSimTape + · simp [h2]; exact hwf.1 utmSimTape + · by_cases h3 : i = utmScratchTape + · simp [h2, h3]; exact hwf.1 utmScratchTape + · simp [h2, h3]; exact hwf.1 i + · intro i j hj; show (c₃.work i).cells j ≠ Γ.start; simp only [c₃] + by_cases h2 : i = utmSimTape + · simp [h2]; exact hwf.2 utmSimTape j hj + · by_cases h3 : i = utmScratchTape + · simp [h2, h3]; exact hwf.2 utmScratchTape j hj + · simp [h2, h3]; exact hwf.2 i j hj) + hinp_h hinp_ns hout_h hout_ns + (by intro i; show (c₃.work i).head ≥ 1 + simp only [c₃]; split + · simp only []; have := hwk_heads utmSimTape; omega + · split + · simp only []; have := hwk_heads utmScratchTape; omega + · exact hwk_heads i) + obtain ⟨c', hreach_ih, hst', hsim_h', hsim_c', hsc_h', hsc_c', hwk_other', hinp', hout', hwf', hwk_heads'⟩ := hih + refine ⟨c', ?_, hst', ?_, ?_, hsc_h', ?_, ?_, hinp', hout', hwf', hwk_heads'⟩ + · -- reachesIn composition + have : 3 * (m + 1) + 1 = 3 + (3 * m + 1) := by omega + rw [this]; exact reachesIn_trans setupSimTM hreach3 hreach_ih + · -- sim head + rw [hsim_h']; show (c₃.work utmSimTape).head + 3 * m + 1 = _ + simp only [c₃, ↓reduceIte]; omega + · -- sim cells + rw [hsim_c']; show (c₃.work utmSimTape).cells = _ + simp only [c₃, ↓reduceIte] + · -- scratch cells + rw [hsc_c']; show (c₃.work utmScratchTape).cells = _ + simp only [c₃, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + · -- other tapes + intro i hi1 hi2 + rw [hwk_other' i hi1 hi2]; show c₃.work i = c.work i + simp only [c₃, hi1, hi2, ↓reduceIte] + +-- Helper: for any pos ≠ pos' or tapeIdx ≥ 1, the super-cell offsets don't collide +-- with h0+1 or h0+2 (which are at position pos', tape 0, offsets 1 and 2). +private theorem simTapeOffset_ne_of + (n pos pos' tapeIdx off : ℕ) (hoff : off ≤ 2) (htlt : tapeIdx < n + 2) + (h : pos ≠ pos' ∨ tapeIdx ≥ 1) : + 1 + pos * (3 * (n + 2)) + 3 * tapeIdx + off ≠ 1 + pos' * (3 * (n + 2)) + 1 ∧ + 1 + pos * (3 * (n + 2)) + 3 * tapeIdx + off ≠ 1 + pos' * (3 * (n + 2)) + 2 := by + -- Key: if pos ≤ pos' - 1, then pos * W ≤ (pos' - 1) * W, so pos' * W ≥ pos * W + W + -- And W = 3*(n+2) ≥ 6, so the gap is large enough that offsets 1,2 vs 3*t+off can't collide + -- Strategy: derive ALL needed gap inequalities FIRST (as products), THEN generalize + -- to make the products opaque for omega. + -- For pos < pos': pos'*W ≥ (pos+1)*W = pos*W + W, so gap ≥ W ≥ 6 + -- For pos > pos': pos*W ≥ (pos'+1)*W = pos'*W + W + have hW_ge : 3 * (n + 2) ≥ 6 := by omega + -- Expand succ multiplications to get linear forms + have hsucc_pos : (pos + 1) * (3 * (n + 2)) = pos * (3 * (n + 2)) + 3 * (n + 2) := Nat.succ_mul _ _ + have hsucc_pos' : (pos' + 1) * (3 * (n + 2)) = pos' * (3 * (n + 2)) + 3 * (n + 2) := Nat.succ_mul _ _ + -- Derive all possible gap bounds before generalizing + rcases h with hne | htge + · rcases Nat.lt_or_gt_of_ne hne with hlt | hgt + · have hgap := Nat.mul_le_mul_right (3 * (n + 2)) (show pos + 1 ≤ pos' from hlt) + rw [hsucc_pos] at hgap + -- hgap : pos*W + W ≤ pos'*W. Now generalize. + generalize pos * (3 * (n + 2)) = A at * + generalize pos' * (3 * (n + 2)) = B at * + constructor <;> omega + · have hgap := Nat.mul_le_mul_right (3 * (n + 2)) (show pos' + 1 ≤ pos from hgt) + rw [hsucc_pos'] at hgap + generalize pos * (3 * (n + 2)) = A at * + generalize pos' * (3 * (n + 2)) = B at * + constructor <;> omega + · by_cases hpe : pos = pos' + · subst hpe; constructor <;> omega + · rcases Nat.lt_or_gt_of_ne hpe with hlt | hgt + · have hgap := Nat.mul_le_mul_right (3 * (n + 2)) (show pos + 1 ≤ pos' from hlt) + rw [hsucc_pos] at hgap + generalize pos * (3 * (n + 2)) = A at * + generalize pos' * (3 * (n + 2)) = B at * + constructor <;> omega + · have hgap := Nat.mul_le_mul_right (3 * (n + 2)) (show pos' + 1 ≤ pos from hgt) + rw [hsucc_pos'] at hgap + generalize pos * (3 * (n + 2)) = A at * + generalize pos' * (3 * (n + 2)) = B at * + constructor <;> omega + +private theorem simTapeOffset_ne_prev (n processed p : ℕ) (off : ℕ) (hoff : off ≤ 2) + (hp : p ≤ processed) : + 1 + p * (3 * (n + 2)) + off ≠ 1 + (processed + 1) * (3 * (n + 2)) + 1 ∧ + 1 + p * (3 * (n + 2)) + off ≠ 1 + (processed + 1) * (3 * (n + 2)) + 2 := + -- p ≤ processed < processed + 1, so this is a special case of simTapeOffset_ne_of + -- with tapeIdx = 0, pos = p, pos' = processed + 1 + simTapeOffset_ne_of n p (processed + 1) 0 off hoff (by omega) (Or.inl (by omega)) + +/-- One-bit cycle: process one input bit, advancing from checkInput back to checkInput. + Takes 4n+9 steps. Writes head-marker/sym_hi/sym_lo at the current super-cell position, + then strides the sim tape to the next super-cell. -/ +private theorem one_bit_cycle + (b : Bool) (x : List Bool) (processed : ℕ) + (c : Cfg 4 setupSimTM.Q) + (hlen : processed + 1 ≤ x.length) + (hstate' : c.state = .checkInput) + (hsim0' : (c.work utmSimTape).cells 0 = Γ.start) + (hsim_head' : (c.work utmSimTape).head = 1 + (processed + 1) * (3 * (n + 2))) + (hones' : ∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c.work utmSimTape).cells j = Γ.one) + (hsim_rest' : ∀ j, j > (processed + 1) * (3 * (n + 2)) → (c.work utmSimTape).cells j = Γ.blank) + (hinput_written : ∀ (p : ℕ) (_hp1 : p ≥ 1) (_hp2 : p ≤ processed), + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) + (hblank_written : ∀ (tapeIdx pos : ℕ), pos ≥ 1 → pos ≤ processed → + tapeIdx ≥ 1 → tapeIdx < n + 2 → ∀ off, off < 3 → + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) pos tapeIdx + off) = Γ.blank) + (hsc_ones' : ∀ j, j ≥ 1 → j ≤ n → (c.work utmScratchTape).cells j = Γ.one) + (hsc_blank' : (c.work utmScratchTape).cells (n + 1) = Γ.blank) + (hsc0' : (c.work utmScratchTape).cells 0 = Γ.start) + (hsc_head' : (c.work utmScratchTape).head = n + 1) + (hinp_h' : c.input.head ≥ 1) + (hinp_ns' : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (hinp_read : c.input.read = Γ.ofBool b) + (hb_eq : b = x.get ⟨processed, by omega⟩) + (hout_h' : c.output.head ≥ 1) + (hout_ns' : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hwf' : WorkTapesWF c.work) + (hdesc_h' : (c.work utmDescTape).head ≥ 1) + (hst_h' : (c.work utmStateTape).head ≥ 1) + (hwk_heads : ∀ i : Fin 4, (c.work i).head ≥ 1) : + ∃ c_next, + setupSimTM.reachesIn (4 * n + 9) c c_next ∧ + c_next.state = .checkInput ∧ + (c_next.work utmSimTape).cells 0 = Γ.start ∧ + (c_next.work utmSimTape).head = 1 + (processed + 1 + 1) * (3 * (n + 2)) ∧ + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c_next.work utmSimTape).cells j = Γ.one) ∧ + (∀ j, j > (processed + 1 + 1) * (3 * (n + 2)) → (c_next.work utmSimTape).cells j = Γ.blank) ∧ + (∀ (p : ℕ) (_hp1 : p ≥ 1) (_hp2 : p ≤ processed + 1) (_hpx : p ≤ x.length), + (c_next.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c_next.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c_next.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) ∧ + (∀ (tapeIdx pos : ℕ), pos ≥ 1 → pos ≤ processed + 1 → tapeIdx ≥ 1 → tapeIdx < n + 2 → + ∀ off, off < 3 → + (c_next.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) pos tapeIdx + off) = Γ.blank) ∧ + (∀ j, j ≥ 1 → j ≤ n → (c_next.work utmScratchTape).cells j = Γ.one) ∧ + (c_next.work utmScratchTape).cells (n + 1) = Γ.blank ∧ + (c_next.work utmScratchTape).cells 0 = Γ.start ∧ + (c_next.work utmScratchTape).head = n + 1 ∧ + c_next.input.head = c.input.head + 1 ∧ + c_next.input.cells = c.input.cells ∧ + c_next.work utmDescTape = c.work utmDescTape ∧ + c_next.work utmStateTape = c.work utmStateTape ∧ + c_next.output = c.output ∧ + WorkTapesWF c_next.work ∧ + (∀ i : Fin 4, (c_next.work i).head ≥ 1) := by + -- Abbreviations + set h0 := (c.work utmSimTape).head with h0_def + have h0_val : h0 = 1 + (processed + 1) * (3 * (n + 2)) := by rw [h0_def]; exact hsim_head' + have hinp_not_blank : c.input.read ≠ Γ.blank := by rw [hinp_read]; cases b <;> simp [Γ.ofBool] + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h' hinp_ns' + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h' hout_ns' + -- Sim tape after 3 write steps: cells updated at h0+1 (Γ.zero) and h0+2 (w.toΓ) + let w : Γw := if c.input.read = Γ.one then .one else .zero + let sim_a : Tape := { + head := h0 + 3, + cells := fun j => + if j = h0 + 1 then Γ.zero + else if j = h0 + 2 then w.toΓ + else (c.work utmSimTape).cells j } + let c_a : Cfg 4 setupSimTM.Q := { + state := .rewindScratch, + input := ⟨c.input.head + 1, c.input.cells⟩, + work := fun i => if i = utmSimTape then sim_a else c.work i, + output := c.output } + -- Block A: 3 write steps (sorry'd — mechanical step tracing) + have hreach_a : setupSimTM.reachesIn 3 c c_a := by + -- Step 1: checkInput(non-blank) → writeSymHi via simAdvanceRight + set sim1 := (c.work utmSimTape).writeAndMove (readBackWrite (c.work utmSimTape).read) Dir3.right + have hsim1_head : sim1.head = h0 + 1 := writeAndMove_right_head + have hsim1_cells : sim1.cells = (c.work utmSimTape).cells := + readBackWrite_cells (hwk_heads utmSimTape) (fun j hj => hwf'.2 utmSimTape j hj) + have hstep1 : setupSimTM.step c = some + { state := .writeSymHi, input := c.input, + work := fun i => if i = utmSimTape then sim1 else c.work i, + output := c.output } := by + simp only [TM.step, hstate', setupSimTM, simAdvanceRight, simWriteRight, + show SetupSimPhase.checkInput ≠ SetupSimPhase.done from nofun, ↓reduceIte, hinp_not_blank, + hinp_idle, hout_idle] + congr 2; funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, sim1] + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf'.2 i j hj) + -- Step 2: writeSymHi → writeSymLo via simWriteRight .zero + -- sim1 → sim2: write Γ.zero at h0+1, advance to h0+2 + set sim2 : Tape := ⟨h0 + 2, fun j => if j = h0 + 1 then Γ.zero else (c.work utmSimTape).cells j⟩ + have hstep2 : setupSimTM.step + { state := .writeSymHi, input := c.input, + work := fun i => if i = utmSimTape then sim1 else c.work i, + output := c.output } = some + { state := .writeSymLo, input := c.input, + work := fun i => if i = utmSimTape then sim2 else c.work i, + output := c.output } := by + simp only [TM.step, setupSimTM, simWriteRight, + show SetupSimPhase.writeSymHi ≠ SetupSimPhase.done from nofun, ↓reduceIte, hinp_idle, hout_idle] + congr 2; funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, sim2] + -- sim1.writeAndMove Γw.zero Dir3.right = sim2 + have hh : (sim1.writeAndMove Γw.zero Dir3.right).head = (h0 + 2) := by + rw [writeAndMove_right_head, hsim1_head] + have hc : (sim1.writeAndMove Γw.zero Dir3.right).cells = + (fun j => if j = h0 + 1 then Γ.zero else (c.work utmSimTape).cells j) := by + ext j; by_cases hj : j = h0 + 1 + · subst hj; simp only [↓reduceIte] + conv_lhs => rw [← hsim1_head] + exact writeAndMove_cells_at_head (by rw [hsim1_head]; omega) + · simp only [hj, ↓reduceIte] + rw [writeAndMove_cells_ne (by rw [hsim1_head]; exact hj), hsim1_cells] + exact match sim1.writeAndMove _ Dir3.right, hh, hc with | ⟨_, _⟩, rfl, rfl => rfl + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf'.2 i j hj) + -- Step 3: writeSymLo → rewindScratch (write w to sim at h0+2, advance sim+input right) + have hstep3 : setupSimTM.step + { state := .writeSymLo, input := c.input, + work := fun i => if i = utmSimTape then sim2 else c.work i, + output := c.output } = some c_a := by + simp only [TM.step, setupSimTM, + show SetupSimPhase.writeSymLo ≠ SetupSimPhase.done from nofun, ↓reduceIte, hout_idle] + -- After simp: some { .rewindScratch, input.move Right, fun i => ..., output } + -- Need to show = some c_a + -- input.move Right = ⟨head+1, cells⟩ + have hinp_right : c.input.move Dir3.right = ⟨c.input.head + 1, c.input.cells⟩ := by simp [Tape.move] + simp only [hinp_right] + congr 2; funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, c_a, sim_a] + -- sim2.writeAndMove w Dir3.right = sim_a + have hh : (sim2.writeAndMove w Dir3.right).head = (h0 + 3) := by + rw [writeAndMove_right_head] + have hc : (sim2.writeAndMove w Dir3.right).cells = sim_a.cells := by + ext j; simp only [sim_a] + by_cases hj1 : j = h0 + 1 + · subst hj1; simp only [↓reduceIte] + rw [writeAndMove_cells_ne (show h0 + 1 ≠ (h0 + 2 : ℕ) from by omega)]; simp [sim2] + · simp only [hj1, ↓reduceIte] + by_cases hj2 : j = h0 + 2 + · subst hj2; simp only [↓reduceIte] + exact writeAndMove_cells_at_head (show (h0 + 2 : ℕ) ≠ 0 from by omega) + · simp only [hj2, ↓reduceIte] + rw [writeAndMove_cells_ne (show j ≠ (h0 + 2 : ℕ) from hj2)]; simp [sim2, hj1] + exact match sim2.writeAndMove _ Dir3.right, hh, hc with | ⟨_, _⟩, rfl, rfl => rfl + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi, c_a] + exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf'.2 i j hj) + exact .step hstep1 (.step hstep2 (.step hstep3 .zero)) + have hca_wf : WorkTapesWF c_a.work := by + constructor + · intro i; simp only [c_a]; split + · simp only [sim_a, show h0 + 1 ≠ 0 from by omega, show h0 + 2 ≠ 0 from by omega, ↓reduceIte] + exact hsim0' + · exact hwf'.1 _ + · intro i j hj; simp only [c_a]; split + · simp only [sim_a]; split + · simp [Γ.zero] + · split + · cases w <;> simp [Γw.toΓ] + · exact hwf'.2 utmSimTape j hj + · exact hwf'.2 _ j hj + -- Block B: rewind scratch (n+2 steps) + obtain ⟨c_b, hreach_b, hcb_state, hcb_scratch_head, hcb_scratch_cells, + hcb_other, hcb_inp, hcb_out, hcb_wf, hcb_heads⟩ := + rewindScratch_loop (n + 1) c_a rfl + (show (c_a.work utmScratchTape).head = n + 1 from by + simp only [c_a, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte]; exact hsc_head') + hca_wf (show c_a.input.head ≥ 1 from by simp only [c_a]; omega) hinp_ns' hout_h' hout_ns' + (fun i hi => by + show (c_a.work i).head ≥ 1; simp only [c_a] + by_cases hi2 : i = utmSimTape + · subst hi2; simp only [↓reduceIte, sim_a]; have := hwk_heads utmSimTape; omega + · simp only [hi2, ↓reduceIte]; exact hwk_heads _) + -- Block C: bounce (1 step) + let c_c : Cfg 4 setupSimTM.Q := + { state := .stride1, input := c_b.input, work := c_b.work, output := c_b.output } + have hreach_c : setupSimTM.reachesIn 1 c_b c_c := by + have hstep : setupSimTM.step c_b = some c_c := by + simp only [TM.step, hcb_state, setupSimTM, setupIdle, c_c, + show SetupSimPhase.bounceScratch ≠ SetupSimPhase.done from nofun, ↓reduceIte, + idle_input_preserved (hcb_inp ▸ show c_a.input.head ≥ 1 from by simp [c_a]) (hcb_inp ▸ hinp_ns'), + idle_tape_preserved (hcb_out ▸ hout_h') (hcb_out ▸ hout_ns')] + congr 2; funext i; exact idle_tape_preserved (hcb_heads i) (fun j hj => hcb_wf.2 i j hj) + exact .step hstep .zero + -- Block D: stride loop (3n+1 steps) + obtain ⟨c_d, hreach_d, hcd_state, hcd_sim_head, hcd_sim_cells, hcd_scratch_head, + hcd_scratch_cells, hcd_other, hcd_inp, hcd_out, hcd_wf, hcd_heads⟩ := + stride_loop 0 c_c (by omega) rfl + (show (c_c.work utmScratchTape).head = 1 + 0 from by + show (c_b.work utmScratchTape).head = 1; exact hcb_scratch_head) + (by intro j hj hjn; show (c_b.work utmScratchTape).cells j = Γ.one + rw [hcb_scratch_cells]; simp only [c_a, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc_ones' j hj hjn) + (by show (c_b.work utmScratchTape).cells (n + 1) = Γ.blank + rw [hcb_scratch_cells]; simp only [c_a, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc_blank') + (by show (c_b.work utmScratchTape).cells 0 = Γ.start + rw [hcb_scratch_cells]; simp only [c_a, show utmScratchTape ≠ utmSimTape from by decide, ↓reduceIte] + exact hsc0') + hcb_wf (by rw [hcb_inp]; simp [c_a]) (by rw [hcb_inp]; exact hinp_ns') + (by rw [hcb_out]; exact hout_h') (by rw [hcb_out]; exact hout_ns') hcb_heads + -- Block E: 2 strideExtra steps (sorry'd — mechanical step tracing) + let c_e_sim : Tape := ⟨(c_d.work utmSimTape).head + 2, (c_d.work utmSimTape).cells⟩ + let c_e : Cfg 4 setupSimTM.Q := { + state := .checkInput, input := c_d.input, + work := fun i => if i = utmSimTape then c_e_sim else c_d.work i, + output := c_d.output } + have hreach_e : setupSimTM.reachesIn 2 c_d c_e := by + -- strideExtra2 → strideExtra3 → checkInput (both simAdvanceRight) + -- Intermediate: sim head +1, cells preserved, rest idle + set sim_d1 := (c_d.work utmSimTape).writeAndMove (readBackWrite (c_d.work utmSimTape).read) Dir3.right + have hd_inp_h : c_d.input.head ≥ 1 := by rw [hcd_inp, hcb_inp]; simp [c_a] + have hd_inp_ns : ∀ j, j ≥ 1 → c_d.input.cells j ≠ Γ.start := by rw [hcd_inp, hcb_inp]; exact hinp_ns' + have hd_out_h : c_d.output.head ≥ 1 := by rw [hcd_out, hcb_out]; exact hout_h' + have hd_out_ns : ∀ j, j ≥ 1 → c_d.output.cells j ≠ Γ.start := by rw [hcd_out, hcb_out]; exact hout_ns' + have hd_inp := idle_input_preserved hd_inp_h hd_inp_ns + have hd_out := idle_tape_preserved hd_out_h hd_out_ns + -- Use same pattern as stride_loop: define intermediate sim tapes, match via head/cells + set sim_d2 : Tape := ⟨(c_d.work utmSimTape).head + 2, (c_d.work utmSimTape).cells⟩ + -- Step 1: strideExtra2 → strideExtra3 + have hstep1 : setupSimTM.step c_d = some + { state := .strideExtra3, input := c_d.input, + work := fun i => if i = utmSimTape then sim_d1 else c_d.work i, + output := c_d.output } := by + simp only [TM.step, hcd_state, setupSimTM, simAdvanceRight, simWriteRight, + show SetupSimPhase.strideExtra2 ≠ SetupSimPhase.done from nofun, ↓reduceIte, hd_inp, hd_out] + congr 2; funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, sim_d1] + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi] + exact idle_tape_preserved (hcd_heads i) (fun j hj => hcd_wf.2 i j hj) + -- Step 2: strideExtra3 → checkInput + have hstep2 : setupSimTM.step + { state := .strideExtra3, input := c_d.input, + work := fun i => if i = utmSimTape then sim_d1 else c_d.work i, + output := c_d.output } = some c_e := by + simp only [TM.step, setupSimTM, simAdvanceRight, simWriteRight, + show SetupSimPhase.strideExtra3 ≠ SetupSimPhase.done from nofun, ↓reduceIte, hd_inp, hd_out] + congr 2; funext i; by_cases hi : i = utmSimTape + · subst hi; simp only [utmSimTape, show (2 : Fin 4).val = 2 from rfl, ↓reduceIte, c_e, c_e_sim] + have hh := @writeAndMove_right_head sim_d1 (readBackWrite sim_d1.read) + have hc := readBackWrite_cells + (show sim_d1.head ≥ 1 from by rw [writeAndMove_right_head]; have := hcd_heads utmSimTape; omega) + (fun j hj => by rw [show sim_d1.cells = (c_d.work utmSimTape).cells from + readBackWrite_cells (hcd_heads utmSimTape) (fun k hk => hcd_wf.2 utmSimTape k hk)]; exact hcd_wf.2 utmSimTape j hj) + (d := Dir3.right) + show sim_d1.writeAndMove _ Dir3.right = sim_d2 + have : sim_d2 = ⟨sim_d1.head + 1, sim_d1.cells⟩ := by + simp only [sim_d2, sim_d1, writeAndMove_right_head, + readBackWrite_cells (hcd_heads utmSimTape) (fun j hj => hcd_wf.2 utmSimTape j hj)] + rw [this] + exact match sim_d1.writeAndMove _ Dir3.right, hh, hc with + | ⟨_, _⟩, rfl, rfl => rfl + · have hival : ¬((i : Fin 4).val = 2) := fun heq => hi (Fin.ext heq) + simp only [hival, ↓reduceIte, hi, c_e] + exact idle_tape_preserved (hcd_heads i) (fun j hj => hcd_wf.2 i j hj) + exact .step hstep1 (.step hstep2 .zero) + -- Compose all blocks: 3 + (n+2) + 1 + (3n+1) + 2 = 4n+9 + have hreach_total : setupSimTM.reachesIn (4 * n + 9) c c_e := by + have : 4 * n + 9 = 3 + ((n + 1 + 1) + (1 + ((3 * (n - 0) + 1) + 2))) := by omega + rw [this]; exact reachesIn_trans setupSimTM hreach_a + (reachesIn_trans setupSimTM hreach_b + (reachesIn_trans setupSimTM hreach_c + (reachesIn_trans setupSimTM hreach_d hreach_e))) + -- ═══ Track sim cells: c_e sim cells = sim_a cells ═══ + have hce_sim_cells : ∀ j, (c_e.work utmSimTape).cells j = sim_a.cells j := by + intro j; show c_e_sim.cells j = sim_a.cells j; simp only [c_e_sim] + rw [hcd_sim_cells, show (c_c.work utmSimTape) = c_b.work utmSimTape from rfl, + hcb_other utmSimTape (by decide)]; simp [c_a] + have sim_a_ne : ∀ j, j ≠ h0 + 1 → j ≠ h0 + 2 → sim_a.cells j = (c.work utmSimTape).cells j := by + intro j h1 h2; simp [sim_a, h1, h2] + -- ═══ Non-sim tape tracking ═══ + have hce_nonsim_noscratch : ∀ i : Fin 4, i ≠ utmSimTape → i ≠ utmScratchTape → c_e.work i = c.work i := by + intro i hi hi3; show (if i = utmSimTape then _ else c_d.work i) = _; simp only [hi, ↓reduceIte] + rw [hcd_other i hi hi3, show c_c.work i = c_b.work i from rfl, hcb_other i hi3]; simp [c_a, hi] + have hce_scratch_cells : (c_e.work utmScratchTape).cells = (c.work utmScratchTape).cells := by + show (c_d.work utmScratchTape).cells = _; rw [hcd_scratch_cells] + show (c_b.work utmScratchTape).cells = _; rw [hcb_scratch_cells] + simp [c_a, show utmScratchTape ≠ utmSimTape from by decide] + have hce_scratch_head : (c_e.work utmScratchTape).head = n + 1 := hcd_scratch_head + have hce_inp_head : c_e.input.head = c.input.head + 1 := by + show c_d.input.head = _; rw [hcd_inp, hcb_inp] + have hce_inp_cells : c_e.input.cells = c.input.cells := by + show c_d.input.cells = _; rw [hcd_inp, hcb_inp] + have hce_desc : c_e.work utmDescTape = c.work utmDescTape := + hce_nonsim_noscratch utmDescTape (by decide) (by decide) + have hce_state_tape : c_e.work utmStateTape = c.work utmStateTape := + hce_nonsim_noscratch utmStateTape (by decide) (by decide) + have hce_out : c_e.output = c.output := by show c_d.output = _; rw [hcd_out, hcb_out] + have hce_wf : WorkTapesWF c_e.work := by + constructor + · intro i; simp only [c_e]; split + · simp only [c_e_sim]; rw [hcd_sim_cells]; exact hcb_wf.1 utmSimTape + · exact hcd_wf.1 _ + · intro i j hj; simp only [c_e]; split + · simp only [c_e_sim]; rw [hcd_sim_cells]; exact hcb_wf.2 utmSimTape j hj + · exact hcd_wf.2 _ j hj + have hce_heads : ∀ i : Fin 4, (c_e.work i).head ≥ 1 := by + intro i; simp only [c_e]; split + · simp only [c_e_sim]; have := hcd_heads utmSimTape; omega + · exact hcd_heads _ + -- ═══ Sim head ═══ + have hce_sim_head : (c_e.work utmSimTape).head = 1 + (processed + 1 + 1) * (3 * (n + 2)) := by + show c_e_sim.head = _; simp only [c_e_sim]; rw [hcd_sim_head] + have : (c_c.work utmSimTape).head = h0 + 3 := by + show (c_b.work utmSimTape).head = _ + rw [hcb_other utmSimTape (by decide)]; simp [c_a, sim_a] + rw [this, h0_val] + have : (processed + 1 + 1) * (3 * (n + 2)) = (processed + 1) * (3 * (n + 2)) + 3 * (n + 2) := by + show (processed + 2) * (3 * (n + 2)) = _; rw [Nat.succ_mul] + generalize (processed + 1) * (3 * (n + 2)) = PW at * + omega + -- ═══ Postconditions ═══ + -- Use simTapeOffset_ne_of and simTapeOffset_ne_prev for all offset comparisons + have h_offset_eq : SuperCell.simTapeOffset (n + 2) (processed + 1) 0 = h0 := by + simp [SuperCell.simTapeOffset, SuperCell.width, h0_val] + refine ⟨c_e, hreach_total, rfl, ?_, hce_sim_head, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hce_scratch_head, + hce_inp_head, hce_inp_cells, hce_desc, hce_state_tape, hce_out, hce_wf, hce_heads⟩ + · -- sim0 + rw [hce_sim_cells]; exact sim_a_ne 0 (by omega) (by omega) ▸ hsim0' + · -- ones: j ≤ 3*(n+2) < h0, so j < h0+1 and j < h0+2 + intro j hj1 hjn; rw [hce_sim_cells] + have hh0_ge : h0 ≥ 1 + 3 * (n + 2) := by + rw [h0_val]; have := Nat.le_mul_of_pos_left (3 * (n + 2)) (show processed + 1 > 0 by omega); omega + rw [sim_a_ne j (by omega) (by omega)]; exact hones' j hj1 hjn + · -- rest blank: j > (processed+2)*W ≥ h0+W > h0+2 + intro j hj; rw [hce_sim_cells] + have hj' : j > (processed + 1) * (3 * (n + 2)) := by + have : (processed + 1 + 1) * (3 * (n + 2)) = (processed + 1) * (3 * (n + 2)) + 3 * (n + 2) := by + show (processed + 2) * (3 * (n + 2)) = _; rw [Nat.succ_mul] + generalize (processed + 1) * (3 * (n + 2)) = PW at *; omega + have hh0_le : h0 + 2 < j := by + have : (processed + 1 + 1) * (3 * (n + 2)) = (processed + 1) * (3 * (n + 2)) + 3 * (n + 2) := by + show (processed + 2) * (3 * (n + 2)) = _; rw [Nat.succ_mul] + rw [h0_val]; generalize (processed + 1) * (3 * (n + 2)) = PW at *; omega + rw [sim_a_ne j (by omega) (by omega)]; exact hsim_rest' j hj' + · -- input written + intro p hp1 hp2 hpx + by_cases hple : p ≤ processed + · -- Previously written: use simTapeOffset_ne_prev to show offsets don't collide with h0+1/h0+2 + have ⟨g1, g2, g3⟩ := hinput_written p hp1 hple + -- Use sim_a_ne: the key is that p ≤ processed < processed+1, so offsets don't collide + have hsane : ∀ k, k ≤ 2 → + sim_a.cells (SuperCell.simTapeOffset (n + 2) p 0 + k) = + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + k) := by + intro k hk + have hne := simTapeOffset_ne_prev n processed p k hk hple + apply sim_a_ne + · show SuperCell.simTapeOffset (n + 2) p 0 + k ≠ h0 + 1 + simp only [SuperCell.simTapeOffset, SuperCell.width, h0_val]; exact hne.1 + · show SuperCell.simTapeOffset (n + 2) p 0 + k ≠ h0 + 2 + simp only [SuperCell.simTapeOffset, SuperCell.width, h0_val]; exact hne.2 + refine ⟨?_, ?_, ?_⟩ <;> rw [hce_sim_cells] + · rw [show SuperCell.simTapeOffset (n + 2) p 0 = SuperCell.simTapeOffset (n + 2) p 0 + 0 from by omega, + hsane 0 (by omega)]; exact g1 + · rw [hsane 1 (by omega)]; exact g2 + · rw [hsane 2 (by omega)]; exact g3 + · -- Newly written: p = processed + 1 + have hpeq : p = processed + 1 := by omega + subst hpeq + refine ⟨?_, ?_, ?_⟩ <;> rw [hce_sim_cells] + · -- head marker = blank (at offset 0, which is h0, not h0+1 or h0+2) + rw [sim_a_ne _ (by rw [h_offset_eq]; omega) (by rw [h_offset_eq]; omega)] + apply hsim_rest'; rw [h_offset_eq]; omega + · -- sym_hi = zero (at offset 1 = h0+1) + show sim_a.cells (SuperCell.simTapeOffset (n + 2) (processed + 1) 0 + 1) = Γ.zero + rw [show SuperCell.simTapeOffset (n + 2) (processed + 1) 0 + 1 = h0 + 1 from by rw [h_offset_eq]] + simp [sim_a] + · -- sym_lo = ofBool(x[processed]) + show sim_a.cells (SuperCell.simTapeOffset (n + 2) (processed + 1) 0 + 2) = + Γ.ofBool (x.get ⟨processed, _⟩) + rw [show SuperCell.simTapeOffset (n + 2) (processed + 1) 0 + 2 = h0 + 2 from by rw [h_offset_eq]] + simp only [sim_a, show h0 + 2 ≠ h0 + 1 from by omega, ↓reduceIte] + show w.toΓ = Γ.ofBool (x.get ⟨processed, _⟩) + simp only [w, hinp_read, ← hb_eq]; cases b <;> simp [Γ.ofBool, Γw.toΓ] + · -- blank written (tapeIdx ≥ 1) + intro tapeIdx pos hpos hple htge htlt off hoff + rw [hce_sim_cells] + have ⟨hne1, hne2⟩ := simTapeOffset_ne_of n pos (processed + 1) tapeIdx off (by omega) htlt + (Or.inr htge) + -- hne1/hne2 have form: 1 + pos*W + 3*tapeIdx + off ≠ 1 + (processed+1)*W + 1/2 + -- sim_a_ne needs j ≠ h0 + 1 and j ≠ h0 + 2 where j = SuperCell.simTapeOffset + off + -- These match after unfolding SuperCell.simTapeOffset and h0_val + have : sim_a.cells (SuperCell.simTapeOffset (n + 2) pos tapeIdx + off) = + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) pos tapeIdx + off) := by + apply sim_a_ne + · simp only [SuperCell.simTapeOffset, SuperCell.width]; rw [h0_val]; exact hne1 + · simp only [SuperCell.simTapeOffset, SuperCell.width]; rw [h0_val]; exact hne2 + rw [this] + by_cases hple' : pos ≤ processed + · exact hblank_written tapeIdx pos hpos hple' htge htlt off hoff + · have hpeq : pos = processed + 1 := by omega + subst hpeq; apply hsim_rest' + simp only [SuperCell.simTapeOffset, SuperCell.width] + generalize (processed + 1) * (3 * (n + 2)) = PW + omega + · -- scratch ones + intro j hj hjn; rw [hce_scratch_cells]; exact hsc_ones' j hj hjn + · -- scratch blank + rw [hce_scratch_cells]; exact hsc_blank' + · -- scratch start + rw [hce_scratch_cells]; exact hsc0' + +/-- Phase 3: copy x with stride, then halt on blank. + + Each x bit takes 4n+9 steps. Final blank check takes 1 step. + Total: x.length * (4n+9) + 1 steps. -/ +private theorem setupSim_phase3 + (x : List Bool) + (c : Cfg 4 setupSimTM.Q) + (hstate : c.state = .checkInput) + -- sim tape after phase 1+2 + (hsim0 : (c.work utmSimTape).cells 0 = Γ.start) + (hsim_head : (c.work utmSimTape).head = 1 + 3 * (n + 2)) + (hpos0_ones : ∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c.work utmSimTape).cells j = Γ.one) + (hsim_rest : ∀ j, j > 3 * (n + 2) → (c.work utmSimTape).cells j = Γ.blank) + -- scratch tape + (hsc_ones : ∀ j, j ≥ 1 → j ≤ n → (c.work utmScratchTape).cells j = Γ.one) + (hsc_blank : (c.work utmScratchTape).cells (n + 1) = Γ.blank) + (hsc0 : (c.work utmScratchTape).cells 0 = Γ.start) + (hsc_head : (c.work utmScratchTape).head = n + 1) + -- input tape + (hinp_h : c.input.head ≥ 1) + (hinp_ns : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) + (hinp_x : ∀ (i : ℕ) (hi : i < x.length), + c.input.cells (c.input.head + i) = Γ.ofBool (x.get ⟨i, hi⟩)) + (hinp_end : c.input.cells (c.input.head + x.length) = Γ.blank) + -- output + wf + (hout_h : c.output.head ≥ 1) + (hout_ns : ∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) + (hwf : WorkTapesWF c.work) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hst_h : (c.work utmStateTape).head ≥ 1) : + ∃ c', + setupSimTM.reachesIn (x.length * (4 * n + 9) + 1) c c' ∧ + setupSimTM.halted c' ∧ + (c'.work utmSimTape).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c'.work utmSimTape).cells j = Γ.one) ∧ + (∀ (p : ℕ) (hp : p ≥ 1) (hp2 : p ≤ x.length), + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) ∧ + (∀ (numTapes tapeIdx pos : ℕ), + pos > 0 → tapeIdx < numTapes → numTapes = n + 2 → + (tapeIdx > 0 ∨ pos > x.length) → + ∀ off, off < 3 → + (c'.work utmSimTape).cells + (SuperCell.simTapeOffset numTapes pos tapeIdx + off) = Γ.blank) ∧ + c'.work utmDescTape = c.work utmDescTape ∧ + c'.work utmStateTape = c.work utmStateTape ∧ + WorkTapesWF c'.work ∧ + (∀ i, (c'.work i).head ≥ 1) ∧ + (c'.work utmSimTape).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (c'.work utmScratchTape).head ≤ n + 1 ∧ + c'.input.cells = c.input.cells ∧ + c'.input.head ≥ 1 ∧ + c'.output = c.output := by + -- Generalized induction with processed counter. + -- We add explicit p < x.length bounds so that by omega inside the type works. + suffices h_gen : ∀ (processed : ℕ) (xs : List Bool) (c : Cfg 4 setupSimTM.Q) + (hlen_g : processed + xs.length = x.length) + (hple_g : processed ≤ x.length), + c.state = .checkInput → + (c.work utmSimTape).cells 0 = Γ.start → + (c.work utmSimTape).head = 1 + (processed + 1) * (3 * (n + 2)) → + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c.work utmSimTape).cells j = Γ.one) → + (∀ j, j > (processed + 1) * (3 * (n + 2)) → (c.work utmSimTape).cells j = Γ.blank) → + (∀ (p : ℕ) (_hp1 : p ≥ 1) (_hp2 : p ≤ processed), + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) → + (∀ (tapeIdx pos : ℕ), + pos ≥ 1 → pos ≤ processed → + tapeIdx ≥ 1 → tapeIdx < n + 2 → + ∀ off, off < 3 → + (c.work utmSimTape).cells + (SuperCell.simTapeOffset (n + 2) pos tapeIdx + off) = Γ.blank) → + (∀ j, j ≥ 1 → j ≤ n → (c.work utmScratchTape).cells j = Γ.one) → + (c.work utmScratchTape).cells (n + 1) = Γ.blank → + (c.work utmScratchTape).cells 0 = Γ.start → + (c.work utmScratchTape).head = n + 1 → + c.input.head ≥ 1 → + (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → + (∀ (i : ℕ) (hi : i < xs.length), + c.input.cells (c.input.head + i) = Γ.ofBool (xs.get ⟨i, hi⟩)) → + c.input.cells (c.input.head + xs.length) = Γ.blank → + (∀ (i : ℕ) (hi : i < xs.length), xs.get ⟨i, hi⟩ = x.get ⟨processed + i, by omega⟩) → + c.output.head ≥ 1 → + (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → + WorkTapesWF c.work → + (c.work utmDescTape).head ≥ 1 → + (c.work utmStateTape).head ≥ 1 → + ∃ c', + setupSimTM.reachesIn (xs.length * (4 * n + 9) + 1) c c' ∧ + setupSimTM.halted c' ∧ + (c'.work utmSimTape).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c'.work utmSimTape).cells j = Γ.one) ∧ + (∀ (p : ℕ) (hp : p ≥ 1) (hp2 : p ≤ x.length), + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) ∧ + (∀ (numTapes tapeIdx pos : ℕ), + pos > 0 → tapeIdx < numTapes → numTapes = n + 2 → + (tapeIdx > 0 ∨ pos > x.length) → + ∀ off, off < 3 → + (c'.work utmSimTape).cells + (SuperCell.simTapeOffset numTapes pos tapeIdx + off) = Γ.blank) ∧ + c'.work utmDescTape = c.work utmDescTape ∧ + c'.work utmStateTape = c.work utmStateTape ∧ + WorkTapesWF c'.work ∧ + (∀ i, (c'.work i).head ≥ 1) ∧ + (c'.work utmSimTape).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (c'.work utmScratchTape).head ≤ n + 1 ∧ + c'.input.cells = c.input.cells ∧ + c'.input.head ≥ 1 ∧ + c'.output = c.output by + exact h_gen 0 x c (by omega) (by omega) + hstate hsim0 + (by convert hsim_head using 2; omega) + hpos0_ones + (by intro j hj; exact hsim_rest j (by omega)) + (by intro p _ hp2; omega) + (by intro _ pos _ hp2; omega) + hsc_ones hsc_blank hsc0 hsc_head + hinp_h hinp_ns hinp_x hinp_end + (by intro i hi; simp) + hout_h hout_ns hwf hdesc_h hst_h + -- Proof of h_gen by induction on xs + intro processed xs + induction xs generalizing processed with + | nil => + intro c hlen hproc_le hstate' hsim0' hsim_head' hones' hsim_rest' + hinput_written hblank_written hsc_ones' hsc_blank' hsc0' hsc_head' + hinp_h' hinp_ns' hinp_xs' hinp_end' hxs_eq hout_h' hout_ns' hwf' hdesc_h' hst_h' + have hproc : processed = x.length := by simp at hlen; exact hlen + -- Input reads blank + have hinp_blank : c.input.read = Γ.blank := by + simp only [Tape.read]; simpa using hinp_end' + have hinp_idle : c.input.move (idleDir c.input.read) = c.input := + idle_input_preserved hinp_h' hinp_ns' + have hout_idle : c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) = c.output := + idle_tape_preserved hout_h' hout_ns' + have hwk_heads : ∀ i : Fin 4, (c.work i).head ≥ 1 := fun + | ⟨0, _⟩ => hdesc_h' | ⟨1, _⟩ => hst_h' + | ⟨2, _⟩ => by show (c.work utmSimTape).head ≥ 1; omega + | ⟨3, _⟩ => by show (c.work utmScratchTape).head ≥ 1; rw [hsc_head']; omega + -- checkInput with blank → setupIdle .done → all tapes preserved + let c' : Cfg 4 setupSimTM.Q := + { state := .done, input := c.input, work := c.work, output := c.output } + have hstep : setupSimTM.step c = some c' := by + simp only [TM.step, hstate', setupSimTM, hinp_blank, setupIdle, c', + show SetupSimPhase.checkInput ≠ SetupSimPhase.done from nofun, ↓reduceIte, + hinp_idle, hout_idle] + congr 1 + refine Cfg.mk.injEq .. |>.mpr ⟨rfl, rfl, ?_, rfl⟩ + funext i; exact idle_tape_preserved (hwk_heads i) (fun j hj => hwf'.2 i j hj) + have hreach : setupSimTM.reachesIn (([] : List Bool).length * (4 * n + 9) + 1) c c' := by + simp only [List.length_nil, Nat.zero_mul, Nat.zero_add]; exact .step hstep .zero + exact ⟨c', hreach, + show c'.state = setupSimTM.qhalt from rfl, + hsim0', hones', + fun p hp hp2 => hinput_written p hp (by omega), + (by intro numTapes tapeIdx pos hpos htape hnt hor off hoff; subst hnt + rcases hor with htgt0 | hpgt + · by_cases hple : pos ≤ processed + · exact hblank_written tapeIdx pos (by omega) hple (by omega) htape off hoff + · apply hsim_rest' + have := Nat.mul_le_mul_right (3 * (n + 2)) (show processed + 1 ≤ pos from by omega) + simp only [SuperCell.simTapeOffset, SuperCell.width]; omega + · apply hsim_rest' + have := Nat.mul_le_mul_right (3 * (n + 2)) (show processed + 1 ≤ pos from by omega) + simp only [SuperCell.simTapeOffset, SuperCell.width]; omega), + rfl, rfl, hwf', hwk_heads, + by show (c.work utmSimTape).head ≤ _; rw [hsim_head', hproc] + show 1 + (x.length + 1) * (3 * (n + 2)) ≤ (x.length + 1) * 3 * (n + 2) + 1 + have : (x.length + 1) * (3 * (n + 2)) = (x.length + 1) * 3 * (n + 2) := (Nat.mul_assoc _ _ _).symm + omega, + by show (c.work utmScratchTape).head ≤ _; rw [hsc_head'], + rfl, hinp_h', rfl⟩ + | cons b rest ih => + intro c hlen hproc_le hstate' hsim0' hsim_head' hones' hsim_rest' + hinput_written hblank_written hsc_ones' hsc_blank' hsc0' hsc_head' + hinp_h' hinp_ns' hinp_xs' hinp_end' hxs_eq hout_h' hout_ns' hwf' hdesc_h' hst_h' + have hwk_heads : ∀ i : Fin 4, (c.work i).head ≥ 1 := fun + | ⟨0, _⟩ => hdesc_h' | ⟨1, _⟩ => hst_h' + | ⟨2, _⟩ => by show (c.work utmSimTape).head ≥ 1; omega + | ⟨3, _⟩ => by show (c.work utmScratchTape).head ≥ 1; rw [hsc_head']; omega + have hcycle := one_bit_cycle b x processed c (by simp at hlen; omega) + hstate' hsim0' hsim_head' hones' hsim_rest' hinput_written hblank_written + hsc_ones' hsc_blank' hsc0' hsc_head' hinp_h' hinp_ns' + (by simp only [Tape.read]; exact hinp_xs' 0 (by simp)) + (hxs_eq 0 (by simp)) + hout_h' hout_ns' hwf' hdesc_h' hst_h' hwk_heads + obtain ⟨c_next, hreach_cycle, hst_next, hsim0_next, hsim_head_next, hones_next, + hrest_next, hinput_next, hblank_next, hsc_ones_next, hsc_blank_next, + hsc0_next, hsc_head_next, hinp_head_next, hinp_cells_next, + hdesc_next, hstate_next, hout_next, hwf_next, hwk_heads_next⟩ := hcycle + -- Apply IH for rest + have hrest_len : rest.length + 1 = (b :: rest).length := by simp + have hih := ih (processed + 1) c_next + (by omega) + (by omega) + hst_next hsim0_next hsim_head_next hones_next hrest_next + (fun p hp1 hp2 => hinput_next p hp1 hp2 (by omega)) hblank_next + hsc_ones_next hsc_blank_next hsc0_next hsc_head_next + (show c_next.input.head ≥ 1 by rw [hinp_head_next]; omega) + (show ∀ j, j ≥ 1 → c_next.input.cells j ≠ Γ.start by rw [hinp_cells_next]; exact hinp_ns') + (by intro i hi; rw [hinp_cells_next, hinp_head_next] + have h1 : c.input.head + 1 + i = c.input.head + (i + 1) := by omega + rw [h1]; have h2 : i + 1 < (b :: rest).length := by simp; omega + have := hinp_xs' (i + 1) h2; simp only [List.get_cons_succ] at this; exact this) + (by rw [hinp_cells_next, hinp_head_next] + have h1 : c.input.head + 1 + rest.length = c.input.head + (b :: rest).length := by simp; omega + rw [h1]; exact hinp_end') + (by intro i hi + have h1 : i + 1 < (b :: rest).length := by simp; omega + have h2 := hxs_eq (i + 1) h1 + simp only [List.get_cons_succ] at h2 + have : processed + (i + 1) = processed + 1 + i := by omega + simp only [this] at h2; exact h2) + (show c_next.output.head ≥ 1 by rw [hout_next]; exact hout_h') + (show ∀ j, j ≥ 1 → c_next.output.cells j ≠ Γ.start by rw [hout_next]; exact hout_ns') + hwf_next + (show (c_next.work utmDescTape).head ≥ 1 by rw [hdesc_next]; exact hdesc_h') + (show (c_next.work utmStateTape).head ≥ 1 by rw [hstate_next]; exact hst_h') + obtain ⟨c_final, hreach_final, hhalt, hsim0_f, hones_f, hinput_f, hblank_f, + hdesc_f, hstate_f, hwf_f, hheads_f, hsim_hd_f, hsc_hd_f⟩ := hih + refine ⟨c_final, ?_, hhalt, hsim0_f, hones_f, hinput_f, hblank_f, ?_, ?_, hwf_f, + hheads_f, hsim_hd_f, hsc_hd_f.1, + hsc_hd_f.2.1.trans hinp_cells_next, hsc_hd_f.2.2.1, hsc_hd_f.2.2.2.trans hout_next⟩ + · -- reachesIn composition: (b::rest).length * (4n+9) + 1 = (4n+9) + rest.length*(4n+9) + 1 + have : (b :: rest).length * (4 * n + 9) + 1 = (4 * n + 9) + (rest.length * (4 * n + 9) + 1) := by + simp only [List.length_cons]; rw [Nat.succ_mul]; omega + rw [this]; exact reachesIn_trans setupSimTM hreach_cycle hreach_final + · rw [hdesc_f, hdesc_next] + · rw [hstate_f, hstate_next] + +-- ════════════════════════════════════════════════════════════════════════ +-- Full execution (proved modulo phases) +-- ════════════════════════════════════════════════════════════════════════ + +private def setupSimBound (n xLen : ℕ) : ℕ := 3 * n + 9 + xLen * (4 * n + 9) + +private theorem setupSim_full_execution + (x : List Bool) + (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + -- sim tape + (hsim0 : (work utmSimTape).cells 0 = Γ.start) + (hsim_blank : ∀ j, j ≥ 1 → (work utmSimTape).cells j = Γ.blank) + (hsim_head : (work utmSimTape).head = 1) + -- scratch tape (n ones at cells 1..n) + (hsc_bools : tapeStoresBools (List.replicate n true) (work utmScratchTape)) + (hsc_head : (work utmScratchTape).head = 1) + -- input tape + (hinp_h : inp.head ≥ 1) + (hinp_ns : ∀ j, j ≥ 1 → inp.cells j ≠ Γ.start) + (hinp_read_blank : inp.cells inp.head = Γ.blank) + (hinp_x : ∀ (i : ℕ) (hi : i < x.length), + inp.cells (inp.head + 1 + i) = Γ.ofBool (x.get ⟨i, hi⟩)) + (hinp_end : inp.cells (inp.head + 1 + x.length) = Γ.blank) + -- output tape + (hout_h : out.head ≥ 1) + (hout_ns : ∀ j, j ≥ 1 → out.cells j ≠ Γ.start) + -- work tapes WF + (hwf : WorkTapesWF work) + (hdesc_h : (work utmDescTape).head ≥ 1) + (hst_h : (work utmStateTape).head ≥ 1) : + ∃ c', + setupSimTM.reachesIn (setupSimBound n x.length) + ⟨.pos0Write1, inp, work, out⟩ c' ∧ + setupSimTM.halted c' ∧ + -- Position 0 ones + (c'.work utmSimTape).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → j ≤ 3 * (n + 2) → (c'.work utmSimTape).cells j = Γ.one) ∧ + -- Input positions correctly written + (∀ (p : ℕ) (hp : p ≥ 1) (hp2 : p ≤ x.length), + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0) = Γ.blank ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 1) = Γ.zero ∧ + (c'.work utmSimTape).cells (SuperCell.simTapeOffset (n + 2) p 0 + 2) = + Γ.ofBool (x.get ⟨p - 1, by omega⟩)) ∧ + -- Unwritten cells blank + (∀ (numTapes tapeIdx pos : ℕ), + pos > 0 → tapeIdx < numTapes → numTapes = n + 2 → + (tapeIdx > 0 ∨ pos > x.length) → + ∀ off, off < 3 → + (c'.work utmSimTape).cells + (SuperCell.simTapeOffset numTapes pos tapeIdx + off) = Γ.blank) ∧ + -- Preserved tapes + c'.work utmDescTape = work utmDescTape ∧ + c'.work utmStateTape = work utmStateTape ∧ + WorkTapesWF c'.work ∧ + (∀ i, (c'.work i).head ≥ 1) ∧ + -- Head bounds + (c'.work utmSimTape).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (c'.work utmScratchTape).head ≤ n + 1 ∧ + -- Input/output preservation + c'.input.cells = inp.cells ∧ + c'.input.head ≥ 1 ∧ + c'.output = out := by + -- Extract scratch tape properties from tapeStoresBools + have hsc0 : (work utmScratchTape).cells 0 = Γ.start := hsc_bools.1 + have hsc_ones : ∀ j, j ≥ 1 → j ≤ n → + (work utmScratchTape).cells j = Γ.one := by + intro j hj1 hjn + have hj' : j - 1 < (List.replicate n true).length := by simp; omega + have := hsc_bools.2.1 (j - 1) hj' + simp [List.replicate, List.getElem_replicate, Γ.ofBool] at this + rwa [show j - 1 + 1 = j from by omega] at this + have hsc_sentinel : (work utmScratchTape).cells (n + 1) = Γ.blank := by + have := hsc_bools.2.2; simp at this; exact this + -- Phase 1+2: write position-0 ones and advance input + obtain ⟨c1, hreach1, hst1, hsim0_1, hsim_head1, hones1, hblank1, + hdesc1, hstate1, hinp_head1, hinp_cells1, hout1, hwf1, + hsc_ones1, hsc_blank1, hsc0_1, hsc_head1, + hinp_h1, hinp_ns1, hout_h1, hout_ns1⟩ := + setupSim_phase12 inp work out hsim0 hsim_blank hsim_head + hsc0 hsc_ones hsc_sentinel hsc_head hinp_h hinp_ns hout_h hout_ns hwf + hdesc_h hst_h + -- Phase 3: copy x with stride and halt + have hinp_x1 : ∀ (i : ℕ) (hi : i < x.length), + c1.input.cells (c1.input.head + i) = Γ.ofBool (x.get ⟨i, hi⟩) := by + intro i hi + rw [hinp_cells1, hinp_head1] + exact hinp_x i hi + have hinp_end1 : c1.input.cells (c1.input.head + x.length) = Γ.blank := by + rw [hinp_cells1, hinp_head1] + exact hinp_end + obtain ⟨c2, hreach2, hhalt2, hsim0_2, hones2, hinput2, hblank2, + hdesc2, hstate2, hwf2, hheads2, hsim_hd2, hsc_hd2⟩ := + setupSim_phase3 x c1 hst1 hsim0_1 hsim_head1 hones1 hblank1 + hsc_ones1 hsc_blank1 hsc0_1 hsc_head1 + hinp_h1 hinp_ns1 hinp_x1 hinp_end1 hout_h1 hout_ns1 hwf1 + (by rw [hdesc1]; exact hdesc_h) (by rw [hstate1]; exact hst_h) + -- Compose phases + refine ⟨c2, ?_, hhalt2, hsim0_2, hones2, hinput2, hblank2, + ?_, ?_, hwf2, hheads2, hsim_hd2, hsc_hd2.1, + hsc_hd2.2.1.trans hinp_cells1, + hsc_hd2.2.2.1, + hsc_hd2.2.2.2.trans hout1⟩ + -- reachesIn composition + · have : setupSimBound n x.length = (3 * n + 8) + (x.length * (4 * n + 9) + 1) := by + simp [setupSimBound]; omega + rw [this] + exact reachesIn_trans setupSimTM hreach1 hreach2 + -- desc tape preserved + · rw [hdesc2]; exact hdesc1 + -- state tape preserved + · rw [hstate2]; exact hstate1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Main theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime for setupSimTM. + Precondition: sim tape blank, scratch has n ones at head 1, input at separator. + Postcondition: sim tape has super-cells for initCfg x. -/ +theorem setupSimTM_hoareTime (tm : TM n) (k : ℕ) + (e : tm.Q ≃ Fin k) (x : List Bool) + (_hk : k = @Fintype.card tm.Q tm.finQ) : + setupSimTM.HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (e tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmSimTape).head = 1 ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmScratchTape).head = 1 ∧ + inp.cells inp.head = Γ.blank ∧ + (∀ (i : ℕ) (hi : i < x.length), + inp.cells (inp.head + 1 + i) = Γ.ofBool (x.get ⟨i, hi⟩)) ∧ + inp.cells (inp.head + 1 + x.length) = Γ.blank ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmStateTape).head ≤ k + 1) + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (e tm.qstart) (work utmStateTape) ∧ + superCellsCorrect (tm.initCfg x) (work utmSimTape) ∧ + (work (0 : Fin 4)).head ≤ 3 * k + n + 5 ∧ + (work (1 : Fin 4)).head ≤ k + 1 ∧ + (work (2 : Fin 4)).head ≤ (x.length + 1) * 3 * (n + 2) + 1 ∧ + (work (3 : Fin 4)).head ≤ n + 1) + (3 * n + 9 + x.length * (4 * n + 9)) := by + intro inp work out ⟨henv, hdesc, hstate, hsim_cells, hsim_head, hsc_bools, hsc_head, + hinp_blank, hinp_x, hinp_end, hdesc_head_bound, hstate_head_bound⟩ + have hsim0 : (work utmSimTape).cells 0 = Γ.start := by rw [hsim_cells]; simp [initTape] + have hsim_blank : ∀ j, j ≥ 1 → (work utmSimTape).cells j = Γ.blank := by + intro j hj; rw [hsim_cells]; simp [initTape, show j ≠ 0 from by omega] + obtain ⟨hinp0, hinp_ns, hinp_h_bound, hwf, hwork_heads, hout0, hout_ns, hout_h⟩ := henv + obtain ⟨c', hreach, hhalt, hsim0', hones, hinput, hblank, hdesc', hstate', + hwf', hheads, hsim_hd, hsc_hd⟩ := + setupSim_full_execution x inp work out hsim0 hsim_blank hsim_head hsc_bools hsc_head + (by omega) hinp_ns hinp_blank hinp_x hinp_end (by omega) hout_ns hwf + (by have := hwork_heads utmDescTape; omega) (by have := hwork_heads utmStateTape; omega) + -- HoareTime: ∃ c' t, t ≤ bound ∧ reachesIn t start c' ∧ halted c' ∧ post + refine ⟨c', setupSimBound n x.length, le_refl _, hreach, hhalt, ?_⟩ + -- Postcondition assembly + -- superCellsCorrect from cell values + have hsc := superCellsCorrect_from_cells tm x (c'.work utmSimTape) hsim0' hones hinput hblank + -- desc/state preserved (hdesc' and hstate' are tape equalities from setupSim_full_execution) + have hdesc_post : descOnTape (TMEncoding.encodeTM tm) (c'.work utmDescTape) := hdesc' ▸ hdesc + have hstate_post : stateOnTapeAt k (e tm.qstart) (c'.work utmStateTape) := hstate' ▸ hstate + -- InitEnvelope for halted config + -- setupSimTM preserves input cells and output entirely (only work tapes change) + -- We need to add input/output preservation to setupSim_full_execution, or derive here. + -- For now: output is fully idle-preserved, input cells preserved but head advanced. + -- We add these to setupSim_full_execution's postcondition. + obtain ⟨hsc_hd_bound, hinp_cells_eq, hinp_hd_ge, hout_eq⟩ := hsc_hd + have henv' : InitEnvelope c'.input c'.work c'.output := + ⟨by rw [hinp_cells_eq]; exact hinp0, + by intro j hj; rw [hinp_cells_eq]; exact hinp_ns j hj, + hinp_hd_ge, hwf', hheads, + by rw [hout_eq]; exact hout0, + by intro j hj; rw [hout_eq]; exact hout_ns j hj, + by rw [hout_eq]; exact hout_h⟩ + exact ⟨henv', hdesc_post, hstate_post, hsc, + by rw [hdesc']; exact hdesc_head_bound, + by rw [hstate']; exact hstate_head_bound, + hsim_hd, hsc_hd_bound⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupState.lean b/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupState.lean new file mode 100644 index 0000000..aa25a6a --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/InitInternal/SetupState.lean @@ -0,0 +1,1954 @@ +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Complexitylib.Models.TuringMachine.UTM.InitInternal.Rewind + +/-! +# Init proof internals: setupStateTM + +Step-by-step simulation lemmas and HoareTime proof for `setupStateTM`. +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem ss_readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem ss_tape_move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +private theorem ss_tape_read_ne_start_of_wf (t : Tape) (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns _ hh + +private theorem initTape_nil_cell_ge1 {j : ℕ} (hj : j ≥ 1) : + (initTape ([] : List Γ)).cells j = Γ.blank := by + simp [initTape, Nat.ne_of_gt (by omega : j > 0)] + +private theorem initTape_nil_cell_0 : + (initTape ([] : List Γ)).cells 0 = Γ.start := by simp [initTape] + +-- ════════════════════════════════════════════════════════════════════════ +-- encodeTM desc tape cell access +-- ════════════════════════════════════════════════════════════════════════ + +theorem encodeTM_length_ge (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) : + (TMEncoding.encodeTM tm).length ≥ 3 * k + n + 4 := by + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.length_append, List.length_replicate, List.length_singleton, + List.length_map, List.length_finRange] + omega + +theorem tapeStoresBools_cell {bits : List Bool} {t : Tape} + (h : tapeStoresBools bits t) {i : ℕ} (hi : i < bits.length) : + t.cells (i + 1) = Γ.ofBool bits[i] := h.2.1 i hi + +theorem desc_ones_cells (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) + {t : Tape} (hdesc : descOnTape (TMEncoding.encodeTM tm) t) + (j : ℕ) (hj : j < k) : + t.cells (j + 1) = Γ.one := by + have hlen : j < (TMEncoding.encodeTM tm).length := by + have := encodeTM_length_ge tm hk; omega + rw [tapeStoresBools_cell hdesc hlen] + suffices h : (TMEncoding.encodeTM tm)[j] = true by rw [h]; rfl + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.append_assoc] + rw [List.getElem_append_left (show j < (List.replicate _ true).length by simp; omega)] + exact List.getElem_replicate _ + +theorem desc_sep_k_cell (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) + {t : Tape} (hdesc : descOnTape (TMEncoding.encodeTM tm) t) : + t.cells (k + 1) = Γ.zero := by + have hlen : k < (TMEncoding.encodeTM tm).length := by + have := encodeTM_length_ge tm hk; omega + rw [tapeStoresBools_cell hdesc hlen] + suffices h : (TMEncoding.encodeTM tm)[k] = false by rw [h]; rfl + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.append_assoc] + rw [List.getElem_append_right (show (List.replicate _ true).length ≤ k by simp; omega)] + simp [hk] + +theorem desc_n_ones_cells (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) + {t : Tape} (hdesc : descOnTape (TMEncoding.encodeTM tm) t) + (j : ℕ) (hj : j < n) : + t.cells (k + 2 + j) = Γ.one := by + have hlen : k + 1 + j < (TMEncoding.encodeTM tm).length := by + have := encodeTM_length_ge tm hk; omega + rw [show k + 2 + j = (k + 1 + j) + 1 from by omega, tapeStoresBools_cell hdesc hlen] + suffices h : (TMEncoding.encodeTM tm)[k + 1 + j] = true by rw [h]; rfl + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.append_assoc] + rw [List.getElem_append_right (show (List.replicate _ true).length ≤ k + 1 + j by simp; omega)] + have h1 : k + 1 + j - @Fintype.card tm.Q tm.finQ = j + 1 := by omega + simp only [h1, List.singleton_append, List.getElem_cons_succ, + List.getElem_append_left, List.getElem_replicate, + List.length_replicate, hj] + +theorem desc_sep_kn_cell (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) + {t : Tape} (hdesc : descOnTape (TMEncoding.encodeTM tm) t) : + t.cells (k + 2 + n) = Γ.zero := by + have hlen : k + 1 + n < (TMEncoding.encodeTM tm).length := by + have := encodeTM_length_ge tm hk; omega + rw [show k + 2 + n = (k + 1 + n) + 1 from by omega, tapeStoresBools_cell hdesc hlen] + suffices h : (TMEncoding.encodeTM tm)[k + 1 + n] = false by rw [h]; rfl + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.append_assoc] + rw [List.getElem_append_right (show (List.replicate _ true).length ≤ k + 1 + n by simp; omega)] + have h1 : k + 1 + n - @Fintype.card tm.Q tm.finQ = n + 1 := by omega + simp only [h1, List.singleton_append, List.getElem_cons_succ, + List.getElem_append_right, List.length_replicate, le_refl, + Nat.sub_self, List.getElem_cons_zero] + +theorem desc_qstart_cells (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) + {t : Tape} (hdesc : descOnTape (TMEncoding.encodeTM tm) t) + (j : ℕ) (hj : j < k) : + t.cells (2 * k + 4 + n + j) = + Γ.ofBool ((⟨j, by omega⟩ : Fin k) == (hk ▸ tm.stateEquiv tm.qstart)) := by + have hlen : 2 * k + 3 + n + j < (TMEncoding.encodeTM tm).length := by + have := encodeTM_length_ge tm hk; omega + rw [show 2 * k + 4 + n + j = (2 * k + 3 + n + j) + 1 from by omega, + tapeStoresBools_cell hdesc hlen] + congr 1 + unfold TMEncoding.encodeTM TMEncoding.encodeStateOneHot TM.stateEquiv + simp only [List.append_assoc] + rw [List.getElem_append_right (show (List.replicate _ true).length ≤ 2 * k + 3 + n + j by simp; omega)] + have h1 : 2 * k + 3 + n + j - + (List.replicate (@Fintype.card tm.Q tm.finQ) true).length = (k + 2 + n + j) + 1 := by + simp; omega + simp only [h1, List.singleton_append, List.getElem_cons_succ] + rw [List.getElem_append_right (show (List.replicate n true).length ≤ k + 2 + n + j by simp; omega)] + have h3 : k + 2 + n + j - (List.replicate n true).length = k + 2 + j := by simp; omega + simp only [h3] + have h4 : k + 2 + j = (k + 1 + j) + 1 := by omega + simp only [h4, List.getElem_cons_succ] + have hqhalt_len : + (List.map (fun i => i == (Fintype.equivFin tm.Q) tm.qhalt) + (List.finRange (@Fintype.card tm.Q tm.finQ))).length = k := by + simp [List.length_map, List.length_finRange, hk] + rw [List.getElem_append_right (by omega)] + have h5 : k + 1 + j - + (List.map (fun i => i == (Fintype.equivFin tm.Q) tm.qhalt) + (List.finRange (@Fintype.card tm.Q tm.finQ))).length = j + 1 := by + rw [hqhalt_len]; omega + simp only [h5, List.getElem_cons_succ] + rw [List.getElem_append_left (by + simp [List.length_map, List.length_finRange]; omega)] + simp only [List.getElem_map, List.getElem_finRange] + subst hk + simp + +-- ════════════════════════════════════════════════════════════════════════ +-- Idle-tape preservation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Idle tape: writeAndMove with blank and idleDir preserves a tape with + head ≥ 1 and cells matching initTape (all blank for j ≥ 1). -/ +private theorem idle_tape_initTape {t : Tape} (hh : t.head ≥ 1) + (hc : t.cells = (initTape ([] : List Γ)).cells) : + t.writeAndMove (Γw.blank : Γw) (idleDir t.read) = t := by + have hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start := by + intro j hj; rw [hc]; intro h; simp [initTape, show j ≠ 0 from by omega] at h + have hread : t.read ≠ Γ.start := by simp [Tape.read]; exact hns _ hh + simp only [Tape.writeAndMove, idleDir, hread, ↓reduceIte, Tape.move, + Tape.write, show t.head ≠ 0 from by omega] + show { head := t.head, cells := Function.update t.cells t.head Γ.blank } = t + have : Function.update t.cells t.head Γ.blank = t.cells := by + ext j; simp only [Function.update] + split + · next h => subst h; rw [hc]; exact (initTape_nil_cell_ge1 hh).symm + · rfl + simp [this] + +/-- Idle tape for output/non-initTape tapes: writeAndMove blank+stay + when head ≥ 1, read ≠ ▷. Output may not be initTape but we + just need cells j ≠ ▷ preserved and head unchanged. -/ +private theorem idle_tape_wf {t : Tape} (hh : t.head ≥ 1) + (hc0 : t.cells 0 = Γ.start) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + (t.writeAndMove (Γw.blank : Γw) (idleDir t.read)).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → (t.writeAndMove (Γw.blank : Γw) (idleDir t.read)).cells j ≠ Γ.start) ∧ + (t.writeAndMove (Γw.blank : Γw) (idleDir t.read)).head = t.head := by + have hread : t.read ≠ Γ.start := by simp [Tape.read]; exact hns _ hh + simp only [Tape.writeAndMove, idleDir, hread, ↓reduceIte, Tape.move, + Tape.write, show t.head ≠ 0 from by omega] + refine ⟨?_, ?_, ?_⟩ + · simp only [Function.update, show (0 : ℕ) ≠ t.head from by omega]; exact hc0 + · intro j hj + simp only [Function.update] + split + · next h => subst h; show Γ.blank ≠ Γ.start; exact Γ.noConfusion + · exact hns j hj + · trivial + +/-- Input tape idle: move with idleDir preserves everything. -/ +private theorem idle_input {t : Tape} (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + t.move (idleDir t.read) = t := by + have hread : t.read ≠ Γ.start := by simp [Tape.read]; exact hns _ hh + simp [idleDir, hread, Tape.move] + +-- ════════════════════════════════════════════════════════════════════════ +-- WriteAndMove helpers for active tapes +-- ════════════════════════════════════════════════════════════════════════ + +private theorem writeAndMove_right_head {t : Tape} {w : Γw} : + (t.writeAndMove w Dir3.right).head = t.head + 1 := by + simp [Tape.writeAndMove, Tape.write]; split <;> simp [Tape.move] + +private theorem writeAndMove_left_head {t : Tape} {w : Γw} : + (t.writeAndMove w Dir3.left).head = t.head - 1 := by + simp [Tape.writeAndMove, Tape.write]; split <;> simp [Tape.move] + +private theorem writeAndMove_stay_head {t : Tape} {w : Γw} : + (t.writeAndMove w Dir3.stay).head = t.head := by + simp [Tape.writeAndMove, Tape.write]; split <;> rfl + +private theorem writeAndMove_cells_at_head {t : Tape} {w : Γw} {d : Dir3} + (hh : t.head ≠ 0) : + (t.writeAndMove w d).cells t.head = w.toΓ := by + simp only [Tape.writeAndMove, ss_tape_move_cells, Tape.write, hh, ↓reduceIte, + Function.update_self] + +private theorem writeAndMove_cells_ne {t : Tape} {w : Γw} {d : Dir3} {j : ℕ} + (hj : j ≠ t.head) : + (t.writeAndMove w d).cells j = t.cells j := by + simp only [Tape.writeAndMove, ss_tape_move_cells, Tape.write] + split + · rfl + · simp only [Function.update]; split + · next h => exact absurd h hj + · rfl + +private theorem writeAndMove_cells_0 {t : Tape} {w : Γw} {d : Dir3} + (hh : t.head ≠ 0) : + (t.writeAndMove w d).cells 0 = t.cells 0 := by + exact writeAndMove_cells_ne (Ne.symm hh) + +/-- readBackWrite preserves cells regardless of direction. -/ +private theorem readBackWrite_cells {t : Tape} {d : Dir3} + (hh : t.head ≥ 1) (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + (t.writeAndMove (readBackWrite t.read) d).cells = t.cells := by + have hread : t.read ≠ Γ.start := by simp [Tape.read]; exact hns _ hh + ext j + simp only [Tape.writeAndMove, ss_tape_move_cells, Tape.write, + show t.head ≠ 0 from by omega, ↓reduceIte] + simp only [Function.update] + split + · next h => subst h; exact ss_readBackWrite_toΓ_eq hread + · rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: skipK loop — copy k ones from desc to state, then separator +-- ════════════════════════════════════════════════════════════════════════ + +/-- Phase 1 loop: from skipK state with `copied` ones already processed, + process `rem` more ones and then the separator, reaching copyN. + Desc head at copied+1, state head at copied+1. -/ +private theorem skipK_loop (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) : + ∀ (rem : ℕ) (c : Cfg 4 setupStateTM.Q), + c.state = .skipK → + (c.work utmDescTape).head + rem = k + 1 → + (c.work utmDescTape).cells = (w₀ : Tape).cells → + descOnTape (TMEncoding.encodeTM tm) ⟨0, w₀.cells⟩ → + (c.work utmDescTape).head ≥ 1 → + (c.work utmStateTape).head = (c.work utmDescTape).head → + (c.work utmStateTape).cells 0 = Γ.start → + (∀ j, 1 ≤ j → j < (c.work utmDescTape).head → (c.work utmStateTape).cells j = Γ.one) → + (∀ j, j ≥ (c.work utmDescTape).head → (c.work utmStateTape).cells j = (initTape []).cells j) → + (c.work utmSimTape).cells = (initTape []).cells → (c.work utmSimTape).head ≥ 1 → + (c.work utmScratchTape).cells = (initTape []).cells → (c.work utmScratchTape).head = 1 → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → c.input.cells 0 = Γ.start → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → c.output.cells 0 = Γ.start → + (∀ i, (c.work i).cells 0 = Γ.start) → + (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', setupStateTM.reachesIn (rem + 1) c c' ∧ + c'.state = .copyN ∧ + (c'.work utmDescTape).cells = w₀.cells ∧ + (c'.work utmDescTape).head = k + 2 ∧ + (c'.work utmStateTape).head = k + 1 ∧ + (∀ j, j < k → (c'.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c'.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c'.work utmStateTape).cells 0 = Γ.start ∧ + (c'.work utmSimTape).cells = (initTape []).cells ∧ (c'.work utmSimTape).head ≥ 1 ∧ + (c'.work utmScratchTape).cells = (initTape []).cells ∧ (c'.work utmScratchTape).head = 1 ∧ + c'.input.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.input.cells j ≠ Γ.start) ∧ c'.input.cells 0 = Γ.start ∧ + c'.output.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ c'.output.cells 0 = Γ.start ∧ + WorkTapesWF c'.work := by + intro rem + induction rem with + | zero => + intro c hstate hhead_rem hcells hdesc hhead_ge hst_head hst_0 hst_ones hst_tail + hsim_c hsim_h hsc_c hsc_h hinp_h hinp_ns hinp_0 hout_h hout_ns hout_0 hwf0 hwf1 + have hdesc_head : (c.work utmDescTape).head = k + 1 := by omega + have hread : (c.work utmDescTape).read = Γ.zero := by + simp only [Tape.read, hdesc_head, hcells]; exact desc_sep_k_cell tm hk hdesc + have hread_ne_one : (fun i => (c.work i).read) (0 : Fin 4) ≠ Γ.one := by + show (c.work utmDescTape).read ≠ Γ.one; rw [hread]; decide + simp only [show (0 + 1 : ℕ) = 1 from rfl] + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.skipK ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers + have hst_head_val : (c.work utmStateTape).head = k + 1 := by rw [hst_head, hdesc_head] + have hst_ne : (c.work utmStateTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + have hst_idle : (c.work utmStateTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmStateTape).read) = c.work utmStateTape := by + simp only [Tape.writeAndMove, idleDir, hst_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmStateTape).head ≠ 0 from by omega] + have : Function.update (c.work utmStateTape).cells + (c.work utmStateTape).head Γw.blank.toΓ = (c.work utmStateTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmStateTape).cells (c.work utmStateTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hst_head_val, hst_tail (k + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hsc_idle := idle_tape_initTape (by omega) hsc_c + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Build explicit step config (skipK else → copyN) + let c₁ : Cfg 4 setupStateTM.Q := + { state := .copyN + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.skipK : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_ne_one] + show some _ = some c₁; congr 1 + -- Unfold c₁ work tapes for each index + have hw_desc : c₁.work utmDescTape = + (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right := by + simp only [c₁, show (utmDescTape : Fin 4).val = 0 from rfl, ↓reduceIte] + have hw_st : c₁.work utmStateTape = + (c.work utmStateTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmStateTape).read) := by + simp only [c₁, show ((utmStateTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sim : c₁.work utmSimTape = + (c.work utmSimTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmSimTape).read) := by + simp only [c₁, show ((utmSimTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sc : c₁.work utmScratchTape = + (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmScratchTape).read) := by + simp only [c₁, show ((utmScratchTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + refine ⟨c₁, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc cells + rw [hw_desc, readBackWrite_cells hhead_ge (hwf1 utmDescTape)]; exact hcells + · -- desc head = k + 2 + rw [hw_desc, writeAndMove_right_head]; omega + · -- state head = k + 1 + rw [hw_st, hst_idle]; exact hst_head_val + · -- state ones + intro j hj; rw [hw_st, hst_idle]; exact hst_ones (j + 1) (by omega) (by omega) + · -- state tail + intro j hj; rw [hw_st, hst_idle]; exact hst_tail j (by omega) + · -- state cells 0 + rw [hw_st, hst_idle]; exact hst_0 + · -- sim cells + rw [hw_sim, hsim_idle]; exact hsim_c + · -- sim head + rw [hw_sim, hsim_idle]; exact hsim_h + · -- scratch cells + rw [hw_sc, hsc_idle]; exact hsc_c + · -- scratch head + rw [hw_sc, hsc_idle]; exact hsc_h + · -- input head + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_h + · -- input cells ns + intro j hj + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_ns j hj + · -- input cells 0 + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_0 + · -- output head + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + rw [hout_h']; exact hout_h + · -- output cells ns + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_ns' + · -- output cells 0 + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_0' + · -- WorkTapesWF + exact ⟨ + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [hw_desc, writeAndMove_cells_0 (by omega)]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [hw_st, hst_idle]; exact hwf0 utmStateTape + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [hw_sim, hsim_idle]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [hw_sc, hsc_idle]; exact hwf0 utmScratchTape, + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [hw_desc, readBackWrite_cells hhead_ge (hwf1 utmDescTape)]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [hw_st, hst_idle]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [hw_sim, hsim_idle]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [hw_sc, hsc_idle]; exact hwf1 utmScratchTape j hj⟩ + | succ rem' ih => + intro c hstate hhead_rem hcells hdesc hhead_ge hst_head hst_0 hst_ones hst_tail + hsim_c hsim_h hsc_c hsc_h hinp_h hinp_ns hinp_0 hout_h hout_ns hout_0 hwf0 hwf1 + -- Desc reads one + have hread_one : (c.work utmDescTape).read = Γ.one := by + simp only [Tape.read, hcells] + have := desc_ones_cells tm hk hdesc ((c.work utmDescTape).head - 1) (by omega) + rwa [show (c.work utmDescTape).head - 1 + 1 = (c.work utmDescTape).head from by omega] at this + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = Γ.one := hread_one + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.skipK ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers + have hst_ne : (c.work utmStateTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hsc_idle := idle_tape_initTape (by omega) hsc_c + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Step: skipK with one → stay skipK, desc+state right, state writes one + let c₁ : Cfg 4 setupStateTM.Q := { + state := .skipK + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite Γ.one + else if (i : Fin 4).val = 1 then Γw.one else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else if (i : Fin 4).val = 1 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + simp only [TM.step, hstate, ↓reduceIte, setupStateTM, hread_eq]; rfl + -- c₁ desc tape + have h1_desc_cells : (c₁.work utmDescTape).cells = w₀.cells := by + show ((c.work utmDescTape).writeAndMove + (readBackWrite Γ.one : Γw) Dir3.right).cells = _ + rw [← hread_one, readBackWrite_cells hhead_ge (hwf1 utmDescTape)]; exact hcells + have h1_desc_head : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + show ((c.work utmDescTape).writeAndMove _ Dir3.right).head = _ + exact writeAndMove_right_head + -- c₁ state tape + have h1_st_head : (c₁.work utmStateTape).head = (c.work utmStateTape).head + 1 := by + show ((c.work utmStateTape).writeAndMove (Γw.one : Γw) Dir3.right).head = _ + exact writeAndMove_right_head + have h1_st_cells_0 : (c₁.work utmStateTape).cells 0 = Γ.start := by + show ((c.work utmStateTape).writeAndMove (Γw.one : Γw) Dir3.right).cells 0 = _ + rw [writeAndMove_cells_0 (by omega)]; exact hst_0 + have h1_st_ones : ∀ j, 1 ≤ j → j < (c₁.work utmDescTape).head → + (c₁.work utmStateTape).cells j = Γ.one := by + intro j hj1 hj2 + show ((c.work utmStateTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j = Γ.one + rw [h1_desc_head] at hj2 + by_cases hje : j = (c.work utmStateTape).head + · subst hje; rw [writeAndMove_cells_at_head (by omega)]; rfl + · rw [writeAndMove_cells_ne hje]; exact hst_ones j hj1 (by rw [← hst_head] at hj2; omega) + have h1_st_tail : ∀ j, j ≥ (c₁.work utmDescTape).head → + (c₁.work utmStateTape).cells j = (initTape []).cells j := by + intro j hj + show ((c.work utmStateTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j = _ + rw [h1_desc_head] at hj + rw [writeAndMove_cells_ne (by rw [hst_head]; omega)] + exact hst_tail j (by omega) + -- c₁ sim/scratch idle + have h1_sim : c₁.work utmSimTape = c.work utmSimTape := by + show (c.work utmSimTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmSimTape).read) = _ + exact hsim_idle + have h1_sc : c₁.work utmScratchTape = c.work utmScratchTape := by + show (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = _ + exact hsc_idle + have h1_inp : c₁.input = c.input := hinp_idle + -- WorkTapesWF for c₁ + have h1_wf0 : ∀ i, (c₁.work i).cells 0 = Γ.start := + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; exact h1_st_cells_0 + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [h1_sim]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [h1_sc]; exact hwf0 utmScratchTape + have h1_wf1 : ∀ i j, j ≥ 1 → (c₁.work i).cells j ≠ Γ.start := + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by + change (c₁.work utmStateTape).cells j ≠ Γ.start + show ((c.work utmStateTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j ≠ Γ.start + by_cases hje : j = (c.work utmStateTape).head + · subst hje; rw [writeAndMove_cells_at_head (by omega)]; decide + · rw [writeAndMove_cells_ne hje]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [h1_sim]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [h1_sc]; exact hwf1 utmScratchTape j hj + -- Apply IH + obtain ⟨c_f, hreach, hprops⟩ := ih c₁ rfl + (by rw [h1_desc_head]; omega) + h1_desc_cells hdesc + (by rw [h1_desc_head]; omega) + (by rw [h1_st_head, hst_head, h1_desc_head]) + h1_st_cells_0 h1_st_ones h1_st_tail + (by rw [h1_sim]; exact hsim_c) + (by rw [h1_sim]; exact hsim_h) + (by rw [h1_sc]; exact hsc_c) + (by rw [h1_sc]; exact hsc_h) + (by rw [h1_inp]; exact hinp_h) + (fun j hj => by rw [h1_inp]; exact hinp_ns j hj) + (by rw [h1_inp]; exact hinp_0) + (by rw [hout_h']; exact hout_h) + hout_ns' hout_0' + h1_wf0 h1_wf1 + exact ⟨c_f, .step hstep hreach, hprops⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: copyN loop — copy n ones from desc to scratch, then separator +-- ════════════════════════════════════════════════════════════════════════ + +private theorem copyN_loop (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) : + ∀ (rem : ℕ) (c : Cfg 4 setupStateTM.Q), + c.state = .copyN → + (c.work utmDescTape).head + rem = k + n + 2 → + (c.work utmDescTape).cells = (w₀ : Tape).cells → + descOnTape (TMEncoding.encodeTM tm) ⟨0, w₀.cells⟩ → + (c.work utmDescTape).head ≥ k + 2 → + -- state tape: already has k ones, head at k+1, unchanged during this phase + (c.work utmStateTape).head = k + 1 → + (∀ j, j < k → (c.work utmStateTape).cells (j + 1) = Γ.one) → + (∀ j, j ≥ k + 1 → (c.work utmStateTape).cells j = (initTape []).cells j) → + (c.work utmStateTape).cells 0 = Γ.start → + -- scratch tape: head at copied+1 where copied = desc_head - (k+2) + (c.work utmScratchTape).head = (c.work utmDescTape).head - (k + 1) → + (c.work utmScratchTape).cells 0 = Γ.start → + (∀ j, 1 ≤ j → j < (c.work utmScratchTape).head → (c.work utmScratchTape).cells j = Γ.one) → + (∀ j, j ≥ (c.work utmScratchTape).head → (c.work utmScratchTape).cells j = (initTape []).cells j) → + (c.work utmSimTape).cells = (initTape []).cells → (c.work utmSimTape).head ≥ 1 → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → c.input.cells 0 = Γ.start → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → c.output.cells 0 = Γ.start → + (∀ i, (c.work i).cells 0 = Γ.start) → + (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', setupStateTM.reachesIn (rem + 1) c c' ∧ + c'.state = .skipQhalt ∧ + (c'.work utmDescTape).cells = w₀.cells ∧ + (c'.work utmDescTape).head = k + n + 3 ∧ + (c'.work utmStateTape).head = k + 1 ∧ + (∀ j, j < k → (c'.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c'.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c'.work utmStateTape).cells 0 = Γ.start ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c'.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c'.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c'.work utmScratchTape).cells 0 = Γ.start ∧ + (c'.work utmSimTape).cells = (initTape []).cells ∧ (c'.work utmSimTape).head ≥ 1 ∧ + c'.input.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.input.cells j ≠ Γ.start) ∧ c'.input.cells 0 = Γ.start ∧ + c'.output.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ c'.output.cells 0 = Γ.start ∧ + WorkTapesWF c'.work := by + intro rem + induction rem with + | zero => + intro c hstate hhead_rem hcells hdesc hhead_ge hst_head hst_ones hst_tail hst_0 + hsc_head hsc_0 hsc_ones hsc_tail hsim_c hsim_h hinp_h hinp_ns hinp_0 + hout_h hout_ns hout_0 hwf0 hwf1 + have hdesc_head : (c.work utmDescTape).head = k + n + 2 := by omega + have hsc_head_val : (c.work utmScratchTape).head = n + 1 := by + rw [hsc_head, hdesc_head]; omega + have hread : (c.work utmDescTape).read = Γ.zero := by + simp only [Tape.read, hdesc_head, hcells] + have := desc_sep_kn_cell tm hk hdesc + rwa [show k + 2 + n = k + n + 2 from by omega] at this + have hread_ne_one : (fun i => (c.work i).read) (0 : Fin 4) ≠ Γ.one := by + show (c.work utmDescTape).read ≠ Γ.one; rw [hread]; decide + simp only [show (0 + 1 : ℕ) = 1 from rfl] + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.copyN ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers + have hst_ne : (c.work utmStateTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + have hst_idle : (c.work utmStateTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmStateTape).read) = c.work utmStateTape := by + simp only [Tape.writeAndMove, idleDir, hst_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmStateTape).head ≠ 0 from by omega] + have : Function.update (c.work utmStateTape).cells + (c.work utmStateTape).head Γw.blank.toΓ = (c.work utmStateTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmStateTape).cells (c.work utmStateTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hst_head, hst_tail (k + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsc_ne : (c.work utmScratchTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmScratchTape) + have hsc_idle : (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = c.work utmScratchTape := by + simp only [Tape.writeAndMove, idleDir, hsc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmScratchTape).head ≠ 0 from by omega] + have : Function.update (c.work utmScratchTape).cells + (c.work utmScratchTape).head Γw.blank.toΓ = (c.work utmScratchTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmScratchTape).cells (c.work utmScratchTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hsc_head_val, hsc_tail (n + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Build explicit step config (copyN else → skipQhalt) + let c₁ : Cfg 4 setupStateTM.Q := + { state := .skipQhalt + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.copyN : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_ne_one] + show some _ = some c₁; congr 1 + -- Unfold c₁ work tapes for each index + have hw_desc : c₁.work utmDescTape = + (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right := by + simp only [c₁, show (utmDescTape : Fin 4).val = 0 from rfl, ↓reduceIte] + have hw_st : c₁.work utmStateTape = + (c.work utmStateTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmStateTape).read) := by + simp only [c₁, show ((utmStateTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sim : c₁.work utmSimTape = + (c.work utmSimTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmSimTape).read) := by + simp only [c₁, show ((utmSimTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sc : c₁.work utmScratchTape = + (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmScratchTape).read) := by + simp only [c₁, show ((utmScratchTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + refine ⟨c₁, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc cells + rw [hw_desc, readBackWrite_cells (by omega) (hwf1 utmDescTape)]; exact hcells + · -- desc head = k + n + 3 + rw [hw_desc, writeAndMove_right_head]; omega + · -- state head = k + 1 + rw [hw_st, hst_idle]; exact hst_head + · -- state ones + intro j hj; rw [hw_st, hst_idle]; exact hst_ones j hj + · -- state tail + intro j hj; rw [hw_st, hst_idle]; exact hst_tail j hj + · -- state cells 0 + rw [hw_st, hst_idle]; exact hst_0 + · -- scratch head = n + 1 + rw [hw_sc, hsc_idle]; exact hsc_head_val + · -- scratch ones + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_ones (j + 1) (by omega) (by omega) + · -- scratch tail + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_tail j (by omega) + · -- scratch cells 0 + rw [hw_sc, hsc_idle]; exact hsc_0 + · -- sim cells + rw [hw_sim, hsim_idle]; exact hsim_c + · -- sim head + rw [hw_sim, hsim_idle]; exact hsim_h + · -- input head + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_h + · -- input cells ns + intro j hj + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_ns j hj + · -- input cells 0 + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_0 + · -- output head + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + rw [hout_h']; exact hout_h + · -- output cells ns + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_ns' + · -- output cells 0 + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_0' + · -- WorkTapesWF + exact ⟨ + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [hw_desc, writeAndMove_cells_0 (by omega)]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [hw_st, hst_idle]; exact hwf0 utmStateTape + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [hw_sim, hsim_idle]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [hw_sc, hsc_idle]; exact hwf0 utmScratchTape, + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [hw_desc, readBackWrite_cells (by omega) (hwf1 utmDescTape)]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [hw_st, hst_idle]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [hw_sim, hsim_idle]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [hw_sc, hsc_idle]; exact hwf1 utmScratchTape j hj⟩ + | succ rem' ih => + intro c hstate hhead_rem hcells hdesc hhead_ge hst_head hst_ones hst_tail hst_0 + hsc_head hsc_0 hsc_ones hsc_tail hsim_c hsim_h hinp_h hinp_ns hinp_0 + hout_h hout_ns hout_0 hwf0 hwf1 + -- Desc reads one + have hread_one : (c.work utmDescTape).read = Γ.one := by + simp only [Tape.read, hcells] + have := desc_n_ones_cells tm hk hdesc ((c.work utmDescTape).head - (k + 2)) (by omega) + rwa [show k + 2 + ((c.work utmDescTape).head - (k + 2)) = (c.work utmDescTape).head from by omega] at this + have hread_eq : (fun i => (c.work i).read) (0 : Fin 4) = Γ.one := hread_one + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.copyN ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers + have hst_ne : (c.work utmStateTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + have hst_idle : (c.work utmStateTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmStateTape).read) = c.work utmStateTape := by + simp only [Tape.writeAndMove, idleDir, hst_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmStateTape).head ≠ 0 from by omega] + have : Function.update (c.work utmStateTape).cells + (c.work utmStateTape).head Γw.blank.toΓ = (c.work utmStateTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmStateTape).cells (c.work utmStateTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hst_head, hst_tail (k + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Step: copyN with one → stay copyN, desc+scratch right, scratch writes one + let c₁ : Cfg 4 setupStateTM.Q := { + state := .copyN + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite Γ.one + else if (i : Fin 4).val = 3 then Γw.one else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else if (i : Fin 4).val = 3 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + simp only [TM.step, hstate, ↓reduceIte, setupStateTM, hread_eq]; rfl + -- c₁ desc tape + have h1_desc_cells : (c₁.work utmDescTape).cells = w₀.cells := by + show ((c.work utmDescTape).writeAndMove + (readBackWrite Γ.one : Γw) Dir3.right).cells = _ + rw [← hread_one, readBackWrite_cells (by omega) (hwf1 utmDescTape)]; exact hcells + have h1_desc_head : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + show ((c.work utmDescTape).writeAndMove _ Dir3.right).head = _ + exact writeAndMove_right_head + -- c₁ state tape (idle) + have h1_st : c₁.work utmStateTape = c.work utmStateTape := by + show (c.work utmStateTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmStateTape).read) = _ + exact hst_idle + -- c₁ scratch tape (active) + have h1_sc_head : (c₁.work utmScratchTape).head = (c.work utmScratchTape).head + 1 := by + show ((c.work utmScratchTape).writeAndMove (Γw.one : Γw) Dir3.right).head = _ + exact writeAndMove_right_head + have h1_sc_cells_0 : (c₁.work utmScratchTape).cells 0 = Γ.start := by + show ((c.work utmScratchTape).writeAndMove (Γw.one : Γw) Dir3.right).cells 0 = _ + rw [writeAndMove_cells_0 (by omega)]; exact hsc_0 + have h1_sc_ones : ∀ j, 1 ≤ j → j < (c₁.work utmScratchTape).head → + (c₁.work utmScratchTape).cells j = Γ.one := by + intro j hj1 hj2 + show ((c.work utmScratchTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j = Γ.one + rw [h1_sc_head] at hj2 + by_cases hje : j = (c.work utmScratchTape).head + · subst hje; rw [writeAndMove_cells_at_head (by omega)]; rfl + · rw [writeAndMove_cells_ne hje]; exact hsc_ones j hj1 (by omega) + have h1_sc_tail : ∀ j, j ≥ (c₁.work utmScratchTape).head → + (c₁.work utmScratchTape).cells j = (initTape []).cells j := by + intro j hj + show ((c.work utmScratchTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j = _ + rw [h1_sc_head] at hj + rw [writeAndMove_cells_ne (by omega)] + exact hsc_tail j (by omega) + -- c₁ sim idle + have h1_sim : c₁.work utmSimTape = c.work utmSimTape := by + show (c.work utmSimTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmSimTape).read) = _ + exact hsim_idle + have h1_inp : c₁.input = c.input := hinp_idle + -- WorkTapesWF for c₁ + have h1_wf0 : ∀ i, (c₁.work i).cells 0 = Γ.start := + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [h1_st]; exact hwf0 utmStateTape + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [h1_sim]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; exact h1_sc_cells_0 + have h1_wf1 : ∀ i j, j ≥ 1 → (c₁.work i).cells j ≠ Γ.start := + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [h1_st]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [h1_sim]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by + change (c₁.work utmScratchTape).cells j ≠ Γ.start + show ((c.work utmScratchTape).writeAndMove (Γw.one : Γw) Dir3.right).cells j ≠ Γ.start + by_cases hje : j = (c.work utmScratchTape).head + · subst hje; rw [writeAndMove_cells_at_head (by omega)]; decide + · rw [writeAndMove_cells_ne hje]; exact hwf1 utmScratchTape j hj + -- Apply IH + obtain ⟨c_f, hreach, hprops⟩ := ih c₁ rfl + (by rw [h1_desc_head]; omega) + h1_desc_cells hdesc + (by rw [h1_desc_head]; omega) + (by rw [h1_st]; exact hst_head) + (by intro j hj; rw [h1_st]; exact hst_ones j hj) + (by intro j hj; rw [h1_st]; exact hst_tail j hj) + (by rw [h1_st]; exact hst_0) + (by rw [h1_sc_head, hsc_head, h1_desc_head]; omega) + h1_sc_cells_0 h1_sc_ones h1_sc_tail + (by rw [h1_sim]; exact hsim_c) + (by rw [h1_sim]; exact hsim_h) + (by rw [h1_inp]; exact hinp_h) + (fun j hj => by rw [h1_inp]; exact hinp_ns j hj) + (by rw [h1_inp]; exact hinp_0) + (by rw [hout_h']; exact hout_h) + hout_ns' hout_0' + h1_wf0 h1_wf1 + exact ⟨c_f, .step hstep hreach, hprops⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 3: skipQhalt loop — rewind state tape using desc as counter +-- ════════════════════════════════════════════════════════════════════════ + +private theorem skipQhalt_loop (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) : + ∀ (rem : ℕ) (c : Cfg 4 setupStateTM.Q), + c.state = .skipQhalt → + rem = (c.work utmStateTape).head + 1 → + (c.work utmDescTape).cells = (w₀ : Tape).cells → + descOnTape (TMEncoding.encodeTM tm) ⟨0, w₀.cells⟩ → + (c.work utmDescTape).head ≥ k + n + 3 → + (c.work utmDescTape).head + (c.work utmStateTape).head = k + n + 3 + k + 1 → + (c.work utmStateTape).cells 0 = Γ.start → + (∀ j, j < k → (c.work utmStateTape).cells (j + 1) = Γ.one) → + (∀ j, j ≥ k + 1 → (c.work utmStateTape).cells j = (initTape []).cells j) → + (c.work utmScratchTape).head = n + 1 → + (∀ j, j < n → (c.work utmScratchTape).cells (j + 1) = Γ.one) → + (∀ j, j ≥ n + 1 → (c.work utmScratchTape).cells j = (initTape []).cells j) → + (c.work utmScratchTape).cells 0 = Γ.start → + (c.work utmSimTape).cells = (initTape []).cells → (c.work utmSimTape).head ≥ 1 → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → c.input.cells 0 = Γ.start → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → c.output.cells 0 = Γ.start → + (∀ i, (c.work i).cells 0 = Γ.start) → + (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', setupStateTM.reachesIn rem c c' ∧ + c'.state = .copyQstart ∧ + (c'.work utmDescTape).cells = w₀.cells ∧ + (c'.work utmDescTape).head = 2 * k + n + 4 ∧ + (c'.work utmStateTape).head = 1 ∧ + (∀ j, j < k → (c'.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c'.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c'.work utmStateTape).cells 0 = Γ.start ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c'.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c'.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c'.work utmScratchTape).cells 0 = Γ.start ∧ + (c'.work utmSimTape).cells = (initTape []).cells ∧ (c'.work utmSimTape).head ≥ 1 ∧ + c'.input.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.input.cells j ≠ Γ.start) ∧ c'.input.cells 0 = Γ.start ∧ + c'.output.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ c'.output.cells 0 = Γ.start ∧ + WorkTapesWF c'.work := by + intro rem + induction rem with + | zero => + intro c _ hrem + omega + | succ rem' ih => + intro c hstate hrem hcells hdesc hdesc_ge hdesc_st_sum hst_0 hst_ones hst_tail + hsc_h hsc_ones hsc_tail hsc_0 hsim_c hsim_h hinp_h hinp_ns hinp_0 + hout_h hout_ns hout_0 hwf0 hwf1 + have hst_head_eq : (c.work utmStateTape).head = rem' := by omega + cases rem' with + | zero => + -- BASE: state_head = 0, reads ▷, one step to .copyQstart + have hread_start : (fun i => (c.work i).read) (1 : Fin 4) = Γ.start := by + show (c.work utmStateTape).read = Γ.start + simp only [Tape.read, hst_head_eq]; exact hst_0 + have hdesc_head : (c.work utmDescTape).head = 2 * k + n + 4 := by omega + -- Idle tape helpers + have hdesc_ne : (c.work utmDescTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmDescTape) + have hdesc_idle : (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) + (idleDir (c.work utmDescTape).read) = c.work utmDescTape := by + simp only [Tape.writeAndMove, idleDir, hdesc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmDescTape).head ≠ 0 from by omega] + have : Function.update (c.work utmDescTape).cells + (c.work utmDescTape).head (readBackWrite (c.work utmDescTape).read).toΓ = + (c.work utmDescTape).cells := by + have hcb : (readBackWrite (c.work utmDescTape).read).toΓ = + (c.work utmDescTape).cells (c.work utmDescTape).head := by + rw [ss_readBackWrite_toΓ_eq hdesc_ne]; rfl + rw [hcb, Function.update_eq_self] + simp only [this] + have hsc_ne : (c.work utmScratchTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmScratchTape) + have hsc_idle : (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = c.work utmScratchTape := by + simp only [Tape.writeAndMove, idleDir, hsc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmScratchTape).head ≠ 0 from by omega] + have : Function.update (c.work utmScratchTape).cells + (c.work utmScratchTape).head Γw.blank.toΓ = (c.work utmScratchTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmScratchTape).cells (c.work utmScratchTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hsc_h, hsc_tail (n + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Build step config (skipQhalt with ▷ → copyQstart) + let c₁ : Cfg 4 setupStateTM.Q := { + state := .copyQstart + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 1 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.skipQhalt : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_start] + show some _ = some c₁; congr 1 + -- Unfold c₁ work tapes + have hw_desc : c₁.work utmDescTape = + (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) + (idleDir (c.work utmDescTape).read) := by + simp only [c₁, show ((utmDescTape : Fin 4).val = 0) = True from by decide, + show ((utmDescTape : Fin 4).val = 1) = False from by decide, ↓reduceIte] + have hw_st : c₁.work utmStateTape = + (c.work utmStateTape).writeAndMove (Γw.blank : Γw) Dir3.right := by + simp only [c₁, show ((utmStateTape : Fin 4).val = 0) = False from by decide, + show ((utmStateTape : Fin 4).val = 1) = True from by decide, ↓reduceIte] + have hw_sim : c₁.work utmSimTape = + (c.work utmSimTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmSimTape).read) := by + simp only [c₁, show ((utmSimTape : Fin 4).val = 0) = False from by decide, + show ((utmSimTape : Fin 4).val = 1) = False from by decide, ↓reduceIte] + have hw_sc : c₁.work utmScratchTape = + (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmScratchTape).read) := by + simp only [c₁, show ((utmScratchTape : Fin 4).val = 0) = False from by decide, + show ((utmScratchTape : Fin 4).val = 1) = False from by decide, ↓reduceIte] + -- State tape: write at head 0 is no-op, so cells preserved + have hst_cells : (c₁.work utmStateTape).cells = (c.work utmStateTape).cells := by + rw [hw_st] + simp only [Tape.writeAndMove, Tape.write, hst_head_eq, ↓reduceIte, ss_tape_move_cells] + refine ⟨c₁, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc cells + rw [hw_desc, hdesc_idle]; exact hcells + · -- desc head = 2 * k + n + 4 + rw [hw_desc, hdesc_idle]; exact hdesc_head + · -- state head = 1 + rw [hw_st, writeAndMove_right_head, hst_head_eq] + · -- state ones + intro j hj; rw [hst_cells]; exact hst_ones j hj + · -- state tail + intro j hj; rw [hst_cells]; exact hst_tail j hj + · -- state cells 0 + rw [hst_cells]; exact hst_0 + · -- scratch head + rw [hw_sc, hsc_idle]; exact hsc_h + · -- scratch ones + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_ones j hj + · -- scratch tail + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_tail j hj + · -- scratch cells 0 + rw [hw_sc, hsc_idle]; exact hsc_0 + · -- sim cells + rw [hw_sim, hsim_idle]; exact hsim_c + · -- sim head + rw [hw_sim, hsim_idle]; exact hsim_h + · -- input head + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_h + · -- input cells ns + intro j hj + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_ns j hj + · -- input cells 0 + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_0 + · -- output head + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + rw [hout_h']; exact hout_h + · -- output cells ns + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_ns' + · -- output cells 0 + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_0' + · -- WorkTapesWF + exact ⟨ + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [hw_desc, hdesc_idle]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [hst_cells]; exact hst_0 + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [hw_sim, hsim_idle]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [hw_sc, hsc_idle]; exact hwf0 utmScratchTape, + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [hw_desc, hdesc_idle]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [hst_cells]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [hw_sim, hsim_idle]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [hw_sc, hsc_idle]; exact hwf1 utmScratchTape j hj⟩ + | succ rem'' => + -- INDUCTIVE: state_head = rem'' + 1 > 0, one step then IH + have hread_ne_start : (fun i => (c.work i).read) (1 : Fin 4) ≠ Γ.start := by + show (c.work utmStateTape).read ≠ Γ.start + exact ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + -- Idle tape helpers + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hsc_ne : (c.work utmScratchTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmScratchTape) + have hsc_idle : (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = c.work utmScratchTape := by + simp only [Tape.writeAndMove, idleDir, hsc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmScratchTape).head ≠ 0 from by omega] + have : Function.update (c.work utmScratchTape).cells + (c.work utmScratchTape).head Γw.blank.toΓ = (c.work utmScratchTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmScratchTape).cells (c.work utmScratchTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hsc_h, hsc_tail (n + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Step: skipQhalt with ≠ ▷ → stay skipQhalt, desc right, state left + let c₁ : Cfg 4 setupStateTM.Q := { + state := .skipQhalt + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else if (i : Fin 4).val = 1 then readBackWrite (c.work (1 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else if (i : Fin 4).val = 1 then Dir3.left + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.skipQhalt : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_ne_start] + show some _ = some c₁; congr 1 + -- c₁ desc tape (readBackWrite + right) + have h1_desc_cells : (c₁.work utmDescTape).cells = w₀.cells := by + show ((c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells = _ + rw [readBackWrite_cells (by omega) (hwf1 utmDescTape)]; exact hcells + have h1_desc_head : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + show ((c.work utmDescTape).writeAndMove _ Dir3.right).head = _ + exact writeAndMove_right_head + -- c₁ state tape (readBackWrite + left) + have h1_st_cells : (c₁.work utmStateTape).cells = (c.work utmStateTape).cells := by + show ((c.work utmStateTape).writeAndMove + (readBackWrite (c.work utmStateTape).read : Γw) Dir3.left).cells = _ + rw [readBackWrite_cells (by omega) (hwf1 utmStateTape)] + have h1_st_head : (c₁.work utmStateTape).head = (c.work utmStateTape).head - 1 := by + show ((c.work utmStateTape).writeAndMove _ Dir3.left).head = _ + exact writeAndMove_left_head + -- c₁ sim idle + have h1_sim : c₁.work utmSimTape = c.work utmSimTape := by + show (c.work utmSimTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmSimTape).read) = _ + exact hsim_idle + -- c₁ scratch idle + have h1_sc : c₁.work utmScratchTape = c.work utmScratchTape := by + show (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = _ + exact hsc_idle + have h1_inp : c₁.input = c.input := hinp_idle + -- WorkTapesWF for c₁ + have h1_wf0 : ∀ i, (c₁.work i).cells 0 = Γ.start := + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [h1_st_cells]; exact hwf0 utmStateTape + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [h1_sim]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [h1_sc]; exact hwf0 utmScratchTape + have h1_wf1 : ∀ i j, j ≥ 1 → (c₁.work i).cells j ≠ Γ.start := + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [h1_st_cells]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [h1_sim]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [h1_sc]; exact hwf1 utmScratchTape j hj + -- Apply IH + obtain ⟨c_f, hreach, hprops⟩ := ih c₁ rfl + (by rw [h1_st_head, hst_head_eq]; rfl) + h1_desc_cells hdesc + (by rw [h1_desc_head]; omega) + (by rw [h1_desc_head, h1_st_head, hst_head_eq]; omega) + (by rw [h1_st_cells]; exact hst_0) + (by intro j hj; rw [h1_st_cells]; exact hst_ones j hj) + (by intro j hj; rw [h1_st_cells]; exact hst_tail j hj) + (by rw [h1_sc]; exact hsc_h) + (by intro j hj; rw [h1_sc]; exact hsc_ones j hj) + (by intro j hj; rw [h1_sc]; exact hsc_tail j hj) + (by rw [h1_sc]; exact hsc_0) + (by rw [h1_sim]; exact hsim_c) + (by rw [h1_sim]; exact hsim_h) + (by rw [h1_inp]; exact hinp_h) + (fun j hj => by rw [h1_inp]; exact hinp_ns j hj) + (by rw [h1_inp]; exact hinp_0) + (by rw [hout_h']; exact hout_h) + hout_ns' hout_0' + h1_wf0 h1_wf1 + exact ⟨c_f, .step hstep hreach, hprops⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 4: copyQstart loop — copy k desc bits to state, then sentinel +-- ════════════════════════════════════════════════════════════════════════ + +private theorem copyQstart_loop (tm : TM n) (hk : k = @Fintype.card tm.Q tm.finQ) : + ∀ (rem : ℕ) (c : Cfg 4 setupStateTM.Q), + c.state = .copyQstart → + (c.work utmDescTape).head + rem = 3 * k + n + 4 → + (c.work utmDescTape).cells = (w₀ : Tape).cells → + descOnTape (TMEncoding.encodeTM tm) ⟨0, w₀.cells⟩ → + (c.work utmDescTape).head ≥ 2 * k + n + 4 → + (c.work utmStateTape).head = (c.work utmDescTape).head - (2 * k + n + 3) → + (c.work utmStateTape).head ≤ k + 1 → + (c.work utmStateTape).cells 0 = Γ.start → + -- Cells 1..copied already have qstart bits, cells copied+1..k have ones (from Phase 1) + (∀ (j : ℕ) (hj : j < k), j + 1 < (c.work utmStateTape).head → + (c.work utmStateTape).cells (j + 1) = + Γ.ofBool ((⟨j, hj⟩ : Fin k) == (hk ▸ tm.stateEquiv tm.qstart))) → + (∀ j, (c.work utmStateTape).head - 1 ≤ j → j < k → + (c.work utmStateTape).cells (j + 1) = Γ.one) → + (∀ j, j ≥ k + 1 → (c.work utmStateTape).cells j = (initTape []).cells j) → + (c.work utmScratchTape).head = n + 1 → + (∀ j, j < n → (c.work utmScratchTape).cells (j + 1) = Γ.one) → + (∀ j, j ≥ n + 1 → (c.work utmScratchTape).cells j = (initTape []).cells j) → + (c.work utmScratchTape).cells 0 = Γ.start → + (c.work utmSimTape).cells = (initTape []).cells → (c.work utmSimTape).head ≥ 1 → + c.input.head ≥ 1 → (∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) → c.input.cells 0 = Γ.start → + c.output.head ≥ 1 → (∀ j, j ≥ 1 → c.output.cells j ≠ Γ.start) → c.output.cells 0 = Γ.start → + (∀ i, (c.work i).cells 0 = Γ.start) → + (∀ i j, j ≥ 1 → (c.work i).cells j ≠ Γ.start) → + ∃ c', setupStateTM.reachesIn (rem + 1) c c' ∧ + c'.state = .done ∧ + (c'.work utmDescTape).cells = w₀.cells ∧ + (c'.work utmDescTape).head = 3 * k + n + 4 ∧ + (c'.work utmStateTape).head = k + 1 ∧ + (∀ (j : Fin k), (c'.work utmStateTape).cells (j.val + 1) = + Γ.ofBool (j == (hk ▸ tm.stateEquiv tm.qstart))) ∧ + (∀ j, j ≥ k + 1 → (c'.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c'.work utmStateTape).cells 0 = Γ.start ∧ + (c'.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c'.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c'.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c'.work utmScratchTape).cells 0 = Γ.start ∧ + (c'.work utmSimTape).cells = (initTape []).cells ∧ (c'.work utmSimTape).head ≥ 1 ∧ + c'.input.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.input.cells j ≠ Γ.start) ∧ c'.input.cells 0 = Γ.start ∧ + c'.output.head ≥ 1 ∧ (∀ j, j ≥ 1 → c'.output.cells j ≠ Γ.start) ∧ c'.output.cells 0 = Γ.start ∧ + WorkTapesWF c'.work := by + intro rem + induction rem with + | zero => + intro c hstate hhead_rem hcells hdesc hdesc_ge hst_head hst_head_bound hst_0 + hst_copied hst_ones hst_tail hsc_h hsc_ones hsc_tail hsc_0 + hsim_c hsim_h hinp_h hinp_ns hinp_0 hout_h hout_ns hout_0 hwf0 hwf1 + have hdesc_head : (c.work utmDescTape).head = 3 * k + n + 4 := by omega + have hst_head_val : (c.work utmStateTape).head = k + 1 := by + rw [hst_head, hdesc_head]; omega + -- State tape reads blank sentinel at head = k + 1 + have hread_blank : (fun i => (c.work i).read) (1 : Fin 4) = Γ.blank := by + show (c.work utmStateTape).read = Γ.blank + simp only [Tape.read, hst_head_val] + rw [hst_tail (k + 1) (by omega)] + exact initTape_nil_cell_ge1 (by omega) + simp only [show (0 + 1 : ℕ) = 1 from rfl] + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.copyQstart ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers for base case (all tapes idle — all dirs are idleDir) + have hdesc_ne : (c.work utmDescTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmDescTape) + have hdesc_idle : (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) + (idleDir (c.work utmDescTape).read) = c.work utmDescTape := by + simp only [Tape.writeAndMove, idleDir, hdesc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmDescTape).head ≠ 0 from by omega] + have : Function.update (c.work utmDescTape).cells + (c.work utmDescTape).head (readBackWrite (c.work utmDescTape).read).toΓ = + (c.work utmDescTape).cells := by + have hcb : (readBackWrite (c.work utmDescTape).read).toΓ = + (c.work utmDescTape).cells (c.work utmDescTape).head := by + rw [ss_readBackWrite_toΓ_eq hdesc_ne]; rfl + rw [hcb, Function.update_eq_self] + simp only [this] + have hst_ne : (c.work utmStateTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmStateTape) + have hst_idle : (c.work utmStateTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmStateTape).read) = c.work utmStateTape := by + simp only [Tape.writeAndMove, idleDir, hst_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmStateTape).head ≠ 0 from by omega] + have : Function.update (c.work utmStateTape).cells + (c.work utmStateTape).head Γw.blank.toΓ = (c.work utmStateTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmStateTape).cells (c.work utmStateTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hst_head_val, hst_tail (k + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hsc_ne : (c.work utmScratchTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmScratchTape) + have hsc_idle : (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = c.work utmScratchTape := by + simp only [Tape.writeAndMove, idleDir, hsc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmScratchTape).head ≠ 0 from by omega] + have : Function.update (c.work utmScratchTape).cells + (c.work utmScratchTape).head Γw.blank.toΓ = (c.work utmScratchTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmScratchTape).cells (c.work utmScratchTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hsc_h, hsc_tail (n + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Build explicit step config (copyQstart with blank → done, all idle) + let c₁ : Cfg 4 setupStateTM.Q := { + state := .done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.copyQstart : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_blank] + show some _ = some c₁; congr 1 + -- Unfold c₁ work tapes for each index + have hw_desc : c₁.work utmDescTape = + (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) + (idleDir (c.work utmDescTape).read) := by + simp only [c₁, show ((utmDescTape : Fin 4).val = 0) = True from by decide, ↓reduceIte] + have hw_st : c₁.work utmStateTape = + (c.work utmStateTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmStateTape).read) := by + simp only [c₁, show ((utmStateTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sim : c₁.work utmSimTape = + (c.work utmSimTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmSimTape).read) := by + simp only [c₁, show ((utmSimTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + have hw_sc : c₁.work utmScratchTape = + (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) (idleDir (c.work utmScratchTape).read) := by + simp only [c₁, show ((utmScratchTape : Fin 4).val = 0) = False from by decide, ↓reduceIte] + refine ⟨c₁, .step hstep .zero, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc cells + rw [hw_desc, hdesc_idle]; exact hcells + · -- desc head = 3 * k + n + 4 + rw [hw_desc, hdesc_idle]; exact hdesc_head + · -- state head = k + 1 + rw [hw_st, hst_idle]; exact hst_head_val + · -- copied cells: ∀ (j : Fin k), ... + intro j + rw [hw_st, hst_idle] + exact hst_copied j.val j.isLt (by omega) + · -- state tail + intro j hj; rw [hw_st, hst_idle]; exact hst_tail j hj + · -- state cells 0 + rw [hw_st, hst_idle]; exact hst_0 + · -- scratch head + rw [hw_sc, hsc_idle]; exact hsc_h + · -- scratch ones + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_ones j hj + · -- scratch tail + intro j hj; rw [hw_sc, hsc_idle]; exact hsc_tail j hj + · -- scratch cells 0 + rw [hw_sc, hsc_idle]; exact hsc_0 + · -- sim cells + rw [hw_sim, hsim_idle]; exact hsim_c + · -- sim head + rw [hw_sim, hsim_idle]; exact hsim_h + · -- input head + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_h + · -- input cells ns + intro j hj + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_ns j hj + · -- input cells 0 + rw [show c₁.input = c.input.move (idleDir c.input.read) from rfl, hinp_idle]; exact hinp_0 + · -- output head + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + rw [hout_h']; exact hout_h + · -- output cells ns + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_ns' + · -- output cells 0 + rw [show c₁.output = c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) from rfl] + exact hout_0' + · -- WorkTapesWF + exact ⟨ + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [hw_desc, hdesc_idle]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; rw [hw_st, hst_idle]; exact hwf0 utmStateTape + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [hw_sim, hsim_idle]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [hw_sc, hsc_idle]; exact hwf0 utmScratchTape, + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [hw_desc, hdesc_idle]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by change (c₁.work utmStateTape).cells j ≠ Γ.start; rw [hw_st, hst_idle]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [hw_sim, hsim_idle]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [hw_sc, hsc_idle]; exact hwf1 utmScratchTape j hj⟩ + | succ rem' ih => + intro c hstate hhead_rem hcells hdesc hdesc_ge hst_head hst_head_bound hst_0 + hst_copied hst_ones hst_tail hsc_h hsc_ones hsc_tail hsc_0 + hsim_c hsim_h hinp_h hinp_ns hinp_0 hout_h hout_ns hout_0 hwf0 hwf1 + -- State tape reads non-blank (Γ.one) at head < k + 1 + have hst_head_le_k : (c.work utmStateTape).head ≤ k := by omega + have hread_ne_blank : (fun i => (c.work i).read) (1 : Fin 4) ≠ Γ.blank := by + show (c.work utmStateTape).read ≠ Γ.blank + simp only [Tape.read] + have hge1 : (c.work utmStateTape).head ≥ 1 := by omega + have := hst_ones ((c.work utmStateTape).head - 1) (by omega) (by omega) + rw [show (c.work utmStateTape).head - 1 + 1 = (c.work utmStateTape).head from by omega] at this + rw [this]; decide + have hne_halt : c.state ≠ setupStateTM.qhalt := by + rw [hstate]; show SetupStatePhase.copyQstart ≠ SetupStatePhase.done; exact nofun + -- Idle tape helpers + have hsim_idle := idle_tape_initTape hsim_h hsim_c + have hsc_ne : (c.work utmScratchTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmScratchTape) + have hsc_idle : (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = c.work utmScratchTape := by + simp only [Tape.writeAndMove, idleDir, hsc_ne, ↓reduceIte, Tape.move, + Tape.write, show (c.work utmScratchTape).head ≠ 0 from by omega] + have : Function.update (c.work utmScratchTape).cells + (c.work utmScratchTape).head Γw.blank.toΓ = (c.work utmScratchTape).cells := by + have hcb : Γw.blank.toΓ = + (c.work utmScratchTape).cells (c.work utmScratchTape).head := by + rw [show Γw.blank.toΓ = Γ.blank from rfl, + hsc_h, hsc_tail (n + 1) (by omega), initTape_nil_cell_ge1 (by omega)] + rw [hcb, Function.update_eq_self] + simp only [this] + have hinp_idle := idle_input hinp_h hinp_ns + have ⟨hout_0', hout_ns', hout_h'⟩ := idle_tape_wf hout_h hout_0 hout_ns + -- Step: copyQstart with ≠ blank → stay copyQstart, desc+state right, state writes desc bit + let c₁ : Cfg 4 setupStateTM.Q := { + state := .copyQstart + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove + ((if (i : Fin 4).val = 0 then readBackWrite (c.work (0 : Fin 4)).read + else if (i : Fin 4).val = 1 then readBackWrite (c.work (0 : Fin 4)).read + else Γw.blank : Γw) : Γ) + (if (i : Fin 4).val = 0 then Dir3.right + else if (i : Fin 4).val = 1 then Dir3.right + else idleDir (c.work i).read) + output := c.output.writeAndMove ((Γw.blank : Γw) : Γ) (idleDir c.output.read) } + have hstep : setupStateTM.step c = some c₁ := by + unfold TM.step + simp only [hstate, show (SetupStatePhase.copyQstart : SetupStatePhase) ≠ .done from nofun, + ↓reduceIte, setupStateTM, hread_ne_blank] + show some _ = some c₁; congr 1 + -- c₁ desc tape (readBackWrite + right) + have h1_desc_cells : (c₁.work utmDescTape).cells = w₀.cells := by + show ((c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells = _ + rw [readBackWrite_cells (by omega) (hwf1 utmDescTape)]; exact hcells + have h1_desc_head : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + show ((c.work utmDescTape).writeAndMove _ Dir3.right).head = _ + exact writeAndMove_right_head + -- c₁ state tape (readBackWrite(desc.read) + right — cross-tape copy) + have h1_st_head : (c₁.work utmStateTape).head = (c.work utmStateTape).head + 1 := by + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).head = _ + exact writeAndMove_right_head + have h1_st_cells_0 : (c₁.work utmStateTape).cells 0 = Γ.start := by + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells 0 = _ + rw [writeAndMove_cells_0 (by omega)]; exact hst_0 + -- The written value at old state_head: desc bit copied to state tape + have h1_copied : ∀ (j : ℕ) (hj : j < k), j + 1 < (c₁.work utmStateTape).head → + (c₁.work utmStateTape).cells (j + 1) = + Γ.ofBool ((⟨j, hj⟩ : Fin k) == (hk ▸ tm.stateEquiv tm.qstart)) := by + intro j hj hjlt + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells (j + 1) = _ + rw [h1_st_head] at hjlt + by_cases hje : j + 1 = (c.work utmStateTape).head + · -- Newly written cell + rw [hje, writeAndMove_cells_at_head (by omega)] + have hdesc_ne : (c.work utmDescTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmDescTape) + rw [ss_readBackWrite_toΓ_eq hdesc_ne] + simp only [Tape.read, hcells] + rw [show (c.work utmDescTape).head = 2 * k + 4 + n + j from by omega] + exact desc_qstart_cells tm hk hdesc j hj + · -- Previously written cell + rw [writeAndMove_cells_ne hje] + exact hst_copied j hj (by omega) + have h1_ones : ∀ j, (c₁.work utmStateTape).head - 1 ≤ j → j < k → + (c₁.work utmStateTape).cells (j + 1) = Γ.one := by + intro j hj1 hj2 + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells (j + 1) = Γ.one + rw [h1_st_head] at hj1 + rw [writeAndMove_cells_ne (by omega)] + exact hst_ones j (by omega) hj2 + have h1_tail : ∀ j, j ≥ k + 1 → + (c₁.work utmStateTape).cells j = (initTape []).cells j := by + intro j hj + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells j = _ + rw [writeAndMove_cells_ne (by omega)] + exact hst_tail j hj + -- c₁ sim idle + have h1_sim : c₁.work utmSimTape = c.work utmSimTape := by + show (c.work utmSimTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmSimTape).read) = _ + exact hsim_idle + -- c₁ scratch idle + have h1_sc : c₁.work utmScratchTape = c.work utmScratchTape := by + show (c.work utmScratchTape).writeAndMove (Γw.blank : Γw) + (idleDir (c.work utmScratchTape).read) = _ + exact hsc_idle + have h1_inp : c₁.input = c.input := hinp_idle + -- WorkTapesWF for c₁ + have h1_wf0 : ∀ i, (c₁.work i).cells 0 = Γ.start := + fun | ⟨0, _⟩ => by change (c₁.work utmDescTape).cells 0 = Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf0 utmDescTape + | ⟨1, _⟩ => by change (c₁.work utmStateTape).cells 0 = Γ.start; exact h1_st_cells_0 + | ⟨2, _⟩ => by change (c₁.work utmSimTape).cells 0 = Γ.start; rw [h1_sim]; exact hwf0 utmSimTape + | ⟨3, _⟩ => by change (c₁.work utmScratchTape).cells 0 = Γ.start; rw [h1_sc]; exact hwf0 utmScratchTape + have h1_wf1 : ∀ i j, j ≥ 1 → (c₁.work i).cells j ≠ Γ.start := + fun | ⟨0, _⟩, j, hj => by change (c₁.work utmDescTape).cells j ≠ Γ.start; rw [h1_desc_cells, ← hcells]; exact hwf1 utmDescTape j hj + | ⟨1, _⟩, j, hj => by + change (c₁.work utmStateTape).cells j ≠ Γ.start + show ((c.work utmStateTape).writeAndMove (readBackWrite (c.work utmDescTape).read : Γw) Dir3.right).cells j ≠ Γ.start + by_cases hje : j = (c.work utmStateTape).head + · subst hje + rw [writeAndMove_cells_at_head (by omega)] + have hdesc_ne : (c.work utmDescTape).read ≠ Γ.start := + ss_tape_read_ne_start_of_wf _ (by omega) (hwf1 utmDescTape) + rw [ss_readBackWrite_toΓ_eq hdesc_ne] + exact hwf1 utmDescTape _ (by omega) + · rw [writeAndMove_cells_ne hje]; exact hwf1 utmStateTape j hj + | ⟨2, _⟩, j, hj => by change (c₁.work utmSimTape).cells j ≠ Γ.start; rw [h1_sim]; exact hwf1 utmSimTape j hj + | ⟨3, _⟩, j, hj => by change (c₁.work utmScratchTape).cells j ≠ Γ.start; rw [h1_sc]; exact hwf1 utmScratchTape j hj + -- Apply IH + obtain ⟨c_f, hreach, hprops⟩ := ih c₁ rfl + (by rw [h1_desc_head]; omega) + h1_desc_cells hdesc + (by rw [h1_desc_head]; omega) + (by rw [h1_st_head, hst_head, h1_desc_head]; omega) + (by rw [h1_st_head]; omega) + h1_st_cells_0 + h1_copied h1_ones h1_tail + (by rw [h1_sc]; exact hsc_h) + (by intro j hj; rw [h1_sc]; exact hsc_ones j hj) + (by intro j hj; rw [h1_sc]; exact hsc_tail j hj) + (by rw [h1_sc]; exact hsc_0) + (by rw [h1_sim]; exact hsim_c) + (by rw [h1_sim]; exact hsim_h) + (by rw [h1_inp]; exact hinp_h) + (fun j hj => by rw [h1_inp]; exact hinp_ns j hj) + (by rw [h1_inp]; exact hinp_0) + (by rw [hout_h']; exact hout_h) + hout_ns' hout_0' + h1_wf0 h1_wf1 + exact ⟨c_f, .step hstep hreach, hprops⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- Frame lemmas: sim tape and input tape are preserved throughout setupState +-- ════════════════════════════════════════════════════════════════════════ + +/-- In any non-done state, setupStateTM writes .blank to tape 2 and uses idleDir. -/ +private theorem setupStateTM_sim_tape_idle (state : SetupStatePhase) + (hnd : state ≠ .done) + (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + let (_, workWrites, _, _, workDirs, _) := setupStateTM.δ state iHead wHeads oHead + workWrites (2 : Fin 4) = .blank ∧ workDirs (2 : Fin 4) = idleDir (wHeads 2) := by + match state with + | .skipK => + simp only [setupStateTM, show (2 : Fin 4).val = 2 from rfl, show (2 : ℕ) ≠ 0 from by decide, + show (2 : ℕ) ≠ 1 from by decide] + split <;> simp + | .copyN => + simp only [setupStateTM, show (2 : Fin 4).val = 2 from rfl, show (2 : ℕ) ≠ 0 from by decide, + show (2 : ℕ) ≠ 3 from by decide] + split <;> simp + | .skipQhalt => + simp only [setupStateTM, show (2 : Fin 4).val = 2 from rfl, show (2 : ℕ) ≠ 0 from by decide, + show (2 : ℕ) ≠ 1 from by decide] + split <;> simp + | .copyQstart => + simp only [setupStateTM, show (2 : Fin 4).val = 2 from rfl, show (2 : ℕ) ≠ 0 from by decide, + show (2 : ℕ) ≠ 1 from by decide] + split <;> simp + | .done => exact absurd rfl hnd + +/-- In any non-done state, setupStateTM uses idleDir for the input direction. -/ +private theorem setupStateTM_inp_dir_idle (state : SetupStatePhase) + (hnd : state ≠ .done) + (iHead : Γ) (wHeads : Fin 4 → Γ) (oHead : Γ) : + let (_, _, _, inDir, _, _) := setupStateTM.δ state iHead wHeads oHead + inDir = idleDir iHead := by + match state with + | .skipK => simp [setupStateTM]; split <;> rfl + | .copyN => simp [setupStateTM]; split <;> rfl + | .skipQhalt => simp [setupStateTM]; split <;> rfl + | .copyQstart => simp [setupStateTM]; split <;> rfl + | .done => exact absurd rfl hnd + +/-- One step of setupStateTM preserves the sim tape exactly (tape 2 is idle). -/ +private theorem setupStateTM_step_sim_preserved + (c c' : Cfg 4 setupStateTM.Q) + (hstep : setupStateTM.step c = some c') + (hsim_c : (c.work utmSimTape).cells = (initTape []).cells) + (hsim_h : (c.work utmSimTape).head ≥ 1) : + c'.work utmSimTape = c.work utmSimTape := by + unfold TM.step at hstep + have hnd : c.state ≠ setupStateTM.qhalt := by + intro h; simp [h] at hstep + simp only [hnd, ↓reduceIte] at hstep + -- Extract delta output + set δout := setupStateTM.δ c.state c.input.read (fun i => (c.work i).read) c.output.read + have hδ := setupStateTM_sim_tape_idle c.state hnd + c.input.read (fun i => (c.work i).read) c.output.read + simp only [show δout.2.1 (2 : Fin 4) = (setupStateTM.δ c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.1 (2 : Fin 4) from rfl] at hδ + obtain ⟨hw_blank, hd_idle⟩ := hδ + -- The step result's work field + have hc' := Option.some.inj hstep.symm + rw [show c'.work utmSimTape = (c.work utmSimTape).writeAndMove + (δout.2.1 utmSimTape).toΓ (δout.2.2.2.2.1 utmSimTape) from by rw [hc']] + simp only [show (utmSimTape : Fin 4) = (2 : Fin 4) from rfl] + rw [hw_blank, hd_idle] + exact idle_tape_initTape hsim_h hsim_c + +/-- One step of setupStateTM preserves the input tape exactly. -/ +private theorem setupStateTM_step_inp_preserved + (c c' : Cfg 4 setupStateTM.Q) + (hstep : setupStateTM.step c = some c') + (hinp_h : c.input.head ≥ 1) + (hinp_ns : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) : + c'.input = c.input := by + unfold TM.step at hstep + have hnd : c.state ≠ setupStateTM.qhalt := by + intro h; simp [h] at hstep + simp only [hnd, ↓reduceIte] at hstep + set δout := setupStateTM.δ c.state c.input.read (fun i => (c.work i).read) c.output.read + have hδ := setupStateTM_inp_dir_idle c.state hnd + c.input.read (fun i => (c.work i).read) c.output.read + simp only [show δout.2.2.2.1 = (setupStateTM.δ c.state c.input.read + (fun i => (c.work i).read) c.output.read).2.2.2.1 from rfl] at hδ + have hc' : c'.input = c.input.move δout.2.2.2.1 := by + have := Option.some.inj hstep.symm; rw [this] + rw [hc', hδ] + exact idle_input hinp_h hinp_ns + +/-- setupStateTM preserves the sim tape exactly over any reachesIn. -/ +private theorem setupStateTM_reachesIn_sim_preserved {t : ℕ} + (c c' : Cfg 4 setupStateTM.Q) + (h : setupStateTM.reachesIn t c c') + (hsim_c : (c.work utmSimTape).cells = (initTape []).cells) + (hsim_h : (c.work utmSimTape).head ≥ 1) : + c'.work utmSimTape = c.work utmSimTape := by + induction h with + | zero => rfl + | step hstep hrest ih => + have hpres_mid := setupStateTM_step_sim_preserved _ _ hstep hsim_c hsim_h + rw [ih (by rw [hpres_mid]; exact hsim_c) (by rw [hpres_mid]; exact hsim_h), hpres_mid] + +/-- setupStateTM preserves the input tape exactly over any reachesIn. -/ +private theorem setupStateTM_reachesIn_inp_preserved {t : ℕ} + (c c' : Cfg 4 setupStateTM.Q) + (h : setupStateTM.reachesIn t c c') + (hinp_h : c.input.head ≥ 1) + (hinp_ns : ∀ j, j ≥ 1 → c.input.cells j ≠ Γ.start) : + c'.input = c.input := by + induction h with + | zero => rfl + | step hstep hrest ih => + have hpres_mid := setupStateTM_step_inp_preserved _ _ hstep hinp_h hinp_ns + rw [ih (by rw [hpres_mid]; exact hinp_h) (by rw [hpres_mid]; exact hinp_ns), hpres_mid] + +-- ════════════════════════════════════════════════════════════════════════ +-- Full simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Step-by-step simulation of setupStateTM through all 4 phases. -/ +theorem setupStateTM_simulation (tm : TM n) (k : ℕ) + (_x : List Bool) + (hk : k = @Fintype.card tm.Q tm.finQ) + (inp : Tape) (work : Fin 4 → Tape) (out : Tape) + (hdesc : descOnTape (TMEncoding.encodeTM tm) (work utmDescTape)) + (hdesc_h : (work utmDescTape).head = 1) + (hst_c : (work utmStateTape).cells = (initTape []).cells) + (hst_h : (work utmStateTape).head = 1) + (hsim_c : (work utmSimTape).cells = (initTape []).cells) + (hsc_c : (work utmScratchTape).cells = (initTape []).cells) + (hsc_h : (work utmScratchTape).head = 1) + (henv : InitEnvelope inp work out) : + ∃ c', setupStateTM.reachesIn (3 * k + n + 5) + { state := SetupStatePhase.skipK, input := inp, work := work, output := out } c' ∧ + setupStateTM.halted c' ∧ + InitEnvelope c'.input c'.work c'.output ∧ + (let desc := TMEncoding.encodeTM tm + descOnTape desc (c'.work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (c'.work utmStateTape) ∧ + (c'.work utmSimTape).cells = (initTape []).cells ∧ + tapeStoresBools (List.replicate n true) (c'.work utmScratchTape) ∧ + (c'.work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (c'.work utmScratchTape).head ≤ n + 1 ∧ + (c'.work utmStateTape).head ≤ k + 1 ∧ + c'.work utmSimTape = work utmSimTape ∧ + c'.input = inp) := by + -- Extract InitEnvelope components + obtain ⟨hic0, hins, hih, hwf, hheads, hoc0, hons, hoh⟩ := henv + -- WorkTapesWF gives us cells-level properties for all work tapes + have hwf0 := hwf.1; have hwf1 := hwf.2 + -- Abbrevs + set desc := TMEncoding.encodeTM tm + set c₀ : Cfg 4 setupStateTM.Q := + { state := .skipK, input := inp, work := work, output := out } + -- The proof proceeds through 4 phases. + -- We construct the final config and reachesIn chain by composing phases. + + -- Phase 1: skipK reads k ones from desc cells 1..k, writes to state cells 1..k + -- Phase 1 + separator = k+1 steps, then + -- Phase 2: copyN reads n ones from desc cells k+2..k+1+n, writes to scratch cells 1..n + -- Phase 2 + separator = n+1 steps, then + -- Phase 3: skipQhalt counts down state from k+1 to 0 = k+2 steps, then + -- Phase 4: copyQstart copies k desc bits to state + done = k+1 steps + -- Total: (k+1) + (n+1) + (k+2) + (k+1) = 3k+n+5 + + -- The output tape gets blank written at head each step (idleDir = stay since head ≥ 1). + -- Since head ≥ 1 and head stays, the effect is: cells at out.head become Γ.blank, + -- all other cells unchanged. For InitEnvelope, we need cells 0 = ▷ and cells ≥ 1 ≠ ▷. + -- Γ.blank ≠ ▷, so this is fine. The output tape's exact final state doesn't matter + -- beyond InitEnvelope preservation. + + -- Similarly, sim tape gets blank written at head (which is ≥ 1), but since sim cells + -- start as initTape (cells ≥ 1 = blank), writing blank is identity. So sim tape + -- is truly unchanged throughout. + + -- For desc tape: readBackWrite preserves cells (since desc cells ≥ 1 ≠ ▷, and + -- readBackWrite roundtrips non-▷ symbols). So desc cells are unchanged. + + -- Let's proceed phase by phase. + -- We'll show: each step of the machine produces a specific next config. + -- For loops (phases 1,2,3,4), we use induction. + + -- Helper: desc tape cells don't have ▷ at positions ≥ 1 + have hdesc_ne : ∀ j, j ≥ 1 → (work utmDescTape).cells j ≠ Γ.start := + hwf1 utmDescTape + -- State tape cells don't have ▷ at positions ≥ 1 (initTape has blank for ≥ 1) + have hst_ne : ∀ j, j ≥ 1 → (work utmStateTape).cells j ≠ Γ.start := by + intro j hj; rw [hst_c]; intro h; simp [initTape, show j ≠ 0 from by omega] at h + -- Scratch tape similarly + have hsc_ne : ∀ j, j ≥ 1 → (work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hsc_c]; intro h; simp [initTape, show j ≠ 0 from by omega] at h + -- Sim tape similarly + have hsim_ne : ∀ j, j ≥ 1 → (work utmSimTape).cells j ≠ Γ.start := by + intro j hj; rw [hsim_c]; intro h; simp [initTape, show j ≠ 0 from by omega] at h + + -- The proof is organized as 4 sorry'd phase claims composed via reachesIn_trans. + -- Each phase claim is then proved separately by induction. + + -- Phase 1 claim: from initial c₀, reach c₁ in k+1 steps + -- Phase 2 claim: from c₁, reach c₂ in n+1 steps + -- Phase 3 claim: from c₂, reach c₃ in k+2 steps + -- Phase 4 claim: from c₃, reach c₄ in k+1 steps + -- Total: (k+1)+(n+1)+(k+2)+(k+1) = 3k+n+5 + + -- We define intermediate configs c₁..c₄ via sorry and prove the claims. + -- At the end, we verify postconditions on c₄. + + -- Step 1: Construct the proof via sorry'd claims, then fill each in. + -- This lets us verify the overall structure first. + + -- Actually, to avoid defining explicit configs (which is very verbose), + -- we use existential witnesses throughout. + + -- Phase 1: k+1 steps from skipK to copyN + have phase1 : ∃ c₁, setupStateTM.reachesIn (k + 1) c₀ c₁ ∧ + c₁.state = .copyN ∧ + (c₁.work utmDescTape).cells = (work utmDescTape).cells ∧ + (c₁.work utmDescTape).head = k + 2 ∧ + (c₁.work utmStateTape).head = k + 1 ∧ + (∀ j, j < k → (c₁.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c₁.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c₁.work utmStateTape).cells 0 = Γ.start ∧ + (c₁.work utmSimTape).cells = (initTape []).cells ∧ + (c₁.work utmSimTape).head ≥ 1 ∧ + (c₁.work utmScratchTape).cells = (initTape []).cells ∧ + (c₁.work utmScratchTape).head = 1 ∧ + c₁.input.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₁.input.cells j ≠ Γ.start) ∧ + c₁.input.cells 0 = Γ.start ∧ + c₁.output.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₁.output.cells j ≠ Γ.start) ∧ + c₁.output.cells 0 = Γ.start ∧ + WorkTapesWF c₁.work := by + have h_desc_tape : descOnTape desc ⟨0, (work utmDescTape).cells⟩ := by + exact ⟨hdesc.1, hdesc.2.1, hdesc.2.2⟩ + exact skipK_loop tm hk k c₀ rfl (by simp [c₀, hdesc_h]; omega) rfl h_desc_tape + (by simp [c₀, hdesc_h]) (by simp [c₀, hst_h, hdesc_h]) + (by simp [c₀]; exact hwf0 utmStateTape) + (by intro j hj1 hj2; simp [c₀, hst_h, hdesc_h] at hj2; omega) + (by intro j hj; simp [c₀, hst_h, hdesc_h] at hj ⊢; rw [hst_c]) + (by simp [c₀]; exact hsim_c) (by simp [c₀]; exact hheads utmSimTape) + (by simp [c₀]; exact hsc_c) (by simp [c₀]; exact hsc_h) + (by simp [c₀]; exact hih) (by simp [c₀]; exact hins) (by simp [c₀]; exact hic0) + (by simp [c₀]; exact hoh) (by simp [c₀]; exact hons) (by simp [c₀]; exact hoc0) + (by simp [c₀]; exact hwf0) (by simp [c₀]; exact hwf1) + + obtain ⟨c₁, hreach1, hst1, hdesc_c1, hdesc_h1, hst_h1, hst_ones1, hst_tail1, + hst_01, hsim_c1, hsim_h1, hsc_c1, hsc_h1, hinp_h1, hinp_ne1, hinp_01, + hout_h1, hout_ne1, hout_01, hwf1'⟩ := phase1 + + -- Phase 2: n+1 steps from copyN to skipQhalt + have phase2 : ∃ c₂, setupStateTM.reachesIn (n + 1) c₁ c₂ ∧ + c₂.state = .skipQhalt ∧ + (c₂.work utmDescTape).cells = (work utmDescTape).cells ∧ + (c₂.work utmDescTape).head = k + n + 3 ∧ + -- state tape unchanged from c₁ + (c₂.work utmStateTape).head = k + 1 ∧ + (∀ j, j < k → (c₂.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c₂.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c₂.work utmStateTape).cells 0 = Γ.start ∧ + -- scratch tape has n ones + (c₂.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c₂.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c₂.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c₂.work utmScratchTape).cells 0 = Γ.start ∧ + -- sim unchanged + (c₂.work utmSimTape).cells = (initTape []).cells ∧ + (c₂.work utmSimTape).head ≥ 1 ∧ + -- envelope stuff + c₂.input.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₂.input.cells j ≠ Γ.start) ∧ + c₂.input.cells 0 = Γ.start ∧ + c₂.output.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₂.output.cells j ≠ Γ.start) ∧ + c₂.output.cells 0 = Γ.start ∧ + WorkTapesWF c₂.work := by + have h_desc_tape : descOnTape desc ⟨0, (work utmDescTape).cells⟩ := + ⟨hdesc.1, hdesc.2.1, hdesc.2.2⟩ + exact copyN_loop tm hk n c₁ + hst1 + (by rw [hdesc_h1]; omega) + hdesc_c1 + h_desc_tape + (by omega) + hst_h1 + hst_ones1 + hst_tail1 + hst_01 + (by rw [hsc_h1, hdesc_h1]; omega) + (hwf1'.1 utmScratchTape) + (by intro j hj1 hj2; rw [hsc_h1] at hj2; omega) + (by intro j _; exact congr_fun hsc_c1 j) + hsim_c1 + hsim_h1 + hinp_h1 hinp_ne1 hinp_01 + hout_h1 hout_ne1 hout_01 + hwf1'.1 hwf1'.2 + + obtain ⟨c₂, hreach2, hst2, hdesc_c2, hdesc_h2, hst_h2, hst_ones2, hst_tail2, + hst_02, hsc_h2, hsc_ones2, hsc_tail2, hsc_02, hsim_c2, hsim_h2, + hinp_h2, hinp_ne2, hinp_02, hout_h2, hout_ne2, hout_02, hwf2'⟩ := phase2 + + -- Phase 3: k+2 steps from skipQhalt to copyQstart + have phase3 : ∃ c₃, setupStateTM.reachesIn (k + 2) c₂ c₃ ∧ + c₃.state = .copyQstart ∧ + (c₃.work utmDescTape).cells = (work utmDescTape).cells ∧ + (c₃.work utmDescTape).head = 2 * k + n + 4 ∧ + -- state tape: head back to 1, cells unchanged from c₂ + (c₃.work utmStateTape).head = 1 ∧ + (∀ j, j < k → (c₃.work utmStateTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ k + 1 → (c₃.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c₃.work utmStateTape).cells 0 = Γ.start ∧ + -- scratch, sim unchanged + (c₃.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c₃.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c₃.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c₃.work utmScratchTape).cells 0 = Γ.start ∧ + (c₃.work utmSimTape).cells = (initTape []).cells ∧ + (c₃.work utmSimTape).head ≥ 1 ∧ + c₃.input.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₃.input.cells j ≠ Γ.start) ∧ + c₃.input.cells 0 = Γ.start ∧ + c₃.output.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₃.output.cells j ≠ Γ.start) ∧ + c₃.output.cells 0 = Γ.start ∧ + WorkTapesWF c₃.work := by + have h_desc_tape : descOnTape desc ⟨0, (work utmDescTape).cells⟩ := + ⟨hdesc.1, hdesc.2.1, hdesc.2.2⟩ + exact skipQhalt_loop tm hk (k + 2) c₂ + hst2 + (by omega) + hdesc_c2 + h_desc_tape + (by omega) + (by rw [hdesc_h2, hst_h2]; omega) + hst_02 + hst_ones2 + hst_tail2 + hsc_h2 + hsc_ones2 + hsc_tail2 + hsc_02 + hsim_c2 + hsim_h2 + hinp_h2 hinp_ne2 hinp_02 + hout_h2 hout_ne2 hout_02 + hwf2'.1 hwf2'.2 + + obtain ⟨c₃, hreach3, hst3, hdesc_c3, hdesc_h3, hst_h3, hst_ones3, hst_tail3, + hst_03, hsc_h3, hsc_ones3, hsc_tail3, hsc_03, hsim_c3, hsim_h3, + hinp_h3, hinp_ne3, hinp_03, hout_h3, hout_ne3, hout_03, hwf3'⟩ := phase3 + + -- Phase 4: k+1 steps from copyQstart to done + have phase4 : ∃ c₄, setupStateTM.reachesIn (k + 1) c₃ c₄ ∧ + c₄.state = .done ∧ + (c₄.work utmDescTape).cells = (work utmDescTape).cells ∧ + (c₄.work utmDescTape).head = 3 * k + n + 4 ∧ + -- state tape: has qstart one-hot at cells 1..k + (c₄.work utmStateTape).head = k + 1 ∧ + (∀ (j : Fin k), (c₄.work utmStateTape).cells (j.val + 1) = + Γ.ofBool (j == (hk ▸ tm.stateEquiv tm.qstart))) ∧ + (∀ j, j ≥ k + 1 → (c₄.work utmStateTape).cells j = (initTape []).cells j) ∧ + (c₄.work utmStateTape).cells 0 = Γ.start ∧ + -- scratch, sim unchanged from c₃ + (c₄.work utmScratchTape).head = n + 1 ∧ + (∀ j, j < n → (c₄.work utmScratchTape).cells (j + 1) = Γ.one) ∧ + (∀ j, j ≥ n + 1 → (c₄.work utmScratchTape).cells j = (initTape []).cells j) ∧ + (c₄.work utmScratchTape).cells 0 = Γ.start ∧ + (c₄.work utmSimTape).cells = (initTape []).cells ∧ + (c₄.work utmSimTape).head ≥ 1 ∧ + c₄.input.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₄.input.cells j ≠ Γ.start) ∧ + c₄.input.cells 0 = Γ.start ∧ + c₄.output.head ≥ 1 ∧ + (∀ j, j ≥ 1 → c₄.output.cells j ≠ Γ.start) ∧ + c₄.output.cells 0 = Γ.start ∧ + WorkTapesWF c₄.work := by + have h_desc_tape : descOnTape desc ⟨0, (work utmDescTape).cells⟩ := + ⟨hdesc.1, hdesc.2.1, hdesc.2.2⟩ + exact copyQstart_loop tm hk k c₃ + hst3 + (by rw [hdesc_h3]; omega) + hdesc_c3 + h_desc_tape + (by omega) + (by rw [hst_h3, hdesc_h3]; omega) + (by rw [hst_h3]; omega) + hst_03 + (by intro j _ h; rw [hst_h3] at h; omega) + (by intro j _ hj2; exact hst_ones3 j hj2) + hst_tail3 + hsc_h3 + hsc_ones3 + hsc_tail3 + hsc_03 + hsim_c3 + hsim_h3 + hinp_h3 hinp_ne3 hinp_03 + hout_h3 hout_ne3 hout_03 + hwf3'.1 hwf3'.2 + + obtain ⟨c₄, hreach4, hst4, hdesc_c4, hdesc_h4, hst_h4, hst_qstart4, hst_tail4, + hst_04, hsc_h4, hsc_ones4, hsc_tail4, hsc_04, hsim_c4, hsim_h4, + hinp_h4, hinp_ne4, hinp_04, hout_h4, hout_ne4, hout_04, hwf4'⟩ := phase4 + + -- Compose the four phases + have hreach12 := reachesIn_trans setupStateTM hreach1 hreach2 + have hreach123 := reachesIn_trans setupStateTM hreach12 hreach3 + have hreach1234 := reachesIn_trans setupStateTM hreach123 hreach4 + rw [show (k + 1 + (n + 1)) + (k + 2) + (k + 1) = 3 * k + n + 5 from by omega] + at hreach1234 + + -- The final config is c₄ + refine ⟨c₄, hreach1234, ?_, ?_, ?_⟩ + + -- c₄ is halted (state = done = qhalt) + · show c₄.state = SetupStatePhase.done; exact hst4 + + -- InitEnvelope + · refine ⟨hinp_04, hinp_ne4, hinp_h4, hwf4', ?_, hout_04, hout_ne4, hout_h4⟩ + intro i + match i with + | ⟨0, _⟩ => show (c₄.work 0).head ≥ 1; rw [show (0 : Fin 4) = utmDescTape from rfl, hdesc_h4]; omega + | ⟨1, _⟩ => show (c₄.work 1).head ≥ 1; rw [show (1 : Fin 4) = utmStateTape from rfl, hst_h4]; omega + | ⟨2, _⟩ => show (c₄.work 2).head ≥ 1; rw [show (2 : Fin 4) = utmSimTape from rfl]; exact hsim_h4 + | ⟨3, _⟩ => show (c₄.work 3).head ≥ 1; rw [show (3 : Fin 4) = utmScratchTape from rfl, hsc_h4]; omega + + -- Postconditions + · change descOnTape desc (c₄.work utmDescTape) ∧ _ + refine ⟨?_, ?_, hsim_c4, ?_, ?_, ?_, by rw [hst_h4], ?_, ?_⟩ + -- descOnTape desc (c₄.work utmDescTape) + · constructor + · rw [hdesc_c4]; exact hdesc.1 + · constructor + · intro i hi; rw [hdesc_c4]; exact hdesc.2.1 i hi + · rw [hdesc_c4]; exact hdesc.2.2 + -- stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (c₄.work utmStateTape) + · refine ⟨hst_04, ?_, ?_⟩ + · intro j hj + have := hst_qstart4 ⟨j, hj⟩ + rw [this]; clear this + rw [stateEquivK_val]; subst hk + by_cases hq : j = (tm.stateEquiv tm.qstart).val + · have hbeq : BEq.beq (⟨j, hj⟩ : Fin (Fintype.card tm.Q)) (tm.stateEquiv tm.qstart) = true := by + rw [beq_iff_eq, Fin.ext_iff]; exact hq + simp [hbeq, Γ.ofBool, hq] + · have hbeq : BEq.beq (⟨j, hj⟩ : Fin (Fintype.card tm.Q)) (tm.stateEquiv tm.qstart) = false := by + rw [Bool.eq_false_iff]; intro h; rw [beq_iff_eq, Fin.ext_iff] at h; exact hq h + simp [hbeq, Γ.ofBool, hq] + · have := hst_tail4 (k + 1) (by omega) + rw [show k + 1 = k + 1 from rfl] at this + rw [this]; exact initTape_nil_cell_ge1 (by omega) + -- tapeStoresBools (replicate n true) scratch + · refine ⟨hsc_04, ?_, ?_⟩ + · intro i hi + simp only [List.length_replicate] at hi + rw [hsc_ones4 i hi] + simp [List.getElem_replicate, Γ.ofBool] + · simp only [List.length_replicate] + have := hsc_tail4 (n + 1) (by omega) + rw [show n + 1 = n + 1 from rfl] at this + rw [this]; exact initTape_nil_cell_ge1 (by omega) + -- desc head bound + · rw [hdesc_h4]; omega + -- scratch head bound + · rw [hsc_h4] + -- sim tape preservation: by frame lemma, tape 2 is idle throughout + · show c₄.work utmSimTape = work utmSimTape + have := setupStateTM_reachesIn_sim_preserved c₀ c₄ hreach1234 + (by simp only [c₀]; exact hsim_c) (by simp only [c₀]; exact hheads utmSimTape) + simp only [c₀] at this; exact this + -- input tape preservation: by frame lemma, input is idle throughout + · show c₄.input = inp + have := setupStateTM_reachesIn_inp_preserved c₀ c₄ hreach1234 + (by simp only [c₀]; exact hih) (by simp only [c₀]; exact hins) + simp only [c₀] at this; exact this + +-- ════════════════════════════════════════════════════════════════════════ +-- Main theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime for setupStateTM. + Precondition: desc tape with head at 1, other work tapes blank. + Postcondition: state tape has qstart one-hot, scratch has n ones. -/ +theorem setupStateTM_hoareTime (tm : TM n) (k : ℕ) + (_x : List Bool) + (hk : k = @Fintype.card tm.Q tm.finQ) : + setupStateTM.HoareTime + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).cells = (initTape []).cells ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + (work utmScratchTape).cells = (initTape []).cells ∧ + (work utmScratchTape).head = 1) + (fun inp work out => + InitEnvelope inp work out ∧ + let desc := TMEncoding.encodeTM tm + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk tm.qstart) (work utmStateTape) ∧ + (work utmSimTape).cells = (initTape []).cells ∧ + tapeStoresBools (List.replicate n true) (work utmScratchTape) ∧ + (work utmDescTape).head ≤ 3 * k + n + 5 ∧ + (work utmScratchTape).head ≤ n + 1 ∧ + (work utmStateTape).head ≤ k + 1 ∧ + (work utmSimTape) = (work utmSimTape) ∧ + inp = inp) + (3 * k + n + 5) := by + intro inp work out hpre + obtain ⟨henv, hdesc, hdesc_h, hst_c, hst_h, hsim_c, hsc_c, hsc_h⟩ := hpre + have hsim := setupStateTM_simulation tm k _x hk inp work out + hdesc hdesc_h hst_c hst_h hsim_c hsc_c hsc_h henv + obtain ⟨c', hreach, hhalt, henv', hpost⟩ := hsim + -- Extract all fields from the simulation postcondition + have hdesc' := hpost.1 + have hstate' := hpost.2.1 + have hsim' := hpost.2.2.1 + have hsc' := hpost.2.2.2.1 + have hd_head' := hpost.2.2.2.2.1 + have hsc_head' := hpost.2.2.2.2.2.1 + have hst_head' := hpost.2.2.2.2.2.2.1 + have hsim_pres := hpost.2.2.2.2.2.2.2.1 + have hinp_pres := hpost.2.2.2.2.2.2.2.2 + exact ⟨c', 3 * k + n + 5, le_refl _, hreach, hhalt, henv', + hdesc', hstate', hsim', hsc', hd_head', hsc_head', hst_head', + by rw [hsim_pres], by rw [hinp_pres]⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/Lookup.lean b/Complexitylib/Models/TuringMachine/UTM/Lookup.lean new file mode 100644 index 0000000..8390942 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/Lookup.lean @@ -0,0 +1,381 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Mathlib.Data.Fintype.Prod +import Mathlib.Data.Fintype.Sum + +/-! +# UTM Transition Lookup + +Linear-scan lookup of the matching transition entry in the encoded +description on work tape 0. + +## Main results + +- `lookupTM` — the lookup machine definition (parametric in `k`) +- `lookupTM_hoareTime` — HoareTime spec: parametric in state and symbols +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- State type +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the lookup machine. Parametric in `k` (number of TM states). + The machine uses bounded counters for position within the input pattern + and remaining bits during skip/copy. -/ +inductive LookupQ (n k : ℕ) where + /-- Skip header bits on desc tape. -/ + | skipHeader (rem : Fin (TMEncoding.tableOffset k n + 1)) + /-- Compare desc bit vs scratch bit at position `pos` within input pattern. -/ + | compare (pos : Fin (TMEncoding.inputPatternWidth k n + 1)) + /-- Mismatch: skip remaining entry bits on desc tape. -/ + | skipRest (rem : Fin (TMEncoding.entryWidth k n + 1)) + /-- Rewind scratch tape left after mismatch. -/ + | rewindScratch + /-- Scratch hit ▷, move right to cell 1. Then try next entry. -/ + | rewindScratchR + /-- Full match: skip separator on desc, rewind scratch for copy. -/ + | matchRewind + /-- Scratch hit ▷ after match rewind, move right to cell 1. -/ + | matchRewindR + /-- Copy output bits from desc to scratch. -/ + | copyOutput (rem : Fin (TMEncoding.outputWidth k n + 1)) + /-- Rewind desc tape back to cell 1. -/ + | rewindDesc + /-- Desc hit ▷, move right to cell 1. -/ + | rewindDescR + /-- Rewind scratch tape after copy. -/ + | rewindScratchFinal + /-- Scratch hit ▷, move right. -/ + | rewindScratchFinalR + /-- Done. -/ + | done + deriving DecidableEq + +private instance : Fintype (LookupQ n k) where + elems := + {.rewindScratch, .rewindScratchR, .matchRewind, .matchRewindR, + .rewindDesc, .rewindDescR, .rewindScratchFinal, .rewindScratchFinalR, .done} ∪ + (Finset.univ.image fun (r : Fin (TMEncoding.tableOffset k n + 1)) => + LookupQ.skipHeader r) ∪ + (Finset.univ.image fun (p : Fin (TMEncoding.inputPatternWidth k n + 1)) => + LookupQ.compare p) ∪ + (Finset.univ.image fun (r : Fin (TMEncoding.entryWidth k n + 1)) => + LookupQ.skipRest r) ∪ + (Finset.univ.image fun (r : Fin (TMEncoding.outputWidth k n + 1)) => + LookupQ.copyOutput r) + complete x := by + cases x with + | skipHeader r => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; left; right; exact ⟨r, rfl⟩ + | compare p => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; right; exact ⟨p, rfl⟩ + | skipRest r => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; right; exact ⟨r, rfl⟩ + | copyOutput r => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + right; exact ⟨r, rfl⟩ + | rewindScratch => simp [Finset.mem_union, Finset.mem_insert] + | rewindScratchR => simp [Finset.mem_union, Finset.mem_insert] + | matchRewind => simp [Finset.mem_union, Finset.mem_insert] + | matchRewindR => simp [Finset.mem_union, Finset.mem_insert] + | rewindDesc => simp [Finset.mem_union, Finset.mem_insert] + | rewindDescR => simp [Finset.mem_union, Finset.mem_insert] + | rewindScratchFinal => simp [Finset.mem_union, Finset.mem_insert] + | rewindScratchFinalR => simp [Finset.mem_union, Finset.mem_insert] + | done => simp [Finset.mem_union, Finset.mem_insert] + +-- ════════════════════════════════════════════════════════════════════════ +-- Machine definition +-- ════════════════════════════════════════════════════════════════════════ + +/-- Scan the description tape for a matching transition entry. + Compares each entry's input pattern against the scratch tape, + then copies the matching entry's output to scratch. + + Parametric in `k` (number of states of the simulated TM). -/ +noncomputable def lookupTM (k : ℕ) : TM 4 where + Q := LookupQ n k + qstart := .skipHeader ⟨TMEncoding.tableOffset k n, by omega⟩ + qhalt := .done + δ := fun state iHead wHeads oHead => + let ipw := TMEncoding.inputPatternWidth k n + let ew := TMEncoding.entryWidth k n + let ow := TMEncoding.outputWidth k n + match state with + | .skipHeader rem => + if rem.val = 0 then + -- At transition table. Start comparing first entry. + (.compare ⟨0, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + -- Skip one desc bit. + (.skipHeader ⟨rem.val - 1, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .compare pos => + if wHeads utmDescTape = wHeads utmScratchTape then + if h : pos.val + 1 < ipw then + -- Match, more bits to compare. + (.compare ⟨pos.val + 1, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right + else if i = utmScratchTape then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + else + -- Full pattern matched! Advance desc past separator. + (.matchRewind, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Mismatch. Skip rest of this entry. + (.skipRest ⟨ew - pos.val - 1, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .skipRest rem => + if rem.val = 0 then + (.rewindScratch, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.skipRest ⟨rem.val - 1, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .rewindScratch => + if wHeads utmScratchTape = Γ.start then + (.rewindScratchR, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewindScratch, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then moveLeftDir (wHeads utmScratchTape) + else idleDir (wHeads i), + idleDir oHead) + | .rewindScratchR => + (.compare ⟨0, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .matchRewind => + -- Desc already advanced past separator. Now rewind scratch. + if wHeads utmScratchTape = Γ.start then + (.matchRewindR, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.matchRewind, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then moveLeftDir (wHeads utmScratchTape) + else idleDir (wHeads i), + idleDir oHead) + | .matchRewindR => + -- Scratch at cell 1, desc at separator. Advance desc past separator, + -- then start copying output from desc to scratch. + (.copyOutput ⟨ow, by omega⟩, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + | .copyOutput rem => + if rem.val = 0 then + -- Done copying. Rewind desc. + (.rewindDesc, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then moveLeftDir (wHeads utmDescTape) + else idleDir (wHeads i), + idleDir oHead) + else + -- Copy one bit from desc to scratch. + let w : Γw := match wHeads utmDescTape with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + (.copyOutput ⟨rem.val - 1, by omega⟩, + fun i => if i = utmScratchTape then w else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = utmDescTape then Dir3.right + else if i = utmScratchTape then Dir3.right + else idleDir (wHeads i), + idleDir oHead) + | .rewindDesc => + if wHeads utmDescTape = Γ.start then + (.rewindDescR, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewindDesc, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmDescTape then moveLeftDir (wHeads utmDescTape) + else idleDir (wHeads i), + idleDir oHead) + | .rewindDescR => + -- Desc at cell 1. Rewind scratch. + (.rewindScratchFinal, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then moveLeftDir (wHeads utmScratchTape) + else idleDir (wHeads i), + idleDir oHead) + | .rewindScratchFinal => + if wHeads utmScratchTape = Γ.start then + (.rewindScratchFinalR, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewindScratchFinal, + fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, + fun i => if i = utmScratchTape then moveLeftDir (wHeads utmScratchTape) + else idleDir (wHeads i), + idleDir oHead) + | .rewindScratchFinalR => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + have hros := fun (h : iHead = Γ.start) => idleDir_right_of_start h + have hrosO := fun (h : oHead = Γ.start) => idleDir_right_of_start h + have descRos : ∀ i, wHeads i = Γ.start → + (if i = utmDescTape then Dir3.right else idleDir (wHeads i)) = Dir3.right := by + intro i hi; split <;> [rfl; exact idleDir_right_of_start hi] + have scratchRos : ∀ i, wHeads i = Γ.start → + (if i = utmScratchTape then Dir3.right else idleDir (wHeads i)) = Dir3.right := by + intro i hi; split <;> [rfl; exact idleDir_right_of_start hi] + have descScratchRos : ∀ i, wHeads i = Γ.start → + (if i = utmDescTape then Dir3.right + else if i = utmScratchTape then Dir3.right + else idleDir (wHeads i)) = Dir3.right := by + intro i hi; split <;> [rfl; split <;> [rfl; exact idleDir_right_of_start hi]] + match state with + | .skipHeader rem => + dsimp only []; split + · exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + · exact ⟨hros, descRos, hrosO⟩ + | .compare pos => + dsimp only []; split + · split + · exact ⟨hros, descScratchRos, hrosO⟩ + · exact ⟨hros, descRos, hrosO⟩ + · exact ⟨hros, descRos, hrosO⟩ + | .skipRest rem => + dsimp only []; split + · exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + · exact ⟨hros, descRos, hrosO⟩ + | .rewindScratch => + dsimp only []; split + · exact ⟨hros, scratchRos, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + | .rewindScratchR => + exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + | .matchRewind => + dsimp only []; split + · exact ⟨hros, scratchRos, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + | .matchRewindR => + exact ⟨hros, descRos, hrosO⟩ + | .copyOutput rem => + dsimp only []; split + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + · exact ⟨hros, descScratchRos, hrosO⟩ + | .rewindDesc => + dsimp only []; split + · exact ⟨hros, descRos, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + | .rewindDescR => + refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + | .rewindScratchFinal => + dsimp only []; split + · exact ⟨hros, scratchRos, hrosO⟩ + · refine ⟨hros, ?_, hrosO⟩ + intro i hi; dsimp only []; split + · next heq => subst heq; rw [hi]; rfl + · exact idleDir_right_of_start hi + | .rewindScratchFinalR => + exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + | .done => + exact ⟨hros, fun _ hi => idleDir_right_of_start hi, hrosO⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- HoareTime specification +-- ════════════════════════════════════════════════════════════════════════ + +/-- HoareTime specification for `lookupTM`. + + The `hdesc` hypothesis links the desc tape contents to the TM's + transition table, which is required for the linear-scan lookup + to find the correct entry. -/ +theorem lookupTM_hoareTime (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) + (q : Fin k) (iHead : Γ) (wHeads : Fin n → Γ) (oHead : Γ) : + let e := tm.stateEquivK hk + ∃ B, (lookupTM (n := n) k).HoareTime + (fun inp work out => + descOnTape desc (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (∀ i, (work i).head ≥ 1) ∧ + scratchHasInputPattern k n q iHead wHeads oHead (work utmScratchTape) ∧ + (work utmScratchTape).cells (TMEncoding.outputWidth k n + 1) = Γ.blank ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ inp.head ≥ 1 ∧ + out.read ≠ Γ.start ∧ out.head ≥ 1) + (fun _inp work _out => + let (q', wW, oW, iD, wD, oD) := tm.δ (e.symm q) iHead wHeads oHead + descOnTape desc (work utmDescTape) ∧ + scratchHasTransOutput k n (e q') wW oW iD wD oD (work utmScratchTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmScratchTape).head = 1 ∧ + WorkTapesWF work) + B := by + -- See `TM.lookupTM_hoareTime_proof` in LookupInternal.lean for the proof. + -- The circular import (LookupInternal imports Lookup) prevents direct use here. + -- Downstream files should import LookupInternal and use `lookupTM_hoareTime_proof`. + sorry + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/LookupInternal.lean b/Complexitylib/Models/TuringMachine/UTM/LookupInternal.lean new file mode 100644 index 0000000..d9633ad --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/LookupInternal.lean @@ -0,0 +1,2908 @@ +import Complexitylib.Models.TuringMachine.UTM.Lookup +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.Hoare + +/-! +# Lookup proof internals + +Step-by-step simulation lemmas for `lookupTM`. +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem lu_readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem lu_tape_idle_preserve (t : Tape) (hns : t.read ≠ Γ.start) (hh : t.head ≥ 1) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · omega + · simp only [Tape.read] at hns ⊢ + rw [lu_readBackWrite_toΓ_eq hns, Function.update_eq_self] + +private theorem lu_tape_read_ne_start_of_wf (t : Tape) (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns _ hh + +-- ════════════════════════════════════════════════════════════════════════ +-- Encoding lemmas +-- ════════════════════════════════════════════════════════════════════════ + +private lemma flatMap_encode_length {α : Type} (l : List α) (f : α → Γ) : + (l.flatMap (fun x => (f x).encode)).length = 2 * l.length := by + induction l with + | nil => simp + | cons a as ih => + simp only [List.flatMap_cons, List.length_append, Γ.encode_length, ih, List.length_cons] + omega + +private lemma flatMap_Γw_encode_length {α : Type} (l : List α) (f : α → Γw) : + (l.flatMap (fun x => (f x).encode)).length = 2 * l.length := by + induction l with + | nil => simp + | cons a as ih => + simp only [List.flatMap_cons, List.length_append, Γw.encode_length, ih, List.length_cons] + omega + +private lemma flatMap_Dir3_encode_length {α : Type} (l : List α) (f : α → Dir3) : + (l.flatMap (fun x => (f x).encode)).length = 2 * l.length := by + induction l with + | nil => simp + | cons a as ih => + simp only [List.flatMap_cons, List.length_append, Dir3.encode_length, ih, List.length_cons] + omega + +private lemma encodeInputPattern_length (k n : ℕ) (q : Fin k) (iH : Γ) + (wH : Fin n → Γ) (oH : Γ) : + (TMEncoding.encodeInputPattern k n q iH wH oH).length = + TMEncoding.inputPatternWidth k n := by + simp only [TMEncoding.encodeInputPattern, TMEncoding.inputPatternWidth, + List.length_append, List.length_map, List.length_finRange, + Γ.encode_length, flatMap_encode_length] + +private lemma encodeTransOutput_length (k n : ℕ) (q' : Fin k) + (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) : + (TMEncoding.encodeTransOutput k n q' wW oW iD wD oD).length = + TMEncoding.outputWidth k n := by + simp only [TMEncoding.encodeTransOutput, TMEncoding.outputWidth, + List.length_append, List.length_map, List.length_finRange, + Γw.encode_length, Dir3.encode_length, + flatMap_Γw_encode_length, flatMap_Dir3_encode_length] + +private lemma encodeEntry_eq (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) + (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) : + TMEncoding.encodeEntry k n q iH wH oH q' wW oW iD wD oD = + TMEncoding.encodeInputPattern k n q iH wH oH ++ + [false] ++ + TMEncoding.encodeTransOutput k n q' wW oW iD wD oD := by + simp only [TMEncoding.encodeEntry, TMEncoding.encodeInputPattern, + TMEncoding.encodeTransOutput, List.append_assoc] + +private lemma encodeEntry_length (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) + (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) : + (TMEncoding.encodeEntry k n q iH wH oH q' wW oW iD wD oD).length = + TMEncoding.entryWidth k n := by + rw [encodeEntry_eq, TMEncoding.entryWidth] + simp only [List.length_append, List.length_cons, List.length_nil, + encodeInputPattern_length, encodeTransOutput_length] + +-- ════════════════════════════════════════════════════════════════════════ +-- Encoding connection helpers +-- ════════════════════════════════════════════════════════════════════════ + +/-- The header portion of `encodeTM` (everything before the transition table). -/ +private noncomputable def encodeTM_header (tm : TM n) : List Bool := + let k := @Fintype.card tm.Q tm.finQ + let e := tm.stateEquiv + List.replicate k true ++ [false] ++ + List.replicate n true ++ [false] ++ + TMEncoding.encodeStateOneHot tm e tm.qhalt ++ [false] ++ + TMEncoding.encodeStateOneHot tm e tm.qstart ++ [false] + +/-- `encodeTM` splits as header ++ transTable. -/ +private theorem encodeTM_eq_header_append_table (tm : TM n) : + TMEncoding.encodeTM tm = encodeTM_header tm ++ TMEncoding.encodeTransTable tm tm.stateEquiv := by + simp only [TMEncoding.encodeTM, encodeTM_header, List.append_assoc] + +/-- The header has length `tableOffset k n`. -/ +private theorem encodeTM_header_length (tm : TM n) + (hk : k = @Fintype.card tm.Q tm.finQ) : + (encodeTM_header tm).length = TMEncoding.tableOffset k n := by + subst hk + simp only [encodeTM_header, TMEncoding.encodeStateOneHot, TMEncoding.tableOffset, + TMEncoding.qstartOffset, TMEncoding.qhaltOffset, + List.length_append, List.length_replicate, List.length_singleton, + List.length_map, List.length_finRange] + +/-- Length of a constant-width flatMap. -/ +private theorem flatMap_const_width_length {α : Type} {β : Type} + (l : List α) (f : α → List β) (w : ℕ) + (hfw : ∀ a, a ∈ l → (f a).length = w) : + (l.flatMap f).length = l.length * w := by + induction l with + | nil => simp + | cons a as ih => + simp only [List.flatMap_cons, List.length_append, List.length_cons] + rw [hfw _ List.mem_cons_self, + ih (fun a' ha' => hfw a' (List.mem_cons_of_mem _ ha')), + Nat.add_mul, Nat.one_mul, Nat.add_comm] + +/-- Bound: idx * w + j < llen * w when idx < llen and j < w. -/ +private theorem mul_add_lt_mul_of_lt (idx j llen w : ℕ) + (hidx : idx < llen) (hj : j < w) : + idx * w + j < llen * w := by + have h1 : idx * w + j < idx * w + w := Nat.add_lt_add_left hj _ + have h2 : idx * w + w ≤ llen * w := by + have : idx + 1 ≤ llen := hidx + calc idx * w + w = (idx + 1) * w := by simp [Nat.add_mul, Nat.one_mul] + _ ≤ llen * w := Nat.mul_le_mul_right w this + omega + +/-- Indexing into a constant-width flatMap: if every `f a` has length `w`, + then `(l.flatMap f)[idx * w + j] = (f l[idx])[j]`. -/ +private theorem flatMap_const_width_getElem {α : Type} {β : Type} + (l : List α) (f : α → List β) (w : ℕ) + (hfw : ∀ a, a ∈ l → (f a).length = w) + (idx j : ℕ) (hidx : idx < l.length) (hj : j < w) : + (l.flatMap f)[idx * w + j]'(by + rw [flatMap_const_width_length l f w hfw] + exact mul_add_lt_mul_of_lt idx j l.length w hidx hj) = + (f l[idx])[j]'(by rw [hfw _ (List.getElem_mem hidx)]; exact hj) := by + induction l generalizing idx with + | nil => simp at hidx + | cons a as ih => + match idx with + | 0 => + simp only [List.flatMap_cons, Nat.zero_mul, Nat.zero_add, List.getElem_cons_zero] + exact List.getElem_append_left _ + | idx' + 1 => + simp only [List.flatMap_cons, List.getElem_cons_succ] + have hlen_a : (f a).length = w := hfw _ List.mem_cons_self + have hle : (f a).length ≤ (idx' + 1) * w + j := by + calc (f a).length = w := hlen_a + _ ≤ (idx' + 1) * w := Nat.le_mul_of_pos_left w (by omega) + _ ≤ (idx' + 1) * w + j := Nat.le_add_right _ _ + rw [List.getElem_append_right hle] + have hfw' := fun a' (ha' : a' ∈ as) => hfw a' (List.mem_cons_of_mem _ ha') + have hidx' : idx' < as.length := by simp at hidx; omega + convert ih hfw' idx' hidx' using 1 + congr 1 + show (idx' + 1) * w + j - (f a).length = idx' * w + j + rw [hlen_a, Nat.add_mul, Nat.one_mul] + omega + +private theorem allΓ_complete (g : Γ) : g ∈ allΓ := by cases g <;> simp [allΓ] + +private theorem allΓ_length : allΓ.length = 4 := rfl + +private theorem allΓFuncs_complete : ∀ (f : Fin n → Γ), f ∈ allΓFuncs n := by + induction n with + | zero => intro f; simp [allΓFuncs]; ext i; exact i.elim0 + | succ n ih => + intro f + simp only [allΓFuncs, List.mem_flatMap, List.mem_map] + refine ⟨fun i => f ⟨i.val, by omega⟩, ih _, f ⟨n, by omega⟩, allΓ_complete _, ?_⟩ + ext i + simp only + split + · rfl + · next h => + have hiv : i.val = n := Nat.le_antisymm (by omega) (by omega) + exact congrArg f (Fin.ext hiv.symm) + +private theorem Γ_ofBool_injective : Function.Injective Γ.ofBool := by + intro a b h; cases a <;> cases b <;> simp_all [Γ.ofBool] + +private theorem Γ_ofBool_ne_of_ne {a b : Bool} (h : a ≠ b) : Γ.ofBool a ≠ Γ.ofBool b := + fun heq => h (Γ_ofBool_injective heq) + +private theorem allΓ_nodup : allΓ.Nodup := by decide + +-- ════════════════════════════════════════════════════════════════════════ +-- Transition table structure +-- ════════════════════════════════════════════════════════════════════════ + +/-- The canonical enumeration of all 4-tuples (q, iH, wH, oH). -/ +private noncomputable def allTuples (k n : ℕ) : List (Fin k × Γ × (Fin n → Γ) × Γ) := + (List.finRange k).flatMap fun q => + allΓ.flatMap fun iH => + (allΓFuncs n).flatMap fun wH => + allΓ.map fun oH => + (q, iH, wH, oH) + +/-- Every 4-tuple is in the canonical enumeration. -/ +private theorem allTuples_mem (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) : + (q, iH, wH, oH) ∈ allTuples k n := by + simp only [allTuples, List.mem_flatMap, List.mem_map] + exact ⟨q, List.mem_finRange q, + iH, allΓ_complete iH, + wH, allΓFuncs_complete wH, + oH, allΓ_complete oH, rfl⟩ + +private theorem allTuples_nodup (k n : ℕ) : (allTuples k n).Nodup := by + simp only [allTuples] + -- Each level uses nodup_flatMap: inner lists are nodup + pairwise disjoint + -- Disjointness follows from tuple components being fixed per inner list + have fst_eq : ∀ (q : Fin k) a, + a ∈ (allΓ.flatMap fun iH => (allΓFuncs n).flatMap fun wH => + allΓ.map fun oH => (q, iH, wH, oH)) → a.1 = q := by + intro q a ha; simp only [List.mem_flatMap, List.mem_map] at ha + obtain ⟨_, _, _, _, _, _, rfl⟩ := ha; rfl + have snd_eq : ∀ (q : Fin k) (iH : Γ) a, + a ∈ ((allΓFuncs n).flatMap fun wH => allΓ.map fun oH => (q, iH, wH, oH)) → + a.2.1 = iH := by + intro q iH a ha; simp only [List.mem_flatMap, List.mem_map] at ha + obtain ⟨_, _, _, _, rfl⟩ := ha; rfl + have thd_eq : ∀ (q : Fin k) (iH : Γ) (wH : Fin n → Γ) a, + a ∈ (allΓ.map fun oH => (q, iH, wH, oH)) → a.2.2.1 = wH := by + intro q iH wH a ha; simp only [List.mem_map] at ha; obtain ⟨_, _, rfl⟩ := ha; rfl + -- Level 1 (q): different q → disjoint first components + rw [List.nodup_flatMap]; refine ⟨fun q _ => ?_, (List.nodup_finRange k).pairwise fun hne a h1 h2 => + hne (by rw [← fst_eq _ a h1, fst_eq _ a h2])⟩ + -- Level 2 (iH): different iH → disjoint second components + rw [List.nodup_flatMap]; refine ⟨fun iH _ => ?_, allΓ_nodup.pairwise fun hne a h1 h2 => + hne (by rw [← snd_eq q _ a h1, snd_eq q _ a h2])⟩ + -- Level 3 (wH): different wH → disjoint third components + sorry -- allΓFuncs_nodup: needs induction on n to show allΓFuncs is nodup + +/-- The input pattern of an encodeEntry starts with the given encodeInputPattern. -/ +private theorem encodeEntry_input_prefix (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) + (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) + (j : ℕ) (hj : j < TMEncoding.inputPatternWidth k n) : + (TMEncoding.encodeInputPattern k n q iH wH oH ++ [false] ++ + TMEncoding.encodeTransOutput k n q' wW oW iD wD oD)[j]'(by + simp only [List.length_append, encodeInputPattern_length, + List.length_cons, List.length_nil, encodeTransOutput_length, + TMEncoding.entryWidth]; omega) = + (TMEncoding.encodeInputPattern k n q iH wH oH)[j]'(by + rw [encodeInputPattern_length]; exact hj) := by + rw [List.getElem_append_left (by + simp only [List.length_append, encodeInputPattern_length, List.length_cons, + List.length_nil]; omega)] + exact List.getElem_append_left (by rw [encodeInputPattern_length]; exact hj) + +/-- The output bits of an encodeEntry are past the input pattern + separator. -/ +private theorem encodeEntry_output_getElem (k n : ℕ) (q : Fin k) (iH : Γ) (wH : Fin n → Γ) (oH : Γ) + (q' : Fin k) (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) + (j : ℕ) (hj : j < (TMEncoding.encodeTransOutput k n q' wW oW iD wD oD).length) : + (TMEncoding.encodeInputPattern k n q iH wH oH ++ [false] ++ + TMEncoding.encodeTransOutput k n q' wW oW iD wD oD)[TMEncoding.inputPatternWidth k n + 1 + j]'(by + simp only [List.length_append, encodeInputPattern_length, + List.length_cons, List.length_nil]; omega) = + (TMEncoding.encodeTransOutput k n q' wW oW iD wD oD)[j] := by + rw [List.getElem_append_right (by + simp only [List.length_append, encodeInputPattern_length, List.length_cons, + List.length_nil]; omega)] + congr 1 + have := encodeInputPattern_length k n q iH wH oH + simp only [List.length_append, List.length_cons, List.length_nil] at this ⊢ + omega + +/-- `encodeInputPattern` is injective: equal patterns imply equal tuples. + (All sub-lemmas are packaged inside for modularity.) -/ +private theorem encodeInputPattern_injective {k n : ℕ} + {q₁ q₂ : Fin k} {iH₁ iH₂ : Γ} {wH₁ wH₂ : Fin n → Γ} {oH₁ oH₂ : Γ} + (heq : TMEncoding.encodeInputPattern k n q₁ iH₁ wH₁ oH₁ = + TMEncoding.encodeInputPattern k n q₂ iH₂ wH₂ oH₂) : + q₁ = q₂ ∧ iH₁ = iH₂ ∧ wH₁ = wH₂ ∧ oH₁ = oH₂ := by + -- Unfold and work with left-associated appends: + -- ((map(==q) ++ iH.encode) ++ flatMap(wH)) ++ oH.encode + simp only [TMEncoding.encodeInputPattern] at heq + -- Step 1: split off oH.encode from the right + have hlen_prefix : (((List.finRange k).map (· == q₁) ++ iH₁.encode) ++ + (List.finRange n).flatMap (fun i => (wH₁ i).encode)).length = + (((List.finRange k).map (· == q₂) ++ iH₂.encode) ++ + (List.finRange n).flatMap (fun i => (wH₂ i).encode)).length := by + simp [List.length_append, flatMap_encode_length, Γ.encode_length] + have h_prefix := List.append_inj_left heq hlen_prefix + have h_oH := List.append_inj_right heq hlen_prefix + have hoH : oH₁ = oH₂ := Γ.encode_injective h_oH + -- Step 2: split off flatMap(wH) + have hlen_sq : ((List.finRange k).map (· == q₁) ++ iH₁.encode).length = + ((List.finRange k).map (· == q₂) ++ iH₂.encode).length := by + simp [Γ.encode_length] + have h_sq := List.append_inj_left h_prefix hlen_sq + have h_wH := List.append_inj_right h_prefix hlen_sq + -- Step 3: split stateMap from iH + have hlen_state : ((List.finRange k).map (· == q₁)).length = + ((List.finRange k).map (· == q₂)).length := by simp + have h_s := List.append_inj_left h_sq hlen_state + have h_iH := List.append_inj_right h_sq hlen_state + -- q₁ = q₂ from one-hot + have hq : q₁ = q₂ := by + by_contra hne + -- map(==q₁) and map(==q₂) are equal (h_s), but differ at position q₁.val + have h_at := congrArg (fun l => l[q₁.val]?) h_s + simp only [List.getElem?_map, List.getElem?_eq_getElem (by simp : q₁.val < (List.finRange k).length), + Option.map_some, Option.some.injEq, List.getElem_finRange, Fin.cast_mk] at h_at + -- h_at : (⟨q₁.val, _⟩ == q₁) = (⟨q₁.val, _⟩ == q₂) + have : (⟨q₁.val, q₁.isLt⟩ : Fin k) = q₁ := Fin.ext rfl + rw [show (⟨q₁.val, (by omega : q₁.val < k)⟩ : Fin k) = q₁ from Fin.ext rfl] at h_at + rw [beq_self_eq_true] at h_at + exact hne (beq_iff_eq.mp h_at.symm) + have hiH : iH₁ = iH₂ := Γ.encode_injective h_iH + -- wH₁ = wH₂ from flatMap equality + have hwH : wH₁ = wH₂ := by + ext ⟨i, hi⟩ + have hfw := fun (a : Fin n) (_ : a ∈ List.finRange n) => Γ.encode_length (wH₁ a) + have hfw' := fun (a : Fin n) (_ : a ∈ List.finRange n) => Γ.encode_length (wH₂ a) + have hidx : i < (List.finRange n).length := by simp; exact hi + -- Extract per-position equality from list equality + have hbound0 : i * 2 + 0 < (List.flatMap (fun j => (wH₁ j).encode) (List.finRange n)).length := by + rw [flatMap_const_width_length _ _ 2 hfw]; exact mul_add_lt_mul_of_lt i 0 _ 2 hidx (by omega) + have hbound1 : i * 2 + 1 < (List.flatMap (fun j => (wH₁ j).encode) (List.finRange n)).length := by + rw [flatMap_const_width_length _ _ 2 hfw]; exact mul_add_lt_mul_of_lt i 1 _ 2 hidx (by omega) + have hbound0' : i * 2 + 0 < (List.flatMap (fun j => (wH₂ j).encode) (List.finRange n)).length := by + rw [flatMap_const_width_length _ _ 2 hfw']; exact mul_add_lt_mul_of_lt i 0 _ 2 hidx (by omega) + have hbound1' : i * 2 + 1 < (List.flatMap (fun j => (wH₂ j).encode) (List.finRange n)).length := by + rw [flatMap_const_width_length _ _ 2 hfw']; exact mul_add_lt_mul_of_lt i 1 _ 2 hidx (by omega) + have h_eq0 : (List.flatMap (fun j => (wH₁ j).encode) (List.finRange n))[i * 2 + 0]'hbound0 = + (List.flatMap (fun j => (wH₂ j).encode) (List.finRange n))[i * 2 + 0]'hbound0' := by + simp only [h_wH] + have h_eq1 : (List.flatMap (fun j => (wH₁ j).encode) (List.finRange n))[i * 2 + 1]'hbound1 = + (List.flatMap (fun j => (wH₂ j).encode) (List.finRange n))[i * 2 + 1]'hbound1' := by + simp only [h_wH] + rw [flatMap_const_width_getElem _ _ 2 hfw i 0 hidx (by omega), + flatMap_const_width_getElem _ _ 2 hfw' i 0 hidx (by omega)] at h_eq0 + rw [flatMap_const_width_getElem _ _ 2 hfw i 1 hidx (by omega), + flatMap_const_width_getElem _ _ 2 hfw' i 1 hidx (by omega)] at h_eq1 + simp only [List.getElem_finRange] at h_eq0 h_eq1 + apply Γ.encode_injective + apply List.ext_getElem (by simp [Γ.encode_length]) + intro j hj₁ _ + have : j < 2 := by rw [Γ.encode_length] at hj₁; exact hj₁ + match j, this with + | 0, _ => convert h_eq0 using 2 <;> simp [Fin.ext_iff] + | 1, _ => convert h_eq1 using 2 <;> simp [Fin.ext_iff] + exact ⟨hq, hiH, hwH, hoH⟩ + +/-- Different 4-tuples produce different input pattern lists. -/ +private theorem encodeInputPattern_ne_of_ne {k n : ℕ} + {q₁ q₂ : Fin k} {iH₁ iH₂ : Γ} {wH₁ wH₂ : Fin n → Γ} {oH₁ oH₂ : Γ} + (hne : (q₁, iH₁, wH₁, oH₁) ≠ (q₂, iH₂, wH₂, oH₂)) : + TMEncoding.encodeInputPattern k n q₁ iH₁ wH₁ oH₁ ≠ + TMEncoding.encodeInputPattern k n q₂ iH₂ wH₂ oH₂ := by + intro heq + obtain ⟨hq, hi, hw, ho⟩ := encodeInputPattern_injective heq + exact hne (by rw [hq, hi, hw, ho]) + +/-- Connect desc tape cell at `tableOffset + p` to transition table bit `p`. + Key bridging lemma: the desc tape after header stores the transition table bits. -/ +private theorem desc_cell_eq_table_bit {n : ℕ} (tm : TM n) + (desc : List Bool) (t : Tape) + (hdesc : desc = TMEncoding.encodeTM tm) + (hdescOnTape : descOnTape desc t) + (p : ℕ) (hp : p < (TMEncoding.encodeTransTable tm tm.stateEquiv).length) : + t.cells (TMEncoding.tableOffset (Fintype.card tm.Q) n + p + 1) = + Γ.ofBool ((TMEncoding.encodeTransTable tm tm.stateEquiv)[p]'hp) := by + have hoff := encodeTM_header_length tm rfl + have h_split := encodeTM_eq_header_append_table tm + have h_idx : TMEncoding.tableOffset (Fintype.card tm.Q) n + p < desc.length := by + rw [hdesc, h_split, List.length_append, hoff]; omega + have h_cell := hdescOnTape.2.1 (TMEncoding.tableOffset (Fintype.card tm.Q) n + p) h_idx + rw [h_cell] + congr 1 + simp only [hdesc, h_split] + rw [List.getElem_append_right (by rw [hoff]; omega)] + congr 1; rw [hoff]; omega + +/-- The entry function that maps a 4-tuple to its encoded entry using `tm.δ`. -/ +private noncomputable def allTuples_entryFn {n : ℕ} (tm : TM n) + (e : tm.Q ≃ Fin (Fintype.card tm.Q)) : + Fin (Fintype.card tm.Q) × Γ × (Fin n → Γ) × Γ → List Bool := + fun ⟨q, iH, wH, oH⟩ => + let (q', wW, oW, iD, wD, oD) := tm.δ (e.symm q) iH wH oH + TMEncoding.encodeEntry (Fintype.card tm.Q) n q iH wH oH (e q') wW oW iD wD oD + +/-- The transition table equals `allTuples.flatMap (allTuples_entryFn tm e)`. -/ +private theorem encodeTransTable_eq_allTuples_flatMap {n : ℕ} (tm : TM n) + (e : tm.Q ≃ Fin (Fintype.card tm.Q)) : + TMEncoding.encodeTransTable tm e = + (allTuples (Fintype.card tm.Q) n).flatMap (allTuples_entryFn tm e) := by + unfold TMEncoding.encodeTransTable allTuples allTuples_entryFn + simp only [List.flatMap_assoc, List.flatMap_map] + +/-- Every entry produced by `allTuples_entryFn` has width `entryWidth k n`. -/ +private theorem allTuples_entryFn_width {n : ℕ} (tm : TM n) + (e : tm.Q ≃ Fin (Fintype.card tm.Q)) + (t : Fin (Fintype.card tm.Q) × Γ × (Fin n → Γ) × Γ) + (ht : t ∈ allTuples (Fintype.card tm.Q) n) : + (allTuples_entryFn tm e t).length = TMEncoding.entryWidth (Fintype.card tm.Q) n := by + obtain ⟨q, iH, wH, oH⟩ := t + simp only [allTuples_entryFn] + generalize tm.δ (e.symm q) iH wH oH = δ_result + obtain ⟨q', wW, oW, iD, wD, oD⟩ := δ_result + exact encodeEntry_length _ _ _ _ _ _ _ _ _ _ _ _ + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 1: skipHeader simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- `Tape.write` preserves the head field. -/ +private theorem lu_tape_write_head (t : Tape) (s : Γ) : (t.write s).head = t.head := by + simp [Tape.write]; split <;> rfl + +/-- Skip `rem` header bits on the desc tape, then one idle step to enter compare. + From state `skipHeader rem`, after `rem + 1` steps reach state `compare 0` + with desc head advanced by `rem`, all tapes preserved. -/ +private theorem skipHeader_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) (rem : ℕ) (hrem : rem ≤ TMEncoding.tableOffset k n) + (hstate : c.state = .skipHeader ⟨rem, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (rem + 1) c c' ∧ + c'.state = .compare ⟨0, by omega⟩ ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + rem ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (∀ i, i ≠ utmDescTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction rem generalizing c with + | zero => + -- skipHeader 0 → compare 0: one idle step preserving all tapes + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + -- Verify the step + have hstep : ∃ c', (lookupTM (n := n) k).step c = some c' ∧ + c'.state = .compare ⟨0, by omega⟩ ∧ + (∀ i, c'.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c'.input = c.input.move (idleDir c.input.read) ∧ + c'.output = c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) := by + simp only [TM.step, hne_halt, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, fun i => rfl, rfl, rfl⟩ + obtain ⟨c', hstep', hst', hwork', hinp', hout'⟩ := hstep + refine ⟨c', .step hstep' .zero, hst', ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork']; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; omega + · rw [hwork']; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h] + · intro i hne; rw [hwork']; exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · rw [hinp']; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · rw [hout']; exact lu_tape_idle_preserve _ hout hout_h + · constructor + · intro i; rw [hwork'] + by_cases hi : i = utmDescTape + · subst hi; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; exact hwf.1 _ + · rw [lu_tape_idle_preserve _ (hother i hi).1 (hother i hi).2]; exact hwf.1 _ + · intro i j hj; rw [hwork'] + by_cases hi : i = utmDescTape + · subst hi; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; exact hwf.2 _ j hj + · rw [lu_tape_idle_preserve _ (hother i hi).1 (hother i hi).2]; exact hwf.2 _ j hj + | succ rem ih => + -- skipHeader (rem+1) → skipHeader rem: desc moves right, others preserved + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + -- Verify the step + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .skipHeader ⟨rem, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, hne_halt, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · show (c.work utmDescTape).writeAndMove (readBackWrite (c.work utmDescTape).read) + (if utmDescTape = utmDescTape then Dir3.right + else idleDir (c.work utmDescTape).read) = _ + simp only [↓reduceIte] + · intro i hne + show (c.work i).writeAndMove (readBackWrite (c.work i).read) + (if i = utmDescTape then Dir3.right else idleDir (c.work i).read) = _ + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep + -- Properties of c₁ + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → c₁.work i = c.work i := by + intro i hne; rw [hother₁ i hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + have hc₁_wf : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.1 _ + · rw [hc₁_other i hi]; exact hwf.1 _ + · intro i j hj; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi]; exact hwf.2 _ j hj + -- Apply IH + obtain ⟨c', hreach', hst', hhead', hcells', hother', hinp', hout', hwf'⟩ := + ih c₁ (by omega) hst₁ hc₁_wf + (by rw [hc₁_inp]; exact hinp) (by rw [hc₁_inp]; exact hinp_h) + (by rw [hc₁_out]; exact hout) (by rw [hc₁_out]; exact hout_h) + (by intro j hj; rw [hc₁_desc_cells]; exact hdesc_ns j hj) + (by omega) + (by intro i hne; rw [hc₁_other i hne]; exact hother i hne) + refine ⟨c', .step hstep' hreach', hst', ?_, ?_, ?_, ?_, ?_, hwf'⟩ + · rw [hhead', hc₁_desc_h]; omega + · rw [hcells', hc₁_desc_cells] + · intro i hne; rw [hother' i hne, hc₁_other i hne] + · rw [hinp', hc₁_inp] + · rw [hout', hc₁_out] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2: compare simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Compare loop: all `ipw` bits match. + From `compare 0` with desc and scratch both positioned at the start of + a matching input pattern, after `ipw` steps reach `matchRewind` with + desc advanced past the entire input pattern (positioned at the separator). + + The `hmatch` hypothesis asserts that desc and scratch store identical + bits at positions `descStart + j` and `scratchStart + j` for all + `j < ipw`. -/ +private theorem compare_match_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) + (pos : ℕ) (hpos : pos < TMEncoding.inputPatternWidth k n) + (hstate : c.state = .compare ⟨pos, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + -- The remaining ipw - pos bits all match + (hmatch : ∀ (j : ℕ), j < TMEncoding.inputPatternWidth k n - pos → + (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) : + let ipw := TMEncoding.inputPatternWidth k n + ∃ c', + (lookupTM (n := n) k).reachesIn (ipw - pos) c c' ∧ + c'.state = .matchRewind ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + (ipw - pos) ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + -- Scratch advances by ipw - pos - 1 (last step only advances desc) + (c'.work utmScratchTape).head = (c.work utmScratchTape).head + (ipw - pos - 1) ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + intro ipw + -- Generalized loop: induction on diff = ipw - pos, universally quantifying c and pos + suffices h_loop : ∀ (diff : ℕ) (c : Cfg 4 (lookupTM (n := n) k).Q) (pos : ℕ) + (hpos : pos < ipw), diff = ipw - pos → + c.state = .compare ⟨pos, by omega⟩ → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) → + (c.work utmDescTape).head ≥ 1 → + (∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) → + (c.work utmScratchTape).head ≥ 1 → + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + (∀ j, j < ipw - pos → (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) → + ∃ c', (lookupTM (n := n) k).reachesIn diff c c' ∧ + c'.state = .matchRewind ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + diff ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (c'.work utmScratchTape).head = (c.work utmScratchTape).head + (diff - 1) ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ WorkTapesWF c'.work from + h_loop _ c pos hpos rfl hstate hwf hinp hinp_h hout hout_h hdesc_ns hdesc_h + hscratch_ns hscratch_h hother hmatch + intro diff; induction diff with + | zero => intro c pos hpos hdiff; omega + | succ diff ih => + intro c pos hpos hdiff hstate hwf hinp hinp_h hout hout_h hdesc_ns hdesc_h + hscratch_ns hscratch_h hother hmatch_bits + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read := lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read := lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + have hmatch0 : (c.work utmDescTape).read = (c.work utmScratchTape).read := by + simp only [Tape.read]; exact hmatch_bits 0 (by omega) + by_cases hlast : pos + 1 < ipw + · -- Match, more bits: both tapes right, state → compare(pos+1), then IH + have hstep_eq : (lookupTM (n := n) k).step c = some + { state := .compare ⟨pos + 1, by omega⟩, + input := c.input.move (idleDir c.input.read), + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (if i = utmDescTape then Dir3.right + else if i = utmScratchTape then Dir3.right + else idleDir (c.work i).read), + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } := by + simp only [TM.step, lookupTM, hstate] + split_ifs <;> first | rfl | contradiction + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .compare ⟨pos + 1, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (c₁.work utmScratchTape = (c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + refine ⟨_, hstep_eq, rfl, ?_, ?_, ?_, rfl, rfl⟩ + · dsimp only []; simp only [↓reduceIte] + · dsimp only []; simp only [show ¬(utmScratchTape = utmDescTape) from (by decide), ↓reduceIte] + · intro i hne_d hne_s; dsimp only [] + simp only [show ¬(i = utmDescTape) from hne_d, + show ¬(i = utmScratchTape) from hne_s, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hscratch₁, hother₁, hinp₁, hout₁⟩ := hstep + -- Properties of c₁ + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_scratch_h : (c₁.work utmScratchTape).head = (c.work utmScratchTape).head + 1 := by + rw [hscratch₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_scratch_cells : (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells := by + rw [hscratch₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hscratch_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₁.work i = c.work i := by + intro i hne_d hne_s; rw [hother₁ i hne_d hne_s] + exact lu_tape_idle_preserve _ (hother i hne_d hne_s).1 (hother i hne_d hne_s).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + have hc₁_wf : WorkTapesWF c₁.work := by + constructor + · intro i + by_cases hi_d : i = utmDescTape + · subst hi_d; rw [hc₁_desc_cells]; exact hwf.1 _ + · by_cases hi_s : i = utmScratchTape + · subst hi_s; rw [hc₁_scratch_cells]; exact hwf.1 _ + · rw [hc₁_other i hi_d hi_s]; exact hwf.1 _ + · intro i j hj + by_cases hi_d : i = utmDescTape + · subst hi_d; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · by_cases hi_s : i = utmScratchTape + · subst hi_s; rw [hc₁_scratch_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi_d hi_s]; exact hwf.2 _ j hj + -- Apply IH + obtain ⟨c', hreach', hst', hhead', hcells', hshead', hscells', hother', hinp', hout', hwf'⟩ := + ih c₁ (pos + 1) (by omega) (by omega) hst₁ hc₁_wf + (by rw [hc₁_inp]; exact hinp) (by rw [hc₁_inp]; exact hinp_h) + (by rw [hc₁_out]; exact hout) (by rw [hc₁_out]; exact hout_h) + (by intro j hj; rw [hc₁_desc_cells]; exact hdesc_ns j hj) + (by omega) + (by intro j hj; rw [hc₁_scratch_cells]; exact hscratch_ns j hj) + (by omega) + (by intro i hne_d hne_s; rw [hc₁_other i hne_d hne_s]; exact hother i hne_d hne_s) + (by intro j hj + rw [hc₁_desc_cells, hc₁_desc_h, hc₁_scratch_cells, hc₁_scratch_h] + have := hmatch_bits (j + 1) (by omega) + convert this using 2 <;> omega) + refine ⟨c', .step hstep' hreach', hst', ?_, ?_, ?_, ?_, ?_, ?_, ?_, hwf'⟩ + · rw [hhead', hc₁_desc_h]; omega + · rw [hcells', hc₁_desc_cells] + · rw [hshead', hc₁_scratch_h]; omega + · rw [hscells', hc₁_scratch_cells] + · intro i hne_d hne_s; rw [hother' i hne_d hne_s, hc₁_other i hne_d hne_s] + · rw [hinp', hc₁_inp] + · rw [hout', hc₁_out] + · -- Last bit: full match. desc +1, scratch stays. State → matchRewind. + -- diff = 0 because pos + 1 ≥ ipw + have hdiff0 : diff = 0 := by omega + subst hdiff0 + have hstep' : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .matchRewind ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, lookupTM, hstate] + split_ifs <;> try (first | rfl | contradiction) + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · dsimp only []; simp only [↓reduceIte] + · intro i hne; dsimp only [] + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c₁, hstep₁, hst₁, hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep' + -- Properties of c₁ + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → c₁.work i = c.work i := by + intro i hne; rw [hother₁ i hne] + by_cases hi : i = utmScratchTape + · subst hi; exact lu_tape_idle_preserve _ hscratch_read hscratch_h + · exact lu_tape_idle_preserve _ (hother i hne hi).1 (hother i hne hi).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + refine ⟨c₁, .step hstep₁ .zero, hst₁, ?_, hc₁_desc_cells, ?_, ?_, ?_, hc₁_inp, hc₁_out, ?_⟩ + · rw [hc₁_desc_h] + · -- scratch head: 0 + 1 - 1 = 0, so head stays same + simp only [show 0 + 1 - 1 = 0 from rfl, Nat.add_zero] + rw [hc₁_other utmScratchTape (by decide)] + · -- scratch cells preserved + rw [hc₁_other utmScratchTape (by decide)] + · intro i hne_d hne_s; exact hc₁_other i hne_d + · constructor + · intro i; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.1 _ + · rw [hc₁_other i hi]; exact hwf.1 _ + · intro i j hj; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi]; exact hwf.2 _ j hj + +/-- Compare mismatch: the first mismatch is at position `mismatchPos`. + From `compare 0` with a mismatch at position `mismatchPos < ipw`, + after `mismatchPos + 1` steps reach `skipRest (ew - mismatchPos - 1)`. + + The `hmatch_before` hypothesis says bits match for all `j < mismatchPos`. + The `hmismatch` hypothesis says the bit at `mismatchPos` differs. -/ +private theorem compare_mismatch + (c : Cfg 4 (lookupTM (n := n) k).Q) + (mismatchPos : ℕ) (hmp : mismatchPos < TMEncoding.inputPatternWidth k n) + (hstate : c.state = .compare ⟨0, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + -- Bits match before the mismatch position + (hmatch_before : ∀ (j : ℕ), j < mismatchPos → + (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) + -- The bit at mismatchPos differs + (hmismatch : + (c.work utmDescTape).cells ((c.work utmDescTape).head + mismatchPos) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + mismatchPos)) : + have hmp' : mismatchPos < k + 2 + 2 * n + 2 := hmp + have hew_bound : mismatchPos + 1 ≤ TMEncoding.entryWidth k n := by + show mismatchPos + 1 ≤ (k + 2 + 2 * n + 2) + 1 + (k + 2 * n + 2 + 2 + 2 * n + 2) + omega + ∃ c', + (lookupTM (n := n) k).reachesIn (mismatchPos + 1) c c' ∧ + c'.state = .skipRest ⟨TMEncoding.entryWidth k n - mismatchPos - 1, by omega⟩ ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + mismatchPos + 1 ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (c'.work utmScratchTape).head = (c.work utmScratchTape).head + mismatchPos ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + -- Generalized loop: induction on mismatchPos, universally quantifying c and pos + -- We track the current compare position pos + suffices h_loop : ∀ (mp : ℕ) (c : Cfg 4 (lookupTM (n := n) k).Q) (pos : ℕ) + (hpos : pos + mp < TMEncoding.inputPatternWidth k n), + c.state = .compare ⟨pos, by omega⟩ → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) → + (c.work utmDescTape).head ≥ 1 → + (∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) → + (c.work utmScratchTape).head ≥ 1 → + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) → + (∀ j, j < mp → (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) → + (c.work utmDescTape).cells ((c.work utmDescTape).head + mp) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + mp) → + ∃ c', (lookupTM (n := n) k).reachesIn (mp + 1) c c' ∧ + c'.state = .skipRest ⟨TMEncoding.entryWidth k n - (pos + mp) - 1, by omega⟩ ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + mp + 1 ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (c'.work utmScratchTape).head = (c.work utmScratchTape).head + mp ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ WorkTapesWF c'.work from by + obtain ⟨c', hreach, hst, hd, hdc, hs, hsc, ho, hi, hou, hwf'⟩ := + h_loop mismatchPos c 0 (by omega) hstate hwf hinp hinp_h hout hout_h hdesc_ns hdesc_h + hscratch_ns hscratch_h hother hmatch_before hmismatch + refine ⟨c', hreach, ?_, hd, hdc, hs, hsc, ho, hi, hou, hwf'⟩ + simp only [Nat.zero_add] at hst; exact hst + intro mp; induction mp with + | zero => + intro c pos hpos hstate hwf hinp hinp_h hout hout_h hdesc_ns hdesc_h + hscratch_ns hscratch_h hother _ hmismatch + -- One mismatch step: desc reads ≠ scratch reads + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read := lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read := lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + have hmismatch0 : (c.work utmDescTape).read ≠ (c.work utmScratchTape).read := by + simp only [Tape.read]; exact hmismatch + -- The mismatch step: desc advances, scratch stays, state → skipRest + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .skipRest ⟨TMEncoding.entryWidth k n - pos - 1, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, lookupTM, hstate, hmismatch0] + split_ifs <;> try (first | rfl | contradiction) + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · dsimp only []; simp only [↓reduceIte] + · intro i hne; dsimp only [] + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → c₁.work i = c.work i := by + intro i hne; rw [hother₁ i hne] + by_cases hi : i = utmScratchTape + · subst hi; exact lu_tape_idle_preserve _ hscratch_read hscratch_h + · exact lu_tape_idle_preserve _ (hother i hne hi).1 (hother i hne hi).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + refine ⟨c₁, .step hstep' .zero, hst₁, ?_, hc₁_desc_cells, ?_, ?_, ?_, hc₁_inp, hc₁_out, ?_⟩ + · rw [hc₁_desc_h] + · simp only [Nat.add_zero]; rw [hc₁_other utmScratchTape (by decide)] + · rw [hc₁_other utmScratchTape (by decide)] + · intro i hne_d hne_s; exact hc₁_other i hne_d + · constructor + · intro i; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.1 _ + · rw [hc₁_other i hi]; exact hwf.1 _ + · intro i j hj; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi]; exact hwf.2 _ j hj + | succ mp ih => + intro c pos hpos hstate hwf hinp hinp_h hout hout_h hdesc_ns hdesc_h + hscratch_ns hscratch_h hother hmatch_before hmismatch + -- One matching step, then IH + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read := lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read := lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + have hmatch0 : (c.work utmDescTape).read = (c.work utmScratchTape).read := by + simp only [Tape.read]; exact hmatch_before 0 (by omega) + -- Match step: both desc and scratch advance + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .compare ⟨pos + 1, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (c₁.work utmScratchTape = (c.work utmScratchTape).writeAndMove + (readBackWrite (c.work utmScratchTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + have hpos1 : pos + 1 < TMEncoding.inputPatternWidth k n := by omega + simp only [TM.step, lookupTM, hstate, hmatch0, hpos1] + split_ifs <;> try (first | rfl | contradiction) + refine ⟨_, rfl, rfl, ?_, ?_, ?_, rfl, rfl⟩ + · dsimp only []; simp only [↓reduceIte]; rw [hmatch0] + · dsimp only []; simp only [show ¬(utmScratchTape = utmDescTape) from (by decide), ↓reduceIte] + · intro i hne_d hne_s; dsimp only [] + simp only [show ¬(i = utmDescTape) from hne_d, + show ¬(i = utmScratchTape) from hne_s, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hscratch₁, hother₁, hinp₁, hout₁⟩ := hstep + -- Properties of c₁ + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_scratch_h : (c₁.work utmScratchTape).head = (c.work utmScratchTape).head + 1 := by + rw [hscratch₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_scratch_cells : (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells := by + rw [hscratch₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hscratch_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₁.work i = c.work i := by + intro i hne_d hne_s; rw [hother₁ i hne_d hne_s] + exact lu_tape_idle_preserve _ (hother i hne_d hne_s).1 (hother i hne_d hne_s).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + have hc₁_wf : WorkTapesWF c₁.work := by + constructor + · intro i + by_cases hi_d : i = utmDescTape + · subst hi_d; rw [hc₁_desc_cells]; exact hwf.1 _ + · by_cases hi_s : i = utmScratchTape + · subst hi_s; rw [hc₁_scratch_cells]; exact hwf.1 _ + · rw [hc₁_other i hi_d hi_s]; exact hwf.1 _ + · intro i j hj + by_cases hi_d : i = utmDescTape + · subst hi_d; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · by_cases hi_s : i = utmScratchTape + · subst hi_s; rw [hc₁_scratch_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi_d hi_s]; exact hwf.2 _ j hj + -- Apply IH + obtain ⟨c', hreach', hst', hhead', hcells', hshead', hscells', hother', hinp', hout', hwf'⟩ := + ih c₁ (pos + 1) (by omega) hst₁ hc₁_wf + (by rw [hc₁_inp]; exact hinp) (by rw [hc₁_inp]; exact hinp_h) + (by rw [hc₁_out]; exact hout) (by rw [hc₁_out]; exact hout_h) + (by intro j hj; rw [hc₁_desc_cells]; exact hdesc_ns j hj) + (by omega) + (by intro j hj; rw [hc₁_scratch_cells]; exact hscratch_ns j hj) + (by omega) + (by intro i hne_d hne_s; rw [hc₁_other i hne_d hne_s]; exact hother i hne_d hne_s) + (by intro j hj + rw [hc₁_desc_cells, hc₁_desc_h, hc₁_scratch_cells, hc₁_scratch_h] + have := hmatch_before (j + 1) (by omega) + convert this using 2 <;> omega) + (by rw [hc₁_desc_cells, hc₁_desc_h, hc₁_scratch_cells, hc₁_scratch_h] + convert hmismatch using 2 <;> omega) + refine ⟨c', .step hstep' hreach', ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hwf'⟩ + · simp only [show pos + (mp + 1) = pos + 1 + mp from by omega]; exact hst' + · rw [hhead', hc₁_desc_h]; omega + · rw [hcells', hc₁_desc_cells] + · rw [hshead', hc₁_scratch_h]; omega + · rw [hscells', hc₁_scratch_cells] + · intro i hne_d hne_s; rw [hother' i hne_d hne_s, hc₁_other i hne_d hne_s] + · rw [hinp', hc₁_inp] + · rw [hout', hc₁_out] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 3: skipRest simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Skip `rem` remaining bits of the current entry on desc. + From `skipRest rem`, after `rem + 1` steps reach `rewindScratch` with + desc advanced by `rem`, all other tapes preserved. -/ +private theorem skipRest_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) + (rem : ℕ) (hrem : rem ≤ TMEncoding.entryWidth k n) + (hstate : c.state = .skipRest ⟨rem, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (rem + 1) c c' ∧ + c'.state = .rewindScratch ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + rem ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (∀ i, i ≠ utmDescTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + -- Identical structure to skipHeader_loop: induction on rem, desc moves right + induction rem generalizing c with + | zero => + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hstep : ∃ c', (lookupTM (n := n) k).step c = some c' ∧ + c'.state = .rewindScratch ∧ + (∀ i, c'.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c'.input = c.input.move (idleDir c.input.read) ∧ + c'.output = c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) := by + simp only [TM.step, hne_halt, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, fun i => rfl, rfl, rfl⟩ + obtain ⟨c', hstep', hst', hwork', hinp', hout'⟩ := hstep + refine ⟨c', .step hstep' .zero, hst', ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork']; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; omega + · rw [hwork']; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h] + · intro i hne; rw [hwork']; exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · rw [hinp']; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · rw [hout']; exact lu_tape_idle_preserve _ hout hout_h + · constructor + · intro i; rw [hwork'] + by_cases hi : i = utmDescTape + · subst hi; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; exact hwf.1 _ + · rw [lu_tape_idle_preserve _ (hother i hi).1 (hother i hi).2]; exact hwf.1 _ + · intro i j hj; rw [hwork'] + by_cases hi : i = utmDescTape + · subst hi; rw [lu_tape_idle_preserve _ hdesc_read hdesc_h]; exact hwf.2 _ j hj + · rw [lu_tape_idle_preserve _ (hother i hi).1 (hother i hi).2]; exact hwf.2 _ j hj + | succ rem ih => + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .skipRest ⟨rem, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, hne_halt, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · show (c.work utmDescTape).writeAndMove (readBackWrite (c.work utmDescTape).read) + (if utmDescTape = utmDescTape then Dir3.right + else idleDir (c.work utmDescTape).read) = _ + simp only [↓reduceIte] + · intro i hne + show (c.work i).writeAndMove (readBackWrite (c.work i).read) + (if i = utmDescTape then Dir3.right else idleDir (c.work i).read) = _ + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hc₁_other : ∀ i, i ≠ utmDescTape → c₁.work i = c.work i := by + intro i hne; rw [hother₁ i hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + have hc₁_wf : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.1 _ + · rw [hc₁_other i hi]; exact hwf.1 _ + · intro i j hj; by_cases hi : i = utmDescTape + · subst hi; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · rw [hc₁_other i hi]; exact hwf.2 _ j hj + obtain ⟨c', hreach', hst', hhead', hcells', hother', hinp', hout', hwf'⟩ := + ih c₁ (by omega) hst₁ hc₁_wf + (by rw [hc₁_inp]; exact hinp) (by rw [hc₁_inp]; exact hinp_h) + (by rw [hc₁_out]; exact hout) (by rw [hc₁_out]; exact hout_h) + (by intro j hj; rw [hc₁_desc_cells]; exact hdesc_ns j hj) + (by omega) + (by intro i hne; rw [hc₁_other i hne]; exact hother i hne) + refine ⟨c', .step hstep' hreach', hst', ?_, ?_, ?_, ?_, ?_, hwf'⟩ + · rw [hhead', hc₁_desc_h]; omega + · rw [hcells', hc₁_desc_cells] + · intro i hne; rw [hother' i hne, hc₁_other i hne] + · rw [hinp', hc₁_inp] + · rw [hout', hc₁_out] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 4: rewindScratch simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind the scratch tape to cell 1 after mismatch. + From `rewindScratch` with scratch head at position `sh`, after `sh + 2` + steps reach `compare 0` (via `rewindScratchR`), with scratch head = 1. + + The extra +2 accounts for: hit ▷ at cell 0 (1 step to `rewindScratchR`), + then move right to cell 1 and transition to `compare 0` (1 step). -/ +private theorem rewindScratch_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) (sh : ℕ) + (hstate : c.state = .rewindScratch) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = sh) + (hother : ∀ i, i ≠ utmScratchTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (sh + 2) c c' ∧ + c'.state = .compare ⟨0, by omega⟩ ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction sh generalizing c with + | zero => + -- scratch head = 0, so read ▷ at cell 0 + have hread : (c.work utmScratchTape).read = Γ.start := by + simp [Tape.read, hscratch_h, hwf.1 utmScratchTape] + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + -- Step 1: rewindScratch → rewindScratchR (read ▷, move right) + have hstep1 : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindScratchR ∧ + (c₁.work utmScratchTape).head = 1 ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep1 + -- Step 2: rewindScratchR → compare 0 (all idle) + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmScratchTape + · rw [h]; omega + · rw [hw1 i h]; exact (hother i h).2 + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hout1' : c₁.output.read ≠ Γ.start := by rw [hout1]; exact hout + have hstep2 : ∃ c₂, (lookupTM (n := n) k).step c₁ = some c₂ ∧ + c₂.state = .compare ⟨0, by omega⟩ ∧ + c₂.work = c₁.work ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, lookupTM, hst1] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · ext i; dsimp only [] + exact lu_tape_idle_preserve (c₁.work i) + (lu_tape_read_ne_start_of_wf _ (hheads1 i) (hwf1.2 i)) (hheads1 i) + · simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve c₁.output hout1' (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hstep2', hst2, hwork2, hinp2, hout2⟩ := hstep2 + refine ⟨c₂, .step hstep1' (.step hstep2' .zero), hst2, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork2]; exact hhead1 + · rw [hwork2, hcells1] + · intro i hne; rw [hwork2, hw1 i hne] + · rw [hinp2, hinp1] + · rw [hout2, hout1] + · rw [hwork2]; exact hwf1 + | succ sh ih => + have hread_ne : (c.work utmScratchTape).read ≠ Γ.start := by + simp [Tape.read, hscratch_h]; exact hscratch_ns (sh + 1) (by omega) + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindScratch ∧ + (c₁.work utmScratchTape).head = sh ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := ih c₁ + hst1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + (by intro j hj; rw [hcells1]; exact hscratch_ns j hj) + hhead1 + (by intro i hne; rw [hw1 i hne]; exact hother i hne) + refine ⟨c_f, .step hstep' hreach, hst_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 5: process a non-matching entry +-- ════════════════════════════════════════════════════════════════════════ + +/-- Process one non-matching entry: compare → mismatch → skipRest → rewindScratch → compare. + Combines `compare_mismatch`, `skipRest_loop`, and `rewindScratch_loop`. + + From `compare 0` at the start of a non-matching entry, reach `compare 0` + at the start of the next entry, with desc advanced by `entryWidth` and + scratch rewound to cell 1. -/ +private theorem process_nonmatch_entry + (c : Cfg 4 (lookupTM (n := n) k).Q) + (mismatchPos : ℕ) (hmp : mismatchPos < TMEncoding.inputPatternWidth k n) + (hstate : c.state = .compare ⟨0, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + (hmatch_before : ∀ (j : ℕ), j < mismatchPos → + (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) + (hmismatch : + (c.work utmDescTape).cells ((c.work utmDescTape).head + mismatchPos) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + mismatchPos)) : + ∃ (c' : Cfg 4 (lookupTM (n := n) k).Q) (steps : ℕ), + (lookupTM (n := n) k).reachesIn steps c c' ∧ + c'.state = .compare ⟨0, by omega⟩ ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + TMEncoding.entryWidth k n ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + -- Step 1: compare_mismatch + obtain ⟨c₁, hreach₁, hst₁, hd₁, hdc₁, hs₁, hsc₁, ho₁, hi₁, hou₁, hwf₁⟩ := + compare_mismatch c mismatchPos hmp hstate hwf hinp hinp_h hout hout_h + hdesc_ns hdesc_h hscratch_ns (by omega) hother hmatch_before hmismatch + -- Step 2: skipRest_loop + have hskip_rem : TMEncoding.entryWidth k n - mismatchPos - 1 ≤ TMEncoding.entryWidth k n := by omega + have hc₁_scratch_read : (c₁.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ (by rw [hs₁, hscratch_h]; omega) + (by intro j hj; rw [hsc₁]; exact hscratch_ns j hj) + obtain ⟨c₂, hreach₂, hst₂, hd₂, hdc₂, ho₂, hi₂, hou₂, hwf₂⟩ := + skipRest_loop c₁ (TMEncoding.entryWidth k n - mismatchPos - 1) hskip_rem hst₁ hwf₁ + (by rw [hi₁]; exact hinp) (by rw [hi₁]; exact hinp_h) + (by rw [hou₁]; exact hout) (by rw [hou₁]; exact hout_h) + (by intro j hj; rw [hdc₁]; exact hdesc_ns j hj) + (by rw [hd₁]; omega) + (by intro i hne + by_cases hi : i = utmScratchTape + · subst hi; exact ⟨hc₁_scratch_read, by rw [hs₁, hscratch_h]; omega⟩ + · exact ⟨by rw [ho₁ i hne hi]; exact (hother i hne hi).1, + by rw [ho₁ i hne hi]; exact (hother i hne hi).2⟩) + -- Step 3: rewindScratch_loop + have hscratch_h₂ : (c₂.work utmScratchTape).head = + (c.work utmScratchTape).head + mismatchPos := by + rw [ho₂ utmScratchTape (by decide)]; exact hs₁ + have hscratch_ns₂ : ∀ j, j ≥ 1 → (c₂.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [ho₂ utmScratchTape (by decide), hsc₁]; exact hscratch_ns j hj + obtain ⟨c₃, hreach₃, hst₃, hsh₃, hsc₃, ho₃, hi₃, hou₃, hwf₃⟩ := + rewindScratch_loop c₂ ((c.work utmScratchTape).head + mismatchPos) + hst₂ hwf₂ + (by rw [hi₂, hi₁]; exact hinp) (by rw [hi₂, hi₁]; exact hinp_h) + (by rw [hou₂, hou₁]; exact hout) (by rw [hou₂, hou₁]; exact hout_h) + hscratch_ns₂ + hscratch_h₂ + (by intro i hne + by_cases hi_d : i = utmDescTape + · subst hi_d; constructor + · exact lu_tape_read_ne_start_of_wf _ (by rw [hd₂, hd₁]; omega) + (by intro j hj; rw [hdc₂, hdc₁]; exact hdesc_ns j hj) + · rw [hd₂, hd₁]; omega + · constructor + · rw [ho₂ i (show i ≠ utmDescTape from hi_d), ho₁ i hi_d hne] + exact (hother i hi_d hne).1 + · rw [ho₂ i (show i ≠ utmDescTape from hi_d), ho₁ i hi_d hne] + exact (hother i hi_d hne).2) + -- Compose all three + refine ⟨c₃, _, reachesIn_trans _ (reachesIn_trans _ hreach₁ hreach₂) hreach₃, + hst₃, ?_, ?_, ?_, ?_, ?_, ?_, ?_, hwf₃⟩ + · -- desc head + rw [ho₃ utmDescTape (by decide), hd₂, hd₁] + have : TMEncoding.entryWidth k n ≥ mismatchPos + 1 := by + simp [TMEncoding.entryWidth, TMEncoding.inputPatternWidth] at hmp ⊢; omega + omega + · rw [ho₃ utmDescTape (by decide), hdc₂, hdc₁] + · exact hsh₃ + · rw [hsc₃, ho₂ utmScratchTape (by decide), hsc₁] + · intro i hne_d hne_s + rw [ho₃ i hne_s, ho₂ i (show i ≠ utmDescTape from hne_d), ho₁ i hne_d hne_s] + · rw [hi₃, hi₂, hi₁] + · rw [hou₃, hou₂, hou₁] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 6: scan past non-matching entries to find the match +-- ════════════════════════════════════════════════════════════════════════ + +/-- Scan past `numBefore` non-matching entries and reach the matching entry. + From `compare 0` with desc at the first entry, after processing + `numBefore` non-matching entries, reach `matchRewind` positioned at the + matching entry's separator on desc. + + This is proved by induction on `numBefore`, composing + `process_nonmatch_entry` for each non-matching entry and finishing with + `compare_match_loop` on the matching entry. -/ +private theorem entry_scan_to_match + (c : Cfg 4 (lookupTM (n := n) k).Q) + (numBefore : ℕ) + (hstate : c.state = .compare ⟨0, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + -- Each of the numBefore entries before the match has a mismatch position + (hnonmatch : ∀ (j : ℕ), j < numBefore → + ∃ mismatchPos, mismatchPos < TMEncoding.inputPatternWidth k n ∧ + (c.work utmDescTape).cells + ((c.work utmDescTape).head + j * TMEncoding.entryWidth k n + mismatchPos) ≠ + (c.work utmScratchTape).cells (1 + mismatchPos)) + -- The matching entry at position numBefore has all bits matching + (hmatch_entry : ∀ (j : ℕ), j < TMEncoding.inputPatternWidth k n → + (c.work utmDescTape).cells + ((c.work utmDescTape).head + numBefore * TMEncoding.entryWidth k n + j) = + (c.work utmScratchTape).cells (1 + j)) : + ∃ (c' : Cfg 4 (lookupTM (n := n) k).Q) (steps : ℕ), + (lookupTM (n := n) k).reachesIn steps c c' ∧ + c'.state = .matchRewind ∧ + (c'.work utmDescTape).head = + (c.work utmDescTape).head + numBefore * TMEncoding.entryWidth k n + + TMEncoding.inputPatternWidth k n ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + -- Scratch advanced by ipw - 1 (last compare step only advances desc) + (c'.work utmScratchTape).head = TMEncoding.inputPatternWidth k n ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction numBefore generalizing c with + | zero => + -- No non-matching entries: apply compare_match_loop directly + have hipw : 0 < TMEncoding.inputPatternWidth k n := by + simp [TMEncoding.inputPatternWidth] + obtain ⟨c', hreach, hst, hd, hdc, hs, hsc, ho, hi, hou, hwf'⟩ := + compare_match_loop c 0 hipw hstate hwf hinp hinp_h hout hout_h + hdesc_ns hdesc_h hscratch_ns (by rw [hscratch_h]) hother + (by intro j hj; rw [hscratch_h] + have := hmatch_entry j hj; simp only [Nat.zero_mul, Nat.zero_add] at this + exact this) + refine ⟨c', _, hreach, hst, ?_, hdc, ?_, hsc, ho, hi, hou, hwf'⟩ + · rw [hd]; omega + · rw [hs, hscratch_h]; omega + | succ numBefore ih => + -- Process one non-matching entry, then IH + obtain ⟨mpPos, hmpPos_lt, hmpPos_ne⟩ := hnonmatch 0 (by omega) + -- Find the first mismatch position + have hne : (c.work utmDescTape).cells ((c.work utmDescTape).head + mpPos) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + mpPos) := by + rw [hscratch_h]; simpa using hmpPos_ne + -- Find the first mismatch using Nat.find + have hdec : ∀ j, Decidable ((c.work utmDescTape).cells ((c.work utmDescTape).head + j) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j)) := by + intro j; exact instDecidableNot + have hex_raw : ∃ fm, (c.work utmDescTape).cells ((c.work utmDescTape).head + fm) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + fm) := ⟨mpPos, hne⟩ + set firstMismatch := Nat.find hex_raw with hfm_def + have hfm_ne : (c.work utmDescTape).cells ((c.work utmDescTape).head + firstMismatch) ≠ + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + firstMismatch) := + Nat.find_spec hex_raw + have hfm_before : ∀ j, j < firstMismatch → + (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + (c.work utmScratchTape).cells ((c.work utmScratchTape).head + j) := by + intro j hj; by_contra h + exact Nat.find_min hex_raw hj h + have hfm_le : firstMismatch ≤ mpPos := Nat.find_min' hex_raw hne + have hfm_lt : firstMismatch < TMEncoding.inputPatternWidth k n := by omega + -- Apply process_nonmatch_entry + obtain ⟨c₁, steps₁, hreach₁, hst₁, hd₁, hdc₁, hs₁, hsc₁, ho₁, hi₁, hou₁, hwf₁⟩ := + process_nonmatch_entry c firstMismatch hfm_lt hstate hwf hinp hinp_h hout hout_h + hdesc_ns hdesc_h hscratch_ns hscratch_h hother hfm_before hfm_ne + -- Apply IH to c₁ + have ih_hnonmatch : ∀ j, j < numBefore → + ∃ mismatchPos, mismatchPos < TMEncoding.inputPatternWidth k n ∧ + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + j * TMEncoding.entryWidth k n + mismatchPos) ≠ + (c₁.work utmScratchTape).cells (1 + mismatchPos) := by + intro j hj + obtain ⟨mp, hmp_lt, hmp_ne⟩ := hnonmatch (j + 1) (by omega) + refine ⟨mp, hmp_lt, ?_⟩ + rw [hdc₁, hd₁, hsc₁] + convert hmp_ne using 2 + show (c.work utmDescTape).head + TMEncoding.entryWidth k n + + j * TMEncoding.entryWidth k n + mp = + (c.work utmDescTape).head + (j + 1) * TMEncoding.entryWidth k n + mp + rw [Nat.add_mul]; omega + have ih_hmatch : ∀ j, j < TMEncoding.inputPatternWidth k n → + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + numBefore * TMEncoding.entryWidth k n + j) = + (c₁.work utmScratchTape).cells (1 + j) := by + intro j hj + rw [hdc₁, hd₁, hsc₁] + convert hmatch_entry j hj using 2 + show (c.work utmDescTape).head + TMEncoding.entryWidth k n + + numBefore * TMEncoding.entryWidth k n + j = + (c.work utmDescTape).head + (numBefore + 1) * TMEncoding.entryWidth k n + j + rw [Nat.add_mul]; omega + obtain ⟨c', steps', hreach', hst', hd', hdc', hs', hsc', ho', hi', hou', hwf'⟩ := + ih c₁ hst₁ hwf₁ + (by rw [hi₁]; exact hinp) (by rw [hi₁]; exact hinp_h) + (by rw [hou₁]; exact hout) (by rw [hou₁]; exact hout_h) + (by intro j hj; rw [hdc₁]; exact hdesc_ns j hj) + (by rw [hd₁]; omega) + (by intro j hj; rw [hsc₁]; exact hscratch_ns j hj) + hs₁ + (by intro i hne_d hne_s; rw [ho₁ i hne_d hne_s]; exact hother i hne_d hne_s) + ih_hnonmatch ih_hmatch + refine ⟨c', _, reachesIn_trans _ hreach₁ hreach', hst', ?_, ?_, ?_, ?_, ?_, ?_, ?_, hwf'⟩ + · rw [hd', hd₁]; rw [Nat.add_mul]; omega + · rw [hdc', hdc₁] + · exact hs' + · rw [hsc', hsc₁] + · intro i hne_d hne_s; rw [ho' i hne_d hne_s, ho₁ i hne_d hne_s] + · rw [hi', hi₁] + · rw [hou', hou₁] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 7: matchRewind simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind scratch after full match. + From `matchRewind` with scratch head at position `sh`, after `sh + 2` + steps reach `matchRewindR` then immediately continue. + + The scratch tape is rewound from position `sh` down to cell 0 (hit ▷), + then move right to cell 1 in the `matchRewindR` step. -/ +private theorem matchRewind_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) (sh : ℕ) + (hstate : c.state = .matchRewind) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = sh) + (hother : ∀ i, i ≠ utmScratchTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (sh + 1) c c' ∧ + c'.state = .matchRewindR ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction sh generalizing c with + | zero => + -- scratch head = 0, so read ▷ at cell 0 + have hread : (c.work utmScratchTape).read = Γ.start := by + simp [Tape.read, hscratch_h, hwf.1 utmScratchTape] + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + -- Step: matchRewind → matchRewindR (read ▷, move right) + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .matchRewindR ∧ + (c₁.work utmScratchTape).head = 1 ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + refine ⟨c₁, .step hstep' .zero, hst1, hhead1, hcells1, hw1, hinp1, hout1, ?_⟩ + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + | succ sh ih => + have hread_ne : (c.work utmScratchTape).read ≠ Γ.start := by + simp [Tape.read, hscratch_h]; exact hscratch_ns (sh + 1) (by omega) + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .matchRewind ∧ + (c₁.work utmScratchTape).head = sh ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := ih c₁ + hst1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + (by intro j hj; rw [hcells1]; exact hscratch_ns j hj) + hhead1 + (by intro i hne; rw [hw1 i hne]; exact hother i hne) + refine ⟨c_f, .step hstep' hreach, hst_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 8: matchRewindR step +-- ════════════════════════════════════════════════════════════════════════ + +/-- From `matchRewindR` with scratch at cell 1, take 1 step to `copyOutput ow`. + Desc advances past the separator bit. -/ +private theorem matchRewindR_step + (c : Cfg 4 (lookupTM (n := n) k).Q) + (hstate : c.state = .matchRewindR) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + let ow := TMEncoding.outputWidth k n + ∃ c', + (lookupTM (n := n) k).reachesIn 1 c c' ∧ + c'.state = .copyOutput ⟨ow, by omega⟩ ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + 1 ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (∀ i, i ≠ utmDescTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + intro ow + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read : (c.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + -- matchRewindR: desc moves right, scratch and others idle + have hstep : ∃ c', (lookupTM (n := n) k).step c = some c' ∧ + c'.state = .copyOutput ⟨ow, by omega⟩ ∧ + (c'.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → c'.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c'.input = c.input.move (idleDir c.input.read) ∧ + c'.output = c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) := by + simp only [TM.step, hne_halt, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · show (c.work utmDescTape).writeAndMove (readBackWrite (c.work utmDescTape).read) + (if utmDescTape = utmDescTape then Dir3.right + else idleDir (c.work utmDescTape).read) = _ + simp only [↓reduceIte] + · intro i hne + show (c.work i).writeAndMove (readBackWrite (c.work i).read) + (if i = utmDescTape then Dir3.right else idleDir (c.work i).read) = _ + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c', hstep', hst', hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep + refine ⟨c', .step hstep' .zero, hst', ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc head + 1 + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + · -- desc cells + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + · -- other tapes + intro i hne; rw [hother₁ i hne] + by_cases hi : i = utmScratchTape + · subst hi; exact lu_tape_idle_preserve _ hscratch_read hscratch_h + · exact lu_tape_idle_preserve _ (hother i hne hi).1 (hother i hne hi).2 + · rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + · -- WorkTapesWF + have hdesc_cells : (c'.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + have hother_eq : ∀ i, i ≠ utmDescTape → c'.work i = c.work i := by + intro i hne; rw [hother₁ i hne] + by_cases hi : i = utmScratchTape + · subst hi; exact lu_tape_idle_preserve _ hscratch_read hscratch_h + · exact lu_tape_idle_preserve _ (hother i hne hi).1 (hother i hne hi).2 + constructor + · intro i; by_cases hi : i = utmDescTape + · subst hi; rw [hdesc_cells]; exact hwf.1 _ + · rw [hother_eq i hi]; exact hwf.1 _ + · intro i j hj; by_cases hi : i = utmDescTape + · subst hi; rw [hdesc_cells]; exact hwf.2 _ j hj + · rw [hother_eq i hi]; exact hwf.2 _ j hj + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 9: copyOutput simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Copy `rem` output bits from desc to scratch. + From `copyOutput rem`, after `rem + 1` steps reach `rewindDesc`, + with `rem` bits copied from desc to scratch. + + After copying, scratch contains the transition output bits at cells + 1 through ow, and the head is positioned at ow + 1. The desc tape + has advanced past all output bits. -/ +private theorem copyOutput_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) + (rem : ℕ) (hrem : rem ≤ TMEncoding.outputWidth k n) + (hstate : c.state = .copyOutput ⟨rem, by omega⟩) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = TMEncoding.outputWidth k n - rem + 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) + -- The output bits to be copied from desc + (outputBits : List Bool) + (houtLen : outputBits.length = TMEncoding.outputWidth k n) + -- desc stores the remaining output bits starting at its current head + (hdesc_bits : ∀ (j : ℕ), j < rem → + ∃ (hj : TMEncoding.outputWidth k n - rem + j < outputBits.length), + (c.work utmDescTape).cells ((c.work utmDescTape).head + j) = + Γ.ofBool (outputBits[TMEncoding.outputWidth k n - rem + j]'hj)) + -- Already-copied bits on scratch + (hscratch_bits : ∀ (j : ℕ) (hj : j < outputBits.length), + j < TMEncoding.outputWidth k n - rem → + (c.work utmScratchTape).cells (1 + j) = Γ.ofBool (outputBits[j]'hj)) : + ∃ c', + (lookupTM (n := n) k).reachesIn (rem + 1) c c' ∧ + c'.state = .rewindDesc ∧ + (c'.work utmDescTape).head = (c.work utmDescTape).head + rem - 1 ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + -- Scratch now has the output bits written + (∀ (j : ℕ) (hj : j < outputBits.length), + j < TMEncoding.outputWidth k n → + (c'.work utmScratchTape).cells (1 + j) = Γ.ofBool (outputBits[j]'hj)) ∧ + (c'.work utmScratchTape).cells 0 = Γ.start ∧ + (c'.work utmScratchTape).head = TMEncoding.outputWidth k n + 1 ∧ + (∀ j, j ≥ TMEncoding.outputWidth k n + 1 → + (c'.work utmScratchTape).cells j = (c.work utmScratchTape).cells j) ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction rem generalizing c with + | zero => + -- copyOutput 0 → rewindDesc: one step, desc moves left, others idle + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read : (c.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ (by omega) hscratch_ns + -- Verify the step + have hstep : ∃ c', (lookupTM (n := n) k).step c = some c' ∧ + c'.state = .rewindDesc ∧ + (c'.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) + (moveLeftDir (c.work utmDescTape).read)) ∧ + (∀ i, i ≠ utmDescTape → c'.work i = (c.work i).writeAndMove + (readBackWrite (c.work i).read) (idleDir (c.work i).read)) ∧ + c'.input = c.input.move (idleDir c.input.read) ∧ + c'.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate] + refine ⟨_, rfl, rfl, ?_, ?_, rfl, rfl⟩ + · show (c.work utmDescTape).writeAndMove (readBackWrite (c.work utmDescTape).read) + (if utmDescTape = utmDescTape then moveLeftDir (c.work utmDescTape).read + else idleDir (c.work utmDescTape).read) = _ + simp only [↓reduceIte] + · intro i hne + show (c.work i).writeAndMove (readBackWrite (c.work i).read) + (if i = utmDescTape then moveLeftDir (c.work utmDescTape).read + else idleDir (c.work i).read) = _ + simp only [show ¬(i = utmDescTape) from hne, ↓reduceIte] + obtain ⟨c', hstep', hst', hdesc₁, hother₁, hinp₁, hout₁⟩ := hstep + -- Establish scratch preservation + have hscratch_eq : c'.work utmScratchTape = c.work utmScratchTape := by + rw [hother₁ _ (by decide : utmScratchTape ≠ utmDescTape)] + exact lu_tape_idle_preserve _ hscratch_read (by omega) + have hmld : moveLeftDir (c.work utmDescTape).read = Dir3.left := by + simp [moveLeftDir, hdesc_read] + have hdesc_cells : (c'.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁, Tape.writeAndMove, hmld, Tape.move] + simp only [Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + refine ⟨c', .step hstep' .zero, hst', ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · -- desc head + rw [hdesc₁, Tape.writeAndMove, hmld, Tape.move] + show (Tape.write _ _).head - 1 = _ + rw [lu_tape_write_head]; omega + · -- desc cells + exact hdesc_cells + · -- scratch bits (from hscratch_bits) + intro j hj hjow + rw [hscratch_eq]; exact hscratch_bits j hj (by omega) + · -- scratch cell 0 + rw [hscratch_eq]; exact hwf.1 utmScratchTape + · -- scratch head + rw [hscratch_eq, hscratch_h]; omega + · -- scratch cells beyond ow preserved + intro j _; rw [hscratch_eq] + · -- other tapes + intro i hne_desc hne_scratch + rw [hother₁ i hne_desc] + exact lu_tape_idle_preserve _ (hother i hne_desc hne_scratch).1 + (hother i hne_desc hne_scratch).2 + · -- input + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · -- output + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + · -- WorkTapesWF + constructor + · intro i + by_cases hi1 : i = utmDescTape + · subst hi1; rw [hdesc_cells]; exact hwf.1 _ + · by_cases hi2 : i = utmScratchTape + · subst hi2; rw [hscratch_eq]; exact hwf.1 _ + · rw [hother₁ i hi1, lu_tape_idle_preserve _ (hother i hi1 hi2).1 + (hother i hi1 hi2).2]; exact hwf.1 _ + · intro i j hj + by_cases hi1 : i = utmDescTape + · subst hi1; rw [hdesc_cells]; exact hwf.2 _ j hj + · by_cases hi2 : i = utmScratchTape + · subst hi2; rw [hscratch_eq]; exact hwf.2 _ j hj + · rw [hother₁ i hi1, lu_tape_idle_preserve _ (hother i hi1 hi2).1 + (hother i hi1 hi2).2]; exact hwf.2 _ j hj + | succ rem ih => + -- copyOutput (rem+1) → copyOutput rem: copy one bit, desc & scratch move right + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hdesc_read : (c.work utmDescTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hdesc_h hdesc_ns + have hscratch_read : (c.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ (by omega) hscratch_ns + -- The value written to scratch + let w : Γw := match (c.work utmDescTape).read with + | .zero => .zero | .one => .one | .blank => .blank | .start => .blank + -- Verify the step + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .copyOutput ⟨rem, by omega⟩ ∧ + (c₁.work utmDescTape = (c.work utmDescTape).writeAndMove + (readBackWrite (c.work utmDescTape).read) Dir3.right) ∧ + (c₁.work utmScratchTape = (c.work utmScratchTape).writeAndMove w Dir3.right) ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + c₁.work i = (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read)) ∧ + c₁.input = c.input.move (idleDir c.input.read) ∧ + c₁.output = c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) := by + simp only [TM.step, lookupTM, hstate] + split_ifs <;> try (first | rfl | contradiction) + refine ⟨_, rfl, rfl, ?_, ?_, ?_, rfl, rfl⟩ + · -- desc tape + simp only [show ¬(utmDescTape = utmScratchTape) from (by decide), ↓reduceIte] + · -- scratch tape + simp only [show ¬(utmScratchTape = utmDescTape) from (by decide), ↓reduceIte] + rfl + · -- other tapes + intro i hne_desc hne_scratch + simp only [show ¬(i = utmScratchTape) from hne_scratch, + show ¬(i = utmDescTape) from hne_desc, ↓reduceIte] + obtain ⟨c₁, hstep', hst₁, hdesc₁, hscratch₁, hother₁, hinp₁, hout₁⟩ := hstep + -- Properties of c₁: desc tape + have hc₁_desc_h : (c₁.work utmDescTape).head = (c.work utmDescTape).head + 1 := by + rw [hdesc₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head] + have hc₁_desc_cells : (c₁.work utmDescTape).cells = (c.work utmDescTape).cells := by + rw [hdesc₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + split + · rfl + · rw [lu_readBackWrite_toΓ_eq hdesc_read]; exact Function.update_eq_self _ _ + -- Properties of c₁: scratch tape + have hc₁_scratch_h : (c₁.work utmScratchTape).head = + TMEncoding.outputWidth k n - rem + 1 := by + rw [hscratch₁, Tape.writeAndMove, Tape.move] + show (Tape.write _ _).head + 1 = _ + rw [lu_tape_write_head, hscratch_h]; omega + have hc₁_scratch_cells_0 : (c₁.work utmScratchTape).cells 0 = Γ.start := by + rw [hscratch₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + split + · exact hwf.1 utmScratchTape + · simp only [Function.update] + split + · omega + · exact hwf.1 utmScratchTape + -- Properties of c₁: other tapes preserved + have hc₁_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₁.work i = c.work i := by + intro i hne_d hne_s; rw [hother₁ i hne_d hne_s] + exact lu_tape_idle_preserve _ (hother i hne_d hne_s).1 (hother i hne_d hne_s).2 + have hc₁_inp : c₁.input = c.input := by + rw [hinp₁]; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + have hc₁_out : c₁.output = c.output := by + rw [hout₁]; exact lu_tape_idle_preserve _ hout hout_h + -- w.toΓ ≠ Γ.start + have hw_ne_start : w.toΓ ≠ Γ.start := by + show (match (c.work utmDescTape).read with + | .zero => Γw.zero | .one => Γw.one | .blank => Γw.blank | .start => Γw.blank).toΓ ≠ _ + cases (c.work utmDescTape).read <;> simp [Γw.toΓ] + -- WorkTapesWF for c₁ + have hc₁_wf : WorkTapesWF c₁.work := by + constructor + · intro i + by_cases hi1 : i = utmDescTape + · subst hi1; rw [hc₁_desc_cells]; exact hwf.1 _ + · by_cases hi2 : i = utmScratchTape + · subst hi2; exact hc₁_scratch_cells_0 + · rw [hc₁_other i hi1 hi2]; exact hwf.1 _ + · intro i j hj + by_cases hi1 : i = utmDescTape + · subst hi1; rw [hc₁_desc_cells]; exact hwf.2 _ j hj + · by_cases hi2 : i = utmScratchTape + · subst hi2 + have : (c₁.work utmScratchTape).cells j ≠ Γ.start := by + rw [hscratch₁]; simp only [Tape.writeAndMove, Tape.move, Tape.write] + simp only [show ¬((c.work utmScratchTape).head = 0) from by omega, ↓reduceIte] + by_cases hjh : j = (c.work utmScratchTape).head + · rw [Function.update_apply, if_pos hjh]; exact hw_ne_start + · rw [Function.update_apply, if_neg hjh]; exact hscratch_ns j hj + exact this + · rw [hc₁_other i hi1 hi2]; exact hwf.2 _ j hj + -- Scratch no-start for c₁ + have hc₁_scratch_ns : ∀ j, j ≥ 1 → (c₁.work utmScratchTape).cells j ≠ Γ.start := by + exact hc₁_wf.2 utmScratchTape + -- desc bits shifted for IH + have hc₁_desc_bits : ∀ j, j < rem → + ∃ (hj : TMEncoding.outputWidth k n - rem + j < outputBits.length), + (c₁.work utmDescTape).cells ((c₁.work utmDescTape).head + j) = + Γ.ofBool (outputBits[TMEncoding.outputWidth k n - rem + j]'hj) := by + intro j hj + have hdb := hdesc_bits (j + 1) (by omega) + obtain ⟨hj', hval⟩ := hdb + have hidx1 : (c.work utmDescTape).head + 1 + j = + (c.work utmDescTape).head + (j + 1) := by omega + refine ⟨by omega, ?_⟩ + rw [hc₁_desc_cells, hc₁_desc_h, hidx1] + have : TMEncoding.outputWidth k n - rem + j = + TMEncoding.outputWidth k n - (rem + 1) + (j + 1) := by omega + simp only [this]; exact hval + -- Already-copied bits for IH: include the bit just copied + have hc₁_scratch_bits : ∀ (j : ℕ) (hj : j < outputBits.length), + j < TMEncoding.outputWidth k n - rem → + (c₁.work utmScratchTape).cells (1 + j) = + Γ.ofBool (outputBits[j]'hj) := by + intro j hjlen hjow + rw [hscratch₁] + simp only [Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + have hne0 : ¬(TMEncoding.outputWidth k n - (rem + 1) + 1 = 0) := by omega + simp only [hne0, ↓reduceIte] + by_cases hjh : 1 + j = TMEncoding.outputWidth k n - (rem + 1) + 1 + · -- j + 1 = head position, so this is the NEW bit + rw [Function.update_apply, if_pos hjh] + have hj_eq : j = TMEncoding.outputWidth k n - (rem + 1) := by omega + subst hj_eq + -- From hdesc_bits j=0: desc.read = Γ.ofBool outputBits[ow - (rem+1)] + have hdb0 := hdesc_bits 0 (by omega) + obtain ⟨_, hval0⟩ := hdb0 + simp only [Nat.add_zero] at hval0 + -- w = match desc.read with ..., desc.read = Γ.ofBool b + show w.toΓ = _ + show (match (c.work utmDescTape).read with + | .zero => Γw.zero | .one => Γw.one | .blank => Γw.blank | .start => Γw.blank).toΓ = _ + have : (c.work utmDescTape).read = Γ.ofBool outputBits[TMEncoding.outputWidth k n - (rem + 1)] := hval0 + rw [this] + cases outputBits[TMEncoding.outputWidth k n - (rem + 1)] <;> simp [Γ.ofBool, Γw.toΓ] + · -- j ≠ head position, use old scratch bits + rw [Function.update_apply, if_neg hjh] + exact hscratch_bits j hjlen (by omega) + -- Apply IH + obtain ⟨c', hreach', hst', hhead', hdcells', hbits', hcell0', + hscratch_head', hscratch_beyond', hother', hinp', hout', hwf'⟩ := + ih c₁ (by omega) hst₁ hc₁_wf + (by rw [hc₁_inp]; exact hinp) (by rw [hc₁_inp]; exact hinp_h) + (by rw [hc₁_out]; exact hout) (by rw [hc₁_out]; exact hout_h) + (by intro j hj; rw [hc₁_desc_cells]; exact hdesc_ns j hj) + (by omega) + hc₁_scratch_ns + hc₁_scratch_h + (by intro i hne_d hne_s; rw [hc₁_other i hne_d hne_s]; exact hother i hne_d hne_s) + hc₁_desc_bits + hc₁_scratch_bits + refine ⟨c', .step hstep' hreach', hst', ?_, ?_, hbits', hcell0', + hscratch_head', ?_, ?_, ?_, ?_, hwf'⟩ + · -- desc head: (c.head + 1) + rem - 1 = c.head + (rem + 1) - 1 + rw [hhead', hc₁_desc_h]; omega + · -- desc cells + rw [hdcells', hc₁_desc_cells] + · -- scratch cells beyond ow preserved + intro j hj + rw [hscratch_beyond' j hj, hscratch₁] + simp only [Tape.writeAndMove, Tape.move, Tape.write] + simp only [show ¬((c.work utmScratchTape).head = 0) from by rw [hscratch_h]; omega, + ↓reduceIte] + rw [Function.update_apply, if_neg (by rw [hscratch_h]; omega)] + · -- other tapes + intro i hne_d hne_s + rw [hother' i hne_d hne_s, hc₁_other i hne_d hne_s] + · -- input + rw [hinp', hc₁_inp] + · -- output + rw [hout', hc₁_out] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 10: rewindDesc simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Rewind the desc tape to cell 1. + From `rewindDesc` with desc head at position `dh`, after `dh + 2` steps + reach `rewindDescR` then `rewindScratchFinal`, with desc head = 1. + + The pattern is: move left until hitting ▷ at cell 0 (`dh` steps + to `rewindDesc`), then 1 step to `rewindDescR` (move right), + then 1 step to `rewindScratchFinal`. -/ +private theorem rewindDesc_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) (dh : ℕ) + (hstate : c.state = .rewindDesc) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hdesc_ns : ∀ j, j ≥ 1 → (c.work utmDescTape).cells j ≠ Γ.start) + (hdesc_h : (c.work utmDescTape).head = dh) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head ≥ 1) + (hother : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (dh + 2) c c' ∧ + c'.state = .rewindScratchFinal ∧ + (c'.work utmDescTape).head = 1 ∧ + (c'.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (c'.work utmScratchTape).head = (c.work utmScratchTape).head - 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction dh generalizing c with + | zero => + -- desc head = 0, so read ▷ at cell 0 + have hread : (c.work utmDescTape).read = Γ.start := by + simp [Tape.read, hdesc_h, hwf.1 utmDescTape] + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hscratch_read : (c.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + -- Step 1: rewindDesc → rewindDescR (desc moves right) + have hstep1 : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindDescR ∧ + (c₁.work utmDescTape).head = 1 ∧ + (c₁.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hdesc_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hdesc_h] + · intro i hne; dsimp only []; rw [if_neg hne] + have : (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1 := by + by_cases hi : i = utmScratchTape + · subst hi; exact ⟨hscratch_read, hscratch_h⟩ + · exact hother i hne hi + exact lu_tape_idle_preserve _ this.1 this.2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep1 + -- Prepare for step 2 + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmDescTape + · rw [h, hcells1]; exact hwf.1 utmDescTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmDescTape + · rw [h, hcells1]; exact hwf.2 utmDescTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hout1' : c₁.output.read ≠ Γ.start := by rw [hout1]; exact hout + have hscratch_read1 : (c₁.work utmScratchTape).read ≠ Γ.start := by + rw [hw1 utmScratchTape (by decide)]; exact hscratch_read + have hscratch_h1 : (c₁.work utmScratchTape).head ≥ 1 := by + rw [hw1 utmScratchTape (by decide)]; exact hscratch_h + have hheads1_desc : (c₁.work utmDescTape).head ≥ 1 := by omega + -- Step 2: rewindDescR → rewindScratchFinal (desc idle, scratch moves left) + have hstep2 : ∃ c₂, (lookupTM (n := n) k).step c₁ = some c₂ ∧ + c₂.state = .rewindScratchFinal ∧ + c₂.work utmDescTape = c₁.work utmDescTape ∧ + (c₂.work utmScratchTape).head = (c₁.work utmScratchTape).head - 1 ∧ + (c₂.work utmScratchTape).cells = (c₁.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → c₂.work i = c₁.work i) ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, lookupTM, hst1] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + have : ¬(utmDescTape = utmScratchTape) := by decide + rw [if_neg this] + exact lu_tape_idle_preserve _ (lu_tape_read_ne_start_of_wf _ + hheads1_desc (hwf1.2 utmDescTape)) hheads1_desc + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, moveLeftDir, hscratch_read1, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hscratch_read1] + simp only [Tape.write]; split + · omega + · simp + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, moveLeftDir, hscratch_read1, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hscratch_read1] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne_d hne_s; dsimp only [] + rw [if_neg hne_s] + have : (c₁.work i).read ≠ Γ.start ∧ (c₁.work i).head ≥ 1 := by + rw [hw1 i hne_d]; exact hother i hne_d hne_s + exact lu_tape_idle_preserve _ this.1 this.2 + · simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve c₁.output hout1' (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hstep2', hst2, hdesc2, hshead2, hscells2, hw2, hinp2, hout2⟩ := hstep2 + refine ⟨c₂, .step hstep1' (.step hstep2' .zero), hst2, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hdesc2]; exact hhead1 + · rw [hdesc2, hcells1] + · rw [hshead2, hw1 utmScratchTape (by decide)] + · rw [hscells2, hw1 utmScratchTape (by decide)] + · intro i hne_d hne_s; rw [hw2 i hne_d hne_s, hw1 i hne_d] + · rw [hinp2, hinp1] + · rw [hout2, hout1] + · constructor + · intro i + by_cases hi_d : i = utmDescTape + · rw [hi_d, hdesc2, hcells1]; exact hwf.1 utmDescTape + · by_cases hi_s : i = utmScratchTape + · rw [hi_s, hscells2, hw1 utmScratchTape (by decide)]; exact hwf.1 utmScratchTape + · rw [hw2 i hi_d hi_s, hw1 i hi_d]; exact hwf.1 i + · intro i j hj + by_cases hi_d : i = utmDescTape + · rw [hi_d, hdesc2, hcells1]; exact hwf.2 utmDescTape j hj + · by_cases hi_s : i = utmScratchTape + · rw [hi_s, hscells2, hw1 utmScratchTape (by decide)]; exact hwf.2 utmScratchTape j hj + · rw [hw2 i hi_d hi_s, hw1 i hi_d]; exact hwf.2 i j hj + | succ dh ih => + have hread_ne : (c.work utmDescTape).read ≠ Γ.start := by + simp [Tape.read, hdesc_h]; exact hdesc_ns (dh + 1) (by omega) + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hscratch_read : (c.work utmScratchTape).read ≠ Γ.start := + lu_tape_read_ne_start_of_wf _ hscratch_h hscratch_ns + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindDesc ∧ + (c₁.work utmDescTape).head = dh ∧ + (c₁.work utmDescTape).cells = (c.work utmDescTape).cells ∧ + (∀ i, i ≠ utmDescTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hdesc_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + have : (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1 := by + by_cases hi : i = utmScratchTape + · subst hi; exact ⟨hscratch_read, hscratch_h⟩ + · exact hother i hne hi + exact lu_tape_idle_preserve _ this.1 this.2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmDescTape + · rw [h, hcells1]; exact hwf.1 utmDescTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmDescTape + · rw [h, hcells1]; exact hwf.2 utmDescTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hshead_f, hscells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := + ih c₁ hst1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + (by intro j hj; rw [hcells1]; exact hdesc_ns j hj) + hhead1 + (by intro j hj; rw [hw1 utmScratchTape (by decide)]; exact hscratch_ns j hj) + (by rw [hw1 utmScratchTape (by decide)]; exact hscratch_h) + (by intro i hne_d hne_s; rw [hw1 i hne_d]; exact hother i hne_d hne_s) + refine ⟨c_f, .step hstep' hreach, hst_f, hhead_f, ?_, ?_, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · rw [hshead_f, hw1 utmScratchTape (by decide)] + · rw [hscells_f, hw1 utmScratchTape (by decide)] + · intro i hne_d hne_s; rw [hw_f i hne_d hne_s, hw1 i hne_d] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 11: rewindScratchFinal simulation +-- ════════════════════════════════════════════════════════════════════════ + +/-- Final scratch rewind and halt. + From `rewindScratchFinal` with scratch head at position `sh`, after + `sh + 2` steps reach `done` (halted) with scratch head = 1. + + The pattern is: move left until hitting ▷ at cell 0, then + `rewindScratchFinalR` moves right to cell 1, then transition to `done`. -/ +private theorem rewindScratchFinal_loop + (c : Cfg 4 (lookupTM (n := n) k).Q) (sh : ℕ) + (hstate : c.state = .rewindScratchFinal) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + (hscratch_ns : ∀ j, j ≥ 1 → (c.work utmScratchTape).cells j ≠ Γ.start) + (hscratch_h : (c.work utmScratchTape).head = sh) + (hother : ∀ i, i ≠ utmScratchTape → (c.work i).read ≠ Γ.start ∧ (c.work i).head ≥ 1) : + ∃ c', + (lookupTM (n := n) k).reachesIn (sh + 2) c c' ∧ + (lookupTM (n := n) k).halted c' ∧ + c'.state = .done ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + induction sh generalizing c with + | zero => + -- scratch head = 0, so read ▷ at cell 0 + have hread : (c.work utmScratchTape).read = Γ.start := by + simp [Tape.read, hscratch_h, hwf.1 utmScratchTape] + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + -- Step 1: rewindScratchFinal → rewindScratchFinalR (read ▷, move right) + have hstep1 : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindScratchFinalR ∧ + (c₁.work utmScratchTape).head = 1 ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, Tape.write, hscratch_h] + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep1 + -- Step 2: rewindScratchFinalR → done (all idle) + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmScratchTape + · rw [h]; omega + · rw [hw1 i h]; exact (hother i h).2 + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hout1' : c₁.output.read ≠ Γ.start := by rw [hout1]; exact hout + have hne_halt1 : c₁.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hst1] + have hstep2 : ∃ c₂, (lookupTM (n := n) k).step c₁ = some c₂ ∧ + c₂.state = .done ∧ + c₂.work = c₁.work ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, lookupTM, hst1] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · ext i; dsimp only [] + exact lu_tape_idle_preserve (c₁.work i) + (lu_tape_read_ne_start_of_wf _ (hheads1 i) (hwf1.2 i)) (hheads1 i) + · simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve c₁.output hout1' (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hstep2', hst2, hwork2, hinp2, hout2⟩ := hstep2 + refine ⟨c₂, .step hstep1' (.step hstep2' .zero), ?_, hst2, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · simp [TM.halted, Cfg.isHalted, hst2, lookupTM] + · rw [hwork2]; exact hhead1 + · rw [hwork2, hcells1] + · intro i hne; rw [hwork2, hw1 i hne] + · rw [hinp2, hinp1] + · rw [hout2, hout1] + · rw [hwork2]; exact hwf1 + | succ sh ih => + have hread_ne : (c.work utmScratchTape).read ≠ Γ.start := by + simp [Tape.read, hscratch_h]; exact hscratch_ns (sh + 1) (by omega) + have hne_halt : c.state ≠ (lookupTM (n := n) k).qhalt := by + simp [lookupTM, hstate] + have hstep : ∃ c₁, (lookupTM (n := n) k).step c = some c₁ ∧ + c₁.state = .rewindScratchFinal ∧ + (c₁.work utmScratchTape).head = sh ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, ↓reduceIte, lookupTM, hstate, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hscratch_h] + · dsimp only [] + simp only [↓reduceIte, Tape.writeAndMove, Tape.move, moveLeftDir, hread_ne, ↓reduceIte] + rw [lu_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact lu_tape_idle_preserve _ (hother i hne).1 (hother i hne).2 + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact lu_tape_idle_preserve _ hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + obtain ⟨c_f, hreach, hhalted, hst_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := ih c₁ + hst1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + (by intro j hj; rw [hcells1]; exact hscratch_ns j hj) + hhead1 + (by intro i hne; rw [hw1 i hne]; exact hother i hne) + refine ⟨c_f, .step hstep' hreach, hhalted, hst_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Time bound +-- ════════════════════════════════════════════════════════════════════════ + +/-- Time bound for the lookup machine. + Components: + - skipHeader: tableOffset + 1 + - entry scan: numEntries * (ipw + ew + scratchHead + 4) worst case + - match: ipw + scratchHead + 2 + - matchRewindR: 1 + - copyOutput: ow + 1 + - rewindDesc: descHead + 2 + - rewindScratchFinal: scratchHead + 2 + + For a TM with k states and n work tapes, the total number of entries + is k * 4 * 4^n * 4 = 16 * k * 4^n. Each entry has width `entryWidth k n`. + The desc tape head stays bounded by tableOffset + numEntries * entryWidth. + The scratch tape head stays bounded by inputPatternWidth. + + We give a simplified quadratic bound. -/ +noncomputable def lookupTimeBound (k n : ℕ) (descLen : ℕ) : ℕ := + let tableOff := TMEncoding.tableOffset k n + let ew := TMEncoding.entryWidth k n + let ipw := TMEncoding.inputPatternWidth k n + let ow := TMEncoding.outputWidth k n + -- skipHeader phase + (tableOff + 1) + + -- worst-case entry scan: at most descLen / ew entries, each costs ew + ipw + 4 + (descLen * (ew + ipw + 4)) + + -- match phase: compare + matchRewind + matchRewindR + (ipw + ipw + 3) + + -- copy output + (ow + 1) + + -- rewind desc + (descLen + 2) + + -- rewind scratch final + (ow + 2) + +-- ════════════════════════════════════════════════════════════════════════ +-- Full HoareTime proof (non-private, exported for Lookup.lean) +-- ════════════════════════════════════════════════════════════════════════ + +set_option maxHeartbeats 800000 in +theorem lookupTM_hoareTime_proof (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) + (hdesc : desc = TMEncoding.encodeTM tm) + (q : Fin k) (iHead : Γ) (wHeads : Fin n → Γ) (oHead : Γ) : + let e := tm.stateEquivK hk + ∃ B, (lookupTM (n := n) k).HoareTime + (fun inp work out => + descOnTape desc (work utmDescTape) ∧ + (work utmDescTape).head = 1 ∧ + (∀ i, (work i).head ≥ 1) ∧ + scratchHasInputPattern k n q iHead wHeads oHead (work utmScratchTape) ∧ + (work utmScratchTape).cells (TMEncoding.outputWidth k n + 1) = Γ.blank ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ inp.head ≥ 1 ∧ + out.read ≠ Γ.start ∧ out.head ≥ 1) + (fun _inp work _out => + let (q', wW, oW, iD, wD, oD) := tm.δ (e.symm q) iHead wHeads oHead + descOnTape desc (work utmDescTape) ∧ + scratchHasTransOutput k n (e q') wW oW iD wD oD (work utmScratchTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmScratchTape).head = 1 ∧ + WorkTapesWF work) + B := by + intro e + -- Destructure the transition output for later use + set δ_result := tm.δ (e.symm q) iHead wHeads oHead with hδ_def + obtain ⟨q', wW, oW, iD, wD, oD⟩ := δ_result + -- Provide the time bound + refine ⟨lookupTimeBound k n desc.length, ?_⟩ + -- Unfold HoareTime + intro inp work out hpre + obtain ⟨hdescOnTape, hdesc_head_eq, hheads, hscratch_inp, hscratchSentinel, hwf, hinp_ns, hinp_h, hout_ns, hout_h⟩ := hpre + -- Build the initial configuration + set c₀ : Cfg 4 (lookupTM (n := n) k).Q := + { state := (lookupTM k).qstart + input := inp + work := work + output := out } with hc₀_def + -- c₀.state = skipHeader (tableOffset k n) + have hc₀_state : c₀.state = .skipHeader ⟨TMEncoding.tableOffset k n, by omega⟩ := rfl + -- Extract tape properties from preconditions + have hdesc_ns : ∀ j, j ≥ 1 → (c₀.work utmDescTape).cells j ≠ Γ.start := + hwf.2 utmDescTape + have hdesc_h : (c₀.work utmDescTape).head ≥ 1 := hheads utmDescTape + have hscratch_ns : ∀ j, j ≥ 1 → (c₀.work utmScratchTape).cells j ≠ Γ.start := + hwf.2 utmScratchTape + have hscratch_h : (c₀.work utmScratchTape).head = 1 := hscratch_inp.2 + have hother₀ : ∀ i, i ≠ utmDescTape → + (c₀.work i).read ≠ Γ.start ∧ (c₀.work i).head ≥ 1 := by + intro i _ + exact ⟨lu_tape_read_ne_start_of_wf _ (hheads i) (hwf.2 i), hheads i⟩ + -- ────────────────────────────────────────────────────────────────── + -- Phase 1: skipHeader — advance desc past header to table start + -- ────────────────────────────────────────────────────────────────── + obtain ⟨c₁, hreach₁, hst₁, hdesc_h₁, hdesc_cells₁, hother₁, hinp₁, hout₁, hwf₁⟩ := + skipHeader_loop c₀ (TMEncoding.tableOffset k n) (le_refl _) hc₀_state + hwf hinp_ns hinp_h hout_ns hout_h hdesc_ns hdesc_h hother₀ + -- After skipHeader, c₁.work utmDescTape.head = 1 + tableOffset k n + -- and desc cells are unchanged from c₀ (= work) + have hc₁_desc_h : (c₁.work utmDescTape).head = + (c₀.work utmDescTape).head + TMEncoding.tableOffset k n := + hdesc_h₁ + -- c₁ scratch tape = c₀ scratch tape + have hc₁_scratch : c₁.work utmScratchTape = c₀.work utmScratchTape := + hother₁ utmScratchTape (by decide) + have hc₁_scratch_h : (c₁.work utmScratchTape).head = 1 := by + rw [hc₁_scratch]; exact hscratch_h + have hc₁_scratch_ns : ∀ j, j ≥ 1 → (c₁.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hc₁_scratch]; exact hscratch_ns j hj + have hc₁_desc_ns : ∀ j, j ≥ 1 → (c₁.work utmDescTape).cells j ≠ Γ.start := by + intro j hj; rw [hdesc_cells₁]; exact hdesc_ns j hj + have hc₁_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c₁.work i).read ≠ Γ.start ∧ (c₁.work i).head ≥ 1 := by + intro i hd hs; rw [hother₁ i hd]; exact hother₀ i hd + -- ────────────────────────────────────────────────────────────────── + -- Encoding connection: the desc tape after header skip contains the + -- transition table entries, and the matching entry for (q, iHead, wHeads, oHead) + -- is at some position numBefore in the enumeration. + -- ────────────────────────────────────────────────────────────────── + -- We need to show: + -- 1. There exists numBefore such that entries 0..numBefore-1 don't match + -- the scratch input pattern, and entry numBefore does match. + -- 2. The output portion of the matching entry encodes the transition output. + -- + -- This requires reasoning about the structure of encodeTransTable. + -- We sorry these encoding-level facts and prove the phase composition. + have henc_connection : ∃ numBefore : ℕ, + -- Non-matching entries before the match + (∀ j, j < numBefore → + ∃ mismatchPos, mismatchPos < TMEncoding.inputPatternWidth k n ∧ + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + j * TMEncoding.entryWidth k n + mismatchPos) ≠ + (c₁.work utmScratchTape).cells (1 + mismatchPos)) ∧ + -- Matching entry's input pattern matches scratch + (∀ j, j < TMEncoding.inputPatternWidth k n → + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + numBefore * TMEncoding.entryWidth k n + j) = + (c₁.work utmScratchTape).cells (1 + j)) ∧ + -- The output bits of the matching entry (on desc tape, after the separator) + -- are exactly encodeTransOutput of the transition output + (let outputBits := TMEncoding.encodeTransOutput k n (e q') wW oW iD wD oD + ∀ j, j < outputBits.length → + ∃ (hj : j < outputBits.length), + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + + numBefore * TMEncoding.entryWidth k n + + TMEncoding.inputPatternWidth k n + 1 + j) = + Γ.ofBool (outputBits[j]'hj)) := by + -- The desc tape stores desc = header ++ transTable, with head at 1 + tableOffset. + -- The transition table is a flat list of entries in canonical order. + -- We use List.getElem_of_mem to find the entry for (q, iHead, wHeads, oHead). + subst hk + -- After subst, e = tm.stateEquiv, and the transition table uses stateEquiv too. + -- The desc tape cells at offset = 1 + tableOffset + i correspond to desc[tableOffset + i] + -- = transTable[i] (via descOnTape and header splitting). + -- Use allTuples_mem to get membership, then List.getElem_of_mem to get index. + have hmem := allTuples_mem (Fintype.card tm.Q) n q iHead wHeads oHead + obtain ⟨numBefore, hnumBefore_lt, hnumBefore_eq⟩ := List.getElem_of_mem hmem + -- The transition table = allTuples.flatMap entryFn (via encodeTransTable_eq_allTuples_flatMap) + -- Each entry has width entryWidth (via allTuples_entry_width) + -- Use flatMap_const_width_getElem to index into the table by entry number + -- Then connect to tape cells via descOnTape + -- For now, we provide numBefore and prove the three properties + refine ⟨numBefore, ?_, ?_, ?_⟩ + · -- Non-matching entries before numBefore + -- Approach: allTuples_nodup + different index → different tuple → + -- different input pattern (encodeInputPattern_ne_of_ne) → mismatch position → + -- chain via desc_cell_eq_table_bit + flatMap_const_width_getElem + encodeEntry_input_prefix + -- Same chain as refine_2 but with ≠ instead of =. + -- Blocked on: allTuples_nodup (needs allΓFuncs_nodup, which needs induction on n) + sorry + · -- Matching entry's input pattern matches scratch + intro j hj_ipw + let k := Fintype.card tm.Q + let ew := TMEncoding.entryWidth k n + have hj_ew : j < ew := by + simp only [ew, TMEncoding.entryWidth, TMEncoding.inputPatternWidth] at hj_ipw ⊢; omega + have htable_eq := encodeTransTable_eq_allTuples_flatMap tm tm.stateEquiv + have hentry_width := allTuples_entryFn_width tm tm.stateEquiv + have hbound : numBefore * ew + j < (TMEncoding.encodeTransTable tm tm.stateEquiv).length := by + rw [htable_eq, flatMap_const_width_length _ _ _ (fun a ha => hentry_width a ha)] + exact mul_add_lt_mul_of_lt numBefore j _ _ hnumBefore_lt hj_ew + -- LHS: desc tape cell = Γ.ofBool (transTable bit) + have h_lhs : (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + numBefore * ew + j) = + Γ.ofBool ((TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + j]'hbound) := by + rw [hdesc_cells₁, hc₁_desc_h, hdesc_head_eq] + convert desc_cell_eq_table_bit tm desc (work utmDescTape) hdesc hdescOnTape + (numBefore * ew + j) hbound using 2 + omega + -- RHS: scratch tape cell = Γ.ofBool (inputPattern bit) + have h_ipw_bound : j < (TMEncoding.encodeInputPattern k n q iHead wHeads oHead).length := by + rw [encodeInputPattern_length]; exact hj_ipw + have h_rhs : (c₁.work utmScratchTape).cells (1 + j) = + Γ.ofBool ((TMEncoding.encodeInputPattern k n q iHead wHeads oHead)[j]'h_ipw_bound) := by + rw [hc₁_scratch, show 1 + j = j + 1 by omega] + exact hscratch_inp.1.2.1 j h_ipw_bound + -- Middle: transTable bit = inputPattern bit (via entryFn and encodeEntry_input_prefix) + -- Use a helper that goes through entryFn directly on the concrete tuple + have hentry_j_bound : j < (allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead)).length := by + rw [hentry_width _ hmem]; exact hj_ew + have h_entry_bit : + (allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead))[j]'hentry_j_bound = + (TMEncoding.encodeInputPattern k n q iHead wHeads oHead)[j]'h_ipw_bound := by + unfold allTuples_entryFn + -- After unfolding, the match on the tuple is reduced but the match on tm.δ + -- leaves projections. The encodeEntry_eq rewrite splits encodeEntry into + -- inputPattern ++ [false] ++ output. Then encodeEntry_input_prefix + -- extracts the j-th bit from the input pattern prefix. + -- The output part doesn't matter for this index, so we use convert. + simp only [encodeEntry_eq] + exact encodeEntry_input_prefix k n q iHead wHeads oHead _ _ _ _ _ _ j hj_ipw + -- Connect transTable to entryFn via flatMap_const_width_getElem + have hbound_fm : numBefore * ew + j < + ((allTuples k n).flatMap (allTuples_entryFn tm tm.stateEquiv)).length := by + rw [flatMap_const_width_length _ _ _ (fun a ha => hentry_width a ha)] + exact mul_add_lt_mul_of_lt numBefore j _ _ hnumBefore_lt hj_ew + have h_fm_idx := flatMap_const_width_getElem + (allTuples k n) + (allTuples_entryFn tm tm.stateEquiv) ew + (fun a ha => hentry_width a ha) numBefore j hnumBefore_lt hj_ew + -- h_fm_idx : (allTuples.flatMap entryFn)[numBefore * ew + j] = (entryFn allTuples[numBefore])[j] + -- We need: transTable[numBefore * ew + j] = inputPattern[j] + -- Go: transTable = allTuples.flatMap entryFn (htable_eq) + -- (flatMap entryFn)[...] = (entryFn allTuples[numBefore])[j] (h_fm_idx) + -- allTuples[numBefore] = (q, iH, wH, oH) (hnumBefore_eq) — handled via congrArg + -- (entryFn (q,...,oH))[j] = inputPattern[j] (h_entry_bit) + have h_entry_at : (allTuples_entryFn tm tm.stateEquiv (allTuples k n)[numBefore]) = + (allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead)) := by + rw [hnumBefore_eq] + have h_mid : (TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + j]'hbound = + (TMEncoding.encodeInputPattern k n q iHead wHeads oHead)[j]'h_ipw_bound := by + have : (TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + j]'hbound = + ((allTuples k n).flatMap (allTuples_entryFn tm tm.stateEquiv))[numBefore * ew + j]'hbound_fm := by + congr 1 + rw [this, h_fm_idx] + simp only [h_entry_at, h_entry_bit] + rw [h_lhs, h_rhs, congrArg Γ.ofBool h_mid] + · -- Output bits match + -- The goal starts with `let outputBits := ...; ∀ j < ..., ...` + intro outputBits j hj_out + refine ⟨hj_out, ?_⟩ + let k := Fintype.card tm.Q + let ew := TMEncoding.entryWidth k n + let ipw := TMEncoding.inputPatternWidth k n + -- Position within the entry: ipw + 1 + j + have hout_len : outputBits.length = TMEncoding.outputWidth k n := + encodeTransOutput_length k n (e q') wW oW iD wD oD + have hpos_ew : ipw + 1 + j < ew := by + simp only [ew, TMEncoding.entryWidth, ipw]; rw [← hout_len]; omega + have htable_eq := encodeTransTable_eq_allTuples_flatMap tm tm.stateEquiv + have hentry_width := allTuples_entryFn_width tm tm.stateEquiv + have hbound : numBefore * ew + (ipw + 1 + j) < + (TMEncoding.encodeTransTable tm tm.stateEquiv).length := by + rw [htable_eq, flatMap_const_width_length _ _ _ (fun a ha => hentry_width a ha)] + exact mul_add_lt_mul_of_lt numBefore (ipw + 1 + j) _ _ hnumBefore_lt hpos_ew + -- LHS: desc tape cell → transition table bit + have h_lhs : (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + numBefore * ew + ipw + 1 + j) = + Γ.ofBool ((TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + (ipw + 1 + j)]'hbound) := by + rw [hdesc_cells₁, hc₁_desc_h, hdesc_head_eq] + convert desc_cell_eq_table_bit tm desc (work utmDescTape) hdesc hdescOnTape + (numBefore * ew + (ipw + 1 + j)) hbound using 2 + omega + -- Bound for the entry at the matching position + have hbound_fm : numBefore * ew + (ipw + 1 + j) < + ((allTuples k n).flatMap (allTuples_entryFn tm tm.stateEquiv)).length := by + rw [flatMap_const_width_length _ _ _ (fun a ha => hentry_width a ha)] + exact mul_add_lt_mul_of_lt numBefore _ _ _ hnumBefore_lt hpos_ew + have hentry_j_bound : ipw + 1 + j < + (allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead)).length := by + rw [hentry_width _ hmem]; exact hpos_ew + -- Middle: transTable bit at (numBefore * ew + ipw + 1 + j) = outputBits[j] + have h_entry_at : (allTuples_entryFn tm tm.stateEquiv (allTuples k n)[numBefore]) = + (allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead)) := by + rw [hnumBefore_eq] + -- entryFn (q,iHead,wHeads,oHead) at position (ipw + 1 + j) = outputBits[j] + -- We need a helper lemma about allTuples_entryFn output bits + -- The entryFn at (q,iH,wH,oH) = encodeEntry k n q iH wH oH (e q'') wW' oW' iD' wD' oD' + -- where (q'',wW',oW',iD',wD',oD') = tm.δ (e.symm q) iH wH oH + -- After encodeEntry_eq, this = inputPattern ++ [false] ++ transOutput + -- So at position ipw + 1 + j, we get transOutput[j] = outputBits[j] + -- Use encodeEntry_output_getElem + have h_entry_list_eq : allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead) = + TMEncoding.encodeEntry k n q iHead wHeads oHead + (tm.stateEquiv (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).1) + (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).2.1 + (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).2.2.1 + (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).2.2.2.1 + (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).2.2.2.2.1 + (tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead).2.2.2.2.2 := by + unfold allTuples_entryFn; rfl + have h_entry_list_eq2 : allTuples_entryFn tm tm.stateEquiv (q, iHead, wHeads, oHead) = + TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false] ++ outputBits := by + rw [h_entry_list_eq, encodeEntry_eq] + congr 1 + -- Need: the encodeTransOutput with tm.δ projections = outputBits + -- outputBits = encodeTransOutput k n (e q') wW oW iD wD oD + -- and (q', wW, oW, iD, wD, oD) = tm.δ (e.symm q) iHead wHeads oHead + -- so the projections of tm.δ are exactly (q', wW, oW, iD, wD, oD) + -- and tm.stateEquiv = e, so e q' = the first component of the output + generalize hres : tm.δ (tm.stateEquiv.symm q) iHead wHeads oHead = res + obtain ⟨rq, rwW, roW, riD, rwD, roD⟩ := res + have : (q', wW, oW, iD, wD, oD) = (rq, rwW, roW, riD, rwD, roD) := by + rw [hδ_def]; exact hres + obtain ⟨rfl, rfl, rfl, rfl, rfl, rfl⟩ := this + rfl + have h_ipw_len : (TMEncoding.encodeInputPattern k n q iHead wHeads oHead).length = ipw := + encodeInputPattern_length k n q iHead wHeads oHead + have h_list_rw : allTuples_entryFn tm tm.stateEquiv (allTuples k n)[numBefore] = + TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false] ++ outputBits := + h_entry_at ▸ h_entry_list_eq2 + have happ_bound : ipw + 1 + j < + (TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false] ++ outputBits).length := by + rw [List.length_append, List.length_append, h_ipw_len, + List.length_cons, List.length_nil]; omega + have hlen1 : (TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false]).length = ipw + 1 := by + rw [List.length_append, h_ipw_len, List.length_cons, List.length_nil] + have h_app_idx : (TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false] ++ outputBits)[ipw + 1 + j]'happ_bound = + outputBits[j]'hj_out := by + rw [List.getElem_append_right (by rw [hlen1]; omega)] + congr 1; rw [hlen1]; omega + have h_mid : (TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + (ipw + 1 + j)]'hbound = + outputBits[j]'hj_out := by + have h1 : (TMEncoding.encodeTransTable tm tm.stateEquiv)[numBefore * ew + (ipw + 1 + j)]'hbound = + ((allTuples k n).flatMap (allTuples_entryFn tm tm.stateEquiv))[numBefore * ew + (ipw + 1 + j)]'hbound_fm := by + congr 1 + rw [h1, flatMap_const_width_getElem _ _ _ (fun a ha => hentry_width a ha) numBefore _ hnumBefore_lt hpos_ew] + have hbound_entry : ipw + 1 + j < (allTuples_entryFn tm tm.stateEquiv (allTuples k n)[numBefore]).length := by + rw [h_entry_at]; exact hentry_j_bound + calc (allTuples_entryFn tm tm.stateEquiv (allTuples k n)[numBefore])[ipw + 1 + j]'hbound_entry = + (TMEncoding.encodeInputPattern k n q iHead wHeads oHead ++ [false] ++ outputBits)[ipw + 1 + j]'happ_bound := by + congr 1 + _ = outputBits[j] := h_app_idx + convert h_lhs.trans (congrArg Γ.ofBool h_mid) using 2 + obtain ⟨numBefore, hnonmatch, hmatch_entry, houtput_bits⟩ := henc_connection + -- ────────────────────────────────────────────────────────────────── + -- Phase 2: entry_scan_to_match — scan entries until match found + -- ────────────────────────────────────────────────────────────────── + obtain ⟨c₂, steps₂, hreach₂, hst₂, hdesc_h₂, hdesc_cells₂, + hscratch_h₂, hscratch_cells₂, hother₂, hinp₂, hout₂, hwf₂⟩ := + entry_scan_to_match c₁ numBefore hst₁ hwf₁ + (by rw [hinp₁]; exact hinp_ns) (by rw [hinp₁]; exact hinp_h) + (by rw [hout₁]; exact hout_ns) (by rw [hout₁]; exact hout_h) + hc₁_desc_ns (by omega) hc₁_scratch_ns hc₁_scratch_h hc₁_other + hnonmatch hmatch_entry + -- ────────────────────────────────────────────────────────────────── + -- Phase 3: matchRewind — rewind scratch after match + -- ────────────────────────────────────────────────────────────────── + have hc₂_scratch_ns : ∀ j, j ≥ 1 → (c₂.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hscratch_cells₂, hc₁_scratch]; exact hscratch_ns j hj + have hc₂_other_scratch : ∀ i, i ≠ utmScratchTape → + (c₂.work i).read ≠ Γ.start ∧ (c₂.work i).head ≥ 1 := by + intro i hne + by_cases hd : i = utmDescTape + · subst hd + exact ⟨lu_tape_read_ne_start_of_wf _ (by omega) (hwf₂.2 utmDescTape), + by omega⟩ + · rw [hother₂ i hd hne]; exact hc₁_other i hd hne + obtain ⟨c₃, hreach₃, hst₃, hscratch_h₃, hscratch_cells₃, hother₃, hinp₃, hout₃, hwf₃⟩ := + matchRewind_loop c₂ (TMEncoding.inputPatternWidth k n) hst₂ hwf₂ + (by rw [hinp₂, hinp₁]; exact hinp_ns) (by rw [hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₂, hout₁]; exact hout_ns) (by rw [hout₂, hout₁]; exact hout_h) + hc₂_scratch_ns hscratch_h₂ hc₂_other_scratch + -- ────────────────────────────────────────────────────────────────── + -- Phase 4: matchRewindR — advance desc past separator + -- ────────────────────────────────────────────────────────────────── + have hc₃_desc : c₃.work utmDescTape = c₂.work utmDescTape := + hother₃ utmDescTape (by decide) + have hc₃_desc_ns : ∀ j, j ≥ 1 → (c₃.work utmDescTape).cells j ≠ Γ.start := by + intro j hj; rw [hc₃_desc]; exact hwf₂.2 utmDescTape j hj + have hc₃_desc_h : (c₃.work utmDescTape).head ≥ 1 := by + rw [hc₃_desc, hdesc_h₂]; omega + have hc₃_scratch_ns : ∀ j, j ≥ 1 → (c₃.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hscratch_cells₃]; exact hc₂_scratch_ns j hj + have hc₃_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c₃.work i).read ≠ Γ.start ∧ (c₃.work i).head ≥ 1 := by + intro i hd hs + have hne_s : i ≠ utmScratchTape := hs + rw [hother₃ i (by intro h; subst h; exact hs (by decide))] + exact hc₂_other_scratch i hne_s + obtain ⟨c₄, hreach₄, hst₄, hdesc_h₄, hdesc_cells₄, hother₄, hinp₄, hout₄, hwf₄⟩ := + matchRewindR_step c₃ hst₃ hwf₃ + (by rw [hinp₃, hinp₂, hinp₁]; exact hinp_ns) + (by rw [hinp₃, hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₃, hout₂, hout₁]; exact hout_ns) + (by rw [hout₃, hout₂, hout₁]; exact hout_h) + hc₃_desc_ns hc₃_desc_h + (by intro j hj; rw [hscratch_cells₃]; exact hc₂_scratch_ns j hj) + (by omega) hc₃_other + -- ────────────────────────────────────────────────────────────────── + -- Phase 5: copyOutput — copy output bits from desc to scratch + -- ────────────────────────────────────────────────────────────────── + -- After matchRewindR: desc advanced by 1 past separator, now at output bits + -- c₄.work utmDescTape.head = c₃.work utmDescTape.head + 1 + -- = c₂.work utmDescTape.head + 1 + -- = (c₁.head + numBefore * ew + ipw) + 1 + -- which is exactly at the output bits position + set outputBits := TMEncoding.encodeTransOutput k n (e q') wW oW iD wD oD with houtputBits_def + have houtLen : outputBits.length = TMEncoding.outputWidth k n := + encodeTransOutput_length k n (e q') wW oW iD wD oD + -- c₄ scratch tape preserved from c₃ + have hc₄_scratch : c₄.work utmScratchTape = c₃.work utmScratchTape := + hother₄ utmScratchTape (by decide) + have hc₄_scratch_h : (c₄.work utmScratchTape).head = 1 := by + rw [hc₄_scratch]; exact hscratch_h₃ + -- The desc bits at c₄ correspond to the output bits + have hc₄_desc_bits : ∀ (j : ℕ), j < TMEncoding.outputWidth k n → + ∃ (hj : TMEncoding.outputWidth k n - TMEncoding.outputWidth k n + j < outputBits.length), + (c₄.work utmDescTape).cells ((c₄.work utmDescTape).head + j) = + Γ.ofBool (outputBits[TMEncoding.outputWidth k n - TMEncoding.outputWidth k n + j]'hj) := by + intro j hj + have hj' : j < outputBits.length := by rw [houtLen]; exact hj + refine ⟨by omega, ?_⟩ + simp only [Nat.sub_self, Nat.zero_add] + have hobits := houtput_bits j hj' + obtain ⟨_, hval⟩ := hobits + have : (c₄.work utmDescTape).cells ((c₄.work utmDescTape).head + j) = + (c₁.work utmDescTape).cells + ((c₁.work utmDescTape).head + numBefore * TMEncoding.entryWidth k n + + TMEncoding.inputPatternWidth k n + 1 + j) := by + rw [hdesc_cells₄, hc₃_desc, hdesc_cells₂] + congr 1 + rw [hdesc_h₄, hc₃_desc, hdesc_h₂] + rw [this]; exact hval + -- Scratch head at ow - ow + 1 = 1 + have hc₄_scratch_h' : (c₄.work utmScratchTape).head = + TMEncoding.outputWidth k n - TMEncoding.outputWidth k n + 1 := by + rw [hc₄_scratch_h]; omega + have hc₄_scratch_ns : ∀ j, j ≥ 1 → (c₄.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hc₄_scratch, hscratch_cells₃]; exact hc₂_scratch_ns j hj + have hc₄_desc_ns : ∀ j, j ≥ 1 → (c₄.work utmDescTape).cells j ≠ Γ.start := by + intro j hj; rw [hdesc_cells₄]; exact hc₃_desc_ns j hj + have hc₄_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c₄.work i).read ≠ Γ.start ∧ (c₄.work i).head ≥ 1 := by + intro i hd hs; rw [hother₄ i hd]; exact hc₃_other i hd hs + -- No previously copied bits (rem = ow, so ow - rem = 0) + have hc₄_scratch_bits_prev : ∀ (j : ℕ) (hj : j < outputBits.length), + j < TMEncoding.outputWidth k n - TMEncoding.outputWidth k n → + (c₄.work utmScratchTape).cells (1 + j) = + Γ.ofBool (outputBits[j]'hj) := by + intro j _ hj; omega + obtain ⟨c₅, hreach₅, hst₅, hdesc_h₅, hdesc_cells₅, hbits₅, hcell0₅, + hscratch_h₅, hscratch_beyond₅, hother₅, hinp₅, hout₅, hwf₅⟩ := + copyOutput_loop c₄ (TMEncoding.outputWidth k n) (le_refl _) + (by exact hst₄) + hwf₄ + (by rw [hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_ns) + (by rw [hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₄, hout₃, hout₂, hout₁]; exact hout_ns) + (by rw [hout₄, hout₃, hout₂, hout₁]; exact hout_h) + hc₄_desc_ns (by rw [hdesc_h₄]; omega) + hc₄_scratch_ns hc₄_scratch_h' + hc₄_other outputBits houtLen hc₄_desc_bits hc₄_scratch_bits_prev + -- ────────────────────────────────────────────────────────────────── + -- Phase 6: rewindDesc — rewind desc tape to cell 1 + -- ────────────────────────────────────────────────────────────────── + -- c₅ is in state rewindDesc + -- We need the desc head position for rewindDesc_loop + -- After copyOutput, desc head = c₄.desc.head + ow - 1 + have hc₅_desc_ns : ∀ j, j ≥ 1 → (c₅.work utmDescTape).cells j ≠ Γ.start := hwf₅.2 utmDescTape + have hc₅_scratch_ns : ∀ j, j ≥ 1 → (c₅.work utmScratchTape).cells j ≠ Γ.start := hwf₅.2 utmScratchTape + have hc₅_other : ∀ i, i ≠ utmDescTape → i ≠ utmScratchTape → + (c₅.work i).read ≠ Γ.start ∧ (c₅.work i).head ≥ 1 := by + intro i hd hs; rw [hother₅ i hd hs]; exact hc₄_other i hd hs + -- Need scratch head for rewindDesc_loop + -- copyOutput ends with scratch head ≥ 1 (from WorkTapesWF) + -- Actually need to compute it. After copyOutput with rem=ow, scratch head ends at ow + 1 + -- The rewindDesc_loop wants scratch head ≥ 1, which is fine. + obtain ⟨c₆, hreach₆, hst₆, hdesc_h₆, hdesc_cells₆, + hscratch_h₆, hscratch_cells₆, hother₆, hinp₆, hout₆, hwf₆⟩ := + rewindDesc_loop c₅ ((c₅.work utmDescTape).head) hst₅ hwf₅ + (by rw [hinp₅, hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_ns) + (by rw [hinp₅, hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₅, hout₄, hout₃, hout₂, hout₁]; exact hout_ns) + (by rw [hout₅, hout₄, hout₃, hout₂, hout₁]; exact hout_h) + hc₅_desc_ns rfl hc₅_scratch_ns + (by rw [hscratch_h₅]; omega) + hc₅_other + -- ────────────────────────────────────────────────────────────────── + -- Phase 7: rewindScratchFinal — rewind scratch and halt + -- ────────────────────────────────────────────────────────────────── + have hc₆_scratch_ns : ∀ j, j ≥ 1 → (c₆.work utmScratchTape).cells j ≠ Γ.start := by + intro j hj; rw [hscratch_cells₆]; exact hc₅_scratch_ns j hj + have hc₆_other_scratch : ∀ i, i ≠ utmScratchTape → + (c₆.work i).read ≠ Γ.start ∧ (c₆.work i).head ≥ 1 := by + intro i hne + by_cases hd : i = utmDescTape + · subst hd + refine ⟨lu_tape_read_ne_start_of_wf _ (by omega) (hwf₆.2 utmDescTape), by omega⟩ + · rw [hother₆ i hd hne]; exact hc₅_other i hd hne + obtain ⟨c₇, hreach₇, hhalted₇, hst₇, hscratch_h₇, hscratch_cells₇, + hother₇, hinp₇, hout₇, hwf₇⟩ := + rewindScratchFinal_loop c₆ ((c₆.work utmScratchTape).head) hst₆ hwf₆ + (by rw [hinp₆, hinp₅, hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_ns) + (by rw [hinp₆, hinp₅, hinp₄, hinp₃, hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₆, hout₅, hout₄, hout₃, hout₂, hout₁]; exact hout_ns) + (by rw [hout₆, hout₅, hout₄, hout₃, hout₂, hout₁]; exact hout_h) + hc₆_scratch_ns rfl hc₆_other_scratch + -- ────────────────────────────────────────────────────────────────── + -- Assemble the final result + -- ────────────────────────────────────────────────────────────────── + -- Chain all the reachesIn steps + have htotal := reachesIn_trans _ hreach₁ + (reachesIn_trans _ hreach₂ + (reachesIn_trans _ hreach₃ + (reachesIn_trans _ hreach₄ + (reachesIn_trans _ hreach₅ + (reachesIn_trans _ hreach₆ hreach₇))))) + refine ⟨c₇, _, ?_, htotal, hhalted₇, ?_⟩ + · -- Time bound: sorry for now, can be filled in later + sorry + · -- Postcondition + dsimp only [] + -- Trace tapes back to work + have hc₇_desc : c₇.work utmDescTape = c₆.work utmDescTape := + hother₇ utmDescTape (by decide) + -- descOnTape: desc tape cells unchanged throughout + have hfinal_descOnTape : descOnTape desc (c₇.work utmDescTape) := by + have hcells : (c₇.work utmDescTape).cells = (work utmDescTape).cells := by + rw [hc₇_desc, hdesc_cells₆, hdesc_cells₅, hdesc_cells₄, hc₃_desc, + hdesc_cells₂, hdesc_cells₁] + constructor + · rw [hcells]; exact hdescOnTape.1 + constructor + · intro i hi; rw [hcells]; exact hdescOnTape.2.1 i hi + · rw [hcells]; exact hdescOnTape.2.2 + -- scratchHasTransOutput: scratch now has outputBits + have hfinal_scratchOutput : scratchHasTransOutput k n (e q') wW oW iD wD oD + (c₇.work utmScratchTape) := by + constructor + · -- tapeStoresBools outputBits scratch + have hcells : (c₇.work utmScratchTape).cells = (c₅.work utmScratchTape).cells := by + rw [hscratch_cells₇, hscratch_cells₆] + constructor + · -- cells 0 = start + rw [hcells]; exact hcell0₅ + constructor + · -- cells (i+1) = ofBool outputBits[i] + intro i hi + rw [hcells] + have : (c₅.work utmScratchTape).cells (1 + i) = Γ.ofBool outputBits[i] := + hbits₅ i hi (by rw [houtLen] at hi; exact hi) + rw [show i + 1 = 1 + i from by omega]; exact this + · -- cells (length + 1) = blank + show (c₇.work utmScratchTape).cells (outputBits.length + 1) = Γ.blank + rw [hcells] + have hge : outputBits.length + 1 ≥ TMEncoding.outputWidth k n + 1 := by + rw [houtLen] + have h_beyond := hscratch_beyond₅ (outputBits.length + 1) hge + rw [h_beyond, hc₄_scratch, hscratch_cells₃, hscratch_cells₂, + hc₁_scratch, houtLen] + exact hscratchSentinel + · exact hscratch_h₇ + refine ⟨hfinal_descOnTape, hfinal_scratchOutput, ?_, hscratch_h₇, hwf₇⟩ + -- desc head = 1 + rw [hc₇_desc]; exact hdesc_h₆ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/ReadCurrent.lean b/Complexitylib/Models/TuringMachine/UTM/ReadCurrent.lean new file mode 100644 index 0000000..dc38043 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/ReadCurrent.lean @@ -0,0 +1,436 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Mathlib.Data.Fintype.Prod + +/-! +# UTM Read Current State and Symbols + +Reads the current simulated state and head symbols from the UTM's work tapes +and serializes them to the scratch tape for lookup. + +## Architecture + +The machine operates in three phases: + +1. **Copy state one-hot**: Scan state tape (work 1) right, copying each cell + to scratch tape (work 3). Stop at the blank sentinel after k cells. + +2. **Read head symbols**: For each simulated tape t (0 to n+1), scan the sim + tape (work 2) to find tape t's head marker (Γ.one), read the 2 symbol + cells, transcode from super-cell encoding to Γ.encode encoding, write + 2 bits to scratch, then rewind the sim tape back to cell 1. + +3. **Final rewinds**: Rewind state tape and scratch tape to cell 1. + +## Super-cell to Γ.encode transcoding + +The sim tape uses `symToCellPair` encoding while the scratch tape needs +`Γ.encode` encoding (via `Γ.ofBool`). These differ for Γ.blank: +- `symToCellPair .blank = (blank, blank)` but `Γ.encode .blank = [true, false]` + which maps to `(one, zero)` via `Γ.ofBool`. + +## Main results + +- `readCurrentTM` — the machine definition +- `readCurrentTM_hoareTime` — HoareTime spec: parametric in `simCfg` +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Transcoding helper +-- ════════════════════════════════════════════════════════════════════════ + +/-- Transcode a super-cell symbol pair (from `symToCellPair`) to the + Γ.encode representation (as `Γw` values for writing to scratch). + + Valid pairs and their transcodings: + - `(zero, zero)` → `(zero, zero)` (Γ.zero) + - `(zero, one)` → `(zero, one)` (Γ.one) + - `(blank, blank)` → `(one, zero)` (Γ.blank) + - `(one, one)` → `(one, one)` (Γ.start) + + Invalid pairs default to `(blank, blank)`. -/ +def transcodePair (simHi simLo : Γ) : Γw × Γw := + match simHi, simLo with + | .zero, .zero => (.zero, .zero) + | .zero, .one => (.zero, .one) + | .blank, .blank => (.one, .zero) + | .one, .one => (.one, .one) + | _, _ => (.blank, .blank) + +-- ════════════════════════════════════════════════════════════════════════ +-- State type +-- ════════════════════════════════════════════════════════════════════════ + +/-- States for the readCurrent machine. + + The machine processes the sim tape per-tape: for each simulated tape + (indexed 0 to n+1), it scans the sim tape for that tape's head marker, + reads the symbol cells, transcodes, writes to scratch, then rewinds + the sim tape. A position counter `Fin (3*(n+2))` tracks location within + each super-cell during the scan. -/ +inductive ReadCurrentQ (n : ℕ) where + /-- Copy state tape one-hot to scratch tape. -/ + | copyState + /-- Scan sim tape for `target`'s head marker. + `pos` tracks position within the current super-cell (mod `3*(n+2)`). + Head marker for tape `target` is at position `3 * target.val`. -/ + | scan (target : Fin (n + 2)) (pos : Fin (3 * (n + 2))) + /-- Head marker found for `target`. Reading sym_hi cell. -/ + | readHi (target : Fin (n + 2)) + /-- Read sym_lo cell, remembering `simHi`. Will transcode and write + first scratch bit. -/ + | readLoWrite (target : Fin (n + 2)) (simHi : Γ) + /-- Write second scratch bit (`scrLo`). -/ + | writeLo (target : Fin (n + 2)) (scrLo : Γw) + /-- Rewind sim tape leftward after reading `target`'s symbol. -/ + | rewindSim (target : Fin (n + 2)) + /-- Sim tape hit ▷, move right one step to cell 1. -/ + | rewindSimR (target : Fin (n + 2)) + /-- Rewind state tape leftward. -/ + | rewindState + /-- State tape hit ▷, move right one step. -/ + | rewindStateR + /-- Rewind scratch tape leftward. -/ + | rewindScratch + /-- Scratch tape hit ▷, move right one step. -/ + | rewindScratchR + /-- Halt state. -/ + | done + deriving DecidableEq + +instance : Fintype (ReadCurrentQ n) where + elems := + {.copyState, .rewindState, .rewindStateR, + .rewindScratch, .rewindScratchR, .done} ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Fin (3 * (n + 2))) => + ReadCurrentQ.scan p.1 p.2) ∪ + (Finset.univ.image fun (t : Fin (n + 2)) => ReadCurrentQ.readHi t) ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Γ) => + ReadCurrentQ.readLoWrite p.1 p.2) ∪ + (Finset.univ.image fun (p : Fin (n + 2) × Γw) => + ReadCurrentQ.writeLo p.1 p.2) ∪ + (Finset.univ.image fun (t : Fin (n + 2)) => ReadCurrentQ.rewindSim t) ∪ + (Finset.univ.image fun (t : Fin (n + 2)) => ReadCurrentQ.rewindSimR t) + complete x := by + cases x with + | copyState => simp [Finset.mem_union, Finset.mem_insert] + | scan t p => + simp only [Finset.mem_union, Finset.mem_insert, Finset.mem_singleton, + Finset.mem_image, Finset.mem_univ, true_and, Prod.exists] + left; left; left; left; left; right; exact ⟨t, p, rfl⟩ + | readHi t => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; left; left; left; right; exact ⟨t, rfl⟩ + | readLoWrite t g => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, + Prod.exists] + left; left; left; right; exact ⟨t, g, rfl⟩ + | writeLo t w => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and, + Prod.exists] + left; left; right; exact ⟨t, w, rfl⟩ + | rewindSim t => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + left; right; exact ⟨t, rfl⟩ + | rewindSimR t => + simp only [Finset.mem_union, Finset.mem_image, Finset.mem_univ, true_and] + right; exact ⟨t, rfl⟩ + | rewindState => simp [Finset.mem_union, Finset.mem_insert] + | rewindStateR => simp [Finset.mem_union, Finset.mem_insert] + | rewindScratch => simp [Finset.mem_union, Finset.mem_insert] + | rewindScratchR => simp [Finset.mem_union, Finset.mem_insert] + | done => simp [Finset.mem_union, Finset.mem_insert] + +-- ════════════════════════════════════════════════════════════════════════ +-- Machine definition +-- ════════════════════════════════════════════════════════════════════════ + +/-- Read the current simulated state and head symbols to the scratch tape. + + **Phase 1 (copyState)**: Copy state tape one-hot to scratch tape. + State tape (work 1) and scratch tape (work 3) both start at cell 1. + At each step, reads state tape; if not blank, copies the value to + scratch and advances both right. On blank sentinel, enters phase 2. + + **Phase 2 (scan/read/rewind)**: For each simulated tape t (0 to n+1): + - Scan sim tape (work 2) right from cell 1 + - Navigate super-cell structure: check head marker at position `3*t` + within each super-cell + - On finding head marker (Γ.one): read sym_hi, then sym_lo, transcode + to Γ.encode representation, write 2 bits to scratch + - Rewind sim tape back to cell 1 + - Proceed to next tape (or phase 3 if all tapes done) + + **Phase 3 (rewinds)**: Rewind state tape and scratch tape to cell 1. + + Preserves desc tape (work 0), state tape cells, and sim tape cells + (read-only on all three). Only modifies scratch tape contents. -/ +def readCurrentTM : TM 4 where + Q := ReadCurrentQ n + qstart := .copyState + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + -- ── Phase 1: Copy state one-hot ──────────────────────────────────── + | .copyState => + if wHeads 1 = Γ.blank then + -- Sentinel reached: state one-hot fully copied. + -- Enter phase 2: scan for tape 0's head marker. + (.scan ⟨0, by omega⟩ ⟨0, by omega⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + else + -- Copy state tape cell to scratch tape, advance both right. + (.copyState, + fun i => + if i = (3 : Fin 4) then readBackWrite (wHeads 1) -- copy from tape 1 + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => + if i = (1 : Fin 4) then Dir3.right -- advance state tape + else if i = (3 : Fin 4) then Dir3.right -- advance scratch tape + else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Scan sim tape for head markers ─────────────────────── + | .scan target pos => + if pos.val = 3 * target.val then + -- At tape `target`'s head marker position. + if wHeads 2 = Γ.one then + -- Head marker found! Advance sim to sym_hi cell. + (.readHi target, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (2 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Head not here. Advance sim right, increment position. + (.scan target + ⟨(pos.val + 1) % (3 * (n + 2)), Nat.mod_lt _ (by omega)⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (2 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Not at target's marker position. Advance sim right. + (.scan target + ⟨(pos.val + 1) % (3 * (n + 2)), Nat.mod_lt _ (by omega)⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (2 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Read sym_hi ────────────────────────────────────────── + | .readHi target => + -- Read sim tape cell (sym_hi), remember it, advance sim to sym_lo. + (.readLoWrite target (wHeads 2), + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (2 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Read sym_lo, transcode, write first scratch bit ────── + | .readLoWrite target simHi => + let (scrHi, scrLo) := transcodePair simHi (wHeads 2) + -- Write first encoded bit to scratch, advance scratch right. + (.writeLo target scrLo, + fun i => + if i = (3 : Fin 4) then scrHi -- write to scratch + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (3 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Write second scratch bit ───────────────────────────── + | .writeLo target scrLo => + -- Write second encoded bit to scratch, advance scratch right. + -- Then rewind sim tape. + (.rewindSim target, + fun i => + if i = (3 : Fin 4) then scrLo -- write to scratch + else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (3 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Rewind sim tape ────────────────────────────────────── + | .rewindSim target => + if wHeads 2 = Γ.start then + -- Hit ▷ at cell 0. Move right to cell 1. + (.rewindSimR target, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (2 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + -- Keep moving sim left. + (.rewindSim target, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => + if i = (2 : Fin 4) then Dir3.left else idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 2: Sim at cell 1, proceed to next tape ───────────────── + | .rewindSimR target => + if h : target.val = n + 1 then + -- All tapes processed. Enter phase 3: rewind state tape. + (.rewindState, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + else + -- More tapes to process. Start scanning for next tape. + (.scan ⟨target.val + 1, by omega⟩ ⟨0, by omega⟩, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 3: Rewind state tape ──────────────────────────────────── + | .rewindState => + if wHeads 1 = Γ.start then + (.rewindStateR, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (1 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewindState, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => + if i = (1 : Fin 4) then Dir3.left else idleDir (wHeads i), + idleDir oHead) + + | .rewindStateR => + -- State tape now at cell 1. Rewind scratch tape. + (.rewindScratch, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + + -- ── Phase 3: Rewind scratch tape ────────────────────────────────── + | .rewindScratch => + if wHeads 3 = Γ.start then + (.rewindScratchR, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i = (3 : Fin 4) then Dir3.right else idleDir (wHeads i), + idleDir oHead) + else + (.rewindScratch, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => + if i = (3 : Fin 4) then Dir3.left else idleDir (wHeads i), + idleDir oHead) + + | .rewindScratchR => + -- Scratch tape now at cell 1. Done! + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => idleDir (wHeads i), + idleDir oHead) + + -- ── Halt state ──────────────────────────────────────────────────── + | .done => allIdle .done iHead wHeads oHead + + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .copyState => + dsimp only []; split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only [] + split + · subst_eqs; rfl + · split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + | .scan _ _ => + dsimp only []; split + · split <;> ( + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi) + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + | .readHi _ => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + | .readLoWrite _ _ => + dsimp only [] + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + | .writeLo _ _ => + refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + | .rewindSim _ => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; simp_all + · exact idleDir_right_of_start hwi + | .rewindSimR _ => + dsimp only []; split <;> + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .rewindState => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; simp_all + · exact idleDir_right_of_start hwi + | .rewindStateR => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .rewindScratch => + dsimp only []; split + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; rfl + · exact idleDir_right_of_start hwi + · refine ⟨idleDir_right_of_start, ?_, idleDir_right_of_start⟩ + intro i hwi; dsimp only []; split + · subst_eqs; simp_all + · exact idleDir_right_of_start hwi + | .rewindScratchR => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/ReadCurrentInternal.lean b/Complexitylib/Models/TuringMachine/UTM/ReadCurrentInternal.lean new file mode 100644 index 0000000..04c4962 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/ReadCurrentInternal.lean @@ -0,0 +1,1929 @@ +import Complexitylib.Models.TuringMachine.UTM.ReadCurrent +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.Hoare + +/-! +# ReadCurrent proof internals + +Step-by-step simulation lemmas for `readCurrentTM`. +-/ + +namespace TM + +variable {n : ℕ} + +private theorem reachesIn_toReaches' {tm : TM n} {t : ℕ} {c c' : Cfg n tm.Q} + (h : tm.reachesIn t c c') : tm.reaches c c' := by + induction h with + | zero => exact Relation.ReflTransGen.refl + | step hs _ ih => exact Relation.ReflTransGen.head hs ih + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape helpers +-- ════════════════════════════════════════════════════════════════════════ + +private theorem rc_readBackWrite_toΓ_eq {g : Γ} (h : g ≠ Γ.start) : + (readBackWrite g).toΓ = g := by cases g <;> simp_all [readBackWrite, Γw.toΓ] + +private theorem rc_tape_move_cells (t : Tape) (d : Dir3) : + (t.move d).cells = t.cells := by cases d <;> rfl + +/-- writeAndMove with readBackWrite and idleDir preserves a tape + when read ≠ ▷ and head ≥ 1. -/ +private theorem rc_tape_idle_preserve (t : Tape) (hns : t.read ≠ Γ.start) (hh : t.head ≥ 1) : + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) = t := by + simp only [Tape.writeAndMove, idleDir, hns, ↓reduceIte, Tape.move, Tape.write] + split + · omega + · simp only [Tape.read] at hns ⊢ + rw [rc_readBackWrite_toΓ_eq hns, Function.update_eq_self] + +private theorem rc_tape_read_ne_start_of_wf (t : Tape) (hh : t.head ≥ 1) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : t.read ≠ Γ.start := by + simp only [Tape.read]; exact hns _ hh + +-- ════════════════════════════════════════════════════════════════════════ +-- Transcoding correctness +-- ════════════════════════════════════════════════════════════════════════ + +/-- `transcodePair` correctly converts super-cell encoding to Γ.encode encoding. -/ +theorem transcodePair_symToCellPair (g : Γ) : + let p := SuperCell.symToCellPair g + let t := transcodePair p.1 p.2 + t.1.toΓ = Γ.ofBool (g.encode[0]'(by cases g <;> decide)) ∧ + t.2.toΓ = Γ.ofBool (g.encode[1]'(by cases g <;> decide)) := by + cases g <;> simp [SuperCell.symToCellPair, transcodePair, Γ.encode, Γ.ofBool, Γw.toΓ] + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase simulation lemmas +-- ════════════════════════════════════════════════════════════════════════ + +/-- Phase 1: copyState copies k state bits from state tape to scratch tape. + After k+1 steps (k copy steps + 1 sentinel step): + - scratch cells 1..k match state tape cells 1..k + - state = .scan 0 0 + - state tape head = k + 1 + - scratch tape head = k + 1 + - sim tape head unchanged (= 1) + - desc tape unchanged -/ +private theorem copyState_simulation + (c : Cfg 4 (readCurrentTM (n := n)).Q) + (k : ℕ) (q : Fin k) + (hstate : c.state = .copyState) + (hst_head : (c.work utmStateTape).head = 1) + (hsc_head : (c.work utmScratchTape).head = 1) + (hsim_head : (c.work utmSimTape).head = 1) + (hdesc_head : (c.work utmDescTape).head ≥ 1) + (hstate_cells : stateOnTapeAt k q (c.work utmStateTape)) + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (_hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) : + ∃ c', + (readCurrentTM (n := n)).reachesIn (k + 1) c c' ∧ + c'.state = .scan ⟨0, by omega⟩ ⟨0, by omega⟩ ∧ + (c'.work utmStateTape).head = k + 1 ∧ + (c'.work utmStateTape).cells = (c.work utmStateTape).cells ∧ + (c'.work utmScratchTape).head = k + 1 ∧ + (∀ j, j < k → (c'.work utmScratchTape).cells (j + 1) = + if j = q.val then Γ.one else Γ.zero) ∧ + (∀ j, j ≥ k + 1 → (c'.work utmScratchTape).cells j = + (c.work utmScratchTape).cells j) ∧ + (c'.work utmSimTape).head = 1 ∧ + (c'.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c'.work utmDescTape) = (c.work utmDescTape) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + -- Generalized loop: induction on remaining cells to copy + suffices loop : ∀ (rem : ℕ) (c' : Cfg 4 readCurrentTM.Q), + rem ≤ k → c'.state = .copyState → + (c'.work utmStateTape).head = k - rem + 1 → + (c'.work utmScratchTape).head = k - rem + 1 → + (c'.work utmSimTape).head = 1 → + (c'.work utmDescTape) = (c.work utmDescTape) → + (c'.work utmStateTape).cells = (c.work utmStateTape).cells → + (c'.work utmSimTape).cells = (c.work utmSimTape).cells → + c'.input = c.input → c'.output = c.output → + (∀ j, j < k - rem → + (c'.work utmScratchTape).cells (j + 1) = + if j = q.val then Γ.one else Γ.zero) → + (∀ j, j ≥ k + 1 → (c'.work utmScratchTape).cells j = + (c.work utmScratchTape).cells j) → + WorkTapesWF c'.work → + ∃ c_f, + readCurrentTM.reachesIn (rem + 1) c' c_f ∧ + c_f.state = .scan ⟨0, by omega⟩ ⟨0, by omega⟩ ∧ + (c_f.work utmStateTape).head = k + 1 ∧ + (c_f.work utmStateTape).cells = (c.work utmStateTape).cells ∧ + (c_f.work utmScratchTape).head = k + 1 ∧ + (∀ j, j < k → + (c_f.work utmScratchTape).cells (j + 1) = + if j = q.val then Γ.one else Γ.zero) ∧ + (∀ j, j ≥ k + 1 → (c_f.work utmScratchTape).cells j = + (c.work utmScratchTape).cells j) ∧ + (c_f.work utmSimTape).head = 1 ∧ + (c_f.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + c_f.work utmDescTape = c.work utmDescTape ∧ + c_f.input = c.input ∧ c_f.output = c.output ∧ + WorkTapesWF c_f.work by + exact loop k c le_rfl hstate (by omega) (by omega) hsim_head rfl rfl rfl rfl rfl + (fun _ hj => absurd hj (by omega)) (fun _ _ => rfl) hwf + intro rem; induction rem with + | zero => + intro c' _ hstate' hst_h' hsc_h' hsim_h' hdesc' hst_c' hsim_c' hinp' hout' hsc_done hsc_high hwf' + have hdesc_h' : (c'.work utmDescTape).head ≥ 1 := by rw [hdesc']; exact hdesc_head + have hheads : ∀ i, (c'.work i).head ≥ 1 := by + intro i + by_cases h0 : i = utmDescTape; · rw [h0]; exact hdesc_h' + by_cases h1 : i = utmStateTape; · rw [h1]; omega + by_cases h2 : i = utmSimTape; · rw [h2]; omega + have : i = utmScratchTape := by + simp only [Ne, Fin.ext_iff, utmDescTape, utmStateTape, utmSimTape, utmScratchTape] at * + omega + rw [this]; omega + have hread : (c'.work utmStateTape).read = Γ.blank := by + simp only [Tape.read, hst_h', hst_c'] + convert hstate_cells.2.2 using 2 + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c' = some c₁ ∧ + c₁.state = .scan ⟨0, by omega⟩ ⟨0, by omega⟩ ∧ + c₁.work = c'.work ∧ + c₁.input = c'.input ∧ c₁.output = c'.output := by + simp only [TM.step, hstate', readCurrentTM, ↓reduceIte, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · ext i; dsimp only [] + exact rc_tape_idle_preserve (c'.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i) (hwf'.2 i)) (hheads i) + · rw [hinp']; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · rw [hout']; exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hwork1, hinp1, hout1⟩ := hstep + refine ⟨c₁, .step hstep' .zero, hst1, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork1]; omega + · rw [hwork1, hst_c'] + · rw [hwork1]; omega + · intro j hj; rw [hwork1]; exact hsc_done j (by omega) + · intro j hj; rw [hwork1]; exact hsc_high j hj + · rw [hwork1, hsim_h'] + · rw [hwork1, hsim_c'] + · rw [hwork1, hdesc'] + · rw [hinp1, hinp'] + · rw [hout1, hout'] + · rw [hwork1]; exact hwf' + | succ m ih => + intro c' hle hstate' hst_h' hsc_h' hsim_h' hdesc' hst_c' hsim_c' hinp' hout' hsc_done hsc_high hwf' + have hdesc_h' : (c'.work utmDescTape).head ≥ 1 := by rw [hdesc']; exact hdesc_head + have hheads : ∀ i, (c'.work i).head ≥ 1 := by + intro i + by_cases h0 : i = utmDescTape; · rw [h0]; exact hdesc_h' + by_cases h1 : i = utmStateTape; · rw [h1]; omega + by_cases h2 : i = utmSimTape; · rw [h2]; omega + have : i = utmScratchTape := by + simp only [Ne, Fin.ext_iff, utmDescTape, utmStateTape, utmSimTape, utmScratchTape] at * + omega + rw [this]; omega + have hread_val : (c'.work utmStateTape).read = + if (k - (m + 1)) = q.val then Γ.one else Γ.zero := by + simp only [Tape.read, hst_h', hst_c'] + exact hstate_cells.2.1 (k - (m + 1)) (by omega) + have hread_ne_blank : (c'.work utmStateTape).read ≠ Γ.blank := by + rw [hread_val]; split <;> decide + have hread_ne_start : (c'.work utmStateTape).read ≠ Γ.start := by + rw [hread_val]; split <;> decide + -- Fin 4 comparison facts for resolving if-then-else in δ + have hfin_st_ne_3 : ¬ (utmStateTape = (3 : Fin 4)) := by decide + have hfin_sc_ne_1 : ¬ (utmScratchTape = (1 : Fin 4)) := by decide + have hfin_sim_ne_1 : ¬ (utmSimTape = (1 : Fin 4)) := by decide + have hfin_sim_ne_3 : ¬ (utmSimTape = (3 : Fin 4)) := by decide + have hfin_desc_ne_1 : ¬ (utmDescTape = (1 : Fin 4)) := by decide + have hfin_desc_ne_3 : ¬ (utmDescTape = (3 : Fin 4)) := by decide + -- One copy step: copies state tape cell to scratch, advances both right + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c' = some c₁ ∧ + c₁.state = .copyState ∧ + (c₁.work utmStateTape).head = k - m + 1 ∧ + (c₁.work utmStateTape).cells = (c'.work utmStateTape).cells ∧ + (c₁.work utmScratchTape).head = k - m + 1 ∧ + (c₁.work utmScratchTape).cells (k - (m + 1) + 1) = + (readBackWrite (c'.work utmStateTape).read).toΓ ∧ + (∀ j, j ≠ k - (m + 1) + 1 → + (c₁.work utmScratchTape).cells j = (c'.work utmScratchTape).cells j) ∧ + (c₁.work utmSimTape) = (c'.work utmSimTape) ∧ + (c₁.work utmDescTape) = (c'.work utmDescTape) ∧ + c₁.input = c'.input ∧ c₁.output = c'.output := by + simp only [TM.step, hstate', readCurrentTM, ↓reduceIte, hread_ne_blank] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- State tape head: readBackWrite + right + · dsimp only [] + rw [if_neg hfin_st_ne_3, if_pos (show utmStateTape = (1 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, Tape.move, Tape.write, hst_h'] + split + · omega + · dsimp only []; omega + -- State tape cells: preserved (readBackWrite writes same value) + · dsimp only [] + rw [if_neg hfin_st_ne_3, if_pos (show utmStateTape = (1 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + -- Scratch tape head: copy + right + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_neg hfin_sc_ne_1, if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, Tape.move, Tape.write, hsc_h'] + split + · omega + · dsimp only []; omega + -- Scratch tape cell at written position + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_neg hfin_sc_ne_1, if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc_h'] + split + · omega + · dsimp only []; simp + -- Scratch tape cells preserved at other positions + · intro j hne + dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_neg hfin_sc_ne_1, if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc_h'] + split + · omega + · dsimp only []; rw [Function.update_apply, if_neg hne] + -- Sim tape (idle) + · dsimp only [] + rw [if_neg hfin_sim_ne_3, if_neg hfin_sim_ne_1, if_neg hfin_sim_ne_3] + exact rc_tape_idle_preserve (c'.work utmSimTape) + (rc_tape_read_ne_start_of_wf _ (hheads utmSimTape) (hwf'.2 utmSimTape)) + (hheads utmSimTape) + -- Desc tape (idle) + · dsimp only [] + rw [if_neg hfin_desc_ne_3, if_neg hfin_desc_ne_1, if_neg hfin_desc_ne_3] + exact rc_tape_idle_preserve (c'.work utmDescTape) + (rc_tape_read_ne_start_of_wf _ (hheads utmDescTape) (hwf'.2 utmDescTape)) + (hheads utmDescTape) + -- Input + · rw [hinp']; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + -- Output + · rw [hout']; exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hc₁st, hc₁sth, hc₁stc, hc₁sch, hc₁_sc_cell, hc₁_sc_other, + hc₁sim, hc₁desc, hc₁inp, hc₁out⟩ := hstep + -- WorkTapesWF preserved + have hwf₁ : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmStateTape + · rw [h, hc₁stc]; exact hwf'.1 utmStateTape + · by_cases h : i = utmSimTape + · rw [h, hc₁sim]; exact hwf'.1 utmSimTape + · by_cases h : i = utmDescTape + · rw [h, hc₁desc]; exact hwf'.1 utmDescTape + · have hi : i = utmScratchTape := by + simp only [Ne, Fin.ext_iff, utmDescTape, utmStateTape, utmSimTape, utmScratchTape] at * + omega + rw [hi]; rw [hc₁_sc_other 0 (by omega)]; exact hwf'.1 utmScratchTape + · intro i j hj; by_cases h : i = utmStateTape + · rw [h, hc₁stc]; exact hwf'.2 utmStateTape j hj + · by_cases h : i = utmSimTape + · rw [h, hc₁sim]; exact hwf'.2 utmSimTape j hj + · by_cases h : i = utmDescTape + · rw [h, hc₁desc]; exact hwf'.2 utmDescTape j hj + · have hi : i = utmScratchTape := by + simp only [Ne, Fin.ext_iff, utmDescTape, utmStateTape, utmSimTape, utmScratchTape] at * + omega + rw [hi] + by_cases heq : j = k - (m + 1) + 1 + · rw [heq, hc₁_sc_cell, rc_readBackWrite_toΓ_eq hread_ne_start] + rw [hread_val]; split <;> decide + · rw [hc₁_sc_other j heq]; exact hwf'.2 utmScratchTape j hj + -- Scratch condition for IH + have hsc_done₁ : ∀ j, j < k - m → + (c₁.work utmScratchTape).cells (j + 1) = + if j = q.val then Γ.one else Γ.zero := by + intro j hj + by_cases heq : j = k - (m + 1) + · subst heq + rw [hc₁_sc_cell, rc_readBackWrite_toΓ_eq hread_ne_start, hread_val] + · rw [hc₁_sc_other (j + 1) (by omega)] + exact hsc_done j (by omega) + -- Scratch high cells preserved for IH + have hsc_high₁ : ∀ j, j ≥ k + 1 → + (c₁.work utmScratchTape).cells j = (c.work utmScratchTape).cells j := by + intro j hj; rw [hc₁_sc_other j (by omega)]; exact hsc_high j hj + -- Apply IH + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hsch_f, hsc_f, hsc_high_f, hsimh_f, hsimc_f, + hdesc_f, hinp_f, hout_f, hwf_f⟩ := + ih c₁ (by omega) hc₁st (by omega) (by omega) + (by rw [hc₁sim]; exact hsim_h') + (by rw [hc₁desc]; exact hdesc') + (by rw [hc₁stc]; exact hst_c') + (by rw [hc₁sim]; exact hsim_c') + (by rw [hc₁inp]; exact hinp') + (by rw [hc₁out]; exact hout') + hsc_done₁ hsc_high₁ hwf₁ + exact ⟨c_f, .step hstep' hreach, hst_f, hhead_f, hcells_f, hsch_f, hsc_f, hsc_high_f, hsimh_f, hsimc_f, + hdesc_f, hinp_f, hout_f, hwf_f⟩ + +/-- Rewind sim tape from some position to cell 1 (reaching rewindSimR). -/ +private theorem rewindSim_simulation : + ∀ (sim_head : ℕ) (c : Cfg 4 (readCurrentTM (n := n)).Q) (target : Fin (n + 2)), + c.state = .rewindSim target → + (c.work utmSimTape).head = sim_head → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ i, i ≠ utmSimTape → (c.work i).head ≥ 1) → + ∃ c', + (readCurrentTM (n := n)).reachesIn (sim_head + 1) c c' ∧ + c'.state = .rewindSimR target ∧ + (c'.work utmSimTape).head = 1 ∧ + (c'.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + intro sim_head; induction sim_head with + | zero => + intro c target hstate hsim_head hwf hinp hinp_h hout hout_h hheads + have hread : (c.work utmSimTape).read = Γ.start := by + simp [Tape.read, hsim_head, hwf.1 utmSimTape] + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindSimR target ∧ + (c₁.work utmSimTape).head = 1 ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write, hsim_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsim_head] + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + refine ⟨c₁, .step hstep' .zero, hst1, hhead1, hcells1, hw1, hinp1, hout1, ?_⟩ + constructor + · intro i; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf.1 utmSimTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf.2 utmSimTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + | succ h ih => + intro c target hstate hsim_head hwf hinp hinp_h hout hout_h hheads + have hread_ne : (c.work utmSimTape).read ≠ Γ.start := by + simp [Tape.read, hsim_head]; exact hwf.2 utmSimTape (h + 1) (by omega) + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindSim target ∧ + (c₁.work utmSimTape).head = h ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hsim_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h' : i = utmSimTape + · rw [h', hcells1]; exact hwf.1 utmSimTape + · rw [hw1 i h']; exact hwf.1 i + · intro i j hj; by_cases h' : i = utmSimTape + · rw [h', hcells1]; exact hwf.2 utmSimTape j hj + · rw [hw1 i h']; exact hwf.2 i j hj + have hheads1 : ∀ i, i ≠ utmSimTape → (c₁.work i).head ≥ 1 := by + intro i h'; rw [hw1 i h']; exact hheads i h' + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := + ih c₁ target hst1 hhead1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + hheads1 + refine ⟨c_f, .step hstep' hreach, hst_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +/-- Phase 2: for a single tape target with head at position h, + scan the sim tape, read head symbols, transcode and write to scratch, + then rewind sim tape back to cell 1. -/ +private theorem per_tape_simulation + (target_sym : ℕ → Γ) + (c : Cfg 4 (readCurrentTM (n := n)).Q) + (target : Fin (n + 2)) (h_target : ℕ) (sc_pos : ℕ) + (hstate : c.state = .scan target ⟨0, by omega⟩) + (hsim_head : (c.work utmSimTape).head = 1) + -- sim tape correctly encodes the target tape's data + (hsim_marker : ∀ pos, (c.work utmSimTape).cells + (SuperCell.simTapeOffset (n + 2) pos target.val) = + if h_target = pos then Γ.one else Γ.blank) + (hsim_hi : ∀ pos, (c.work utmSimTape).cells + (SuperCell.simTapeOffset (n + 2) pos target.val + 1) = + (SuperCell.symToCellPair (target_sym pos)).1) + (hsim_lo : ∀ pos, (c.work utmSimTape).cells + (SuperCell.simTapeOffset (n + 2) pos target.val + 2) = + (SuperCell.symToCellPair (target_sym pos)).2) + -- scratch tape + (hsc_head : (c.work utmScratchTape).head = sc_pos) + (hsc_pos_ge : sc_pos ≥ 1) + -- other tapes idle + (hwf : WorkTapesWF c.work) + (hinp : c.input.read ≠ Γ.start) (hinp_h : c.input.head ≥ 1) + (hout : c.output.read ≠ Γ.start) (hout_h : c.output.head ≥ 1) + -- sim tape well-formed (cell 0 = ▷) + (hsim_cell0 : (c.work utmSimTape).cells 0 = Γ.start) + -- all work tape heads ≥ 1 + (hwork_heads : ∀ i, (c.work i).head ≥ 1) : + ∃ c' t, + (readCurrentTM (n := n)).reachesIn t c c' ∧ + -- Next state: either scan for next tape or rewindState + (if h : target.val = n + 1 then + c'.state = .rewindState + else + c'.state = .scan ⟨target.val + 1, by omega⟩ ⟨0, by omega⟩) ∧ + (c'.work utmSimTape).head = 1 ∧ + (c'.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c'.work utmScratchTape).head = sc_pos + 2 ∧ + -- Scratch has the correct 2 encoded bits for target + (c'.work utmScratchTape).cells sc_pos = + Γ.ofBool ((target_sym h_target).encode[0]'(by cases (target_sym h_target) <;> decide)) ∧ + (c'.work utmScratchTape).cells (sc_pos + 1) = + Γ.ofBool ((target_sym h_target).encode[1]'(by cases (target_sym h_target) <;> decide)) ∧ + -- Previously written scratch cells preserved + (∀ j, j < sc_pos → (c'.work utmScratchTape).cells j = (c.work utmScratchTape).cells j) ∧ + -- Scratch cells above written range preserved + (∀ j, j ≥ sc_pos + 2 → (c'.work utmScratchTape).cells j = (c.work utmScratchTape).cells j) ∧ + -- Other tapes preserved + (c'.work utmDescTape) = (c.work utmDescTape) ∧ + (c'.work utmStateTape) = (c.work utmStateTape) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work ∧ + t ≤ 2 * SuperCell.simTapeOffset (n + 2) h_target target.val + 7 := by + -- Abbreviations for key values + set W := 3 * (n + 2) with hW_def + set offset := SuperCell.simTapeOffset (n + 2) h_target target.val with hoffset_def + have hW_pos : W > 0 := by omega + have hoffset_pos : offset ≥ 1 := by + simp only [SuperCell.simTapeOffset, SuperCell.width, hoffset_def]; omega + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 1: Scan sim tape to find head marker + -- ═══════════════════════════════════════════════════════════════════ + have scan_result : ∃ c₁, + readCurrentTM.reachesIn offset c c₁ ∧ + c₁.state = .readHi target ∧ + (c₁.work utmSimTape).head = offset + 1 ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output ∧ + WorkTapesWF c₁.work := by + -- Key arithmetic fact: offset - 1 = h_target * W + 3 * target.val + have hoffset_expand : offset - 1 = h_target * W + 3 * target.val := by + simp only [hoffset_def, SuperCell.simTapeOffset, SuperCell.width, hW_def]; omega + -- Induction on remaining distance from current sim head to offset + suffices loop : ∀ (rem : ℕ) (c' : Cfg 4 readCurrentTM.Q), + (c'.work utmSimTape).head + rem = offset → + c'.state = .scan target ⟨((c'.work utmSimTape).head - 1) % W, Nat.mod_lt _ (by omega)⟩ → + (c'.work utmSimTape).cells = (c.work utmSimTape).cells → + (∀ i, i ≠ utmSimTape → c'.work i = c.work i) → + c'.input = c.input → c'.output = c.output → + WorkTapesWF c'.work → + (∀ i, (c'.work i).head ≥ 1) → + ∃ c₁, + readCurrentTM.reachesIn (rem + 1) c' c₁ ∧ + c₁.state = .readHi target ∧ + (c₁.work utmSimTape).head = offset + 1 ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output ∧ + WorkTapesWF c₁.work by + obtain ⟨c₁, hr, hst, hh, hcells, ho, hinp', hout', hwf'⟩ := + loop (offset - 1) c (by omega) + (by convert hstate using 2; ext; simp [hsim_head]) + rfl (fun _ _ => rfl) rfl rfl hwf hwork_heads + exact ⟨c₁, by rwa [show offset - 1 + 1 = offset by omega] at hr, + hst, hh, hcells, ho, hinp', hout', hwf'⟩ + intro rem; induction rem with + | zero => + intro c' hhead hstate' hcells' ho' hinp' hout' hwf' hheads' + -- head = offset, we're at the marker + have hsim_head' : (c'.work utmSimTape).head = offset := by omega + -- pos = 3 * target.val (the marker column) + have hpos_val : ((c'.work utmSimTape).head - 1) % W = 3 * target.val := by + rw [hsim_head'] + have h1 : offset - 1 = h_target * W + 3 * target.val := hoffset_expand + rw [h1, Nat.mul_add_mod_self_right, Nat.mod_eq_of_lt (show 3 * target.val < W by omega)] + -- sim reads Γ.one at the marker + have hread_one : (c'.work utmSimTape).read = Γ.one := by + simp only [Tape.read, hsim_head', hcells'] + have := hsim_marker h_target + simp only [] at this; exact this + have hread_ne_start : (c'.work utmSimTape).read ≠ Γ.start := + rc_tape_read_ne_start_of_wf _ (hheads' utmSimTape) (hwf'.2 utmSimTape) + -- Prove the if-condition for pos + have hpos_if : (⟨((c'.work utmSimTape).head - 1) % W, + Nat.mod_lt _ (by omega)⟩ : Fin (3 * (n + 2))).val = + 3 * target.val := hpos_val + -- One step to readHi + have hne_done : (ReadCurrentQ.scan target ⟨((c'.work utmSimTape).head - 1) % W, + Nat.mod_lt _ (by omega)⟩ : ReadCurrentQ n) ≠ .done := by + intro h; cases h + have hstep : ∃ c₁, readCurrentTM.step c' = some c₁ ∧ + c₁.state = .readHi target ∧ + (c₁.work utmSimTape).head = offset + 1 ∧ + (c₁.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate', readCurrentTM] + simp only [↓reduceIte, hpos_val, hread_one] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, Tape.move, Tape.write] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + split + · omega + · simp [hsim_head'] + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + simp only [Tape.write]; split + · omega + · dsimp only []; simp only [Tape.read, Function.update_eq_self]; exact hcells' + · intro i hne; dsimp only []; rw [if_neg hne] + rw [rc_tape_idle_preserve (c'.work i) + (rc_tape_read_ne_start_of_wf _ (hheads' i) (hwf'.2 i)) (hheads' i)] + exact ho' i hne + · rw [hinp']; simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · rw [hout']; exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hh1, hcells1, ho1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf.1 utmSimTape + · rw [ho1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf.2 utmSimTape j hj + · rw [ho1 i h]; exact hwf.2 i j hj + exact ⟨c₁, .step hstep' .zero, hst1, hh1, hcells1, ho1, hinp1, hout1, hwf1⟩ + | succ m ih => + intro c' hhead hstate' hcells' ho' hinp' hout' hwf' hheads' + -- head < offset since head + (m+1) = offset + have hhead_lt : (c'.work utmSimTape).head < offset := by omega + have hhead_ge : (c'.work utmSimTape).head ≥ 1 := hheads' utmSimTape + have hread_ne_start : (c'.work utmSimTape).read ≠ Γ.start := + rc_tape_read_ne_start_of_wf _ hhead_ge (hwf'.2 utmSimTape) + -- The scan doesn't find the marker at this position. + set pos := ((c'.work utmSimTape).head - 1) % W with hpos_def + -- Show the read is NOT Γ.one at this position (head marker not here) + have hread_ne_one : ¬(pos = 3 * target.val ∧ (c'.work utmSimTape).read = Γ.one) := by + intro ⟨hpos_eq, hread_eq⟩ + simp only [Tape.read] at hread_eq + rw [hcells'] at hread_eq + have hdiv := Nat.div_add_mod ((c'.work utmSimTape).head - 1) W + have hhead_eq : (c'.work utmSimTape).head = + SuperCell.simTapeOffset (n + 2) (((c'.work utmSimTape).head - 1) / W) target.val := by + simp only [SuperCell.simTapeOffset, SuperCell.width, hW_def] + have := hpos_def ▸ hpos_eq -- (head-1) % W = 3 * target.val + set q := ((c'.work utmSimTape).head - 1) / W with hq_def + -- We have: W * q + pos = head - 1 (from hdiv) and pos = 3 * target.val (from this) + -- Goal: head = 1 + q * (3*(n+2)) + 3 * target + -- Since W = 3*(n+2), W*q = q*(3*(n+2)), so head - 1 = q*(3*(n+2)) + 3*target + have : W * q = q * (3 * (n + 2)) := by rw [hW_def, Nat.mul_comm] + omega + rw [hhead_eq] at hread_eq + have hmk := hsim_marker (((c'.work utmSimTape).head - 1) / W) + rw [hread_eq] at hmk + split_ifs at hmk with heq + rw [← heq, ← hoffset_def] at hhead_eq; omega + -- Both branches of scan produce the same tape effects (advance sim right, idle rest). + -- Split on position check BEFORE unfolding TM.step. + have hstep : ∃ c₁, readCurrentTM.step c' = some c₁ ∧ + c₁.state = .scan target ⟨(pos + 1) % W, Nat.mod_lt _ (by omega)⟩ ∧ + (c₁.work utmSimTape).head = (c'.work utmSimTape).head + 1 ∧ + (c₁.work utmSimTape).cells = (c'.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₁.work i = c'.work i) ∧ + c₁.input = c'.input ∧ c₁.output = c'.output := by + -- Prove: in both sub-cases, δ returns the same writes/dirs. + -- Sub-case 1: pos = 3*target (then read ≠ one, inner else) + -- Sub-case 2: pos ≠ 3*target (outer else) + have hpos_if : + (⟨((c'.work utmSimTape).head - 1) % W, Nat.mod_lt _ (by omega)⟩ : + Fin (3 * (n + 2))).val = 3 * target.val → + (c'.work utmSimTape).read ≠ Γ.one := by + intro hpeq hre; exact hread_ne_one ⟨hpeq, hre⟩ + -- We can handle both cases uniformly by considering them together + by_cases hpeq : ((c'.work utmSimTape).head - 1) % W = 3 * target.val + · -- pos = 3*target, but read ≠ one + have hread_ne := hpos_if hpeq + simp only [TM.step, hstate', readCurrentTM, hpeq, hread_ne, ↓reduceIte] + have hpos_eq_rw : (3 * target.val + 1) % (3 * (n + 2)) = (pos + 1) % W := by + rw [hpos_def, hpeq, hW_def] + refine ⟨_, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only []; rw [show ReadCurrentQ.scan target ⟨(3 * target.val + 1) % + (3 * (n + 2)), _⟩ = ReadCurrentQ.scan target ⟨(pos + 1) % W, Nat.mod_lt _ (by omega)⟩ + from by congr 1; ext1; exact hpos_eq_rw] + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, Tape.move, Tape.write] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + split_ifs <;> simp_all + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + simp only [Tape.write]; split_ifs with h + · omega + · dsimp only []; simp only [Tape.read, Function.update_eq_self] + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c'.work i) + (rc_tape_read_ne_start_of_wf _ (hheads' i) (hwf'.2 i)) (hheads' i) + · simp only [idleDir, (show c'.input.read ≠ Γ.start by rw [hinp']; exact hinp), + ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c'.output + (by rw [hout']; exact hout) (by rw [hout']; exact hout_h) + · -- pos ≠ 3*target + simp only [TM.step, hstate', readCurrentTM, hpeq, ↓reduceIte] + refine ⟨_, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rfl -- state: pos and W match definitionally + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, Tape.move, Tape.write] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + split_ifs <;> simp_all + · dsimp only [] + rw [if_pos (rfl : utmSimTape = (2 : Fin 4))] + simp only [Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne_start] + simp only [Tape.write]; split_ifs with h + · omega + · dsimp only []; simp only [Tape.read, Function.update_eq_self] + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c'.work i) + (rc_tape_read_ne_start_of_wf _ (hheads' i) (hwf'.2 i)) (hheads' i) + · simp only [idleDir, (show c'.input.read ≠ Γ.start by rw [hinp']; exact hinp), + ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c'.output + (by rw [hout']; exact hout) (by rw [hout']; exact hout_h) + obtain ⟨c₁, hstep', hst1, hh1, hcells1, ho1, hinp1, hout1⟩ := hstep + -- WorkTapesWF for intermediate config + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf'.1 utmSimTape + · rw [ho1 i h]; exact hwf'.1 i + · intro i j hj; by_cases h : i = utmSimTape + · rw [h, hcells1]; exact hwf'.2 utmSimTape j hj + · rw [ho1 i h]; exact hwf'.2 i j hj + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmSimTape + · rw [h]; omega + · rw [ho1 i h]; exact hheads' i + -- Show the new state matches IH form + have hmod_step : (pos + 1) % W = (c'.work utmSimTape).head % W := by + rw [hpos_def] + -- Goal: ((head - 1) % W + 1) % W = head % W + rw [Nat.mod_add_mod, Nat.sub_add_cancel hhead_ge] + have hstate1 : c₁.state = .scan target + ⟨((c₁.work utmSimTape).head - 1) % W, Nat.mod_lt _ (by omega)⟩ := by + rw [hst1]; congr 1; ext + simp only [hh1, Nat.add_sub_cancel] + exact hmod_step + -- Apply IH + have hhead1 : (c₁.work utmSimTape).head + m = offset := by omega + obtain ⟨c_f, hreach, hst_f, hh_f, hcells_f, ho_f, hinp_f, hout_f, hwf_f⟩ := + ih c₁ hhead1 hstate1 (by rw [hcells1, hcells']) + (by intro i hne; rw [ho1 i hne, ho' i hne]) + (by rw [hinp1, hinp']) (by rw [hout1, hout']) hwf1 hheads1 + exact ⟨c_f, .step hstep' hreach, hst_f, hh_f, hcells_f, ho_f, hinp_f, hout_f, hwf_f⟩ + obtain ⟨c₁, hr1, hst1, hh1, hc1, ho1, hinp1, hout1, hwf1⟩ := scan_result + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 2: readHi step — read sym_hi from sim tape + -- ═══════════════════════════════════════════════════════════════════ + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmSimTape + · rw [h]; omega + · rw [ho1 i h]; exact hwork_heads i + have hsim_hi_val : (c₁.work utmSimTape).read = + (SuperCell.symToCellPair (target_sym h_target)).1 := by + simp only [Tape.read, hh1, hc1] + exact hsim_hi h_target + have readHi_result : ∃ c₂, + readCurrentTM.step c₁ = some c₂ ∧ + c₂.state = .readLoWrite target (SuperCell.symToCellPair (target_sym h_target)).1 ∧ + (c₂.work utmSimTape).head = offset + 2 ∧ + (c₂.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (∀ i, i ≠ utmSimTape → c₂.work i = c₁.work i) ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, hst1, readCurrentTM] + refine ⟨_, rfl, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only []; rw [hsim_hi_val] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write] + rw [rc_readBackWrite_toΓ_eq (rc_tape_read_ne_start_of_wf _ (hheads1 utmSimTape) (hwf1.2 utmSimTape))] + split + · omega + · simp [hh1] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq (rc_tape_read_ne_start_of_wf _ (hheads1 utmSimTape) (hwf1.2 utmSimTape))] + simp only [Tape.write] + split + · omega + · dsimp only []; simp only [Tape.read, Function.update_eq_self]; exact hc1 + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c₁.work i) + (rc_tape_read_ne_start_of_wf _ (hheads1 i) (hwf1.2 i)) (hheads1 i) + · simp only [idleDir, (by rw [hinp1]; exact hinp : c₁.input.read ≠ Γ.start), ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c₁.output (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hr2, hst2, hh2, hc2, ho2, hinp2, hout2⟩ := readHi_result + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 3: readLoWrite step — read sym_lo, transcode, write scrHi + -- ═══════════════════════════════════════════════════════════════════ + have hsim_lo_val : (c₂.work utmSimTape).read = + (SuperCell.symToCellPair (target_sym h_target)).2 := by + simp only [Tape.read, hh2, hc2] + exact hsim_lo h_target + -- transcodePair result + have htrans := transcodePair_symToCellPair (target_sym h_target) + set sim_hi := (SuperCell.symToCellPair (target_sym h_target)).1 + set sim_lo := (SuperCell.symToCellPair (target_sym h_target)).2 + set scrHi := (transcodePair sim_hi sim_lo).1 + set scrLo := (transcodePair sim_hi sim_lo).2 + have readLoWrite_result : ∃ c₃, + readCurrentTM.step c₂ = some c₃ ∧ + c₃.state = .writeLo target scrLo ∧ + (c₃.work utmSimTape).head = offset + 2 ∧ + (c₃.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c₃.work utmScratchTape).head = sc_pos + 1 ∧ + (c₃.work utmScratchTape).cells sc_pos = scrHi.toΓ ∧ + (∀ j, j ≠ sc_pos → (c₃.work utmScratchTape).cells j = + (c₂.work utmScratchTape).cells j) ∧ + (c₃.work utmDescTape) = (c₂.work utmDescTape) ∧ + (c₃.work utmStateTape) = (c₂.work utmStateTape) ∧ + c₃.input = c₂.input ∧ c₃.output = c₂.output := by + have hne : ReadCurrentQ.readLoWrite target sim_hi ≠ ReadCurrentQ.done := nofun + have hheads2 : ∀ i, (c₂.work i).head ≥ 1 := by + intro i; by_cases h : i = utmSimTape + · rw [h]; omega + · rw [ho2 i h]; exact hheads1 i + have hwf2 : WorkTapesWF c₂.work := by + constructor + · intro i; by_cases h : i = utmSimTape + · subst h; show (c₂.work utmSimTape).cells 0 = _; rw [hc2]; exact hwf.1 utmSimTape + · rw [ho2 i h]; exact hwf1.1 i + · intro i j hj; by_cases h : i = utmSimTape + · subst h; show (c₂.work utmSimTape).cells j ≠ _; rw [hc2]; exact hwf.2 utmSimTape j hj + · rw [ho2 i h]; exact hwf1.2 i j hj + -- scratch tape in c₂ equals c's scratch tape + have hsc2 : c₂.work utmScratchTape = c.work utmScratchTape := by + rw [ho2 utmScratchTape (by decide), ho1 utmScratchTape (by decide)] + simp only [TM.step, readCurrentTM, hst2, if_neg hne, + show (c₂.work (2 : Fin 4)).read = sim_lo from hsim_lo_val] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- sim tape head (i=2 ≠ 3, idle) + · dsimp only [] + rw [if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide)] + have h := rc_tape_idle_preserve (c₂.work utmSimTape) + (rc_tape_read_ne_start_of_wf _ (hheads2 utmSimTape) (hwf2.2 utmSimTape)) (hheads2 utmSimTape) + rw [h]; exact hh2 + -- sim tape cells + · dsimp only [] + rw [if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide)] + have h := rc_tape_idle_preserve (c₂.work utmSimTape) + (rc_tape_read_ne_start_of_wf _ (hheads2 utmSimTape) (hwf2.2 utmSimTape)) (hheads2 utmSimTape) + rw [h]; exact hc2 + -- scratch head (i=3, write scrHi + right) + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, Tape.move, Tape.write, hsc2, hsc_head] + split + · omega + · dsimp only [] + -- scratch cells sc_pos = scrHi.toΓ + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc2, hsc_head] + rw [if_neg (by omega)]; exact Function.update_self sc_pos _ _ + -- scratch other cells + · intro j hne_j; dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc2, hsc_head] + rw [if_neg (by omega)]; exact Function.update_of_ne (by omega) _ _ + -- desc tape (i=0 ≠ 3) + · dsimp only [] + rw [if_neg (show utmDescTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmDescTape ≠ (3 : Fin 4) from by decide)] + exact rc_tape_idle_preserve (c₂.work utmDescTape) + (rc_tape_read_ne_start_of_wf _ (hheads2 utmDescTape) (hwf2.2 utmDescTape)) (hheads2 utmDescTape) + -- state tape (i=1 ≠ 3) + · dsimp only [] + rw [if_neg (show utmStateTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmStateTape ≠ (3 : Fin 4) from by decide)] + exact rc_tape_idle_preserve (c₂.work utmStateTape) + (rc_tape_read_ne_start_of_wf _ (hheads2 utmStateTape) (hwf2.2 utmStateTape)) (hheads2 utmStateTape) + -- input + · simp only [idleDir, (by rw [hinp2, hinp1]; exact hinp : c₂.input.read ≠ Γ.start), + ite_false, Tape.move] + -- output + · exact rc_tape_idle_preserve c₂.output + (by rw [hout2, hout1]; exact hout) (by rw [hout2, hout1]; exact hout_h) + obtain ⟨c₃, hr3, hst3, hh3, hc3, hsc3h, hsc3v, hsc3o, hdesc3, hstate3, hinp3, hout3⟩ := + readLoWrite_result + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 4: writeLo step — write scrLo to scratch + -- ═══════════════════════════════════════════════════════════════════ + have writeLo_result : ∃ c₄, + readCurrentTM.step c₃ = some c₄ ∧ + c₄.state = .rewindSim target ∧ + (c₄.work utmSimTape).head = offset + 2 ∧ + (c₄.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c₄.work utmScratchTape).head = sc_pos + 2 ∧ + (c₄.work utmScratchTape).cells (sc_pos + 1) = scrLo.toΓ ∧ + (∀ j, j ≠ sc_pos + 1 → (c₄.work utmScratchTape).cells j = + (c₃.work utmScratchTape).cells j) ∧ + (c₄.work utmDescTape) = (c₃.work utmDescTape) ∧ + (c₄.work utmStateTape) = (c₃.work utmStateTape) ∧ + c₄.input = c₃.input ∧ c₄.output = c₃.output := by + have hne : ReadCurrentQ.writeLo target scrLo ≠ ReadCurrentQ.done := nofun + have hheads3 : ∀ i, (c₃.work i).head ≥ 1 := by + intro i + by_cases h2 : i = utmSimTape + · rw [h2]; omega + · by_cases h3 : i = utmScratchTape + · rw [h3]; omega + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc3, ho2 _ (by decide)]; exact hheads1 _ + · have : i = utmStateTape := by + revert h2 h3 h4; revert i; decide + rw [this, hstate3, ho2 _ (by decide)]; exact hheads1 _ + have hwf3 : WorkTapesWF c₃.work := by + constructor + · intro i + by_cases h2 : i = utmSimTape + · subst h2; show (c₃.work utmSimTape).cells 0 = _; rw [hc3]; exact hwf.1 utmSimTape + · by_cases h3 : i = utmScratchTape + · subst h3; rw [hsc3o 0 (by omega)] + rw [ho2 utmScratchTape (by decide), ho1 utmScratchTape (by decide)] + exact hwf.1 utmScratchTape + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc3, ho2 _ (by decide)]; exact hwf1.1 _ + · have : i = utmStateTape := by revert h2 h3 h4; revert i; decide + rw [this, hstate3, ho2 _ (by decide)]; exact hwf1.1 _ + · intro i j hj + by_cases h2 : i = utmSimTape + · subst h2; show (c₃.work utmSimTape).cells j ≠ _; rw [hc3]; exact hwf.2 utmSimTape j hj + · by_cases h3 : i = utmScratchTape + · subst h3 + by_cases hj2 : j = sc_pos + · subst hj2; rw [hsc3v]; cases scrHi <;> simp [Γw.toΓ] + · rw [hsc3o j hj2, ho2 utmScratchTape (by decide), ho1 utmScratchTape (by decide)] + exact hwf.2 utmScratchTape j hj + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc3, ho2 _ (by decide)]; exact hwf1.2 _ j hj + · have : i = utmStateTape := by revert h2 h3 h4; revert i; decide + rw [this, hstate3, ho2 _ (by decide)]; exact hwf1.2 _ j hj + -- scratch tape in c₃ + have hsc3 : (c₃.work utmScratchTape).head = sc_pos + 1 := hsc3h + simp only [TM.step, readCurrentTM, hst3, if_neg hne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- sim tape head (i=2 ≠ 3, idle) + · dsimp only [] + rw [if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide)] + have h := rc_tape_idle_preserve (c₃.work utmSimTape) + (rc_tape_read_ne_start_of_wf _ (hheads3 utmSimTape) (hwf3.2 utmSimTape)) (hheads3 utmSimTape) + rw [h]; exact hh3 + -- sim tape cells + · dsimp only [] + rw [if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmSimTape ≠ (3 : Fin 4) from by decide)] + have h := rc_tape_idle_preserve (c₃.work utmSimTape) + (rc_tape_read_ne_start_of_wf _ (hheads3 utmSimTape) (hwf3.2 utmSimTape)) (hheads3 utmSimTape) + rw [h]; exact hc3 + -- scratch head = sc_pos + 2 + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, Tape.move, Tape.write, hsc3] + split + · omega + · dsimp only [] + -- scratch cells (sc_pos + 1) = scrLo.toΓ + · dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc3] + rw [if_neg (by omega)]; exact Function.update_self (sc_pos + 1) _ _ + -- scratch other cells + · intro j hne_j; dsimp only [] + rw [if_pos (show utmScratchTape = (3 : Fin 4) from rfl), + if_pos (show utmScratchTape = (3 : Fin 4) from rfl)] + simp only [Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc3] + rw [if_neg (by omega)]; exact Function.update_of_ne (by omega) _ _ + -- desc tape (i=0 ≠ 3) + · dsimp only [] + rw [if_neg (show utmDescTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmDescTape ≠ (3 : Fin 4) from by decide)] + exact rc_tape_idle_preserve (c₃.work utmDescTape) + (rc_tape_read_ne_start_of_wf _ (hheads3 utmDescTape) (hwf3.2 utmDescTape)) (hheads3 utmDescTape) + -- state tape (i=1 ≠ 3) + · dsimp only [] + rw [if_neg (show utmStateTape ≠ (3 : Fin 4) from by decide), + if_neg (show utmStateTape ≠ (3 : Fin 4) from by decide)] + exact rc_tape_idle_preserve (c₃.work utmStateTape) + (rc_tape_read_ne_start_of_wf _ (hheads3 utmStateTape) (hwf3.2 utmStateTape)) (hheads3 utmStateTape) + -- input + · simp only [idleDir, (by rw [hinp3, hinp2, hinp1]; exact hinp : c₃.input.read ≠ Γ.start), + ite_false, Tape.move] + -- output + · exact rc_tape_idle_preserve c₃.output + (by rw [hout3, hout2, hout1]; exact hout) + (by rw [hout3, hout2, hout1]; exact hout_h) + obtain ⟨c₄, hr4, hst4, hh4, hc4, hsc4h, hsc4v, hsc4o, hdesc4, hstate4, hinp4, hout4⟩ := + writeLo_result + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 5: Rewind sim tape + -- ═══════════════════════════════════════════════════════════════════ + have hwf4 : WorkTapesWF c₄.work := by + constructor + · intro i + by_cases h2 : i = utmSimTape + · subst h2; show (c₄.work utmSimTape).cells 0 = _; rw [hc4]; exact hwf.1 utmSimTape + · by_cases h3 : i = utmScratchTape + · subst h3 + rw [hsc4o 0 (by omega), hsc3o 0 (by omega)] + rw [ho2 utmScratchTape (by decide), ho1 utmScratchTape (by decide)] + exact hwf.1 utmScratchTape + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc4, hdesc3, ho2 _ (by decide)]; exact hwf1.1 _ + · have : i = utmStateTape := by revert h2 h3 h4; revert i; decide + rw [this, hstate4, hstate3, ho2 _ (by decide)]; exact hwf1.1 _ + · intro i j hj + by_cases h2 : i = utmSimTape + · subst h2; show (c₄.work utmSimTape).cells j ≠ _; rw [hc4]; exact hwf.2 utmSimTape j hj + · by_cases h3 : i = utmScratchTape + · subst h3 + by_cases hj2 : j = sc_pos + 1 + · subst hj2; rw [hsc4v]; cases scrLo <;> simp [Γw.toΓ] + · rw [hsc4o j hj2] + by_cases hj3 : j = sc_pos + · subst hj3; rw [hsc3v]; cases scrHi <;> simp [Γw.toΓ] + · rw [hsc3o j hj3, ho2 utmScratchTape (by decide), ho1 utmScratchTape (by decide)] + exact hwf.2 utmScratchTape j hj + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc4, hdesc3, ho2 _ (by decide)]; exact hwf1.2 _ j hj + · have : i = utmStateTape := by revert h2 h3 h4; revert i; decide + rw [this, hstate4, hstate3, ho2 _ (by decide)]; exact hwf1.2 _ j hj + have hheads4_ne : ∀ i, i ≠ utmSimTape → (c₄.work i).head ≥ 1 := by + intro i hne + by_cases h3 : i = utmScratchTape + · rw [h3]; omega + · by_cases h4 : i = utmDescTape + · rw [h4, hdesc4, hdesc3, ho2 _ (by decide)]; exact hheads1 _ + · have : i = utmStateTape := by revert hne h3 h4; revert i; decide + rw [this, hstate4, hstate3, ho2 _ (by decide)]; exact hheads1 _ + obtain ⟨c₅, hr5, hst5, hh5, hc5, ho5, hinp5, hout5, hwf5⟩ := + rewindSim_simulation (offset + 2) c₄ target hst4 hh4 hwf4 + (by rw [hinp4, hinp3, hinp2, hinp1]; exact hinp) + (by rw [hinp4, hinp3, hinp2, hinp1]; exact hinp_h) + (by rw [hout4, hout3, hout2, hout1]; exact hout) + (by rw [hout4, hout3, hout2, hout1]; exact hout_h) + hheads4_ne + -- ═══════════════════════════════════════════════════════════════════ + -- Phase 6: rewindSimR step — transition to next tape or rewindState + -- ═══════════════════════════════════════════════════════════════════ + have hheads5 : ∀ i, (c₅.work i).head ≥ 1 := by + intro i; by_cases h : i = utmSimTape + · rw [h]; omega + · rw [ho5 i h]; exact hheads4_ne i h + have rewindSimR_result : ∃ c₆, + readCurrentTM.step c₅ = some c₆ ∧ + (if h : target.val = n + 1 then + c₆.state = .rewindState + else + c₆.state = .scan ⟨target.val + 1, by omega⟩ ⟨0, by omega⟩) ∧ + c₆.work = c₅.work ∧ + c₆.input = c₅.input ∧ c₆.output = c₅.output := by + simp only [TM.step, hst5, readCurrentTM] + have hne : ReadCurrentQ.rewindSimR target ≠ ReadCurrentQ.done := nofun + rw [if_neg hne] + by_cases htgt : target.val = n + 1 + · rw [dif_pos htgt] + refine ⟨_, rfl, ?_, ?_, ?_, ?_⟩ + · rw [dif_pos htgt] + · ext i; exact rc_tape_idle_preserve (c₅.work i) + (rc_tape_read_ne_start_of_wf _ (hheads5 i) (hwf5.2 i)) (hheads5 i) + · simp only [idleDir, (show c₅.input.read ≠ Γ.start from by + rw [hinp5, hinp4, hinp3, hinp2, hinp1]; exact hinp), ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c₅.output + (by rw [hout5, hout4, hout3, hout2, hout1]; exact hout) + (by rw [hout5, hout4, hout3, hout2, hout1]; exact hout_h) + · rw [dif_neg htgt] + refine ⟨_, rfl, ?_, ?_, ?_, ?_⟩ + · rw [dif_neg htgt] + · ext i; exact rc_tape_idle_preserve (c₅.work i) + (rc_tape_read_ne_start_of_wf _ (hheads5 i) (hwf5.2 i)) (hheads5 i) + · simp only [idleDir, (show c₅.input.read ≠ Γ.start from by + rw [hinp5, hinp4, hinp3, hinp2, hinp1]; exact hinp), ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c₅.output + (by rw [hout5, hout4, hout3, hout2, hout1]; exact hout) + (by rw [hout5, hout4, hout3, hout2, hout1]; exact hout_h) + obtain ⟨c₆, hr6, hst6, hw6, hinp6, hout6⟩ := rewindSimR_result + -- ═══════════════════════════════════════════════════════════════════ + -- Compose all phases + -- ═══════════════════════════════════════════════════════════════════ + have hreach := reachesIn_trans _ hr1 + (.step hr2 (.step hr3 (.step hr4 + (reachesIn_trans _ hr5 (.step hr6 .zero))))) + refine ⟨c₆, _, hreach, hst6, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- sim tape head = 1 + · rw [hw6]; exact hh5 + -- sim tape cells preserved + · rw [hw6, hc5, hc4] + -- scratch tape head = sc_pos + 2 + · rw [hw6, ho5 utmScratchTape (by decide)]; exact hsc4h + -- scratch cell sc_pos = correct encode bit 0 + · rw [hw6, ho5 utmScratchTape (by decide)] + rw [hsc4o sc_pos (by omega)] + rw [hsc3v] + exact htrans.1 + -- scratch cell sc_pos + 1 = correct encode bit 1 + · rw [hw6, ho5 utmScratchTape (by decide)] + rw [hsc4v] + exact htrans.2 + -- previously written scratch cells preserved + · intro j hj + rw [hw6, ho5 utmScratchTape (by decide)] + rw [hsc4o j (by omega)] + rw [hsc3o j (by omega)] + rw [ho2 utmScratchTape (by decide)] + rw [ho1 utmScratchTape (by decide)] + -- scratch cells above written range preserved + · intro j hj + rw [hw6, ho5 utmScratchTape (by decide)] + rw [hsc4o j (by omega)] + rw [hsc3o j (by omega)] + rw [ho2 utmScratchTape (by decide)] + rw [ho1 utmScratchTape (by decide)] + -- desc tape preserved + · rw [hw6, ho5 utmDescTape (by decide), hdesc4, hdesc3] + rw [ho2 utmDescTape (by decide), ho1 utmDescTape (by decide)] + -- state tape preserved + · rw [hw6, ho5 utmStateTape (by decide), hstate4, hstate3] + rw [ho2 utmStateTape (by decide), ho1 utmStateTape (by decide)] + -- input preserved + · rw [hinp6, hinp5, hinp4, hinp3, hinp2, hinp1] + -- output preserved + · rw [hout6, hout5, hout4, hout3, hout2, hout1] + -- WorkTapesWF preserved (two conjuncts) + · exact ⟨fun i => by rw [hw6]; exact hwf5.1 i, fun i j hj => by rw [hw6]; exact hwf5.2 i j hj⟩ + -- Time bound: 2 * offset + 7 + · omega + +/-- Phase 3: rewind state tape from some position to cell 1. -/ +private theorem rewindState_simulation : + ∀ (st_head : ℕ) (c : Cfg 4 (readCurrentTM (n := n)).Q), + c.state = .rewindState → + (c.work utmStateTape).head = st_head → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ i, i ≠ utmStateTape → (c.work i).head ≥ 1) → + ∃ c', + (readCurrentTM (n := n)).reachesIn (st_head + 2) c c' ∧ + c'.state = .rewindScratch ∧ + (c'.work utmStateTape).head = 1 ∧ + (c'.work utmStateTape).cells = (c.work utmStateTape).cells ∧ + (∀ i, i ≠ utmStateTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + intro st_head; induction st_head with + | zero => + intro c hstate hst_head hwf hinp hinp_h hout hout_h hheads + have hread : (c.work utmStateTape).read = Γ.start := by + simp [Tape.read, hst_head, hwf.1 utmStateTape] + -- Step 1: rewindState → rewindStateR (read ▷, move right) + have hstep1 : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindStateR ∧ + (c₁.work utmStateTape).head = 1 ∧ + (c₁.work utmStateTape).cells = (c.work utmStateTape).cells ∧ + (∀ i, i ≠ utmStateTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write, hst_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells, Tape.write, hst_head] + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep1 + -- Step 2: rewindStateR → rewindScratch (all idle) + -- All tapes have head ≥ 1 after step 1 + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmStateTape + · rw [h]; omega + · rw [hw1 i h]; exact hheads i h + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmStateTape + · rw [h, hcells1]; exact hwf.1 utmStateTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmStateTape + · rw [h, hcells1]; exact hwf.2 utmStateTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hout1' : c₁.output.read ≠ Γ.start := by rw [hout1]; exact hout + have hstep2 : ∃ c₂, (readCurrentTM (n := n)).step c₁ = some c₂ ∧ + c₂.state = .rewindScratch ∧ + c₂.work = c₁.work ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, hst1, readCurrentTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · ext i; dsimp only [] + exact rc_tape_idle_preserve (c₁.work i) + (rc_tape_read_ne_start_of_wf _ (hheads1 i) (hwf1.2 i)) (hheads1 i) + · simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c₁.output hout1' (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hstep2', hst2, hwork2, hinp2, hout2⟩ := hstep2 + refine ⟨c₂, .step hstep1' (.step hstep2' .zero), hst2, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork2]; exact hhead1 + · rw [hwork2, hcells1] + · intro i hne; rw [hwork2, hw1 i hne] + · rw [hinp2, hinp1] + · rw [hout2, hout1] + · rw [hwork2]; exact hwf1 + | succ h ih => + intro c hstate hst_head hwf hinp hinp_h hout hout_h hheads + have hread_ne : (c.work utmStateTape).read ≠ Γ.start := by + simp [Tape.read, hst_head]; exact hwf.2 utmStateTape (h + 1) (by omega) + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindState ∧ + (c₁.work utmStateTape).head = h ∧ + (c₁.work utmStateTape).cells = (c.work utmStateTape).cells ∧ + (∀ i, i ≠ utmStateTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hst_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h' : i = utmStateTape + · rw [h', hcells1]; exact hwf.1 utmStateTape + · rw [hw1 i h']; exact hwf.1 i + · intro i j hj; by_cases h' : i = utmStateTape + · rw [h', hcells1]; exact hwf.2 utmStateTape j hj + · rw [hw1 i h']; exact hwf.2 i j hj + have hheads1 : ∀ i, i ≠ utmStateTape → (c₁.work i).head ≥ 1 := by + intro i h'; rw [hw1 i h']; exact hheads i h' + obtain ⟨c_f, hreach, hst_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := ih c₁ hst1 + hhead1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + hheads1 + refine ⟨c_f, .step hstep' hreach, hst_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +/-- Phase 3: rewind scratch tape to cell 1 and halt. -/ +private theorem rewindScratch_simulation : + ∀ (sc_head : ℕ) (c : Cfg 4 (readCurrentTM (n := n)).Q), + c.state = .rewindScratch → + (c.work utmScratchTape).head = sc_head → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ i, i ≠ utmScratchTape → (c.work i).head ≥ 1) → + ∃ c', + (readCurrentTM (n := n)).reachesIn (sc_head + 2) c c' ∧ + (readCurrentTM (n := n)).halted c' ∧ + (c'.work utmScratchTape).head = 1 ∧ + (c'.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c'.work i = c.work i) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work := by + intro sc_head; induction sc_head with + | zero => + intro c hstate hsc_head hwf hinp hinp_h hout hout_h hheads + have hread : (c.work utmScratchTape).read = Γ.start := by + simp [Tape.read, hsc_head, hwf.1 utmScratchTape] + -- Step 1: rewindScratch → rewindScratchR (read ▷, move right) + have hstep1 : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindScratchR ∧ + (c₁.work utmScratchTape).head = 1 ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move, Tape.write, hsc_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells, Tape.write, hsc_head] + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep1', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep1 + -- All tapes have head ≥ 1 after step 1 + have hheads1 : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; by_cases h : i = utmScratchTape + · rw [h]; omega + · rw [hw1 i h]; exact hheads i h + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h]; exact hwf.1 i + · intro i j hj; by_cases h : i = utmScratchTape + · rw [h, hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h]; exact hwf.2 i j hj + have hinp1' : c₁.input.read ≠ Γ.start := by rw [hinp1]; exact hinp + have hout1' : c₁.output.read ≠ Γ.start := by rw [hout1]; exact hout + -- Step 2: rewindScratchR → done (all idle, halted) + have hstep2 : ∃ c₂, (readCurrentTM (n := n)).step c₁ = some c₂ ∧ + c₂.state = .done ∧ + c₂.work = c₁.work ∧ + c₂.input = c₁.input ∧ c₂.output = c₁.output := by + simp only [TM.step, hst1, readCurrentTM] + refine ⟨_, rfl, rfl, ?_, ?_, ?_⟩ + · ext i; dsimp only [] + exact rc_tape_idle_preserve (c₁.work i) + (rc_tape_read_ne_start_of_wf _ (hheads1 i) (hwf1.2 i)) (hheads1 i) + · simp only [idleDir, hinp1', ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c₁.output hout1' (by rw [hout1]; exact hout_h) + obtain ⟨c₂, hstep2', hst2, hwork2, hinp2, hout2⟩ := hstep2 + refine ⟨c₂, .step hstep1' (.step hstep2' .zero), hst2, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · rw [hwork2]; exact hhead1 + · rw [hwork2, hcells1] + · intro i hne; rw [hwork2, hw1 i hne] + · rw [hinp2, hinp1] + · rw [hout2, hout1] + · rw [hwork2]; exact hwf1 + | succ h ih => + intro c hstate hsc_head hwf hinp hinp_h hout hout_h hheads + have hread_ne : (c.work utmScratchTape).read ≠ Γ.start := by + simp [Tape.read, hsc_head]; exact hwf.2 utmScratchTape (h + 1) (by omega) + have hstep : ∃ c₁, (readCurrentTM (n := n)).step c = some c₁ ∧ + c₁.state = .rewindScratch ∧ + (c₁.work utmScratchTape).head = h ∧ + (c₁.work utmScratchTape).cells = (c.work utmScratchTape).cells ∧ + (∀ i, i ≠ utmScratchTape → c₁.work i = c.work i) ∧ + c₁.input = c.input ∧ c₁.output = c.output := by + simp only [TM.step, hstate, readCurrentTM, ↓reduceIte, hread_ne] + refine ⟨_, rfl, rfl, ?_, ?_, ?_, ?_, ?_⟩ + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, Tape.move] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · omega + · simp [hsc_head] + · dsimp only [] + simp only [↓reduceIte, + Tape.writeAndMove, rc_tape_move_cells] + rw [rc_readBackWrite_toΓ_eq hread_ne] + simp only [Tape.write]; split + · rfl + · exact Function.update_eq_self _ _ + · intro i hne; dsimp only []; rw [if_neg hne] + exact rc_tape_idle_preserve (c.work i) + (rc_tape_read_ne_start_of_wf _ (hheads i hne) (hwf.2 i)) (hheads i hne) + · simp only [idleDir, hinp, ↓reduceIte, Tape.move] + · exact rc_tape_idle_preserve c.output hout hout_h + obtain ⟨c₁, hstep', hst1, hhead1, hcells1, hw1, hinp1, hout1⟩ := hstep + have hwf1 : WorkTapesWF c₁.work := by + constructor + · intro i; by_cases h' : i = utmScratchTape + · rw [h', hcells1]; exact hwf.1 utmScratchTape + · rw [hw1 i h']; exact hwf.1 i + · intro i j hj; by_cases h' : i = utmScratchTape + · rw [h', hcells1]; exact hwf.2 utmScratchTape j hj + · rw [hw1 i h']; exact hwf.2 i j hj + have hheads1 : ∀ i, i ≠ utmScratchTape → (c₁.work i).head ≥ 1 := by + intro i h'; rw [hw1 i h']; exact hheads i h' + obtain ⟨c_f, hreach, hhalt_f, hhead_f, hcells_f, hw_f, hinp_f, hout_f, hwf_f⟩ := ih c₁ hst1 + hhead1 hwf1 + (by rw [hinp1]; exact hinp) (by rw [hinp1]; exact hinp_h) + (by rw [hout1]; exact hout) (by rw [hout1]; exact hout_h) + hheads1 + refine ⟨c_f, .step hstep' hreach, hhalt_f, hhead_f, ?_, ?_, ?_, ?_, hwf_f⟩ + · rw [hcells_f, hcells1] + · intro i hne; rw [hw_f i hne, hw1 i hne] + · rw [hinp_f, hinp1] + · rw [hout_f, hout1] + +-- ════════════════════════════════════════════════════════════════════════ +-- Assembling the scratch tape postcondition +-- ════════════════════════════════════════════════════════════════════════ + +/-- Helper: the head symbol for simulated tape t_idx in simCfg. + t_idx = 0 → input tape + t_idx = 1..n → work tape (t_idx - 1) + t_idx = n+1 → output tape -/ +private noncomputable def simHeadSym {n : ℕ} {Q : Type} (simCfg : Cfg n Q) + (t_idx : Fin (n + 2)) : Γ := + if h0 : t_idx.val = 0 then simCfg.input.read + else if h1 : t_idx.val ≤ n then + (simCfg.work ⟨t_idx.val - 1, by omega⟩).read + else simCfg.output.read + +/-- The encodeInputPattern matches what readCurrentTM writes to scratch. -/ +private theorem encodeInputPattern_matches_scratch + {Q : Type} (k n : ℕ) (q : Fin k) (simCfg : Cfg n Q) : + TMEncoding.encodeInputPattern k n q simCfg.input.read + (fun i => (simCfg.work i).read) simCfg.output.read = + (List.finRange k).map (fun i => i == q) ++ + simCfg.input.read.encode ++ + (List.finRange n).flatMap (fun i => ((simCfg.work i).read).encode) ++ + simCfg.output.read.encode := by + rfl + +-- ════════════════════════════════════════════════════════════════════════ +-- Phase 2 iteration: per_tape_simulation across all n+2 tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- Helper: the head position of simulated tape t_idx in simCfg. -/ +private noncomputable def simHeadPos {n : ℕ} {Q : Type} (simCfg : Cfg n Q) + (t_idx : Fin (n + 2)) : ℕ := + if h0 : t_idx.val = 0 then simCfg.input.head + else if h1 : t_idx.val ≤ n then + (simCfg.work ⟨t_idx.val - 1, by omega⟩).head + else simCfg.output.head + +/-- Helper: the cell function of simulated tape t_idx in simCfg. -/ +private noncomputable def simCellsFn {n : ℕ} {Q : Type} (simCfg : Cfg n Q) + (t_idx : Fin (n + 2)) : ℕ → Γ := + if h0 : t_idx.val = 0 then simCfg.input.cells + else if h1 : t_idx.val ≤ n then + (simCfg.work ⟨t_idx.val - 1, by omega⟩).cells + else simCfg.output.cells + +/-- Extract per-tape sim conditions from superCellsCorrect for a given target tape. -/ +private theorem extract_sim_conditions + {Q : Type} (simCfg : Cfg n Q) (cells : ℕ → Γ) + (hscc : superCellsCorrect simCfg ⟨1, cells⟩) (target : Fin (n + 2)) : + (∀ pos, cells (SuperCell.simTapeOffset (n + 2) pos target.val) = + if simHeadPos simCfg target = pos then Γ.one else Γ.blank) ∧ + (∀ pos, cells (SuperCell.simTapeOffset (n + 2) pos target.val + 1) = + (SuperCell.symToCellPair (simCellsFn simCfg target pos)).1) ∧ + (∀ pos, cells (SuperCell.simTapeOffset (n + 2) pos target.val + 2) = + (SuperCell.symToCellPair (simCellsFn simCfg target pos)).2) := by + obtain ⟨_, hscc_inp, hscc_work, hscc_out⟩ := hscc + rcases target with ⟨tv, htv⟩ + simp only [] at * + by_cases h0 : tv = 0 + · -- Input tape + subst h0 + simp only [simHeadPos, simCellsFn, ↓reduceDIte] + exact ⟨fun pos => (hscc_inp pos).1, + fun pos => (hscc_inp pos).2.1, + fun pos => (hscc_inp pos).2.2⟩ + · by_cases hlast : tv = n + 1 + · -- Output tape + subst hlast + simp only [simHeadPos, simCellsFn, show (n + 1) ≠ 0 from by omega, + show ¬(n + 1 ≤ n) from by omega, ↓reduceDIte] + exact ⟨fun pos => (hscc_out pos).1, + fun pos => (hscc_out pos).2.1, + fun pos => (hscc_out pos).2.2⟩ + · -- Work tape + have hle : tv ≤ n := by omega + have hlt : tv - 1 < n := by omega + simp only [simHeadPos, simCellsFn, h0, hle, ↓reduceDIte] + have hvaleq : (⟨tv - 1, hlt⟩ : Fin n).val + 1 = tv := by + show tv - 1 + 1 = tv; omega + refine ⟨fun pos => ?_, fun pos => ?_, fun pos => ?_⟩ + · have := (hscc_work ⟨tv - 1, hlt⟩ pos).1 + simp only [hvaleq] at this; exact this + · have := (hscc_work ⟨tv - 1, hlt⟩ pos).2.1 + simp only [hvaleq] at this; exact this + · have := (hscc_work ⟨tv - 1, hlt⟩ pos).2.2 + simp only [hvaleq] at this; exact this + +/-- Time bound for all_tapes_simulation: sum of per-tape costs from `targetVal` + for `remaining` tapes. Each tape costs `2 * simTapeOffset(n+2, head_pos, idx) + 7`. -/ +private noncomputable def allTapesBound {n : ℕ} {Q : Type} (simCfg : Cfg n Q) + (remaining : ℕ) (targetVal : ℕ) : ℕ := + match remaining with + | 0 => 0 + | m + 1 => + (2 * SuperCell.simTapeOffset (n + 2) + (if h : targetVal < n + 2 then simHeadPos simCfg ⟨targetVal, h⟩ else 0) targetVal + 7) + + allTapesBound simCfg m (targetVal + 1) + +/-- Phase 2: iterate per_tape_simulation over tapes [target..n+1], accumulating + encoded head symbols onto the scratch tape. + + Starts at `.scan target 0` with scratch head at `sc_pos` and produces + `.rewindState` with scratch head at `sc_pos + 2 * (n + 2 - target.val)`. -/ +private theorem all_tapes_simulation + {Q : Type} [DecidableEq Q] [Fintype Q] + (simCfg : Cfg n Q) : + ∀ (remaining : ℕ) (target : Fin (n + 2)) + (htarget : target.val = n + 2 - remaining) (hrem : remaining ≤ n + 2) + (c : Cfg 4 (readCurrentTM (n := n)).Q) + (sc_pos : ℕ), + c.state = .scan target ⟨0, by omega⟩ → + (c.work utmSimTape).head = 1 → + (c.work utmSimTape).cells 0 = Γ.start → + superCellsCorrect simCfg ⟨1, (c.work utmSimTape).cells⟩ → + (c.work utmScratchTape).head = sc_pos → + sc_pos ≥ 1 → + WorkTapesWF c.work → + c.input.read ≠ Γ.start → c.input.head ≥ 1 → + c.output.read ≠ Γ.start → c.output.head ≥ 1 → + (∀ i, (c.work i).head ≥ 1) → + ∃ c' t, + (readCurrentTM (n := n)).reachesIn t c c' ∧ + c'.state = .rewindState ∧ + (c'.work utmSimTape).head = 1 ∧ + (c'.work utmSimTape).cells = (c.work utmSimTape).cells ∧ + (c'.work utmDescTape) = (c.work utmDescTape) ∧ + (c'.work utmStateTape) = (c.work utmStateTape) ∧ + (c'.work utmScratchTape).head = sc_pos + 2 * remaining ∧ + (∀ j, j < sc_pos → (c'.work utmScratchTape).cells j = + (c.work utmScratchTape).cells j) ∧ + (∀ j, j ≥ sc_pos + 2 * remaining → (c'.work utmScratchTape).cells j = + (c.work utmScratchTape).cells j) ∧ + (∀ (p : ℕ) (hp : p < remaining), + (c'.work utmScratchTape).cells (sc_pos + 2 * p) = + Γ.ofBool ((simCellsFn simCfg ⟨target.val + p, by omega⟩ + (simHeadPos simCfg ⟨target.val + p, by omega⟩)).encode[0]'(by rw [Γ.encode_length]; omega)) ∧ + (c'.work utmScratchTape).cells (sc_pos + 2 * p + 1) = + Γ.ofBool ((simCellsFn simCfg ⟨target.val + p, by omega⟩ + (simHeadPos simCfg ⟨target.val + p, by omega⟩)).encode[1]'(by rw [Γ.encode_length]; omega))) ∧ + c'.input = c.input ∧ c'.output = c.output ∧ + WorkTapesWF c'.work ∧ + t ≤ allTapesBound simCfg remaining target.val := by + intro remaining + induction remaining with + | zero => + intro target htarget; exact absurd htarget (by omega) + | succ m ih => + intro target htarget hrem c sc_pos hstate hsim_head hsim_cell0 hscc + hsc_head hsc_ge hwf hinp hinp_h hout hout_h hwork_heads + -- Extract marker/hi/lo conditions for current target + have ⟨hmarker, hhi, hlo⟩ := extract_sim_conditions simCfg _ hscc target + -- Apply per_tape_simulation + obtain ⟨c', t', hreach', hnext', hsim_head', hsim_cells', hsc_head', hsc0, hsc1, + hsc_prev, hsc_above, hdesc', hstate', hinp', hout', hwf', ht'_bound⟩ := + per_tape_simulation (simCellsFn simCfg target) c target + (simHeadPos simCfg target) sc_pos hstate hsim_head hmarker hhi hlo + hsc_head hsc_ge hwf hinp hinp_h hout hout_h hsim_cell0 hwork_heads + -- Case split: last tape or not? + by_cases hlast : target.val = n + 1 + · -- Last tape (m = 0): per_tape_simulation reached .rewindState + have hm0 : m = 0 := by omega + subst hm0; simp [hlast] at hnext' + refine ⟨c', t', hreach', hnext', hsim_head', hsim_cells', hdesc', hstate', + by rw [hsc_head'], hsc_prev, + fun j hj => hsc_above j (by omega), + fun p hp => ?_, hinp', hout', hwf', ?_⟩ + · have hp0 : p = 0 := by omega + subst hp0; simp only [Nat.mul_zero, Nat.add_zero, Nat.zero_add] + exact ⟨hsc0, hsc1⟩ + · -- Time bound for last tape + show t' ≤ allTapesBound simCfg (0 + 1) target.val + simp only [allTapesBound] + have : target.val < n + 2 := target.isLt + rw [dif_pos this] + omega + · -- Not last tape: per_tape_simulation reached .scan ⟨target+1, _⟩, recurse + simp [hlast] at hnext' + have htarget1 : (⟨target.val + 1, by omega⟩ : Fin (n + 2)).val = n + 2 - m := by + show target.val + 1 = n + 2 - m; omega + obtain ⟨c'', t'', hreach'', hst'', hsim_head'', hsim_cells'', hdesc'', hstate'', + hsc_head'', hsc_prev'', hsc_above'', hsc_vals'', hinp'', hout'', hwf'', ht''_bound⟩ := + ih ⟨target.val + 1, by omega⟩ htarget1 (by omega) c' (sc_pos + 2) hnext' + hsim_head' (by rw [hsim_cells']; exact hsim_cell0) + (by rw [hsim_cells']; exact hscc) hsc_head' (by omega) hwf' + (by rw [hinp']; exact hinp) (by rw [hinp']; exact hinp_h) + (by rw [hout']; exact hout) (by rw [hout']; exact hout_h) + (by intro i + by_cases hi2 : i = utmSimTape + · rw [hi2]; omega + · by_cases hi3 : i = utmScratchTape + · rw [hi3, hsc_head']; omega + · have : i = utmDescTape ∨ i = utmStateTape := by + simp only [Fin.ext_iff, utmSimTape, utmScratchTape, utmDescTape, utmStateTape] at * + omega + rcases this with rfl | rfl + · rw [hdesc']; exact hwork_heads _ + · rw [hstate']; exact hwork_heads _) + refine ⟨c'', t' + t'', reachesIn_trans readCurrentTM hreach' hreach'', hst'', + hsim_head'', by rw [hsim_cells'', hsim_cells'], + by rw [hdesc'', hdesc'], by rw [hstate'', hstate'], + by rw [hsc_head'']; omega, + fun j hj => by rw [hsc_prev'' j (by omega), hsc_prev j hj], + fun j hj => by rw [hsc_above'' j (by omega), hsc_above j (by omega)], + fun p hp => ?_, by rw [hinp'', hinp'], by rw [hout'', hout'], hwf'', ?_⟩ + -- Prove the per-cell values for remaining = m + 1 + cases p with + | zero => + simp only [Nat.mul_zero, Nat.add_zero] + exact ⟨hsc_prev'' sc_pos (by omega) ▸ hsc0, + hsc_prev'' (sc_pos + 1) (by omega) ▸ hsc1⟩ + | succ p' => + have hp' : p' < m := by omega + have h := hsc_vals'' p' hp' + have hfin : (⟨↑(⟨↑target + 1, by omega⟩ : Fin (n + 2)) + p', + by show ↑target + 1 + p' < n + 2; omega⟩ : Fin (n + 2)) = + ⟨↑target + (p' + 1), by omega⟩ := + Fin.ext (show ↑target + 1 + p' = ↑target + (p' + 1) by omega) + simp only [hfin] at h + constructor + · rw [show sc_pos + 2 * (p' + 1) = sc_pos + 2 + 2 * p' from by omega]; exact h.1 + · rw [show sc_pos + 2 * (p' + 1) + 1 = sc_pos + 2 + 2 * p' + 1 from by omega]; exact h.2 + -- Time bound for recursive case + · show t' + t'' ≤ allTapesBound simCfg (m + 1) target.val + simp only [allTapesBound] + have htlt : target.val < n + 2 := target.isLt + rw [dif_pos htlt] + have : (⟨target.val + 1, by omega⟩ : Fin (n + 2)).val = target.val + 1 := rfl + have hfin_eq : (⟨target.val, htlt⟩ : Fin (n + 2)) = target := Fin.ext rfl + calc t' + t'' + ≤ (2 * SuperCell.simTapeOffset (n + 2) (simHeadPos simCfg target) target.val + 7) + + allTapesBound simCfg m (target.val + 1) := + Nat.add_le_add ht'_bound (by rw [show (⟨target.val + 1, by omega⟩ : Fin (n + 2)).val = target.val + 1 from rfl] at ht''_bound; exact ht''_bound) + _ = _ := by rw [hfin_eq] + + +-- ════════════════════════════════════════════════════════════════════════ +-- Helper lemmas for scratchHasInputPattern proof +-- ════════════════════════════════════════════════════════════════════════ + +/-- Length of flatMap of Γ.encode lists. -/ +private lemma flatMap_encode_length {α : Type} (l : List α) (f : α → Γ) : + (l.flatMap (fun x => (f x).encode)).length = 2 * l.length := by + induction l with + | nil => simp + | cons a as ih => + simp only [List.flatMap_cons, List.length_append, Γ.encode_length, ih, List.length_cons] + omega + +/-- Length of encodeInputPattern equals k + 2*(n+2). -/ +private lemma encodeInputPattern_length_eq (k n : ℕ) (q : Fin k) (iH : Γ) + (wH : Fin n → Γ) (oH : Γ) : + (TMEncoding.encodeInputPattern k n q iH wH oH).length = k + 2 * (n + 2) := by + simp only [TMEncoding.encodeInputPattern, List.length_append, List.length_map, + List.length_finRange, Γ.encode_length, flatMap_encode_length] + omega + +/-- Indexing into flatMap of Γ.encode lists: the (2m+b)-th element is + the b-th encode bit of the m-th list element. -/ +private lemma flatMap_encode_getElem {α : Type} (l : List α) (f : α → Γ) + (m : ℕ) (hm : m < l.length) (b : ℕ) (hb : b < 2) : + (l.flatMap (fun x => (f x).encode))[2 * m + b]'(by rw [flatMap_encode_length]; omega) = + (f l[m]).encode[b]'(by rw [Γ.encode_length]; exact hb) := by + induction l generalizing m with + | nil => exact absurd hm (by simp) + | cons a as ih => + simp only [List.flatMap_cons] + match m with + | 0 => + simp only [Nat.mul_zero, Nat.zero_add, List.getElem_cons_zero] + exact List.getElem_append_left (show b < (f a).encode.length by rw [Γ.encode_length]; exact hb) + | m' + 1 => + rw [List.getElem_append_right + (show (f a).encode.length ≤ 2 * (m' + 1) + b by rw [Γ.encode_length]; omega)] + simp only [Γ.encode_length, show 2 * (m' + 1) + b - 2 = 2 * m' + b from by omega, + List.getElem_cons_succ] + exact ih m' (by simp only [List.length_cons] at hm; omega) + +/-- For tape-encoding indices i in [k, k + 2*(n+2)), the i-th bit of + encodeInputPattern equals the b-th encode bit of the appropriate tape head, + where p = (i-k)/2 selects the tape and b = (i-k)%2 selects the encode bit. -/ +private lemma encodeInputPattern_tape_getElem (k n : ℕ) (q : Fin k) (iH : Γ) + (wH : Fin n → Γ) (oH : Γ) (p b : ℕ) (hp : p < n + 2) (hb : b < 2) : + let bits := TMEncoding.encodeInputPattern k n q iH wH oH + (bits[k + (2 * p + b)]'(by rw [encodeInputPattern_length_eq]; omega)) = + (if h₀ : p = 0 then iH + else if h₁ : p ≤ n then wH ⟨p - 1, by omega⟩ + else oH).encode[b]'(by rw [Γ.encode_length]; omega) := by + intro bits + -- bits = stateMap ++ iH.encode ++ flatMap ++ oH.encode + -- The stateMap has length k, so bits[k + (2*p+b)] = (iH.encode ++ flatMap ++ oH.encode)[2*p+b] + show (TMEncoding.encodeInputPattern k n q iH wH oH)[k + (2 * p + b)]'(by + rw [encodeInputPattern_length_eq]; omega) = _ + simp only [TMEncoding.encodeInputPattern, List.append_assoc] + -- Now the LHS is ((map ++ (iH.encode ++ (flatMap ++ oH.encode))))[k + (2*p+b)] + -- Skip past the map (length k) + rw [List.getElem_append_right (show ((List.finRange k).map (· == q)).length ≤ k + (2 * p + b) + from by simp [List.length_map, List.length_finRange])] + simp only [List.length_map, List.length_finRange, + show k + (2 * p + b) - k = 2 * p + b from by omega] + -- Case split on p + by_cases hp0 : p = 0 + · -- p = 0: indexing into iH.encode + simp only [hp0, ↓reduceDIte, Nat.mul_zero, Nat.zero_add] + exact List.getElem_append_left + (show b < iH.encode.length by rw [Γ.encode_length]; exact hb) + · by_cases hpn : p ≤ n + · -- 1 ≤ p ≤ n: indexing into flatMap(wH) + simp only [hp0, hpn, ↓reduceDIte] + rw [List.getElem_append_right + (show iH.encode.length ≤ 2 * p + b by rw [Γ.encode_length]; omega)] + simp only [Γ.encode_length, show 2 * p + b - 2 = 2 * (p - 1) + b from by omega] + -- Goal: (flatMap ++ oH.encode)[2*(p-1)+b] = (wH ⟨p-1,_⟩).encode[b] + -- Since p ≤ n and p ≥ 1, 2*(p-1)+b < 2*n = flatMap.length + rw [List.getElem_append_left + (show 2 * (p - 1) + b < + ((List.finRange n).flatMap (fun j => (wH j).encode)).length by + rw [flatMap_encode_length, List.length_finRange]; omega)] + have hpm : p - 1 < n := by omega + rw [flatMap_encode_getElem _ _ (p - 1) (by simp [List.length_finRange]; exact hpm) b hb] + simp only [List.getElem_finRange, Fin.cast_mk] + · -- p = n + 1: indexing into oH.encode + have hpeq : p = n + 1 := by omega + simp only [hp0, show ¬(p ≤ n) from hpn, ↓reduceDIte] + rw [List.getElem_append_right + (show iH.encode.length ≤ 2 * p + b by rw [Γ.encode_length]; omega)] + simp only [Γ.encode_length, show 2 * p + b - 2 = 2 * (p - 1) + b from by omega] + -- Now we need (flatMap ++ oH.encode)[2*(p-1)+b], where p-1 = n, so index is 2*n + b + -- flatMap has length 2*n, so we skip it to reach oH.encode[b] + rw [List.getElem_append_right + (show ((List.finRange n).flatMap (fun j => (wH j).encode)).length ≤ + 2 * (p - 1) + b by + rw [flatMap_encode_length, List.length_finRange, hpeq]; omega)] + congr 1 + rw [flatMap_encode_length, List.length_finRange, hpeq] + omega + +-- ════════════════════════════════════════════════════════════════════════ +-- Full readCurrentTM_hoareTime +-- ════════════════════════════════════════════════════════════════════════ + +/-- Total time bound for readCurrentTM: + Phase 1 (copyState): k + 1 steps + Phase 2 (all tapes): allTapesBound steps + Phase 3a (rewindState): k + 3 steps + Phase 3b (rewindScratch): k + 2*(n+2) + 3 steps -/ +private noncomputable def readCurrentTimeBound {n : ℕ} {Q : Type} [DecidableEq Q] [Fintype Q] + (k : ℕ) (simCfg : Cfg n Q) : ℕ := + (k + 1) + allTapesBound simCfg (n + 2) 0 + (k + 1 + 2) + (k + 1 + 2 * (n + 2) + 2) + +/-- HoareTime specification for `readCurrentTM`. + + **Pre**: State and sim tapes encode `simCfg`; desc tape valid; all heads at 1; + scratch tape cells ≥ 1 are blank (fresh scratch). + **Post**: All tapes preserved + scratch has input pattern for current + state and head symbols. Heads returned to cell 1. -/ +theorem readCurrentTM_hoareTime' (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) + (desc : List Bool) (simCfg : Cfg n tm.Q) : + let e := tm.stateEquivK hk + ∃ B, (readCurrentTM (n := n)).HoareTime + (fun inp work out => + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (e simCfg.state) (work utmStateTape) ∧ + superCellsCorrect simCfg (work utmSimTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).head = 1 ∧ + (work utmScratchTape).head = 1 ∧ + (∀ j, j ≥ 1 → (work utmScratchTape).cells j = Γ.blank) ∧ + WorkTapesWF work ∧ + inp.read ≠ Γ.start ∧ inp.head ≥ 1 ∧ + out.read ≠ Γ.start ∧ out.head ≥ 1) + (fun _inp work _out => + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (e simCfg.state) (work utmStateTape) ∧ + superCellsCorrect simCfg (work utmSimTape) ∧ + scratchHasInputPattern k n (e simCfg.state) + simCfg.input.read (fun i => (simCfg.work i).read) simCfg.output.read + (work utmScratchTape) ∧ + (work utmDescTape).head = 1 ∧ + (work utmStateTape).head = 1 ∧ + (work utmSimTape).head = 1 ∧ + WorkTapesWF work) + B := by + intro e + -- Helper: tape index facts for `decide` + have hne_desc_st : utmDescTape ≠ utmStateTape := by decide + have hne_desc_sc : utmDescTape ≠ utmScratchTape := by decide + have hne_st_sc : utmStateTape ≠ utmScratchTape := by decide + have hne_sim_sc : utmSimTape ≠ utmScratchTape := by decide + have hne_sim_st : utmSimTape ≠ utmStateTape := by decide + have hne_desc_sim : utmDescTape ≠ utmSimTape := by decide + -- Helper: classify Fin 4 into the 4 tape indices + have fin4_cases : ∀ (i : Fin 4), + i = utmDescTape ∨ i = utmStateTape ∨ i = utmSimTape ∨ i = utmScratchTape := by + decide + refine ⟨readCurrentTimeBound k simCfg, fun inp work out ⟨hdesc, hstate_tape, hscc, hdesc_h, hstate_h, + hsim_h, hsc_h, hsc_blank, hwf, hinp_r, hinp_h, hout_r, hout_h⟩ => ?_⟩ + -- ── Phase 1: copyState ────────────────────────────────────────────── + obtain ⟨c₁, hreach₁, hst₁, hst_head₁, hst_cells₁, hsc_head₁, hsc_cells₁, hsc_high₁, + hsim_head₁, hsim_cells₁, hdesc₁, hinp₁, hout₁, hwf₁⟩ := + copyState_simulation + ⟨(readCurrentTM (n := n)).qstart, inp, work, out⟩ + k (e simCfg.state) rfl hstate_h hsc_h hsim_h + (show (work utmDescTape).head ≥ 1 by omega) + hstate_tape hwf hinp_r hinp_h hout_r hout_h + -- ── Phase 2: all_tapes ────────────────────────────────────────────── + have hscc₁ : superCellsCorrect simCfg ⟨1, (c₁.work utmSimTape).cells⟩ := by + rw [hsim_cells₁]; exact hscc + have hwork_heads₁ : ∀ i, (c₁.work i).head ≥ 1 := by + intro i; rcases fin4_cases i with rfl | rfl | rfl | rfl + · have := congr_arg Tape.head hdesc₁; simp only [] at this; rw [this, hdesc_h] + · omega + · omega + · omega + obtain ⟨c₂, t₂, hreach₂, hst₂, hsim_head₂, hsim_cells₂, hdesc₂, hstate₂, + hsc_head₂, hsc_prev₂, hsc_above₂, hsc_vals₂, hinp₂, hout₂, hwf₂, ht₂_bound⟩ := + all_tapes_simulation simCfg (n + 2) ⟨0, by omega⟩ (by simp) le_rfl c₁ (k + 1) + hst₁ hsim_head₁ (by rw [hsim_cells₁]; exact hwf.1 utmSimTape) hscc₁ + hsc_head₁ (by omega) hwf₁ + (by rw [hinp₁]; exact hinp_r) (by rw [hinp₁]; exact hinp_h) + (by rw [hout₁]; exact hout_r) (by rw [hout₁]; exact hout_h) hwork_heads₁ + -- ── Phase 3a: rewindState ─────────────────────────────────────────── + have hstate_head₂ : (c₂.work utmStateTape).head = k + 1 := by + rw [hstate₂]; exact hst_head₁ + have hheads₂_ne : ∀ i, i ≠ utmStateTape → (c₂.work i).head ≥ 1 := by + intro i hne; rcases fin4_cases i with rfl | rfl | rfl | rfl + · have := congr_arg Tape.head hdesc₂; simp only [] at this; rw [this] + exact hwork_heads₁ utmDescTape + · exact absurd rfl hne + · omega + · rw [hsc_head₂]; omega + obtain ⟨c₃, hreach₃, hst₃, hstate_head₃, hstate_cells₃, hother₃, hinp₃, hout₃, hwf₃⟩ := + rewindState_simulation (k + 1) c₂ hst₂ hstate_head₂ hwf₂ + (by rw [hinp₂, hinp₁]; exact hinp_r) (by rw [hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₂, hout₁]; exact hout_r) (by rw [hout₂, hout₁]; exact hout_h) + hheads₂_ne + -- ── Phase 3b: rewindScratch ───────────────────────────────────────── + have hsc_head₃ : (c₃.work utmScratchTape).head = k + 1 + 2 * (n + 2) := by + rw [hother₃ utmScratchTape hne_st_sc.symm]; exact hsc_head₂ + have hheads₃_ne : ∀ i, i ≠ utmScratchTape → (c₃.work i).head ≥ 1 := by + intro i hne; rcases fin4_cases i with rfl | rfl | rfl | rfl + · rw [hother₃ utmDescTape hne_desc_st]; exact hheads₂_ne utmDescTape hne_desc_st + · omega + · rw [hother₃ utmSimTape hne_sim_st]; omega + · exact absurd rfl hne + obtain ⟨c₄, hreach₄, hhalted₄, hsc_head₄, hsc_cells₄, hother₄, hinp₄, hout₄, hwf₄⟩ := + rewindScratch_simulation (k + 1 + 2 * (n + 2)) c₃ hst₃ hsc_head₃ hwf₃ + (by rw [hinp₃, hinp₂, hinp₁]; exact hinp_r) (by rw [hinp₃, hinp₂, hinp₁]; exact hinp_h) + (by rw [hout₃, hout₂, hout₁]; exact hout_r) (by rw [hout₃, hout₂, hout₁]; exact hout_h) + hheads₃_ne + -- ── Compose all phases ────────────────────────────────────────────── + have hreaches := reachesIn_trans readCurrentTM hreach₁ + (reachesIn_trans readCurrentTM hreach₂ + (reachesIn_trans readCurrentTM hreach₃ hreach₄)) + refine ⟨c₄, _, ?_, hreaches, hhalted₄, ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + -- Time bound + · show k + 1 + (t₂ + (k + 1 + 2 + (k + 1 + 2 * (n + 2) + 2))) ≤ readCurrentTimeBound k simCfg + unfold readCurrentTimeBound + have : (⟨0, by omega⟩ : Fin (n + 2)).val = 0 := rfl + rw [this] at ht₂_bound + omega + -- Post 1: descOnTape + · rw [hother₄ utmDescTape hne_desc_sc, hother₃ utmDescTape hne_desc_st, + hdesc₂, hdesc₁]; exact hdesc + -- Post 2: stateOnTapeAt + · have hcells : (c₄.work utmStateTape).cells = (work utmStateTape).cells := by + rw [hother₄ utmStateTape hne_st_sc] + show (c₃.work utmStateTape).cells = _ + rw [hstate_cells₃, hstate₂, hst_cells₁] + have hhead : (c₄.work utmStateTape).head = 1 := by + rw [hother₄ utmStateTape hne_st_sc]; exact hstate_head₃ + show stateOnTapeAt k (e simCfg.state) (c₄.work utmStateTape) + simp only [stateOnTapeAt, hcells, hhead] + simp only [stateOnTapeAt, hstate_h] at hstate_tape + exact hstate_tape + -- Post 3: superCellsCorrect + · have hcells : (c₄.work utmSimTape).cells = (work utmSimTape).cells := by + rw [hother₄ utmSimTape hne_sim_sc, hother₃ utmSimTape hne_sim_st, + hsim_cells₂, hsim_cells₁] + show superCellsCorrect simCfg (c₄.work utmSimTape) + unfold superCellsCorrect simTapeCellCorrect at hscc ⊢ + simp only [hcells]; exact hscc + -- Post 4: scratchHasInputPattern + · -- Establish cell chain: c₄ scratch cells = c₂ scratch cells + have h_sc₃₂ : c₃.work utmScratchTape = c₂.work utmScratchTape := + hother₃ utmScratchTape (Ne.symm hne_st_sc) + have hcc : ∀ j, (c₄.work utmScratchTape).cells j = + (c₂.work utmScratchTape).cells j := by + intro j; exact congr_fun hsc_cells₄ j ▸ congr_fun (congr_arg Tape.cells h_sc₃₂) j + refine ⟨⟨hwf₄.1 utmScratchTape, ?_, ?_⟩, hsc_head₄⟩ + · -- Per-cell: ∀ i < bits.length, cells(i+1) = Γ.ofBool bits[i] + intro i hi + rw [encodeInputPattern_length_eq] at hi + by_cases hik : i < k + · -- State bits (i < k) + rw [hcc, hsc_prev₂ (i + 1) (by omega), hsc_cells₁ i hik]; symm + simp only [TMEncoding.encodeInputPattern, List.append_assoc] + rw [List.getElem_append_left (show i < ((List.finRange k).map (· == e simCfg.state)).length + from by simp [List.length_map, List.length_finRange]; omega)] + rw [List.getElem_map, List.getElem_finRange] + simp only [Fin.cast_mk, Γ.ofBool] + by_cases h : i = (e simCfg.state).val + · have : ((⟨i, hik⟩ : Fin k) == e simCfg.state) = true := by + rw [beq_iff_eq, Fin.ext_iff]; exact h + simp [h] + · have : ((⟨i, hik⟩ : Fin k) == e simCfg.state) = false := by + rw [beq_eq_false_iff_ne]; exact fun heq => h (Fin.ext_iff.mp heq) + simp [this, h] + + · -- Tape encoding bits (i ≥ k) + push_neg at hik + have hp : (i - k) / 2 < n + 2 := by omega + have hvals := hsc_vals₂ ((i - k) / 2) hp + -- Normalize the ↑⟨0, ⋯⟩ + p to just p in hvals + simp only [Nat.zero_add] at hvals + -- Connect simCellsFn/simHeadPos to encodeInputPattern via tape_getElem + have h_sim_eq : simCellsFn simCfg ⟨(i - k) / 2, by omega⟩ + (simHeadPos simCfg ⟨(i - k) / 2, by omega⟩) = + (if h₀ : (i - k) / 2 = 0 then simCfg.input.read + else if h₁ : (i - k) / 2 ≤ n then + (simCfg.work ⟨(i - k) / 2 - 1, by omega⟩).read + else simCfg.output.read) := by + simp only [simCellsFn, simHeadPos, Tape.read] + split <;> [rfl; split <;> rfl] + -- Show cell(i+1) = cell in c₂ at the right position + rw [hcc, show i + 1 = k + 1 + 2 * ((i - k) / 2) + (i - k) % 2 from by omega] + rcases Nat.mod_two_eq_zero_or_one (i - k) with h0 | h1 + · -- b = 0 + rw [h0, Nat.add_zero]; rw [hvals.1]; congr 1 + have h_tape := encodeInputPattern_tape_getElem k n (e simCfg.state) + simCfg.input.read (fun j => (simCfg.work j).read) simCfg.output.read + ((i - k) / 2) 0 hp (by omega) + simp only [h_sim_eq]; convert h_tape.symm using 2; omega + · -- b = 1 + rw [h1]; rw [hvals.2]; congr 1 + have h_tape := encodeInputPattern_tape_getElem k n (e simCfg.state) + simCfg.input.read (fun j => (simCfg.work j).read) simCfg.output.read + ((i - k) / 2) 1 hp (by omega) + simp only [h_sim_eq]; convert h_tape.symm using 2; omega + · -- Sentinel blank: cells(bits.length + 1) = Γ.blank + rw [encodeInputPattern_length_eq, hcc, hsc_above₂ _ (by omega), + hsc_high₁ _ (by omega)] + exact hsc_blank _ (by omega) + -- Post 5: desc head = 1 + · rw [hother₄ utmDescTape hne_desc_sc, hother₃ utmDescTape hne_desc_st, hdesc₂, hdesc₁] + exact hdesc_h + -- Post 6: state head = 1 + · rw [hother₄ utmStateTape hne_st_sc]; exact hstate_head₃ + -- Post 7: sim head = 1 + · rw [hother₄ utmSimTape hne_sim_sc, hother₃ utmSimTape hne_sim_st]; exact hsim_head₂ + -- Post 8: WorkTapesWF + · exact hwf₄ + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/SimConfig/Defs.lean b/Complexitylib/Models/TuringMachine/UTM/SimConfig/Defs.lean new file mode 100644 index 0000000..65a02a6 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/SimConfig/Defs.lean @@ -0,0 +1,212 @@ +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Complexitylib.Models.TuringMachine.Combinators.SeqInternal + +/-! +# Simulation Configuration + +Defines the simulation invariant and tape predicates that relate the UTM's +work tapes to the simulated TM's configuration. + +## Main definitions + +- `SimInvariant` — the loop invariant: work tapes encode a simulated config +- `stateOnTapeAt` — one-hot state encoding on a tape +- `superCellsCorrect` — super-cell encoding of all simulated tapes +- `descOnTape` — description bits stored on a tape +- `scratchHasInputPattern` — scratch tape has serialized (state, symbols) +- `scratchHasTransOutput` — scratch tape has decoded transition output +- `WorkTapesWF` — all work tapes have cell 0 = ▷, cells ≥ 1 ≠ ▷ + +## Work Tape Layout (4 work tapes) + +| Tape | Index | Contents | +|------|-------|----------| +| Description | `0` | Encoded TM description (read-only after init) | +| State | `1` | Current simulated state (one-hot: k cells) | +| Simulation | `2` | All simulated tapes interleaved as super-cells | +| Scratch | `3` | Temporary workspace | +-/ + +namespace TM + +-- ════════════════════════════════════════════════════════════════════════ +-- Work tape indices +-- ════════════════════════════════════════════════════════════════════════ + +abbrev utmDescTape : Fin 4 := 0 +abbrev utmStateTape : Fin 4 := 1 +abbrev utmSimTape : Fin 4 := 2 +abbrev utmScratchTape : Fin 4 := 3 + +-- ════════════════════════════════════════════════════════════════════════ +-- Tape well-formedness +-- ════════════════════════════════════════════════════════════════════════ + +/-- All work tapes are well-formed: cell 0 = ▷, cells ≥ 1 ≠ ▷. -/ +def WorkTapesWF (work : Fin 4 → Tape) : Prop := + (∀ i, (work i).cells 0 = Γ.start) ∧ + (∀ i j, j ≥ 1 → (work i).cells j ≠ Γ.start) + +-- ════════════════════════════════════════════════════════════════════════ +-- State encoding on tape +-- ════════════════════════════════════════════════════════════════════════ + +/-- Encode a state `q : Fin k` as a one-hot pattern on a tape. + Cell 0 = ▷ (as always). + Cell (j+1) = Γ.one if j = q.val, else Γ.zero, for 0 ≤ j < k. + Cell (k+1) = Γ.blank (sentinel). -/ +def stateOnTapeAt (k : ℕ) (q : Fin k) (t : Tape) : Prop := + t.cells 0 = Γ.start ∧ + (∀ j, j < k → t.cells (j + 1) = if j = q.val then Γ.one else Γ.zero) ∧ + t.cells (k + 1) = Γ.blank + +-- ════════════════════════════════════════════════════════════════════════ +-- Super-cell encoding of simulated tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- The simulation tape correctly encodes a single simulated tape at a given + position. For position `pos` of simulated tape `tapeIdx`: + - Head marker cell = Γ.one if the simulated head is at `pos`, Γ.blank otherwise + - Symbol cells encode `tape.cells pos` via `symToCellPair` + + Design: head-absent = `Γ.blank` (not `Γ.zero`) so that uninitialized UTM sim + tape cells automatically satisfy this predicate for blank-content positions + where the head is elsewhere. -/ +def simTapeCellCorrect (numTapes : ℕ) (tapeIdx : ℕ) (pos : ℕ) + (simHead : ℕ) (simSym : Γ) (utmSim : Tape) : Prop := + let base := SuperCell.simTapeOffset numTapes pos tapeIdx + let (hi, lo) := SuperCell.symToCellPair simSym + utmSim.cells base = (if simHead = pos then Γ.one else Γ.blank) ∧ + utmSim.cells (base + 1) = hi ∧ + utmSim.cells (base + 2) = lo + +/-- The simulation tape correctly encodes all simulated tapes at every position. + The simulated machine has n work tapes, so n+2 total tapes (input + n work + output). + Tape indices: 0 = input, 1..n = work, n+1 = output. -/ +def superCellsCorrect {n : ℕ} {Q : Type} (simCfg : Cfg n Q) (utmSim : Tape) : Prop := + utmSim.cells 0 = Γ.start ∧ + -- Input tape encoding (tape index 0) + (∀ pos, simTapeCellCorrect (n + 2) 0 pos simCfg.input.head + (simCfg.input.cells pos) utmSim) ∧ + -- Work tape encodings (tape indices 1..n) + (∀ (i : Fin n) pos, simTapeCellCorrect (n + 2) (i.val + 1) pos + (simCfg.work i).head ((simCfg.work i).cells pos) utmSim) ∧ + -- Output tape encoding (tape index n+1) + (∀ pos, simTapeCellCorrect (n + 2) (n + 1) pos simCfg.output.head + (simCfg.output.cells pos) utmSim) + +-- ════════════════════════════════════════════════════════════════════════ +-- Description tape encoding +-- ════════════════════════════════════════════════════════════════════════ + +/-- A tape stores a list of bools at cells 1..len, with cell 0 = ▷ and + a blank sentinel after. Used for both the description tape and scratch tape. -/ +def tapeStoresBools (bits : List Bool) (t : Tape) : Prop := + t.cells 0 = Γ.start ∧ + (∀ (i : ℕ) (hi : i < bits.length), + t.cells (i + 1) = Γ.ofBool (bits[i]'hi)) ∧ + t.cells (bits.length + 1) = Γ.blank + +/-- The description tape correctly stores the encoded TM description. -/ +abbrev descOnTape (desc : List Bool) (t : Tape) : Prop := tapeStoresBools desc t + +-- ════════════════════════════════════════════════════════════════════════ +-- Scratch tape predicates +-- ════════════════════════════════════════════════════════════════════════ + +/-- The scratch tape contains the serialized input pattern (state + current symbols) + for lookup in the transition table. + + Format matches the input pattern prefix of a self-describing entry: + q (one-hot, k bits) ++ iHead (2b) ++ wHeads (2n bits) ++ oHead (2b). -/ +def scratchHasInputPattern (k n : ℕ) (q : Fin k) + (iHead : Γ) (wHeads : Fin n → Γ) (oHead : Γ) (scratch : Tape) : Prop := + tapeStoresBools (TMEncoding.encodeInputPattern k n q iHead wHeads oHead) scratch ∧ + scratch.head = 1 + +/-- The scratch tape contains the decoded transition output after lookup. + + Format matches the output portion of a self-describing entry: + q' (one-hot, k bits) ++ wWrites (2n bits) ++ oWrite (2b) + ++ iDir (2b) ++ wDirs (2n bits) ++ oDir (2b). -/ +def scratchHasTransOutput (k n : ℕ) (q' : Fin k) + (wW : Fin n → Γw) (oW : Γw) + (iD : Dir3) (wD : Fin n → Dir3) (oD : Dir3) (scratch : Tape) : Prop := + tapeStoresBools (TMEncoding.encodeTransOutput k n q' wW oW iD wD oD) scratch ∧ + scratch.head = 1 + +-- ════════════════════════════════════════════════════════════════════════ +-- Simulation invariant +-- ════════════════════════════════════════════════════════════════════════ + +/-- The simulation invariant: the UTM's work tapes encode a simulated TM + configuration. This is the loop invariant for `loopTM simStepTM checkHaltTM`. + + Existentially quantifies over the simulated config `simCfg`. The sub-machine + specs are parametric in `simCfg` and instantiate the existential when composing. + + Components: + - Description tape stores the encoded TM + - State tape has one-hot encoding of current state + - Simulation tape has super-cell encoding of all simulated tapes + - All work tape heads at cell 1 (rewound) + - All work tapes well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷) -/ +noncomputable def SimInvariant {n : ℕ} (tm : TM n) (k : ℕ) + (hk : k = @Fintype.card tm.Q tm.finQ) (desc : List Bool) : TapePred 4 := + fun _inp work _out => + ∃ (simCfg : Cfg n tm.Q), + descOnTape desc (work utmDescTape) ∧ + stateOnTapeAt k (tm.stateEquivK hk simCfg.state) (work utmStateTape) ∧ + superCellsCorrect simCfg (work utmSimTape) ∧ + (∀ i, (work i).head ≥ 1) ∧ + WorkTapesWF work + +-- ════════════════════════════════════════════════════════════════════════ +-- seqTM transition preservation +-- ════════════════════════════════════════════════════════════════════════ + +/-- When a tape reads a non-▷ symbol, `idleDir` returns `.stay`. -/ +private theorem idleDir_stay_of_ne {t : Tape} (h : t.read ≠ Γ.start) : + idleDir t.read = Dir3.stay := by + simp [idleDir, h] + +/-- When a tape reads a non-▷ symbol, `readBackWrite` preserves it. -/ +private theorem readBackWrite_toΓ_eq_read {t : Tape} (h : t.read ≠ Γ.start) : + (readBackWrite t.read).toΓ = t.read := by + cases hr : t.read <;> simp_all [readBackWrite, Γw.toΓ] + +/-- `seqTransitionTape` is identity when the tape reads a non-▷ symbol + and head ≥ 1. (Head stays, cell is written back with same value.) -/ +theorem seqTransitionTape_id {t : Tape} + (hread : t.read ≠ Γ.start) (hhead : t.head ≥ 1) : + seqTransitionTape t = t := by + simp only [seqTransitionTape, Tape.writeAndMove, idleDir_stay_of_ne hread, + Tape.move, readBackWrite_toΓ_eq_read hread, Tape.write] + split + · omega + · show { head := t.head, cells := Function.update t.cells t.head t.read } = t + simp only [Tape.read, Function.update_eq_self] + +/-- `seqTransitionInput` is identity when the tape reads a non-▷ symbol. -/ +theorem seqTransitionInput_id {t : Tape} + (hread : t.read ≠ Γ.start) : + seqTransitionInput t = t := by + simp only [seqTransitionInput, idleDir_stay_of_ne hread, Tape.move] + +/-- When all work tapes are well-formed and heads ≥ 1, `seqTransitionTape` is + identity on every work tape. This is the key lemma for `seqTM_hoareTime`'s + `h_trans` obligation: the intermediate postcondition carries through unchanged. -/ +theorem seqTransition_work_id {work : Fin 4 → Tape} + (hwf : WorkTapesWF work) + (hheads : ∀ i, (work i).head ≥ 1) : + (fun i => seqTransitionTape (work i)) = work := by + ext i + apply seqTransitionTape_id + · intro h + have := hwf.2 i (work i).head (hheads i) + rw [Tape.read] at h + exact this h + · exact hheads i + +end TM diff --git a/Complexitylib/Models/TuringMachine/UTM/UTM.lean b/Complexitylib/Models/TuringMachine/UTM/UTM.lean new file mode 100644 index 0000000..8849035 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/UTM/UTM.lean @@ -0,0 +1,114 @@ +import Complexitylib.Models.TuringMachine.Combinators +import Complexitylib.Models.TuringMachine.Hoare +import Complexitylib.Models.TuringMachine.UTM.Defs +import Complexitylib.Models.TuringMachine.UTM.Helpers +import Complexitylib.Models.TuringMachine.UTM.HelpersInternal +import Complexitylib.Models.TuringMachine.UTM.SimConfig.Defs +import Complexitylib.Models.TuringMachine.UTM.Init +import Complexitylib.Models.TuringMachine.UTM.ReadCurrent +import Complexitylib.Models.TuringMachine.UTM.Lookup +import Complexitylib.Models.TuringMachine.UTM.ApplyTransition +import Complexitylib.Models.TuringMachine.UTM.CheckHalt +import Complexitylib.Models.TuringMachine.UTM.CheckHaltInternal +import Complexitylib.Models.TuringMachine.UTM.ExtractOutput + +/-! +# Universal Turing Machine (AB Theorem 1.9) + +Top-level composition of the UTM from sub-machines, connected via +`seqTM_hoareTime` and `loopTM_hoareTime`. + +## Architecture + +``` +utmTM = + seqTM initTM + (seqTM (loopTM utmSimStepTM utmCheckHaltTM) + extractOutputTM) +``` + +Where: +``` +utmSimStepTM = + seqTM readCurrentTM + (seqTM lookupTM + applyTransitionTM) +``` + +## Main results + +- `utmTM` — the Universal Turing Machine definition +- `utm_simulates` — simulation correctness theorem +- `utm_correct` — AB Theorem 1.9: O(T²) time overhead +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- Simulation step machine: one step of the simulated TM +-- ════════════════════════════════════════════════════════════════════════ + +/-- The simulation step machine performs one step of the simulated TM. + Composed as: readCurrentTM ; lookupTM ; applyTransitionTM. + Parametric in `k` (number of states of the simulated TM). -/ +noncomputable def utmSimStepTM (k : ℕ) : TM 4 := + seqTM (readCurrentTM (n := n)) (seqTM (lookupTM (n := n) k) (applyTransitionTM (n := n) k)) + +-- ════════════════════════════════════════════════════════════════════════ +-- The Universal Turing Machine +-- ════════════════════════════════════════════════════════════════════════ + +/-- The Universal Turing Machine. + Architecture: initTM ; loop(simStepTM, checkHaltTM) ; extractOutputTM. + Parametric in `k` (number of states of the simulated TM). -/ +noncomputable def utmTM (k : ℕ) : TM 4 := + seqTM initTM + (seqTM (loopTM (utmSimStepTM (n := n) k) utmCheckHaltTM) + (extractOutputTM (n := n))) + +-- ════════════════════════════════════════════════════════════════════════ +-- Simulation correctness +-- ════════════════════════════════════════════════════════════════════════ + +/-- The UTM's initial configuration with input `⟨M, x⟩` encoded as `List Γ`. + Uses `initTape` directly since `encodeUTMInput` returns `List Γ` + (not `List Bool`), which already includes the blank separator. -/ +noncomputable def utmInitCfg (tm : TM n) (k : ℕ) (x : List Bool) : + Cfg 4 (utmTM (n := n) k).Q := + { state := (utmTM (n := n) k).qstart, + input := initTape (encodeUTMInput tm x), + work := fun _ => initTape [], + output := initTape [] } + +/-- The UTM correctly simulates any TM M: if M decides L in time T, + then running the UTM on `encodeUTMInput tm x` produces the same + accept/reject decision as M on x. -/ +theorem utm_simulates (tm : TM n) (k : ℕ) (hk : k = @Fintype.card tm.Q tm.finQ) + (L : Language) (T : ℕ → ℕ) + (hM : tm.DecidesInTime L T) (x : List Bool) : + ∃ (c' : Cfg 4 (utmTM (n := n) k).Q) (t : ℕ), + (utmTM (n := n) k).reachesIn t (utmInitCfg tm k x) c' ∧ + (utmTM (n := n) k).halted c' ∧ + (x ∈ L → c'.output.cells 1 = Γ.one) ∧ + (x ∉ L → c'.output.cells 1 = Γ.zero) := by + sorry + +-- ════════════════════════════════════════════════════════════════════════ +-- AB Theorem 1.9: O(T²) overhead +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Arora-Barak Theorem 1.9** (basic construction). + + For every TM M that decides language L in time T, there exists a + constant C (depending on |M| but not the input) such that the UTM + decides L in time C · T². -/ +theorem utm_correct (tm : TM n) (k : ℕ) (hk : k = @Fintype.card tm.Q tm.finQ) + (L : Language) (T : ℕ → ℕ) + (hM : tm.DecidesInTime L T) : + ∃ (C : ℕ), + (utmTM (n := n) k).DecidesInTime L (fun len => C * (T len) ^ 2) := by + sorry + +end TM