From 5a07813f14adf87055dacd1445e84847019f1404 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 12:54:39 -0400 Subject: [PATCH 1/6] feat(Combinators): add seqTM, ifTM, loopTM combinators with generic proof infrastructure MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add three new TM combinators for compositional machine construction: - seqTM: sequential composition (tm₁ then tm₂), time t₁ + 1 + t₂ - ifTM: conditional branching (test → rewind → branch), with then/else - loopTM: loop until test condition, with body + test + rewind cycle Refactor proof internals into modular structure: - Internal/Generic.lean: reusable simulation_reachesIn and generic_rewind_loop infrastructure - Internal/Union.lean: unionTM-specific proofs (extracted from Internal.lean) - SeqInternal, IfInternal, LoopInternal: per-combinator proof modules All proofs are sorry-free. The generic rewind loop pattern captures the recurring output-head-rewind used by complement, if, and loop combinators. --- .../Models/TuringMachine/Combinators.lean | 392 ++++ .../Combinators/ComplementInternal.lean | 142 +- .../TuringMachine/Combinators/IfInternal.lean | 507 ++++++ .../TuringMachine/Combinators/Internal.lean | 1590 +---------------- .../Combinators/Internal/Generic.lean | 231 +++ .../Combinators/Internal/Union.lean | 1588 ++++++++++++++++ .../Combinators/LoopInternal.lean | 493 +++++ .../Combinators/SeqInternal.lean | 184 ++ 8 files changed, 3458 insertions(+), 1669 deletions(-) create mode 100644 Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/Internal/Union.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean create mode 100644 Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean 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..012e603 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean @@ -0,0 +1,493 @@ +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 + +-- ════════════════════════════════════════════════════════════════════════ +-- Full variants: rewind and check with input/work tape preservation +-- ════════════════════════════════════════════════════════════════════════ + +private theorem loop_rewind_step_left_full (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) + (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', (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 ∧ + c'.input = c.input ∧ c'.work = c.work := 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 _ _ + · exact tape_move_idleDir_stable _ h_ih h_ins + · ext i; exact tape_writeAndMove_stable _ (h_wh i) (h_wns i) + +private theorem loop_rewind_step_base_full (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) + (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', (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 ∧ + c'.input = c.input ∧ c'.work = c.work := 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] + · 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 loopTM_rewind_loop_full (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.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, + (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 ∧ + c_check.input = c.input ∧ + c_check.work = c.work := + generic_rewind_loop_full (loopTM tmBody tmTest) + (fun c hst hread hc0 hns h_ih h_ins h_wh h_wns => + loop_rewind_step_left_full tmBody tmTest 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 => + loop_rewind_step_base_full tmBody tmTest c hst hread hc0 hns h_ih h_ins h_wh h_wns) + +/-- Check-halt step with full tape tracking. -/ +theorem loopTM_check_halt_full (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) + (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', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inr (Sum.inl LoopPhase.done) ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := 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 _ _ + · 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-continue step with full tape tracking. -/ +theorem loopTM_check_continue_full (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) + (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', (loopTM tmBody tmTest).step c = some c' ∧ + c'.state = Sum.inl tmBody.qstart ∧ + c'.output.cells = c.output.cells ∧ + c'.output.head = 1 ∧ + c'.input = c.input ∧ c'.work = c.work := 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 _ _ + · have hstable := tape_writeAndMove_stable c.output (by omega) hnostart + 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/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 From 5edc18e0c35887a8a068d4d854c85fda77b9e735 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 12:54:49 -0400 Subject: [PATCH 2/6] feat(Hoare): add time-bounded Hoare logic for compositional TM reasoning MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce a Hoare triple framework for Turing machines: - TapePred: predicates on (input, work, output) tape configurations - HoareTime: time-bounded Hoare triple {pre} tm {post} [≤ bound] - Hoare: unbounded variant for pure correctness - Structural rules: consequence, weakening, strengthening, monotonicity Composition rules for all combinators: - seqTM_hoareTime: sequential composition with intermediate predicate - complementTM_hoareTime: output bit flipping with head bound - ifTM_hoareTime: conditional branching with AllTapesWF tracking - loopTM_hoareTime: loop invariant rule with variant-based termination AllTapesWF tracks well-formedness (cell 0 = ▷, cells ≥ 1 ≠ ▷) as a stability invariant preserved through tape transitions. --- Complexitylib/Models.lean | 4 + Complexitylib/Models/TuringMachine/Hoare.lean | 353 ++++++++++++++++++ .../Models/TuringMachine/Hoare/Defs.lean | 130 +++++++ 3 files changed, 487 insertions(+) create mode 100644 Complexitylib/Models/TuringMachine/Hoare.lean create mode 100644 Complexitylib/Models/TuringMachine/Hoare/Defs.lean diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index cccc124..99abf5b 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -3,3 +3,7 @@ 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 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 From 379a748581a82096e9836cf4f988d6407751f4e7 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 12:54:53 -0400 Subject: [PATCH 3/6] chore: add .claude/ to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 7913863..4af097a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ /.lake arora-barak-draft.pdf +.claude/ From 8aa17afdada0af4e1a36eabe3219c34c365a7fdd Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 13:05:21 -0400 Subject: [PATCH 4/6] refactor: unify duplicated transition tape operations, remove linter suppression MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Extract `transitionTape`/`transitionInput` and their property lemmas (`_cells`, `_head_ge`, `_head_bound`) into Generic.lean as the single source of truth. These were previously duplicated as `seqTransitionTape`, `ifTransitionTape`, and `loopTransitionTape`. - Remove `set_option linter.unusedSimpArgs false` from Hoare.lean (the underlying simp calls were already clean). - Rename `AllTapesWF.ifTransition` → `AllTapesWF.transition` since the property is combinator-agnostic. Net: -64 lines, zero duplication of the phase-transition tape operations. --- .../TuringMachine/Combinators/IfInternal.lean | 72 ++---------- .../Combinators/Internal/Generic.lean | 70 ++++++++++++ .../Combinators/LoopInternal.lean | 72 ++++-------- .../Combinators/SeqInternal.lean | 48 ++------ Complexitylib/Models/TuringMachine/Hoare.lean | 106 ++++++++---------- 5 files changed, 152 insertions(+), 216 deletions(-) diff --git a/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean index 0aab5ad..3e22975 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean @@ -145,23 +145,14 @@ theorem ifTM_else_simulation (tmTest tmThen tmElse : TM n) {t : ℕ} -- 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 + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape 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] @@ -172,9 +163,9 @@ 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 + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape 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] @@ -189,9 +180,9 @@ 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 + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape 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] @@ -210,51 +201,6 @@ theorem ifTM_halted_done (tmTest tmThen tmElse : TM n) (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) -- ════════════════════════════════════════════════════════════════════════ diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean index b04cd5b..dd61ec6 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean @@ -228,4 +228,74 @@ theorem generic_rewind_loop_full (tm : TM n) by rw [hinp_t, hinp], by rw [hwork_t, hwork]⟩ +-- ════════════════════════════════════════════════════════════════════════ +-- Standard phase-transition tape operations +-- ════════════════════════════════════════════════════════════════════════ + +/-- The standard tape transformation applied at combinator phase boundaries + (work tapes and output tape). Writes back the current symbol (preserving + cells) and stays in place; if at cell 0, `δ_right_of_start` forces a + right move to cell 1. + + Used by all combinators (`seqTM`, `ifTM`, `loopTM`, `complementTM`) + at transitions between phases. -/ +def transitionTape (t : Tape) : Tape := + t.writeAndMove (readBackWrite t.read).toΓ (idleDir t.read) + +/-- The standard input-tape transformation at combinator phase boundaries. + The input tape is read-only (no write), so only the head moves: stay + in place unless at cell 0, where `δ_right_of_start` forces right. -/ +def transitionInput (t : Tape) : Tape := + t.move (idleDir t.read) + +/-- `transitionTape` preserves cells when cells ≥ 1 ≠ start. -/ +theorem transitionTape_cells (t : Tape) + (hns : ∀ j, j ≥ 1 → t.cells j ≠ Γ.start) : + (transitionTape t).cells = t.cells := by + simp only [transitionTape, 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] + +/-- `transitionInput` preserves cells (always, since input has no write). -/ +theorem transitionInput_cells (t : Tape) : + (transitionInput t).cells = t.cells := by + simp [transitionInput, Tape.move]; split <;> rfl + +/-- After `transitionTape`, head ≥ 1 when cell 0 = start. -/ +theorem transitionTape_head_ge (t : Tape) (h0 : t.cells 0 = Γ.start) : + (transitionTape t).head ≥ 1 := by + unfold transitionTape Tape.writeAndMove + by_cases hh : t.head = 0 + · simp only [Tape.write, hh, ↓reduceIte, Tape.read, h0, idleDir, Tape.move]; 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 `transitionInput`, head ≥ 1 when cell 0 = start. -/ +theorem transitionInput_head_ge (t : Tape) (h0 : t.cells 0 = Γ.start) : + (transitionInput t).head ≥ 1 := by + unfold transitionInput + 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 + +/-- Bound on `transitionTape` output head: ≤ original head + 1. -/ +theorem transitionTape_head_bound {t : Tape} {p_bound : ℕ} + (hcell0 : t.cells 0 = Γ.start) (hhead : t.head ≤ p_bound) : + (transitionTape t).head ≤ p_bound + 1 := by + unfold transitionTape Tape.writeAndMove + by_cases hh : t.head = 0 + · simp only [Tape.write, hh, ↓reduceIte, Tape.read, hcell0, idleDir, Tape.move]; 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 + end TM diff --git a/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean index 012e603..8c70a7f 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean @@ -10,7 +10,7 @@ This file contains the simulation lemmas for `loopTM tmBody tmTest`. - `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 +- Tape transformations use the shared `transitionTape` / `transitionInput` -/ variable {n : ℕ} @@ -35,16 +35,6 @@ def loopTestWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmTest.Q) : 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 -- ════════════════════════════════════════════════════════════════════════ @@ -88,9 +78,9 @@ theorem loopTM_body_to_test (tmBody tmTest : TM n) {c : Cfg n tmBody.Q} (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 + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape 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] @@ -131,9 +121,9 @@ 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 + input := transitionInput c.input, + work := fun i => transitionTape (c.work i), + output := transitionTape 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] @@ -258,28 +248,6 @@ theorem loopTM_halted_done (tmBody tmTest : TM n) (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 -- ════════════════════════════════════════════════════════════════════════ @@ -291,17 +259,17 @@ theorem loopTM_iteration_halt (tmBody tmTest : TM n) {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 } + input := transitionInput c_body_end.input, + work := fun i => transitionTape (c_body_end.work i), + output := transitionTape 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) + (hcell0 : (transitionTape 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) : + (transitionTape c_test_end.output).cells j ≠ Γ.start) + (hhead : (transitionTape c_test_end.output).head = p) + (hcell1 : (transitionTape 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 ∧ @@ -319,17 +287,17 @@ theorem loopTM_iteration_halt (tmBody tmTest : TM n) 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 } := + input := transitionInput c_test_end.input, + work := fun i => transitionTape (c_test_end.work i), + output := transitionTape 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 } + input := transitionInput c_test_end.input, + work := fun i => transitionTape (c_test_end.work i), + output := transitionTape c_test_end.output } rfl hcell0 hnostart hhead -- Check: output at cell 1 is Γ.one obtain ⟨c_done, hstep_done, hst_done, hcells_done⟩ := diff --git a/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean index 24247ef..3fef946 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean @@ -10,7 +10,7 @@ This file contains the simulation lemmas for `seqTM tm₁ tm₂`. - `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 +- Tape transformations use the shared `transitionTape` / `transitionInput` -/ variable {n : ℕ} @@ -37,18 +37,6 @@ def phase2Wrap (tm₁ : TM n) (tm₂ : TM n) (c₂ : Cfg n tm₂.Q) : 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) -- ════════════════════════════════════════════════════════════════════════ @@ -86,9 +74,9 @@ theorem seqTM_transition_step (tm₁ tm₂ : TM n) {c₁ : Cfg n tm₁.Q} (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 + input := transitionInput c₁.input, + work := fun i => transitionTape (c₁.work i), + output := transitionTape 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] @@ -133,9 +121,9 @@ theorem seqTM_full_simulation (tm₁ tm₂ : TM n) {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 } + input := transitionInput c₁_end.input, + work := fun i => transitionTape (c₁_end.work i), + output := transitionTape c₁_end.output } c₂_end) : (seqTM tm₁ tm₂).reachesIn (t₁ + 1 + t₂) (phase1Wrap tm₁ tm₂ c₁_start) @@ -159,26 +147,4 @@ theorem phase2Wrap_halted (tm₁ tm₂ : TM n) (c₂ : Cfg n tm₂.Q) : 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 index 5d0f442..7a353af 100644 --- a/Complexitylib/Models/TuringMachine/Hoare.lean +++ b/Complexitylib/Models/TuringMachine/Hoare.lean @@ -15,8 +15,6 @@ import Complexitylib.Models.TuringMachine.Combinators.ComplementInternal - `loopTM_hoareTime` — loop invariant rule -/ -set_option linter.unusedSimpArgs false - namespace TM variable {n : ℕ} @@ -26,9 +24,9 @@ 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)) + mid' (transitionInput inp) + (fun i => transitionTape (work i)) + (transitionTape out)) (h₂ : tm₂.HoareTime mid' post b₂) : (seqTM tm₁ tm₂).HoareTime pre post (b₁ + 1 + b₂) := by intro inp work out hpre @@ -48,38 +46,26 @@ def AllTapesWF (inp : Tape) (work : Fin n → Tape) (out : Tape) : Prop := out.cells 0 = Γ.start ∧ (∀ j, j ≥ 1 → out.cells j ≠ Γ.start) -- ════════════════════════════════════════════════════════════════════════ --- AllTapesWF propagation through ifTransition +-- AllTapesWF propagation through phase transitions -- ════════════════════════════════════════════════════════════════════════ -/-- AllTapesWF is preserved through ifTransition (readBackWrite + idleDir). -/ -theorem AllTapesWF.ifTransition {inp : Tape} {work : Fin n → Tape} {out : Tape} +/-- AllTapesWF is preserved through the standard combinator phase transition + (`transitionTape` / `transitionInput`). -/ +theorem AllTapesWF.transition {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 + (transitionInput inp).head ≥ 1 ∧ + (∀ j, j ≥ 1 → (transitionInput inp).cells j ≠ Γ.start) ∧ + (∀ i, (transitionTape (work i)).head ≥ 1) ∧ + (∀ i j, j ≥ 1 → (transitionTape (work i)).cells j ≠ Γ.start) ∧ + (transitionTape out).cells = out.cells ∧ + (transitionTape 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 + exact ⟨transitionInput_head_ge inp hic0, + by rw [transitionInput_cells]; exact hins, + fun i => transitionTape_head_ge _ (hwc0 i), + fun i j hj => by rw [transitionTape_cells _ (hwns i)]; exact hwns i j hj, + transitionTape_cells out hons, + transitionTape_head_ge out hoc0⟩ -- ════════════════════════════════════════════════════════════════════════ -- Complement rule @@ -132,19 +118,19 @@ theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) (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)) + mid_then (transitionInput inp) (fun i => transitionTape (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)) + mid_else (transitionInput inp) (fun i => transitionTape (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)) + post (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) (h_post_else : ∀ inp work out, post_else inp work out → - post (ifTransitionInput inp) (fun i => ifTransitionTape (work i)) - (ifTransitionTape out)) : + post (transitionInput inp) (fun i => transitionTape (work i)) + (transitionTape out)) : (ifTM tmTest tmThen tmElse).HoareTime pre post (b_test + p_bound + max b_then b_else + 5) := by intro inp work out hpre @@ -158,14 +144,14 @@ theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) 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 + AllTapesWF.transition (h_wf _ _ _ hmid) + have h_out_head_bound := transitionTape_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 + ifTM_rewind_loop_full tmTest tmThen tmElse (transitionTape 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 } + input := transitionInput c_test.input, + work := fun i => transitionTape (c_test.work i), + output := transitionTape 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 @@ -184,7 +170,7 @@ theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) 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)) + (1 + ((transitionTape 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 @@ -203,19 +189,19 @@ theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) -- 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, + transitionInput c_then.input, + fun i => transitionTape (c_then.work i), + transitionTape c_then.output⟩ + refine ⟨c_done, t₁ + (1 + ((transitionTape c_test.output).head + 1)) + 1 + t₃ + 1, ?_, ?_, ?_, ?_⟩ - · have : (ifTransitionTape c_test.output).head + 1 ≤ p_bound + 2 := by omega + · have : (transitionTape 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 + ⟨tmThen.qstart, transitionInput c_test.input, + fun i => transitionTape (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 = @@ -243,19 +229,19 @@ theorem ifTM_hoareTime (tmTest tmThen tmElse : TM n) 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, + transitionInput c_else.input, + fun i => transitionTape (c_else.work i), + transitionTape c_else.output⟩ + refine ⟨c_done_else, t₁ + (1 + ((transitionTape c_test.output).head + 1)) + 1 + t₃ + 1, ?_, ?_, ?_, ?_⟩ - · have : (ifTransitionTape c_test.output).head + 1 ≤ p_bound + 2 := by omega + · have : (transitionTape 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 + ⟨tmElse.qstart, transitionInput c_test.input, + fun i => transitionTape (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 = From e475bad6fbe1d1b6e1a13f211667c285f4b540b2 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 13:23:55 -0400 Subject: [PATCH 5/6] feat(Encoding,Subroutines): add state normalization, binary encoding, and TM building blocks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Extract general-purpose infrastructure from the UTM development: **Encoding.lean**: State normalization and binary encoding primitives. - `TM.normalize`: convert any TM to use `Fin (Fintype.card Q)` states, with full behavioral equivalence (`normalize_decidesInTime`) - `Γ.encode`/`Γ.decode`, `Γw.encode`, `Dir3.encode`: 2-bit symbol/direction encodings with roundtrip correctness - `Nat.toBits`/`Nat.fromBits`: fixed-width big-endian binary - `allΓ`, `allΓFuncs`: canonical enumeration of tape symbols **Subroutines.lean**: Five composable TM building blocks. - `writeTM sym`: write symbol to output cell 1 and halt - `rewindWorkTM idx`: rewind work tape to cell 1 - `scanRightTM idx`: scan work tape right until blank - `copyInputToWorkTM idx`: copy input tape to work tape - `compareWorkTapesTM i j`: compare two work tapes cell by cell **Subroutines/Internal.lean**: HoareTime specifications. - `writeTM_hoareTime`: time B+3, postcondition output cell 1 = sym.toΓ - `rewindWorkTM_hoareTime`: time B+2, postcondition head = 1 - `rewindWorkTM_rich_hoareTime`: preserves arbitrary predicate P through rewind **Generic.lean additions**: Frame rules for composition. - `transitionTape_id`: transitionTape is identity when tape reads non-▷ - `transitionInput_id`: same for input tape - `rightOfStart_allIdle` made public (needed by subroutines) --- Complexitylib/Models.lean | 3 + .../Models/TuringMachine/Combinators.lean | 2 +- .../Combinators/Internal/Generic.lean | 23 + .../Models/TuringMachine/Encoding.lean | 205 +++++++++ .../Models/TuringMachine/Subroutines.lean | 278 ++++++++++++ .../TuringMachine/Subroutines/Internal.lean | 406 ++++++++++++++++++ 6 files changed, 916 insertions(+), 1 deletion(-) create mode 100644 Complexitylib/Models/TuringMachine/Encoding.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines.lean create mode 100644 Complexitylib/Models/TuringMachine/Subroutines/Internal.lean diff --git a/Complexitylib/Models.lean b/Complexitylib/Models.lean index 99abf5b..4d8b398 100644 --- a/Complexitylib/Models.lean +++ b/Complexitylib/Models.lean @@ -7,3 +7,6 @@ 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.Encoding +import Complexitylib.Models.TuringMachine.Subroutines +import Complexitylib.Models.TuringMachine.Subroutines.Internal diff --git a/Complexitylib/Models/TuringMachine/Combinators.lean b/Complexitylib/Models/TuringMachine/Combinators.lean index f5face6..f3bd363 100644 --- a/Complexitylib/Models/TuringMachine/Combinators.lean +++ b/Complexitylib/Models/TuringMachine/Combinators.lean @@ -81,7 +81,7 @@ def allIdle {σ : Type} {k : ℕ} (newState, fun _ => .blank, .blank, idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) /-- Proof that all-idle directions satisfy `δ_right_of_start`. -/ -private def rightOfStart_allIdle (iHead : Γ) (wHeads : Fin k → Γ) (oHead : Γ) : +def rightOfStart_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) := diff --git a/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean index dd61ec6..9526c45 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/Internal/Generic.lean @@ -298,4 +298,27 @@ theorem transitionTape_head_bound {t : Tape} {p_bound : ℕ} | right => simp only [Tape.move, Tape.write, hh, ↓reduceIte]; omega | left => exfalso; revert hdir; simp only [idleDir]; split <;> simp +-- ════════════════════════════════════════════════════════════════════════ +-- Frame rules: transitionTape/transitionInput are identity on stable tapes +-- ════════════════════════════════════════════════════════════════════════ + +/-- **Frame rule**: `transitionTape` is the identity when the tape reads a + non-▷ symbol. This is the key lemma for threading invariants through + `seqTM` / `loopTM` / `ifTM` composition: tapes that are "stable" + (head not at cell 0) pass through phase transitions unchanged. -/ +theorem transitionTape_id {t : Tape} (hread : t.read ≠ Γ.start) : + transitionTape t = t := by + unfold transitionTape Tape.writeAndMove + rw [readBackWrite_toΓ_eq hread] + simp only [idleDir, hread, ↓reduceIte, Tape.move, Tape.write] + split + · rfl + · simp only [Tape.read, Function.update_eq_self] + +/-- **Frame rule**: `transitionInput` is the identity when the tape reads a + non-▷ symbol. -/ +theorem transitionInput_id {t : Tape} (hread : t.read ≠ Γ.start) : + transitionInput t = t := by + simp only [transitionInput, idleDir, hread, ↓reduceIte, Tape.move] + end TM diff --git a/Complexitylib/Models/TuringMachine/Encoding.lean b/Complexitylib/Models/TuringMachine/Encoding.lean new file mode 100644 index 0000000..52cba1a --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Encoding.lean @@ -0,0 +1,205 @@ +import Complexitylib.Models.TuringMachine + +/-! +# TM State Normalization and Binary Encoding + +This file provides two pieces of general infrastructure for working with +Turing machines: + +1. **State normalization**: Convert any `TM n` with finite state type `Q` to + an equivalent machine using states `Fin (Fintype.card Q)`. This is needed + whenever states must be represented as binary numbers (e.g., for encoding + a TM description). + +2. **Binary encoding primitives**: Fixed-width encodings for tape symbols, + write symbols, directions, and natural numbers, with roundtrip correctness + proofs. + +## Main definitions + +### State normalization +- `TM.stateEquiv` — canonical equivalence `Q ≃ Fin (Fintype.card Q)` +- `TM.normalize` — normalize state type to `Fin (Fintype.card Q)` +- `TM.normalizeCfg` — embed a config into the normalized state space +- `TM.normalize_decidesInTime` — behavioral equivalence + +### Binary encoding +- `Γ.encode` / `Γ.decode` — tape symbol ↔ 2 bits +- `Γw.encode` — write symbol → 2 bits +- `Dir3.encode` — direction → 2 bits +- `Nat.toBits` / `Nat.fromBits` — fixed-width big-endian binary + +### Enumeration +- `allΓ` — all 4 tape symbols in canonical order +- `allΓFuncs` — enumerate all `Fin n → Γ` functions +-/ + +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`. -/ +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. -/ +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 diff --git a/Complexitylib/Models/TuringMachine/Subroutines.lean b/Complexitylib/Models/TuringMachine/Subroutines.lean new file mode 100644 index 0000000..aeb2fb6 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines.lean @@ -0,0 +1,278 @@ +import Complexitylib.Models.TuringMachine.Combinators + +/-! +# TM Subroutines + +Small concrete Turing machines used as composable building blocks for +constructing larger machines via `seqTM`, `ifTM`, and `loopTM`. + +Each subroutine has a corresponding `HoareTime` specification in +`Complexitylib.Models.TuringMachine.Subroutines.Internal`. + +## Main definitions + +- `TM.writeTM` — write a symbol to output cell 1 and halt +- `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 : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- 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 rightOfStart_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 rightOfStart_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 rightOfStart_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 rightOfStart_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 rightOfStart_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 rightOfStart_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 rightOfStart_allIdle iHead wHeads oHead + | .matchDone => exact rightOfStart_allIdle iHead wHeads oHead + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +end TM diff --git a/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean b/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean new file mode 100644 index 0000000..ef660d8 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/Internal.lean @@ -0,0 +1,406 @@ +import Complexitylib.Models.TuringMachine.Subroutines +import Complexitylib.Models.TuringMachine.Hoare.Defs +import Complexitylib.Models.TuringMachine.Combinators.Internal.Generic + +/-! +# TM Subroutines: proof internals + +Simulation lemmas and HoareTime proofs for the subroutine machines defined in +`Complexitylib.Models.TuringMachine.Subroutines`. + +## Main results + +- `writeTM_hoareTime` — writes `sym.toΓ` to output cell 1 +- `rewindWorkTM_hoareTime` — rewinds work tape `idx` to cell 1 +- `rewindWorkTM_rich_hoareTime` — rewind preserving arbitrary predicate P +-/ + +namespace TM + +variable {n : ℕ} + +-- ════════════════════════════════════════════════════════════════════════ +-- writeTM: rewind loop +-- ════════════════════════════════════════════════════════════════════════ + +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 +-- ════════════════════════════════════════════════════════════════════════ + +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 + have hoDir : idleDir (c.output.read) = Dir3.stay := by + simp [idleDir, Tape.read, hhead, hnostart1] + -- Step 1: goRight → write + 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 + 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. + **Pre**: output tape well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷), head ≤ B. + **Post**: 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⟩ + 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 + 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 +-- ════════════════════════════════════════════════════════════════════════ + +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 +-- ════════════════════════════════════════════════════════════════════════ + +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' ∧ + (rewindWorkTM idx).halted c' ∧ + (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', hhalt, hhead⟩ := hstep + exact ⟨c', .step hstep' .zero, hhalt, hhead⟩ + +-- ════════════════════════════════════════════════════════════════════════ +-- rewindWorkTM: main HoareTime theorem +-- ════════════════════════════════════════════════════════════════════════ + +/-- `rewindWorkTM idx` rewinds work tape `idx` to cell 1 and halts. + **Pre**: work tape `idx` well-formed (cell 0 = ▷, cells ≥ 1 ≠ ▷), head ≤ B. + **Post**: 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⟩ + 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 + 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 invariants (e.g., simulation state, + encoded data) 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⟩ + -- Helper: idle-step identity for stable tapes + have tape_idle_preserve : ∀ (t : Tape), t.read ≠ Γ.start → t.head ≥ 1 → + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + intro t hns hh + 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] + -- 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 From 3450bc566be6bb339e2c09c905dd90a8c74cd297 Mon Sep 17 00:00:00 2001 From: Samuel Schlesinger Date: Sat, 4 Apr 2026 14:10:02 -0400 Subject: [PATCH 6/6] docs: improve module docstrings and add missing definition docs - Add time-bound formulas and tape transition explanation to Hoare.lean module docstring - Add docstrings to all config wrapping functions (phase1Wrap, phase2Wrap, ifTestWrap, ifThenWrap, ifElseWrap, loopBodyWrap, loopTestWrap) --- .../TuringMachine/Combinators/IfInternal.lean | 3 +++ .../TuringMachine/Combinators/LoopInternal.lean | 2 ++ .../TuringMachine/Combinators/SeqInternal.lean | 6 ++++-- Complexitylib/Models/TuringMachine/Hoare.lean | 17 +++++++++++++---- 4 files changed, 22 insertions(+), 6 deletions(-) diff --git a/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean index 3e22975..9d2af4d 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/IfInternal.lean @@ -21,6 +21,7 @@ namespace TM -- Config wrapping -- ════════════════════════════════════════════════════════════════════════ +/-- Embed a `tmTest` config into the `ifTM` config space (test phase). -/ 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 @@ -28,6 +29,7 @@ def ifTestWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) work := c.work output := c.output +/-- Embed a `tmThen` config into the `ifTM` config space (then branch). -/ 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)) @@ -35,6 +37,7 @@ def ifThenWrap (tmTest : TM n) (tmThen : TM n) (tmElse : TM n) work := c.work output := c.output +/-- Embed a `tmElse` config into the `ifTM` config space (else branch). -/ 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)) diff --git a/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean index 8c70a7f..8cc2387 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/LoopInternal.lean @@ -21,6 +21,7 @@ namespace TM -- Config wrapping -- ════════════════════════════════════════════════════════════════════════ +/-- Embed a `tmBody` config into the `loopTM` config space (body phase). -/ 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 @@ -28,6 +29,7 @@ def loopBodyWrap (tmBody : TM n) (tmTest : TM n) (c : Cfg n tmBody.Q) : work := c.work output := c.output +/-- Embed a `tmTest` config into the `loopTM` config space (test phase). -/ 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) diff --git a/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean index 3fef946..bb9aea3 100644 --- a/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean +++ b/Complexitylib/Models/TuringMachine/Combinators/SeqInternal.lean @@ -21,7 +21,8 @@ namespace TM -- Config wrapping -- ════════════════════════════════════════════════════════════════════════ -/-- Embed a `tm₁` configuration into the `seqTM` config space. -/ +/-- Embed a `tm₁` configuration into the `seqTM` config space (Phase 1). + State is wrapped in `Sum.inl`; tapes are shared. -/ 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 @@ -29,7 +30,8 @@ def phase1Wrap (tm₁ : TM n) (tm₂ : TM n) (c₁ : Cfg n tm₁.Q) : work := c₁.work output := c₁.output -/-- Embed a `tm₂` configuration into the `seqTM` config space. -/ +/-- Embed a `tm₂` configuration into the `seqTM` config space (Phase 2). + State is wrapped in `Sum.inr`; tapes are shared. -/ 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 diff --git a/Complexitylib/Models/TuringMachine/Hoare.lean b/Complexitylib/Models/TuringMachine/Hoare.lean index 7a353af..45e6838 100644 --- a/Complexitylib/Models/TuringMachine/Hoare.lean +++ b/Complexitylib/Models/TuringMachine/Hoare.lean @@ -7,12 +7,21 @@ import Complexitylib.Models.TuringMachine.Combinators.ComplementInternal /-! # Hoare-style composition rules for TM combinators +This file provides Hoare-triple composition rules for all four TM combinators. +Each rule specifies how pre/postconditions and time bounds compose. + ## 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 +- `seqTM_hoareTime` — sequential composition: time `b₁ + 1 + b₂` +- `complementTM_hoareTime` — complement flips output cell 1: time `b + p_bound + 4` +- `ifTM_hoareTime` — if-then-else branching: time `b_test + p_bound + max b_then b_else + 5` +- `loopTM_hoareTime` — loop invariant with variant: time `(k + 1) * b_iter` + +## Tape transition effects + +All combinators apply `transitionTape` / `transitionInput` at phase boundaries. +These are the identity on stable tapes (head ≥ 1, read ≠ ▷) — see `transitionTape_id`. +The `AllTapesWF` invariant ensures stability is preserved across transitions. -/ namespace TM