diff --git a/Complexitylib/Asymptotics/PolyBound.lean b/Complexitylib/Asymptotics/PolyBound.lean new file mode 100644 index 00000000..e4b24aab --- /dev/null +++ b/Complexitylib/Asymptotics/PolyBound.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Asymptotics + +/-! +# Polynomial bounds on natural-number functions + +`PolyBound f` says `f` is dominated pointwise (at every argument, not merely +eventually) by the evaluation of a natural polynomial. Resource bookkeeping +assembles time and space bounds by addition, multiplication, and monotonicity, +so an everywhere-bound closed under those operations is easier to carry through +a construction than a big-O statement; `PolyBound.bigO` converts to the big-O +form the complexity classes are stated in. + +## Main results + +- `PolyBound` — pointwise domination by a natural polynomial +- `PolyBound.const`, `.id`, `.add`, `.mul`, `.pow`, `.mono`, `.max`, `.eval` — + the closure API +- `PolyBound.bigO` — a polynomial bound is a big-O power bound +-/ + + +@[expose] public section + +namespace Complexity + +/-- Pointwise domination by the evaluation of a natural polynomial. -/ +def PolyBound (f : ℕ → ℕ) : Prop := + ∃ p : Polynomial ℕ, ∀ inputLength, f inputLength ≤ p.eval inputLength + +namespace PolyBound + +theorem const (value : ℕ) : PolyBound (fun _ => value) := + ⟨Polynomial.C value, fun _ => by simp⟩ + +theorem id : PolyBound (fun inputLength => inputLength) := + ⟨Polynomial.X, fun _ => by simp⟩ + +theorem add {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => f inputLength + g inputLength) := by + obtain ⟨p, hp⟩ := hf + obtain ⟨q, hq⟩ := hg + exact ⟨p + q, fun inputLength => by + rw [Polynomial.eval_add] + exact Nat.add_le_add (hp inputLength) (hq inputLength)⟩ + +theorem mul {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => f inputLength * g inputLength) := by + obtain ⟨p, hp⟩ := hf + obtain ⟨q, hq⟩ := hg + exact ⟨p * q, fun inputLength => by + rw [Polynomial.eval_mul] + exact Nat.mul_le_mul (hp inputLength) (hq inputLength)⟩ + +theorem mono {f g : ℕ → ℕ} (hg : PolyBound g) + (hle : ∀ inputLength, f inputLength ≤ g inputLength) : PolyBound f := by + obtain ⟨p, hp⟩ := hg + exact ⟨p, fun inputLength => le_trans (hle inputLength) (hp inputLength)⟩ + +theorem max {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : + PolyBound (fun inputLength => max (f inputLength) (g inputLength)) := + (hf.add hg).mono fun _ => Nat.max_le.mpr + ⟨Nat.le_add_right _ _, Nat.le_add_left _ _⟩ + +theorem eval (p : Polynomial ℕ) : + PolyBound (fun inputLength => p.eval inputLength) := + ⟨p, fun _ => le_rfl⟩ + +theorem pow {f : ℕ → ℕ} (hf : PolyBound f) (exponent : ℕ) : + PolyBound (fun inputLength => f inputLength ^ exponent) := by + induction exponent with + | zero => simpa using const 1 + | succ exponent ih => simpa [pow_succ] using ih.mul hf + +/-- A polynomial bound is a big-O bound by the polynomial's degree. -/ +theorem bigO {f : ℕ → ℕ} (hf : PolyBound f) : ∃ d, f =O (· ^ d) := by + obtain ⟨p, hp⟩ := hf + exact ⟨p.natDegree, BigO.of_polynomial_bound p hp⟩ + +end PolyBound + +end Complexity diff --git a/Complexitylib/Classes/P.lean b/Complexitylib/Classes/P.lean index b27cf6ae..6eb2a781 100644 --- a/Complexitylib/Classes/P.lean +++ b/Complexitylib/Classes/P.lean @@ -12,6 +12,7 @@ public import Complexitylib.Classes.P.PairWithInput public import Complexitylib.Classes.P.Preimage public import Complexitylib.Classes.P.UnaryLength public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.P.Cobham public import Complexitylib.Models.TuringMachine.Subroutines.CopyOutput /-! @@ -36,6 +37,7 @@ This file aggregates the definitions and theorems for P, FP, and PSPACE. - `mem_P_preimage` — `P` is closed under preimages of functions in `FP` - `unaryLength_mem_FP` — materializing the unary input length belongs to `FP` - `ite_mem_finset_mem_FP` — functions supported on a finite set belong to `FP` +- `CobhamFP_eq_FP` — Cobham's machine-independent characterization of `FP` -/ diff --git a/Complexitylib/Classes/P/Cobham.lean b/Complexitylib/Classes/P/Cobham.lean new file mode 100644 index 00000000..692cd6d7 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Defs +public import Complexitylib.Classes.P.Defs +import Complexitylib.Classes.P.Cobham.Internal + +/-! +# Cobham's characterization of FP — surface layer + +Cobham's theorem (1965): the machine-independent function algebra +`Complexity.Cobham` of `Complexitylib.Classes.P.Cobham.Defs` carves out exactly +the polynomial-time computable string functions. + +## Main results + +- `CobhamFP_subset_FP` — every function of the algebra is polynomial-time +- `FP_subset_CobhamFP` — every polynomial-time function is in the algebra +- `CobhamFP_eq_FP` — **Cobham's theorem**, the two directions together + +## How the two directions are proved + +Both halves live in `Complexitylib.Classes.P.Cobham.Internal`. + +*Soundness* is the induction `Cobham f → FPn f` over the six constructors, where +`Cobham.FPn` lifts `FP` to argument vectors through the tuple encoding +`Cobham.encodeVec`. Four constructors are bespoke transducers +(`Cobham.cons_mem_FP`, `fstBlock_mem_FP`, `sndBlock_mem_FP`, `reorder_mem_FP`, +`mulLenFn_mem_FP`); the fifth, `boundedRec`, is a loop: recursion on notation is +a fold (`Cobham.recFold_eq_recNotation`), Cobham's side condition makes its width +clamp vacuous (`Cobham.recFoldClamp_eq_recFold`), and `Cobham.iterate_mem_FP` +runs the clamped step once per bit under a polynomial ruler. + +*Completeness* simulates a polynomial-time machine inside the algebra. A whole +configuration is one block-aligned bitstring with each tape split at its head, so +a head move is a two-bit shift (`Cobham.cfgCode`); the transition function is the +finite table `Cobham.stepFn`; the run is `Cobham.iterFn` under a clock built from +`smash` (`Cobham.exists_pow_clock`); and the output is read off the output tape +after a rewind (`Cobham.rewindFn`). The assembly is `Cobham.simFn_eq`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- Cobham's algebra is sound for polynomial time: every function of the (unary +fragment of the) algebra is computable by a deterministic TM in polynomial time. + +The multi-arity soundness induction `Cobham.cobham_imp_FPn`, specialized to +arity one. -/ +theorem CobhamFP_subset_FP : CobhamFP ⊆ FP := + Cobham.CobhamFP_subset_FP_of_FPn + +/-- Cobham's algebra is complete for polynomial time: every polynomial-time +computable function belongs to the algebra. + +Proved by simulating the machine inside the algebra (`Cobham.simFn_eq`). -/ +theorem FP_subset_CobhamFP : FP ⊆ CobhamFP := + Cobham.FP_subset_CobhamFP_internal + +/-- **Cobham's theorem** (1965): the machine-independent function algebra of +`Complexitylib.Classes.P.Cobham.Defs` characterizes exactly the polynomial-time +computable string functions. -/ +theorem CobhamFP_eq_FP : CobhamFP = FP := + Set.Subset.antisymm CobhamFP_subset_FP FP_subset_CobhamFP + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Defs.lean b/Complexitylib/Classes/P/Cobham/Defs.lean new file mode 100644 index 00000000..647f0bca --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Defs.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.Fin.Tuple.Basic +public import Mathlib.Data.List.Basic + +/-! +# Cobham's characterization of FP — definitions + +This file defines Cobham's machine-independent characterization of the polynomial-time +computable functions on bitstrings (Cobham, *The intrinsic computational difficulty of +functions*, 1965): the smallest class of functions `(Fin n → List Bool) → List Bool` +containing the projections, the empty string, the two bit successors, and the smash +function, and closed under composition and **limited recursion on notation**. + +Bitstrings are LSB-first: in the recursion on notation, the head of the list is the +least-significant (innermost) bit, so the bit successors *prepend* a bit +(`x ↦ b :: x`, the string analogue of `n ↦ 2·n + bit`), and recursion on notation +peels bits off the head. + +The functions are multi-arity (indexed by `Fin n` argument vectors) because limited +recursion on notation inherently produces functions of higher arity; the unary fragment +is collected in `CobhamFP`, which `Complexitylib.Classes.P.Cobham` proves equal to the +machine class `FP`. + +## Main definitions + +- `Complexity.smash` — Cobham's smash function: a string of length `|x| · |y|` +- `Complexity.recNotation` — the recursion-on-notation combinator +- `Complexity.Cobham` — the inductive predicate carving out Cobham's function algebra +- `Complexity.CobhamFP` — the unary fragment, as a set of string functions + +## Design notes + +The bound in `Cobham.boundedRec` follows Cobham's original formulation: the recursively +defined function must be *length-bounded by another function of the class* (rather than +by an external polynomial). Together with `smash` and the successors this realizes +exactly the polynomial length bounds, which is what makes the class no larger than `FP`; +dropping the bound would admit iterated doubling and hence exponential growth. + +The string toolkit the proof is written in — bit dispatch, flags, fixed-width blocks +— is not part of this statement and lives in +`Complexitylib.Classes.P.Cobham.Internal.Blocks`. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **Cobham's smash function** on bitstrings: a canonical string of length +`|x| · |y|`. This is the length-arithmetic engine of the class: composing `smash` with +the bit successors and projections realizes every polynomial length bound, which is +what lets `Cobham.boundedRec` bound recursions by a function of the class itself. + +(Cobham's original smash is `x # y = 2^(|x|·|y|)`; over bitstrings we keep only the +length, which is all the class ever uses.) -/ +def smash (x y : List Bool) : List Bool := + List.replicate (x.length * y.length) false + +@[simp] theorem smash_length (x y : List Bool) : + (smash x y).length = x.length * y.length := by + simp [smash] + + +/-- **Recursion on notation**: the string analogue of primitive recursion, recursing on +the bit structure of the first argument. + +`recNotation g h₀ h₁ x v` computes `g v` when `x` is empty, and on `b :: x` applies the +step function selected by the bit `b` to the argument vector consisting of the tail +`x`, the recursive value on the tail, and the parameters `v`. -/ +def recNotation {n : ℕ} (g : (Fin n → List Bool) → List Bool) + (h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool) : + List Bool → (Fin n → List Bool) → List Bool + | [], v => g v + | b :: x, v => + (bif b then h₁ else h₀) (Fin.cons x (Fin.cons (recNotation g h₀ h₁ x v) v)) + +@[simp] theorem recNotation_nil {n : ℕ} (g : (Fin n → List Bool) → List Bool) + (h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool) (v : Fin n → List Bool) : + recNotation g h₀ h₁ [] v = g v := rfl + +@[simp] theorem recNotation_cons {n : ℕ} (g : (Fin n → List Bool) → List Bool) + (h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool) (b : Bool) (x : List Bool) + (v : Fin n → List Bool) : + recNotation g h₀ h₁ (b :: x) v = + (bif b then h₁ else h₀) (Fin.cons x (Fin.cons (recNotation g h₀ h₁ x v) v)) := rfl + +/-- **Cobham's function algebra**: the smallest class of bitstring functions containing +the projections, the empty string, the bit successors `x ↦ b :: x`, and `smash`, and +closed under composition and limited recursion on notation. + +In `boundedRec`, the recursion is *limited*: the result must be length-bounded, +uniformly in the arguments, by a function `j` already in the class. This is the +polynomial-growth leash that pins the class to exactly `FP` +(see `Complexitylib.Classes.P.Cobham`). -/ +inductive Cobham : ∀ {n : ℕ}, ((Fin n → List Bool) → List Bool) → Prop + /-- Every projection is in the class. -/ + | proj {n : ℕ} (i : Fin n) : Cobham fun v => v i + /-- The empty-string constant (at every arity) is in the class. -/ + | empty {n : ℕ} : Cobham fun _ : Fin n → List Bool => [] + /-- The bit successors `x ↦ b :: x` (the string analogue of `n ↦ 2·n + b`) are in + the class. -/ + | bit (b : Bool) : Cobham fun v : Fin 1 → List Bool => b :: v 0 + /-- The smash function is in the class. -/ + | smash : Cobham fun v : Fin 2 → List Bool => smash (v 0) (v 1) + /-- The class is closed under composition. -/ + | comp {m n : ℕ} {f : (Fin m → List Bool) → List Bool} + {gs : Fin m → (Fin n → List Bool) → List Bool} : + Cobham f → (∀ i, Cobham (gs i)) → Cobham fun v => f fun i => gs i v + /-- The class is closed under **limited recursion on notation**: recursion on the bit + structure of the first argument, provided the result is length-bounded by a function + `j` of the class. -/ + | boundedRec {n : ℕ} {g : (Fin n → List Bool) → List Bool} + {h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool} + {j : (Fin (n + 1) → List Bool) → List Bool} : + Cobham g → Cobham h₀ → Cobham h₁ → Cobham j → + (∀ x v, (recNotation g h₀ h₁ x v).length ≤ (j (Fin.cons x v)).length) → + Cobham fun v : Fin (n + 1) → List Bool => recNotation g h₀ h₁ (v 0) (Fin.tail v) + +/-- The unary fragment of Cobham's function algebra, as a class of string functions. +`Complexitylib.Classes.P.Cobham` proves `CobhamFP = FP`: this machine-independent +algebra carves out exactly the polynomial-time computable functions. -/ +def CobhamFP : Set (List Bool → List Bool) := + {f | Cobham fun v : Fin 1 → List Bool => f (v 0)} + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal.lean b/Complexitylib/Classes/P/Cobham/Internal.lean new file mode 100644 index 00000000..89a2ae7e --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal.lean @@ -0,0 +1,1111 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Defs +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.SndBlock +public import Complexitylib.Classes.P.Cobham.Internal.Cat +public import Complexitylib.Classes.P.Cobham.Internal.ConsBit +public import Complexitylib.Classes.P.Cobham.Internal.Reorder +public import Complexitylib.Classes.P.Cobham.Internal.Vec +public import Complexitylib.Classes.P.Cobham.Internal.Algebra +public import Complexitylib.Classes.P.Cobham.Internal.Encoding +public import Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import Complexitylib.Classes.P.Cobham.Internal.Simulate +public import Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import Complexitylib.Classes.P.Cobham.Internal.Iterate +public import Complexitylib.Classes.P.Cobham.Internal.TakeLen +public import Complexitylib.Classes.P.Cobham.Internal.Reverse +public import Complexitylib.Classes.P.UnaryLength +public import Complexitylib.Classes.P.Cobham.Internal.MulLen +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Classes.P.Composition +public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.P.Cobham.Internal.HeadFlag +public import Complexitylib.Classes.P.PairWithInput +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Cobham's characterization of FP — proof internals + +The assembly of `CobhamFP = FP` (`Complexitylib.Classes.P.Cobham`). Not meant +for human review of the mathematics — the surface file carries the auditable +statements; the type checker carries this. + +The machines are in sibling modules (`Internal.BlockDecoders`, `Internal.Cat`, +`Internal.ConsBit`, `Internal.Reorder`, `Internal.MulLen`, `Internal.Iterate`), +the algebra toolkit in `Internal.Algebra`, and the interpreter of the +completeness direction in `Internal.Encoding`, `Internal.StepAlgebra`, +`Internal.Extract` and `Internal.Simulate`. What remains here is the soundness +induction and the `boundedRec` loop. + +## Contents + +- the six constructor cases `fpn_empty`, `fpn_proj`, `fpn_bit`, `fpn_smash`, + `fpn_comp`, `fpn_boundedRec`, and the induction `cobham_imp_FPn` over them; +- the `FP` closure lemmas they need: `pairFn_mem_FP`, `appendFn_mem_FP`, + `selectHeadFn_mem_FP` (branching on a bit, via `Complexity.headFlag`), + `takeLenFn_mem_FP`, `assembleVec_mem_FP`; +- the `boundedRec` loop: `recNotation_eq_foldr`, `recFold_eq_recNotation`, + `recFoldClamp_eq_recFold`, `loopStep_iterate` and `recFoldClamp_mem_FP`, on top + of `iterate_mem_FP`; +- the rulers `exists_ruler` and `exists_exact_ruler` that carry the loop's width + clamp as data. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## Soundness: `Cobham f → FPn f`, constructor by constructor -/ + +/-- `empty` case: the constant empty function is `FPn` at every arity, witnessed +by `const_nil_mem_FP`. -/ +theorem fpn_empty {n : ℕ} : FPn (fun _ : Fin n → List Bool => ([] : List Bool)) := + ⟨fun _ => [], const_nil_mem_FP, fun _ => rfl⟩ + +/-- `proj` case: extracting the `i`-th component of an encoded vector is `FP`. + +The extraction is `sndBlock` after `i`-fold `fstBlock`: peel `i` leading blocks to +reach the encoding of components `i, i+1, …`, then read its head with `sndBlock`. +Proved here by induction on the arity; each atomic step is `FP` +(`fstBlock_mem_FP`, `sndBlock_mem_FP`) and `FP` is closed under composition +(`mem_FP_comp`), so only those two machine lemmas remain open. -/ +theorem fpn_proj {n : ℕ} (i : Fin n) : FPn (fun v : Fin n → List Bool => v i) := by + induction n with + | zero => exact i.elim0 + | succ n ih => + induction i using Fin.cases with + | zero => + exact ⟨sndBlock, sndBlock_mem_FP, fun v => sndBlock_encodeVec_succ v⟩ + | succ j => + obtain ⟨g, hg, hgf⟩ := ih j + refine ⟨g ∘ fstBlock, mem_FP_comp fstBlock_mem_FP hg, fun v => ?_⟩ + show g (fstBlock (encodeVec v)) = v j.succ + rw [fstBlock_encodeVec_succ, hgf] + rfl + +/-- `bit` case: prepending a fixed bit is `FPn` at arity one. On the arity-one +encoding `encodeVec ![x] = pair [] x`, the head component `x` is `sndBlock`, so the +witness is `(b :: ·) ∘ sndBlock`; both factors are `FP`. -/ +theorem fpn_bit (b : Bool) : + FPn (fun v : Fin 1 → List Bool => b :: v 0) := by + refine ⟨(fun x => b :: x) ∘ sndBlock, + mem_FP_comp sndBlock_mem_FP (cons_mem_FP b), fun v => ?_⟩ + show b :: sndBlock (encodeVec v) = b :: v 0 + rw [sndBlock_encodeVec_succ] + +/-- Pairing two `FP` functions of the same input is `FP`. + +Built without a two-output machine: `mem_FP_pairWithInput` gives the nested triple +`z ↦ pair (a z) (pair (b z) z)` (pairing each computed value against the raw +input, then again), and the self-contained `reorder` drops the trailing input +copy to leave `pair (a z) (b z)`. This is what lets `fpn_comp` avoid a bespoke +tuple-assembly machine. -/ +theorem pairFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => pair (a z) (b z)) ∈ FP := by + have h1 : (fun z => pair (b z) z) ∈ FP := mem_FP_pairWithInput hb + have h2 : (fun w => pair (a (sndBlock w)) w) ∈ FP := + mem_FP_pairWithInput (mem_FP_comp sndBlock_mem_FP ha) + have h12 := mem_FP_comp h1 h2 + have heq : ((fun w => pair (a (sndBlock w)) w) ∘ fun z => pair (b z) z) + = fun z => pair (a z) (pair (b z) z) := by + funext z; simp [Function.comp, sndBlock_pair] + rw [heq] at h12 + have hr := mem_FP_comp h12 reorder_mem_FP + have heq2 : (reorder ∘ fun z => pair (a z) (pair (b z) z)) + = fun z => pair (a z) (b z) := by + funext z; simp [Function.comp, reorder_pair_pair] + rwa [heq2] at hr + +/-- **`FP` is closed under concatenation.** -/ +theorem appendFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => a z ++ b z) ∈ FP := by + have h := mem_FP_comp (pairFn_mem_FP ha hb) catBlocks_mem_FP + have heq : (catBlocks ∘ fun z => pair (a z) (b z)) = fun z => a z ++ b z := by + funext z + simp [Function.comp] + rwa [heq] at h + +/-- Emitting `|a z| · |b z|` copies of `false` is `FP` when `a, b` are. Built as +the self-contained `mulUnpair` (see `Complexitylib.Classes.P.Cobham.Internal.MulLen`) +after `pairFn a b`, avoiding a bespoke length-arithmetic machine over two +sub-machines. -/ +theorem mulLenFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => List.replicate ((a z).length * (b z).length) false) ∈ FP := by + have hc := mem_FP_comp (pairFn_mem_FP ha hb) mulUnpair_mem_FP + have heq : (mulUnpair ∘ fun z => pair (a z) (b z)) + = fun z => List.replicate ((a z).length * (b z).length) false := by + funext z; simp [Function.comp, mulUnpair_pair] + rwa [heq] at hc + +/-- Truncating one `FP` value to another's length. -/ +theorem takeLenFn_mem_FP {a b : List Bool → List Bool} (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => (b z).take (a z).length) ∈ FP := by + have hc := mem_FP_comp (pairFn_mem_FP ha hb) takeLen_mem_FP + have heq : (takeLen ∘ fun z => pair (a z) (b z)) + = fun z => (b z).take (a z).length := by + funext z; simp [Function.comp, takeLen_pair] + rwa [heq] at hc + +/-- Select `x` or `y` according to the leading bit of `s`; nothing when `s` is +empty. This is the only shape of value-dependent branching the algebra's loop +needs, and `Complexity.headFlag` is what makes it expressible. -/ +def selectHead (s x y : List Bool) : List Bool := + if s.head? = some true then x else if s.head? = some false then y else [] + +/-- **Selection is masking.** Exactly one of the two masks is full width, so the +concatenation returns exactly one branch. -/ +theorem selectHead_eq (s x y : List Bool) : + selectHead s x y = x.take ((headFlag true s).length * x.length) + ++ y.take ((headFlag false s).length * y.length) := by + rw [selectHead, headFlag, headFlag] + rcases hs : s.head? with _ | a + · simp + · cases a <;> simp + +/-- **Selecting between two `FP` values by a bit is `FP`.** -/ +theorem selectHeadFn_mem_FP {f a b : List Bool → List Bool} + (hf : f ∈ FP) (ha : a ∈ FP) (hb : b ∈ FP) : + (fun z => selectHead (f z) (a z) (b z)) ∈ FP := by + have hflag : ∀ t : Bool, (fun z => headFlag t (f z)) ∈ FP := fun t => by + have := mem_FP_comp hf (headFlag_mem_FP t) + simpa [Function.comp] using this + have hx : (fun z => (a z).take ((headFlag true (f z)).length * (a z).length)) ∈ FP := by + have := takeLenFn_mem_FP (mulLenFn_mem_FP (hflag true) ha) ha + simpa using this + have hy : (fun z => (b z).take ((headFlag false (f z)).length * (b z).length)) ∈ FP := by + have := takeLenFn_mem_FP (mulLenFn_mem_FP (hflag false) hb) hb + simpa using this + have h := appendFn_mem_FP hx hy + have heq : (fun z => (a z).take ((headFlag true (f z)).length * (a z).length) + ++ (b z).take ((headFlag false (f z)).length * (b z).length)) + = fun z => selectHead (f z) (a z) (b z) := by + funext z; rw [selectHead_eq] + rwa [heq] at h + +/-- `smash` case: the smash function is `FPn`. On `encodeVec ![x, y]` the two +components are `sndBlock` and `sndBlock ∘ fstBlock`; `smash x y` is +`|x| · |y|` copies of `false`, so the witness is `mulLenFn_mem_FP` of the two +decoders. Rests only on `mulLenFn_mem_FP` and the block decoders. -/ +theorem fpn_smash : + FPn (fun v : Fin 2 → List Bool => Complexity.smash (v 0) (v 1)) := by + refine ⟨fun z => + List.replicate ((sndBlock z).length * (sndBlock (fstBlock z)).length) false, + mulLenFn_mem_FP sndBlock_mem_FP (mem_FP_comp fstBlock_mem_FP sndBlock_mem_FP), + fun v => ?_⟩ + show List.replicate + ((sndBlock (encodeVec v)).length * + (sndBlock (fstBlock (encodeVec v))).length) false + = Complexity.smash (v 0) (v 1) + rw [sndBlock_encodeVec_succ, fstBlock_encodeVec_succ, sndBlock_encodeVec_succ, + Complexity.smash] + rfl + +/-- Assembling an encoded vector out of `FP` component functions of a common input +is `FP`. Proved by induction on the arity: the empty vector is the constant `[]`, +and the successor step is one `pairFn_mem_FP`. -/ +theorem assembleVec_mem_FP {m : ℕ} (w : Fin m → (List Bool → List Bool)) + (hw : ∀ i, w i ∈ FP) : + (fun z => encodeVec fun i => w i z) ∈ FP := by + induction m with + | zero => + have : (fun z : List Bool => encodeVec fun i : Fin 0 => w i z) + = fun _ => [] := by funext z; rfl + rw [this]; exact const_nil_mem_FP + | succ m ih => + have htail : (fun z => encodeVec fun i : Fin m => Fin.tail w i z) ∈ FP := + ih (Fin.tail w) fun i => hw i.succ + have h0 : w 0 ∈ FP := hw 0 + have hpair := pairFn_mem_FP htail h0 + have heq : (fun z => encodeVec fun i : Fin (m + 1) => w i z) + = fun z => pair (encodeVec fun i : Fin m => Fin.tail w i z) (w 0 z) := by + funext z; rw [encodeVec_succ]; rfl + rw [heq]; exact hpair + +/-- `comp` case: `FPn` is closed under Cobham composition. On `encodeVec v`, each +inner `gs i` is computed by its `FP` witness `G i`, the results are assembled into +`encodeVec (fun i => gs i v)` (`assembleVec_mem_FP`), and the outer `f`'s witness +is applied; `FP` is closed under composition. Rests only on `pairFn_mem_FP`. -/ +theorem fpn_comp {m n : ℕ} {f : (Fin m → List Bool) → List Bool} + {gs : Fin m → (Fin n → List Bool) → List Bool} + (ihf : FPn f) (ihgs : ∀ i, FPn (gs i)) : + FPn (fun v => f fun i => gs i v) := by + obtain ⟨F, hF, hFf⟩ := ihf + choose G hG hGf using ihgs + refine ⟨F ∘ fun z => encodeVec fun i => G i z, + mem_FP_comp (assembleVec_mem_FP G hG) hF, fun v => ?_⟩ + show F (encodeVec fun i => G i (encodeVec v)) = f fun i => gs i v + have hinner : (fun i => G i (encodeVec v)) = fun i => gs i v := by + funext i; exact hGf i v + rw [hinner, hFf] + +/-- One step of recursion on notation viewed as a fold operation: extend the +running suffix `p.1` by the bit `b` and update the running recursive value `p.2` by +the bit-selected step function. Folding this over a string with `List.foldr` +reproduces `recNotation` (see `recNotation_eq_foldr`); it is the per-iteration +body a loop machine runs. -/ +def recNotationStep {n : ℕ} (h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool) + (w : Fin n → List Bool) (b : Bool) (p : List Bool × List Bool) : + List Bool × List Bool := + (b :: p.1, (bif b then h₁ else h₀) (Fin.cons p.1 (Fin.cons p.2 w))) + +/-- The first component of the recursion-on-notation fold accumulates exactly the +bits processed so far — i.e. it rebuilds the input string. -/ +theorem recNotationStep_foldr_fst {n : ℕ} (g : (Fin n → List Bool) → List Bool) + {h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool} (s : List Bool) + (w : Fin n → List Bool) : + (s.foldr (recNotationStep h₀ h₁ w) ([], g w)).1 = s := by + induction s with + | nil => rfl + | cons b x ih => simp [List.foldr_cons, recNotationStep, ih] + +/-- **Recursion on notation is a fold.** `recNotation g h₀ h₁ s w` is the second +component of folding `recNotationStep` over `s` from the empty suffix and base +value `g w`. This reduces the `boundedRec` case to iterating a single step +function over the bits of `s` — exactly what a loop machine computes — and is the +target identity for `fpn_boundedRec`. -/ +theorem recNotation_eq_foldr {n : ℕ} (g : (Fin n → List Bool) → List Bool) + (h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool) (s : List Bool) + (w : Fin n → List Bool) : + recNotation g h₀ h₁ s w = + (s.foldr (recNotationStep h₀ h₁ w) ([], g w)).2 := by + induction s with + | nil => rfl + | cons b x ih => + rw [recNotation_cons, List.foldr_cons] + simp only [recNotationStep] + rw [recNotationStep_foldr_fst g x w, ih] + +/-! ### The `boundedRec` loop + +The `boundedRec` case runs the recursion as a loop on *encoded* arguments: +`recFold A B e W s` threads a running suffix `t` of `s` and the running +accumulator `a` through the argument encoding `pair (pair W a) t`, which is +exactly `encodeVec (Fin.cons t (Fin.cons a w))` when `W = encodeVec w`. + +A machine cannot run `recFold` as written: nothing stops the accumulator from +doubling in length at every iteration, so intermediate values would need +exponential space. `recFoldClamp` truncates every intermediate value to a +prescribed width, which makes the loop unconditionally polynomial-time +(`recFoldClamp_mem_FP`); Cobham's limited-recursion side condition is then +exactly what shows the truncation never fires (`recFoldClamp_eq_recFold`). -/ + +/-- The recursion-on-notation loop on encoded arguments: fold the bit-selected +step functions `A` (bit `false`) and `B` (bit `true`) over `s`, threading the +running suffix and accumulator through the argument encoding. -/ +def recFold (A B : List Bool → List Bool) (e W : List Bool) : + List Bool → List Bool + | [] => e + | b :: t => (bif b then B else A) (pair (pair W (recFold A B e W t)) t) + +/-- `recFold` with every intermediate value truncated to `bound` bits. This is +the loop a machine can actually run: each iteration's state is length-bounded, +so the whole loop takes polynomial time. -/ +def recFoldClamp (A B : List Bool → List Bool) (bound : ℕ) (e W : List Bool) : + List Bool → List Bool + | [] => e.take bound + | b :: t => + ((bif b then B else A) + (pair (pair W (recFoldClamp A B bound e W t)) t)).take bound + +/-- A natural-coefficient polynomial is dominated by a single power of `n + 1` +scaled by the sum of its coefficients. -/ +private theorem poly_eval_le_pow (p : Polynomial ℕ) (n : ℕ) : + p.eval n ≤ + (∑ i ∈ Finset.range (p.natDegree + 1), p.coeff i) * (n + 1) ^ p.natDegree := by + rw [Polynomial.eval_eq_sum_range, Finset.sum_mul] + refine Finset.sum_le_sum fun i hi => ?_ + have hi' : i ≤ p.natDegree := by rw [Finset.mem_range] at hi; omega + exact Nat.mul_le_mul_left _ + (le_trans (Nat.pow_le_pow_left (by omega) i) (Nat.pow_le_pow_right (by omega) hi')) + +/-- An `FP` function whose output is at least `c` bits long, for any constant `c`. +Built by iterating `pair · []`, which doubles the length and adds two. -/ +theorem exists_const_ruler (c : ℕ) : + ∃ K : List Bool → List Bool, K ∈ FP ∧ ∀ z, c ≤ (K z).length := by + induction c with + | zero => exact ⟨fun _ => [], const_nil_mem_FP, fun _ => by simp⟩ + | succ c ih => + obtain ⟨K, hK, hlen⟩ := ih + refine ⟨fun z => pair (K z) [], pairFn_mem_FP hK const_nil_mem_FP, fun z => ?_⟩ + have := hlen z + simp only [pair_length, List.length_nil] + omega + +/-- **Rulers.** For every constant `c` and exponent `d` there is an `FP` function +whose output is at least `c · (|z| + 1) ^ d` bits long. Rulers let the loop of the +`boundedRec` case carry its width clamp as *data* — truncating to a string costs +linear time, whereas truncating to a computed number would not. -/ +theorem exists_pow_ruler (c d : ℕ) : + ∃ R : List Bool → List Bool, R ∈ FP ∧ + ∀ z, c * (z.length + 1) ^ d ≤ (R z).length := by + induction d with + | zero => + obtain ⟨K, hK, hlen⟩ := exists_const_ruler c + exact ⟨K, hK, fun z => by simpa using hlen z⟩ + | succ d ih => + obtain ⟨R, hR, hlen⟩ := ih + refine ⟨fun z => List.replicate ((R z).length * (pair [] z).length) false, + mulLenFn_mem_FP hR pairLeftNil_mem_FP, fun z => ?_⟩ + have hR' := hlen z + have hL : z.length + 1 ≤ (pair [] z).length := by simp + calc c * (z.length + 1) ^ (d + 1) + = (c * (z.length + 1) ^ d) * (z.length + 1) := by ring + _ ≤ (R z).length * (pair [] z).length := Nat.mul_le_mul hR' hL + _ = _ := by simp + +/-- Every polynomial bound has an `FP` ruler. -/ +theorem exists_ruler (p : Polynomial ℕ) : + ∃ R : List Bool → List Bool, R ∈ FP ∧ ∀ z, p.eval z.length ≤ (R z).length := by + obtain ⟨R, hR, hlen⟩ := + exists_pow_ruler (∑ i ∈ Finset.range (p.natDegree + 1), p.coeff i) p.natDegree + exact ⟨R, hR, fun z => le_trans (poly_eval_le_pow p z.length) (hlen z)⟩ + +/-! ### Exact rulers + +`exists_ruler` builds an `FP` string *at least* `p.eval |z|` bits long, which is +all a clamp needs. The loop needs an exact one: the width it truncates to is the +ruler's length, and that has to be the bound the statement names. Exactness comes +from `Complexity.unaryLength_mem_FP` together with the two exact length +arithmetic operations now available — `mulLenFn_mem_FP` multiplies lengths and +`appendFn_mem_FP` adds them. -/ + +/-- Constants of any width are `FP`. -/ +theorem const_replicate_mem_FP (c : ℕ) : + (fun _ : List Bool => List.replicate c false) ∈ FP := by + induction c with + | zero => simpa using const_nil_mem_FP + | succ c ih => + have := mem_FP_comp ih (cons_mem_FP false) + simpa [Function.comp, List.replicate_succ] using this + +/-- A ruler of length exactly `|z| ^ d`. -/ +private theorem exists_pow_exact_ruler (d : ℕ) : + ∃ R : List Bool → List Bool, R ∈ FP ∧ ∀ z, (R z).length = z.length ^ d := by + induction d with + | zero => exact ⟨fun _ => List.replicate 1 false, const_replicate_mem_FP 1, + fun z => by simp⟩ + | succ d ih => + obtain ⟨R, hR, hlen⟩ := ih + refine ⟨fun z => List.replicate ((R z).length * (List.replicate z.length true).length) + false, mulLenFn_mem_FP hR unaryLength_mem_FP, fun z => ?_⟩ + simp [hlen, pow_succ] + +/-- **A ruler of length exactly `p.eval |z|`.** -/ +theorem exists_exact_ruler (p : Polynomial ℕ) : + ∃ R : List Bool → List Bool, R ∈ FP ∧ ∀ z, (R z).length = p.eval z.length := by + have hsum : ∀ N : ℕ, ∃ R : List Bool → List Bool, R ∈ FP ∧ + ∀ z, (R z).length = ∑ i ∈ Finset.range N, p.coeff i * z.length ^ i := by + intro N + induction N with + | zero => exact ⟨fun _ => [], const_nil_mem_FP, fun z => by simp⟩ + | succ N ih => + obtain ⟨R, hR, hlen⟩ := ih + obtain ⟨S, hS, hSlen⟩ := exists_pow_exact_ruler N + refine ⟨fun z => R z ++ List.replicate + ((List.replicate (p.coeff N) false).length * (S z).length) false, + appendFn_mem_FP hR (mulLenFn_mem_FP (const_replicate_mem_FP _) hS), + fun z => ?_⟩ + rw [List.length_append, hlen, List.length_replicate, List.length_replicate, + hSlen, Finset.sum_range_succ] + obtain ⟨R, hR, hlen⟩ := hsum (p.natDegree + 1) + exact ⟨R, hR, fun z => by rw [hlen, ← Polynomial.eval_eq_sum_range]⟩ + +/-! ### The loop as an iteration + +`recFoldClamp` is an iteration of a *single* `FP` step function on a packed +state. Writing `s` for `sndBlock z`, the state after `m` iterations is + + `pair (pair R (pair W s)) (pair (s.drop (|s| - m)) (recFoldClamp … (s.drop (|s| - m))))` + +so the answer is the accumulator after `|s|` iterations. Every ingredient of the +step is now `FP`: the suffix grows by `Complexity.takeLen` against a ruler one +longer, read off `s.reverse`; the branch on the new leading bit is `selectHead`; +and the clamp is `takeLen` against `R`. -/ + +/-- One iteration of the clamped loop, on the loop's components. -/ +def loopStepOn (A B : List Bool → List Bool) (R W s t a : List Bool) : List Bool := + pair (pair R (pair W s)) + (pair ((takeLen (pair (false :: t) s.reverse)).reverse) + (takeLen (pair R + (selectHead ((takeLen (pair (false :: t) s.reverse)).reverse) + (B (pair (pair W a) t)) (A (pair (pair W a) t)))))) + +/-- One iteration of the clamped loop, on the packed state. -/ +def loopStep (A B : List Bool → List Bool) (v : List Bool) : List Bool := + loopStepOn A B (fstBlock (fstBlock v)) (fstBlock (sndBlock (fstBlock v))) + (sndBlock (sndBlock (fstBlock v))) (fstBlock (sndBlock v)) (sndBlock (sndBlock v)) + +@[simp] theorem loopStep_pair (A B : List Bool → List Bool) (R W s t a : List Bool) : + loopStep A B (pair (pair R (pair W s)) (pair t a)) = loopStepOn A B R W s t a := by + simp [loopStep] + +/-- **The step is `FP`.** -/ +theorem loopStep_mem_FP {A B : List Bool → List Bool} (hA : A ∈ FP) (hB : B ∈ FP) : + loopStep A B ∈ FP := by + have hfst : fstBlock ∈ FP := fstBlock_mem_FP + have hsnd : sndBlock ∈ FP := sndBlock_mem_FP + have hcomp₁ : ∀ {g : List Bool → List Bool}, g ∈ FP → + (fun v => fstBlock (g v)) ∈ FP := fun hg => by + simpa [Function.comp] using mem_FP_comp hg hfst + have hcomp₂ : ∀ {g : List Bool → List Bool}, g ∈ FP → + (fun v => sndBlock (g v)) ∈ FP := fun hg => by + simpa [Function.comp] using mem_FP_comp hg hsnd + have hP : (fun v : List Bool => fstBlock v) ∈ FP := hfst + have hR : (fun v : List Bool => fstBlock (fstBlock v)) ∈ FP := hcomp₁ hP + have hW : (fun v : List Bool => fstBlock (sndBlock (fstBlock v))) ∈ FP := + hcomp₁ (hcomp₂ hP) + have hs : (fun v : List Bool => sndBlock (sndBlock (fstBlock v))) ∈ FP := + hcomp₂ (hcomp₂ hP) + have ht : (fun v : List Bool => fstBlock (sndBlock v)) ∈ FP := hcomp₁ hsnd + have ha : (fun v : List Bool => sndBlock (sndBlock v)) ∈ FP := hcomp₂ hsnd + have hrev : ∀ {g : List Bool → List Bool}, g ∈ FP → + (fun v => (g v).reverse) ∈ FP := fun hg => by + simpa [Function.comp] using mem_FP_comp hg reverse_mem_FP + have hcons : (fun v : List Bool => false :: fstBlock (sndBlock v)) ∈ FP := by + simpa [Function.comp] using mem_FP_comp ht (cons_mem_FP false) + have ht' : (fun v : List Bool => + (takeLen (pair (false :: fstBlock (sndBlock v)) + (sndBlock (sndBlock (fstBlock v))).reverse)).reverse) ∈ FP := by + refine hrev ?_ + have := takeLenFn_mem_FP hcons (hrev hs) + simpa [takeLen_pair] using this + have hX : (fun v : List Bool => + pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v))) ∈ FP := pairFn_mem_FP (pairFn_mem_FP hW ha) ht + have hsel := selectHeadFn_mem_FP ht' + (by simpa [Function.comp] using mem_FP_comp hX hB) + (by simpa [Function.comp] using mem_FP_comp hX hA) + have hacc : (fun v : List Bool => takeLen (pair (fstBlock (fstBlock v)) + (selectHead ((takeLen (pair (false :: fstBlock (sndBlock v)) + (sndBlock (sndBlock (fstBlock v))).reverse)).reverse) + (B (pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v)))) + (A (pair (pair (fstBlock (sndBlock (fstBlock v))) (sndBlock (sndBlock v))) + (fstBlock (sndBlock v))))))) ∈ FP := by + have := takeLenFn_mem_FP hR hsel + simpa [takeLen_pair, Function.comp] using this + have hall := pairFn_mem_FP (pairFn_mem_FP hR (pairFn_mem_FP hW hs)) + (pairFn_mem_FP ht' hacc) + simpa [loopStep, loopStepOn] using hall + +/-- **The loop's invariant.** After `m` iterations the state holds the suffix +`s.drop (|s| - m)` and the clamped fold over it. -/ +theorem loopStep_iterate {A B : List Bool → List Bool} (R W s e : List Bool) : + ∀ m ≤ s.length, + (loopStep A B)^[m] + (pair (pair R (pair W s)) (pair [] (e.take R.length))) + = pair (pair R (pair W s)) + (pair (s.drop (s.length - m)) + (recFoldClamp A B R.length e W (s.drop (s.length - m)))) := by + intro m + induction m with + | zero => intro _; simp [recFoldClamp] + | succ m ih => + intro hm + rw [Function.iterate_succ_apply', ih (by omega), loopStep_pair, loopStepOn] + have hlt : s.length - (m + 1) < s.length := by omega + have hdrop : s.drop (s.length - (m + 1)) + = s[s.length - (m + 1)] :: s.drop (s.length - m) := by + rw [List.drop_eq_getElem_cons hlt, + show s.length - (m + 1) + 1 = s.length - m from by omega] + have hnext : (takeLen (pair (false :: s.drop (s.length - m)) s.reverse)).reverse + = s.drop (s.length - (m + 1)) := by + rw [takeLen_pair, List.length_cons, List.length_drop, + show s.length - (s.length - m) + 1 = s.length - (s.length - (m + 1)) from by omega, + ← List.reverse_drop, List.reverse_reverse] + rw [hnext, hdrop, recFoldClamp] + congr 2 + rw [takeLen_pair, selectHead] + cases hb : s[s.length - (m + 1)] <;> simp + +/-- The clamp really clamps. -/ +theorem recFoldClamp_length_le (A B : List Bool → List Bool) (bound : ℕ) + (e W s : List Bool) : (recFoldClamp A B bound e W s).length ≤ bound := by + cases s with + | nil => simp [recFoldClamp] + | cons b t => simp [recFoldClamp] + +/-! ### The loop's step function + +`Complexity.iterate_input_mem_FP` supplies a machine that applies an `FP` +function once per bit of its own input, starting from `pair [] x`. The state +below is `pair (pair C v) x`: a counter `C`, the running value `v`, and the +machine's input `x` kept verbatim. Keeping `x` is what makes the whole +construction work: the ruler and the width stay readable at every step, and +truncating the new state to `|x|` bounds the state length *globally* — the +machine's contract needs a bound that holds for every input, not just for the +well-formed ones. -/ + +/-- A flag whose leading bit is `true` exactly when `s` is empty — the one test +`Complexity.selectHead` cannot make directly. -/ +def emptyFlag (s : List Bool) : List Bool := + headFlag true s ++ headFlag false s ++ [true] + +@[simp] theorem emptyFlag_nil : emptyFlag [] = [true] := rfl + +theorem emptyFlag_head_cons (b : Bool) (t : List Bool) : + (emptyFlag (b :: t)).head? = some false := by + cases b <;> rfl + +theorem selectHead_emptyFlag_nil (x y : List Bool) : selectHead (emptyFlag []) x y = x := by + rw [emptyFlag_nil, selectHead, + if_pos (show ([true] : List Bool).head? = some true from rfl)] + +theorem length_take_le_arg (n : ℕ) (l : List Bool) : (l.take n).length ≤ n := by + rw [List.length_take]; omega + +theorem selectHead_emptyFlag_cons (b : Bool) (t x y : List Bool) : + selectHead (emptyFlag (b :: t)) x y = y := by + rw [selectHead, if_neg (by rw [emptyFlag_head_cons]; simp), + if_pos (emptyFlag_head_cons b t)] + +theorem selectHead_length_le (s x y : List Bool) : + (selectHead s x y).length ≤ max x.length y.length := by + rw [selectHead] + split + · exact le_max_left _ _ + · split + · exact le_max_right _ _ + · simp + +/-- The counter of the next iteration: one more mark of the reversed ruler. -/ +def nextCounter (w : List Bool) : List Bool := + (takeLen (pair (false :: fstBlock (fstBlock w)) + (fstBlock (fstBlock (sndBlock w))))).reverse + +/-- The value of the next iteration: the initial value on the first step, then +`F` of the current value until the counter saturates. -/ +def nextValue (F : List Bool → List Bool) (w : List Bool) : List Bool := + selectHead (emptyFlag (fstBlock (fstBlock w))) + (sndBlock (sndBlock w)) + (selectHead (nextCounter w) (sndBlock (fstBlock w)) + (takeLen (pair (sndBlock (fstBlock (sndBlock w))) (F (sndBlock (fstBlock w)))))) + +/-- One iteration of the loop, truncated to the machine's own input length. -/ +def iterStep (F : List Bool → List Bool) (w : List Bool) : List Bool := + pair (takeLen (pair (sndBlock w) (pair (nextCounter w) (nextValue F w)))) (sndBlock w) + +theorem sndBlock_iterStep (F : List Bool → List Bool) (w : List Bool) : + sndBlock (iterStep F w) = sndBlock w := by + rw [iterStep, sndBlock_pair] + +theorem iterStep_length_le (F : List Bool → List Bool) (w : List Bool) : + (iterStep F w).length ≤ 3 * (sndBlock w).length + 2 := by + rw [iterStep, pair_length, takeLen_pair] + have := length_take_le_arg (sndBlock w).length (pair (nextCounter w) (nextValue F w)) + omega + +/-- **The state length is globally bounded**: whatever the input, the state +after one or more iterations fits in `3|x| + 2`. -/ +theorem iterStep_iterate_length_le (F : List Bool → List Bool) (x : List Bool) : + ∀ i, ((iterStep F)^[i] (pair [] x)).length ≤ 3 * x.length + 2 := by + have hsnd : ∀ i, sndBlock ((iterStep F)^[i] (pair [] x)) = x := by + intro i + induction i with + | zero => exact sndBlock_pair [] x + | succ i ih => rw [Function.iterate_succ_apply', sndBlock_iterStep, ih] + intro i + cases i with + | zero => + rw [Function.iterate_zero_apply, pair_length] + simp + omega + | succ i => + rw [Function.iterate_succ_apply'] + have := iterStep_length_le F ((iterStep F)^[i] (pair [] x)) + rw [hsnd i] at this + exact this + +theorem emptyFlag_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : + (fun z => emptyFlag (f z)) ∈ FP := by + have hcst : (fun _ : List Bool => [true]) ∈ FP := by + simpa [Function.comp] using mem_FP_comp const_nil_mem_FP (cons_mem_FP true) + have h1 : (fun z => headFlag true (f z)) ∈ FP := by + simpa [Function.comp] using mem_FP_comp hf (headFlag_mem_FP true) + have h2 : (fun z => headFlag false (f z)) ∈ FP := by + simpa [Function.comp] using mem_FP_comp hf (headFlag_mem_FP false) + exact appendFn_mem_FP (appendFn_mem_FP h1 h2) hcst + +theorem nextCounter_mem_FP : nextCounter ∈ FP := by + have hf : fstBlock ∈ FP := fstBlock_mem_FP + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hc : (fun w => false :: fstBlock (fstBlock w)) ∈ FP := by + simpa [Function.comp] using + mem_FP_comp (mem_FP_comp hf hf) (cons_mem_FP false) + have hk : (fun w => fstBlock (fstBlock (sndBlock w))) ∈ FP := by + simpa [Function.comp] using mem_FP_comp hs (mem_FP_comp hf hf) + have := takeLenFn_mem_FP hc hk + have hrev : (fun w => ((fstBlock (fstBlock (sndBlock w))).take + (false :: fstBlock (fstBlock w)).length).reverse) ∈ FP := by + simpa [Function.comp] using mem_FP_comp this reverse_mem_FP + have heq : (fun w => ((fstBlock (fstBlock (sndBlock w))).take + (false :: fstBlock (fstBlock w)).length).reverse) = nextCounter := by + funext w + rw [nextCounter, takeLen_pair] + rwa [heq] at hrev + +theorem nextValue_mem_FP {F : List Bool → List Bool} (hF : F ∈ FP) : + nextValue F ∈ FP := by + have hf : fstBlock ∈ FP := fstBlock_mem_FP + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hC : (fun w => fstBlock (fstBlock w)) ∈ FP := mem_FP_comp hf hf + have hv : (fun w => sndBlock (fstBlock w)) ∈ FP := mem_FP_comp hf hs + have hv0 : (fun w => sndBlock (sndBlock w)) ∈ FP := mem_FP_comp hs hs + have hW : (fun w => sndBlock (fstBlock (sndBlock w))) ∈ FP := + mem_FP_comp hs (mem_FP_comp hf hs) + have hFv : (fun w => F (sndBlock (fstBlock w))) ∈ FP := mem_FP_comp hv hF + have hclamp : (fun w => takeLen (pair (sndBlock (fstBlock (sndBlock w))) + (F (sndBlock (fstBlock w))))) ∈ FP := by + have := takeLenFn_mem_FP hW hFv + simpa [takeLen_pair] using this + exact selectHeadFn_mem_FP (emptyFlag_mem_FP hC) hv0 + (selectHeadFn_mem_FP nextCounter_mem_FP hv hclamp) + +theorem iterStep_mem_FP {F : List Bool → List Bool} (hF : F ∈ FP) : + iterStep F ∈ FP := by + have hs : sndBlock ∈ FP := sndBlock_mem_FP + have hpair : (fun w => pair (nextCounter w) (nextValue F w)) ∈ FP := + pairFn_mem_FP nextCounter_mem_FP (nextValue_mem_FP hF) + have hclamp : (fun w => takeLen (pair (sndBlock w) + (pair (nextCounter w) (nextValue F w)))) ∈ FP := by + have := takeLenFn_mem_FP hs hpair + simpa [takeLen_pair] using this + exact pairFn_mem_FP hclamp hs + +/-- The value the loop carries after `i` iterations, from the second on. -/ +def iterVal (F : List Bool → List Bool) (Krev W v₀ : List Bool) : ℕ → List Bool + | 0 => v₀ + | i + 1 => selectHead ((Krev.take (i + 2)).reverse) (iterVal F Krev W v₀ i) + ((F (iterVal F Krev W v₀ i)).take W.length) + +theorem iterVal_length_le (F : List Bool → List Bool) (Krev W v₀ : List Bool) : + ∀ i, (iterVal F Krev W v₀ i).length ≤ max v₀.length W.length := by + intro i + induction i with + | zero => exact le_max_left _ _ + | succ i ih => + refine le_trans (selectHead_length_le _ _ _) ?_ + have := length_take_le_arg W.length (F (iterVal F Krev W v₀ i)) + omega + +theorem take_succ_min (l : List Bool) (i : ℕ) : + l.take (min i l.length + 1) = l.take (i + 1) := by + rcases Nat.lt_or_ge l.length i with h | h + · rw [min_eq_right (by omega), List.take_of_length_le (by omega), + List.take_of_length_le (by omega)] + · rw [min_eq_left h] + +/-- **The loop's trajectory.** With the counter growing one mark per iteration +and the state always fitting in the input, the `i+1`-st state is exactly the +counter `(Krev.take (i+1)).reverse` beside the value `iterVal … i`. -/ +theorem iterStep_iterate (F : List Bool → List Bool) (Krev W v₀ : List Bool) + (hK : Krev ≠ []) + (hfit : ∀ i, (pair ((Krev.take (i + 1)).reverse) (iterVal F Krev W v₀ i)).length + ≤ (pair (pair Krev W) v₀).length) : + ∀ i, (iterStep F)^[i + 1] (pair [] (pair (pair Krev W) v₀)) + = pair (pair ((Krev.take (i + 1)).reverse) (iterVal F Krev W v₀ i)) + (pair (pair Krev W) v₀) := by + intro i + induction i with + | zero => + rw [Function.iterate_succ_apply', Function.iterate_zero_apply, iterStep, sndBlock_pair] + rw [show nextCounter (pair [] (pair (pair Krev W) v₀)) = (Krev.take 1).reverse from by + rw [nextCounter, fstBlock_pair, sndBlock_pair, fstBlock_pair, fstBlock_pair, + takeLen_pair] + simp [fstBlock]] + rw [show nextValue F (pair [] (pair (pair Krev W) v₀)) = v₀ from by + rw [nextValue, fstBlock_pair, show fstBlock ([] : List Bool) = [] from rfl, + selectHead_emptyFlag_nil, sndBlock_pair, sndBlock_pair]] + rw [takeLen_pair] + show pair ((pair ((Krev.take (0 + 1)).reverse) (iterVal F Krev W v₀ 0)).take + (pair (pair Krev W) v₀).length) (pair (pair Krev W) v₀) = _ + rw [List.take_of_length_le (hfit 0)] + | succ i ih => + rw [Function.iterate_succ_apply', ih, iterStep, sndBlock_pair] + have hlen : ((Krev.take (i + 1)).reverse).length = min (i + 1) Krev.length := by + simp + have hC : nextCounter (pair (pair ((Krev.take (i + 1)).reverse) + (iterVal F Krev W v₀ i)) (pair (pair Krev W) v₀)) + = (Krev.take (i + 2)).reverse := by + rw [nextCounter, fstBlock_pair, sndBlock_pair, fstBlock_pair, fstBlock_pair, + fstBlock_pair, takeLen_pair, List.length_cons, hlen, take_succ_min] + have hne : (Krev.take (i + 1)).reverse ≠ [] := by + intro hc + have : Krev.length = 0 := by + have h0 : ((Krev.take (i + 1)).reverse).length = 0 := by rw [hc]; rfl + rw [hlen] at h0 + omega + exact hK (List.eq_nil_of_length_eq_zero this) + obtain ⟨b, t, hbt⟩ := List.exists_cons_of_ne_nil hne + have hV : nextValue F (pair (pair ((Krev.take (i + 1)).reverse) + (iterVal F Krev W v₀ i)) (pair (pair Krev W) v₀)) + = iterVal F Krev W v₀ (i + 1) := by + rw [nextValue, fstBlock_pair, fstBlock_pair, sndBlock_pair, sndBlock_pair, + fstBlock_pair, sndBlock_pair, hbt, selectHead_emptyFlag_cons, ← hbt, hC, + takeLen_pair, sndBlock_pair, iterVal] + rw [hC, hV, takeLen_pair, List.take_of_length_le (hfit (i + 1))] + +theorem counter_take_le (a j : ℕ) (h : j ≤ a) : + (List.replicate a false ++ [true]).take j = List.replicate j false := by + rw [List.take_append_of_le_length (by simpa using h), List.take_replicate, min_eq_left h] + +theorem counter_head_false (a j : ℕ) (h1 : 1 ≤ j) (h2 : j ≤ a) : + (((List.replicate a false ++ [true]).take j).reverse).head? = some false := by + rw [counter_take_le a j h2, List.reverse_replicate] + cases j with + | zero => omega + | succ j => rfl + +theorem counter_head_true (a j : ℕ) (h : a + 1 ≤ j) : + (((List.replicate a false ++ [true]).take j).reverse).head? = some true := by + rw [List.take_of_length_le (by simp; omega), List.reverse_append, List.reverse_replicate] + rfl + +/-- **The value sequence is the iterate.** While the counter has marks left the +step applies `F`; once it saturates the value stops changing. The clamp is a +no-op because every intermediate value fits in `W`. -/ +theorem iterVal_eq_iterate (F : List Bool → List Bool) (W v₀ : List Bool) (M : ℕ) + (hclamp : ∀ j, j ≤ M → (F^[j] v₀).length ≤ W.length) : + ∀ i, iterVal F (List.replicate (M + 1) false ++ [true]) W v₀ i = F^[min i M] v₀ := by + intro i + induction i with + | zero => simp [iterVal] + | succ i ih => + rw [iterVal, ih] + by_cases h : i + 2 ≤ M + 1 + · have hhead := counter_head_false (M + 1) (i + 2) (by omega) h + rw [selectHead, if_neg (by rw [hhead]; simp), if_pos hhead, + show min i M = i from by omega, ← Function.iterate_succ_apply' F i v₀, + List.take_of_length_le (hclamp (i + 1) (by omega)), + show min (i + 1) M = i + 1 from by omega] + · have hhead := counter_head_true (M + 1) (i + 2) (by omega) + rw [selectHead, if_pos hhead, show min i M = M from by omega, + show min (i + 1) M = M from by omega] + +/-- **`FP` is closed under bounded iteration** — the one machine-level fact the +soundness direction needs. + +*Construction.* The machine is assembled in +`Complexitylib.Classes.P.Cobham.Internal.Iterate` out of the phase contracts of +`Complexitylib.Classes.P.Cobham.Internal.IterateLayout`; `iterate_input_mem_FP` is its +interface. Three details are worth recording, because three earlier plans died +on them. + +*Why resetting scratch is the crux.* `F`'s machine `M` comes from an +existential (`F ∈ FP`), so nothing is known about the shape it leaves its +scratch tapes in. Re-running it needs those tapes genuinely blank, but a +content-driven eraser (`TM.blankWorkTM` scans right to the *first* blank) +under-wipes whenever `M` left a gap — an isolated blank cell with more content +beyond it. `TM.wipeStepTM` therefore writes blank *unconditionally*, and +`Complexity.resetTapesTM` drives it a fixed number of times off a fuel register +that is unrelated to the wiped tapes' content. `TM.reachesIn_work_cells_far` +supplies the bound that makes the fixed count sufficient: a `t`-step run cannot +have touched anything past `head + t`. `Complexity.iterTail` is the resulting +five-phase cleanup, shared by the loop body and the setup; its first two phases +are not bookkeeping either, since `δ_right_of_start` only forces a head +*reading* `▷` to move right, so an arbitrary witness machine may legitimately +*halt* with a head at cell `0`. + +*Why the state carries the machine's own input.* `TM.ComputesInTime` quantifies +over *all* inputs, so the loop's contract has to survive malformed ones: the +state is `pair (pair C v) x` with the machine's input `x` kept verbatim, and +every new state is truncated to `|x|` (`iterStep`). That makes +`iterStep_iterate_length_le` — a state-length bound holding for every input, +not just the well-formed ones — available for free, and keeps the ruler and the +width readable at every step. On the intended trajectory the truncation is a +no-op (`iterStep_iterate`). + +*How the counter avoids a second fuel value.* The loop runs `|x| + 1` times, one +per bit of the machine's own input (`TM.inputLenRegTM`), which is more +iterations than needed; the surplus is absorbed by a counter that grows one mark +of `Krev = 0^(m+1) 1` per step, whose leading bit turns `true` exactly when the +`m` real applications are done (`counter_head_false`, `counter_head_true`). So +`iterVal` is `F` iterated `min i m` times, and over-iteration is harmless +(`iterVal_eq_iterate`). The wipe width is a *different* register, `p.eval |x|`, +computed by `TM.polyEvalTM` — the state is longer than the input, so `|x|` +alone cannot pay for the reset. + +*Time.* Each iteration costs `iterStep`'s own polynomial bound at width +`(width z).length` — which is why `hbound` is a hypothesis — plus the linear +copies and the wipe, and there are `|x| + 1` of them, so the total is polynomial +(`polyBnd_iterBound`). -/ +theorem iterate_mem_FP {F init ruler width : List Bool → List Bool} + (hF : F ∈ FP) (hinit : init ∈ FP) (hruler : ruler ∈ FP) (hwidth : width ∈ FP) + (hbound : ∀ z, ∀ n ≤ (ruler z).length, + (F^[n] (init z)).length ≤ (width z).length) : + (fun z => F^[(ruler z).length] (init z)) ∈ FP := by + set Krev : List Bool → List Bool := + fun z => List.replicate ((ruler z).length + 1) false ++ [true] with hKrev + have hKrevLen : ∀ z, (Krev z).length = (ruler z).length + 2 := by + intro z; rw [hKrev]; simp + have hKrevNe : ∀ z, Krev z ≠ [] := by + intro z h + have := hKrevLen z + rw [h] at this + simp at this + -- the machine's input + set X : List Bool → List Bool := + fun z => pair (pair (Krev z) (width z)) (init z) with hX + have hXlen : ∀ z, (X z).length + = 4 * (Krev z).length + 2 * (width z).length + (init z).length + 6 := by + intro z; rw [hX]; simp only [pair_length]; omega + -- the iterated step is `FP`, and its state length is globally bounded + have hstep : iterStep F ∈ FP := iterStep_mem_FP hF + have hr : ∀ (x : List Bool), ∀ i ≤ x.length, + ((iterStep F)^[i] (pair [] x)).length + ≤ (3 * Polynomial.X + Polynomial.C 2 : Polynomial ℕ).eval x.length := by + intro x i _ + have := iterStep_iterate_length_le F x i + simpa using this + have hΛ := iterate_input_mem_FP hstep (3 * Polynomial.X + Polynomial.C 2) hr + -- the wrapper is `FP`, so the composite is + have hXFP : X ∈ FP := by + have hone : (fun _ : List Bool => [false]) ∈ FP := by + simpa [Function.comp] using mem_FP_comp const_nil_mem_FP (cons_mem_FP false) + have htrue : (fun _ : List Bool => [true]) ∈ FP := by + simpa [Function.comp] using mem_FP_comp const_nil_mem_FP (cons_mem_FP true) + have hrl : (fun z => ruler z ++ [false]) ∈ FP := appendFn_mem_FP hruler hone + have hrep : (fun z => List.replicate ((ruler z).length + 1) false) ∈ FP := by + have := mulLenFn_mem_FP hrl hone + simpa using this + exact pairFn_mem_FP (pairFn_mem_FP (appendFn_mem_FP hrep htrue) hwidth) hinit + have hXeq : ∀ z, X z = pair (pair (Krev z) (width z)) (init z) := fun z => by rw [hX] + have heq : (fun z => F^[(ruler z).length] (init z)) + = sndBlock ∘ (fstBlock ∘ ((fun x => (iterStep F)^[x.length + 1] (pair [] x)) ∘ X)) := by + funext z + simp only [Function.comp_apply] + have hfit : ∀ i, (pair (((Krev z).take (i + 1)).reverse) + (iterVal F (Krev z) (width z) (init z) i)).length ≤ (X z).length := by + intro i + have h1 : (((Krev z).take (i + 1)).reverse).length ≤ (Krev z).length := by simp + have h2 := iterVal_length_le F (Krev z) (width z) (init z) i + rw [pair_length, hXlen z] + omega + have hval : ∀ i, iterVal F (Krev z) (width z) (init z) i + = F^[min i (ruler z).length] (init z) := by + have hclamp : ∀ j, j ≤ (ruler z).length → (F^[j] (init z)).length ≤ (width z).length := + fun j hj => hbound z j hj + intro i + exact iterVal_eq_iterate F (width z) (init z) (ruler z).length hclamp i + have hiter := iterStep_iterate F (Krev z) (width z) (init z) (hKrevNe z) hfit (X z).length + have hlarge : (ruler z).length ≤ (X z).length := by + have := hKrevLen z + rw [hXlen z]; omega + rw [hXeq z, hiter, fstBlock_pair, sndBlock_pair, hval, min_eq_right hlarge] + rw [heq] + exact mem_FP_comp (mem_FP_comp (mem_FP_comp hXFP hΛ) fstBlock_mem_FP) sndBlock_mem_FP + +/-- **The loop of the `boundedRec` case.** `recFoldClamp` is `loopStep` iterated +once per bit of `sndBlock z` (`loopStep_iterate`), started from the packed state +`pair (pair R (pair W s)) (pair [] (e.take |R|))` — with `R` an *exact* ruler for +the clamp (`exists_exact_ruler`) — and read off with two `sndBlock`s. -/ +theorem recFoldClamp_mem_FP {A B E : List Bool → List Bool} + (hA : A ∈ FP) (hB : B ∈ FP) (hE : E ∈ FP) (p : Polynomial ℕ) : + (fun z => recFoldClamp A B (p.eval z.length) (E z) (fstBlock z) (sndBlock z)) + ∈ FP := by + obtain ⟨R, hR, hRlen⟩ := exists_exact_ruler p + have hfst : fstBlock ∈ FP := fstBlock_mem_FP + have hsnd : sndBlock ∈ FP := sndBlock_mem_FP + have hP : (fun z => pair (R z) (pair (fstBlock z) (sndBlock z))) ∈ FP := + pairFn_mem_FP hR (pairFn_mem_FP hfst hsnd) + have hinit : (fun z => pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length))) ∈ FP := + pairFn_mem_FP hP (pairFn_mem_FP const_nil_mem_FP (takeLenFn_mem_FP hR hE)) + have hwidth : (fun z => pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair (sndBlock z) (R z))) ∈ FP := pairFn_mem_FP hP (pairFn_mem_FP hsnd hR) + have hbound : ∀ z, ∀ n ≤ (sndBlock z).length, + ((loopStep A B)^[n] (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length)))).length + ≤ (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair (sndBlock z) (R z))).length := by + intro z n hn + rw [loopStep_iterate (A := A) (B := B) (R z) (fstBlock z) (sndBlock z) (E z) n hn] + have h1 : ((sndBlock z).drop ((sndBlock z).length - n)).length + ≤ (sndBlock z).length := by simp + have h2 : (recFoldClamp A B (R z).length (E z) (fstBlock z) + ((sndBlock z).drop ((sndBlock z).length - n))).length ≤ (R z).length := + recFoldClamp_length_le _ _ _ _ _ _ + simp only [pair_length] + omega + have hiter := iterate_mem_FP (loopStep_mem_FP hA hB) hinit hsnd hwidth hbound + have hout := mem_FP_comp hiter (mem_FP_comp hsnd hsnd) + have heq : ((sndBlock ∘ sndBlock) ∘ fun z => + (loopStep A B)^[(sndBlock z).length] + (pair (pair (R z) (pair (fstBlock z) (sndBlock z))) + (pair [] ((E z).take (R z).length)))) + = fun z => recFoldClamp A B (p.eval z.length) (E z) (fstBlock z) (sndBlock z) := by + funext z + rw [Function.comp, Function.comp, + loopStep_iterate (A := A) (B := B) (R z) (fstBlock z) (sndBlock z) (E z) + (sndBlock z).length le_rfl] + simp [hRlen z] + rwa [heq] at hout + +/-- Truncation is a no-op as soon as every intermediate value already fits. -/ +theorem recFoldClamp_eq_recFold {A B : List Bool → List Bool} {bound : ℕ} + {e W : List Bool} (s : List Bool) + (hle : ∀ t : List Bool, t.length ≤ s.length → + (recFold A B e W t).length ≤ bound) : + recFoldClamp A B bound e W s = recFold A B e W s := by + induction s with + | nil => + show e.take bound = e + exact List.take_of_length_le (hle [] (by simp)) + | cons b t ih => + have htail : recFoldClamp A B bound e W t = recFold A B e W t := + ih fun u hu => hle u (by simp only [List.length_cons]; omega) + show ((bif b then B else A) + (pair (pair W (recFoldClamp A B bound e W t)) t)).take bound = _ + rw [htail] + exact List.take_of_length_le (hle (b :: t) le_rfl) + +/-- On encoded arguments the loop computes recursion on notation: `recFold` over +the `FP` witnesses of `g`, `h₀`, `h₁` reproduces `recNotation`. -/ +theorem recFold_eq_recNotation {n : ℕ} {g : (Fin n → List Bool) → List Bool} + {h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool} + {G H₀ H₁ : List Bool → List Bool} + (hG : ∀ u : Fin n → List Bool, G (encodeVec u) = g u) + (hH₀ : ∀ u : Fin (n + 2) → List Bool, H₀ (encodeVec u) = h₀ u) + (hH₁ : ∀ u : Fin (n + 2) → List Bool, H₁ (encodeVec u) = h₁ u) + (w : Fin n → List Bool) (s : List Bool) : + recFold H₀ H₁ (G (encodeVec w)) (encodeVec w) s = recNotation g h₀ h₁ s w := by + -- The encoded step argument is exactly the vector `Fin.cons t (Fin.cons a w)`. + have henc : ∀ (t a : List Bool), + pair (pair (encodeVec w) a) t = encodeVec (Fin.cons t (Fin.cons a w)) := by + intro t a + rw [encodeVec_succ, encodeVec_succ] + simp [Fin.tail_cons] + induction s with + | nil => exact hG w + | cons b t ih => + show (bif b then H₁ else H₀) + (pair (pair (encodeVec w) (recFold H₀ H₁ (G (encodeVec w)) (encodeVec w) t)) t) + = _ + rw [ih, henc, recNotation_cons] + cases b + · simp only [cond_false]; exact hH₀ _ + · simp only [cond_true]; exact hH₁ _ + +/-- Every `FP` function has polynomially bounded output length: a time bound is +also an output-length bound (`TM.ComputesInTime.output_length_le`). -/ +theorem output_length_poly_of_mem_FP {f : List Bool → List Bool} (hf : f ∈ FP) : + ∃ p : Polynomial ℕ, ∀ x, (f x).length ≤ p.eval x.length := by + obtain ⟨k, tm, p, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hf + exact ⟨p, fun x => hcomp.output_length_le x⟩ + +/-- `boundedRec` case: `FPn` is closed under limited recursion on notation. + +By `recFold_eq_recNotation` the value is the encoded-argument loop `recFold` run +over the bits of `v 0`. Cobham's limited-recursion side condition `hbound` caps +every intermediate accumulator by `|j (…)|`, which is polynomial in `|encodeVec v|` +(`output_length_poly_of_mem_FP`), so the clamped loop `recFoldClamp` — which a +machine can run in polynomial time (`recFoldClamp_mem_FP`) — never truncates and +therefore agrees with `recFold`. -/ +theorem fpn_boundedRec {n : ℕ} {g : (Fin n → List Bool) → List Bool} + {h₀ h₁ : (Fin (n + 2) → List Bool) → List Bool} + {j : (Fin (n + 1) → List Bool) → List Bool} + (ihg : FPn g) (ih0 : FPn h₀) (ih1 : FPn h₁) (ihj : FPn j) + (hbound : ∀ x v, (recNotation g h₀ h₁ x v).length ≤ (j (Fin.cons x v)).length) : + FPn (fun v : Fin (n + 1) → List Bool => + recNotation g h₀ h₁ (v 0) (Fin.tail v)) := by + obtain ⟨G, hGFP, hG⟩ := ihg + obtain ⟨H₀, hH0FP, hH0⟩ := ih0 + obtain ⟨H₁, hH1FP, hH1⟩ := ih1 + obtain ⟨J, hJFP, hJ⟩ := ihj + obtain ⟨p, hp⟩ := output_length_poly_of_mem_FP hJFP + have hE : (fun z => G (fstBlock z)) ∈ FP := mem_FP_comp fstBlock_mem_FP hGFP + refine ⟨fun z => recFoldClamp H₀ H₁ (p.eval z.length) (G (fstBlock z)) (fstBlock z) + (sndBlock z), recFoldClamp_mem_FP hH0FP hH1FP hE p, fun v => ?_⟩ + show recFoldClamp H₀ H₁ (p.eval (encodeVec v).length) (G (fstBlock (encodeVec v))) + (fstBlock (encodeVec v)) (sndBlock (encodeVec v)) + = recNotation g h₀ h₁ (v 0) (Fin.tail v) + rw [fstBlock_encodeVec_succ, sndBlock_encodeVec_succ] + rw [recFoldClamp_eq_recFold (v 0) ?_] + · exact recFold_eq_recNotation hG hH0 hH1 (Fin.tail v) (v 0) + · -- Cobham's limited-recursion bound caps every intermediate accumulator. + intro t ht + rw [recFold_eq_recNotation hG hH0 hH1 (Fin.tail v) t] + refine le_trans (hbound t (Fin.tail v)) ?_ + have hJt : (j (Fin.cons t (Fin.tail v))).length + ≤ p.eval (encodeVec (Fin.cons t (Fin.tail v))).length := by + rw [← hJ (Fin.cons t (Fin.tail v))] + exact hp _ + refine le_trans hJt (polynomial_eval_mono_nat p ?_) + have e1 : (encodeVec (Fin.cons t (Fin.tail v))).length + = 2 * (encodeVec (Fin.tail v)).length + 2 + t.length := by + simp [encodeVec_succ, Fin.tail_cons] + have e2 : (encodeVec v).length + = 2 * (encodeVec (Fin.tail v)).length + 2 + (v 0).length := by + simp [encodeVec_succ] + omega + +/-- **Soundness induction.** Every function of Cobham's algebra is polynomial +time on encoded argument vectors. -/ +theorem cobham_imp_FPn : ∀ {n : ℕ} {f : (Fin n → List Bool) → List Bool}, + Cobham f → FPn f := by + intro n f h + induction h with + | proj i => exact fpn_proj i + | empty => exact fpn_empty + | bit b => exact fpn_bit b + | smash => exact fpn_smash + | comp _ _ ihf ihgs => exact fpn_comp ihf ihgs + | boundedRec _ _ _ _ hbound ihg ih0 ih1 ihj => + exact fpn_boundedRec ihg ih0 ih1 ihj hbound + +/-- Arity-one specialization: from the multi-arity soundness induction, the +unary fragment `CobhamFP` lands in `FP`. -/ +theorem CobhamFP_subset_FP_of_FPn : CobhamFP ⊆ FP := by + intro f hf + obtain ⟨g, hg, hgf⟩ := cobham_imp_FPn hf + -- `hgf` specialized to `![x]`: `g (pair [] x) = f x`. + have hval : ∀ x : List Bool, g (pair [] x) = f x := by + intro x + have := hgf ![x] + rwa [encodeVec_one] at this + -- Hence `f = g ∘ (x ↦ pair [] x)`, a composition of `FP` functions. + have hfeq : f = g ∘ fun x : List Bool => pair [] x := by + funext x; simp [Function.comp, hval x] + rw [hfeq] + exact mem_FP_comp pairLeftNil_mem_FP hg + +/-! ## Completeness: `FP ⊆ CobhamFP` -/ + +/-- **Completeness direction.** Every polynomial-time function belongs to +Cobham's algebra. + +*Construction:* a polynomial-time Turing machine is simulated inside the algebra. +1. A whole configuration — state, input tape, work tapes, output tape and every + head position — is one bitstring of equal-width blocks, each tape split at its + head so that a head move is a two-bit shift (`Cobham.cfgCode`). +2. The one-step transition is a finite case split on (state, symbols read), which + is `Cobham.tableFn` against the finitely many constant key patterns, with each + branch built from `takeFn`/`dropFn`/`appendFn`/`padFn` (`Cobham.stepFn`). At + the halting state the branch is the identity, so the encoding is a fixed point + once the machine stops. +3. The step is iterated once per bit of a clock string built from `smash` + (`Cobham.exists_pow_clock`), long enough by the polynomial normal form + `mem_FP_iff_computesInTime_polynomial`. +4. A second iteration walks the output head back to cell `0` + (`Cobham.rewindFn`), after which that tape's right half-block is the whole + tape in order, and the output is read off it by two `Complexity.cellBits` + recursions and one `Complexity.runTrue` (`Cobham.simFn`). +The length bounds throughout are polynomial, so every `boundedRec` side condition +is met. -/ +theorem FP_subset_CobhamFP_internal : FP ⊆ CobhamFP := by + intro f hf + obtain ⟨k, tm, p, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hf + exact computes_mem_CobhamFP tm + (S := ∑ i ∈ Finset.range (p.natDegree + 1), p.coeff i) (D := p.natDegree) + (poly_eval_le_pow p) hcomp diff --git a/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean b/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean new file mode 100644 index 00000000..c5414a59 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Algebra.lean @@ -0,0 +1,543 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.Blocks +public import Complexitylib.Classes.P.Cobham.Defs +public import Complexitylib.Encoding.Pairing +public import Mathlib.Data.Fin.VecNotation +public import Mathlib.Data.Fintype.Basic +public import Mathlib.Tactic.FinCases +public import Mathlib.Tactic.Ring + +/-! +# Cobham's algebra — the working toolkit + +Derived members of `Complexity.Cobham`: the operations a Turing-machine +interpreter written inside the algebra needs. Each is a single limited recursion +on notation, or a finite composition of such. + +Two of these carry the weight. `dispatch` shows that branching is free: the step +functions of `recNotation` are already selected by the bit being peeled, so a +one-step recursion on `v 0` *is* an if-then-else on its leading bit. +`dropPrefix` shows how to move an argument that changes along a recursion — +`recNotation` fixes its parameters, so the changing value has to live in the +recursion's *value*, and iterating `tail` there gives `drop`. With `drop` in +hand, `takePrefix` reads off successive bits, and fixed-width pairing with +projections follows. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The class respects pointwise equality of functions. Useful because the constructors +of `Cobham` produce syntactically specific lambda terms. -/ +theorem of_eq {n : ℕ} {f g : (Fin n → List Bool) → List Bool} (hf : Cobham f) + (h : ∀ v, f v = g v) : Cobham g := + (funext h : f = g) ▸ hf + +/-- Every constant function is in the class: build the constant string bit by bit from +`empty` and the successors. -/ +theorem const {n : ℕ} (s : List Bool) : Cobham fun _ : Fin n → List Bool => s := by + induction s with + | nil => exact .empty + | cons b s ih => exact (Cobham.comp (.bit b) fun _ : Fin 1 => ih).of_eq fun v => rfl + +/-- Composition with two inner functions, packaged for readability: the +constructor's `Fin`-indexed family is awkward to supply when the two components +differ. -/ +theorem comp₂ {n : ℕ} {f : (Fin 2 → List Bool) → List Bool} + {g₀ g₁ : (Fin n → List Bool) → List Bool} + (hf : Cobham f) (h₀ : Cobham g₀) (h₁ : Cobham g₁) : + Cobham fun v : Fin n → List Bool => f ![g₀ v, g₁ v] := by + refine (Cobham.comp hf (gs := ![g₀, g₁]) ?_).of_eq fun v => ?_ + · intro i; fin_cases i <;> assumption + · congr 1 + funext i + fin_cases i <;> rfl + +/-- Composition with three inner functions. -/ +theorem comp₃ {n : ℕ} {f : (Fin 3 → List Bool) → List Bool} + {g₀ g₁ g₂ : (Fin n → List Bool) → List Bool} + (hf : Cobham f) (h₀ : Cobham g₀) (h₁ : Cobham g₁) (h₂ : Cobham g₂) : + Cobham fun v : Fin n → List Bool => f ![g₀ v, g₁ v, g₂ v] := by + refine (Cobham.comp hf (gs := ![g₀, g₁, g₂]) ?_).of_eq fun v => ?_ + · intro i; fin_cases i <;> assumption + · congr 1 + funext i + fin_cases i <;> rfl + +/-- Concatenation is in the class, by limited recursion on notation on the first +argument with bound `smash (true :: x) (true :: y)`. -/ +theorem append : Cobham fun v : Fin 2 → List Bool => v 0 ++ v 1 := by + -- Recursion on notation computing `x ++ y`: base `y`, step `b :: ·` on the + -- recursive value. + have hrec : ∀ (x : List Bool) (v : Fin 1 → List Bool), + recNotation (fun v : Fin 1 → List Bool => v 0) + (fun w : Fin 3 → List Bool => false :: w 1) + (fun w : Fin 3 → List Bool => true :: w 1) x v = x ++ v 0 := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [ih] + -- The bit-prepending step functions are in the class. + have hstep : ∀ b : Bool, Cobham fun w : Fin 3 → List Bool => b :: w 1 := fun b => + (Cobham.comp (.bit b) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl + -- The length bound `smash (true :: x) (true :: y)` is in the class. + have hj : Cobham fun w : Fin 2 → List Bool => + Complexity.smash (true :: w 0) (true :: w 1) := + (Cobham.comp .smash fun i : Fin 2 => + (Cobham.comp (.bit true) fun _ : Fin 1 => .proj i).of_eq fun v => rfl).of_eq + fun v => rfl + refine (Cobham.boundedRec (.proj 0) (hstep false) (hstep true) hj ?_).of_eq fun v => ?_ + · intro x v + rw [hrec] + have h1 : (Fin.cons x v : Fin 2 → List Bool) 1 = v 0 := rfl + have hexp : (x.length + 1) * ((v 0).length + 1) = + x.length * (v 0).length + x.length + (v 0).length + 1 := by ring + simp only [Fin.cons_zero, h1, smash_length, List.length_append, List.length_cons] + omega + · rw [hrec] + rfl + +/-- Concatenation of two members of the class is a member of the class. -/ +theorem appendFn {n : ℕ} {g₀ g₁ : (Fin n → List Bool) → List Bool} + (h₀ : Cobham g₀) (h₁ : Cobham g₁) : + Cobham fun v : Fin n → List Bool => g₀ v ++ g₁ v := + (comp₂ append h₀ h₁).of_eq fun v => by simp + +/-- The self-delimiting pairing `pair x y = delimit x ++ y` is in the class, by +limited recursion on notation on `x`: each peeled bit is doubled onto the +recursive value, and the base case emits the separator `01` followed by `y`. The +bound is exact — `|pair x y| = |x ++ x| + |y ++ [0,1]|`. -/ +theorem pairing : Cobham fun v : Fin 2 → List Bool => pair (v 0) (v 1) := by + have hrec : ∀ (x : List Bool) (v : Fin 1 → List Bool), + recNotation (fun u : Fin 1 → List Bool => false :: true :: u 0) + (fun w : Fin 3 → List Bool => false :: false :: w 1) + (fun w : Fin 3 → List Bool => true :: true :: w 1) x v + = pair x (v 0) := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [pair_cons_eq, ih] + have hg : Cobham fun u : Fin 1 → List Bool => false :: true :: u 0 := + (Cobham.comp (.bit false) fun _ : Fin 1 => + (Cobham.comp (.bit true) fun _ : Fin 1 => .proj 0).of_eq fun v => rfl).of_eq + fun v => rfl + have hstep : ∀ b : Bool, Cobham fun w : Fin 3 → List Bool => b :: b :: w 1 := fun b => + (Cobham.comp (.bit b) fun _ : Fin 1 => + (Cobham.comp (.bit b) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl).of_eq + fun v => rfl + have hj : Cobham fun w : Fin 2 → List Bool => + (w 0 ++ w 0) ++ (w 1 ++ [false, true]) := + appendFn (appendFn (.proj 0) (.proj 0)) + (appendFn (.proj 1) (Cobham.const [false, true])) + refine (Cobham.boundedRec hg (hstep false) (hstep true) hj ?_).of_eq fun v => ?_ + · intro x v + rw [hrec] + have h0 : (Fin.cons x v : Fin 2 → List Bool) 0 = x := rfl + have h1 : (Fin.cons x v : Fin 2 → List Bool) 1 = v 0 := rfl + simp only [h0, h1, pair_length, List.length_append, List.length_cons, + List.length_nil] + omega + · rw [hrec] + rfl + +/-- Dropping the leading bit is in the class, by limited recursion on notation: +on `b :: x` both step functions return the peeled tail `x`, and the argument +itself bounds the result. -/ +theorem tail : Cobham fun v : Fin 1 → List Bool => (v 0).tail := by + have hrec : ∀ (x : List Bool) (v : Fin 0 → List Bool), + recNotation (fun _ : Fin 0 → List Bool => ([] : List Bool)) + (fun w : Fin 2 → List Bool => w 0) (fun w : Fin 2 → List Bool => w 0) x v + = x.tail := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + refine (Cobham.boundedRec .empty (.proj 0) (.proj 0) (.proj 0) ?_).of_eq fun v => ?_ + · intro x v + rw [hrec, Fin.cons_zero] + cases x <;> simp + · rw [hrec] + +/-- **Bit dispatch is in the class.** `caseBit (v 0) (v 1) (v 2)` is a single +limited recursion on notation over `v 0`: the recursion's own bit-selected step +functions do the branching, projecting out `v 1` or `v 2`, and the concatenation +of the two branches bounds the result. -/ +theorem dispatch : Cobham fun v : Fin 3 → List Bool => + caseBit (v 0) (v 1) (v 2) := by + -- On `b :: x` the step argument is `⟨x, rec, v 1, v 2⟩`, so the branches are + -- projections 3 (bit `0`) and 2 (bit `1`). + have hrec : ∀ (x : List Bool) (v : Fin 2 → List Bool), + recNotation (fun _ : Fin 2 → List Bool => ([] : List Bool)) + (fun w : Fin 4 → List Bool => w 3) (fun w : Fin 4 → List Bool => w 2) x v + = caseBit x (v 0) (v 1) := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + -- The bound: the two branches concatenated. + have hj : Cobham fun w : Fin 3 → List Bool => w 1 ++ w 2 := + (Cobham.comp Cobham.append fun i : Fin 2 => Cobham.proj i.succ).of_eq fun v => rfl + refine (Cobham.boundedRec .empty (.proj 3) (.proj 2) hj ?_).of_eq fun v => ?_ + · intro x v + rw [hrec] + exact caseBit_length_le _ _ _ + · rw [hrec] + rfl + +/-- **Dropping a prefix of a given length is in the class.** `v 1` is advanced by +one `tail` per bit of the ruler `v 0`: the recursion applies `tail` to its own +recursive value, so the changing argument lives in the recursion's value rather +than in its parameters — which is what makes it expressible at all. -/ +theorem dropPrefix : + Cobham fun v : Fin 2 → List Bool => (v 1).drop (v 0).length := by + have hrec : ∀ (r : List Bool) (u : Fin 1 → List Bool), + recNotation (fun u : Fin 1 → List Bool => u 0) + (fun w : Fin 3 → List Bool => (w 1).tail) + (fun w : Fin 3 → List Bool => (w 1).tail) r u + = (u 0).drop r.length := by + intro r u + induction r with + | nil => rfl + | cons b r ih => cases b <;> simp [ih, List.tail_drop] + have hstep : Cobham fun w : Fin 3 → List Bool => (w 1).tail := + (Cobham.comp Cobham.tail fun _ : Fin 1 => Cobham.proj 1).of_eq fun v => rfl + refine (Cobham.boundedRec (.proj 0) hstep hstep (.proj 1) ?_).of_eq fun v => ?_ + · intro r u + rw [hrec, show (Fin.cons r u : Fin 2 → List Bool) 1 = u 0 from rfl] + simp + · rw [hrec] + rfl + +/-- One more bit of a prefix is the prefix plus the first bit of what remains. -/ +private theorem take_succ_eq (x : List Bool) (n : ℕ) : + x.take (n + 1) = x.take n ++ (x.drop n).take 1 := by + induction n generalizing x with + | zero => simp + | succ n ih => + cases x with + | nil => simp + | cons a x => simpa using ih x + +/-- **Taking a prefix of a given length is in the class.** Each bit of the ruler +`v 0` appends one more bit of `v 1`, read off by dispatching on the head of what +is still undropped — so `dropPrefix` and `dispatch` together give `take`. -/ +theorem takePrefix : + Cobham fun v : Fin 2 → List Bool => (v 1).take (v 0).length := by + have hbit : ∀ z : List Bool, caseBit z [true] [false] = z.take 1 := by + intro z; cases z with + | nil => rfl + | cons b z => cases b <;> rfl + have hrec : ∀ (r : List Bool) (u : Fin 1 → List Bool), + recNotation (fun _ : Fin 1 → List Bool => ([] : List Bool)) + (fun w : Fin 3 → List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false]) + (fun w : Fin 3 → List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false]) r u + = (u 0).take r.length := by + intro r u + induction r with + | nil => rfl + | cons b r ih => + cases b <;> + · show (recNotation _ _ _ r u) ++ caseBit _ _ _ = _ + rw [ih, hbit] + exact (take_succ_eq (u 0) r.length).symm + -- The step: append the next bit of `u 0`, located by dropping `|r|` bits. + have hdrop : Cobham fun w : Fin 3 → List Bool => (w 2).drop (w 0).length := + (comp₂ dropPrefix (.proj 0) (.proj 2)).of_eq fun v => by simp + have hbitFn : Cobham fun w : Fin 3 → List Bool => + caseBit ((w 2).drop (w 0).length) [true] [false] := + (comp₃ dispatch hdrop (Cobham.const [true]) (Cobham.const [false])).of_eq + fun v => by simp + have hstep : Cobham fun w : Fin 3 → List Bool => + w 1 ++ caseBit ((w 2).drop (w 0).length) [true] [false] := + appendFn (.proj 1) hbitFn + refine (Cobham.boundedRec .empty hstep hstep (.proj 1) ?_).of_eq fun v => ?_ + · intro r u + rw [hrec, show (Fin.cons r u : Fin 2 → List Bool) 1 = u 0 from rfl] + simp + · rw [hrec] + rfl + +/-- **Total bit dispatch is in the class.** Same recursion as `dispatch`, except +the base case returns the `false` branch instead of the empty string — so the +empty string reads as `false` and every flag is genuinely one bit. -/ +theorem dispatch₀ : Cobham fun v : Fin 3 → List Bool => + caseBit₀ (v 0) (v 1) (v 2) := by + have hrec : ∀ (x : List Bool) (v : Fin 2 → List Bool), + recNotation (fun u : Fin 2 → List Bool => u 1) + (fun w : Fin 4 → List Bool => w 3) (fun w : Fin 4 → List Bool => w 2) x v + = caseBit₀ x (v 0) (v 1) := by + intro x v + cases x with + | nil => rfl + | cons b x => cases b <;> rfl + have hj : Cobham fun w : Fin 3 → List Bool => w 1 ++ w 2 := + (Cobham.comp Cobham.append fun i : Fin 2 => Cobham.proj i.succ).of_eq fun v => rfl + refine (Cobham.boundedRec (.proj 1) (.proj 3) (.proj 2) hj ?_).of_eq fun v => ?_ + · intro x v + rw [hrec] + exact caseBit₀_length_le _ _ _ + · rw [hrec] + rfl + +/-- Applying `tail` to a member of the class. -/ +theorem tailFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => (g v).tail := + (Cobham.comp Cobham.tail fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- Total if-then-else on a flag is in the class. -/ +theorem iteFn {n : ℕ} {gc gx gy : (Fin n → List Bool) → List Bool} + (hc : Cobham gc) (hx : Cobham gx) (hy : Cobham gy) : + Cobham fun v : Fin n → List Bool => caseBit₀ (gc v) (gx v) (gy v) := + (comp₃ dispatch₀ hc hx hy).of_eq fun v => by simp + +/-- The flag connectives are in the class: each is one `dispatch₀`. -/ +theorem andFn {n : ℕ} {g₀ g₁ : (Fin n → List Bool) → List Bool} + (h₀ : Cobham g₀) (h₁ : Cobham g₁) : + Cobham fun v : Fin n → List Bool => andBit (g₀ v) (g₁ v) := + iteFn h₀ (iteFn h₁ (Cobham.const [true]) (Cobham.const [false])) + (Cobham.const [false]) + +/-- Disjunction of flags is in the class. -/ +theorem orFn {n : ℕ} {g₀ g₁ : (Fin n → List Bool) → List Bool} + (h₀ : Cobham g₀) (h₁ : Cobham g₁) : + Cobham fun v : Fin n → List Bool => orBit (g₀ v) (g₁ v) := + iteFn h₀ (Cobham.const [true]) + (iteFn h₁ (Cobham.const [true]) (Cobham.const [false])) + +/-- Negation of a flag is in the class. -/ +theorem notFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => notBit (g v) := + iteFn h (Cobham.const [false]) (Cobham.const [true]) + +/-- **Bit extraction is in the class**: drop to the marked position and dispatch +on what is left. -/ +theorem bitAtFn : Cobham fun v : Fin 2 → List Bool => bitAt (v 0) (v 1) := + (comp₃ dispatch₀ dropPrefix (Cobham.const [true]) (Cobham.const [false])).of_eq + fun v => by simp [bitAt] + +/-- Extracting the leading bit of a member of the class, as a flag. -/ +theorem headFlagFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => bitAt [] (g v) := + (comp₂ bitAtFn (Cobham.const []) h).of_eq fun v => by simp + +/-- **The nonemptiness flag is in the class.** This is the one consumer of the +*partial* dispatcher: both branches are `[true]`, so the flag is `[true]` exactly +when there is a bit to read and `[]` otherwise. -/ +theorem nonemptyFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => nonemptyFlag (g v) := + (comp₃ dispatch h (Cobham.const [true]) (Cobham.const [true])).of_eq + fun v => by simp [nonemptyFlag] + +/-- **Matching against a fixed constant is in the class.** For each constant the +test unfolds into finitely many bit comparisons joined by `andFn`, so this is a +finite composition — the meta-level induction is on the constant, not a +recursion inside the algebra. -/ +theorem matchPrefixFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) + (c : List Bool) : + Cobham fun v : Fin n → List Bool => matchPrefix c (g v) := by + induction c generalizing g with + | nil => exact (Cobham.const [true]).of_eq fun v => rfl + | cons b c ih => + have htail := ih (tailFn h) + have hhead : Cobham fun v : Fin n → List Bool => + bif b then bitAt [] (g v) else notBit (bitAt [] (g v)) := by + cases b + · exact (notFn (headFlagFn h)).of_eq fun v => rfl + · exact (headFlagFn h).of_eq fun v => rfl + exact (andFn (nonemptyFn h) (andFn hhead htail)).of_eq fun v => rfl + +/-- Taking a prefix of one member of the class at the width of another. -/ +theorem takeFn {n : ℕ} {gr gx : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n → List Bool => (gx v).take (gr v).length := + (comp₂ takePrefix hr hx).of_eq fun v => by simp + +/-- Dropping a prefix of one member of the class at the width of another. -/ +theorem dropFn {n : ℕ} {gr gx : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n → List Bool => (gx v).drop (gr v).length := + (comp₂ dropPrefix hr hx).of_eq fun v => by simp + +/-- A block of `|x|` zeros is in the class, by limited recursion on notation: +each peeled bit prepends one `0` to the recursive value, and the argument bounds +the result. -/ +theorem lengthPad : + Cobham fun v : Fin 1 → List Bool => List.replicate (v 0).length false := by + have hrec : ∀ (x : List Bool) (v : Fin 0 → List Bool), + recNotation (fun _ : Fin 0 → List Bool => ([] : List Bool)) + (fun w : Fin 2 → List Bool => false :: w 1) + (fun w : Fin 2 → List Bool => false :: w 1) x v + = List.replicate x.length false := by + intro x v + induction x with + | nil => rfl + | cons b x ih => cases b <;> simp [ih, List.replicate_succ] + have hstep : Cobham fun w : Fin 2 → List Bool => false :: w 1 := + (Cobham.comp (.bit false) fun _ : Fin 1 => .proj 1).of_eq fun v => rfl + refine (Cobham.boundedRec .empty hstep hstep (.proj 0) ?_).of_eq fun v => ?_ + · intro x v + rw [hrec, Fin.cons_zero] + simp + · rw [hrec] + +/-- A block of zeros as wide as a member of the class. -/ +theorem zeroBlockFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => List.replicate (g v).length false := + (Cobham.comp lengthPad fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- Concatenating `i` copies of a member of the class — a finite composition, so +the induction is at the meta level. -/ +theorem repeatFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + ∀ i : ℕ, Cobham fun v : Fin n → List Bool => (List.replicate i (g v)).flatten + | 0 => Cobham.empty.of_eq fun _ => rfl + | i + 1 => (appendFn h (repeatFn h i)).of_eq fun _ => by + simp [List.replicate_succ] + +/-- **Block addressing is in the class.** With every field of a configuration +padded to the ruler's width, field `i` is `takeFn` after dropping `i` rulers — +and `i` is a fixed natural number, so the drop is a finite concatenation. -/ +theorem blockFn {n : ℕ} {gr gx : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hx : Cobham gx) (i : ℕ) : + Cobham fun v : Fin n → List Bool => blockAt (gr v) (gx v) i := + (takeFn hr (dropFn (repeatFn hr i) hx)).of_eq fun v => by + rw [blockAt] + congr 2 + simp + +/-- **Fixed-width padding is in the class.** With every field of a simulated +configuration padded to one ruler's width, field `i` is recovered by dropping `i` +rulers and taking one — so no self-delimiting decoder is ever needed inside the +algebra. -/ +theorem padFn {n : ℕ} {gr gx : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hx : Cobham gx) : + Cobham fun v : Fin n → List Bool => padTo (gr v) (gx v) := + (takeFn hr (appendFn hx (zeroBlockFn hr))).of_eq fun _ => rfl + +/-- **Finite table dispatch is in the class.** Matching a member of the class +against each of finitely many constant patterns in turn, taking the first +branch that fires and a default otherwise, is a finite chain of `iteFn`s. + +This is exactly the shape of a Turing machine's transition function: the patterns +are the (state, symbols-read) combinations, of which there are finitely many for +a fixed machine, and the branches assemble the successor configuration. -/ +theorem tableFn {n : ℕ} {g d : (Fin n → List Bool) → List Bool} + (hg : Cobham g) (hd : Cobham d) + (table : List (List Bool × ((Fin n → List Bool) → List Bool))) + (hbranch : ∀ p ∈ table, Cobham p.2) : + Cobham fun v : Fin n → List Bool => + table.foldr (fun p acc => caseBit₀ (matchPrefix p.1 (g v)) (p.2 v) acc) + (d v) := by + induction table with + | nil => exact hd + | cons p t ih => + exact iteFn (matchPrefixFn hg p.1) (hbranch p (by simp)) + (ih fun q hq => hbranch q (by simp [hq])) + +/-- **A table of constant patterns is a case analysis.** If some entry's pattern +prefixes the key, and every entry whose pattern prefixes the key carries the same +value, then the fold returns that value — regardless of the order the entries +appear in. + +Phrasing it as "all matching entries agree" rather than "exactly one matches" +avoids having to prove the patterns pairwise distinct: for a transition table the +patterns *are* distinct, but agreement is the weaker and more convenient +obligation. -/ +theorem foldr_table_eq (g d val : List Bool) : + ∀ table : List (List Bool × List Bool), + (∃ p ∈ table, p.1 <+: g) → + (∀ q ∈ table, q.1 <+: g → q.2 = val) → + table.foldr (fun q acc => caseBit₀ (matchPrefix q.1 g) q.2 acc) d = val := by + intro table + induction table with + | nil => rintro ⟨p, hp, -⟩ -; simp at hp + | cons a rest ih => + rintro ⟨p, hp, hpre⟩ hall + rcases Decidable.em (a.1 <+: g) with hm | hm + · rw [List.foldr_cons, (matchPrefix_eq_true_iff a.1 g).mpr hm, caseBit₀_cons, + cond_true] + exact hall a (by simp) hm + · have hmf : matchPrefix a.1 g = [false] := by + rcases matchPrefix_flag a.1 g with h | h + · exact absurd ((matchPrefix_eq_true_iff a.1 g).mp h) hm + · exact h + rw [List.foldr_cons, hmf, caseBit₀_cons, cond_false] + refine ih ⟨p, ?_, hpre⟩ fun q hq => hall q (by simp [hq]) + rcases List.mem_cons.mp hp with rfl | hp' + · exact absurd hpre hm + · exact hp' + +/-! ### Clocked iteration + +The engine of the completeness direction: a machine is simulated by iterating its +one-step transition function a polynomial number of times, and both halves of +that — the iteration and the polynomial clock — are cheap inside the algebra. -/ + +/-- **Bounded iteration is in the class.** Iterating a step function once per bit +of a clock string is a single limited recursion on notation: the recursion +ignores *which* bit it peels and simply applies the step to its own recursive +value, so `h₀ = h₁ = f ∘ Fin.tail`. The clock's length is the iteration count, +which is why polynomial clocks (`exists_pow_clock`) give polynomially many +steps. -/ +theorem iterFn {n : ℕ} {e : (Fin n → List Bool) → List Bool} + {f j : (Fin (n + 1) → List Bool) → List Bool} + (he : Cobham e) (hf : Cobham f) (hj : Cobham j) + (hbound : ∀ (c : List Bool) (v : Fin n → List Bool), + ((fun s => f (Fin.cons s v))^[c.length] (e v)).length + ≤ (j (Fin.cons c v)).length) : + Cobham fun v : Fin (n + 1) → List Bool => + (fun s => f (Fin.cons s (Fin.tail v)))^[(v 0).length] (e (Fin.tail v)) := by + have hstep : Cobham fun w : Fin (n + 1 + 1) → List Bool => f (Fin.tail w) := + (Cobham.comp hf fun i : Fin (n + 1) => Cobham.proj i.succ).of_eq fun w => rfl + have hrec : ∀ (c : List Bool) (v : Fin n → List Bool), + recNotation e (fun w : Fin (n + 1 + 1) → List Bool => f (Fin.tail w)) + (fun w : Fin (n + 1 + 1) → List Bool => f (Fin.tail w)) c v + = (fun s => f (Fin.cons s v))^[c.length] (e v) := by + intro c v + induction c with + | nil => rfl + | cons b c ih => + rw [List.length_cons, Function.iterate_succ_apply', ← ih] + cases b <;> simp [Fin.tail_cons] + refine (Cobham.boundedRec he hstep hstep hj ?_).of_eq fun v => ?_ + · intro c v + rw [hrec] + exact hbound c v + · rw [hrec] + +/-- **Clocks.** For every constant `c` and exponent `d` there is a member of the +class whose value on `v` is at least `c · (|v 0| + 1) ^ d` bits long — built from +constants and `smash`, which is exactly what `smash` is for. -/ +theorem exists_pow_clock (c d : ℕ) : + ∃ f : (Fin 1 → List Bool) → List Bool, Cobham f ∧ + ∀ v : Fin 1 → List Bool, c * ((v 0).length + 1) ^ d ≤ (f v).length := by + induction d with + | zero => + exact ⟨fun _ => List.replicate c false, Cobham.const _, fun v => by simp⟩ + | succ d ih => + obtain ⟨f, hf, hlen⟩ := ih + have hsucc : Cobham fun v : Fin 1 → List Bool => false :: v 0 := + (Cobham.comp (.bit false) fun _ : Fin 1 => .proj 0).of_eq fun v => rfl + refine ⟨fun v => Complexity.smash (f v) (false :: v 0), + (comp₂ Cobham.smash hf hsucc).of_eq fun v => by simp, fun v => ?_⟩ + have h1 := hlen v + calc c * ((v 0).length + 1) ^ (d + 1) + = (c * ((v 0).length + 1) ^ d) * ((v 0).length + 1) := by ring + _ ≤ (f v).length * (false :: v 0).length := by + exact Nat.mul_le_mul h1 (by simp) + _ = _ := by simp + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean b/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean new file mode 100644 index 00000000..e72cc393 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/BlockScan.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.Cobham.Internal.Vec +public import Complexitylib.Models.TuringMachine.Subroutines + +/-! +# What the block scanners compute — proof internals + +The two total parsers of a self-delimiting block — `Cobham.fstBlock` decodes the +leading block's payload, `Cobham.sndBlock` returns the suffix after it — and the +control states their scanners share. `Complexity.pairSplitCoreTM` handles only +valid pair inputs, so the total decoders need machines of their own; those are +`Internal.SndBlock`, `Internal.FstBlock` and `Internal.Cat`, one per machine. +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- Decode the payload of the leading self-delimiting block: read doubled bits +until the `[false, true]` separator. On a valid pair `pair x y` this +returns `x` (see `fstBlock_pair`); on malformed input it returns the bits decoded +so far. This total, incremental form is what the `fstBlockTM` scanner computes. -/ +def fstBlock : List Bool → List Bool + | false :: false :: z => false :: fstBlock z + | true :: true :: z => true :: fstBlock z + | _ => [] + +/-- Take the suffix after the leading self-delimiting block (the second `unpair?` +component), or `[]` if the input is not a valid block. On `encodeVec` of a +nonempty vector this returns the head component `v 0`. -/ +def sndBlock (z : List Bool) : List Bool := + match unpair? z with + | some (_, s) => s + | none => [] + +@[simp] theorem fstBlock_pair (x y : List Bool) : fstBlock (pair x y) = x := by + induction x with + | nil => rfl + | cons b x ih => cases b <;> (rw [pair_cons_eq]; simp [fstBlock, ih]) + +@[simp] theorem sndBlock_pair (x y : List Bool) : sndBlock (pair x y) = y := by + simp [sndBlock] + +/-- Stripping the head component of an encoded vector yields the encoded tail. +(Not a `simp` lemma: `simp` already reaches this via `encodeVec_succ` and +`fstBlock_pair`.) -/ +theorem fstBlock_encodeVec_succ {n : ℕ} (v : Fin (n + 1) → List Bool) : + fstBlock (encodeVec v) = encodeVec (Fin.tail v) := by + simp + +/-- The suffix of an encoded vector is its head component. +(Not a `simp` lemma: `simp` already reaches this via `encodeVec_succ` and +`sndBlock_pair`.) -/ +theorem sndBlock_encodeVec_succ {n : ℕ} (v : Fin (n + 1) → List Bool) : + sndBlock (encodeVec v) = v 0 := by + simp + +/-- Control states of the block-decoding scanners. -/ +inductive ScanPhase where + | skip | scanA | scanBfalse | scanBtrue | emit | done + deriving DecidableEq + +instance : Fintype ScanPhase where + elems := {.skip, .scanA, .scanBfalse, .scanBtrue, .emit, .done} + complete := fun x => by cases x <;> simp + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean b/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean new file mode 100644 index 00000000..72373194 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Blocks.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Data.List.Basic + +/-! +# Blocks, flags, and bit dispatch — proof internals + +The string toolkit the simulation of a machine inside Cobham's algebra is +written in. None of it appears in the statement of `CobhamFP_eq_FP`; it is the +vocabulary of the proof. + +* *Dispatch* — `Complexity.caseBit` selects on a leading bit and returns nothing + on the empty string; `Complexity.caseBit₀` reads "no bit" as `false`. Both are + needed: the partial one to read off the end of a string, the total one so that + a *flag* (a one-bit string) is always genuinely one bit. +* *Flags* — `Complexity.andBit`, `orBit`, `notBit`, `bitAt`, + `Complexity.nonemptyFlag` and `Complexity.matchPrefix`, the Boolean layer a + machine's finite transition table is written in. `matchPrefix` unfolds into + `|c|` bit tests for each fixed constant `c`, so it is a *finite* composition — + the induction is at the meta level, not inside the algebra. +* *Blocks* — `Complexity.padTo` pads a field to one ruler's width and + `Complexity.blockAt` reads field `i` back, so a packed configuration needs no + self-delimiting decoder inside the algebra. The padding algebra + (`padTo_append_padTo`, `take_padTo`, `drop_padTo`, `padTo_drop`) says that + re-padding commutes with the edits a simulated step performs. +-/ + + +@[expose] public section + +namespace Complexity + +/-- **Bit dispatch**: select `x` or `y` according to the leading bit of `s`, +returning the empty string when `s` is empty. + +This is the branching primitive of the algebra. It is definable by a single +limited recursion on notation (`Cobham.caseBit`) because the step functions of +`recNotation` are already selected by the bit being peeled — dispatching on a bit +costs nothing beyond the recursion that is there anyway. -/ +def caseBit (s x y : List Bool) : List Bool := + match s with + | [] => [] + | b :: _ => bif b then x else y + +@[simp] theorem caseBit_nil (x y : List Bool) : caseBit [] x y = [] := rfl + +@[simp] theorem caseBit_cons (b : Bool) (s x y : List Bool) : + caseBit (b :: s) x y = bif b then x else y := rfl + +/-- Bit dispatch never returns more than its two branches together. -/ +theorem caseBit_length_le (s x y : List Bool) : + (caseBit s x y).length ≤ (x ++ y).length := by + cases s with + | nil => simp + | cons b s => cases b <;> simp + +/-- **Total bit dispatch**: like `caseBit`, but the empty string selects the +`false` branch instead of returning nothing. + +Both variants are needed. `caseBit` is the *partial* reader used when running off +the end of a string must produce nothing (`Cobham.takePrefix` reads bits this +way); `caseBit₀` is the *total* one used for Boolean logic, where "no bit" has to +mean `false` so that flags are always exactly `[true]` or `[false]`. -/ +def caseBit₀ (s x y : List Bool) : List Bool := + match s with + | [] => y + | b :: _ => bif b then x else y + +@[simp] theorem caseBit₀_nil (x y : List Bool) : caseBit₀ [] x y = y := rfl + +@[simp] theorem caseBit₀_cons (b : Bool) (s x y : List Bool) : + caseBit₀ (b :: s) x y = bif b then x else y := rfl + +/-- Total bit dispatch never returns more than its two branches together. -/ +theorem caseBit₀_length_le (s x y : List Bool) : + (caseBit₀ s x y).length ≤ (x ++ y).length := by + cases s with + | nil => simp + | cons b s => cases b <;> simp + +/-! ### Flags + +A *flag* is a one-bit string, `[true]` or `[false]`. The connectives below are +each one `caseBit₀`, so they are in the algebra as soon as `caseBit₀` is, and +they are how the finite case analysis of a machine's transition function gets +written inside it. Because they are built on the *total* dispatcher, every flag +these produce is genuinely one bit — never empty — so they compose. -/ + +/-- Conjunction of flags. -/ +def andBit (x y : List Bool) : List Bool := + caseBit₀ x (caseBit₀ y [true] [false]) [false] + +/-- Disjunction of flags. -/ +def orBit (x y : List Bool) : List Bool := + caseBit₀ x [true] (caseBit₀ y [true] [false]) + +/-- Negation of a flag. -/ +def notBit (x : List Bool) : List Bool := caseBit₀ x [false] [true] + +/-- The bit of `x` at the position marked by the ruler `r`, as a flag; `false` +when the position is past the end of `x`. -/ +def bitAt (r x : List Bool) : List Bool := + caseBit₀ (x.drop r.length) [true] [false] + +@[simp] theorem bitAt_nil_left (x : List Bool) : + bitAt [] x = caseBit₀ x [true] [false] := by simp [bitAt] + +/-- A flag is exactly one bit long. -/ +theorem bitAt_length (r x : List Bool) : (bitAt r x).length = 1 := by + rw [bitAt] + rcases hx : x.drop r.length with _ | ⟨b, z⟩ + · simp + · cases b <;> simp + +/-- Pad (or truncate) `x` to exactly the width of the ruler `r`, filling with +zeros. + +Fixed-width blocks are how a simulated machine's configuration is packed into the +single string a member of the class returns: every field occupies `|r|` bits, so +field `i` is recovered by dropping `i` rulers and taking one — no self-delimiting +decoder is needed inside the algebra. -/ +def padTo (r x : List Bool) : List Bool := + (x ++ List.replicate r.length false).take r.length + +/-- A padded block always has exactly the ruler's width. -/ +@[simp] theorem padTo_length (r x : List Bool) : (padTo r x).length = r.length := by + rw [padTo, List.length_take, List.length_append, List.length_replicate] + omega + +/-- Padding a short string appends zeros. -/ +theorem padTo_eq_append (r x : List Bool) (h : x.length ≤ r.length) : + padTo r x = x ++ List.replicate (r.length - x.length) false := by + rw [padTo] + simp [List.take_append, List.take_replicate, List.take_of_length_le h] + +/-- The `i`-th block of `x`, when `x` is a concatenation of blocks each as wide +as the ruler `r`. -/ +def blockAt (r x : List Bool) (i : ℕ) : List Bool := + (x.drop (i * r.length)).take r.length + +/-- Block zero of a block-aligned string is its first block. -/ +@[simp] theorem blockAt_zero_append (r a x : List Bool) (h : a.length = r.length) : + blockAt r (a ++ x) 0 = a := by + rw [blockAt, Nat.zero_mul, List.drop_zero, ← h, List.take_left] + +/-- Later blocks of a block-aligned string are the blocks of its tail. -/ +theorem blockAt_succ_append (r a x : List Bool) (h : a.length = r.length) (i : ℕ) : + blockAt r (a ++ x) (i + 1) = blockAt r x i := by + have hd : (a ++ x).drop (i * a.length + a.length) = x.drop (i * a.length) := by + rw [Nat.add_comm] + simp + rw [blockAt, blockAt, Nat.succ_mul, ← h, hd] + +/-! ### Padding algebra + +A simulated step reads a padded block, edits it, and re-pads. These three lemmas +say that the padding is invisible to that: re-padding commutes with the edits, so +the encoded step can be reasoned about on raw contents. -/ + +/-- Extra zero padding is invisible to `padTo`. -/ +theorem padTo_append_replicate (r z : List Bool) (m : ℕ) : + padTo r (z ++ List.replicate m false) = padTo r z := by + rw [padTo, padTo, List.append_assoc, ← List.replicate_add, List.take_append, + List.take_append, List.take_replicate, List.take_replicate] + congr 2 + omega + +/-- Re-padding a padded block is the same as padding its raw content. -/ +theorem padTo_append_padTo (r y x : List Bool) (hx : x.length ≤ r.length) : + padTo r (y ++ padTo r x) = padTo r (y ++ x) := by + rw [padTo_eq_append r x hx, ← List.append_assoc, padTo_append_replicate] + +/-- Taking from within the content of a padded block ignores the padding. -/ +theorem take_padTo (r x : List Bool) (n : ℕ) (hn : n ≤ x.length) + (hx : x.length ≤ r.length) : + (padTo r x).take n = x.take n := by + rw [padTo, List.take_take, Nat.min_eq_left (by omega : n ≤ r.length), + List.take_append, Nat.sub_eq_zero_of_le hn, List.take_zero, List.append_nil] + +/-- Dropping from a padded block leaves the padding trailing at the end. -/ +theorem drop_padTo (r x : List Bool) (n : ℕ) (hn : n ≤ x.length) + (hx : x.length ≤ r.length) : + (padTo r x).drop n = x.drop n ++ List.replicate (r.length - x.length) false := by + rw [padTo_eq_append r x hx, List.drop_append, Nat.sub_eq_zero_of_le hn, + List.drop_zero] + +/-- Dropping from a padded block and re-padding ignores the padding. -/ +theorem padTo_drop (r x : List Bool) (n : ℕ) (hn : n ≤ x.length) + (hx : x.length ≤ r.length) : + padTo r ((padTo r x).drop n) = padTo r (x.drop n) := by + rw [padTo_eq_append r x hx, List.drop_append, Nat.sub_eq_zero_of_le hn, + List.drop_zero, padTo_append_replicate] + +/-- **Reading a field out of a block-aligned record.** When `bs` is a list of +blocks all as wide as the ruler `r`, block `i` of their concatenation is `bs[i]`. +This is what makes `Cobham.blockFn` a field accessor. -/ +theorem blockAt_flatten (r : List Bool) : + ∀ (bs : List (List Bool)), (∀ b ∈ bs, b.length = r.length) → + ∀ (i : ℕ) (hi : i < bs.length), blockAt r bs.flatten i = bs[i] := by + intro bs + induction bs with + | nil => intro _ i hi; simp at hi + | cons b bs ih => + intro hb i hi + cases i with + | zero => + rw [List.flatten_cons] + exact blockAt_zero_append r b _ (hb b (by simp)) + | succ i => + rw [List.flatten_cons, blockAt_succ_append _ _ _ (hb b (by simp))] + rw [ih (fun c hc => hb c (by simp [hc])) i (by simpa using hi)] + simp + +/-- Flag: is `x` nonempty? The *partial* dispatcher returns `[]` on the empty +string, and `[]` reads as false to the flag connectives — so this is the one +place `caseBit` rather than `caseBit₀` is what is wanted. + +Without it `matchPrefix` could not tell "the head bit is `0`" from "there is no +head bit", and would report a match of `[0]` against `[]`. -/ +def nonemptyFlag (x : List Bool) : List Bool := caseBit x [true] [true] + +@[simp] theorem nonemptyFlag_nil : nonemptyFlag [] = [] := rfl + +@[simp] theorem nonemptyFlag_cons (b : Bool) (x : List Bool) : + nonemptyFlag (b :: x) = [true] := by cases b <;> rfl + +/-- Flag: does `x` begin with the fixed constant `c`? Unfolds into `|c|` bit +tests joined by `andBit`, so for each constant it is a *finite* composition — +no recursion on notation is needed. -/ +def matchPrefix : List Bool → List Bool → List Bool + | [], _ => [true] + | b :: c, x => + andBit (nonemptyFlag x) + (andBit (bif b then bitAt [] x else notBit (bitAt [] x)) + (matchPrefix c x.tail)) + +@[simp] theorem matchPrefix_nil (x : List Bool) : matchPrefix [] x = [true] := rfl + +@[simp] theorem matchPrefix_cons (b : Bool) (c x : List Bool) : + matchPrefix (b :: c) x = + andBit (nonemptyFlag x) + (andBit (bif b then bitAt [] x else notBit (bitAt [] x)) + (matchPrefix c x.tail)) := rfl + +/-- A constant is matched by anything it prefixes. -/ +theorem matchPrefix_append (c y : List Bool) : matchPrefix c (c ++ y) = [true] := by + induction c generalizing y with + | nil => rfl + | cons b c ih => cases b <;> simp [andBit, notBit, ih] + +/-- Nothing but the empty constant matches the empty string. (Not a `simp` +lemma: `simp` unfolds the left-hand side past this shape.) -/ +theorem matchPrefix_nil_right (b : Bool) (c : List Bool) : + matchPrefix (b :: c) [] = [false] := by + cases b <;> rfl + +/-- Conjunction always returns a genuine one-bit flag, whatever it is given. -/ +theorem andBit_flag (x y : List Bool) : + andBit x y = [true] ∨ andBit x y = [false] := by + rw [andBit] + cases x with + | nil => exact Or.inr rfl + | cons a x => + cases a + · exact Or.inr rfl + · rw [caseBit₀_cons, cond_true] + cases y with + | nil => exact Or.inr rfl + | cons d y => cases d <;> simp + +/-- The match test always returns a genuine one-bit flag. -/ +theorem matchPrefix_flag (c x : List Bool) : + matchPrefix c x = [true] ∨ matchPrefix c x = [false] := by + cases c with + | nil => exact Or.inl rfl + | cons b c => rw [matchPrefix_cons]; exact andBit_flag _ _ + +/-- **The match test is exactly the prefix test.** This is what makes a table of +constant patterns behave like a case analysis: the entry whose pattern is a +prefix of the key fires, and no other does. -/ +theorem matchPrefix_eq_true_iff (c x : List Bool) : + matchPrefix c x = [true] ↔ c <+: x := by + induction c generalizing x with + | nil => simp + | cons b c ih => + cases x with + | nil => simp [andBit] + | cons a x => + rw [matchPrefix_cons, nonemptyFlag_cons, andBit, caseBit₀_cons, cond_true, + andBit] + have hbit : (bif b then bitAt [] (a :: x) else notBit (bitAt [] (a :: x))) + = [decide (a = b)] := by + cases a <;> cases b <;> rfl + rw [hbit, List.cons_prefix_cons] + rcases matchPrefix_flag c x with h | h <;> cases a <;> cases b <;> + simp [h, ← ih x] + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Cat.lean b/Complexitylib/Classes/P/Cobham/Internal/Cat.lean new file mode 100644 index 00000000..78f67e2d --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Cat.lean @@ -0,0 +1,416 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.Counter +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.SndBlock + +/-! +# Concatenating two blocks — proof internals + +`Cobham.catBlocks` appends the payloads of two consecutive blocks, the string +concatenation behind `Cobham.appendFn_mem_FP`, together with the `Cobham.catTM` +scanner that computes it. + +## Main results + +- `Cobham.catBlocks_mem_FP` — concatenation is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ### Concatenation + +`catBlocks` is `fstBlock` and `sndBlock` fused: decode the leading block's +payload *and* keep the suffix, so on a genuine pair it is concatenation. Its +machine is `sndBlockTM` with the scan also emitting each decoded bit — the one +`FP` primitive that lets two computed strings be joined. -/ + +/-- Decode the leading self-delimiting block's payload and keep the suffix. On +`pair x y` this is `x ++ y` (`catBlocks_pair`); on malformed input it returns the +bits decoded so far. -/ +def catBlocks : List Bool → List Bool + | false :: false :: z => false :: catBlocks z + | true :: true :: z => true :: catBlocks z + | false :: true :: z => z + | _ => [] + +@[simp] theorem catBlocks_pair (x y : List Bool) : catBlocks (pair x y) = x ++ y := by + induction x with + | nil => rfl + | cons b x ih => cases b <;> (rw [pair_cons_eq]; simp [catBlocks, ih]) + +/-- The concatenator: like `sndBlockTM`, but the scan also emits each decoded +payload bit, so the output ends up holding the payload followed by the suffix. +Computes `catBlocks`. -/ +def catTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Γ.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Γ.one => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.zero => + (.scanA, fun i => readBackWrite (wHeads i), Γw.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Γ.one => + (.scanA, fun i => readBackWrite (wHeads i), Γw.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if iHead = Γ.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `catTM`: from `emit` with input cursor on suffix `y` and +output holding `acc`, the machine copies `y` after `acc` and halts. -/ +private theorem catTM_emit_loop : + ∀ (y acc : List Bool) (c : Cfg 0 catTM.Q), + c.state = ScanPhase.emit → + c.input.HasBinarySuffix y → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ y.length + 1 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y) := by + intro y + induction y with + | nil => + intro acc c hstate hsuf hpre + have hread : c.input.read = Γ.blank := hsuf.read_nil + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, catTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa using hpre + | cons bit y ih => + intro acc c hstate hsuf hpre + have hread : c.input.read = Γ.ofBool bit := hsuf.read_cons + have hne : c.input.read ≠ Γ.blank := by rw [hread]; cases bit <;> decide + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.emit + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hne, c1] + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [bit]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool bit := by + rw [hread]; cases bit <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [bit]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit bit hpre + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih (acc ++ [bit]) c1 rfl hsuf.move_right_cons hpre1 + refine ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, ?_⟩ + rwa [List.append_assoc, List.cons_append, List.nil_append] at hout + +/-- A one-step halt from a scan state whose input reads a symbol that ends the +block: the output is untouched. -/ +private theorem catTM_halt_step {c : Cfg 0 catTM.Q} {acc : List Bool} + (hstep : catTM.step c = some + { state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }) + (hpre : c.output.HasBinaryPrefix acc) : + ∃ c' t, t ≤ 1 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix acc := by + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + refine ⟨_, 1, le_rfl, .step hstep .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + +/-- The scan phase of `catTM`: from `scanA` with input cursor on `w` and output +holding `acc`, the machine halts with output `acc ++ catBlocks w`. -/ +private theorem catTM_scan_loop : + ∀ (fuel : ℕ) (w acc : List Bool), w.length ≤ fuel → ∀ (c : Cfg 0 catTM.Q), + c.state = ScanPhase.scanA → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ 2 * w.length + 2 ∧ catTM.reachesIn t c c' ∧ catTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ catBlocks w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Γ.blank := hsuf.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c) (acc := acc) + (by simp [TM.step, hstate, catTM, hread]) hpre + exact ⟨c', t, by omega, hreach, hhalt, by simpa [catBlocks] using hout⟩ + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c) (acc := acc) + (by simp [TM.step, hstate, catTM, hread]) hpre + exact ⟨c', t, by omega, hreach, hhalt, by simpa [catBlocks] using hout⟩ + | [b0] => + have hread : c.input.read = Γ.ofBool b0 := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := if b0 then ScanPhase.scanBtrue else ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : catTM.step c = some c1 := by + cases b0 <;> simp [TM.step, hstate, catTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c1) (acc := acc) + (by cases b0 <;> simp [TM.step, catTM, hread1, c1]) hpre1 + exact ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, + by cases b0 <;> simpa [catBlocks] using hout⟩ + | false :: true :: y => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.emit + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix acc := by + show (c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1]; exact hpre1 + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := catTM_emit_loop y acc c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + simpa [catBlocks] using hout + | true :: false :: rest => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + catTM_halt_step (c := c1) (acc := acc) + (by simp [TM.step, catTM, hreadB, Γ.ofBool, c1]) hpre1 + exact ⟨c', t + 1, by simp only [List.length_cons]; omega, + .step hstepA hreach, hhalt, by simpa [catBlocks] using hout⟩ + | false :: false :: rest => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool false) Dir3.right } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix rest := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Γw.ofBool false).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hrfuel : rest.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih rest (acc ++ [false]) hrfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hcb : catBlocks (false :: false :: rest) = false :: catBlocks rest := rfl + rw [hcb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hout + | true :: true :: rest => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : catTM.step c = some c1 := by + simp [TM.step, hstate, catTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + show (c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read)).HasBinaryPrefix acc + rw [Tape.writeAndMove_readBack_idle_of_ne_start _ houtne]; exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool true) Dir3.right } + have hstepB : catTM.step c1 = some c2 := by + simp [TM.step, catTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix rest := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Γw.ofBool true).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hrfuel : rest.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih rest (acc ++ [true]) hrfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hcb : catBlocks (true :: true :: rest) = true :: catBlocks rest := rfl + rw [hcb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hout + +/-- **Concatenation is polynomial-time.** -/ +theorem catBlocks_mem_FP : catBlocks ∈ FP := by + refine ⟨1, 0, catTM, (fun m => 2 * m + 3), ?_, ?_⟩ + · intro z + let c1 : Cfg 0 catTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : catTM.step (catTM.initCfg z) = some c1 := by + simp [TM.step, catTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + catTM_scan_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≤ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + · have hn : (fun m : ℕ => 2 * m) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun m : ℕ => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean b/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean new file mode 100644 index 00000000..65220d10 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/ConsBit.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.Counter +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Complexitylib.Classes.P.Cobham.Internal.Vec + +/-! +# The bit successor — proof internals + +`Cobham.consBitTM b` prepends the fixed bit `b` to its input: the machine behind +the `bit` constructor of Cobham's algebra. + +## Main results + +- `Cobham.cons_mem_FP` — prepending a fixed bit is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ### The bit-successor transducer + +A small machine computing `x ↦ b :: x`: skip the left marker, emit `b`, then copy +the input verbatim after it. Modelled on `TM.copyInputToOutputTM`. -/ + + +/-- Control states of `consBitTM`: skip the `▷` marker, emit the fixed bit, copy +the input, halt. -/ +inductive ConsPhase where + | skip | emit | copy | done + deriving DecidableEq + +instance : Fintype ConsPhase where + elems := {.skip, .emit, .copy, .done} + complete := fun x => by cases x <;> simp + +/-- The bit-successor machine: on input `x` it writes `b :: x` to the output tape +in `|x| + 3` steps. First `skip` advances past the left markers, `emit` writes `b` +into output cell 1, and `copy` copies the input bits after it. -/ +def consBitTM (b : Bool) : TM 0 where + Q := ConsPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .emit => + (.copy, fun i => readBackWrite (wHeads i), Γw.ofBool b, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + | .copy => + if iHead = Γ.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.copy, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .emit => + exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .copy => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `consBitTM`: from a configuration whose output already holds +`b :: x.take k` and whose input head is at the first uncopied cell, the remaining +`rem = |x| - k` bits are copied and the machine halts with output `b :: x`. -/ +private theorem consBitTM_copy_loop (b : Bool) (x : List Bool) : + ∀ rem k (c : Cfg 0 (consBitTM b).Q), + rem = x.length - k → + c.state = ConsPhase.copy → + c.input.cells = (Tape.init (x.map Γ.ofBool)).cells → + c.input.head = k + 1 → + c.output.HasBinaryPrefix (b :: x.take k) → + k ≤ x.length → + ∃ c', + (consBitTM b).reachesIn (rem + 1) c c' ∧ + (consBitTM b).halted c' ∧ + c'.output.HasBinaryPrefix (b :: x) := by + intro rem + induction rem with + | zero => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_eq : k = x.length := by omega + subst hk_eq + have hread : c.input.read = Γ.blank := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_ge x x.length le_rfl] + have hprefix_full : c.output.HasBinaryPrefix (b :: x) := by + simpa using hprefix + have houtput_blank : c.output.read = Γ.blank := hprefix_full.read_blank + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hinput_keep : c.input.move (idleDir c.input.read) = c.input := by + simp [idleDir, hread, Tape.move] + have houtput_keep : + c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) = c.output := by + rw [writeAndMove_readBack c.output (by simp [houtput_blank]), + idleDir, if_neg (by simp [houtput_blank]), Tape.move] + have hstep : (consBitTM b).step c = some c1 := by + simp [TM.step, hstate, consBitTM, hread, c1] + refine ⟨c1, .step hstep .zero, rfl, ?_⟩ + rw [show c1.output = c.output by simpa [c1] using houtput_keep] + exact hprefix_full + | succ rem ih => + intro k c hrem hstate hcells hhead hprefix hk_le + have hk_lt : k < x.length := by omega + have hread : c.input.read = Γ.ofBool (x[k]'hk_lt) := by + simp [Tape.read, hhead, hcells, Tape.init_ofBool_cells_lt x k hk_lt] + have hread_ne : c.input.read ≠ Γ.blank := by + rw [hread]; cases x[k]'hk_lt <;> simp [Γ.ofBool] + have hprefix_next : + (c.output.writeAndMove (Γ.ofBool (x[k]'hk_lt)) Dir3.right).HasBinaryPrefix + (b :: x.take (k + 1)) := by + have hwrite := Tape.hasBinaryPrefix_write_bit (x[k]'hk_lt) hprefix + have heq : (b :: x.take k) ++ [x[k]'hk_lt] = b :: x.take (k + 1) := by + rw [List.cons_append, List.take_concat_get' x k hk_lt] + rwa [heq] at hwrite + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.copy + input := c.input.move Dir3.right + work := fun i => + (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : (consBitTM b).step c = some c1 := by + simp [TM.step, hstate, consBitTM, hread_ne, c1] + have hcells1 : c1.input.cells = (Tape.init (x.map Γ.ofBool)).cells := by + simpa [c1, Tape.move_cells] using hcells + have hhead1 : c1.input.head = (k + 1) + 1 := by simp [c1, Tape.move, hhead] + have hprefix1 : c1.output.HasBinaryPrefix (b :: x.take (k + 1)) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool (x[k]'hk_lt) := by + rw [hread]; cases x[k]'hk_lt <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) Dir3.right).HasBinaryPrefix + (b :: x.take (k + 1)) + rw [hco]; exact hprefix_next + obtain ⟨c', hreach, hhalt, hprefix'⟩ := + ih (k + 1) c1 (by omega) rfl hcells1 hhead1 hprefix1 (by omega) + exact ⟨c', .step hstep hreach, hhalt, hprefix'⟩ + +/-- `consBitTM b` computes `x ↦ b :: x` within the linear bound `|x| + 3`. -/ +theorem consBitTM_computesInTime (b : Bool) : + (consBitTM b).ComputesInTime (fun x => b :: x) (fun m => m + 3) := by + intro x + -- Step 1: `skip` advances past the left markers. + let c1 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.emit + input := (Tape.init (x.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).writeAndMove (readBackWrite (Tape.init []).read) + (idleDir (Tape.init []).read) + output := (Tape.init []).move Dir3.right } + have hstep1 : (consBitTM b).step ((consBitTM b).initCfg x) = some c1 := by + simp [TM.step, consBitTM, c1, Tape.read, Tape.init, idleDir, Tape.writeAndMove, + Tape.write, Tape.move] + -- The input head after `skip` reads a data/blank cell, never the marker. + have hne : c1.input.read ≠ Γ.start := by + cases x with + | nil => simp [c1, Tape.read, Tape.move, Tape.init] + | cons a t => cases a <;> simp [c1, Tape.read, Tape.move, Tape.init, Γ.ofBool] + -- Step 2: `emit` writes `b` into output cell 1. + let c2 : Cfg 0 (consBitTM b).Q := + { state := ConsPhase.copy + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool b) Dir3.right } + have hstep2 : (consBitTM b).step c1 = some c2 := by + simp [TM.step, consBitTM, c1, c2] + have hc2_input_cells : c2.input.cells = (Tape.init (x.map Γ.ofBool)).cells := by + simp [c2, c1, Tape.move_cells] + have hc2_input_head : c2.input.head = 0 + 1 := by + show (c1.input.move (idleDir c1.input.read)).head = 0 + 1 + rw [idleDir, if_neg hne] + simp [Tape.move, c1, Tape.init] + have hc2_output : c2.output.HasBinaryPrefix (b :: x.take 0) := by + have hbase : ((Tape.init []).move Dir3.right).HasBinaryPrefix [] := + Tape.init_nil_move_right_hasBinaryPrefix_nil + have hw := Tape.hasBinaryPrefix_write_bit (t := (Tape.init []).move Dir3.right) b hbase + show (c1.output.writeAndMove ((Γw.ofBool b).toΓ) Dir3.right).HasBinaryPrefix (b :: x.take 0) + rw [Γw.ofBool_toΓ, show c1.output = (Tape.init []).move Dir3.right from rfl] + simpa using hw + obtain ⟨c', hreach, hhalt, hprefix⟩ := + consBitTM_copy_loop b x x.length 0 c2 (by simp) rfl hc2_input_cells + hc2_input_head hc2_output (Nat.zero_le _) + refine ⟨c', x.length + 3, le_rfl, ?_, hhalt, (hprefix.hasOutput)⟩ + have : (consBitTM b).reachesIn (x.length + 1 + 1 + 1) ((consBitTM b).initCfg x) c' := + .step hstep1 (.step hstep2 hreach) + simpa [Nat.add_assoc] using this + +/-- Prepending a fixed bit is polynomial-time — the string-successor underlying +the `bit` constructor. Witnessed by `consBitTM`. -/ +theorem cons_mem_FP (b : Bool) : (fun x : List Bool => b :: x) ∈ FP := by + refine ⟨1, 0, consBitTM b, (fun m => m + 3), consBitTM_computesInTime b, ?_⟩ + have hn : (fun m : ℕ => m) =O ((· ^ 1) : ℕ → ℕ) := by + simpa only [pow_one] using BigO.refl (fun m : ℕ => m) + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean b/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean new file mode 100644 index 00000000..8a3f3fa5 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Encoding.lean @@ -0,0 +1,972 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.Blocks +public import Complexitylib.Classes.P.Cobham.Defs +public import Complexitylib.Models.TuringMachine +public import Complexitylib.Models.TuringMachine.Internal + +/-! +# Encoding machine configurations as bitstrings — proof internals + +The completeness direction of Cobham's theorem simulates a polynomial-time +machine inside the function algebra, so a configuration has to become a single +bitstring. This module fixes that encoding and proves the arithmetic facts about +it; the algebra-side operations that act on it live in +`Complexitylib.Classes.P.Cobham.Internal.StepAlgebra`. + +## The two design choices + +**Two bits per symbol, with blank `= 00`.** Fixed-width blocks are padded with +zeros (`Complexity.padTo`), so making blank the all-zero code means padding a +tape block with zeros *is* extending it with blanks — the padding needs no +special treatment anywhere. + +**Tapes split at the head.** A tape is stored as its cells to the left of the +head, nearest first, and its cells from the head rightwards. Then a head move is +transferring one symbol between the two sides, i.e. a `take`/`drop`/`append` of +two bits, rather than arithmetic on a position index. Reading is the first two +bits of the right part. + +Cell `0` is the only `▷` (the writable alphabet `Γw` excludes it), so "the head +is at cell 0" is exactly "the read symbol is `▷`" — and in that case +`TM.δ_right_of_start` forces a move right. The left part is therefore never +consulted when it is empty, which is why it needs no emptiness test. + +## Main definitions + +- `Complexity.Cobham.symCode` — two-bit code for `Γ` +- `Complexity.Cobham.cellsCode` — a window of cells as a bitstring +- `Complexity.Cobham.leftCode`, `Complexity.Cobham.rightCode` — a tape split at + its head + +## Main results + +The six lemmas that make the split representation simulate `Tape.writeAndMove`, +each expressing one head move as two bits crossing the split: + +- `leftCode_write_stay`, `rightCode_write_stay` +- `leftCode_write_right`, `rightCode_write_right` +- `leftCode_write_left`, `rightCode_write_left` + +Every right-hand side is built from `take 2`, `drop 2`, `++` and the constant +`symCode s` — all of which the algebra has (`Cobham.takeFn`, `Cobham.dropFn`, +`Cobham.appendFn`, `Cobham.const`). +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## The symbol code -/ + +/-- Two-bit code for the tape alphabet. Blank is `00`, so zero-padding a block is +blank-padding it. -/ +def symCode : Γ → List Bool + | .blank => [false, false] + | .start => [false, true] + | .zero => [true, false] + | .one => [true, true] + +/-- Decode the leading two bits of a string as a tape symbol; anything shorter +than two bits reads as blank. -/ +def symDecode : List Bool → Γ + | false :: false :: _ => .blank + | false :: true :: _ => .start + | true :: false :: _ => .zero + | true :: true :: _ => .one + | _ => .blank + +@[simp] theorem symCode_length (g : Γ) : (symCode g).length = 2 := by cases g <;> rfl + +@[simp] theorem symCode_blank : symCode Γ.blank = [false, false] := rfl + +/-- The code round-trips, even with arbitrary trailing bits — which is what lets +the decoder read a symbol off the front of a longer block. -/ +@[simp] theorem symDecode_symCode (g : Γ) (rest : List Bool) : + symDecode (symCode g ++ rest) = g := by cases g <;> rfl + +/-- The decoder only ever looks at two bits, so truncating first changes +nothing. -/ +theorem symDecode_take_two (l : List Bool) : symDecode (l.take 2) = symDecode l := by + match l with + | [] => rfl + | [b] => cases b <;> rfl + | b :: b' :: t => cases b <;> cases b' <;> rfl + +/-- Zero padding decodes as blank: the reason `symCode Γ.blank = [0,0]`. -/ +theorem symDecode_replicate_false {n : ℕ} (h : 2 ≤ n) : + symDecode (List.replicate n false) = Γ.blank := by + obtain ⟨m, rfl⟩ : ∃ m, n = m + 2 := ⟨n - 2, by omega⟩ + rw [show m + 2 = 2 + m from by omega, List.replicate_add] + rfl + +/-- The code is injective. -/ +theorem symCode_injective : Function.Injective symCode := by + intro a b hab + have h1 : symDecode (symCode a ++ []) = a := symDecode_symCode a [] + rw [hab, symDecode_symCode] at h1 + exact h1.symm + +/-- Every symbol costs two bits, so a run of coded symbols has twice the +length. -/ +private theorem length_flatMap_symCode (l : List ℕ) (f : ℕ → Γ) : + ((l.flatMap fun j => symCode (f j)).length) = 2 * l.length := by + induction l with + | nil => rfl + | cons a l ih => simp only [List.flatMap_cons, List.length_append, ih, + symCode_length, List.length_cons]; omega + +/-! ## The control state + +The state is stored one-hot: `|Q|` bits with a single `1`. Fixed width and +injective, and — the point — every state's code is a *constant* for a fixed +machine, so the transition table is finitely many `Cobham.matchPrefixFn` tests +against constants (`Cobham.tableFn`). Binary would need arithmetic; one-hot needs +none. -/ + +/-- One-hot code for a control state: one bit per element of `Q`, set exactly at +the state itself. + +Noncomputable only because `Finset.toList` picks an enumeration order; the code +appears solely in specifications, never in a machine that must run. -/ +noncomputable def stateCode {Q : Type} [Fintype Q] [DecidableEq Q] (q : Q) : + List Bool := + (Finset.univ.toList (α := Q)).map fun p => decide (p = q) + +@[simp] theorem stateCode_length {Q : Type} [Fintype Q] [DecidableEq Q] (q : Q) : + (stateCode q).length = Fintype.card Q := by + rw [stateCode, List.length_map, Finset.length_toList, Finset.card_univ] + +/-- Distinct states get distinct codes. -/ +theorem stateCode_injective {Q : Type} [Fintype Q] [DecidableEq Q] : + Function.Injective (stateCode (Q := Q)) := by + intro a b hab + rw [stateCode, stateCode, List.map_inj_left] at hab + have h := hab a (by simp) + simpa using h.symm + +/-! ## Windows of cells -/ + +/-- The `w` cells of `t` starting at cell `i`, two bits each. -/ +def cellsCode (t : Tape) (i w : ℕ) : List Bool := + (List.range w).flatMap fun j => symCode (t.cells (i + j)) + +@[simp] theorem cellsCode_zero (t : Tape) (i : ℕ) : cellsCode t i 0 = [] := rfl + +@[simp] theorem cellsCode_length (t : Tape) (i w : ℕ) : + (cellsCode t i w).length = 2 * w := by + rw [cellsCode, length_flatMap_symCode, List.length_range] + +/-- Peeling the first cell off a window. -/ +theorem cellsCode_succ_left (t : Tape) (i w : ℕ) : + cellsCode t i (w + 1) = symCode (t.cells i) ++ cellsCode t (i + 1) w := by + rw [cellsCode, cellsCode, List.range_succ_eq_map, List.flatMap_cons] + simp [List.flatMap_map, Nat.add_comm, Nat.add_left_comm] + +/-! ## Tapes split at the head -/ + +/-- The cells `n-1, n-2, …, 0` of `t`, nearest first. -/ +def leftCodeFrom (t : Tape) : ℕ → List Bool + | 0 => [] + | n + 1 => symCode (t.cells n) ++ leftCodeFrom t n + +/-- The cells strictly left of the head, nearest first. -/ +def leftCode (t : Tape) : List Bool := leftCodeFrom t t.head + +@[simp] theorem leftCodeFrom_zero (t : Tape) : leftCodeFrom t 0 = [] := rfl + +@[simp] theorem leftCodeFrom_succ (t : Tape) (n : ℕ) : + leftCodeFrom t (n + 1) = symCode (t.cells n) ++ leftCodeFrom t n := rfl + +@[simp] theorem leftCodeFrom_length (t : Tape) (n : ℕ) : + (leftCodeFrom t n).length = 2 * n := by + induction n with + | zero => rfl + | succ n ih => simp only [leftCodeFrom_succ, List.length_append, ih, symCode_length]; omega + +/-- The nearest-left window depends only on the cells it covers. -/ +theorem leftCodeFrom_congr {t t' : Tape} {n : ℕ} + (h : ∀ j, j < n → t.cells j = t'.cells j) : + leftCodeFrom t n = leftCodeFrom t' n := by + induction n with + | zero => rfl + | succ n ih => + rw [leftCodeFrom_succ, leftCodeFrom_succ, h n (by omega), + ih fun j hj => h j (by omega)] + +/-- The cells from the head rightwards, out to cell `W`. + +The width is `W + 1 - head`, complementary to `leftCode`'s `head`, so the two +parts always account for exactly the cells `0 … W`: their total width is the +constant `2 · (W + 1)` and a head move just shifts two bits across the split. -/ +def rightCode (t : Tape) (W : ℕ) : List Bool := cellsCode t t.head (W + 1 - t.head) + +@[simp] theorem leftCode_length (t : Tape) : (leftCode t).length = 2 * t.head := + leftCodeFrom_length t t.head + +@[simp] theorem rightCode_length (t : Tape) (W : ℕ) : + (rightCode t W).length = 2 * (W + 1 - t.head) := cellsCode_length _ _ _ + +/-- The two halves together always span the same window. -/ +theorem leftCode_rightCode_length (t : Tape) {W : ℕ} (h : t.head ≤ W + 1) : + (leftCode t).length + (rightCode t W).length = 2 * (W + 1) := by + simp only [leftCode_length, rightCode_length] + omega + +/-- The read symbol is the first two bits of the right part. -/ +theorem symDecode_rightCode (t : Tape) {W : ℕ} (hw : t.head ≤ W) : + symDecode (rightCode t W) = t.read := by + rw [rightCode, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left] + exact symDecode_symCode _ _ + +/-! ### Congruence + +Both halves read only the cells in their own window, so an update outside that +window is invisible to them. These are the lemmas that let a single-cell write be +localized. -/ + +/-- A window depends only on the cells it covers. -/ +theorem cellsCode_congr {t t' : Tape} {i w : ℕ} + (h : ∀ j, j < w → t.cells (i + j) = t'.cells (i + j)) : + cellsCode t i w = cellsCode t' i w := by + rw [cellsCode, cellsCode] + refine List.flatMap_congr fun j hj => ?_ + rw [h j (List.mem_range.mp hj)] + +/-- The left half depends only on the head and the cells strictly below it. -/ +theorem leftCode_congr {t t' : Tape} (hh : t.head = t'.head) + (h : ∀ j, j < t.head → t.cells j = t'.cells j) : leftCode t = leftCode t' := by + rw [leftCode, leftCode, ← hh] + exact leftCodeFrom_congr h + +/-! ### Writing and moving + +`Tape.write` never touches cell `0` (the model makes writing there a no-op), and +`Γw` cannot produce `▷`, so cell `0` is permanently the unique `▷`. Hence "the +head is at `0`" is exactly "the read symbol is `▷`", and `TM.δ_right_of_start` +then forces a right move — which is why the left half is never consulted while +empty. -/ + +/-- Writing at the head leaves every other cell alone. -/ +theorem write_cells_of_ne {t : Tape} {s : Γ} {j : ℕ} (h : j ≠ t.head) : + (t.write s).cells j = t.cells j := by + rw [Tape.write] + split + · rfl + · exact Function.update_of_ne h _ _ + +/-- Writing at the head sets exactly that cell — except at cell `0`, where the +model makes the write a no-op, so the written symbol must already agree with +what is there. In a run that agreement is automatic: cell `0` holds `▷`, and +`TM.δ_right_of_start` fires only when the head reads `▷`, in which branch the +transition table's write constant is `▷` too. -/ +theorem write_cells_head {t : Tape} {s : Γ} (hs : t.head = 0 → s = t.cells t.head) : + (t.write s).cells t.head = s := by + rw [Tape.write] + split + · next h => exact (hs h).symm + · exact Function.update_self _ _ _ + +/-- Writing at the head sets exactly that cell, away from cell `0`. -/ +theorem write_cells_self {t : Tape} {s : Γ} (h : t.head ≠ 0) : + (t.write s).cells t.head = s := + write_cells_head fun h0 => absurd h0 h + +/-- **Staying put**: the left half is untouched and the right half gets its +leading symbol replaced. -/ +theorem leftCode_write_stay {t : Tape} {s : Γ} : + leftCode ((t.write s).move Dir3.stay) = leftCode t := by + have hhead : ((t.write s).move Dir3.stay).head = t.head := Tape.write_head t s + refine leftCode_congr hhead fun j hj => ?_ + rw [hhead] at hj + show (t.write s).cells j = t.cells j + exact write_cells_of_ne (by omega) + +/-- **Moving right**: the written symbol crosses over to the left half. This is +the one direction a head at cell `0` can take, so it is stated with the weaker +hypothesis that the write agrees with cell `0` when the head is there. -/ +theorem leftCode_write_right {t : Tape} {s : Γ} + (h : t.head = 0 → s = t.cells t.head) : + leftCode ((t.write s).move Dir3.right) = symCode s ++ leftCode t := by + have hhead : ((t.write s).move Dir3.right).head = t.head + 1 := by + rw [Tape.move, Tape.write_head] + rw [leftCode, leftCode, hhead, leftCodeFrom_succ] + congr 1 + · show symCode (((t.write s).move Dir3.right).cells t.head) = _ + rw [Tape.move_cells, write_cells_head h] + · exact leftCodeFrom_congr fun j hj => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Moving left**: the nearest left symbol crosses over to the right half, so +the left half loses its first two bits. -/ +theorem leftCode_write_left {t : Tape} {s : Γ} (h : t.head ≠ 0) : + leftCode ((t.write s).move Dir3.left) = (leftCode t).drop 2 := by + have hhead : ((t.write s).move Dir3.left).head = t.head - 1 := by + rw [Tape.move, Tape.write_head] + obtain ⟨m, hm⟩ : ∃ m, t.head = m + 1 := ⟨t.head - 1, by omega⟩ + rw [leftCode, leftCode, hhead, hm, Nat.add_sub_cancel, leftCodeFrom_succ] + rw [show (symCode (t.cells m) ++ leftCodeFrom t m).drop 2 + = leftCodeFrom t m from by + rw [List.drop_left' (by simp)]] + exact leftCodeFrom_congr fun j hj => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Staying put**, right half: the leading symbol is replaced. -/ +theorem rightCode_write_stay {t : Tape} {s : Γ} {W : ℕ} (h : t.head ≠ 0) + (hW : t.head ≤ W) : + rightCode ((t.write s).move Dir3.stay) W = symCode s ++ (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.stay).head = t.head := Tape.write_head t s + rw [rightCode, rightCode, hhead, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, cellsCode_succ_left] + congr 1 + · show symCode ((t.write s).cells t.head) = _ + rw [write_cells_self h] + · rw [List.drop_left' (by simp)] + exact cellsCode_congr fun j _ => write_cells_of_ne (by omega) + +/-- **Moving right**, right half: the leading symbol is consumed. -/ +theorem rightCode_write_right {t : Tape} {s : Γ} {W : ℕ} (hW : t.head ≤ W) : + rightCode ((t.write s).move Dir3.right) W = (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.right).head = t.head + 1 := by + rw [Tape.move, Tape.write_head] + rw [rightCode, rightCode, hhead, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, List.drop_left' (by simp), + show W + 1 - (t.head + 1) = W - t.head from by omega] + exact cellsCode_congr fun j _ => by + rw [Tape.move_cells]; exact write_cells_of_ne (by omega) + +/-- **Moving left**, right half: the nearest left symbol and the written symbol +both join it. -/ +theorem rightCode_write_left {t : Tape} {s : Γ} {W : ℕ} (h : t.head ≠ 0) + (hW : t.head ≤ W) : + rightCode ((t.write s).move Dir3.left) W = + (leftCode t).take 2 ++ symCode s ++ (rightCode t W).drop 2 := by + have hhead : ((t.write s).move Dir3.left).head = t.head - 1 := by + rw [Tape.move, Tape.write_head] + obtain ⟨m, hm⟩ : ∃ m, t.head = m + 1 := ⟨t.head - 1, by omega⟩ + have hleft : (leftCode t).take 2 = symCode (t.cells m) := by + rw [leftCode, hm, leftCodeFrom_succ, List.take_left' (by simp)] + rw [rightCode, rightCode, hhead, hm, Nat.add_sub_cancel, hleft, + show W + 1 - m = (W - m) + 1 from by omega, cellsCode_succ_left, + show W + 1 - (m + 1) = (W - (m + 1)) + 1 from by omega, cellsCode_succ_left, + List.drop_left' (by simp), List.append_assoc] + have hwrite : (t.write s).cells (m + 1) = s := by + rw [← hm]; exact write_cells_self h + congr 1 + · show symCode (((t.write s).move Dir3.left).cells m) = _ + rw [Tape.move_cells] + exact congrArg symCode (write_cells_of_ne (by omega)) + · rw [show W - m = (W - (m + 1)) + 1 from by omega, cellsCode_succ_left] + congr 1 + · show symCode (((t.write s).move Dir3.left).cells (m + 1)) = _ + rw [Tape.move_cells] + exact congrArg symCode hwrite + · refine cellsCode_congr fun j _ => ?_ + rw [Tape.move_cells] + exact write_cells_of_ne (by omega) + +/-! ## Whole configurations + +Every field occupies a block of the same width, so field `i` is recovered by +`Cobham.blockFn … i` — the algebra never needs a self-delimiting decoder. A tape +costs two blocks (its two halves); the state costs one, padded to the same +width. -/ + +/-- The block width used throughout: wide enough for either half of a tape whose +head stays within `0 … W`. -/ +def blockWidth (W : ℕ) : ℕ := 2 * (W + 1) + +/-- The canonical ruler of one block's width. -/ +def blockRuler (W : ℕ) : List Bool := List.replicate (blockWidth W) false + +@[simp] theorem blockRuler_length (W : ℕ) : (blockRuler W).length = blockWidth W := by + simp [blockRuler] + +/-- A tape as two padded half-blocks: the cells left of the head (nearest first) +and the cells from the head rightwards. -/ +def tapeBlocks (W : ℕ) (t : Tape) : List (List Bool) := + [padTo (blockRuler W) (leftCode t), padTo (blockRuler W) (rightCode t W)] + +/-- Both halves of a tape occupy one block each. -/ +theorem tapeBlocks_width (W : ℕ) (t : Tape) : + ∀ b ∈ tapeBlocks W t, b.length = (blockRuler W).length := by + intro b hb + rw [blockRuler_length] + rcases List.mem_cons.mp hb with rfl | hb + · simp + · rcases List.mem_cons.mp hb with rfl | hb + · simp + · simp at hb + +@[simp] theorem tapeBlocks_length (W : ℕ) (t : Tape) : + (tapeBlocks W t).length = 2 := rfl + +/-- A tape as a bitstring: its two half-blocks concatenated. -/ +def tapeCode (W : ℕ) (t : Tape) : List Bool := (tapeBlocks W t).flatten + +@[simp] theorem tapeCode_length (W : ℕ) (t : Tape) : + (tapeCode W t).length = 2 * blockWidth W := by + rw [tapeCode, tapeBlocks, List.flatten_cons, List.flatten_cons, + List.flatten_nil, List.length_append, List.length_append, padTo_length, + padTo_length, blockRuler_length] + simp + omega + +/-- Blocks of a common width concatenate to a predictable length. -/ +private theorem length_flatMap_const {α β : Type} (l : List α) (f : α → List β) + (m : ℕ) (h : ∀ a, (f a).length = m) : (l.flatMap f).length = l.length * m := by + induction l with + | nil => simp + | cons a l ih => + rw [List.flatMap_cons, List.length_append, ih, h a, List.length_cons, + Nat.succ_mul] + exact Nat.add_comm _ _ + +/-- The work tapes, one after another. -/ +def worksCode {k : ℕ} (W : ℕ) (work : Fin k → Tape) : List Bool := + (List.finRange k).flatMap fun i => tapeCode W (work i) + +@[simp] theorem worksCode_length {k : ℕ} (W : ℕ) (work : Fin k → Tape) : + (worksCode W work).length = k * (2 * blockWidth W) := by + rw [worksCode, length_flatMap_const _ _ _ (fun i => tapeCode_length W (work i)), + List.length_finRange] + +/-! ### The window invariant + +A head moves at most one cell per step and starts at cell `0`, so after `t` steps +every head is within `0 … t`. Taking the window `W` to be the machine's time +bound therefore discharges the `head ≤ W` side condition of every encoding lemma +— the simulated machine can never reach outside the encoded window. -/ + +/-- After `t` steps from the initial configuration every head is at most `t`. -/ +theorem heads_le_of_reachesIn {k : ℕ} (tm : TM k) {x : List Bool} {t : ℕ} + {c : Cfg k tm.Q} (h : tm.reachesIn t (tm.initCfg x) c) : + c.input.head ≤ t ∧ c.output.head ≤ t ∧ ∀ i, (c.work i).head ≤ t := by + obtain ⟨hin, hout, hwork⟩ := TM.head_le_start_add_of_reachesIn tm h + exact ⟨by simpa using hin, by simpa using hout, fun i => by simpa using hwork i⟩ + +/-- **Reading a symbol out of an encoded tape.** The head symbol is the first two +bits of the padded right half-block — one `takeFn` in the algebra. -/ +theorem symDecode_take_padTo_rightCode {W : ℕ} (t : Tape) (hW : t.head ≤ W) : + symDecode ((padTo (blockRuler W) (rightCode t W)).take 2) = t.read := by + rw [take_padTo _ _ 2 (by rw [rightCode_length]; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth]; omega), + symDecode_take_two] + exact symDecode_rightCode t hW + +/-! ### One tape's step + +The encoded step on a tape's two half-blocks. Every right-hand side is +`take 2` / `drop 2` / `++` / a constant and a re-pad, so the algebra realizes it +with `Cobham.takeFn`, `Cobham.dropFn`, `Cobham.appendFn`, `Cobham.const` and +`Cobham.padFn` — and within one branch of `Cobham.tableFn` the symbol `s` and the +direction `d` are *constants*. -/ + +/-- The two half-blocks of a tape after writing `s` and moving `d`. -/ +def tapeStepBlocks (R : List Bool) (s : Γ) (d : Dir3) (L Rt : List Bool) : + List Bool × List Bool := + match d with + | .stay => (L, padTo R (symCode s ++ Rt.drop 2)) + | .right => (padTo R (symCode s ++ L), padTo R (Rt.drop 2)) + | .left => (padTo R (L.drop 2), padTo R (L.take 2 ++ symCode s ++ Rt.drop 2)) + +/-- **The encoded step simulates `Tape.writeAndMove`** on both half-blocks. + +The hypotheses are exactly what a real run supplies. `hs`: at cell `0` the write +is a no-op, so the transition's write constant must agree with `▷` there — which +it does, because `TM.δ_right_of_start` fires only in the branch whose read symbol +is `▷`. `hne`: for the same reason a head at cell `0` can only move *right*, so +the stay and left cases never arise there. -/ +theorem tapeStepBlocks_eq {W : ℕ} (t : Tape) (s : Γ) (d : Dir3) + (hs : t.head = 0 → s = t.cells t.head) + (hne : d ≠ Dir3.right → t.head ≠ 0) (hW : t.head ≤ W) : + tapeStepBlocks (blockRuler W) s d + (padTo (blockRuler W) (leftCode t)) (padTo (blockRuler W) (rightCode t W)) + = (padTo (blockRuler W) (leftCode ((t.write s).move d)), + padTo (blockRuler W) (rightCode ((t.write s).move d) W)) := by + have hLlen : (leftCode t).length ≤ (blockRuler W).length := by + rw [leftCode_length, blockRuler_length, blockWidth]; omega + have hRlen : (rightCode t W).length ≤ (blockRuler W).length := by + rw [rightCode_length, blockRuler_length, blockWidth]; omega + have hR2 : 2 ≤ (rightCode t W).length := by rw [rightCode_length]; omega + have hdrop : (padTo (blockRuler W) (rightCode t W)).drop 2 + = (rightCode t W).drop 2 ++ + List.replicate ((blockRuler W).length - (rightCode t W).length) false := + drop_padTo _ _ 2 hR2 hRlen + cases d with + | stay => + have h0 : t.head ≠ 0 := hne (by decide) + rw [tapeStepBlocks, leftCode_write_stay, rightCode_write_stay h0 hW, hdrop, + ← List.append_assoc, padTo_append_replicate] + | right => + rw [tapeStepBlocks, leftCode_write_right hs, rightCode_write_right hW, hdrop, + padTo_append_padTo _ _ _ hLlen, padTo_append_replicate] + | left => + have h0 : t.head ≠ 0 := hne (by decide) + have hL2 : 2 ≤ (leftCode t).length := by + rw [leftCode_length]; omega + rw [tapeStepBlocks, leftCode_write_left h0, rightCode_write_left h0 hW, + padTo_drop _ _ 2 hL2 hLlen, take_padTo _ _ 2 hL2 hLlen, hdrop, + ← List.append_assoc, padTo_append_replicate] + +/-! ### All the tapes at once + +`TM.step` writes and moves on every tape independently, so the encoded step is +the same operation applied tapewise. Treating the tapes as one list — input, work +tapes, output, the order the encoding uses — makes that a `List.zipWith` against +the transition's per-tape actions, with no positional index arithmetic. -/ + +/-- Writing back the symbol already under the head changes nothing. This is what +lets the read-only input tape take part in the uniform tapewise step: its action +is "write what you read, then move". -/ +theorem write_read_self (t : Tape) : t.write t.read = t := by + rw [Tape.write] + split + · rfl + · exact Tape.ext rfl (by rw [Tape.read]; exact Function.update_eq_self _ _) + +/-- All of a configuration's tapes in encoding order. -/ +def cfgTapes {k : ℕ} {Q : Type} (c : Cfg k Q) : List Tape := + c.input :: c.output :: List.ofFn c.work + +@[simp] theorem cfgTapes_length {k : ℕ} {Q : Type} (c : Cfg k Q) : + (cfgTapes c).length = k + 2 := by + rw [cfgTapes, List.length_cons, List.length_cons, List.length_ofFn] + +/-! ### The transition key + +The transition function is indexed by the current state together with the symbol +under every head. Packing those into one string turns the whole finite case +analysis into `Cobham.tableFn`: each (state, symbols) combination is a *constant* +pattern, and there are finitely many of them for a fixed machine. -/ + +/-- The state and the symbols under every head, in tape order. -/ +noncomputable def keyCode {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (c : Cfg k Q) : List Bool := + stateCode c.state ++ (cfgTapes c).flatMap fun t => symCode t.read + +@[simp] theorem keyCode_length {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (c : Cfg k Q) : (keyCode c).length = Fintype.card Q + 2 * (k + 2) := by + rw [keyCode, List.length_append, stateCode_length, + length_flatMap_const (cfgTapes c) (fun t => symCode t.read) 2 + (fun t => symCode_length t.read), cfgTapes_length, Nat.mul_comm] + +/-- The first two bits of a tape's right half-block are its read symbol. -/ +theorem take_rightCode (t : Tape) {W : ℕ} (hW : t.head ≤ W) : + (rightCode t W).take 2 = symCode t.read := by + rw [rightCode, show W + 1 - t.head = (W - t.head) + 1 from by omega, + cellsCode_succ_left, List.take_left' (by simp)] + rfl + + +/-- The blocks of a list of tapes: two per tape. -/ +def tapesBlocks (W : ℕ) (ts : List Tape) : List (List Bool) := + ts.flatMap (tapeBlocks W) + +@[simp] theorem tapesBlocks_length (W : ℕ) (ts : List Tape) : + (tapesBlocks W ts).length = 2 * ts.length := by + rw [tapesBlocks, length_flatMap_const _ _ 2 (fun t => tapeBlocks_length W t)] + omega + +/-- The tapes after one step, given each tape's write and move. -/ +def tapesStep (acts : List (Γ × Dir3)) (ts : List Tape) : List Tape := + List.zipWith (fun a t => (t.write a.1).move a.2) acts ts + +/-- `zipWith` over two tuples is the tuple of the pointwise results. -/ +private theorem zipWith_ofFn {α β γ : Type} {n : ℕ} (f : α → β → γ) + (g : Fin n → α) (h : Fin n → β) : + List.zipWith f (List.ofFn g) (List.ofFn h) = List.ofFn fun i => f (g i) (h i) := by + induction n with + | zero => rfl + | succ n ih => + rw [List.ofFn_succ, List.ofFn_succ, List.ofFn_succ, List.zipWith_cons_cons, ih] + +/-- The write a transition *really* performs: at cell `0` the model makes the +write a no-op, and this records that. Under `Tape.StartInvariant` the test is on +the **read symbol**, which the transition table already branches on — so the +correction costs the algebra nothing, it just picks a different constant in the +`▷` branch. -/ +def correctWriteSym (r s : Γ) : Γ := if r = Γ.start then Γ.start else s + +/-- The corrected write on a tape — a function of its read symbol alone, which is +what puts it inside the transition key. -/ +def correctWrite (t : Tape) (s : Γ) : Γ := correctWriteSym t.read s + +/-- Correcting the write does not change what the write does. -/ +theorem write_correctWrite {t : Tape} (s : Γ) (h : t.StartInvariant) : + t.write (correctWrite t s) = t.write s := by + rw [correctWrite, correctWriteSym] + split + · next hr => + have hh : t.head = 0 := by + by_contra hne + exact h.read_ne_start (by omega) hr + rw [Tape.write, if_pos hh, Tape.write, if_pos hh] + · rfl + +/-- Under the invariant, the corrected write agrees with cell `0` when the head +is there — the hypothesis `tapeStepBlocks_eq` needs. -/ +theorem correctWrite_at_zero {t : Tape} (s : Γ) (h : t.StartInvariant) + (hh : t.head = 0) : correctWrite t s = t.cells t.head := by + have hr : t.read = Γ.start := by rw [Tape.read, hh]; exact h.1 + rw [correctWrite, correctWriteSym, if_pos hr] + show Γ.start = t.cells t.head + rw [hh] + exact h.1.symm + +/-- The per-tape (write, move) actions a transition prescribes, in encoding +order. The input tape's "write" is the symbol it just read, which by +`write_read_self` leaves it unchanged — so the read-only input tape fits the +uniform tapewise step with no special case. -/ +def stepActs {k : ℕ} (tm : TM k) (c : Cfg k tm.Q) : List (Γ × Dir3) := + let d := tm.δ c.state c.input.read (fun i => (c.work i).read) c.output.read + (c.input.read, d.2.2.2.1) :: + (correctWrite c.output d.2.2.1.toΓ, d.2.2.2.2.2) :: + List.ofFn fun i => (correctWrite (c.work i) (d.2.1 i).toΓ, d.2.2.2.2.1 i) + +/-! ### The transition key determines the step + +Everything the successor configuration depends on — the new state and every +tape's write and direction — is a function of the state together with the symbol +under each head. That is exactly what a `Cobham.tableFn` entry can be indexed by, +and it is why any entry matching a configuration's key carries the right +branch. -/ + +/-- The symbols under a configuration's heads, in `cfgTapes` order. -/ +def cfgReads {k : ℕ} {Q : Type} (c : Cfg k Q) : Fin (k + 2) → Γ := + Fin.cons c.input.read (Fin.cons c.output.read fun i => (c.work i).read) + +/-- A transition key's pattern string: the state's one-hot code followed by the +symbol under each head. Constant for each key, so it is what a +`Cobham.tableFn` entry matches against. -/ +noncomputable def keyPattern {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (p : Q × (Fin (k + 2) → Γ)) : List Bool := + stateCode p.1 ++ (List.ofFn p.2).flatMap symCode + +@[simp] theorem keyPattern_length {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (p : Q × (Fin (k + 2) → Γ)) : + (keyPattern p).length = Fintype.card Q + 2 * (k + 2) := by + rw [keyPattern, List.length_append, stateCode_length, + length_flatMap_const (List.ofFn p.2) symCode 2 symCode_length, List.length_ofFn, + Nat.mul_comm] + +/-- Runs of coded symbols determine their symbols. -/ +private theorem flatMap_symCode_injective : + ∀ l₁ l₂ : List Γ, l₁.length = l₂.length → + l₁.flatMap symCode = l₂.flatMap symCode → l₁ = l₂ := by + intro l₁ + induction l₁ with + | nil => intro l₂ hlen _; exact (List.length_eq_zero_iff.mp hlen.symm).symm + | cons a l₁ ih => + intro l₂ hlen heq + cases l₂ with + | nil => simp at hlen + | cons b l₂ => + rw [List.flatMap_cons, List.flatMap_cons] at heq + obtain ⟨h1, h2⟩ := List.append_inj heq (by simp) + rw [symCode_injective h1, ih l₂ (by simpa using hlen) h2] + +/-- **Distinct keys get distinct patterns.** Together with the fact that all +patterns have the same length, this is what makes at most one table entry match a +given key. -/ +theorem keyPattern_injective {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] : + Function.Injective (keyPattern (k := k) (Q := Q)) := by + rintro ⟨q₁, s₁⟩ ⟨q₂, s₂⟩ h + rw [keyPattern, keyPattern] at h + obtain ⟨h1, h2⟩ := List.append_inj h (by simp) + have hq := stateCode_injective h1 + have hs := flatMap_symCode_injective _ _ (by simp) h2 + subst hq + simp only [Prod.mk.injEq, true_and] + exact List.ofFn_inj.mp hs + +/-- The tapes' read symbols, listed, are the configuration's read tuple. -/ +theorem cfgTapes_map_read {k : ℕ} {Q : Type} (c : Cfg k Q) : + (cfgTapes c).map Tape.read = List.ofFn (cfgReads c) := by + rw [cfgTapes, cfgReads] + simp [List.ofFn_succ, Function.comp_def] + +/-- **A configuration's key is its key's pattern.** So the table entry indexed by +`(state, reads)` is the one that matches. -/ +theorem keyCode_eq {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] (c : Cfg k Q) : + keyCode c = keyPattern (c.state, cfgReads c) := by + rw [keyCode, keyPattern] + congr 1 + rw [← cfgTapes_map_read] + simp [List.flatMap_map] + +/-- The per-tape actions determined by a transition key. -/ +def stepActsOf {k : ℕ} (tm : TM k) (q : tm.Q) (syms : Fin (k + 2) → Γ) : + List (Γ × Dir3) := + let d := tm.δ q (syms 0) (fun i => syms i.succ.succ) (syms 1) + (syms 0, d.2.2.2.1) :: + (correctWriteSym (syms 1) d.2.2.1.toΓ, d.2.2.2.2.2) :: + List.ofFn fun i => + (correctWriteSym (syms i.succ.succ) (d.2.1 i).toΓ, d.2.2.2.2.1 i) + +/-- The successor state determined by a transition key. -/ +def stepStateOf {k : ℕ} (tm : TM k) (q : tm.Q) (syms : Fin (k + 2) → Γ) : tm.Q := + (tm.δ q (syms 0) (fun i => syms i.succ.succ) (syms 1)).1 + +/-- The actions a configuration prescribes are the ones its key prescribes. -/ +theorem stepActs_eq_stepActsOf {k : ℕ} (tm : TM k) (c : Cfg k tm.Q) : + stepActs tm c = stepActsOf tm c.state (cfgReads c) := rfl + +/-- The successor state is the one the key prescribes. -/ +theorem step_state_eq {k : ℕ} (tm : TM k) {c c' : Cfg k tm.Q} + (h : tm.step c = some c') : c'.state = stepStateOf tm c.state (cfgReads c) := by + have hne : ¬ c.state = tm.qhalt := fun hq => by simp [TM.step, hq] at h + rw [TM.step, if_neg hne] at h + injection h with h + subst h + rfl + +/-- **`TM.step` is the tapewise action.** Every tape writes and moves according +to `stepActs`, so the whole configuration's tapes step uniformly. -/ +theorem cfgTapes_step {k : ℕ} (tm : TM k) {c c' : Cfg k tm.Q} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : ∀ i, (c.work i).StartInvariant) : + cfgTapes c' = tapesStep (stepActs tm c) (cfgTapes c) := by + have hne : ¬ c.state = tm.qhalt := fun hq => by simp [TM.step, hq] at h + rw [TM.step, if_neg hne] at h + injection h with h + subst h + rw [cfgTapes, cfgTapes, stepActs, tapesStep] + dsimp only + rw [List.zipWith_cons_cons, List.zipWith_cons_cons, zipWith_ofFn] + dsimp only + simp only [write_read_self, write_correctWrite _ hout, + write_correctWrite _ (hwork _)] + +/-- **One tape's blocks after a step.** Immediate from `tapeStepBlocks_eq`; this +is the form that lifts tapewise across a whole configuration. -/ +theorem tapeBlocks_step {W : ℕ} (a : Γ × Dir3) (t : Tape) + (hs : t.head = 0 → a.1 = t.cells t.head) + (hne : a.2 ≠ Dir3.right → t.head ≠ 0) (hW : t.head ≤ W) : + tapeBlocks W ((t.write a.1).move a.2) = + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2] := by + rw [tapeStepBlocks_eq t a.1 a.2 hs hne hW] + rfl + +/-- The tapewise step acts blockwise on the encoding. -/ +theorem tapesBlocks_tapesStep {W : ℕ} : + ∀ (acts : List (Γ × Dir3)) (ts : List Tape), + List.Forall₂ (fun (a : Γ × Dir3) (t : Tape) => + (t.head = 0 → a.1 = t.cells t.head) ∧ + (a.2 ≠ Dir3.right → t.head ≠ 0) ∧ t.head ≤ W) acts ts → + tapesBlocks W (tapesStep acts ts) = + (List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) acts ts).flatten := by + intro acts ts h + induction h with + | nil => rfl + | @cons a t acts ts hat _ ih => + rw [tapesStep, List.zipWith_cons_cons, tapesBlocks, List.flatMap_cons, + tapeBlocks_step a t hat.1 hat.2.1 hat.2.2, List.zipWith_cons_cons, + List.flatten_cons] + exact congrArg (List.append _) ih + +/-- A whole configuration as a list of equal-width blocks: the one-hot state +padded to a block, then the input tape, the work tapes, and the output tape, +each as two half-blocks. -/ +noncomputable def cfgBlocks {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : List (List Bool) := + padTo (blockRuler W) (stateCode c.state) :: tapesBlocks W (cfgTapes c) + +theorem cfgBlocks_eq {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + cfgBlocks W c = + padTo (blockRuler W) (stateCode c.state) :: tapesBlocks W (cfgTapes c) := rfl + +/-- Every field of a configuration occupies exactly one block. -/ +theorem cfgBlocks_width {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + ∀ b ∈ cfgBlocks W c, b.length = (blockRuler W).length := by + intro b hb + rw [cfgBlocks, List.mem_cons] at hb + rcases hb with rfl | hb + · simp + · obtain ⟨t, _, ht⟩ := List.mem_flatMap.mp hb + exact tapeBlocks_width W t b ht + +/-- A whole configuration as a bitstring. -/ +noncomputable def cfgCode {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : List Bool := (cfgBlocks W c).flatten + +/-- **Field access.** Block `i` of an encoded configuration is field `i` — so +`Cobham.blockFn … i` reads it, and no self-delimiting decoder is ever needed. -/ +theorem blockAt_cfgCode {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (i : ℕ) (hi : i < (cfgBlocks W c).length) : + blockAt (blockRuler W) (cfgCode W c) i = (cfgBlocks W c)[i] := + blockAt_flatten _ _ (cfgBlocks_width W c) i hi + +/-- A configuration has `2(k+2) + 1` blocks: one per tape half plus the state. -/ +@[simp] theorem cfgBlocks_length {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : (cfgBlocks W c).length = 2 * (k + 2) + 1 := by + rw [cfgBlocks, List.length_cons, tapesBlocks, + length_flatMap_const _ _ 2 (fun t => tapeBlocks_length W t), cfgTapes_length] + omega + +/-- **The encoded configuration steps blockwise.** Composing `cfgTapes_step` +(`TM.step` is the tapewise action) with `tapesBlocks_tapesStep` (that action is +blockwise on the encoding): the successor's blocks are the new state block +followed by the old blocks transformed two at a time by `tapeStepBlocks`. + +The `Forall₂` hypothesis pairs each tape with its own action, which is what a run +supplies: `δ_right_of_start` constrains a tape at cell `0` only through *its own* +transition entry. -/ +theorem cfgBlocks_step {k : ℕ} (tm : TM k) {c c' : Cfg k tm.Q} {W : ℕ} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : ∀ i, (c.work i).StartInvariant) + (hgood : List.Forall₂ (fun (a : Γ × Dir3) (t : Tape) => + (t.head = 0 → a.1 = t.cells t.head) ∧ + (a.2 ≠ Dir3.right → t.head ≠ 0) ∧ t.head ≤ W) (stepActs tm c) (cfgTapes c)) : + cfgBlocks W c' = + padTo (blockRuler W) (stateCode c'.state) :: + (List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) + (stepActs tm c) (cfgTapes c)).flatten := by + rw [cfgBlocks, cfgTapes_step tm h hout hwork, + tapesBlocks_tapesStep (stepActs tm c) (cfgTapes c) hgood] + +/-- `Forall₂` over two tuples follows pointwise. -/ +private theorem forall₂_ofFn {α β : Type} {R : α → β → Prop} {n : ℕ} + {f : Fin n → α} {g : Fin n → β} (h : ∀ i, R (f i) (g i)) : + List.Forall₂ R (List.ofFn f) (List.ofFn g) := by + induction n with + | zero => exact List.Forall₂.nil + | succ n ih => + rw [List.ofFn_succ, List.ofFn_succ] + exact List.Forall₂.cons (h 0) (ih fun i => h i.succ) + +/-- **The step's side conditions hold in any run.** The write-agreement at cell +`0` is `correctWrite_at_zero`, and "a head at cell `0` can only move right" is +exactly `TM.δ_right_of_start` read through the invariant: at cell `0` the tape +reads `▷`, which is the hypothesis that rule fires on. -/ +theorem stepActs_forall₂ {k : ℕ} (tm : TM k) (c : Cfg k tm.Q) {W : ℕ} + (hinv : ∀ t ∈ cfgTapes c, t.StartInvariant) + (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) : + List.Forall₂ (fun (a : Γ × Dir3) (t : Tape) => + (t.head = 0 → a.1 = t.cells t.head) ∧ + (a.2 ≠ Dir3.right → t.head ≠ 0) ∧ t.head ≤ W) + (stepActs tm c) (cfgTapes c) := by + obtain ⟨hri, hrw, hro⟩ := + tm.δ_right_of_start c.state c.input.read (fun i => (c.work i).read) c.output.read + have hmem_in : c.input ∈ cfgTapes c := by simp [cfgTapes] + have hmem_out : c.output ∈ cfgTapes c := by simp [cfgTapes] + have hmem_work : ∀ i, c.work i ∈ cfgTapes c := fun i => by + simp only [cfgTapes, List.mem_cons] + exact Or.inr (Or.inr (List.mem_ofFn.mpr ⟨i, rfl⟩)) + -- At cell `0` a tape reads `▷`, which is what `δ_right_of_start` fires on. + have hzero : ∀ t ∈ cfgTapes c, t.head = 0 → t.read = Γ.start := fun t ht h0 => by + rw [Tape.read, h0]; exact (hinv t ht).1 + rw [stepActs, cfgTapes] + refine List.Forall₂.cons ⟨fun _ => rfl, fun hd h0 => hd ?_, hW _ hmem_in⟩ + (List.Forall₂.cons + ⟨fun h0 => correctWrite_at_zero _ (hinv _ hmem_out) h0, + fun hd h0 => hd ?_, hW _ hmem_out⟩ + (forall₂_ofFn fun i => + ⟨fun h0 => correctWrite_at_zero _ (hinv _ (hmem_work i)) h0, + fun hd h0 => hd ?_, hW _ (hmem_work i)⟩)) + · exact hri (hzero _ hmem_in h0) + · exact hro (hzero _ hmem_out h0) + · exact hrw i (hzero _ (hmem_work i) h0) + +/-- **Tape `j` lives in blocks `2j` and `2j+1`** of the tape-block list. Combined +with the state block at the front of `cfgBlocks`, tape `j` of a configuration +occupies blocks `2j+1` and `2j+2` — which is how `Cobham.blockFn` addresses +them. -/ +theorem getElem?_tapesBlocks (W : ℕ) : + ∀ (ts : List Tape) (j : ℕ), + (tapesBlocks W ts)[2 * j]? = + (ts[j]?).map (fun t => padTo (blockRuler W) (leftCode t)) ∧ + (tapesBlocks W ts)[2 * j + 1]? = + (ts[j]?).map (fun t => padTo (blockRuler W) (rightCode t W)) := by + intro ts + induction ts with + | nil => intro j; simp [tapesBlocks] + | cons t ts ih => + intro j + cases j with + | zero => simp [tapesBlocks, tapeBlocks] + | succ j => + have hlen : (tapeBlocks W t).length = 2 := rfl + have e1 : 2 * (j + 1) = (tapeBlocks W t).length + 2 * j := by + rw [hlen]; omega + rw [tapesBlocks, List.flatMap_cons, e1, + List.getElem?_append_right (by omega), + List.getElem?_append_right (by omega)] + simp only [Nat.add_sub_cancel_left, List.getElem?_cons_succ, + show (tapeBlocks W t).length + 2 * j + 1 - (tapeBlocks W t).length + = 2 * j + 1 from by omega] + exact ⟨(ih j).1, (ih j).2⟩ + +/-! ### Field accessors + +The first three blocks — the state and the input tape's two halves — read out +directly. Each is one `Cobham.blockFn` on the algebra side. -/ + +/-- Block `0` holds the state. -/ +theorem blockAt_cfgCode_state {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 0 + = padTo (blockRuler W) (stateCode c.state) := by + rw [blockAt_cfgCode W c 0 (by simp)] + rfl + +/-- Unpadding block `0` recovers the one-hot state code, which the transition +table then matches against its finitely many constants. -/ +theorem state_of_cfgCode {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (hW : Fintype.card Q ≤ blockWidth W) : + (blockAt (blockRuler W) (cfgCode W c) 0).take (Fintype.card Q) + = stateCode c.state := by + rw [blockAt_cfgCode_state, + take_padTo _ _ _ (by simp) (by rw [stateCode_length, blockRuler_length]; omega), + List.take_of_length_le (by simp)] + +/-- Block `1` is the input tape's left half. -/ +theorem blockAt_cfgCode_inputLeft {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 1 + = padTo (blockRuler W) (leftCode c.input) := by + rw [blockAt_cfgCode W c 1 (by simp)] + rfl + +/-- Block `2` is the input tape's right half — the one the read symbol comes +from. -/ +theorem blockAt_cfgCode_inputRight {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + blockAt (blockRuler W) (cfgCode W c) 2 + = padTo (blockRuler W) (rightCode c.input W) := by + rw [blockAt_cfgCode W c 2 (by rw [cfgBlocks_length]; omega)] + rfl + +/-- The input head's symbol, read straight out of the encoding. -/ +theorem inputRead_of_cfgCode {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (hW : c.input.head ≤ W) : + symDecode ((blockAt (blockRuler W) (cfgCode W c) 2).take 2) = c.input.read := by + rw [blockAt_cfgCode_inputRight] + exact symDecode_take_padTo_rightCode c.input hW + + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Extract.lean b/Complexitylib/Classes/P/Cobham/Internal/Extract.lean new file mode 100644 index 00000000..39011c32 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Extract.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.Blocks +public import Complexitylib.Classes.P.Cobham.Internal.Algebra + +/-! +# Reading a string out of an encoded tape — proof internals + +The completeness direction ends by reading the simulated machine's output off +its encoded output tape. Once the output head has been driven back to cell `0` +(see `Complexitylib.Classes.P.Cobham.Internal.StepAlgebra`), that tape's right +half-block is the whole tape in order, two bits per cell: the first bit of a +cell says whether it holds data, the second is the data bit. + +So the output is recovered by two short recursions on notation, both collected +here: + +* `Complexity.cellBits` — every second bit of a string, from a fixed offset; + used twice, once for the "is data" bits and once for the data bits; +* `Complexity.runTrue` — the leading run of `true`s, as a ruler; its length is + where the first blank cell is, hence the output's length. + +## Main results + +- `Complexity.Cobham.cellBitsFn`, `Complexity.Cobham.runTrueFn` — both are in + the algebra +- `Complexity.runTrue_length` — the run's length is where the first `false` is, + clamped by the ruler +-/ + + +@[expose] public section + +namespace Complexity + +/-! ## Reading a single bit -/ + +/-- The bit of `z` at position `p`, `false` past the end. -/ +def bitOf (z : List Bool) (p : ℕ) : Bool := (z.drop p).headD false + +/-- Within range, `bitOf` is the indexed bit. -/ +theorem bitOf_eq_getElem {z : List Bool} {p : ℕ} (h : p < z.length) : + bitOf z p = z[p] := by + rw [bitOf, List.drop_eq_getElem_cons h, List.headD_cons] + +/-- Past the end there is no bit. -/ +theorem bitOf_of_le {z : List Bool} {p : ℕ} (h : z.length ≤ p) : + bitOf z p = false := by + rw [bitOf, List.drop_eq_nil_of_le h, List.headD_nil] + +/-- Reading inside the first part of a concatenation. -/ +theorem bitOf_append_left {a : List Bool} {p : ℕ} (h : p < a.length) (b : List Bool) : + bitOf (a ++ b) p = bitOf a p := by + rw [bitOf, bitOf, List.drop_append_of_le_length h.le, List.drop_eq_getElem_cons h] + rw [List.cons_append, List.headD_cons, List.headD_cons] + +/-- Reading past the first part of a concatenation. -/ +theorem bitOf_append_right {a : List Bool} {p : ℕ} (h : a.length ≤ p) (b : List Bool) : + bitOf (a ++ b) p = bitOf b (p - a.length) := by + rw [bitOf, bitOf, List.drop_append, List.drop_eq_nil_of_le h, List.nil_append] + +/-- `Cobham.bitAt` reads exactly one bit, and it is `bitOf`. -/ +theorem bitAt_eq (r z : List Bool) : bitAt r z = [bitOf z r.length] := by + rw [bitAt, bitOf] + cases h : z.drop r.length with + | nil => rw [caseBit₀_nil, List.headD_nil] + | cons b l => cases b <;> rw [caseBit₀_cons] <;> rfl + +/-! ## Every second bit + +`cellBits o z m` lists the bits of `z` at positions `o, o + 2, …, o + 2(m-1)`. +With `z` a run of two-bit symbol codes, offset `o` picks out one bit of each +symbol — which is how both halves of a coded cell are read. -/ + +/-- The bits of `z` at positions `2i + o` for `i < m`. -/ +def cellBits (o : ℕ) (z : List Bool) : ℕ → List Bool + | 0 => [] + | m + 1 => cellBits o z m ++ [bitOf z (2 * m + o)] + +@[simp] theorem cellBits_length (o : ℕ) (z : List Bool) (m : ℕ) : + (cellBits o z m).length = m := by + induction m with + | zero => rfl + | succ m ih => rw [cellBits, List.length_append, ih]; rfl + +theorem cellBits_getElem? (o : ℕ) (z : List Bool) : + ∀ (m i : ℕ), i < m → (cellBits o z m)[i]? = some (bitOf z (2 * i + o)) := by + intro m + induction m with + | zero => intro i h; omega + | succ m ih => + intro i h + rw [cellBits] + rcases Nat.lt_or_ge i m with hi | hi + · rw [List.getElem?_append_left (by simpa using hi)] + exact ih i hi + · have him : i = m := by omega + subst him + rw [List.getElem?_append_right (by simp)] + simp + +/-! ## The leading run of `true`s + +The output tape's "is data" bits are `true` on the output and `false` at the +first blank past it, so the output's length is the length of the leading run of +`true`s. The recursion below computes it as a ruler, clamped at the width it is +run to: the guard `m ≤ |previous|` is what stops the run at the first `false` +rather than restarting after it. -/ + +/-- The leading run of `true`s of `z`, clamped to `m` bits, as a ruler. -/ +def runTrue (z : List Bool) : ℕ → List Bool + | 0 => [] + | m + 1 => + runTrue z m ++ (if m ≤ (runTrue z m).length ∧ bitOf z m = true then [true] else []) + +theorem runTrue_length_le (z : List Bool) (m : ℕ) : (runTrue z m).length ≤ m := by + induction m with + | zero => rfl + | succ m ih => + rw [runTrue, List.length_append] + split <;> simp <;> omega + +/-- **The run's length is where the first `false` is.** The guard in `runTrue` +stops the run at the first `false` rather than restarting after it, so the run's +length is the position of the first `false`, clamped by the width. -/ +theorem runTrue_length {z : List Bool} {n : ℕ} (htrue : ∀ i < n, bitOf z i = true) + (hfalse : bitOf z n = false) (m : ℕ) : + (runTrue z m).length = min m n := by + induction m with + | zero => simp [runTrue] + | succ m ih => + rw [runTrue, List.length_append, ih] + rcases Nat.lt_or_ge m n with hm | hm + · rw [if_pos ⟨by omega, htrue m hm⟩] + simp only [List.length_cons, List.length_nil] + omega + · rw [if_neg ?_] + · simp only [List.length_nil] + omega + · rintro ⟨h1, h2⟩ + have hme : m = n := by omega + rw [hme, hfalse] at h2 + exact Bool.noConfusion h2 + +/-! ## Both recursions are in the algebra -/ + +namespace Cobham + +/-- The step of `cellBits`: append the bit of the string at twice the remaining +ruler's length, plus the offset. -/ +private def cellStep (o : ℕ) (w : Fin 3 → List Bool) : List Bool := + w 1 ++ bitAt (w 0 ++ w 0 ++ List.replicate o false) (w 2) + +private theorem cellStep_cons (o : ℕ) (x p : List Bool) (v : Fin 1 → List Bool) : + cellStep o (Fin.cons x (Fin.cons p v)) + = p ++ bitAt (x ++ x ++ List.replicate o false) (v 0) := rfl + +/-- The step of `runTrue`: extend the run by one only when it has kept pace with +the ruler so far and the next bit is `true`. -/ +private def runStep (w : Fin 3 → List Bool) : List Bool := + w 1 ++ caseBit₀ + (andBit (notBit (nonemptyFlag ((w 0).drop (w 1).length))) (bitAt (w 0) (w 2))) + [true] [] + +private theorem runStep_cons (x p : List Bool) (v : Fin 1 → List Bool) : + runStep (Fin.cons x (Fin.cons p v)) + = p ++ caseBit₀ + (andBit (notBit (nonemptyFlag (x.drop p.length))) (bitAt x (v 0))) [true] [] := + rfl + +/-- **Every second bit is in the algebra.** One limited recursion on notation: +each peeled bit of the ruler appends one more bit of `z`, read at twice the +remaining ruler's length plus the offset. -/ +theorem cellBitsFn {n : ℕ} (o : ℕ) {gr gz : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => cellBits o (gz v) (gr v).length := by + have hrec : ∀ (x : List Bool) (v : Fin 1 → List Bool), + recNotation (fun _ : Fin 1 → List Bool => ([] : List Bool)) (cellStep o) + (cellStep o) x v = cellBits o (v 0) x.length := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + have hlen : (x ++ x ++ List.replicate o false).length = 2 * x.length + o := by + simp; omega + cases b <;> + · rw [recNotation_cons] + simp only [cond_true, cond_false] + rw [cellStep_cons, ih, bitAt_eq, hlen, List.length_cons, cellBits] + have hh : Cobham (cellStep o) := + (appendFn (Cobham.proj 1) + (comp₂ bitAtFn + (appendFn (appendFn (Cobham.proj 0) (Cobham.proj 0)) + (Cobham.const (List.replicate o false))) + (Cobham.proj 2))).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 2 → List Bool => cellBits o (v 1) (v 0).length := by + refine (Cobham.boundedRec Cobham.empty hh hh (Cobham.proj 0) ?_).of_eq fun v => ?_ + · intro x v + rw [hrec, cellBits_length, Fin.cons_zero] + · rw [hrec]; rfl + exact (comp₂ hbase hr hz).of_eq fun _ => rfl + +/-- **The leading run of `true`s is in the algebra.** One limited recursion on +notation: the run grows by one only while it has kept pace with the ruler, which +is the length comparison `nonemptyFn`/`notFn` performs. -/ +theorem runTrueFn {n : ℕ} {gr gz : (Fin n → List Bool) → List Bool} + (hr : Cobham gr) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => runTrue (gz v) (gr v).length := by + have hrec : ∀ (x : List Bool) (v : Fin 1 → List Bool), + recNotation (fun _ : Fin 1 → List Bool => ([] : List Bool)) runStep runStep x v + = runTrue (v 0) x.length := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + cases b <;> + · rw [recNotation_cons] + simp only [cond_true, cond_false] + rw [runStep_cons, ih, bitAt_eq, List.length_cons, runTrue] + congr 1 + rcases Nat.lt_or_ge (runTrue (v 0) x.length).length x.length with hlt | hge + · rw [if_neg (by omega)] + cases hd : x.drop (runTrue (v 0) x.length).length with + | nil => rw [List.drop_eq_nil_iff] at hd; omega + | cons c l => cases c <;> rfl + · rw [List.drop_eq_nil_of_le hge] + cases hb : bitOf (v 0) x.length + · rw [if_neg (by simp)]; rfl + · rw [if_pos ⟨hge, rfl⟩]; rfl + have hh : Cobham runStep := + (appendFn (Cobham.proj 1) + (iteFn + (andFn (notFn (nonemptyFn (dropFn (Cobham.proj 1) (Cobham.proj 0)))) + (comp₂ bitAtFn (Cobham.proj 0) (Cobham.proj 2))) + (Cobham.const [true]) Cobham.empty)).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 2 → List Bool => runTrue (v 1) (v 0).length := by + refine (Cobham.boundedRec Cobham.empty hh hh (Cobham.proj 0) ?_).of_eq fun v => ?_ + · intro x v + rw [hrec, Fin.cons_zero] + exact runTrue_length_le _ _ + · rw [hrec]; rfl + exact (comp₂ hbase hr hz).of_eq fun _ => rfl + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean b/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean new file mode 100644 index 00000000..d1dba8d8 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/FstBlock.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.Counter +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# The block-payload decoder — proof internals + +`Cobham.fstBlockTM` is the same scan as `Cobham.sndBlockTM`, emitting each +decoded payload bit as it goes and stopping at the separator. Malformed input +halts with empty output. + +## Main results + +- `Cobham.fstBlock_mem_FP` — the payload decoder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- The payload decoder: scan doubled payload bits, emitting each decoded bit to +the output, until the `[false, true]` separator or end of input. Computes +`fstBlock`. -/ +def fstBlockTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Γ.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Γ.zero => + (.scanA, fun i => readBackWrite (wHeads i), Γw.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Γ.one => + (.scanA, fun i => readBackWrite (wHeads i), Γw.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => allIdle .done iHead wHeads oHead + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => exact rightOfStart_allIdle iHead wHeads oHead + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The scan of `fstBlockTM`: from `scanA` on input `w` with output holding `acc`, +the machine emits the decoded payload of `w`, halting with `acc ++ fstBlock w`. -/ +private theorem fstBlockTM_scan_loop : + ∀ (fuel : ℕ) (w acc : List Bool), w.length ≤ fuel → ∀ (c : Cfg 0 fstBlockTM.Q), + c.state = ScanPhase.scanA → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ 2 * w.length + 2 ∧ fstBlockTM.reachesIn t c c' ∧ fstBlockTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ fstBlock w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Γ.blank := hsuf.read_nil + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, fstBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, fstBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | [false] => + have hread : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, fstBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | [true] => + have hread : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, fstBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: true :: y => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, fstBlockTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true :: false :: rest => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, fstBlockTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: false :: z => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool false) Dir3.right } + have hstepB : fstBlockTM.step c1 = some c2 := by + simp [TM.step, fstBlockTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Γw.ofBool false).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (false :: false :: z) = false :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + | true :: true :: z => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : fstBlockTM.step c = some c1 := by + simp [TM.step, hstate, fstBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool true) Dir3.right } + have hstepB : fstBlockTM.step c1 = some c2 := by + simp [TM.step, fstBlockTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Γw.ofBool true).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (true :: true :: z) = true :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + +/-- `fstBlock` is polynomial-time, via the `fstBlockTM` scanner. -/ +theorem fstBlock_mem_FP : fstBlock ∈ FP := by + refine ⟨1, 0, fstBlockTM, (fun m => 2 * m + 3), ?_, ?_⟩ + · intro z + let c1 : Cfg 0 fstBlockTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : fstBlockTM.step (fstBlockTM.initCfg z) = some c1 := by + simp [TM.step, fstBlockTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + fstBlockTM_scan_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≤ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + · have hn : (fun m : ℕ => 2 * m) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun m : ℕ => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean b/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean new file mode 100644 index 00000000..d40d9856 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/HeadFlag.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Models.TuringMachine.Subroutines + +/-! +# Testing a leading bit — proof internals + +Every other `FP` primitive the Cobham proof uses — `Complexity.takeLen`, +`List.reverse`, `Complexity.pair`, `Cobham.mulUnpair` — fixes its output's +*length* from its inputs' lengths alone, so none of them can react to a bit's +value. `Complexity.headFlag` closes that gap by turning a bit test into a length: +the answer is carried by whether the result is empty. Its two-state transducer +moves off the left-end marker, then emits one bit exactly when the first input +bit matches. + +## Main results + +- `Complexity.headFlag_mem_FP` — the leading-bit test is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-- `[false]` when `x` begins with `target`, and `[]` otherwise: a bit test whose +answer is carried by the *length* of the result. -/ +def headFlag (target : Bool) (x : List Bool) : List Bool := + if x.head? = some target then [false] else [] + +/-- Control states of the head-bit flag machine. -/ +inductive HeadPhase where + /-- Advance past the left-end markers. -/ + | skip + /-- Read the first input bit. -/ + | test + /-- Halted. -/ + | done + deriving DecidableEq + +instance instFintypeHeadPhase : Fintype HeadPhase where + elems := {.skip, .test, .done} + complete := fun p => by cases p <;> simp + +/-- Read the first input bit and emit one output bit exactly when it is +`target`. Two steps: `skip` moves off the left-end markers, `test` reads the bit +and either writes or not. -/ +def headFlagTM (target : Bool) : TM 0 where + Q := HeadPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.test, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .test => + if iHead = Γ.ofBool target then + (.done, fun i => readBackWrite (wHeads i), Γw.zero, idleDir iHead, + fun i => idleDir (wHeads i), Dir3.right) + else + (.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 + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .test => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Writing back the symbol already under the head changes nothing. -/ +private theorem write_read_self' (t : Tape) : t.write t.read = t := by + rw [Tape.write] + split + · rfl + · exact Tape.ext rfl (Function.update_eq_self _ _) + +/-- The input's first cell after the marker holds the first bit, or blank. -/ +private theorem headFlagTM_read (x : List Bool) : + ((Tape.init (x.map Γ.ofBool)).move Dir3.right).read + = (x.head?).elim Γ.blank Γ.ofBool := by + cases x with + | nil => simp [Tape.read, Tape.move, Tape.init] + | cons a t => cases a <;> simp [Tape.read, Tape.move, Tape.init, Γ.ofBool] + +/-- `headFlagTM target` computes `headFlag target` in two steps. -/ +theorem headFlagTM_computesInTime (target : Bool) : + (headFlagTM target).ComputesInTime (headFlag target) (fun _ => 2) := by + intro x + let c1 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.test + input := (Tape.init (x.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).writeAndMove + (readBackWrite (Tape.init []).read) (idleDir (Tape.init []).read) + output := (Tape.init []).move Dir3.right } + have hstep1 : (headFlagTM target).step ((headFlagTM target).initCfg x) = some c1 := by + simp [TM.step, headFlagTM, c1, Tape.read, Tape.init, idleDir, Tape.writeAndMove, + Tape.write, Tape.move] + have hread : c1.input.read = (x.head?).elim Γ.blank Γ.ofBool := + headFlagTM_read x + by_cases hb : x.head? = some target + · -- The bit matches: one output cell is written. + have hri : c1.input.read = Γ.ofBool target := by rw [hread, hb]; rfl + let c2 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove + (readBackWrite (c1.work i).read) (idleDir (c1.work i).read) + output := c1.output.writeAndMove Γw.zero.toΓ Dir3.right } + have hstep2 : (headFlagTM target).step c1 = some c2 := by + simp [TM.step, headFlagTM, c1, c2, hri] + refine ⟨c2, 2, le_rfl, .step hstep1 (.step hstep2 .zero), rfl, ?_⟩ + rw [headFlag, if_pos hb] + refine ⟨fun i hi => ?_, ?_⟩ + · have hi0 : i = 0 := by simpa using hi + subst hi0 + simp [c2, c1, Tape.write, Tape.move, Tape.init, Γw.toΓ, Γ.ofBool] + · simp [c2, c1, Tape.write, Tape.move, Tape.init, Γw.toΓ] + · -- The bit does not match: nothing is written. + have hri : c1.input.read ≠ Γ.ofBool target := by + rw [hread] + cases hx : x.head? with + | none => cases target <;> simp [Γ.ofBool] + | some a => + rw [hx] at hb + simp only [Option.elim] + cases a <;> cases target <;> simp_all [Γ.ofBool] + let c2 : Cfg 0 (headFlagTM target).Q := + { state := HeadPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove + (readBackWrite (c1.work i).read) (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read).toΓ + (idleDir c1.output.read) } + have hstep2 : (headFlagTM target).step c1 = some c2 := by + simp [TM.step, headFlagTM, c1, c2, hri] + refine ⟨c2, 2, le_rfl, .step hstep1 (.step hstep2 .zero), rfl, ?_⟩ + rw [headFlag, if_neg hb] + refine ⟨fun i hi => by simp at hi, ?_⟩ + have hoc : c1.output.read = Γ.blank := by + simp [c1, Tape.read, Tape.move, Tape.init] + have hcells : c2.output.cells = c1.output.cells := by + show ((c1.output.write ((readBackWrite c1.output.read).toΓ)).move + (idleDir c1.output.read)).cells = c1.output.cells + rw [Tape.move_cells, + show (readBackWrite c1.output.read).toΓ = c1.output.read from by rw [hoc]; rfl, + write_read_self'] + rw [hcells] + simp [c1, Tape.move, Tape.init] + +/-- **A bit test, as a length.** -/ +theorem headFlag_mem_FP (target : Bool) : headFlag target ∈ FP := + ⟨1, 0, headFlagTM target, (fun _ => 2), headFlagTM_computesInTime target, + BigO.const_le_pow 2 1⟩ + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean b/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean new file mode 100644 index 00000000..f7fcd028 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Iterate.lean @@ -0,0 +1,966 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Asymptotics.PolyBound +public import Complexitylib.Classes.P.Cobham.Internal.IterateLayout +public import Complexitylib.Models.TuringMachine.Registers.Horner +public import Complexitylib.Models.TuringMachine.Registers.InputLen +public import Complexitylib.Models.TuringMachine.Subroutines.PairEmit +public import Complexitylib.Classes.P.NormalForm + +/-! +# The bounded-iteration machine — proof internals + +`Complexity.Cobham.iterate_mem_FP` needs one machine: given a polynomial-time +`G`, a machine that applies `G` to its own input `|x|` times. This file builds +it out of the phase contracts of +`Complexitylib.Classes.P.Cobham.Internal.IterateLayout`. + +## Layout + +Three bookkeeping tapes (`rfIdx` the loop's fuel register, `wfIdx` the reset's +fuel register, `junkIdx` scratch for the register arithmetic) followed by +`TM.applyTM`'s own block (`appIdx`), whose virtual input `vinIdx` carries the +running value and whose last tape `resIdx` receives each result. + +## Phases + +* `Complexity.iterTail` — the five phases that follow every application: park, + rewind the result, blank the scratch, move the result into virtual-input + position, blank the result tape. Shared by the loop body and the setup. +* `Complexity.iterBody` — one application of the iterated function followed by + the tail; this is what the loop iterates. +* `Complexity.iterSetup` — bump, load `|x|` into the loop register, evaluate a + padding polynomial into the reset register, put `pair [] x` on the result + tape, then the tail. +* `Complexity.iterTM` — setup, loop, and one final application whose output is + the real output tape. +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +variable {k : ℕ} + +/-! ## A confinement frame for an arbitrary bounded run + +Resetting the scratch of an opaque machine needs to know how far its heads can +have travelled. Any `b`-step run from tapes parked at cell `1` and blank beyond +it stays inside cell `1 + b`. -/ + +/-- **Every bounded run is confined.** From work tapes parked at cell `1` whose +content is confined to cell `1`, a `b`-step run leaves every work tape inside +`H` and blank beyond `H`. -/ +theorem hoareTime_confined {n : ℕ} {tm : TM n} {pre post : TapePred n} {b : ℕ} + (h : tm.HoareTime pre post b) (W : Fin n → Tape) (H : ℕ) (hH : 1 + b ≤ H) + (S : Fin n → Prop) (hWSI : ∀ i, Tape.StartInvariant (W i)) + (hWh : ∀ i, S i → (W i).head = 1) + (hWfar : ∀ i, S i → ∀ j, 1 < j → (W i).cells j = Γ.blank) : + tm.HoareTime + (fun inp work out => pre inp work out ∧ work = W ∧ + Tape.StartInvariant inp ∧ Tape.StartInvariant out) + (fun inp work out => post inp work out ∧ Tape.StartInvariant inp ∧ + Tape.StartInvariant out ∧ + ∀ i, Tape.StartInvariant (work i) ∧ (S i → + (work i).head ≤ H ∧ ∀ j, H < j → (work i).cells j = Γ.blank)) + b := by + rintro inp work out ⟨hpre, rfl, hinpSI, houtSI⟩ + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp work out hpre + have hSI := TM.reachesIn_startInvariant hreach hinpSI hWSI houtSI + refine ⟨c', t, ht, hreach, hhalt, hpost, hSI.1, hSI.2.2, + fun i => ⟨hSI.2.1 i, fun hSi => ⟨?_, fun j hj => ?_⟩⟩⟩ + · have hh := (head_le_start_add_of_reachesIn tm hreach).2.2 i + rw [show ((⟨tm.qstart, inp, work, out⟩ : Cfg n tm.Q).work i).head = 1 from hWh i hSi] at hh + omega + · rw [TM.reachesIn_work_cells_far hreach i j (by rw [show + ((⟨tm.qstart, inp, work, out⟩ : Cfg n tm.Q).work i).head = 1 from hWh i hSi]; omega)] + exact hWfar i hSi j (by omega) + +/-! ## The shared tail + +Every application of the iterated function — the loop body's, and the setup's +`pair [] x` — leaves its result on `resIdx` with the scratch dirty. The five +phases below restore the entry shape `TM.applyPre` demands. -/ + +/-- Park, rewind the result, blank the witness machine's scratch and the +virtual input, move the result into virtual-input position, blank the result +tape. -/ +def iterTail (k : ℕ) : TM (3 + (k + 2) + 0) := + seqTM + (seqTM (seqTM skipTM (rewindWorkTM resIdx)) (resetTapesTM (resetTargets k) wfIdx)) + (seqTM (copyToVirtualInputTM resIdx vinIdx) (resetTapesTM (resetResult k) wfIdx)) + +/-- `Complexity.iterTail`'s time bound. -/ +def tailBound (k H m : ℕ) : ℕ := + 1 + 1 + (H + 1 + 2) + 1 + + ((k + 1) * (H + 4) + H * 4 + 8 + 1 + ((k + 1) * (H + 4) + 1)) + 1 + + (2 * m + 5 + 1 + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1))) + +theorem startInvariant_regTape (H : ℕ) : Tape.StartInvariant (regTape H) := + ⟨by rw [regT_cells]; simp [regCells], (parked_regTape H).2⟩ + +/-- **The tail's contract.** From a result tape carrying `v` and a block whose +tapes are confined to `1 … H`, the five phases rebuild `TM.applyPre M v`. -/ +theorem iterTail_hoareTime (M : TM k) (H : ℕ) (v : List Bool) (hv : v.length + 1 ≤ H) + (inp₀ : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (rfT junkT : Tape) (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (iterTail k).HoareTime + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work resIdx).HasOutput v ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = rfT ∧ work wfIdx = regTape H ∧ work junkIdx = junkT) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (∀ j, work (appIdx j) = TM.applyPre M v inp₀ j)) + (tailBound k H v.length) := by + intro inp work out hpre + obtain ⟨hi, ho, hres, hbnd, hrf, hwf, hjunk⟩ := hpre + subst hi + subst ho + have houtP : Parked parkedBlank := parked_parkedBlank + have houtSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hregSI : Tape.StartInvariant (regTape H) := startInvariant_regTape H + have hSI : ∀ i, Tape.StartInvariant (work i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrf]; exact hrfSI + · rw [h, hwf]; exact hregSI + · rw [h, hjunk]; exact hjunkSI + · rw [h]; exact (hbnd j).1 + -- the three phase contracts, instantiated at the actual tape family + have hpark := iterPark_hoareTime H inp hinpP hinpSI work hSI (hbnd (Fin.last (k + 1))).2.1 + have hrst := iterResetScratch_hoareTime H (by omega) inp hinpP hinpSI work hSI + (fun j => (hbnd (Fin.castSucc j)).2.1) + (fun j c hc => (hbnd (Fin.castSucc j)).2.2 c hc) hwf + have hrfeq : (⟨max (work rfIdx).head 1, (work rfIdx).cells⟩ : Tape) = rfT := by + rw [hrf] + exact Tape.ext (by show max rfT.head 1 = rfT.head; have := hrfP.1; omega) rfl + have hjunkeq : (⟨max (work junkIdx).head 1, (work junkIdx).cells⟩ : Tape) = junkT := by + rw [hjunk] + exact Tape.ext (by show max junkT.head 1 = junkT.head; have := hjunkP.1; omega) rfl + have hfin := iterFinish_hoareTime M H v hv inp hinpP hinpSI + (⟨1, (work resIdx).cells⟩ : Tape) rfT junkT rfl + ((Tape.hasOutput_congr rfl v).mp hres) + ⟨(hbnd (Fin.last (k + 1))).1.1, fun c hc => (hbnd (Fin.last (k + 1))).1.2 c hc⟩ + (fun c hc => (hbnd (Fin.last (k + 1))).2.2 c hc) + hrfP hrfSI hjunkP hjunkSI + -- chain the three, converting the seams through the parked frame + have hAB := seqTM_hoareTime _ _ hpark (by + rintro inp' work' out' ⟨rfl, rfl, e3, e4, e5⟩ + have hP : ∀ i, Parked (work' i) := by + intro i + by_cases hir : i = resIdx + · exact ⟨by rw [hir, e3], fun c hc => by rw [hir, e4]; exact (hSI resIdx).2 c hc⟩ + · rw [e5 i hir] + exact ⟨le_max_right _ _, fun c hc => (hSI i).2 c hc⟩ + obtain ⟨t1, t2, t3⟩ := parked_transition hinpP hP houtP + rw [t1, t2, t3] + exact ⟨rfl, rfl, e3, e4, e5⟩) hrst + have hABC := seqTM_hoareTime _ _ hAB (by + rintro inp' work' out' ⟨rfl, rfl, e3, e4, e5, e6, e7, e8⟩ + have hP : ∀ i, Parked (work' i) := by + intro i + by_cases hir : i = resIdx + · exact ⟨by rw [hir, e3], fun c hc => by rw [hir, e4]; exact (hSI resIdx).2 c hc⟩ + · rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, e7, hrfeq]; exact hrfP + · rw [h, e6]; exact parked_regTape H + · rw [h, e8, hjunkeq]; exact hjunkP + · by_cases hjl : j = Fin.last (k + 1) + · exact absurd (by rw [h, hjl]; rfl) hir + · have hjv : j.val < k + 1 := + lt_of_le_of_ne (Nat.lt_succ_iff.mp j.isLt) (fun hc => hjl (Fin.ext hc)) + rw [h, show j = Fin.castSucc (⟨j.val, hjv⟩ : Fin (k + 1)) from Fin.ext rfl, + e5 ⟨j.val, hjv⟩] + exact houtP + obtain ⟨t1, t2, t3⟩ := parked_transition hinpP hP houtP + rw [t1, t2, t3] + exact ⟨rfl, rfl, Tape.ext e3 e4, e7.trans hrfeq, e8.trans hjunkeq, e6, e5⟩) hfin + exact hABC inp work parkedBlank ⟨rfl, rfl, rfl⟩ + +/-! ## One iteration + +The loop body is one application of the iterated function followed by the +tail. -/ + +/-- One combinator seam on a tape satisfying the left-marker invariant: the +cells are untouched and the head only ever bounces off `▷`. -/ +theorem transitionTape_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + transitionTape t = (⟨max t.head 1, t.cells⟩ : Tape) := by + by_cases hh : t.read = Γ.start + · have hh0 : t.head = 0 := by + by_contra hc + exact (h.2 t.head (by omega)) hh + refine Tape.ext ?_ (transitionTape_cells t (fun j hj => h.2 j hj)) + have h1 := one_le_head_transitionTape t h.1 + have h2 := head_transitionTape_le (p_bound := 0) h.1 (le_of_eq hh0) + show (transitionTape t).head = max t.head 1 + omega + · rw [transitionTape_eq_self hh] + have hh0 : t.head ≠ 0 := fun hc => hh (by rw [Tape.read, hc]; exact h.1) + exact Tape.ext (by show t.head = max t.head 1; omega) rfl + +/-- The three bookkeeping tapes, packaged as a placement frame. -/ +def bookTapes (rfT junkT : Tape) (H : ℕ) : Fin (3 + (k + 2) + 0) → Tape := + fun i => if i = rfIdx then rfT else if i = wfIdx then regTape H else junkT + +@[simp] theorem bookTapes_rf (rfT junkT : Tape) (H : ℕ) : + bookTapes (k := k) rfT junkT H rfIdx = rfT := by + rw [bookTapes, if_pos rfl] + +@[simp] theorem bookTapes_wf (rfT junkT : Tape) (H : ℕ) : + bookTapes (k := k) rfT junkT H wfIdx = regTape H := by + rw [bookTapes, if_neg (fun h => rfIdx_ne_wfIdx h.symm), if_pos rfl] + +@[simp] theorem bookTapes_junk (rfT junkT : Tape) (H : ℕ) : + bookTapes (k := k) rfT junkT H junkIdx = junkT := by + rw [bookTapes, if_neg junkIdx_ne_rfIdx, if_neg junkIdx_ne_wfIdx] + +theorem eq_bookTapes_of_not_middle {work : Fin (3 + (k + 2) + 0) → Tape} + {rfT junkT : Tape} {H : ℕ} + (hrf : work rfIdx = rfT) (hwf : work wfIdx = regTape H) (hjunk : work junkIdx = junkT) : + ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → work i = bookTapes rfT junkT H i := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrf, bookTapes_rf] + · rw [h, hwf, bookTapes_wf] + · rw [h, hjunk, bookTapes_junk] + · exact absurd (h ▸ appIdx_middle j) hi + +theorem bookTapes_startInvariant {rfT junkT : Tape} {H : ℕ} + (hrfSI : Tape.StartInvariant rfT) (hjunkSI : Tape.StartInvariant junkT) : + ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → Tape.StartInvariant (bookTapes rfT junkT H i) := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, bookTapes_rf]; exact hrfSI + · rw [h, bookTapes_wf]; exact startInvariant_regTape H + · rw [h, bookTapes_junk]; exact hjunkSI + · exact absurd (h ▸ appIdx_middle j) hi + +theorem bookTapes_head {rfT junkT : Tape} {H : ℕ} + (hrfP : Parked rfT) (hjunkP : Parked junkT) : + ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → 1 ≤ (bookTapes rfT junkT H i).head := by + intro i hi + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, bookTapes_rf]; exact hrfP.1 + · rw [h, bookTapes_wf]; exact (parked_regTape H).1 + · rw [h, bookTapes_junk]; exact hjunkP.1 + · exact absurd (h ▸ appIdx_middle j) hi + +/-- The loop body: apply the iterated function once, then restore the entry +shape. -/ +def iterBody (M : TM k) : TM (3 + (k + 2) + 0) := + seqTM (placeWorkTM 3 0 (TM.applyTM M)) (iterTail k) + +/-- **The body's contract.** From the entry shape for `y`, the body reaches the +entry shape for `G y`, holding both registers and the junk tape fixed. -/ +theorem iterBody_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (H : ℕ) (y : List Bool) + (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) (hGy : (G y).length + 1 ≤ H) + (inp₀ : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (rfT junkT : Tape) (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (iterBody M).HoareTime + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (∀ j, work (appIdx j) = TM.applyPre M y inp₀ j) ∧ + work rfIdx = rfT ∧ work wfIdx = regTape H ∧ work junkIdx = junkT) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (∀ j, work (appIdx j) = TM.applyPre M (G y) inp₀ j)) + (T y.length + 1 + tailBound k H (G y).length) := by + have happ := placedApply_hoareTime M hcomp y inp₀ hinpP hinpSI H hHy hHT + (bookTapes rfT junkT H) (bookTapes_startInvariant hrfSI hjunkSI) + (bookTapes_head hrfP hjunkP) + refine seqTM_hoareTime _ _ (happ.weaken_pre ?_) ?_ + (iterTail_hoareTime M H (G y) hGy inp₀ hinpP hinpSI rfT junkT hrfP hrfSI hjunkP hjunkSI) + · rintro inp work out ⟨hi, ho, happ', hrf, hwf, hjunk⟩ + exact ⟨hi, happ', eq_bookTapes_of_not_middle hrf hwf hjunk, ho⟩ + · rintro inp work out ⟨rfl, rfl, hres, hbnd, hext⟩ + dsimp only + have hrfe : work rfIdx = rfT := by + rw [hext rfIdx rfIdx_not_middle, bookTapes_rf] + have hwfe : work wfIdx = regTape H := by + rw [hext wfIdx wfIdx_not_middle, bookTapes_wf] + have hjunke : work junkIdx = junkT := by + rw [hext junkIdx junkIdx_not_middle, bookTapes_junk] + have hSIall : ∀ i, Tape.StartInvariant (work i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrfe]; exact hrfSI + · rw [h, hwfe]; exact startInvariant_regTape H + · rw [h, hjunke]; exact hjunkSI + · rw [h]; exact (hbnd j).1 + have htin : transitionInput inp = inp := transitionInput_eq_self hinpP.read_ne_start + have htout : transitionTape parkedBlank = parkedBlank := + transitionTape_eq_self parked_parkedBlank.read_ne_start + have hcells : ∀ i, (transitionTape (work i)).cells = (work i).cells := fun i => + transitionTape_cells _ (fun j hj => (hSIall i).2 j hj) + refine ⟨htin, htout, ?_, fun j => ⟨?_, ?_, ?_⟩, ?_, ?_, ?_⟩ + · exact (Tape.hasOutput_congr (hcells resIdx).symm (G y)).mp hres + · exact ⟨(hcells (appIdx j)) ▸ (hbnd j).1.1, + fun c hc => (hcells (appIdx j)) ▸ (hbnd j).1.2 c hc⟩ + · rw [transitionTape_of_startInvariant (hSIall (appIdx j))] + show max (work (appIdx j)).head 1 ≤ H + have := (hbnd j).2.1 + omega + · intro c hc + rw [hcells (appIdx j)] + exact (hbnd j).2.2 c hc + · rw [hrfe, transitionTape_eq_self hrfP.read_ne_start] + · rw [hwfe, transitionTape_eq_self (parked_regTape H).read_ne_start] + · rw [hjunke, transitionTape_eq_self hjunkP.read_ne_start] + +/-! ## The loop + +`TM.forRegTM` drives the body once per mark of the fuel register `rfIdx`, +threading the iteration-indexed ghost family below. -/ + +/-- The whole tape family at iteration `i`: the entry shape for the `i`-th +iterate on `TM.applyTM`'s block, the two registers, and the junk tape. -/ +def iterFamily (M : TM k) (Y : ℕ → List Bool) (inp₀ junkT : Tape) (v H : ℕ) : + ℕ → Fin (3 + (k + 2) + 0) → Tape := + fun i j => if hj : placeWorkInMiddle 3 (k + 2) j + then TM.applyPre M (Y i) inp₀ (placeWorkCoord 3 (k + 2) j hj) + else bookTapes (regTape v) junkT H j + +variable {M : TM k} {Y : ℕ → List Bool} {inp₀ junkT : Tape} {v H : ℕ} + +@[simp] theorem iterFamily_app (i : ℕ) (j : Fin (k + 2)) : + iterFamily M Y inp₀ junkT v H i (appIdx j) = TM.applyPre M (Y i) inp₀ j := by + rw [iterFamily] + rw [dif_pos (appIdx_middle j)] + congr 1 + exact placeWorkCoord_placeWorkIdx 3 0 j + +theorem iterFamily_book (i : ℕ) (j : Fin (3 + (k + 2) + 0)) + (hj : ¬ placeWorkInMiddle 3 (k + 2) j) : + iterFamily M Y inp₀ junkT v H i j = bookTapes (regTape v) junkT H j := by + rw [iterFamily, dif_neg hj] + +@[simp] theorem iterFamily_rf (i : ℕ) : + iterFamily M Y inp₀ junkT v H i rfIdx = regTape v := by + rw [iterFamily_book i rfIdx rfIdx_not_middle, bookTapes_rf] + +@[simp] theorem iterFamily_wf (i : ℕ) : + iterFamily M Y inp₀ junkT v H i wfIdx = regTape H := by + rw [iterFamily_book i wfIdx wfIdx_not_middle, bookTapes_wf] + +@[simp] theorem iterFamily_junk (i : ℕ) : + iterFamily M Y inp₀ junkT v H i junkIdx = junkT := by + rw [iterFamily_book i junkIdx junkIdx_not_middle, bookTapes_junk] + +theorem iterFamily_parked (hjunkP : Parked junkT) (i : ℕ) (j : Fin (3 + (k + 2) + 0)) + (hj : j ≠ rfIdx) : Parked (iterFamily M Y inp₀ junkT v H i j) := by + rcases layout_cases j with h | h | h | ⟨jj, h⟩ + · exact absurd h hj + · rw [h, iterFamily_wf]; exact parked_regTape H + · rw [h, iterFamily_junk]; exact hjunkP + · rw [h, iterFamily_app] + exact ⟨le_of_eq (TM.applyPre_head M (Y i) inp₀ jj).symm, + fun c hc => (TM.applyPre_startInvariant M (Y i) inp₀ jj).2 c hc⟩ + +/-- **The loop's contract.** `v` applications of the iterated function, each +returning the block to its entry shape. -/ +theorem iterLoop_hoareTime {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) + (hY : ∀ i, Y (i + 1) = G (Y i)) + (hlen : ∀ i, i ≤ v → (Y i).length + 1 ≤ H) + (hT : ∀ i, i < v → 1 + T (Y i).length ≤ H) + (b_iter : ℕ) + (hb : ∀ i, i < v → T (Y i).length + 1 + tailBound k H (Y (i + 1)).length ≤ b_iter) + (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (forRegTM (iterBody M) rfIdx).HoareTime + (EmitPred inp₀ (iterFamily M Y inp₀ junkT v H 0) []) + (EmitPred inp₀ (iterFamily M Y inp₀ junkT v H v) []) + (v * (b_iter + 2) + (v + 2)) := by + refine forRegTM_hoareTime (iterBody M) rfIdx v inp₀ (iterFamily M Y inp₀ junkT v H) + (fun _ => []) b_iter hinpP (fun i => iterFamily_rf i) + (fun i j hj => iterFamily_parked hjunkP i j hj) (fun i hi => ?_) + have hrfP : Parked (⟨i + 2, regCells v⟩ : Tape) := regIterCells_parked v i + have hrfSI : Tape.StartInvariant (⟨i + 2, regCells v⟩ : Tape) := + ⟨(startInvariant_regTape v).1, hrfP.2⟩ + have hbody := iterBody_hoareTime M hcomp H (Y i) + (by have := hlen i (by omega); omega) (hT i hi) + (by rw [← hY i]; exact hlen (i + 1) (by omega)) + inp₀ hinpP hinpSI (⟨i + 2, regCells v⟩ : Tape) junkT hrfP hrfSI hjunkP hjunkSI + refine ((hbody.weaken_pre ?_).strengthen_post ?_).mono_bound ?_ + · rintro inp work out ⟨hi', hw, hout⟩ + refine ⟨hi', eq_parkedBlank_of_outAcc_nil hout, fun j => ?_, ?_, ?_, ?_⟩ + · rw [hw, Function.update_of_ne (fun h => rfIdx_ne_appIdx j h.symm), iterFamily_app] + · rw [hw, Function.update_self] + · rw [hw, Function.update_of_ne rfIdx_ne_wfIdx.symm, iterFamily_wf] + · rw [hw, Function.update_of_ne junkIdx_ne_rfIdx, iterFamily_junk] + · rintro inp work out ⟨hi', hout, hrf, hjunk, hwf, happ⟩ + refine ⟨hi', funext fun j => ?_, ?_⟩ + · rcases layout_cases j with h | h | h | ⟨jj, h⟩ + · rw [h, hrf, Function.update_self] + · rw [h, hwf, Function.update_of_ne rfIdx_ne_wfIdx.symm, iterFamily_wf] + · rw [h, hjunk, Function.update_of_ne junkIdx_ne_rfIdx, iterFamily_junk] + · rw [h, happ jj, Function.update_of_ne (fun hc => rfIdx_ne_appIdx jj hc.symm), + iterFamily_app, hY i] + · rw [hout] + exact outAcc_nil_of_parkedBlank + · rw [← hY i] + exact hb i hi + +/-! ## The setup + +Bump, load `|x|` into the loop register, evaluate the padding polynomial into +the reset register, and put `pair [] x` on the result tape. -/ + +@[simp] theorem parkedBlank_head : parkedBlank.head = 1 := rfl + +theorem parkedBlank_cells (j : ℕ) : + parkedBlank.cells j = if j = 0 then Γ.start else Γ.blank := by + show ((Tape.init ([] : List Γ)).move Dir3.right).cells j = _ + rw [Tape.move_cells, initNil_cells] + +theorem hasOutput_nil_parkedBlank : parkedBlank.HasOutput [] := + ⟨fun i hi => absurd hi (Nat.not_lt_zero i), by simp [parkedBlank_cells]⟩ + +/-- The tape family the emission phase starts from: `TM.applyTM`'s block blank, +the bookkeeping tapes as given. -/ +def emitStart (extras : Fin (3 + (k + 2) + 0) → Tape) : Fin (3 + (k + 2) + 0) → Tape := + fun i => if placeWorkInMiddle 3 (k + 2) i then parkedBlank else extras i + +theorem emitStart_middle (extras : Fin (3 + (k + 2) + 0) → Tape) (j : Fin (k + 2)) : + emitStart extras (appIdx j) = parkedBlank := by + rw [emitStart, if_pos (appIdx_middle j)] + +theorem emitStart_extra (extras : Fin (3 + (k + 2) + 0) → Tape) + (i : Fin (3 + (k + 2) + 0)) (hi : ¬ placeWorkInMiddle 3 (k + 2) i) : + emitStart extras i = extras i := by + rw [emitStart, if_neg hi] + +/-- **The setup's emission phase.** From the bumped input holding `x` and an +all-blank block, `pair [] x` lands on the result tape and the whole block stays +inside `H`. -/ +theorem placedEmit_hoareTime (x : List Bool) (H : ℕ) (hH : x.length + 4 ≤ H) + (extras : Fin (3 + (k + 2) + 0) → Tape) + (hextraSI : ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → Tape.StartInvariant (extras i)) + (hextraH : ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → 1 ≤ (extras i).head) : + (placeWorkTM 3 0 (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k)))).HoareTime + (fun inp work out => inp = (Tape.init (x.map Γ.ofBool)).move Dir3.right ∧ + out = parkedBlank ∧ work = emitStart extras) + (fun inp work out => Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + (∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → work i = extras i)) + (x.length + 3) := by + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hplaced := TM.placeWorkTM_hoareTime_frame (pre := 3) (post := 0) + (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k))) + (TM.retargetOutput_hoareTime _ (TM.pairInputWorkTM_hoareTime (Fin.last k) [] x)) + extras hextraSI hextraH + have hconf := hoareTime_confined hplaced (emitStart extras) H + (by simp only [TM.pairInputWorkTime, List.length_nil]; omega) + (placeWorkInMiddle 3 (k + 2)) + (fun i => by + by_cases hi : placeWorkInMiddle 3 (k + 2) i + · rw [emitStart, if_pos hi]; exact hblankSI + · rw [emitStart, if_neg hi]; exact hextraSI i hi) + (fun i hi => by rw [emitStart, if_pos hi, parkedBlank_head]) + (fun i hi j hj => by + rw [emitStart, if_pos hi] + show ((Tape.init ([] : List Γ)).move Dir3.right).cells j = Γ.blank + rw [Tape.move_cells, initNil_cells, if_neg (by omega)]) + refine ((hconf.weaken_pre ?_).strengthen_post ?_).mono_bound + (by simp only [TM.pairInputWorkTime, List.length_nil]; omega) + · rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨⟨⟨⟨rfl, ?_, ?_, ?_, ?_⟩, rfl⟩, + fun i hi => emitStart_extra extras i hi⟩, rfl, + (startInvariant_initOfBool x).move Dir3.right, hblankSI⟩ + · show (emitStart extras (appIdx (Fin.castSucc (Fin.last k)))).head = 1 + rw [emitStart_middle, parkedBlank_head] + · show (emitStart extras (appIdx (Fin.castSucc (Fin.last k)))).HasOutput [] + rw [emitStart_middle] + exact hasOutput_nil_parkedBlank + · intro i + show Tape.StartInvariant (emitStart extras (appIdx (Fin.castSucc i))) ∧ + 1 ≤ (emitStart extras (appIdx (Fin.castSucc i))).head + rw [emitStart_middle] + exact ⟨hblankSI, le_refl 1⟩ + · show emitStart extras (appIdx (Fin.last (k + 1))) = (Tape.init []).move Dir3.right + rw [emitStart_middle] + rfl + · rintro inp work out ⟨⟨⟨hout, ho⟩, hext⟩, hinpSI, -, hconf'⟩ + exact ⟨hinpSI, ho, hout, fun j => ⟨(hconf' (appIdx j)).1, + ((hconf' (appIdx j)).2 (appIdx_middle j)).1, + ((hconf' (appIdx j)).2 (appIdx_middle j)).2⟩, hext⟩ + +theorem parkedBlank_eq_regTape_zero : parkedBlank = regTape 0 := by + refine Tape.ext rfl (funext fun j => ?_) + rw [parkedBlank_cells, regT_cells] + show _ = regCells 0 j + rw [regCells] + by_cases hj : j = 0 + · rw [if_pos hj, if_pos hj] + · rw [if_neg hj, if_neg hj, if_neg (by omega)] + +/-- The register value cap the padding polynomial's evaluation runs under. -/ +def polyM (p : Polynomial ℕ) (n : ℕ) : ℕ := + ((polyCoeffs p).sum + 1) * (n + 1) ^ (polyCoeffs p).length + n + p.eval n + +/-- The setup machine: bump every head off cell `0`, load `|x|` into the loop +register, evaluate the padding polynomial into the reset register, and emit +`pair [] x` onto the result tape. -/ +def iterSetup (k : ℕ) (p : Polynomial ℕ) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (seqTM skipTM (inputLenRegTM rfIdx)) (polyEvalTM rfIdx wfIdx junkIdx p)) + (placeWorkTM 3 0 (TM.retargetOutput (TM.pairInputWorkTM (Fin.last k)))) + +/-- `Complexity.iterSetup`'s time bound. -/ +def setupBound (p : Polynomial ℕ) (n : ℕ) : ℕ := + 1 + 1 + (2 * n + 4) + 1 + + (opBudget (polyM p n) + 1 + ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + + 1 + (n + 3) + +theorem iterSetup_hoareTime (p : Polynomial ℕ) (x : List Bool) (H : ℕ) + (hH : H = p.eval x.length) (hHx : x.length + 4 ≤ H) : + (iterSetup k p).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (fun inp work out => Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = regTape x.length ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) + (setupBound p x.length) := by + set inpx : Tape := ⟨1, (Tape.init (x.map Γ.ofBool)).cells⟩ with hinpx + have hinpxP : Parked inpx := + ⟨le_refl 1, fun j hj => (startInvariant_initOfBool x).2 j hj⟩ + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + set W₀ : Fin (3 + (k + 2) + 0) → Tape := fun _ => parkedBlank with hW₀ + have hW₀P : ∀ i, Parked (W₀ i) := fun _ => parked_parkedBlank + -- phase 1: bump + have hA : (skipTM (n := 3 + (k + 2) + 0)).HoareTime + (fun inp work out => inp = Tape.init (x.map Γ.ofBool) ∧ + work = (fun _ => Tape.init []) ∧ out = Tape.init []) + (EmitPred inpx W₀ []) 1 := by + refine (parkAll_hoareTime (Tape.init (x.map Γ.ofBool)) (fun _ => Tape.init []) + (Tape.init []) (startInvariant_initOfBool x) (fun _ => startInvariant_initNil) + startInvariant_initNil).strengthen_post ?_ + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, funext fun i => (hw i).trans ?_, ?_⟩ + · rw [hW₀] + exact Tape.ext (by show max 0 1 = 1; omega) rfl + · rw [ho] + show OutAcc [] (⟨max 0 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) + have : (⟨max 0 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) = parkedBlank := + Tape.ext (by show max 0 1 = 1; omega) rfl + rw [this] + exact outAcc_nil_of_parkedBlank + -- phase 2: the loop register + have hB := inputLenRegTM_hoareTime (n := 3 + (k + 2) + 0) rfIdx x W₀ [] + (fun i _ => hW₀P i) (by rw [hW₀]; exact parkedBlank_eq_regTape_zero) + set W₁ : Fin (3 + (k + 2) + 0) → Tape := + Function.update W₀ rfIdx (regTape x.length) with hW₁ + have hW₁P : ∀ i, Parked (W₁ i) := by + intro i + by_cases hi : i = rfIdx + · rw [hW₁, hi, Function.update_self]; exact parked_regTape _ + · rw [hW₁, Function.update_of_ne hi]; exact hW₀P i + -- phase 3: the reset register + have hC := polyEvalTM_hoareTime rfIdx wfIdx junkIdx rfIdx_ne_wfIdx + (fun h => junkIdx_ne_rfIdx h.symm) junkIdx_ne_wfIdx.symm p (polyM p x.length) + x.length 0 0 (by rw [polyM]; omega) (by omega) (by omega) + (fun j _ => le_trans (hornerFold_take_le x.length (polyCoeffs p) j) (by rw [polyM]; omega)) + inpx W₁ [] hinpxP hW₁P (by rw [hW₁, Function.update_self]) + (by rw [hW₁, Function.update_of_ne rfIdx_ne_wfIdx.symm, hW₀] + exact parkedBlank_eq_regTape_zero) + (by rw [hW₁, Function.update_of_ne junkIdx_ne_rfIdx, hW₀] + exact parkedBlank_eq_regTape_zero) + -- phase 4: the emission + have hfam : Function.update (Function.update W₁ junkIdx (regTape (p.eval x.length))) wfIdx + (regTape (p.eval x.length)) + = emitStart (bookTapes (regTape x.length) (regTape H) H) := by + funext i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, Function.update_of_ne rfIdx_ne_wfIdx, Function.update_of_ne junkIdx_ne_rfIdx.symm, + hW₁, Function.update_self, emitStart_extra _ _ rfIdx_not_middle, bookTapes_rf] + · rw [h, Function.update_self, emitStart_extra _ _ wfIdx_not_middle, bookTapes_wf, hH] + · rw [h, Function.update_of_ne junkIdx_ne_wfIdx, Function.update_self, + emitStart_extra _ _ junkIdx_not_middle, bookTapes_junk, hH] + · rw [h, Function.update_of_ne (fun hc => wfIdx_ne_appIdx j hc.symm), + Function.update_of_ne (fun hc => junkIdx_ne_appIdx j hc.symm), hW₁, + Function.update_of_ne (fun hc => rfIdx_ne_appIdx j hc.symm), hW₀, emitStart_middle] + have hD := placedEmit_hoareTime (k := k) x H (by omega) + (bookTapes (regTape x.length) (regTape H) H) + (bookTapes_startInvariant (startInvariant_regTape _) (startInvariant_regTape _)) + (bookTapes_head (parked_regTape _) (parked_regTape _)) + -- chain + have hAB := seqTM_hoareTime _ _ hA (emitPred_transition hinpxP hW₀P []) hB + have hBC := seqTM_hoareTime _ _ hAB (emitPred_transition hinpxP hW₁P []) hC + refine ((seqTM_hoareTime _ _ hBC ?_ hD).strengthen_post ?_).mono_bound (by rw [setupBound]) + · rintro inp work out ⟨rfl, hw, hout⟩ + rw [hfam] at hw + subst hw + have houtEq := eq_parkedBlank_of_outAcc_nil hout + have hPall : ∀ i : Fin (3 + (k + 2) + 0), + Parked (emitStart (bookTapes (regTape x.length) (regTape H) H) i) := by + intro i + by_cases hi : placeWorkInMiddle 3 (k + 2) i + · rw [emitStart, if_pos hi]; exact parked_parkedBlank + · rw [emitStart, if_neg hi] + exact ⟨bookTapes_head (parked_regTape _) (parked_regTape _) i hi, + (bookTapes_startInvariant (startInvariant_regTape _) + (startInvariant_regTape _) i hi).2⟩ + obtain ⟨t1, t2, t3⟩ := parked_transition (inp₀ := inpx) (out₀ := out) hinpxP hPall + (houtEq ▸ parked_parkedBlank) + rw [t1, t2, t3] + exact ⟨rfl, houtEq, rfl⟩ + · rintro inp work out ⟨hinpSI, ho, hres, hbnd, hext⟩ + refine ⟨hinpSI, ho, hres, hbnd, ?_, ?_, ?_⟩ + · rw [hext rfIdx rfIdx_not_middle, bookTapes_rf] + · rw [hext wfIdx wfIdx_not_middle, bookTapes_wf] + · rw [hext junkIdx junkIdx_not_middle, bookTapes_junk] + +/-! ## The whole machine + +Setup, loop, and one final application whose output lands on the real output +tape. Over-iteration is harmless, so that last application is just one more +iteration. -/ + +theorem not_middle_succ_cases (i : Fin (3 + (k + 2) + 0)) + (hi : ¬ placeWorkInMiddle (post := 1) 3 (k + 1) i) : + i = rfIdx ∨ i = wfIdx ∨ i = junkIdx ∨ i = resIdx := by + have hlt := i.isLt + have hres : (resIdx (k := k)).val = 3 + (k + 1) := rfl + unfold placeWorkInMiddle at hi + have h : i.val = 0 ∨ i.val = 1 ∨ i.val = 2 ∨ i.val = 3 + (k + 1) := by omega + rcases h with h | h | h | h + · exact Or.inl (Fin.ext h) + · exact Or.inr (Or.inl (Fin.ext h)) + · exact Or.inr (Or.inr (Or.inl (Fin.ext h))) + · exact Or.inr (Or.inr (Or.inr (Fin.ext (h.trans hres.symm)))) + +/-- The frame of the final application: the three bookkeeping tapes and the +result tape, which the last application no longer needs. -/ +def teardownExtras (v H : ℕ) : Fin (3 + (k + 2) + 0) → Tape := + fun i => if i = resIdx then parkedBlank else bookTapes (regTape v) (regTape H) H i + +/-- Setup, loop, and the final application. -/ +def iterMain (M : TM k) : TM (3 + (k + 2) + 0) := + seqTM (seqTM (iterTail k) (forRegTM (iterBody M) rfIdx)) + (placeWorkTM 3 1 (TM.retargetInputStarted M)) + +/-- **The main run.** From the result tape carrying the initial value, the +machine iterates `v + 1` times and writes the last value to the real output. -/ +theorem iterMain_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (H : ℕ) (v : ℕ) + (Y : ℕ → List Bool) (hY : ∀ i, Y (i + 1) = G (Y i)) + (hlen : ∀ i, i ≤ v → (Y i).length + 1 ≤ H) + (hT : ∀ i, i < v → 1 + T (Y i).length ≤ H) + (b_iter : ℕ) + (hb : ∀ i, i < v → T (Y i).length + 1 + tailBound k H (Y (i + 1)).length ≤ b_iter) : + (iterMain M).HoareTime + (fun inp work out => Parked inp ∧ Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (Y 0) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = regTape v ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) + (fun _inp _work out => out.HasOutput (G (Y v))) + (tailBound k H (Y 0).length + 1 + (v * (b_iter + 2) + (v + 2)) + 1 + T (Y v).length) := by + rw [iterMain] + intro inp work out hpre + obtain ⟨hinpP, hinpSI, ho, hres, hbnd, hrf, hwf, hjunk⟩ := hpre + have hregP := parked_regTape H + have hregSI := startInvariant_regTape H + have hfamP : ∀ (i : ℕ) (j : Fin (3 + (k + 2) + 0)), + Parked (iterFamily M Y inp (regTape H) v H i j) := by + intro i j + by_cases hj : j = rfIdx + · rw [hj, iterFamily_rf]; exact parked_regTape v + · exact iterFamily_parked hregP i j hj + -- the tail, the loop, and the final application + have h1 := iterTail_hoareTime M H (Y 0) (hlen 0 (by omega)) inp hinpP hinpSI + (regTape v) (regTape H) (parked_regTape v) (startInvariant_regTape v) hregP hregSI + have h2 := iterLoop_hoareTime (M := M) (Y := Y) (inp₀ := inp) (junkT := regTape H) + (v := v) (H := H) hcomp hY hlen hT b_iter hb hinpP hinpSI hregP hregSI + have h3 := TM.placeWorkTM_hoareTime_frame (pre := 3) (post := 1) + (TM.retargetInputStarted M) (TM.retargetInputStarted_hoareTime M hcomp (Y v)) + (teardownExtras v H) + (fun i hi => by + rcases not_middle_succ_cases i hi with h | h | h | h + · rw [h, teardownExtras, if_neg rfIdx_ne_resIdx, bookTapes_rf] + exact startInvariant_regTape v + · rw [h, teardownExtras, if_neg wfIdx_ne_resIdx, bookTapes_wf]; exact hregSI + · rw [h, teardownExtras, if_neg junkIdx_ne_resIdx, bookTapes_junk]; exact hregSI + · rw [h, teardownExtras, if_pos rfl] + exact startInvariant_initNil.move Dir3.right) + (fun i hi => by + rcases not_middle_succ_cases i hi with h | h | h | h + · rw [h, teardownExtras, if_neg rfIdx_ne_resIdx, bookTapes_rf] + exact (parked_regTape v).1 + · rw [h, teardownExtras, if_neg wfIdx_ne_resIdx, bookTapes_wf]; exact hregP.1 + · rw [h, teardownExtras, if_neg junkIdx_ne_resIdx, bookTapes_junk]; exact hregP.1 + · rw [h, teardownExtras, if_pos rfl]; exact parked_parkedBlank.1) + -- the two seams are the identity: every tape is parked + have hseam : ∀ (W : Fin (3 + (k + 2) + 0) → Tape), (∀ i, Parked (W i)) → + ∀ (inp' : Tape) (out' : Tape), inp' = inp → out' = parkedBlank → + transitionInput inp' = inp ∧ (fun i => transitionTape (W i)) = W ∧ + transitionTape out' = parkedBlank := by + rintro W hW inp' out' rfl rfl + exact parked_transition hinpP hW parked_parkedBlank + have h12 := seqTM_hoareTime _ _ h1 (by + rintro inp' work' out' ⟨rfl, rfl, hrf', hjunk', hwf', happ'⟩ + have hWP : ∀ i, Parked (work' i) := by + intro i + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrf']; exact parked_regTape v + · rw [h, hwf']; exact hregP + · rw [h, hjunk']; exact hregP + · rw [h, happ' j] + exact ⟨le_of_eq (TM.applyPre_head M (Y 0) _ j).symm, + fun c hc => (TM.applyPre_startInvariant M (Y 0) _ j).2 c hc⟩ + obtain ⟨t1, t2, t3⟩ := hseam work' hWP inp' parkedBlank rfl rfl + rw [t1, t2, t3] + refine ⟨rfl, funext fun i => ?_, outAcc_nil_of_parkedBlank⟩ + rcases layout_cases i with h | h | h | ⟨j, h⟩ + · rw [h, hrf', iterFamily_rf] + · rw [h, hwf', iterFamily_wf] + · rw [h, hjunk', iterFamily_junk] + · rw [h, happ' j, iterFamily_app]) h2 + refine (seqTM_hoareTime _ _ h12 ?_ h3).strengthen_post + (post' := fun _inp _work out => out.HasOutput (G (Y v))) ?_ inp work out + ⟨rfl, ho, hres, hbnd, hrf, hwf, hjunk⟩ + · rintro inp' work' out' ⟨rfl, rfl, hout'⟩ + obtain ⟨t1, t2, t3⟩ := hseam _ (hfamP v) inp' out' + rfl (eq_parkedBlank_of_outAcc_nil hout') + rw [t1, t2, t3] + refine ⟨⟨funext fun i => ?_, rfl⟩, fun i hi => ?_⟩ + · show iterFamily M Y inp' (regTape H) v H v (appIdx (Fin.castSucc i)) = _ + rw [iterFamily_app] + exact congrFun (TM.applyPre_spec M (Y v) inp').1 i + · rcases not_middle_succ_cases i hi with h | h | h | h + · rw [h, iterFamily_rf, teardownExtras, if_neg rfIdx_ne_resIdx, bookTapes_rf] + · rw [h, iterFamily_wf, teardownExtras, if_neg wfIdx_ne_resIdx, bookTapes_wf] + · rw [h, iterFamily_junk, teardownExtras, if_neg junkIdx_ne_resIdx, bookTapes_junk] + · rw [h, show (resIdx (k := k)) = appIdx (Fin.last (k + 1)) from rfl, iterFamily_app, + teardownExtras, if_pos (show appIdx (Fin.last (k + 1)) = resIdx from rfl), + TM.applyPre, Fin.snoc_last] + · rintro inp' work' out' ⟨hout, -⟩ + exact hout + +/-- The complete iteration machine. -/ +def iterTM (M : TM k) (p : Polynomial ℕ) : TM (3 + (k + 2) + 0) := + seqTM (iterSetup k p) (iterMain M) + +theorem tailBound_mono (k H : ℕ) {m m' : ℕ} (h : m ≤ m') : + tailBound k H m ≤ tailBound k H m' := by + rw [tailBound, tailBound]; omega + +/-- `Complexity.iterTM`'s time bound. -/ +def iterBound (k : ℕ) (tp p r : Polynomial ℕ) (n : ℕ) : ℕ := + setupBound p n + 1 + + (tailBound k (p.eval n) (n + 2) + 1 + + (n * (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n) + 2) + (n + 2)) + 1 + + tp.eval (r.eval n)) + +/-- **The iteration machine computes the iterate.** On input `x` it applies `G` +to `pair [] x` exactly `|x| + 1` times, provided the padding polynomial `p` +dominates the length bound `r` and the source machine's own bound `tp`. -/ +theorem iterTM_computesInTime (M : TM k) {G : List Bool → List Bool} {tp : Polynomial ℕ} + (hcomp : M.ComputesInTime G tp.eval) (p r : Polynomial ℕ) + (hp₁ : ∀ n, n + 4 ≤ p.eval n) (hp₂ : ∀ n, r.eval n + 1 ≤ p.eval n) + (hp₃ : ∀ n, 1 + tp.eval (r.eval n) ≤ p.eval n) + (hr : ∀ (x : List Bool), ∀ i ≤ x.length, (G^[i] (pair [] x)).length ≤ r.eval x.length) : + (iterTM M p).ComputesInTime (fun x => G^[x.length + 1] (pair [] x)) + (iterBound k tp p r) := by + intro x + set n := x.length with hn + set H := p.eval n with hH + set Y : ℕ → List Bool := fun i => G^[i] (pair [] x) with hY0 + have hYsucc : ∀ i, Y (i + 1) = G (Y i) := by + intro i + rw [hY0] + exact Function.iterate_succ_apply' G i (pair [] x) + have hYlen : ∀ i, i ≤ n → (Y i).length ≤ r.eval n := fun i hi => hr x i hi + have hHpos : 1 ≤ H := by have := hp₁ n; omega + have hlen : ∀ i, i ≤ n → (Y i).length + 1 ≤ H := by + intro i hi + have := hYlen i hi + have := hp₂ n + omega + have hTle : ∀ i, i ≤ n → tp.eval (Y i).length ≤ tp.eval (r.eval n) := fun i hi => + polynomial_eval_mono_nat tp (hYlen i hi) + have hsetup := iterSetup_hoareTime (k := k) p x H rfl (by have := hp₁ n; omega) + have hmain := iterMain_hoareTime M hcomp H n Y hYsucc hlen + (fun i hi => by have := hTle i (by omega); have := hp₃ n; omega) + (tp.eval (r.eval n) + 1 + tailBound k H (r.eval n)) + (fun i hi => by + have h1 := hTle i (by omega) + have h2 := tailBound_mono k H (hYlen (i + 1) (by omega)) + omega) + have hseam : ∀ (inp : Tape) (work : Fin (3 + (k + 2) + 0) → Tape) (out : Tape), + (Tape.StartInvariant inp ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (pair [] x) ∧ + (∀ j : Fin (k + 2), Tape.StartInvariant (work (appIdx j)) ∧ + (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + work rfIdx = regTape n ∧ work wfIdx = regTape H ∧ work junkIdx = regTape H) → + (Parked (transitionInput inp) ∧ Tape.StartInvariant (transitionInput inp) ∧ + transitionTape out = parkedBlank ∧ + ((fun i => transitionTape (work i)) resIdx).HasOutput (Y 0) ∧ + (∀ j : Fin (k + 2), + Tape.StartInvariant ((fun i => transitionTape (work i)) (appIdx j)) ∧ + ((fun i => transitionTape (work i)) (appIdx j)).head ≤ H ∧ + ∀ c, H < c → ((fun i => transitionTape (work i)) (appIdx j)).cells c = Γ.blank) ∧ + (fun i => transitionTape (work i)) rfIdx = regTape n ∧ + (fun i => transitionTape (work i)) wfIdx = regTape H ∧ + (fun i => transitionTape (work i)) junkIdx = regTape H) := by + rintro inp work out ⟨hinpSI, rfl, hres, hbnd, hrf, hwf, hjunk⟩ + dsimp only + have hinpEq : transitionInput inp = (⟨max inp.head 1, inp.cells⟩ : Tape) := + move_idleDir_eq_of_startInvariant hinpSI + refine ⟨?_, ?_, transitionTape_eq_self parked_parkedBlank.read_ne_start, ?_, + fun j => ⟨?_, ?_, ?_⟩, ?_, ?_, ?_⟩ + · rw [hinpEq]; exact ⟨le_max_right _ _, fun c hc => hinpSI.2 c hc⟩ + · rw [hinpEq]; exact ⟨hinpSI.1, fun c hc => hinpSI.2 c hc⟩ + · exact (Tape.hasOutput_congr + (transitionTape_cells _ (fun c hc => (hbnd (Fin.last (k + 1))).1.2 c hc)).symm _).mp hres + · refine ⟨?_, fun c hc => ?_⟩ + · rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.1 + · rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).1.2 c hc + · rw [transitionTape_of_startInvariant (hbnd j).1] + show max (work (appIdx j)).head 1 ≤ H + have := (hbnd j).2.1 + omega + · intro c hc + rw [transitionTape_cells _ (fun c' hc' => (hbnd j).1.2 c' hc')] + exact (hbnd j).2.2 c hc + · show transitionTape (work rfIdx) = regTape n + rw [hrf]; exact transitionTape_eq_self (parked_regTape n).read_ne_start + · show transitionTape (work wfIdx) = regTape H + rw [hwf]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + · show transitionTape (work junkIdx) = regTape H + rw [hjunk]; exact transitionTape_eq_self (parked_regTape H).read_ne_start + have hfull := seqTM_hoareTime _ _ hsetup hseam hmain + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := hfull (Tape.init (x.map Γ.ofBool)) + (fun _ => Tape.init []) (Tape.init []) ⟨rfl, rfl, rfl⟩ + have hY0len : (Y 0).length = n + 2 := by + rw [hY0] + show (pair [] x).length = n + 2 + rw [pair_length] + simp + omega + refine ⟨c', t, ?_, hreach, hhalt, ?_⟩ + · refine le_trans ht ?_ + rw [iterBound, hY0len] + simp only [← hn, hH] + have := hTle n le_rfl + omega + · show c'.output.HasOutput (G^[x.length + 1] (pair [] x)) + rw [Function.iterate_succ_apply'] + exact hpost + +/-! ## Polynomial bounds + +`Complexity.iterBound` is a sum of products of polynomial evaluations, so the +closure API of `Complexitylib.Asymptotics.PolyBound` bounds it directly. -/ + +theorem polyBound_iterBound (k : ℕ) (tp p r : Polynomial ℕ) : + PolyBound (iterBound k tp p r) := by + have hcomp : PolyBound (fun n => tp.eval (r.eval n)) := + PolyBound.mono (PolyBound.eval (tp.comp r)) + (fun n => le_of_eq (by rw [Polynomial.eval_comp])) + have hp : PolyBound (fun n => p.eval n) := PolyBound.eval p + have hr : PolyBound (fun n => r.eval n) := PolyBound.eval r + have hpow : PolyBound (fun n => (n + 1) ^ (polyCoeffs p).length) := + PolyBound.pow (PolyBound.add PolyBound.id (PolyBound.const 1)) _ + have hM : PolyBound (fun n => polyM p n) := by + rw [show (fun n => polyM p n) = fun n => + ((polyCoeffs p).sum + 1) * (n + 1) ^ (polyCoeffs p).length + n + p.eval n from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const _) hpow) PolyBound.id) hp + have hop : PolyBound (fun n => opBudget (polyM p n)) := by + rw [show (fun n => opBudget (polyM p n)) = fun n => + 32 * ((polyM p n + 2) * (polyM p n + 2) * (polyM p n + 2)) from rfl] + exact PolyBound.mul (PolyBound.const _) + (PolyBound.mul (PolyBound.mul (PolyBound.add hM (PolyBound.const _)) + (PolyBound.add hM (PolyBound.const _))) (PolyBound.add hM (PolyBound.const _))) + have hlayer : PolyBound (fun n => layerBudget (polyM p n)) := by + rw [show (fun n => layerBudget (polyM p n)) = fun n => + 4 * opBudget (polyM p n) + 3 from rfl] + exact PolyBound.add (PolyBound.mul (PolyBound.const _) hop) (PolyBound.const _) + have hsetup : PolyBound (setupBound p) := by + rw [show setupBound p = fun n => 1 + 1 + (2 * n + 4) + 1 + + (opBudget (polyM p n) + 1 + + ((p.natDegree + 1) * (layerBudget (polyM p n) + 1) + 1)) + 1 + (n + 3) from rfl] + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul (PolyBound.const 2) PolyBound.id) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add hop (PolyBound.const _)) + (PolyBound.add + (PolyBound.mul (PolyBound.const _) (PolyBound.add hlayer (PolyBound.const _))) + (PolyBound.const _)))) + (PolyBound.const _)) (PolyBound.add PolyBound.id (PolyBound.const _)) + have htail : ∀ m : ℕ → ℕ, PolyBound m → + PolyBound (fun n => tailBound k (p.eval n) (m n)) := by + intro m hm + rw [show (fun n => tailBound k (p.eval n) (m n)) = fun n => + 1 + 1 + (p.eval n + 1 + 2) + 1 + + ((k + 1) * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + ((k + 1) * (p.eval n + 4) + 1)) + 1 + + (2 * m n + 5 + 1 + + (1 * (p.eval n + 4) + p.eval n * 4 + 8 + 1 + (1 * (p.eval n + 4) + 1))) from rfl] + have hbase : PolyBound (fun n => p.eval n + 4) := PolyBound.add hp (PolyBound.const _) + have hk : PolyBound (fun n => (k + 1) * (p.eval n + 4)) := + PolyBound.mul (PolyBound.const _) hbase + have h1 : PolyBound (fun n => 1 * (p.eval n + 4)) := PolyBound.mul (PolyBound.const _) hbase + have h4 : PolyBound (fun n => p.eval n * 4) := PolyBound.mul hp (PolyBound.const _) + exact PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (PolyBound.add (PolyBound.const _) (PolyBound.const _)) + (PolyBound.add (PolyBound.add hp (PolyBound.const _)) (PolyBound.const _))) + (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add hk h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add hk (PolyBound.const _)))) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.mul (PolyBound.const 2) hm) + (PolyBound.const _)) (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add h1 h4) (PolyBound.const _)) + (PolyBound.const _)) (PolyBound.add h1 (PolyBound.const _)))) + rw [show iterBound k tp p r = fun n => setupBound p n + 1 + + (tailBound k (p.eval n) (n + 2) + 1 + + (n * (tp.eval (r.eval n) + 1 + tailBound k (p.eval n) (r.eval n) + 2) + (n + 2)) + 1 + + tp.eval (r.eval n)) from rfl] + exact PolyBound.add (PolyBound.add hsetup (PolyBound.const _)) + (PolyBound.add (PolyBound.add (PolyBound.add (PolyBound.add + (htail _ (PolyBound.add PolyBound.id (PolyBound.const _))) (PolyBound.const _)) + (PolyBound.add (PolyBound.mul PolyBound.id (PolyBound.add (PolyBound.add (PolyBound.add hcomp + (PolyBound.const _)) (htail _ hr)) (PolyBound.const _))) + (PolyBound.add PolyBound.id (PolyBound.const _)))) (PolyBound.const _)) hcomp) + +/-- **`FP` is closed under iterating a polynomial-time function once per input +bit**, provided every intermediate value stays polynomially bounded. -/ +theorem iterate_input_mem_FP {G : List Bool → List Bool} (hG : G ∈ FP) (r : Polynomial ℕ) + (hr : ∀ (x : List Bool), ∀ i ≤ x.length, (G^[i] (pair [] x)).length ≤ r.eval x.length) : + (fun x => G^[x.length + 1] (pair [] x)) ∈ FP := by + obtain ⟨k, M, tp, hcomp⟩ := mem_FP_iff_computesInTime_polynomial.mp hG + set p : Polynomial ℕ := + Polynomial.X + Polynomial.C 4 + r + Polynomial.C 1 + tp.comp r + Polynomial.C 1 with hpdef + have hpeval : ∀ n, p.eval n = n + 4 + r.eval n + 1 + tp.eval (r.eval n) + 1 := by + intro n + rw [hpdef] + simp [Polynomial.eval_comp] + obtain ⟨d, hd⟩ := (polyBound_iterBound k tp p r).bigO + exact ⟨d, 3 + (k + 2) + 0, iterTM M p, iterBound k tp p r, + iterTM_computesInTime M hcomp p r (fun n => by rw [hpeval]; omega) + (fun n => by rw [hpeval]; omega) (fun n => by rw [hpeval]; omega) hr, hd⟩ + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean b/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean new file mode 100644 index 00000000..2e32aaa8 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/IterateLayout.lean @@ -0,0 +1,578 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators.Apply +public import Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import Complexitylib.Models.TuringMachine.Registers.ForReg +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import Complexitylib.Models.TuringMachine.Subroutines.CopyToVirtualInput +public import Complexitylib.Models.TuringMachine.Subroutines.UnaryLength + +/-! +# The bounded-iteration machine's tape layout — proof internals + +The tape layout and phase contracts that +`Complexitylib.Classes.P.Cobham.Internal.Iterate` assembles into the +bounded-iteration machine: two unary fuel registers (one consumed by the outer +loop, one reused by every reset), one junk tape for the register arithmetic, and +then `TM.applyTM`'s own tapes placed after them. The running value needs no tape +of its own — it lives on `applyTM`'s virtual-input tape, which is exactly where +the next call wants it. + +## Main results + +- `Complexity.rfIdx`, `wfIdx`, `junkIdx`, `appIdx`, `vinIdx`, `resIdx` — the layout +- `Complexity.placedApply_hoareTime` — one embedded application of the iterated function +- `Complexity.iterPark_hoareTime`, `iterResetScratch_hoareTime`, + `iterFinish_hoareTime` — the phase contracts around it +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +variable {k : ℕ} + +/-- The outer loop's fuel register. -/ +def rfIdx : Fin (3 + (k + 2) + 0) := ⟨0, by omega⟩ + +/-- The reset's fuel register, restored by every reset. -/ +def wfIdx : Fin (3 + (k + 2) + 0) := ⟨1, by omega⟩ + +/-- Holds the input's padding block; never read again. -/ +def junkIdx : Fin (3 + (k + 2) + 0) := ⟨2, by omega⟩ + +/-- Where `TM.applyTM`'s tape `j` sits in the composite layout. -/ +def appIdx (j : Fin (k + 2)) : Fin (3 + (k + 2) + 0) := placeWorkIdx 3 0 j + +/-- The running value's tape — `applyTM`'s virtual input. -/ +def vinIdx : Fin (3 + (k + 2) + 0) := appIdx (Fin.castSucc (Fin.last k)) + +/-- Where one application of the iterated function leaves its result. -/ +def resIdx : Fin (3 + (k + 2) + 0) := appIdx (Fin.last (k + 1)) + +@[simp] theorem rfIdx_val : (rfIdx (k := k)).val = 0 := rfl +@[simp] theorem wfIdx_val : (wfIdx (k := k)).val = 1 := rfl +@[simp] theorem junkIdx_val : (junkIdx (k := k)).val = 2 := rfl +@[simp] theorem appIdx_val (j : Fin (k + 2)) : (appIdx j).val = 3 + j.val := rfl + +/-- The three bookkeeping tapes are exactly the ones outside `applyTM`'s +block. -/ +theorem not_middle_iff (i : Fin (3 + (k + 2) + 0)) : + ¬ placeWorkInMiddle 3 (k + 2) i ↔ i.val < 3 := by + have hlt := i.isLt + unfold placeWorkInMiddle + constructor <;> intro h <;> omega + +theorem appIdx_middle (j : Fin (k + 2)) : placeWorkInMiddle 3 (k + 2) (appIdx j) := + placeWorkInMiddle_placeWorkIdx 3 0 j + +theorem appIdx_injective : Function.Injective (appIdx (k := k)) := + placeWorkIdx_injective 3 0 + +theorem rfIdx_not_middle : ¬ placeWorkInMiddle 3 (k + 2) (rfIdx (k := k)) := + (not_middle_iff _).mpr (by rw [rfIdx_val]; omega) + +theorem wfIdx_not_middle : ¬ placeWorkInMiddle 3 (k + 2) (wfIdx (k := k)) := + (not_middle_iff _).mpr (by rw [wfIdx_val]; omega) + +theorem junkIdx_not_middle : ¬ placeWorkInMiddle 3 (k + 2) (junkIdx (k := k)) := + (not_middle_iff _).mpr (by rw [junkIdx_val]; omega) + +theorem wfIdx_ne_appIdx (j : Fin (k + 2)) : wfIdx ≠ appIdx j := by + intro h + exact wfIdx_not_middle (h ▸ appIdx_middle j) + +theorem rfIdx_ne_appIdx (j : Fin (k + 2)) : rfIdx ≠ appIdx j := by + intro h + exact rfIdx_not_middle (h ▸ appIdx_middle j) + +theorem junkIdx_ne_appIdx (j : Fin (k + 2)) : junkIdx ≠ appIdx j := by + intro h + exact junkIdx_not_middle (h ▸ appIdx_middle j) + +/-- **The layout is exhaustive.** Every tape of the composite machine is one of +the three bookkeeping tapes or one of `TM.applyTM`'s own, so a predicate that +names all four kinds pins down the whole tape family. -/ +theorem layout_cases (i : Fin (3 + (k + 2) + 0)) : + i = rfIdx ∨ i = wfIdx ∨ i = junkIdx ∨ ∃ j : Fin (k + 2), i = appIdx j := by + by_cases hmid : placeWorkInMiddle 3 (k + 2) i + · exact Or.inr (Or.inr (Or.inr + ⟨placeWorkCoord 3 (k + 2) i hmid, (placeWorkIdx_placeWorkCoord i hmid).symm⟩)) + · rw [not_middle_iff] at hmid + have h : i.val = 0 ∨ i.val = 1 ∨ i.val = 2 := by omega + rcases h with h | h | h + · exact Or.inl (Fin.ext h) + · exact Or.inr (Or.inl (Fin.ext h)) + · exact Or.inr (Or.inr (Or.inl (Fin.ext h))) + +/-- **One application of the iterated function, in the composite layout.** +The bookkeeping tapes are held fixed; `applyTM`'s block goes from its entry +shape for `y` to a state where the result tape holds `G y` and every tape of +the block is still confined to cells `1 … H` — the two facts +`Complexity.resetTapesTM` needs to clean up afterwards. -/ +theorem placedApply_hoareTime (M : TM k) {G : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime G T) (y : List Bool) + (inp₀ : Tape) (hinp : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (H : ℕ) (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) + (extras : Fin (3 + (k + 2) + 0) → Tape) + (hextraSI : ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → Tape.StartInvariant (extras i)) + (hextraH : ∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → 1 ≤ (extras i).head) : + (placeWorkTM 3 0 (applyTM M)).HoareTime + (fun inp work out => inp = inp₀ ∧ + (∀ j, work (appIdx j) = applyPre M y inp₀ j) ∧ + (∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → work i = extras i) ∧ + out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work resIdx).HasOutput (G y) ∧ + (∀ j, Tape.StartInvariant (work (appIdx j)) ∧ (work (appIdx j)).head ≤ H ∧ + ∀ c, H < c → (work (appIdx j)).cells c = Γ.blank) ∧ + (∀ i, ¬ placeWorkInMiddle 3 (k + 2) i → work i = extras i)) + (T y.length) := by + have hbase := placeWorkTM_hoareTime_frame (pre := 3) (post := 0) (applyTM M) + (applyTM_hoareTime_frame M hcomp y inp₀ hinp hinpSI H hHy hHT) extras hextraSI hextraH + refine (hbase.weaken_pre ?_).strengthen_post ?_ + · rintro inp work out ⟨hi, hmid, hext, ho⟩ + exact ⟨⟨hi, funext hmid, ho⟩, hext⟩ + · rintro inp work out ⟨⟨hi, ho, hres, hall⟩, hext⟩ + exact ⟨hi, ho, hres, hall, hext⟩ + +/-- The tapes cleaned between two applications of the iterated function: the +witness machine's own scratch together with the virtual-input tape. The result +tape is deliberately excluded — it still carries the value being moved. -/ +def resetTargets (k : ℕ) : List (Fin (3 + (k + 2) + 0)) := + (List.finRange (k + 1)).map (fun j => appIdx (Fin.castSucc j)) + +theorem resetTargets_nodup : (resetTargets k).Nodup := by + refine (List.nodup_finRange (k + 1)).map ?_ + intro a b hab + exact Fin.castSucc_injective (k + 1) (appIdx_injective hab) + +@[simp] theorem resetTargets_length : (resetTargets k).length = k + 1 := by + simp [resetTargets] + +theorem mem_resetTargets_iff (i : Fin (3 + (k + 2) + 0)) : + i ∈ resetTargets k ↔ ∃ j : Fin (k + 1), appIdx (Fin.castSucc j) = i := by + simp [resetTargets, eq_comm] + +theorem wfIdx_notMem_resetTargets : wfIdx ∉ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact wfIdx_ne_appIdx _ hj.symm + +theorem resIdx_notMem_resetTargets : resIdx ∉ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + have := appIdx_injective hj + exact absurd (congrArg Fin.val this) (by simp; omega) + +theorem vinIdx_mem_resetTargets : vinIdx ∈ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + exact ⟨Fin.last k, rfl⟩ + +/-- The tape cleaned after the result has been moved back. -/ +def resetResult (k : ℕ) : List (Fin (3 + (k + 2) + 0)) := [resIdx] + +theorem resetResult_nodup : (resetResult k).Nodup := List.nodup_singleton _ + +theorem wfIdx_notMem_resetResult : wfIdx ∉ resetResult (k := k) := by + simp only [resetResult, List.mem_singleton] + exact wfIdx_ne_appIdx _ + +/-- **Phases 2–3 of the body.** `δ_right_of_start` only constrains a head that +*reads* `▷`, so an arbitrary witness machine may halt with a head parked on +cell `0`. One idle step lifts every head to at least cell `1`, and one rewind +then brings the result tape's head back to exactly cell `1` — the shape both +`Complexity.resetTapesTM` (which preserves non-target tapes only when they are +parked) and `TM.copyWorkToWorkTM` (which wants its source at cell `1`) +require. -/ +theorem iterPark_hoareTime (H : ℕ) (inp₀ : Tape) (hinpP : Parked inp₀) + (hinpSI : Tape.StartInvariant inp₀) + (W : Fin (3 + (k + 2) + 0) → Tape) + (hSI : ∀ i, Tape.StartInvariant (W i)) + (hB : (W resIdx).head ≤ H) : + (seqTM skipTM (rewindWorkTM resIdx)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (∀ i, i ≠ resIdx → work i = (⟨max (W i).head 1, (W i).cells⟩ : Tape))) + (1 + 1 + (H + 1 + 2)) := by + set WA : Fin (3 + (k + 2) + 0) → Tape := + fun i => (⟨max (W i).head 1, (W i).cells⟩ : Tape) with hWA + have hWAP : ∀ i, Parked (WA i) := fun i => ⟨le_max_right _ _, fun j hj => (hSI i).2 j hj⟩ + have houtP : Parked parkedBlank := parked_parkedBlank + have houtSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + have hinpEq : (⟨max inp₀.head 1, inp₀.cells⟩ : Tape) = inp₀ := + Tape.ext (by show max inp₀.head 1 = inp₀.head; have := hinpP.1; omega) rfl + have houtEq : (⟨max parkedBlank.head 1, parkedBlank.cells⟩ : Tape) = parkedBlank := + Tape.ext (by show max parkedBlank.head 1 = parkedBlank.head; have := houtP.1; omega) rfl + have hA' : (skipTM (n := 3 + (k + 2) + 0)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ work = WA ∧ out = parkedBlank) 1 := + (parkAll_hoareTime inp₀ W parkedBlank hinpSI hSI houtSI).strengthen_post (by + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi.trans hinpEq, funext hw, ho.trans houtEq⟩) + have hP : ∀ (inp : Tape) (work : Fin (3 + (k + 2) + 0) → Tape) (out : Tape) + (inp' : Tape) (work' : Fin (3 + (k + 2) + 0) → Tape) (out' : Tape), + ((work resIdx).cells = (W resIdx).cells ∧ inp = inp₀ ∧ out = parkedBlank ∧ + ∀ i, i ≠ resIdx → work i = WA i) → + (work' resIdx).cells = (work resIdx).cells → + (work' resIdx).head = 1 → + (∀ i, i ≠ resIdx → work' i = work i) → + inp' = inp → out'.cells = out.cells → out'.head = out.head → + ((work' resIdx).cells = (W resIdx).cells ∧ inp' = inp₀ ∧ out' = parkedBlank ∧ + ∀ i, i ≠ resIdx → work' i = WA i) := by + rintro inp work out inp' work' out' ⟨hc, rfl, rfl, hrest⟩ hc' _ hkeep rfl hoc hoh + exact ⟨hc'.trans hc, rfl, Tape.ext hoh hoc, + fun i hi => (hkeep i hi).trans (hrest i hi)⟩ + have hC := rewindWorkTM_hoareTime_frame (n := 3 + (k + 2) + 0) resIdx (H + 1) + (P := fun inp work out => (work resIdx).cells = (W resIdx).cells ∧ + inp = inp₀ ∧ out = parkedBlank ∧ ∀ i, i ≠ resIdx → work i = WA i) hP + have hpreC : ∀ (inp : Tape) (work : Fin (3 + (k + 2) + 0) → Tape) (out : Tape), + (inp = inp₀ ∧ work = WA ∧ out = parkedBlank) → + ((work resIdx).cells 0 = Γ.start ∧ + (∀ j, j ≥ 1 → (work resIdx).cells j ≠ Γ.start) ∧ + (work resIdx).head ≤ H + 1 ∧ + inp.read ≠ Γ.start ∧ + out.read ≠ Γ.start ∧ out.head ≥ 1 ∧ + (∀ i, i ≠ resIdx → (work i).read ≠ Γ.start ∧ (work i).head ≥ 1) ∧ + ((work resIdx).cells = (W resIdx).cells ∧ inp = inp₀ ∧ out = parkedBlank ∧ + ∀ i, i ≠ resIdx → work i = WA i)) := by + rintro inp work out ⟨hi, hw, ho⟩ + subst hw + refine ⟨(hSI resIdx).1, fun j hj => (hSI resIdx).2 j hj, ?_, + by rw [hi]; exact hinpP.read_ne_start, by rw [ho]; exact houtP.read_ne_start, + by rw [ho]; exact houtP.1, + fun i _ => ⟨(hWAP i).read_ne_start, (hWAP i).1⟩, rfl, hi, ho, fun i _ => rfl⟩ + show max (W resIdx).head 1 ≤ H + 1 + omega + have hC' := hC.weaken_pre hpreC + refine (seqTM_hoareTime _ _ hA' ?_ hC').strengthen_post ?_ + · rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨transitionInput_eq_self hinpP.read_ne_start, + funext fun i => transitionTape_eq_self (hWAP i).read_ne_start, + transitionTape_eq_self houtP.read_ne_start⟩ + · rintro inp work out ⟨hh, hc, hi, ho, hrest⟩ + exact ⟨hi, ho, hh, hc, hrest⟩ + +theorem rfIdx_ne_wfIdx : rfIdx (k := k) ≠ wfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +theorem junkIdx_ne_wfIdx : junkIdx (k := k) ≠ wfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +theorem resIdx_ne_wfIdx : resIdx (k := k) ≠ wfIdx := fun h => wfIdx_ne_appIdx _ h.symm + +theorem rfIdx_notMem_resetTargets : rfIdx ∉ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact rfIdx_ne_appIdx _ hj.symm + +theorem junkIdx_notMem_resetTargets : junkIdx ∉ resetTargets (k := k) := by + rw [mem_resetTargets_iff] + rintro ⟨j, hj⟩ + exact junkIdx_ne_appIdx _ hj.symm + +/-- **Phase 4 of the body.** Blank the witness machine's scratch tapes and the +virtual-input tape, leaving the result tape (which carries the value being +moved), both fuel registers, and the junk tape exactly as they were. -/ +theorem iterResetScratch_hoareTime (H : ℕ) (hH : 1 ≤ H) + (inp₀ : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (W : Fin (3 + (k + 2) + 0) → Tape) + (hSI : ∀ i, Tape.StartInvariant (W i)) + (hB : ∀ j : Fin (k + 1), (W (appIdx (Fin.castSucc j))).head ≤ H) + (hfar : ∀ j : Fin (k + 1), ∀ c, H < c → (W (appIdx (Fin.castSucc j))).cells c = Γ.blank) + (hwf : W wfIdx = regTape H) : + (resetTapesTM (resetTargets k) wfIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (∀ i, i ≠ resIdx → work i = (⟨max (W i).head 1, (W i).cells⟩ : Tape))) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work resIdx).head = 1 ∧ + (work resIdx).cells = (W resIdx).cells ∧ + (∀ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank) ∧ + work wfIdx = regTape H ∧ + work rfIdx = (⟨max (W rfIdx).head 1, (W rfIdx).cells⟩ : Tape) ∧ + work junkIdx = (⟨max (W junkIdx).head 1, (W junkIdx).cells⟩ : Tape)) + ((k + 1) * (H + 4) + H * 4 + 8 + 1 + ((k + 1) * (H + 4) + 1)) := by + intro inp work out hpre + obtain ⟨hi, ho, hrh, hrc, hrest⟩ := hpre + rw [hi, ho] + have hworkSI : ∀ j, j ≠ wfIdx → Tape.StartInvariant (work j) := by + intro j _ + by_cases hjr : j = resIdx + · exact ⟨by rw [hjr, hrc]; exact (hSI resIdx).1, + fun c hc => by rw [hjr, hrc]; exact (hSI resIdx).2 c hc⟩ + · rw [hrest j hjr] + exact ⟨(hSI j).1, fun c hc => (hSI j).2 c hc⟩ + have hbnd : ∀ j, j ∈ resetTargets k → + (work j).head ≤ H ∧ ∀ c, H < c → (work j).cells c = Γ.blank := by + intro j hj + obtain ⟨j', rfl⟩ := (mem_resetTargets_iff j).mp hj + have hne : appIdx (Fin.castSucc j') ≠ resIdx := by + intro hc + exact absurd (congrArg Fin.val (appIdx_injective hc)) (by simp; omega) + rw [hrest _ hne] + refine ⟨?_, fun c hc => hfar j' c hc⟩ + show max (W (appIdx (Fin.castSucc j'))).head 1 ≤ H + have := hB j' + omega + have hwfEq : work wfIdx = regTape H := by + rw [hrest wfIdx (fun h => resIdx_ne_wfIdx h.symm), hwf] + refine Tape.ext ?_ rfl + show max (regTape H).head 1 = 1 + rw [regT_head] + omega + obtain ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', hkeep⟩ := + resetTapesTM_hoareTime_of_bounds (resetTargets k) resetTargets_nodup wfIdx + wfIdx_notMem_resetTargets H inp₀ work parkedBlank hinpSI hinpP rfl + (fun j hjw hjt => by + by_cases hjr : j = resIdx + · exact ⟨by rw [hjr, hrh], fun c hc => by + rw [hjr, hrc]; exact (hSI resIdx).2 c hc⟩ + · rw [hrest j hjr] + exact ⟨le_max_right _ _, fun c hc => (hSI j).2 c hc⟩) + inp₀ work parkedBlank ⟨rfl, rfl, hworkSI, hbnd, hwfEq, fun _ _ _ => rfl⟩ + rw [resetTargets_length] at ht + refine ⟨c', t, ht, hreach, hhalt, hi', ho', ?_, ?_, ?_, hR', ?_, ?_⟩ + · rw [hkeep resIdx (fun h => resIdx_ne_wfIdx h) resIdx_notMem_resetTargets]; exact hrh + · rw [hkeep resIdx (fun h => resIdx_ne_wfIdx h) resIdx_notMem_resetTargets]; exact hrc + · intro j + exact hts _ ((mem_resetTargets_iff _).mpr ⟨j, rfl⟩) + · rw [hkeep rfIdx rfIdx_ne_wfIdx rfIdx_notMem_resetTargets] + exact hrest rfIdx (fun h => rfIdx_ne_appIdx _ h) + · rw [hkeep junkIdx junkIdx_ne_wfIdx junkIdx_notMem_resetTargets] + exact hrest junkIdx (fun h => junkIdx_ne_appIdx _ h) + +/-- `TM.applyPre` in closed form: the virtual-input tape carries the value, and +every other tape of the block is blank. -/ +theorem applyPre_eq (M : TM k) (x : List Bool) (inp₀ : Tape) (j : Fin (k + 2)) : + TM.applyPre M x inp₀ j = + if j = Fin.castSucc (Fin.last k) then (Tape.init (x.map Γ.ofBool)).move Dir3.right + else parkedBlank := by + refine Fin.lastCases ?_ ?_ j + · rw [TM.applyPre, Fin.snoc_last, if_neg] + intro hc + exact absurd (congrArg Fin.val hc) (by simp) + · intro j' + rw [TM.applyPre, Fin.snoc_castSucc] + show (TM.retargetInputStartedCfg M x inp₀).work j' = _ + rw [TM.retargetInputStartedCfg] + dsimp only + by_cases hj : j' = Fin.last k + · rw [hj, if_neg (by simp), if_pos rfl] + · have hlt : j'.val < k := by + have := j'.isLt + rcases Nat.lt_or_ge j'.val k with h | h + · exact h + · exact absurd (Fin.ext (show j'.val = (Fin.last k).val by + rw [Fin.val_last]; omega)) hj + rw [if_pos hlt, if_neg (fun hc => hj (Fin.castSucc_injective (k + 1) hc))] + rfl + +theorem resIdx_ne_vinIdx : resIdx (k := k) ≠ vinIdx := by + intro h + exact absurd (congrArg Fin.val (appIdx_injective h)) (by simp) + +theorem rfIdx_ne_resIdx : rfIdx (k := k) ≠ resIdx := rfIdx_ne_appIdx _ +theorem junkIdx_ne_resIdx : junkIdx (k := k) ≠ resIdx := junkIdx_ne_appIdx _ +theorem wfIdx_ne_resIdx : wfIdx (k := k) ≠ resIdx := wfIdx_ne_appIdx _ +theorem rfIdx_ne_vinIdx : rfIdx (k := k) ≠ vinIdx := rfIdx_ne_appIdx _ +theorem junkIdx_ne_vinIdx : junkIdx (k := k) ≠ vinIdx := junkIdx_ne_appIdx _ +theorem wfIdx_ne_vinIdx : wfIdx (k := k) ≠ vinIdx := wfIdx_ne_appIdx _ + +theorem junkIdx_ne_rfIdx : junkIdx (k := k) ≠ rfIdx := by + intro h; exact absurd (congrArg Fin.val h) (by simp) + +/-- **Phases 5–6 of the body.** Move the freshly computed value from the result +tape onto the virtual-input tape — where the next application will read it — +and then blank the result tape, restoring `TM.applyPre`'s entry shape for the +new value. -/ +theorem iterFinish_hoareTime (M : TM k) (H : ℕ) + (x : List Bool) (hx : x.length + 1 ≤ H) + (inp₀ : Tape) (hinpP : Parked inp₀) (hinpSI : Tape.StartInvariant inp₀) + (resT rfT junkT : Tape) + (hresH : resT.head = 1) (hresOut : resT.HasOutput x) + (hresSI : Tape.StartInvariant resT) + (hresFar : ∀ c, H < c → resT.cells c = Γ.blank) + (hrfP : Parked rfT) (hrfSI : Tape.StartInvariant rfT) + (hjunkP : Parked junkT) (hjunkSI : Tape.StartInvariant junkT) : + (seqTM (copyToVirtualInputTM resIdx vinIdx) + (resetTapesTM (resetResult k) wfIdx)).HoareTime + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + work resIdx = resT ∧ work rfIdx = rfT ∧ work junkIdx = junkT ∧ + work wfIdx = regTape H ∧ + (∀ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank)) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + work rfIdx = rfT ∧ work junkIdx = junkT ∧ work wfIdx = regTape H ∧ + (∀ j, work (appIdx j) = TM.applyPre M x inp₀ j)) + (2 * x.length + 5 + 1 + + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1))) := by + have hregP : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i ≠ Γ.start + simp only [regCells]; split + · omega + · split <;> decide⟩ + have hregSI : Tape.StartInvariant (regTape H) := ⟨rfl, hregP.2⟩ + have houtP : Parked parkedBlank := parked_parkedBlank + have hblankSI : Tape.StartInvariant parkedBlank := startInvariant_initNil.move Dir3.right + -- the tape family entering phase 5 + set W₀ : Fin (3 + (k + 2) + 0) → Tape := fun i => + if i = resIdx then resT else if i = rfIdx then rfT else if i = junkIdx then junkT + else if i = wfIdx then regTape H else parkedBlank with hW₀ + have hW₀SI : ∀ i, Tape.StartInvariant (W₀ i) := by + intro i; rw [hW₀]; dsimp only + split; · exact hresSI + split; · exact hrfSI + split; · exact hjunkSI + split; · exact hregSI + exact hblankSI + have hW₀other : ∀ i, i ≠ resIdx → i ≠ vinIdx → Parked (W₀ i) := by + intro i hir _; rw [hW₀]; dsimp only + rw [if_neg hir] + split; · exact hrfP + split; · exact hjunkP + split; · exact hregP + exact houtP + have hW₀res : W₀ resIdx = resT := by rw [hW₀]; simp + have hW₀vin : W₀ vinIdx = parkedBlank := by + rw [hW₀] + dsimp only + rw [if_neg (fun h => resIdx_ne_vinIdx h.symm), if_neg (fun h => rfIdx_ne_appIdx _ h.symm), + if_neg (fun h => junkIdx_ne_appIdx _ h.symm), if_neg (fun h => wfIdx_ne_appIdx _ h.symm)] + have hW₀app : ∀ j : Fin (k + 2), appIdx j ≠ resIdx → W₀ (appIdx j) = parkedBlank := by + intro j hj + rw [hW₀] + dsimp only + rw [if_neg hj, if_neg (fun h => rfIdx_ne_appIdx _ h.symm), + if_neg (fun h => junkIdx_ne_appIdx _ h.symm), if_neg (fun h => wfIdx_ne_appIdx _ h.symm)] + have hW₀rf : W₀ rfIdx = rfT := by + rw [hW₀] + dsimp only + rw [if_neg rfIdx_ne_resIdx, if_pos rfl] + have hW₀junk : W₀ junkIdx = junkT := by + rw [hW₀] + dsimp only + rw [if_neg junkIdx_ne_resIdx, if_neg junkIdx_ne_rfIdx, if_pos rfl] + have hW₀wf : W₀ wfIdx = regTape H := by + rw [hW₀] + dsimp only + rw [if_neg wfIdx_ne_resIdx, if_neg (fun h => rfIdx_ne_wfIdx h.symm), + if_neg (fun h => junkIdx_ne_wfIdx h.symm), if_pos rfl] + -- the value tape produced by the copy, and the family after each phase + set vinT : Tape := (Tape.init (x.map Γ.ofBool)).move Dir3.right with hvinT + have hvinSI : Tape.StartInvariant vinT := (startInvariant_initOfBool x).move Dir3.right + have hvinP : Parked vinT := ⟨le_refl 1, hvinSI.2⟩ + set W₁ : Fin (3 + (k + 2) + 0) → Tape := + Function.update (Function.update W₀ vinIdx vinT) resIdx + (⟨x.length + 1, (W₀ resIdx).cells⟩ : Tape) with hW₁ + set W₂ : Fin (3 + (k + 2) + 0) → Tape := Function.update W₁ resIdx parkedBlank with hW₂ + have hW₁res : W₁ resIdx = (⟨x.length + 1, resT.cells⟩ : Tape) := by + rw [hW₁, Function.update_self, hW₀res] + have hW₁vin : W₁ vinIdx = vinT := by + rw [hW₁, Function.update_of_ne resIdx_ne_vinIdx.symm, Function.update_self] + have hW₁other : ∀ i, i ≠ resIdx → i ≠ vinIdx → W₁ i = W₀ i := by + intro i hir hiv + rw [hW₁, Function.update_of_ne hir, Function.update_of_ne hiv] + have hW₁P : ∀ i, Parked (W₁ i) := by + intro i + by_cases hir : i = resIdx + · rw [hir, hW₁res] + exact ⟨show 1 ≤ x.length + 1 by omega, fun j hj => hresSI.2 j hj⟩ + · by_cases hiv : i = vinIdx + · rw [hiv, hW₁vin]; exact hvinP + · rw [hW₁other i hir hiv]; exact hW₀other i hir hiv + -- phase 5: the copy + have hcopy := copyToVirtualInputTM_hoareTime resIdx vinIdx resIdx_ne_vinIdx x inp₀ W₀ + parkedBlank (by rw [hW₀res]; exact hresH) (by rw [hW₀res]; exact hresOut) + (by rw [hW₀res]; exact ⟨by omega, fun j hj => hresSI.2 j hj⟩) hW₀vin hinpP houtP hW₀other + -- phase 6: blanking the result tape + have hreset := resetTapesTM_hoareTime (resetResult k) resetResult_nodup wfIdx + wfIdx_notMem_resetResult H inp₀ W₁ parkedBlank hinpSI hinpP rfl + (fun j _ => by + by_cases hjr : j = resIdx + · rw [hjr, hW₁res]; exact ⟨hresSI.1, fun c hc => hresSI.2 c hc⟩ + · by_cases hjv : j = vinIdx + · rw [hjv, hW₁vin]; exact hvinSI + · rw [hW₁other j hjr hjv]; exact hW₀SI j) + (fun j hj => by + rw [List.mem_singleton.mp hj, hW₁res] + show x.length + 1 ≤ H + omega) + (fun j hj c hc => by + rw [List.mem_singleton.mp hj, hW₁res] + exact hresFar c hc) + (by rw [hW₁other wfIdx (fun h => resIdx_ne_wfIdx h.symm) (fun h => wfIdx_ne_appIdx _ h), + hW₀wf]) + (fun j hjw hjt => hW₁P j) + have hreset' : (resetTapesTM (resetResult k) wfIdx).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W₁ ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ work = W₂ ∧ out = parkedBlank) + (1 * (H + 4) + H * 4 + 8 + 1 + (1 * (H + 4) + 1)) := by + refine (hreset.strengthen_post ?_).mono_bound (by simp [resetResult]) + rintro inp work out ⟨hi, ho, hts, hR, hrest⟩ + refine ⟨hi, funext fun j => ?_, ho⟩ + by_cases hjr : j = resIdx + · rw [hjr, hts resIdx (by simp [resetResult]), hW₂, Function.update_self] + rfl + · rw [hW₂, Function.update_of_ne hjr] + by_cases hjw : j = wfIdx + · rw [hjw, hR, hW₁other wfIdx (fun h => resIdx_ne_wfIdx h.symm) + (fun h => wfIdx_ne_appIdx _ h), hW₀wf] + · exact hrest j hjw (by simp only [resetResult, List.mem_singleton]; exact hjr) + -- chain the two phases and read the result off + have hpre_imp : ∀ (inp : Tape) (work : Fin (3 + (k + 2) + 0) → Tape) (out : Tape), + (inp = inp₀ ∧ out = parkedBlank ∧ + work resIdx = resT ∧ work rfIdx = rfT ∧ work junkIdx = junkT ∧ + work wfIdx = regTape H ∧ + (∀ j : Fin (k + 1), work (appIdx (Fin.castSucc j)) = parkedBlank)) → + (inp = inp₀ ∧ work = W₀ ∧ out = parkedBlank) := by + rintro inp work out ⟨hi, ho, hres, hrf, hjunk, hwf, happ⟩ + refine ⟨hi, funext fun i => ?_, ho⟩ + rcases layout_cases i with hi' | hi' | hi' | ⟨j, hi'⟩ + · rw [hi', hrf, hW₀rf] + · rw [hi', hwf, hW₀wf] + · rw [hi', hjunk, hW₀junk] + · subst hi' + refine Fin.lastCases ?_ ?_ j + · rw [show appIdx (Fin.last (k + 1)) = resIdx from rfl, hres, hW₀res] + · intro j' + rw [happ j', hW₀app _ (fun h => absurd (appIdx_injective h) + (Fin.castSucc_lt_last j').ne)] + refine (((seqTM_det (copyToVirtualInputTM resIdx vinIdx) + (resetTapesTM (resetResult k) wfIdx) hinpP houtP hW₁P hcopy + hreset').weaken_pre hpre_imp).strengthen_post ?_).mono_bound le_rfl + · rintro inp work out ⟨hi, hw, ho⟩ + subst hw + refine ⟨hi, ho, ?_, ?_, ?_, fun j => ?_⟩ + · rw [hW₂, Function.update_of_ne rfIdx_ne_resIdx, + hW₁other rfIdx rfIdx_ne_resIdx rfIdx_ne_vinIdx, hW₀rf] + · rw [hW₂, Function.update_of_ne junkIdx_ne_resIdx, + hW₁other junkIdx junkIdx_ne_resIdx junkIdx_ne_vinIdx, hW₀junk] + · rw [hW₂, Function.update_of_ne wfIdx_ne_resIdx, + hW₁other wfIdx wfIdx_ne_resIdx wfIdx_ne_vinIdx, hW₀wf] + · rw [applyPre_eq] + by_cases hj : j = Fin.castSucc (Fin.last k) + · rw [if_pos hj, hj, show appIdx (Fin.castSucc (Fin.last k)) = vinIdx from rfl, + hW₂, Function.update_of_ne resIdx_ne_vinIdx.symm, hW₁vin] + · rw [if_neg hj] + by_cases hjl : j = Fin.last (k + 1) + · rw [hjl, show appIdx (Fin.last (k + 1)) = resIdx from rfl, hW₂, Function.update_self] + · have hjr : appIdx j ≠ resIdx := fun h => + hjl (appIdx_injective (h.trans (rfl : resIdx = appIdx (Fin.last (k + 1))))) + have hjv : appIdx j ≠ vinIdx := fun h => + hj (appIdx_injective (h.trans (rfl : vinIdx = appIdx (Fin.castSucc (Fin.last k))))) + rw [hW₂, Function.update_of_ne hjr, hW₁other _ hjr hjv, hW₀app j hjr] + + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean b/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean new file mode 100644 index 00000000..e93bfade --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/MulLen.lean @@ -0,0 +1,716 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Encoding.Pairing +public import Complexitylib.Models.TuringMachine.Registers +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Multiplying the block lengths of a pair — proof internals + +This module builds the one quadratic-output transducer needed by Cobham's +soundness direction: from `pair A B` it emits `|A| · |B|` copies of `false`, +which is exactly the length behaviour of `Complexity.smash`. + +The machine `mulLenTM` is self-contained (one work tape, eight control states): + +1. *scan* — parse the leading self-delimiting block two symbols at a time, + writing one unary mark on the work tape per payload bit, so the work tape + ends up holding `|A|` in unary; +2. *outer loop* — for every remaining input symbol (i.e. `|B|` times) run the + *emit* pass, which walks the `|A|` marks writing one `false` per mark, and + the *rewind* pass, which returns the work head to cell one. + +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Complexity.Cobham.mulUnpair_mem_FP` — the block-length product is `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-! ## The function computed by the scanner -/ + +/-- The remaining output of the length-multiplication scanner when `k` payload +bits of the leading block have already been counted and `w` is the unread part +of the input: `|A| · |B|` copies of `false` for a well-formed remainder, and +nothing at all when the block framing is broken. -/ +def mulAux (k : ℕ) (w : List Bool) : List Bool := + match unpair? w with + | some (x, y) => List.replicate ((k + x.length) * y.length) false + | none => [] + +/-- Emit `|A| · |B|` copies of `false` from a pair `pair A B`; the empty string +on input that is not a valid pair encoding. -/ +def mulUnpair (p : List Bool) : List Bool := mulAux 0 p + +@[simp] theorem mulAux_nil (k : ℕ) : mulAux k [] = [] := rfl + +@[simp] theorem mulAux_singleton (k : ℕ) (b : Bool) : mulAux k [b] = [] := by + cases b <;> rfl + +/-- Reaching the separator ends the block: only the suffix remains. -/ +@[simp] theorem mulAux_sep (k : ℕ) (z : List Bool) : + mulAux k (false :: true :: z) = List.replicate (k * z.length) false := by + simp [mulAux, unpair?] + +/-- A doubled payload bit increments the counted length. -/ +theorem mulAux_double (k : ℕ) (b : Bool) (z : List Bool) : + mulAux k (b :: b :: z) = mulAux (k + 1) z := by + cases b <;> + · simp only [mulAux, unpair?] + cases h : unpair? z with + | none => simp + | some xy => + obtain ⟨x, y⟩ := xy + simp only [Option.map_some, List.length_cons] + congr 2 + omega + +/-- A broken doubling halts the scan with no output. -/ +@[simp] theorem mulAux_broken (k : ℕ) (z : List Bool) : + mulAux k (true :: false :: z) = [] := rfl + +/-- On a genuine pair the scanner emits `|A| · |B|` copies of `false`. -/ +theorem mulUnpair_pair (A B : List Bool) : + mulUnpair (pair A B) = List.replicate (A.length * B.length) false := by + simp [mulUnpair, mulAux] + +/-! ## The scanner -/ + +section MulLenMachine + +/-- Control states of `mulLenTM`. -/ +inductive MulPhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Read the first symbol of a doubled payload bit. -/ + | scanA + /-- The first symbol of the pair was `0`. -/ + | scanB0 + /-- The first symbol of the pair was `1`. -/ + | scanB1 + /-- Consume one symbol of the suffix, or halt at its end. -/ + | outer + /-- Walk the unary marks, emitting one `false` per mark. -/ + | emit + /-- Rewind the work head to cell one. -/ + | rew + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype MulPhase where + elems := {.skip, .scanA, .scanB0, .scanB1, .outer, .emit, .rew, .done} + complete := fun x => by cases x <;> simp + +/-- **The length-multiplication scanner.** Parses the leading self-delimiting +block into `|A|` unary marks on its work tape, then emits `|A|` zeros for each +of the `|B|` remaining input symbols. Computes `mulUnpair`. -/ +def mulLenTM : TM 1 where + Q := MulPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .scanA => + match iHead with + | Γ.zero => + (.scanB0, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.scanB1, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB0 => + match iHead with + | Γ.zero => + (.scanA, fun _ => Γw.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Γ.one => + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB1 => + match iHead with + | Γ.one => + (.scanA, fun _ => Γw.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .outer => + if iHead = Γ.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if wHeads 0 = Γ.one then + (.emit, fun i => readBackWrite (wHeads i), Γw.zero, + idleDir iHead, fun _ => Dir3.right, Dir3.right) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rew => + if wHeads 0 = Γ.start then + (.outer, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun _ => Dir3.right, idleDir oHead) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB0 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB1 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .outer => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ _ => rfl, fun _ => rfl⟩ + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .rew => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ _ => rfl, idleDir_right_of_start⟩ + · exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-! ## Correctness of the scanner -/ + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem idle_eq {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, if_neg h, Tape.move] + +/-- The emit pass: from `emit`, with `m` marks on the work tape and the work +head at cell `k + 1`, the machine writes one `false` for each of the `r` +remaining marks and enters `rew` with the work head past the last mark. -/ +private theorem mulLenTM_emit_loop : + ∀ (r k m : ℕ), k + r = m → ∀ (acc : List Bool) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.emit → + (c.work 0).cells = regCells m → + (c.work 0).head = k + 1 → + c.input.read ≠ Γ.start → + c.output.HasBinaryPrefix acc → + ∃ c', mulLenTM.reachesIn (r + 1) c c' ∧ + c'.state = MulPhase.rew ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = m + 1 ∧ + c'.input = c.input ∧ + c'.output.HasBinaryPrefix (acc ++ List.replicate r false) := by + intro r + induction r with + | zero => + intro k m hkm acc c hstate hcells hhead hinp hpre + have hwread : (c.work 0).read = Γ.blank := by + rw [Tape.read, hcells, hhead]; exact regCells_blank (by omega) + have hwne : (c.work 0).read ≠ Γ.start := by rw [hwread]; decide + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + refine ⟨{ state := MulPhase.rew + input := c.input + work := c.work + output := c.output }, ?_, rfl, hcells, by rw [hhead]; omega, rfl, by simpa⟩ + refine .step ?_ .zero + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)) + (idleDir ((c.work i).read))) = c.work := by + funext i + have : i = 0 := Subsingleton.elim i 0 + subst this + exact idle_eq hwne + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, reduceCtorEq, if_false] + rw [hwork, idle_eq houtne] + | succ r ih => + intro k m hkm acc c hstate hcells hhead hinp hpre + have hwread : (c.work 0).read = Γ.one := by + rw [Tape.read, hcells, hhead]; exact regCells_one (by omega) (by omega) + have hwne : (c.work 0).read ≠ Γ.start := by rw [hwread]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output.writeAndMove (Γ.ofBool false) Dir3.right } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact writeAndMove_readBack _ hwne _ + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, hc1, reduceCtorEq, if_false, + reduceIte] + rw [hwork] + rfl + obtain ⟨c', hreach, hst, hcl, hhd, hin, hout⟩ := + ih (k + 1) m (by omega) (acc ++ [false]) c1 rfl + (by rw [hc1]; simpa using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit false hpre) + refine ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], ?_⟩ + rw [List.append_assoc] at hout + simpa using hout + +/-- The rewind pass: from `rew` with the work head at cell `h`, the machine walks +back to the left-end marker and re-enters `outer` with the work head at cell one, +leaving every tape's contents untouched. -/ +private theorem mulLenTM_rew_loop : + ∀ (h m : ℕ) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.rew → + (c.work 0).cells = regCells m → + (c.work 0).head = h → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → + ∃ c', mulLenTM.reachesIn (h + 1) c c' ∧ + c'.state = MulPhase.outer ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = 1 ∧ + c'.input = c.input ∧ + c'.output = c.output := by + intro h + induction h with + | zero => + intro m c hstate hcells hhead hinp hout + have hwread : (c.work 0).read = Γ.start := by + rw [Tape.read, hcells, hhead]; rfl + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + show ((c.work 0).write _).move Dir3.right = (c.work 0).move Dir3.right + rw [Tape.write, if_pos hhead] + refine ⟨{ state := MulPhase.outer + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simp [Tape.move_cells, hcells], + by simp [Tape.move, hhead], rfl, rfl⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hwread, hinp_eq, reduceIte, reduceCtorEq, + if_false] + rw [hwork, idle_eq hout] + | succ h ih => + intro m c hstate hcells hhead hinp hout + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.rew + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, if_neg hwne] + exact writeAndMove_readBack _ hwne _ + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hinp_eq, hc1, if_neg hwne, reduceCtorEq, + if_false] + rw [hwork, idle_eq hout] + obtain ⟨c', hreach, hst, hcl, hhd, hin, hou⟩ := + ih m c1 rfl (by rw [hc1]; simpa [Tape.move_cells] using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) (by rw [hc1]; simpa using hout) + exact ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], by rw [hou, hc1]⟩ + +/-- The outer loop: from `outer`, with `m` marks on the work tape and `B` left to +read, the machine runs one emit-and-rewind pass per symbol of `B` and halts with +`|B| · m` zeros appended to the output. -/ +private theorem mulLenTM_outer_loop : + ∀ (B : List Bool) (m : ℕ) (acc : List Bool) (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.outer → + (c.work 0).cells = regCells m → + (c.work 0).head = 1 → + c.input.HasBinarySuffix B → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ B.length * (2 * m + 4) + 1 ∧ mulLenTM.reachesIn t c c' ∧ + mulLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ List.replicate (B.length * m) false) := by + intro B + induction B with + | nil => + intro m acc c hstate hcells hhead hsuf hpre + have hread : c.input.read = Γ.blank := hsuf.read_nil + have hinp : c.input.read ≠ Γ.start := by rw [hread]; decide + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir Γ.blank) = c.input := by + rw [idleDir, if_neg (by decide), Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hinp_eq, reduceIte, reduceCtorEq, + if_false] + rw [hwork, idle_eq houtne] + | cons b B ih => + intro m acc c hstate hcells hhead hsuf hpre + have hread : c.input.read = Γ.ofBool b := hsuf.read_cons + have hnb : ¬ c.input.read = Γ.blank := by rw [hread]; cases b <;> decide + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.emit + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep : mulLenTM.step c = some c1 := by + simp only [TM.step, hstate, mulLenTM, hnb, hc1, reduceCtorEq, if_false] + rw [hwork, idle_eq houtne] + have hsuf1 : c1.input.HasBinarySuffix B := hsuf.move_right_cons + obtain ⟨c2, hreach2, hst2, hcl2, hhd2, hin2, hout2⟩ := + mulLenTM_emit_loop m 0 m (by omega) acc c1 rfl (by rw [hc1]; exact hcells) + (by rw [hc1]; simpa using hhead) hsuf1.read_ne_start (by rw [hc1]; exact hpre) + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hout3⟩ := + mulLenTM_rew_loop (m + 1) m c2 hst2 hcl2 hhd2 + (by rw [hin2]; exact hsuf1.read_ne_start) + (by rw [hout2.read_blank]; decide) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih m (acc ++ List.replicate m false) c3 hst3 hcl3 hhd3 + (by rw [hin3, hin2]; exact hsuf1) (by rw [hout3]; exact hout2) + refine ⟨c', (m + 1 + (m + 1 + 1 + t)) + 1, ?_, ?_, hhalt', ?_⟩ + · simp only [List.length_cons] + have : (B.length + 1) * (2 * m + 4) = B.length * (2 * m + 4) + (2 * m + 4) := by ring + omega + · exact .step hstep + (mulLenTM.reachesIn_trans hreach2 (mulLenTM.reachesIn_trans hreach3 hreach')) + · rw [List.append_assoc, ← List.replicate_add] at hout' + have : m + B.length * m = (b :: B).length * m := by + simp only [List.length_cons]; ring + rwa [this] at hout' + +/-- The scan pass: from `scanA`, with `k` payload bits already counted as marks on +the work tape and `w` still unread, the machine runs the rest of the computation +and halts with `mulAux k w` on the output tape. The parameter `N` is a fuel bound +on `k + |w|`, which strictly decreases across the recursive step. -/ +private theorem mulLenTM_scan_loop : + ∀ (N : ℕ) (w : List Bool) (k : ℕ), k + w.length ≤ N → + ∀ (c : Cfg 1 mulLenTM.Q), + c.state = MulPhase.scanA → + (c.work 0).cells = regCells k → + (c.work 0).head = k + 1 → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix [] → + ∃ c' t, t ≤ 2 * N ^ 2 + 5 * N + 5 ∧ mulLenTM.reachesIn t c c' ∧ + mulLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (mulAux k w) := by + intro N + induction N with + | zero => + intro w k hN c hstate hcells hhead hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (by omega) + subst hwnil + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + have hread : c.input.read = Γ.blank := hsuf.read_nil + have hinp_eq : c.input.move (idleDir Γ.blank) = c.input := by + rw [idleDir, if_neg (by decide), Tape.move] + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hinp_eq, reduceCtorEq, if_false] + rw [hwork, idle_eq houtne] + | succ N ih => + intro w k hN c hstate hcells hhead hsuf hpre + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact idle_eq hwne + have hidleB : ∀ t : Tape, t.move (idleDir Γ.blank) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + have hidleZ : ∀ t : Tape, t.move (idleDir Γ.zero) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + -- The one-step transition out of `scanA` on a payload bit. + have hstepA : ∀ b : Bool, + c.input.read = Γ.ofBool b → + mulLenTM.step c = some + { state := (bif b then MulPhase.scanB1 else MulPhase.scanB0) + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + intro b hread + cases b <;> + · simp only [TM.step, hstate, mulLenTM, hread, Γ.ofBool, reduceCtorEq, if_false, + cond_true, cond_false] + rw [hwork, idle_eq houtne] + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := MulPhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, mulLenTM, hread, hidleB, reduceCtorEq, if_false] + rw [hwork, idle_eq houtne] + | [b] => + -- One payload symbol then end of input: the block framing is broken. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix [] := hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.blank := hsuf1.read_nil + refine ⟨{ state := MulPhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [mulAux_singleton] using hpre⟩ + refine .step (hstepA b hsuf.read_cons) (.step ?_ .zero) + cases b <;> + · simp only [TM.step, mulLenTM, hread1, hidleB, reduceCtorEq, if_false, + cond_true, cond_false] + rw [hwork, idle_eq houtne] + | true :: false :: z => + -- A broken doubling: halt with empty output. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.zero := hsuf1.read_cons + refine ⟨{ state := MulPhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [mulAux_broken] using hpre⟩ + refine .step (hstepA true hsuf.read_cons) (.step ?_ .zero) + simp only [TM.step, mulLenTM, hread1, hidleZ, reduceCtorEq, if_false, + cond_true] + rw [hwork, idle_eq houtne] + | false :: true :: z => + -- The separator: rewind the work tape and run the outer loop over `z`. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.one := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.rew + input := (c.input.move Dir3.right).move Dir3.right + work := c.work + output := c.output } with hc2 + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, if_false] + rw [hwork, idle_eq houtne] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hou3⟩ := + mulLenTM_rew_loop (k + 1) k c2 rfl (by rw [hc2]; exact hcells) + (by rw [hc2]; exact hhead) hsuf2.read_ne_start (by rw [hc2]; exact houtne) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + mulLenTM_outer_loop z k [] c3 hst3 hcl3 hhd3 (by rw [hin3]; exact hsuf2) + (by rw [hou3]; exact hpre) + refine ⟨c', (k + 1 + 1 + t) + 1 + 1, ?_, ?_, hhalt', ?_⟩ + · simp only [List.length_cons] at hN + have hz : z.length ≤ N := by omega + have hk : k ≤ N := by omega + have ht' : t ≤ z.length * (2 * k + 4) + 1 := ht + have : z.length * (2 * k + 4) ≤ N * (2 * N + 4) := by + exact Nat.mul_le_mul hz (by omega) + nlinarith [sq_nonneg N] + · exact .step hstep1 (.step hstep2 (mulLenTM.reachesIn_trans hreach3 hreach')) + · rw [mulAux_sep] + have : z.length * k = k * z.length := Nat.mul_comm _ _ + rw [this] at hout' + simpa using hout' + | false :: false :: z => + -- A doubled `0`: write one mark and continue scanning. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.zero := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Γ.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Γw.one).toΓ Dir3.right) + = fun i => ((c.work i).write Γ.one).move Dir3.right := rfl + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, if_false] + rw [hwmark, idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, if_neg (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Γ.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 hhead2 + (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, ?_, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + · nlinarith [sq_nonneg N] + · rwa [mulAux_double] + | true :: true :: z => + -- A doubled `1`: write one mark and continue scanning. + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.one := hsuf1.read_cons + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanB1 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : mulLenTM.step c = some c1 := hstepA true hsuf.read_cons + set c2 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Γ.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Γw.one).toΓ Dir3.right) + = fun i => ((c.work i).write Γ.one).move Dir3.right := rfl + have hstep2 : mulLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, mulLenTM, hread1, reduceCtorEq, if_false] + rw [hwmark, idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, if_neg (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Γ.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 hhead2 + (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, ?_, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + · nlinarith [sq_nonneg N] + · rwa [mulAux_double] + +/-- The blank work tape of the initial configuration is the zero register. -/ +private theorem init_nil_cells_eq_regCells_zero : + (Tape.init ([] : List Γ)).cells = regCells 0 := by + funext j + rcases Nat.eq_zero_or_pos j with rfl | hj + · rfl + · obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_ge _ _ (by simp), regCells_blank (by omega)] + +/-- `mulUnpair` is polynomial-time, via the `mulLenTM` scanner. -/ +theorem mulUnpair_mem_FP : mulUnpair ∈ FP := by + refine ⟨2, 1, mulLenTM, (fun m => 2 * m ^ 2 + 5 * m + 6), ?_, ?_⟩ + · intro z + -- Step 1: move every head off the left-end marker. + set c1 : Cfg 1 mulLenTM.Q := + { state := MulPhase.scanA + input := (Tape.init (z.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : mulLenTM.step (mulLenTM.initCfg z) = some c1 := by + simp [TM.step, mulLenTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + mulLenTM_scan_loop z.length z 0 (by omega) c1 rfl + (by rw [hc1]; show ((Tape.init []).move Dir3.right).cells = _ + rw [Tape.move_cells, init_nil_cells_eq_regCells_zero]) + (by rw [hc1]; show ((Tape.init []).move Dir3.right).head = _ + simp [Tape.move]) + hsuf hpre + exact ⟨c', t + 1, by simpa using by omega, .step hstep1 hreach, hhalt, + hout.hasOutput⟩ + · have h1 : (fun m : ℕ => 2 * m ^ 2) =O ((· ^ 2) : ℕ → ℕ) := by + simpa using (BigO.refl (fun m : ℕ => m ^ 2)).const_mul_left 2 + have h2 : (fun m : ℕ => 5 * m) =O ((· ^ 2) : ℕ → ℕ) := + BigO.const_mul_left 5 + (by simpa [pow_one] using (BigO.pow_le_pow_right (by omega : 1 ≤ 2))) + exact BigO.add (BigO.add h1 h2) (BigO.const_le_pow 6 2) + +end MulLenMachine + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean b/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean new file mode 100644 index 00000000..99c6b69a --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Reorder.lean @@ -0,0 +1,712 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.Counter +public import Complexitylib.Models.TuringMachine.Tape.Encoding +public import Complexitylib.Classes.P.Cobham.Internal.FstBlock +public import Complexitylib.Classes.P.Cobham.Internal.SndBlock + +/-! +# Dropping the third component of a triple — proof internals + +`Cobham.reorder` turns `pair A (pair B C)` into `pair A B`: copy the leading +block verbatim, then decode the next block's payload. It is the one machine the +`comp` constructor needs, via `Cobham.pairFn_mem_FP`. + +## Main results + +- `Cobham.reorder_mem_FP` — the triple reorder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- Drop the third component of a right-nested triple. Copy doubled payload bits +verbatim until the `[false, true]` separator, then decode the *next* block's +payload (`fstBlock`). On a valid triple this satisfies +`reorder (pair A (pair B C)) = pair A B` (`reorder_pair_pair`). The incremental +recursion (writing before knowing validity) is what the `reorderTM` scanner +computes; it is total and needs no sub-machines. -/ +def reorder : List Bool → List Bool + | false :: false :: z => false :: false :: reorder z + | true :: true :: z => true :: true :: reorder z + | false :: true :: z => false :: true :: fstBlock z + | c :: _ => [c] + | [] => [] + +theorem reorder_pair_pair (A B C : List Bool) : + reorder (pair A (pair B C)) = pair A B := by + induction A with + | nil => + show false :: true :: fstBlock (pair B C) = false :: true :: B + rw [fstBlock_pair] + | cons a A ih => + rw [pair_cons_eq] + cases a + · show false :: false :: reorder (pair A (pair B C)) = pair (false :: A) B + rw [ih, pair_cons_eq] + · show true :: true :: reorder (pair A (pair B C)) = pair (true :: A) B + rw [ih, pair_cons_eq] + +/-- Control states of `reorderTM`: skip the marker; phase 1 (`rcopyA`/`rcopyBf`/ +`rcopyBt`) copies doubled pairs verbatim until the separator; phase 2 +(`rdecA`/`rdecBf`/`rdecBt`) decodes the next block's payload; then halt. -/ +inductive ReorderPhase where + | rskip | rcopyA | rcopyBf | rcopyBt | rdecA | rdecBf | rdecBt | rdone + deriving DecidableEq + +instance : Fintype ReorderPhase where + elems := {.rskip, .rcopyA, .rcopyBf, .rcopyBt, .rdecA, .rdecBf, .rdecBt, .rdone} + complete := fun x => by cases x <;> simp + +/-- The reorder transducer computing `reorder`: copy the leading block verbatim +(phase 1) up to and including the `[false,true]` separator, then decode and emit +the payload of the following block (phase 2). -/ +def reorderTM : TM 0 where + Q := ReorderPhase + qstart := .rskip + qhalt := .rdone + δ := fun state iHead wHeads oHead => + match state with + | .rskip => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .rcopyA => + match iHead with + | Γ.zero => + (.rcopyBf, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | Γ.one => + (.rcopyBt, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rcopyBf => + match iHead with + | Γ.zero => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | Γ.one => + (.rdecA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rcopyBt => + match iHead with + | Γ.one => + (.rcopyA, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecA => + match iHead with + | Γ.zero => + (.rdecBf, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.rdecBt, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecBf => + match iHead with + | Γ.zero => + (.rdecA, fun i => readBackWrite (wHeads i), Γw.ofBool false, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdecBt => + match iHead with + | Γ.one => + (.rdecA, fun i => readBackWrite (wHeads i), Γw.ofBool true, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | _ => + (.rdone, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rdone => allIdle .rdone iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .rskip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .rcopyA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rcopyBf => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rcopyBt => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecBf => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdecBt => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rdone => exact rightOfStart_allIdle iHead wHeads oHead + +/-- Phase 2 of `reorderTM`: from `rdecA` on input `w` with output holding `acc`, +decode and emit `fstBlock w`, halting with `acc ++ fstBlock w`. Identical in shape +to `fstBlockTM_scan_loop`. -/ +private theorem reorderTM_dec_loop : + ∀ (fuel : ℕ) (w acc : List Bool), w.length ≤ fuel → ∀ (c : Cfg 0 reorderTM.Q), + c.state = ReorderPhase.rdecA → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ 2 * w.length + 2 ∧ reorderTM.reachesIn t c c' ∧ reorderTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ fstBlock w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Γ.blank := hsuf.read_nil + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [fstBlock] using hpre + | [false] => + have hread : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | [true] => + have hread : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: true :: y => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | true :: false :: rest => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [fstBlock] using hpre1 + | false :: false :: z => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool false) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false]) := by + show (c1.output.writeAndMove ((Γw.ofBool false).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit false hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (false :: false :: z) = false :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + | true :: true :: z => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix acc := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (Γw.ofBool true) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true]) := by + show (c1.output.writeAndMove ((Γw.ofBool true).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [Γw.ofBool_toΓ]; exact Tape.hasBinaryPrefix_write_bit true hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hfb : fstBlock (true :: true :: z) = true :: fstBlock z := rfl + rw [hfb, List.append_assoc, List.cons_append, List.nil_append] at * + exact hcout + +/-- Phase 1 of `reorderTM`: from `rcopyA` on input `w` with output holding `acc`, +copy `w`'s leading block verbatim and decode the following block, halting with +`acc ++ reorder w`. The separator case hands off to `reorderTM_dec_loop`. -/ +private theorem reorderTM_copy_loop : + ∀ (fuel : ℕ) (w acc : List Bool), w.length ≤ fuel → ∀ (c : Cfg 0 reorderTM.Q), + c.state = ReorderPhase.rcopyA → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ 3 * w.length + 3 ∧ reorderTM.reachesIn t c c' ∧ reorderTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ reorder w) := by + intro fuel + induction fuel with + | zero => + intro w acc hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Γ.blank := hsuf.read_nil + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [reorder] using hpre + | succ fuel ih => + intro w acc hw c hstate hsuf hpre + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + -- The `rcopyA` step emits the first bit `c1` verbatim. + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := ReorderPhase.rdone + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, reorderTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + simpa [reorder] using hpre + | [false] => + have hread : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool false := by rw [hread]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [reorder] using hpre1 + | [true] => + have hread : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool true := by rw [hread]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, reorderTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + simpa [reorder] using hpre1 + | false :: true :: y => + -- separator: copy `false` then `true`, then decode `y`. + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool false := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rdecA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false, true]) := by + have hco : (readBackWrite c1.input.read).toΓ = Γ.ofBool true := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [false, true]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit true hpre1 + rwa [List.append_assoc] at this + have hyfuel : y.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + reorderTM_dec_loop fuel y (acc ++ [false, true]) hyfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (false :: true :: y) = false :: true :: fstBlock y := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | false :: false :: z => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBf + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [false]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool false := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [false]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit false hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [false, false]) := by + have hco : (readBackWrite c1.input.read).toΓ = Γ.ofBool false := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [false, false]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit false hpre1 + rwa [List.append_assoc] at this + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [false, false]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (false :: false :: z) = false :: false :: reorder z := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | true :: true :: z => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool true := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.input.read) Dir3.right } + have hstepB : reorderTM.step c1 = some c2 := by + simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix (acc ++ [true, true]) := by + have hco : (readBackWrite c1.input.read).toΓ = Γ.ofBool true := by rw [hreadB]; rfl + show (c1.output.writeAndMove ((readBackWrite c1.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [true, true]) + rw [hco] + have := Tape.hasBinaryPrefix_write_bit true hpre1 + rwa [List.append_assoc] at this + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z (acc ++ [true, true]) hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have hr : reorder (true :: true :: z) = true :: true :: reorder z := rfl + rw [hr] + rwa [List.append_assoc] at hcout + | true :: false :: rest => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyBt + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstepA : reorderTM.step c = some c1 := by + simp [TM.step, hstate, reorderTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [true]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool true := by rw [hreadA]; rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) + Dir3.right).HasBinaryPrefix + (acc ++ [true]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit true hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + have houtne1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + refine ⟨{ state := ReorderPhase.rdone + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, reorderTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from Tape.writeAndMove_readBack_idle_of_ne_start _ houtne1] + have hr : reorder (true :: false :: rest) = [true] := rfl + rw [hr] + exact hpre1 + +/-- `reorder` is polynomial-time, via the `reorderTM` scanner. -/ +theorem reorder_mem_FP : reorder ∈ FP := by + refine ⟨1, 0, reorderTM, (fun m => 3 * m + 4), ?_, ?_⟩ + · intro z + let c1 : Cfg 0 reorderTM.Q := + { state := ReorderPhase.rcopyA + input := (Tape.init (z.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : reorderTM.step (reorderTM.initCfg z) = some c1 := by + simp [TM.step, reorderTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + reorderTM_copy_loop z.length z [] le_rfl c1 rfl hsuf hpre + refine ⟨c', t + 1, by show t + 1 ≤ 3 * z.length + 4; omega, + .step hstep1 hreach, hhalt, ?_⟩ + simpa using hcout.hasOutput + · have hn : (fun m : ℕ => 3 * m) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun m : ℕ => m)).const_mul_left 3 + exact BigO.add hn (BigO.const_le_pow 4 1) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean b/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean new file mode 100644 index 00000000..3ca2c652 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Reverse.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Models.TuringMachine.Combinators +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Polynomial-time string reversal — proof internals + +The transducer `reverseTM` has one work tape and four control states: it copies +the input onto the work tape left to right, then walks the work head back to the +left-end marker, emitting each cell to the output as it passes. The result is the +input read backwards, in `2 · |x| + 3` steps. + +Reversal is what turns a right-to-left recursion into a left-to-right loop: +recursion on notation peels the *head* of a string, so an iterative evaluation +consumes the *last* bit first. + +## Main results + +- `Complexity.reverse_mem_FP` — reversal is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-- Control states of `reverseTM`. -/ +inductive RevPhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Copy the input onto the work tape, left to right. -/ + | copy + /-- Walk the work head back, emitting each cell to the output. -/ + | emit + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype RevPhase where + elems := {.skip, .copy, .emit, .done} + complete := fun x => by cases x <;> simp + +/-- **The reversal transducer.** Copies the input onto its work tape, then +sweeps the work head back to the left-end marker, writing each cell it passes to +the output tape. Computes `List.reverse`. -/ +def reverseTM : TM 1 where + Q := RevPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.copy, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .copy => + match iHead with + | Γ.zero => + (.copy, fun _ => Γw.zero, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Γ.one => + (.copy, fun _ => Γw.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .emit => + if wHeads 0 = Γ.zero then + (.emit, fun i => readBackWrite (wHeads i), Γw.zero, + idleDir iHead, fun i => moveLeftDir (wHeads i), Dir3.right) + else if wHeads 0 = Γ.one then + (.emit, fun i => readBackWrite (wHeads i), Γw.one, + idleDir iHead, fun i => moveLeftDir (wHeads i), Dir3.right) + else + (.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 + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .copy => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => moveLeftDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + fun _ => rfl⟩ + · split + · exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + fun _ => rfl⟩ + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem rev_idle_eq {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, if_neg h, Tape.move] + +/-- The copy phase: from `copy` with the input cursor on `w` and the work tape +holding `acc`, the machine appends `w` to the work tape and enters `emit` with +the work head on the last copied cell. -/ +private theorem reverseTM_copy_loop : + ∀ (w acc : List Bool) (c : Cfg 1 reverseTM.Q), + c.state = RevPhase.copy → + c.input.HasBinarySuffix w → + (c.work 0).HasBinaryPrefix acc → + (c.work 0).cells 0 = Γ.start → + c.output.HasBinaryPrefix [] → + ∃ c', reverseTM.reachesIn (w.length + 1) c c' ∧ + c'.state = RevPhase.emit ∧ + (c'.work 0).HasBinaryContent (acc ++ w) ∧ + (c'.work 0).cells 0 = Γ.start ∧ + (c'.work 0).head = (acc ++ w).length ∧ + c'.input.read ≠ Γ.start ∧ + c'.output.HasBinaryPrefix [] := by + intro w + induction w with + | nil => + intro acc c hstate hsuf hwork hw0 hout + have hread : c.input.read = Γ.blank := hsuf.read_nil + have houtne : c.output.read ≠ Γ.start := by rw [hout.read_blank]; decide + have hwread : (c.work 0).read = Γ.blank := by + rw [Tape.read, hwork.1] + exact hwork.2.2 acc.length le_rfl + have hwne : (c.work 0).read ≠ Γ.start := by rw [hwread]; decide + have hinp_eq : c.input.move (idleDir Γ.blank) = c.input := by + rw [idleDir, if_neg (by decide), Tape.move] + have hwmove : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, if_neg hwne] + exact writeAndMove_readBack _ hwne _ + refine ⟨{ state := RevPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output }, ?_, rfl, ?_, ?_, ?_, by rw [hread]; decide, by simpa⟩ + · refine .step ?_ .zero + simp only [TM.step, hstate, reverseTM, hread, hinp_eq, reduceCtorEq, if_false] + rw [hwmove, rev_idle_eq houtne] + · have hc : (c.work 0).HasBinaryContent acc := hwork.2 + simpa using hc.move Dir3.left + · show ((c.work 0).move Dir3.left).cells 0 = _ + rw [Tape.move_cells]; exact hw0 + · show ((c.work 0).move Dir3.left).head = _ + simp only [Tape.move, hwork.1, List.append_nil] + omega + | cons b w ih => + intro acc c hstate hsuf hwork hw0 hout + have hread : c.input.read = Γ.ofBool b := hsuf.read_cons + have houtne : c.output.read ≠ Γ.start := by rw [hout.read_blank]; decide + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.copy + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (Γ.ofBool b) Dir3.right + output := c.output } with hc1 + have hstep : reverseTM.step c = some c1 := by + cases b <;> + · simp only [TM.step, hstate, reverseTM, hread, Γ.ofBool, hc1, + reduceCtorEq, if_false] + rw [rev_idle_eq houtne] + rfl + obtain ⟨c', hreach, hst, hcont, hcz, hhd, hinp, hpre⟩ := + ih (acc ++ [b]) c1 rfl hsuf.move_right_cons + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit b hwork) + (by + show ((c.work 0).writeAndMove (Γ.ofBool b) Dir3.right).cells 0 = Γ.start + exact Tape.write_move_cell0 _ _ hw0) + (by rw [hc1]; exact hout) + refine ⟨c', .step hstep hreach, hst, ?_, hcz, ?_, hinp, hpre⟩ + · simpa using hcont + · simpa using hhd + +/-- The emit phase: from `emit` with the work tape holding `bits` and its head on +cell `j`, the machine writes `bits.take j` backwards to the output and halts. -/ +private theorem reverseTM_emit_loop : + ∀ (j : ℕ) (bits acc : List Bool) (c : Cfg 1 reverseTM.Q), + c.state = RevPhase.emit → + (c.work 0).HasBinaryContent bits → + (c.work 0).cells 0 = Γ.start → + (c.work 0).head = j → j ≤ bits.length → + c.input.read ≠ Γ.start → + c.output.HasBinaryPrefix acc → + ∃ c', reverseTM.reachesIn (j + 1) c c' ∧ reverseTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ (bits.take j).reverse) := by + intro j + induction j with + | zero => + intro bits acc c hstate hcont hw0 hhead _ hinp hout + have hwread : (c.work 0).read = Γ.start := by rw [Tape.read, hhead]; exact hw0 + have hwne0 : ¬ (c.work 0).read = Γ.zero := by rw [hwread]; decide + have hwne1 : ¬ (c.work 0).read = Γ.one := by rw [hwread]; decide + have houtne : c.output.read ≠ Γ.start := by rw [hout.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + refine ⟨{ state := RevPhase.done + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simpa using hout⟩ + refine .step ?_ .zero + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [Tape.writeAndMove, Tape.write, if_pos (by omega : (c.work 0).head = 0), + idleDir, if_pos hwread] + simp only [TM.step, hstate, reverseTM, hinp_eq, hwne0, hwne1, reduceCtorEq, + if_false] + rw [hwork, rev_idle_eq houtne] + | succ j ih => + intro bits acc c hstate hcont hw0 hhead hjb hinp hout + have hjlt : j < bits.length := by omega + have hwread : (c.work 0).read = Γ.ofBool (bits[j]'hjlt) := by + rw [Tape.read, hhead]; exact hcont.1 j hjlt + have hwne : (c.work 0).read ≠ Γ.start := by + rw [hwread]; exact Γ.ofBool_ne_start _ + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + have hwmove : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, if_neg hwne] + exact writeAndMove_readBack _ hwne _ + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.emit + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output.writeAndMove (Γ.ofBool (bits[j]'hjlt)) Dir3.right } with hc1 + have hstep : reverseTM.step c = some c1 := by + rcases hb : bits[j]'hjlt with _ | _ + · have h0 : (c.work 0).read = Γ.zero := by rw [hwread, hb]; rfl + simp only [TM.step, hstate, reverseTM, hinp_eq, h0, hc1, hb, Γ.ofBool, + reduceCtorEq, if_false, reduceIte] + rw [hwmove] + rfl + · have h1 : (c.work 0).read = Γ.one := by rw [hwread, hb]; rfl + simp only [TM.step, hstate, reverseTM, hinp_eq, h1, hc1, hb, Γ.ofBool, + reduceCtorEq, if_false, reduceIte] + rw [hwmove] + rfl + obtain ⟨c', hreach, hhalt, hfin⟩ := + ih bits (acc ++ [bits[j]'hjlt]) c1 rfl + (by rw [hc1]; exact hcont.move Dir3.left) + (by rw [hc1]; show ((c.work 0).move Dir3.left).cells 0 = _ + rw [Tape.move_cells]; exact hw0) + (by rw [hc1]; show ((c.work 0).move Dir3.left).head = _ + simp only [Tape.move, hhead]; omega) + (by omega) + (by rw [hc1]; exact hinp) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit _ hout) + refine ⟨c', .step hstep hreach, hhalt, ?_⟩ + have hsplit : bits.take (j + 1) = bits.take j ++ [bits[j]'hjlt] := by + rw [List.take_add_one, List.getElem?_eq_getElem hjlt] + rfl + have heq : acc ++ (bits.take (j + 1)).reverse + = (acc ++ [bits[j]'hjlt]) ++ (bits.take j).reverse := by + rw [hsplit]; simp + rw [heq] + exact hfin + +/-- `reverseTM` computes `List.reverse` in `2 · |x| + 3` steps. -/ +theorem reverseTM_computesInTime : + reverseTM.ComputesInTime (fun x : List Bool => x.reverse) (fun n => 2 * n + 3) := by + intro x + set c1 : Cfg 1 reverseTM.Q := + { state := RevPhase.copy + input := (Tape.init (x.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : reverseTM.step (reverseTM.initCfg x) = some c1 := by + simp [TM.step, reverseTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c2, hreach2, hst2, hcont2, hcz2, hhd2, hinp2, hout2⟩ := + reverseTM_copy_loop x [] c1 rfl + (by rw [hc1]; exact Tape.init_move_right_hasBinarySuffix x) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + (by rw [hc1]; show ((Tape.init ([] : List Γ)).move Dir3.right).cells 0 = _ + rw [Tape.move_cells]; simp) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + obtain ⟨c', hreach', hhalt', hfin⟩ := + reverseTM_emit_loop x.length x [] c2 hst2 (by simpa using hcont2) hcz2 + (by simpa using hhd2) le_rfl hinp2 hout2 + refine ⟨c', ((x.length + 1) + (x.length + 1)) + 1, by simp; omega, + .step hstep1 (reverseTM.reachesIn_trans hreach2 hreach'), hhalt', ?_⟩ + rw [List.nil_append, List.take_length] at hfin + exact hfin.hasOutput + +/-- Internal proof that string reversal is in `FP`. -/ +theorem reverse_mem_FP : + (fun x : List Bool => x.reverse) ∈ FP := by + refine ⟨1, 1, reverseTM, (fun n => 2 * n + 3), reverseTM_computesInTime, ?_⟩ + have hn : (fun n : ℕ => 2 * n) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun n : ℕ => n)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean b/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean new file mode 100644 index 00000000..51c749bd --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Simulate.lean @@ -0,0 +1,537 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.Blocks +public import Complexitylib.Classes.P.Cobham.Internal.Extract +public import Complexitylib.Classes.P.Cobham.Internal.StepAlgebra +public import Complexitylib.Models.TuringMachine.OutputBounds + +/-! +# Running a machine inside the algebra — proof internals + +Everything the completeness direction needs about a *run*, as opposed to a single +step: a total step function that stands still once the machine has halted, the +standing invariants of a run (the left-end marker where it belongs, every head +inside the encoded window), and the iterated versions of `Cobham.stepFn` and +`Cobham.rewindFn`. + +## Main results + +- `Complexity.TM.runCfg` — the configuration after `n` steps, halting-idempotent +- `Complexity.Cobham.iterate_stepFn` — the encoded iteration tracks it +- `Complexity.Cobham.iterate_rewindFn` — the rewind iteration drives the head to + cell `0` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-! ## A total run -/ + +/-- The configuration after `n` steps, standing still once halted. -/ +def runCfg (tm : TM k) (c : Cfg k tm.Q) : ℕ → Cfg k tm.Q + | 0 => c + | n + 1 => (tm.step (runCfg tm c n)).getD (runCfg tm c n) + +@[simp] theorem runCfg_zero (tm : TM k) (c : Cfg k tm.Q) : runCfg tm c 0 = c := rfl + +theorem runCfg_succ (tm : TM k) (c : Cfg k tm.Q) (n : ℕ) : + runCfg tm c (n + 1) = (tm.step (runCfg tm c n)).getD (runCfg tm c n) := rfl + +theorem runCfg_add (tm : TM k) (c : Cfg k tm.Q) (a b : ℕ) : + runCfg tm c (a + b) = runCfg tm (runCfg tm c a) b := by + induction b with + | zero => rfl + | succ b ih => rw [show a + (b + 1) = (a + b) + 1 from by omega, runCfg_succ, ih, + runCfg_succ] + +/-- Once halted, the run stands still. -/ +theorem runCfg_of_halted (tm : TM k) {c : Cfg k tm.Q} (h : c.state = tm.qhalt) (n : ℕ) : + runCfg tm c n = c := by + induction n with + | zero => rfl + | succ n ih => rw [runCfg_succ, ih, TM.step, if_pos h, Option.getD_none] + +/-- A run of exactly `t` steps is the `t`-th iterate. -/ +theorem runCfg_of_reachesIn (tm : TM k) {c c' : Cfg k tm.Q} {t : ℕ} + (h : tm.reachesIn t c c') : runCfg tm c t = c' := by + induction h with + | zero => rfl + | @step c c'' t c' hstep _ ih => + rw [show t + 1 = 1 + t from by omega, runCfg_add, runCfg_succ, runCfg_zero, hstep, + Option.getD_some, ih] + +/-! ## The standing invariants of a run -/ + +/-- One step preserves the left-end marker's position on every tape. -/ +theorem step_startInvariant (tm : TM k) {c c' : Cfg k tm.Q} (h : tm.step c = some c') + (hin : c.input.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hout : c.output.StartInvariant) : + c'.input.StartInvariant ∧ (∀ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + rw [TM.step, if_neg (TM.state_ne_qhalt_of_step h)] at h + injection h with h + subst h + exact ⟨hin.move _, fun i => (hwork i).writeAndMove _ _, hout.writeAndMove _ _⟩ + +/-- One step moves every head by at most one cell. -/ +theorem step_head_le (tm : TM k) {c c' : Cfg k tm.Q} (h : tm.step c = some c') : + c'.input.head ≤ c.input.head + 1 ∧ (∀ i, (c'.work i).head ≤ (c.work i).head + 1) ∧ + c'.output.head ≤ c.output.head + 1 := by + rw [TM.step, if_neg (TM.state_ne_qhalt_of_step h)] at h + injection h with h + subst h + exact ⟨Tape.head_move_le _ _, fun i => Tape.head_writeAndMove_le _ _ _, + Tape.head_writeAndMove_le _ _ _⟩ + +/-- **Every tape of a run keeps its left-end marker.** -/ +theorem runCfg_startInvariant (tm : TM k) (x : List Bool) (n : ℕ) : + (runCfg tm (tm.initCfg x) n).input.StartInvariant ∧ + (∀ i, ((runCfg tm (tm.initCfg x) n).work i).StartInvariant) ∧ + (runCfg tm (tm.initCfg x) n).output.StartInvariant := by + induction n with + | zero => + exact ⟨Tape.StartInvariant.init_ofBool x, fun _ => Tape.StartInvariant.init_nil, + Tape.StartInvariant.init_nil⟩ + | succ n ih => + rw [runCfg_succ] + cases hs : tm.step (runCfg tm (tm.initCfg x) n) with + | none => rw [Option.getD_none]; exact ih + | some c' => + rw [Option.getD_some] + exact step_startInvariant tm hs ih.1 ih.2.1 ih.2.2 + +/-- **After `n` steps every head is within `n` cells of the start.** -/ +theorem runCfg_head_le (tm : TM k) (x : List Bool) (n : ℕ) : + (runCfg tm (tm.initCfg x) n).input.head ≤ n ∧ + (∀ i, ((runCfg tm (tm.initCfg x) n).work i).head ≤ n) ∧ + (runCfg tm (tm.initCfg x) n).output.head ≤ n := by + induction n with + | zero => exact ⟨by simp, fun _ => by simp, by simp⟩ + | succ n ih => + rw [runCfg_succ] + cases hs : tm.step (runCfg tm (tm.initCfg x) n) with + | none => rw [Option.getD_none]; exact ⟨by omega, fun i => by have := ih.2.1 i; omega, + by omega⟩ + | some c' => + rw [Option.getD_some] + obtain ⟨h1, h2, h3⟩ := step_head_le tm hs + exact ⟨by omega, fun i => by have := h2 i; have := ih.2.1 i; omega, by omega⟩ + +end TM + +namespace Cobham + +variable {k : ℕ} + +/-- The invariants of a run, in the form the encoding lemmas want. -/ +theorem cfgTapes_runCfg_inv (tm : TM k) (x : List Bool) (n W : ℕ) (hn : n ≤ W) : + (∀ t ∈ cfgTapes (TM.runCfg tm (tm.initCfg x) n), t.StartInvariant) ∧ + (∀ t ∈ cfgTapes (TM.runCfg tm (tm.initCfg x) n), t.head ≤ W) := by + obtain ⟨i1, w1, o1⟩ := TM.runCfg_startInvariant tm x n + obtain ⟨i2, w2, o2⟩ := TM.runCfg_head_le tm x n + constructor <;> intro t ht <;> + · rw [cfgTapes, List.mem_cons, List.mem_cons, List.mem_ofFn] at ht + rcases ht with rfl | rfl | ⟨i, rfl⟩ + · first | exact i1 | omega + · first | exact o1 | omega + · first | exact w1 i | (have := w2 i; omega) + +/-- **The encoded iteration tracks the run.** -/ +theorem iterate_stepFn (tm : TM k) (W : ℕ) (x : List Bool) + (hq : Fintype.card tm.Q ≤ blockWidth W) : + ∀ n : ℕ, n ≤ W → + (stepFn tm (blockRuler W))^[n] (cfgCode W (tm.initCfg x)) + = cfgCode W (TM.runCfg tm (tm.initCfg x) n) := by + intro n + induction n with + | zero => intro _; rfl + | succ n ih => + intro hn + obtain ⟨hinv, hW⟩ := cfgTapes_runCfg_inv tm x n W (by omega) + rw [Function.iterate_succ_apply', ih (by omega), TM.runCfg_succ] + cases hs : tm.step (TM.runCfg tm (tm.initCfg x) n) with + | none => + rw [Option.getD_none] + exact stepFn_halted tm (TM.step_eq_none_iff_halted.mp hs) hq hW + | some c' => + rw [Option.getD_some] + have hgood := stepActs_forall₂ tm _ hinv hW + refine stepFn_eq tm hs hq hW ?_ ?_ hgood + · exact hinv _ (by simp [cfgTapes]) + · intro i + exact hinv _ (by + rw [cfgTapes] + exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ + (List.mem_ofFn.mpr ⟨i, rfl⟩))) + +/-! ## The rewind iteration -/ + +private theorem head_move_left (s : Tape) : (s.move Dir3.left).head = s.head - 1 := rfl + +/-- Iterated left moves. -/ +private theorem head_moveLeft (t : Tape) (n : ℕ) : + ((fun s : Tape => s.move Dir3.left)^[n] t).head = t.head - n ∧ + ((fun s : Tape => s.move Dir3.left)^[n] t).cells = t.cells := by + induction n with + | zero => exact ⟨rfl, rfl⟩ + | succ n ih => + rw [Function.iterate_succ_apply'] + refine ⟨?_, ?_⟩ + · rw [head_move_left, ih.1] + omega + · rw [Tape.move_cells, ih.2] + +private theorem startInvariant_moveLeft (t : Tape) (h : t.StartInvariant) (n : ℕ) : + ((fun s : Tape => s.move Dir3.left)^[n] t).StartInvariant := by + induction n with + | zero => exact h + | succ n ih => rw [Function.iterate_succ_apply']; exact ih.move _ + +/-- **The rewind iteration walks the head left.** -/ +theorem iterate_rewindFn {W : ℕ} (t : Tape) (hinv : t.StartInvariant) (hW : t.head ≤ W) : + ∀ n : ℕ, (rewindFn (blockRuler W))^[n] (pairCode W t) + = pairCode W ((fun s : Tape => s.move Dir3.left)^[n] t) := by + intro n + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', ih, Function.iterate_succ_apply'] + exact rewindFn_eq _ (startInvariant_moveLeft t hinv n) + (by have := (head_moveLeft t n).1; omega) + +/-- **After enough rewinding the head is at cell `0`.** -/ +theorem rewound (t : Tape) {n : ℕ} (h : t.head ≤ n) : + (fun s : Tape => s.move Dir3.left)^[n] t + = { head := 0, cells := t.cells } := by + obtain ⟨h1, h2⟩ := head_moveLeft t n + refine Tape.ext ?_ h2 + show ((fun s : Tape => s.move Dir3.left)^[n] t).head = 0 + rw [h1] + omega + +/-! ## Reading the output off the rewound tape + +With the head at cell `0` the tape's right half-block is the whole window, in +order and two bits per cell. The first bit of each cell says whether it holds +data — `symCode` is arranged so that only `0` and `1` have it set — and the +second is the bit itself. So the output is the second bits, truncated where the +first bits stop: `Complexity.cellBits` twice and one `Complexity.runTrue`. -/ + +@[simp] theorem cellsCode_one (t : Tape) (i : ℕ) : + cellsCode t i 1 = symCode (t.cells i) := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil] + +/-- Reading one bit of an aligned window is reading one bit of a cell's code. -/ +theorem bitOf_cellsCode (t : Tape) {w j : ℕ} (hj : j < w) {o : ℕ} (ho : o < 2) : + bitOf (cellsCode t 0 w) (2 * j + o) = bitOf (symCode (t.cells j)) o := by + have hsplit : cellsCode t 0 w + = cellsCode t 0 j ++ (cellsCode t j 1 ++ cellsCode t (j + 1) (w - j - 1)) := by + conv_lhs => rw [show w = j + (1 + (w - j - 1)) from by omega] + rw [cellsCode_add t 0 j, cellsCode_add t (0 + j) 1 (w - j - 1)] + simp only [Nat.zero_add] + have hlen1 : (cellsCode t 0 j).length = 2 * j := cellsCode_length _ _ _ + have hlen2 : (cellsCode t j 1).length = 2 := by rw [cellsCode_one, symCode_length] + rw [hsplit, bitOf_append_right (by omega), hlen1, + show 2 * j + o - 2 * j = o from by omega, bitOf_append_left (by omega), + cellsCode_one] + +/-- A padded block of exactly the ruler's width is the block itself. -/ +private theorem padTo_of_length_eq {r x : List Bool} (h : x.length = r.length) : + padTo r x = x := by + rw [padTo_eq_append r x h.le, h, Nat.sub_self, List.replicate_zero, List.append_nil] + +/-- The aligned window of a rewound tape is its right half-block. -/ +theorem drop_pairCode_rewound (W : ℕ) (t : Tape) : + (pairCode W { head := 0, cells := t.cells }).drop (blockRuler W).length + = cellsCode t 0 (W + 1) := by + rw [drop_pairCode, rightCode] + refine padTo_of_length_eq ?_ + rw [cellsCode_length, blockRuler_length, blockWidth] + rfl + +/-- **Reading the output off an aligned window.** -/ +theorem output_of_cellsCode {W : ℕ} (t : Tape) (y : List Bool) + (hy : t.HasOutput y) (hyW : y.length + 1 ≤ W) : + (cellBits 3 (cellsCode t 0 (W + 1)) W).take + (runTrue (cellBits 2 (cellsCode t 0 (W + 1)) W) W).length = y := by + set u := cellsCode t 0 (W + 1) with hu + -- Each cell's two bits, read out of the window. + have hcell : ∀ (i : ℕ), i < W → ∀ o < 2, + bitOf u (2 * i + (2 + o)) = bitOf (symCode (t.cells (i + 1))) o := by + intro i hi o ho + rw [hu, show 2 * i + (2 + o) = 2 * (i + 1) + o from by omega, + bitOf_cellsCode t (by omega) ho] + have hflag : ∀ i < W, bitOf (cellBits 2 u W) i + = bitOf (symCode (t.cells (i + 1))) 0 := by + intro i hi + rw [bitOf_eq_getElem (by rw [cellBits_length]; exact hi), + ← Option.some_inj, ← List.getElem?_eq_getElem, cellBits_getElem? 2 u W i hi, + Option.some_inj] + exact hcell i hi 0 (by omega) + have hbit : ∀ i < W, bitOf (cellBits 3 u W) i + = bitOf (symCode (t.cells (i + 1))) 1 := by + intro i hi + rw [bitOf_eq_getElem (by rw [cellBits_length]; exact hi), + ← Option.some_inj, ← List.getElem?_eq_getElem, cellBits_getElem? 3 u W i hi, + Option.some_inj] + have := hcell i hi 1 (by omega) + rwa [show 2 * i + (2 + 1) = 2 * i + 3 from by omega] at this + -- The data flags are `true` exactly on the output. + have hlen : (runTrue (cellBits 2 u W) W).length = y.length := by + have h1 : ∀ i < y.length, bitOf (cellBits 2 u W) i = true := by + intro i hi + rw [hflag i (by omega), hy.1 i hi] + cases y[i] <;> rfl + have h2 : bitOf (cellBits 2 u W) y.length = false := by + rw [hflag y.length (by omega), hy.2] + rfl + rw [runTrue_length h1 h2 W] + omega + rw [hlen] + refine List.ext_getElem (by rw [List.length_take, cellBits_length]; omega) ?_ + intro i h1 h2 + rw [List.getElem_take] + have hiy : i < y.length := by + rwa [List.length_take, cellBits_length, min_eq_left (by omega : y.length ≤ W)] at h1 + rw [← bitOf_eq_getElem (by rw [cellBits_length]; omega), hbit i (by omega), + hy.1 i hiy] + cases hb : y[i] <;> rfl + +/-! ## The whole simulation + +Everything above, wired together: a clock long enough to run the machine to a +halt and to rewind the output head, a first iteration that runs the machine, a +second that rewinds, and the extraction. -/ + +private theorem length_flatten_replicate (u : List Bool) : + ∀ n : ℕ, (List.replicate n u).flatten.length = n * u.length := by + intro n + induction n with + | zero => simp + | succ n ih => + rw [List.replicate_succ, List.flatten_cons, List.length_append, ih] + ring + +theorem initFn_length (tm : TM k) (R x : List Bool) : + (initFn tm R x).length = (2 * (k + 2) + 1) * R.length := by + rw [initFn] + simp only [List.length_append, padTo_length, length_flatten_replicate] + ring + +/-- **A polynomial bound with room for the clock's other duties**: the clock has +to outlast the machine, cover the input, and be wide enough for the state code. -/ +private theorem exists_clock_bound (tm : TM k) {T : ℕ → ℕ} {S D : ℕ} + (hSD : ∀ n, T n ≤ S * (n + 1) ^ D) : + ∃ C E : ℕ, ∀ n : ℕ, T n + n + Fintype.card tm.Q + 2 ≤ C * (n + 1) ^ E := by + refine ⟨S + Fintype.card tm.Q + 2, max D 1, fun n => ?_⟩ + have h1 : T n ≤ S * (n + 1) ^ max D 1 := + le_trans (hSD n) + (Nat.mul_le_mul_left _ (Nat.pow_le_pow_right (by omega) (le_max_left _ _))) + have h2 : n + 1 ≤ (n + 1) ^ max D 1 := Nat.le_self_pow (by omega) _ + have h3 : n + Fintype.card tm.Q + 2 ≤ (Fintype.card tm.Q + 2) * (n + 1) := by + have : 1 * n ≤ (Fintype.card tm.Q + 2) * n := Nat.mul_le_mul_right _ (by omega) + rw [Nat.mul_add, Nat.mul_one] + omega + calc T n + n + Fintype.card tm.Q + 2 + ≤ S * (n + 1) ^ max D 1 + (Fintype.card tm.Q + 2) * (n + 1) := by omega + _ ≤ S * (n + 1) ^ max D 1 + (Fintype.card tm.Q + 2) * (n + 1) ^ max D 1 := + Nat.add_le_add_left (Nat.mul_le_mul_left _ h2) _ + _ = (S + Fintype.card tm.Q + 2) * (n + 1) ^ max D 1 := by ring + +/-! ### The three stages, as functions of the clock + +The clock string `u` fixes the encoded window: the ruler is `2|u|` bits wide, so +the window is `W = |u| - 1` cells and `u.tail` is a ruler of exactly `W` bits. -/ + +/-- The block ruler belonging to a clock value. -/ +def clockRuler (u : List Bool) : List Bool := List.replicate (u ++ u).length false + +theorem clockRuler_eq {u : List Bool} (h : 1 ≤ u.length) : + clockRuler u = blockRuler (u.length - 1) := by + rw [clockRuler, blockRuler, blockWidth] + congr 1 + rw [List.length_append] + omega + +theorem clockRulerFn {n : ℕ} {gu : (Fin n → List Bool) → List Bool} (hu : Cobham gu) : + Cobham fun w : Fin n → List Bool => clockRuler (gu w) := + (zeroBlockFn (appendFn hu hu)).of_eq fun _ => rfl + +/-- Stage one: the encoding after running the machine to a halt. -/ +noncomputable def runFn (tm : TM k) (u x : List Bool) : List Bool := + (stepFn tm (clockRuler u))^[u.tail.length] (initFn tm (clockRuler u) x) + +/-- Stage two: the output tape's two half-blocks, head rewound to cell `0`. -/ +noncomputable def outPairFn (tm : TM k) (u x : List Bool) : List Bool := + (rewindFn (clockRuler u))^[u.length] + (blockAt (clockRuler u) (runFn tm u x) 3 ++ blockAt (clockRuler u) (runFn tm u x) 4) + +/-- Stage three: the string on the rewound output tape. -/ +noncomputable def simFn (tm : TM k) (u x : List Bool) : List Bool := + (cellBits 3 ((outPairFn tm u x).drop (clockRuler u).length) u.tail.length).take + (runTrue (cellBits 2 ((outPairFn tm u x).drop (clockRuler u).length) u.tail.length) + u.tail.length).length + +/-- The simulated run never leaves its blocks. -/ +theorem iterate_stepFn_length_le (tm : TM k) (R x : List Bool) (n : ℕ) : + ((stepFn tm R)^[n] (initFn tm R x)).length ≤ (2 * (k + 2) + 1) * R.length := by + induction n with + | zero => exact (initFn_length tm R x).le + | succ n ih => rw [Function.iterate_succ_apply']; exact stepFn_length_le tm R _ ih + +/-- The rewind never leaves its two blocks. -/ +theorem iterate_rewindFn_length_le (R z : List Bool) (hz : z.length ≤ 2 * R.length) + (n : ℕ) : ((rewindFn R)^[n] z).length ≤ 2 * R.length := by + induction n with + | zero => exact hz + | succ n ih => rw [Function.iterate_succ_apply']; exact rewindFn_length_le R _ ih + +private theorem tail_cons₂ (a b : List Bool) : Fin.tail ![a, b] = fun _ => b := by + funext i + rw [Subsingleton.elim i 0] + rfl + +private theorem cons_val_one (s : List Bool) (v : Fin 1 → List Bool) : + (Fin.cons s v : Fin 2 → List Bool) 1 = v 0 := rfl + +private theorem cons_val_zero' (s : List Bool) (v : Fin 1 → List Bool) : + (Fin.cons s v : Fin 2 → List Bool) 0 = s := rfl + +/-- **The whole simulation is in the algebra.** -/ +theorem simFn_mem (tm : TM k) {gu : (Fin 1 → List Bool) → List Bool} + (hu : Cobham gu) : Cobham fun v : Fin 1 → List Bool => simFn tm (gu v) (v 0) := by + have hu2 : Cobham fun w : Fin 2 → List Bool => gu (fun _ => w 1) := + (Cobham.comp hu fun _ : Fin 1 => Cobham.proj 1).of_eq fun _ => rfl + have hu1 : Cobham fun w : Fin 1 → List Bool => gu (fun _ => w 0) := + (Cobham.comp hu fun _ : Fin 1 => Cobham.proj 0).of_eq fun _ => rfl + have huu : ∀ w : Fin 1 → List Bool, gu (fun _ => w 0) = gu w := fun w => by + congr 1 + funext i + rw [Subsingleton.elim i 0] + -- Stage one. + have hrun : Cobham fun v : Fin 1 → List Bool => runFn tm (gu v) (v 0) := by + have hstage := + iterFn (e := fun w : Fin 1 → List Bool => + initFn tm (clockRuler (gu (fun _ => w 0))) (w 0)) + (f := fun w : Fin 2 → List Bool => + stepFn tm (clockRuler (gu (fun _ => w 1))) (w 0)) + (j := fun w : Fin 2 → List Bool => + (List.replicate (2 * (k + 2) + 1) + (clockRuler (gu (fun _ => w 1)))).flatten) + (initFn_mem tm (clockRulerFn hu1) (Cobham.proj 0)) + (stepFn_mem tm (clockRulerFn hu2) (Cobham.proj 0)) + (repeatFn (clockRulerFn hu2) _) ?_ + · refine (comp₂ hstage (tailFn hu1) (Cobham.proj 0)).of_eq fun v => ?_ + simp only [tail_cons₂, cons_val_one, cons_val_zero', Matrix.cons_val_zero] + rw [runFn, huu] + · intro c v + have := iterate_stepFn_length_le tm (clockRuler (gu fun _ => v 0)) (v 0) c.length + rw [length_flatten_replicate] + exact this + -- Stage two. + have hpair : Cobham fun v : Fin 1 → List Bool => outPairFn tm (gu v) (v 0) := by + have hstage := + iterFn (e := fun w : Fin 1 → List Bool => + blockAt (clockRuler (gu (fun _ => w 0))) (runFn tm (gu (fun _ => w 0)) (w 0)) 3 + ++ blockAt (clockRuler (gu (fun _ => w 0))) + (runFn tm (gu (fun _ => w 0)) (w 0)) 4) + (f := fun w : Fin 2 → List Bool => + rewindFn (clockRuler (gu (fun _ => w 1))) (w 0)) + (j := fun w : Fin 2 → List Bool => + clockRuler (gu (fun _ => w 1)) ++ clockRuler (gu (fun _ => w 1))) + (appendFn (blockFn (clockRulerFn hu1) (hrun.of_eq fun v => by rw [huu]) 3) + (blockFn (clockRulerFn hu1) (hrun.of_eq fun v => by rw [huu]) 4)) + (rewindFn_mem (clockRulerFn hu2) (Cobham.proj 0)) + (appendFn (clockRulerFn hu2) (clockRulerFn hu2)) ?_ + · refine (comp₂ hstage hu1 (Cobham.proj 0)).of_eq fun v => ?_ + simp only [tail_cons₂, cons_val_one, cons_val_zero', Matrix.cons_val_zero] + rw [outPairFn, huu] + · intro c v + simp only [cons_val_one, cons_val_zero'] + have hb : ((rewindFn (clockRuler (gu fun _ => v 0)))^[c.length] + (blockAt (clockRuler (gu fun _ => v 0)) (runFn tm (gu fun _ => v 0) (v 0)) 3 ++ + blockAt (clockRuler (gu fun _ => v 0)) + (runFn tm (gu fun _ => v 0) (v 0)) 4)).length + ≤ 2 * (clockRuler (gu fun _ => v 0)).length := by + refine iterate_rewindFn_length_le _ _ ?_ _ + rw [List.length_append, blockAt, blockAt, List.length_take, List.length_take] + omega + rw [List.length_append] + exact le_trans hb (by omega) + -- Stage three. + have hdrop : Cobham fun v : Fin 1 → List Bool => + (outPairFn tm (gu v) (v 0)).drop (clockRuler (gu v)).length := + dropFn (clockRulerFn hu) hpair + exact (takeFn (runTrueFn (tailFn hu) (cellBitsFn 2 (tailFn hu) hdrop)) + (cellBitsFn 3 (tailFn hu) hdrop)).of_eq fun v => by rw [simFn] + +/-- **The simulation computes the machine's function.** Provided the clock +outlasts the run, covers the input and is wide enough for the state code, the +three stages reproduce exactly the string the machine leaves on its output +tape. -/ +theorem simFn_eq (tm : TM k) {T : ℕ → ℕ} {f : List Bool → List Bool} + (hcomp : tm.ComputesInTime f T) (u x : List Bool) + (hlen : T x.length + x.length + Fintype.card tm.Q + 2 ≤ u.length) : + simFn tm u x = f x := by + have hu1 : 1 ≤ u.length := by omega + have hR : clockRuler u = blockRuler (u.length - 1) := clockRuler_eq hu1 + have htail : u.tail.length = u.length - 1 := List.length_tail + have hq : Fintype.card tm.Q ≤ blockWidth (u.length - 1) := by rw [blockWidth]; omega + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := hcomp x + have hylen : (f x).length ≤ t := TM.output_length_le_of_reachesIn hreach hout + have hrunW : TM.runCfg tm (tm.initCfg x) (u.length - 1) = c' := by + rw [show u.length - 1 = t + (u.length - 1 - t) from by omega, TM.runCfg_add, + TM.runCfg_of_reachesIn tm hreach, TM.runCfg_of_halted tm hhalt] + have hrun : runFn tm u x = cfgCode (u.length - 1) c' := by + rw [runFn, hR, htail, initFn_eq tm _ x (by omega), + iterate_stepFn tm _ x hq _ le_rfl, hrunW] + obtain ⟨hinv, hWh⟩ := cfgTapes_runCfg_inv tm x (u.length - 1) (u.length - 1) le_rfl + rw [hrunW] at hinv hWh + have hmem : c'.output ∈ cfgTapes c' := by simp [cfgTapes] + have hstart : c'.output.StartInvariant := hinv _ hmem + have hhead : c'.output.head ≤ u.length - 1 := hWh _ hmem + obtain ⟨hb3, hb4⟩ := + blockAt_cfgCode_tape (u.length - 1) c' 1 (by rw [cfgTapes_length]; omega) + have hidx : (cfgTapes c')[1]'(by rw [cfgTapes_length]; omega) = c'.output := rfl + rw [hidx, show 2 * 1 + 1 = 3 from rfl] at hb3 + rw [hidx, show 2 * 1 + 2 = 4 from rfl] at hb4 + have hpair : blockAt (clockRuler u) (runFn tm u x) 3 + ++ blockAt (clockRuler u) (runFn tm u x) 4 = pairCode (u.length - 1) c'.output := by + rw [hrun, hR, hb3, hb4, pairCode] + have hrew : outPairFn tm u x + = pairCode (u.length - 1) { head := 0, cells := c'.output.cells } := by + rw [outPairFn, hpair, hR, iterate_rewindFn c'.output hstart hhead u.length, + rewound c'.output (by omega)] + have hdropeq : (outPairFn tm u x).drop (clockRuler u).length + = cellsCode c'.output 0 (u.length - 1 + 1) := by + rw [hrew, hR, drop_pairCode_rewound] + rw [simFn, htail, hdropeq] + exact output_of_cellsCode c'.output (f x) hout (by omega) + +/-- **The completeness direction, for one machine.** -/ +theorem computes_mem_CobhamFP (tm : TM k) {T : ℕ → ℕ} {S D : ℕ} + (hSD : ∀ n, T n ≤ S * (n + 1) ^ D) {f : List Bool → List Bool} + (hcomp : tm.ComputesInTime f T) : CobhamFP f := by + obtain ⟨C, E, hCE⟩ := exists_clock_bound tm hSD + obtain ⟨clk, hclk, hclklen⟩ := exists_pow_clock C E + have hclk1 : Cobham fun w : Fin 1 → List Bool => clk (fun _ => w 0) := + (Cobham.comp hclk fun _ : Fin 1 => Cobham.proj 0).of_eq fun _ => rfl + refine ((simFn_mem tm hclk1).of_eq fun v => ?_ : Cobham fun v : Fin 1 → List Bool => + f (v 0)) + refine simFn_eq tm hcomp _ (v 0) (le_trans (hCE (v 0).length) ?_) + exact hclklen (fun _ => v 0) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean b/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean new file mode 100644 index 00000000..cfcd2938 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/SndBlock.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.BlockScan +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.NormalForm +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.Counter +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# The block-suffix decoder — proof internals + +`Cobham.sndBlockTM` scans the doubled payload two bits at a time until the +`[false, true]` separator, then copies the rest of the input to the output. +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Cobham.sndBlock_mem_FP` — the suffix decoder is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +open Complexity.TM + +/-- The suffix decoder: scan doubled payload bits until the `[false, true]` +separator, then copy the remaining input (the suffix `y` of `pair x y`) to the +output. On malformed input it halts with empty output. Computes `sndBlock`. -/ +def sndBlockTM : TM 0 where + Q := ScanPhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, Dir3.right, + fun i => idleDir (wHeads i), Dir3.right) + | .scanA => + match iHead with + | Γ.zero => + (.scanBfalse, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.scanBtrue, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBfalse => + match iHead with + | Γ.one => + (.emit, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.zero => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanBtrue => + match iHead with + | Γ.one => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .emit => + if iHead = Γ.blank then + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.emit, fun i => readBackWrite (wHeads i), readBackWrite iHead, + Dir3.right, fun i => idleDir (wHeads i), Dir3.right) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .skip => exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBfalse => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanBtrue => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .emit => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + · exact ⟨fun _ => rfl, fun _ => idleDir_right_of_start, fun _ => rfl⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- The copy phase of `sndBlockTM`: from `emit` with input cursor on suffix `y` +and output holding `acc`, the machine copies `y` after `acc` and halts. -/ +private theorem sndBlockTM_emit_loop : + ∀ (y acc : List Bool) (c : Cfg 0 sndBlockTM.Q), + c.state = ScanPhase.emit → + c.input.HasBinarySuffix y → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ y.length + 1 ∧ sndBlockTM.reachesIn t c c' ∧ sndBlockTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y) := by + intro y + induction y with + | nil => + intro acc c hstate hsuf hpre + have hread : c.input.read = Γ.blank := hsuf.read_nil + have hout : c.output.read = Γ.blank := hpre.read_blank + have houtne : c.output.read ≠ Γ.start := by rw [hout]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, if_neg houtne, Tape.move]] + simpa using hpre + | cons bit y ih => + intro acc c hstate hsuf hpre + have hread : c.input.read = Γ.ofBool bit := hsuf.read_cons + have hne : c.input.read ≠ Γ.blank := by rw [hread]; cases bit <;> decide + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.emit + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.input.read) Dir3.right } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hne, c1] + have hpre1 : c1.output.HasBinaryPrefix (acc ++ [bit]) := by + have hco : (readBackWrite c.input.read).toΓ = Γ.ofBool bit := by + rw [hread]; cases bit <;> rfl + show (c.output.writeAndMove ((readBackWrite c.input.read).toΓ) Dir3.right).HasBinaryPrefix + (acc ++ [bit]) + rw [hco]; exact Tape.hasBinaryPrefix_write_bit bit hpre + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + ih (acc ++ [bit]) c1 rfl hsuf.move_right_cons hpre1 + refine ⟨c', t + 1, by simp; omega, .step hstep hreach, hhalt, ?_⟩ + rwa [List.append_assoc, List.cons_append, List.nil_append] at hout + +/-- The scan phase of `sndBlockTM`: from `scanA` with input cursor on `w`, the +machine parses doubled pairs to the separator and copies the suffix, halting with +output `sndBlock w`. `fuel` bounds the recursion by the input length. -/ +private theorem sndBlockTM_scan_loop : + ∀ (fuel : ℕ) (w : List Bool), w.length ≤ fuel → ∀ (c : Cfg 0 sndBlockTM.Q), + c.state = ScanPhase.scanA → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix [] → + ∃ c' t, t ≤ 2 * w.length + 2 ∧ sndBlockTM.reachesIn t c c' ∧ sndBlockTM.halted c' ∧ + c'.output.HasOutput (sndBlock w) := by + intro fuel + induction fuel with + | zero => + intro w hw c hstate hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (Nat.le_zero.mp hw) + subst hwnil + have hread : c.input.read = Γ.blank := hsuf.read_nil + have hout : c.output.read = Γ.blank := hpre.read_blank + have houtne : c.output.read ≠ Γ.start := by rw [hout]; decide + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, if_neg houtne, Tape.move]] + simpa [sndBlock] using hpre.hasOutput + | succ fuel ih => + intro w hw c hstate hsuf hpre + -- Halting helper for the malformed / end-of-input branches. + have hout : c.output.read = Γ.blank := hpre.read_blank + have houtne : c.output.read ≠ Γ.start := by rw [hout]; decide + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := ScanPhase.done + input := c.input.move (idleDir c.input.read) + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) }, 1, by simp, + .step (by simp [TM.step, hstate, sndBlockTM, hread]) .zero, rfl, ?_⟩ + rw [show c.output.writeAndMove (readBackWrite c.output.read) (idleDir c.output.read) + = c.output from by + rw [writeAndMove_readBack c.output houtne, idleDir, if_neg houtne, Tape.move]] + simpa [sndBlock] using hpre.hasOutput + | [false] => + -- scanA reads false → scanBfalse; next reads blank → done. + have hread : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have hout1 : c1.output.read = Γ.blank := hpre1.read_blank + have houtne1 : c1.output.read ≠ Γ.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, sndBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, if_neg houtne1, Tape.move]] + simpa [sndBlock] using hpre1.hasOutput + | [true] => + have hread : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstep : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hread, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix [] := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hread1 : c1.input.read = Γ.blank := hsuf1.read_nil + have hout1 : c1.output.read = Γ.blank := hpre1.read_blank + have houtne1 : c1.output.read ≠ Γ.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstep (.step (by simp [TM.step, sndBlockTM, hread1, c1]) .zero), rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, if_neg houtne1, Tape.move]] + simpa [sndBlock] using hpre1.hasOutput + | false :: true :: y => + -- separator: scanA false → scanBfalse → (reads true) → emit; copy y. + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: y) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.emit + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix y := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read ≠ Γ.start := by + rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + sndBlockTM_emit_loop y [] c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (false :: true :: y) = y := by simp [sndBlock, unpair?] + rw [this] + simpa using hcout.hasOutput + | false :: false :: z => + have hreadA : c.input.read = Γ.ofBool false := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBfalse + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (false :: false :: z) = sndBlock z := by + cases h : unpair? z <;> simp [sndBlock, unpair?, h] + rw [this]; exact hcout + | true :: true :: z => + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (true :: z) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool true := hsuf1.read_cons + let c2 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := c1.input.move Dir3.right + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) } + have hstepB : sndBlockTM.step c1 = some c2 := by + simp [TM.step, sndBlockTM, hreadB, Γ.ofBool, c1, c2] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + have hpre2 : c2.output.HasBinaryPrefix [] := by + have hout1 : c1.output.read ≠ Γ.start := by rw [hpre1.read_blank]; decide + rw [show c2.output = c1.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ hout1] + exact hpre1 + have hzfuel : z.length ≤ fuel := by + simp only [List.length_cons] at hw; omega + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + ih z hzfuel c2 rfl hsuf2 hpre2 + refine ⟨c', t + 1 + 1, by simp only [List.length_cons]; omega, + .step hstepA (.step hstepB hreach), hhalt, ?_⟩ + have : sndBlock (true :: true :: z) = sndBlock z := by + cases h : unpair? z <;> simp [sndBlock, unpair?, h] + rw [this]; exact hcout + | true :: false :: rest => + -- malformed: scanA true → scanBtrue → reads false → done, empty output. + have hreadA : c.input.read = Γ.ofBool true := hsuf.read_cons + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanBtrue + input := c.input.move Dir3.right + work := fun i => (c.work i).writeAndMove (readBackWrite (c.work i).read) + (idleDir (c.work i).read) + output := c.output.writeAndMove (readBackWrite c.output.read) + (idleDir c.output.read) } + have hstepA : sndBlockTM.step c = some c1 := by + simp [TM.step, hstate, sndBlockTM, hreadA, Γ.ofBool, c1] + have hsuf1 : c1.input.HasBinarySuffix (false :: rest) := hsuf.move_right_cons + have hpre1 : c1.output.HasBinaryPrefix [] := by + rw [show c1.output = c.output from + Tape.writeAndMove_readBack_idle_of_ne_start _ houtne] + exact hpre + have hreadB : c1.input.read = Γ.ofBool false := hsuf1.read_cons + have hout1 : c1.output.read = Γ.blank := hpre1.read_blank + have houtne1 : c1.output.read ≠ Γ.start := by rw [hout1]; decide + refine ⟨{ state := ScanPhase.done + input := c1.input.move (idleDir c1.input.read) + work := fun i => (c1.work i).writeAndMove (readBackWrite (c1.work i).read) + (idleDir (c1.work i).read) + output := c1.output.writeAndMove (readBackWrite c1.output.read) + (idleDir c1.output.read) }, 2, by simp, + .step hstepA (.step (by simp [TM.step, sndBlockTM, hreadB, Γ.ofBool, c1]) .zero), + rfl, ?_⟩ + rw [show c1.output.writeAndMove (readBackWrite c1.output.read) (idleDir c1.output.read) + = c1.output from by + rw [writeAndMove_readBack c1.output houtne1, idleDir, if_neg houtne1, Tape.move]] + have : sndBlock (true :: false :: rest) = [] := by simp [sndBlock, unpair?] + rw [this]; simpa using hpre1.hasOutput + +/-- `sndBlock` is polynomial-time, via the `sndBlockTM` scanner. -/ +theorem sndBlock_mem_FP : sndBlock ∈ FP := by + refine ⟨1, 0, sndBlockTM, (fun m => 2 * m + 3), ?_, ?_⟩ + · intro z + -- Step 1: skip past ▷, positioning both cursors. + let c1 : Cfg 0 sndBlockTM.Q := + { state := ScanPhase.scanA + input := (Tape.init (z.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } + have hstep1 : sndBlockTM.step (sndBlockTM.initCfg z) = some c1 := by + simp [TM.step, sndBlockTM, c1, Tape.read, Tape.init, readBackWrite, idleDir, + Tape.writeAndMove, Tape.write, Tape.move] + have hsuf : c1.input.HasBinarySuffix z := Tape.init_move_right_hasBinarySuffix z + have hpre : c1.output.HasBinaryPrefix [] := Tape.init_nil_move_right_hasBinaryPrefix_nil + obtain ⟨c', t, ht, hreach, hhalt, hcout⟩ := + sndBlockTM_scan_loop z.length z le_rfl c1 rfl hsuf hpre + exact ⟨c', t + 1, by show t + 1 ≤ 2 * z.length + 3; omega, + .step hstep1 hreach, hhalt, hcout⟩ + · have hn : (fun m : ℕ => 2 * m) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun m : ℕ => m)).const_mul_left 2 + exact BigO.add hn (BigO.const_le_pow 3 1) + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean b/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean new file mode 100644 index 00000000..c090af32 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/StepAlgebra.lean @@ -0,0 +1,757 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Cobham.Internal.Blocks +public import Complexitylib.Classes.P.Cobham.Internal.Algebra +public import Complexitylib.Classes.P.Cobham.Internal.Encoding +public import Mathlib.Data.Fintype.Prod + +/-! +# The encoded machine step, inside the algebra — proof internals + +`Complexitylib.Classes.P.Cobham.Internal.Encoding` shows that one machine step +acts on an encoded configuration blockwise, via `tapeStepBlocks`. This module +shows the other half: that `tapeStepBlocks` is *in Cobham's algebra* once the +written symbol and the direction are fixed constants — which they are inside one +branch of `Cobham.tableFn`, since the branch is selected by the (state, +read-symbols) key. + +Each half-block of the successor is a short composition of toolkit members: +`Cobham.takeFn` and `Cobham.dropFn` at width two, `Cobham.appendFn`, +`Cobham.const`, and one `Cobham.padFn` to restore the block width. + +## Main results + +- `Complexity.Cobham.tapeStepBlocksFst`, `Complexity.Cobham.tapeStepBlocksSnd` — + both half-blocks of a stepped tape are in the algebra +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-- The two-bit ruler: dropping or taking `2` is `dropFn`/`takeFn` against this +constant. -/ +private def twoRuler : List Bool := [false, false] + +/-- **The left half-block after a step is in the algebra.** For a fixed direction +and written symbol it is one of: the old left block unchanged (stay), the symbol +prepended (right), or two bits dropped (left). -/ +theorem tapeStepBlocksFst {n : ℕ} (s : Γ) (d : Dir3) + {gR gL gRt : (Fin n → List Bool) → List Bool} + (hR : Cobham gR) (hL : Cobham gL) (_hRt : Cobham gRt) : + Cobham fun v : Fin n → List Bool => + (tapeStepBlocks (gR v) s d (gL v) (gRt v)).1 := by + cases d + · exact (padFn hR (dropFn (Cobham.const twoRuler) hL)).of_eq fun _ => rfl + · exact (padFn hR (appendFn (Cobham.const (symCode s)) hL)).of_eq fun _ => rfl + · exact hL.of_eq fun _ => rfl + +/-- **The right half-block after a step is in the algebra.** For a fixed +direction and written symbol it is the old right block with its leading symbol +replaced (stay), consumed (right), or pushed back together with the nearest left +symbol (left). -/ +theorem tapeStepBlocksSnd {n : ℕ} (s : Γ) (d : Dir3) + {gR gL gRt : (Fin n → List Bool) → List Bool} + (hR : Cobham gR) (hL : Cobham gL) (hRt : Cobham gRt) : + Cobham fun v : Fin n → List Bool => + (tapeStepBlocks (gR v) s d (gL v) (gRt v)).2 := by + cases d + · exact (padFn hR (appendFn + (appendFn (takeFn (Cobham.const twoRuler) hL) (Cobham.const (symCode s))) + (dropFn (Cobham.const twoRuler) hRt))).of_eq fun _ => rfl + · exact (padFn hR (dropFn (Cobham.const twoRuler) hRt)).of_eq fun _ => rfl + · exact (padFn hR (appendFn (Cobham.const (symCode s)) + (dropFn (Cobham.const twoRuler) hRt))).of_eq fun _ => rfl + +/-- **Tape `j`'s two half-blocks, read out of an encoded configuration.** Block +`0` is the state, so tape `j` occupies blocks `2j+1` and `2j+2` — exactly the +indices `tapesStepFn` addresses with `Cobham.blockFn`. -/ +theorem blockAt_cfgCode_tape {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (j : ℕ) (hj : j < (cfgTapes c).length) : + blockAt (blockRuler W) (cfgCode W c) (2 * j + 1) + = padTo (blockRuler W) (leftCode (cfgTapes c)[j]) ∧ + blockAt (blockRuler W) (cfgCode W c) (2 * j + 2) + = padTo (blockRuler W) (rightCode (cfgTapes c)[j] W) := by + have hj' : j < k + 2 := by rwa [cfgTapes_length] at hj + have hblocks : (tapesBlocks W (cfgTapes c)).length = 2 * (k + 2) := by + rw [tapesBlocks_length, cfgTapes_length] + obtain ⟨h1, h2⟩ := getElem?_tapesBlocks W (cfgTapes c) j + rw [List.getElem?_eq_getElem (by omega), List.getElem?_eq_getElem hj] at h1 h2 + simp only [Option.map_some] at h1 h2 + replace h1 := Option.some_inj.mp h1 + replace h2 := Option.some_inj.mp h2 + -- Work through `getElem?` so no dependent index proofs appear under a rewrite. + have key1 : (cfgBlocks W c)[2 * j + 1]? = (tapesBlocks W (cfgTapes c))[2 * j]? := by + rw [cfgBlocks_eq]; exact List.getElem?_cons_succ + have key2 : (cfgBlocks W c)[2 * j + 2]? = (tapesBlocks W (cfgTapes c))[2 * j + 1]? := by + rw [cfgBlocks_eq]; exact List.getElem?_cons_succ + rw [List.getElem?_eq_getElem (by rw [cfgBlocks_length]; omega), + List.getElem?_eq_getElem (by omega)] at key1 + rw [List.getElem?_eq_getElem (by rw [cfgBlocks_length]; omega), + List.getElem?_eq_getElem (by omega)] at key2 + exact ⟨by rw [blockAt_cfgCode W c (2 * j + 1) (by rw [cfgBlocks_length]; omega), + Option.some_inj.mp key1, h1], + by rw [blockAt_cfgCode W c (2 * j + 2) (by rw [cfgBlocks_length]; omega), + Option.some_inj.mp key2, h2]⟩ + +/-! ## The transition key + +The key is the state together with the symbol under every head. Reading it out of +an encoding is one `takeFn` per field: the state block truncated to `|Q|` bits, +then the first two bits of each tape's right half-block. -/ + +/-- The read symbols of the tapes from index `j` on, `m` of them. -/ +def readsFn (R : List Bool) (m j : ℕ) (z : List Bool) : List Bool := + match m with + | 0 => [] + | m + 1 => (blockAt R z (2 * j + 2)).take 2 ++ readsFn R m (j + 1) z + +/-- The transition key, read out of an encoded configuration. -/ +def keyFn (R : List Bool) (q m : ℕ) (z : List Bool) : List Bool := + (blockAt R z 0).take q ++ readsFn R m 0 z + +/-- **Reading the head symbols is in the algebra.** -/ +theorem readsFn_mem {n : ℕ} (m j : ℕ) + {gR gz : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => readsFn (gR v) m j (gz v) := by + induction m generalizing j with + | zero => exact Cobham.empty.of_eq fun _ => rfl + | succ m ih => + exact (appendFn (takeFn (Cobham.const twoRuler) (blockFn hR hz (2 * j + 2))) + (ih (j + 1))).of_eq fun _ => rfl + +/-- **Reading the transition key is in the algebra.** -/ +theorem keyFn_mem {n : ℕ} (q m : ℕ) + {gR gz : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => keyFn (gR v) q m (gz v) := + (appendFn (takeFn (Cobham.const (List.replicate q false)) (blockFn hR hz 0)) + (readsFn_mem m 0 hR hz)).of_eq fun _ => by rw [keyFn, List.length_replicate] + +/-- **The extracted key is the transition key.** -/ +theorem readsFn_eq {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) : + ∀ (m j : ℕ), j + m = (cfgTapes c).length → + readsFn (blockRuler W) m j (cfgCode W c) + = ((cfgTapes c).drop j).flatMap fun t => symCode t.read := by + intro m + induction m with + | zero => + intro j hj + have : (cfgTapes c).drop j = [] := by + rw [List.drop_eq_nil_iff]; omega + rw [readsFn, this, List.flatMap_nil] + | succ m ih => + intro j hj + have hjlt : j < (cfgTapes c).length := by omega + obtain ⟨_, hRt⟩ := blockAt_cfgCode_tape W c j hjlt + have hmem : (cfgTapes c)[j] ∈ cfgTapes c := List.getElem_mem hjlt + rw [readsFn, hRt, List.drop_eq_getElem_cons hjlt, List.flatMap_cons, + take_padTo _ _ 2 (by rw [rightCode_length]; have := hW _ hmem; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth] + have := hW _ hmem; omega), + take_rightCode _ (hW _ hmem), ih (j + 1) (by omega)] + +/-- The whole key, read out of an encoded configuration. -/ +theorem keyFn_eq {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) (hq : Fintype.card Q ≤ blockWidth W) + (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) : + keyFn (blockRuler W) (Fintype.card Q) (k + 2) (cfgCode W c) = keyCode c := by + rw [keyFn, state_of_cfgCode W c hq, + readsFn_eq W c hW (k + 2) 0 (by rw [cfgTapes_length]; omega), List.drop_zero, + keyCode] + +/-! ## Lifting across all the tapes + +A machine has a fixed number of tapes, so stepping all of them is a *finite* +composition — the recursion below is at the meta level, over the list of +per-tape actions, not inside the algebra. Tape `j` occupies blocks `2j+1` and +`2j+2` (block `0` is the state), which `Cobham.blockFn` addresses. -/ + +/-- The successor's tape blocks for one transition-table branch, as a function of +the predecessor's encoding: tape `j`'s two half-blocks, stepped, concatenated. -/ +def tapesStepFn (R : List Bool) (acts : List (Γ × Dir3)) (j : ℕ) (z : List Bool) : + List Bool := + match acts with + | [] => [] + | a :: rest => + (tapeStepBlocks R a.1 a.2 (blockAt R z (2 * j + 1)) + (blockAt R z (2 * j + 2))).1 ++ + ((tapeStepBlocks R a.1 a.2 (blockAt R z (2 * j + 1)) + (blockAt R z (2 * j + 2))).2 ++ tapesStepFn R rest (j + 1) z) + +/-- **Stepping every tape is in the algebra.** -/ +theorem tapesStepFn_mem {n : ℕ} (acts : List (Γ × Dir3)) (j : ℕ) + {gR gz : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => tapesStepFn (gR v) acts j (gz v) := by + induction acts generalizing j with + | nil => exact Cobham.empty.of_eq fun _ => rfl + | cons a rest ih => + exact (appendFn + (tapeStepBlocksFst a.1 a.2 hR (blockFn hR hz (2 * j + 1)) + (blockFn hR hz (2 * j + 2))) + (appendFn + (tapeStepBlocksSnd a.1 a.2 hR (blockFn hR hz (2 * j + 1)) + (blockFn hR hz (2 * j + 2))) + (ih (j + 1)))).of_eq fun _ => rfl + +/-- **The algebra-side tape step computes the machine-side one.** Reading the +half-blocks out of the encoding (`blockAt`) gives exactly the tapes' own +half-blocks, so `tapesStepFn` reproduces the blockwise map of +`tapesBlocks_tapesStep`. -/ +theorem tapesStepFn_eq {k : ℕ} {Q : Type} [Fintype Q] [DecidableEq Q] + (W : ℕ) (c : Cfg k Q) : + ∀ (acts : List (Γ × Dir3)) (j : ℕ), j + acts.length ≤ (cfgTapes c).length → + tapesStepFn (blockRuler W) acts j (cfgCode W c) + = ((List.zipWith (fun a t => + [(tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).1, + (tapeStepBlocks (blockRuler W) a.1 a.2 (padTo (blockRuler W) (leftCode t)) + (padTo (blockRuler W) (rightCode t W))).2]) + acts ((cfgTapes c).drop j)).flatten).flatten := by + intro acts + induction acts with + | nil => intro j _; rfl + | cons a rest ih => + intro j hj + have hjlt : j < (cfgTapes c).length := by + simp only [List.length_cons] at hj; omega + obtain ⟨hL, hRt⟩ := blockAt_cfgCode_tape W c j hjlt + rw [List.drop_eq_getElem_cons hjlt, List.zipWith_cons_cons, List.flatten_cons, + List.flatten_append, tapesStepFn, hL, hRt, + ih (j + 1) (by simp only [List.length_cons] at hj; omega)] + simp [List.append_assoc] + +/-- One whole branch of the transition table: the new state block (a constant) +followed by every tape stepped. -/ +def branchFn (R q' : List Bool) (acts : List (Γ × Dir3)) (z : List Bool) : + List Bool := + padTo R q' ++ tapesStepFn R acts 0 z + +/-- **A transition-table branch is in the algebra.** With the branch fixed, the +new state code and every tape's write and direction are constants, so the whole +successor configuration is a finite composition of toolkit members. -/ +theorem branchFn_mem {n : ℕ} (q' : List Bool) (acts : List (Γ × Dir3)) + {gR gz : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => branchFn (gR v) q' acts (gz v) := + (appendFn (padFn hR (Cobham.const q')) (tapesStepFn_mem acts 0 hR hz)).of_eq + fun _ => rfl + +/-- **The join.** For a fixed transition-table branch, the algebra-side successor +`branchFn` — built purely from `takeFn`/`dropFn`/`appendFn`/`padFn`/`const` — *is* +the encoding of the machine's successor configuration. + +This is the point where the two halves of the development meet: the machine side +(`cfgBlocks_step`, from the six write-and-move lemmas) and the algebra side +(`tapesStepFn`, in the class by `branchFn_mem`). -/ +theorem branchFn_eq {k : ℕ} (tm : TM k) {c c' : Cfg k tm.Q} {W : ℕ} + (h : tm.step c = some c') (hout : c.output.StartInvariant) + (hwork : ∀ i, (c.work i).StartInvariant) + (hgood : List.Forall₂ (fun (a : Γ × Dir3) (t : Tape) => + (t.head = 0 → a.1 = t.cells t.head) ∧ + (a.2 ≠ Dir3.right → t.head ≠ 0) ∧ t.head ≤ W) (stepActs tm c) (cfgTapes c)) : + branchFn (blockRuler W) (stateCode c'.state) (stepActs tm c) (cfgCode W c) + = cfgCode W c' := by + rw [branchFn, tapesStepFn_eq W c (stepActs tm c) 0 (by simpa using hgood.length_eq.le)] + conv_rhs => rw [cfgCode, cfgBlocks_step tm h hout hwork hgood, List.flatten_cons] + simp + +/-! ## The whole transition table + +A machine has finitely many (state, read-symbols) keys, so the transition +function is a finite table: one `branchFn` per key, selected by matching the key +read out of the encoding against the key's constant pattern. -/ + +/-- The transition table's index set: every (state, read-symbols) pair. -/ +noncomputable def stepEntries {k : ℕ} (tm : TM k) : + List (tm.Q × (Fin (k + 2) → Γ)) := + (Finset.univ : Finset (tm.Q × (Fin (k + 2) → Γ))).toList + +/-- Every key is in the table. -/ +theorem mem_stepEntries {k : ℕ} (tm : TM k) (p : tm.Q × (Fin (k + 2) → Γ)) : + p ∈ stepEntries tm := Finset.mem_toList.mpr (Finset.mem_univ p) + +/-- The branch a transition key selects. A halting key stands still: the machine +has stopped, but the *simulation* runs for a fixed polynomial number of steps, so +the encoding has to be a fixed point from then on. -/ +noncomputable def stepBranch {k : ℕ} (tm : TM k) (R : List Bool) + (p : tm.Q × (Fin (k + 2) → Γ)) (z : List Bool) : List Bool := + if p.1 = tm.qhalt then z + else branchFn R (stateCode (stepStateOf tm p.1 p.2)) (stepActsOf tm p.1 p.2) z + +theorem stepBranch_halt {k : ℕ} (tm : TM k) (R : List Bool) + {p : tm.Q × (Fin (k + 2) → Γ)} (h : p.1 = tm.qhalt) (z : List Bool) : + stepBranch tm R p z = z := if_pos h + +theorem stepBranch_step {k : ℕ} (tm : TM k) (R : List Bool) + {p : tm.Q × (Fin (k + 2) → Γ)} (h : p.1 ≠ tm.qhalt) (z : List Bool) : + stepBranch tm R p z + = branchFn R (stateCode (stepStateOf tm p.1 p.2)) (stepActsOf tm p.1 p.2) z := + if_neg h + +/-- **One machine step, on encodings.** The table dispatches on the key read out +of the encoding and applies that key's branch. -/ +noncomputable def stepFn {k : ℕ} (tm : TM k) (R z : List Bool) : List Bool := + (stepEntries tm).foldr + (fun p acc => + caseBit₀ (matchPrefix (keyPattern p) (keyFn R (Fintype.card tm.Q) (k + 2) z)) + (stepBranch tm R p z) acc) + [] + +/-- **The encoded step is in the algebra.** -/ +theorem stepFn_mem {n k : ℕ} (tm : TM k) + {gR gz : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => stepFn tm (gR v) (gz v) := by + refine (tableFn (keyFn_mem (Fintype.card tm.Q) (k + 2) hR hz) Cobham.empty + ((stepEntries tm).map fun p => + (keyPattern p, fun v : Fin n → List Bool => stepBranch tm (gR v) p (gz v))) + ?_).of_eq fun v => ?_ + · rintro p hp + obtain ⟨q, -, rfl⟩ := List.mem_map.mp hp + by_cases hh : q.1 = tm.qhalt + · exact hz.of_eq fun v => (stepBranch_halt tm (gR v) hh (gz v)).symm + · exact (branchFn_mem _ _ hR hz).of_eq fun v => + (stepBranch_step tm (gR v) hh (gz v)).symm + · rw [stepFn, List.foldr_map] + +/-- **The table selects the configuration's own branch.** The key read out of the +encoding is the configuration's key, and by `keyPattern_injective` no other +entry's pattern matches it. -/ +theorem stepFn_apply {k : ℕ} (tm : TM k) (c : Cfg k tm.Q) {W : ℕ} + (hq : Fintype.card tm.Q ≤ blockWidth W) (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) : + stepFn tm (blockRuler W) (cfgCode W c) + = stepBranch tm (blockRuler W) (c.state, cfgReads c) (cfgCode W c) := by + have hkey := foldr_table_eq (keyCode c) [] + (stepBranch tm (blockRuler W) (c.state, cfgReads c) (cfgCode W c)) + ((stepEntries tm).map fun p => + (keyPattern p, stepBranch tm (blockRuler W) p (cfgCode W c))) ?_ ?_ + · rw [List.foldr_map] at hkey + rw [stepFn, keyFn_eq W c hq hW] + exact hkey + · refine ⟨_, List.mem_map_of_mem (mem_stepEntries tm (c.state, cfgReads c)), ?_⟩ + show keyPattern (c.state, cfgReads c) <+: keyCode c + rw [← keyCode_eq] + · rintro q hq' hpre + obtain ⟨p, -, rfl⟩ := List.mem_map.mp hq' + replace hpre : keyPattern p <+: keyCode c := hpre + have hlen : (keyPattern p).length = (keyCode c).length := by simp + have hp : p = (c.state, cfgReads c) := + keyPattern_injective (by rw [hpre.eq_of_length hlen, keyCode_eq]) + rw [hp] + +/-- **The encoded step computes the machine step.** -/ +theorem stepFn_eq {k : ℕ} (tm : TM k) {c c' : Cfg k tm.Q} {W : ℕ} + (h : tm.step c = some c') (hq : Fintype.card tm.Q ≤ blockWidth W) + (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) + (hout : c.output.StartInvariant) (hwork : ∀ i, (c.work i).StartInvariant) + (hgood : List.Forall₂ (fun (a : Γ × Dir3) (t : Tape) => + (t.head = 0 → a.1 = t.cells t.head) ∧ + (a.2 ≠ Dir3.right → t.head ≠ 0) ∧ t.head ≤ W) (stepActs tm c) (cfgTapes c)) : + stepFn tm (blockRuler W) (cfgCode W c) = cfgCode W c' := by + rw [stepFn_apply tm c hq hW, + stepBranch_step tm _ (TM.state_ne_qhalt_of_step h), ← step_state_eq tm h, + ← stepActs_eq_stepActsOf] + exact branchFn_eq tm h hout hwork hgood + +/-- **A halted encoding is a fixed point.** -/ +theorem stepFn_halted {k : ℕ} (tm : TM k) {c : Cfg k tm.Q} {W : ℕ} + (h : c.state = tm.qhalt) (hq : Fintype.card tm.Q ≤ blockWidth W) + (hW : ∀ t ∈ cfgTapes c, t.head ≤ W) : + stepFn tm (blockRuler W) (cfgCode W c) = cfgCode W c := by + rw [stepFn_apply tm c hq hW, stepBranch_halt tm _ h] + +/-! ## Length bounds + +`Cobham.iterFn` needs one polynomial bound covering *every* iterate, including +the ones reached from junk inputs. Both simulated steps keep an encoding inside a +fixed number of blocks, which is all the bound needs. -/ + +/-- Total dispatch returns one of its two branches. -/ +private theorem caseBit₀_cases (s x y : List Bool) : + caseBit₀ s x y = x ∨ caseBit₀ s x y = y := by + cases s with + | nil => exact Or.inr rfl + | cons b s => cases b <;> simp + +/-- Both half-blocks of a stepped tape fit in one block each. -/ +private theorem tapeStepBlocks_length_le (R : List Bool) (s : Γ) (d : Dir3) + (L Rt : List Bool) (hL : L.length ≤ R.length) : + (tapeStepBlocks R s d L Rt).1.length ≤ R.length ∧ + (tapeStepBlocks R s d L Rt).2.length ≤ R.length := by + cases d <;> exact ⟨by simp [tapeStepBlocks, hL], by simp [tapeStepBlocks]⟩ + +theorem tapesStepFn_length_le (R : List Bool) : + ∀ (acts : List (Γ × Dir3)) (j : ℕ) (z : List Bool), + (tapesStepFn R acts j z).length ≤ 2 * acts.length * R.length := by + intro acts + induction acts with + | nil => intro j z; simp [tapesStepFn] + | cons a rest ih => + intro j z + obtain ⟨h1, h2⟩ := tapeStepBlocks_length_le R a.1 a.2 + (blockAt R z (2 * j + 1)) (blockAt R z (2 * j + 2)) + (by rw [blockAt]; simp) + have := ih (j + 1) z + have hexp : 2 * (rest.length + 1) * R.length + = 2 * rest.length * R.length + (R.length + R.length) := by ring + rw [tapesStepFn, List.length_append, List.length_append, List.length_cons, hexp] + omega + +theorem branchFn_length_le (R q' : List Bool) (acts : List (Γ × Dir3)) (z : List Bool) : + (branchFn R q' acts z).length ≤ (2 * acts.length + 1) * R.length := by + have := tapesStepFn_length_le R acts 0 z + have hexp : (2 * acts.length + 1) * R.length + = 2 * acts.length * R.length + R.length := by ring + rw [branchFn, List.length_append, padTo_length, hexp] + omega + +@[simp] theorem stepActsOf_length {k : ℕ} (tm : TM k) (q : tm.Q) + (syms : Fin (k + 2) → Γ) : (stepActsOf tm q syms).length = k + 2 := by + rw [stepActsOf] + simp + +/-- **An encoded configuration stays within its blocks.** -/ +theorem stepFn_length_le {k : ℕ} (tm : TM k) (R z : List Bool) + (hz : z.length ≤ (2 * (k + 2) + 1) * R.length) : + (stepFn tm R z).length ≤ (2 * (k + 2) + 1) * R.length := by + rw [stepFn] + induction stepEntries tm with + | nil => simp + | cons p rest ih => + rw [List.foldr_cons] + rcases caseBit₀_cases (matchPrefix (keyPattern p) + (keyFn R (Fintype.card tm.Q) (k + 2) z)) + (stepBranch tm R p z) _ with h | h + · rw [h] + by_cases hh : p.1 = tm.qhalt + · rw [stepBranch_halt tm R hh]; exact hz + · rw [stepBranch_step tm R hh] + have := branchFn_length_le R (stateCode (stepStateOf tm p.1 p.2)) + (stepActsOf tm p.1 p.2) z + rwa [stepActsOf_length] at this + · rw [h]; exact ih + +/-! ## Rewinding the output head + +The encoding splits a tape at its head, so reading a tape off an encoding is +easy only when the head sits at cell `0` — then the left half is empty and the +right half is the whole tape, in order. Driving the head back to cell `0` is a +*separate* iteration, of a step that moves one cell left and writes nothing. + +It is stated on one tape's pair of half-blocks rather than on a whole +configuration: after the simulation only the output tape matters, and a pair of +blocks splits with one `takeFn`/`dropFn`. -/ + +/-- One tape as its two padded half-blocks, concatenated. -/ +def pairCode (W : ℕ) (t : Tape) : List Bool := + padTo (blockRuler W) (leftCode t) ++ padTo (blockRuler W) (rightCode t W) + +theorem take_pairCode (W : ℕ) (t : Tape) : + (pairCode W t).take (blockRuler W).length = padTo (blockRuler W) (leftCode t) := + List.take_left' (by simp) + +theorem drop_pairCode (W : ℕ) (t : Tape) : + (pairCode W t).drop (blockRuler W).length = padTo (blockRuler W) (rightCode t W) := + List.drop_left' (by simp) + +/-- One left move on a pair of half-blocks, writing back the symbol `s`. -/ +def rewindStep (R : List Bool) (s : Γ) (z : List Bool) : List Bool := + (tapeStepBlocks R s Dir3.left (z.take R.length) (z.drop R.length)).1 ++ + (tapeStepBlocks R s Dir3.left (z.take R.length) (z.drop R.length)).2 + +/-- **One rewind step.** The head moves one cell left, except at cell `0` — where +it reads `▷` and stays put, which is also what the machine model does. The symbol +written back is the one just read, so nothing changes but the head. -/ +def rewindFn (R z : List Bool) : List Bool := + caseBit₀ (matchPrefix (symCode Γ.start) (z.drop R.length)) z + (caseBit₀ (matchPrefix (symCode Γ.blank) (z.drop R.length)) (rewindStep R Γ.blank z) + (caseBit₀ (matchPrefix (symCode Γ.zero) (z.drop R.length)) (rewindStep R Γ.zero z) + (rewindStep R Γ.one z))) + +/-- **The rewind step is in the algebra.** -/ +theorem rewindFn_mem {n : ℕ} {gR gz : (Fin n → List Bool) → List Bool} + (hR : Cobham gR) (hz : Cobham gz) : + Cobham fun v : Fin n → List Bool => rewindFn (gR v) (gz v) := by + have hstep : ∀ s : Γ, Cobham fun v : Fin n → List Bool => rewindStep (gR v) s (gz v) := + fun s => + (appendFn (tapeStepBlocksFst s Dir3.left hR (takeFn hR hz) (dropFn hR hz)) + (tapeStepBlocksSnd s Dir3.left hR (takeFn hR hz) (dropFn hR hz))).of_eq + fun _ => rfl + have hkey : Cobham fun v : Fin n → List Bool => (gz v).drop (gR v).length := + dropFn hR hz + exact (iteFn (matchPrefixFn hkey _) hz + (iteFn (matchPrefixFn hkey _) (hstep _) + (iteFn (matchPrefixFn hkey _) (hstep _) (hstep _)))).of_eq fun _ => rfl + +/-- The first two bits of a tape's padded right half-block code its read symbol. -/ +theorem take_two_drop_pairCode {W : ℕ} (t : Tape) (hW : t.head ≤ W) : + ((pairCode W t).drop (blockRuler W).length).take 2 = symCode t.read := by + rw [drop_pairCode, + take_padTo _ _ 2 (by rw [rightCode_length]; omega) + (by rw [rightCode_length, blockRuler_length, blockWidth]; omega), + take_rightCode _ hW] + +/-- A two-bit symbol code prefixes a padded right half-block exactly when it is +*the* read symbol's code. -/ +private theorem matchPrefix_symCode {W : ℕ} (t : Tape) (hW : t.head ≤ W) (s : Γ) : + matchPrefix (symCode s) ((pairCode W t).drop (blockRuler W).length) + = if s = t.read then [true] else [false] := by + have hlen : (symCode s).length = 2 := symCode_length s + split + · next h => + subst h + refine (matchPrefix_eq_true_iff _ _).mpr ?_ + rw [← take_two_drop_pairCode t hW, ← hlen] + exact List.take_prefix _ _ + · next h => + rcases matchPrefix_flag (symCode s) + ((pairCode W t).drop (blockRuler W).length) with hm | hm + · exfalso + have hpre := (matchPrefix_eq_true_iff _ _).mp hm + have : symCode s = symCode t.read := by + rw [← take_two_drop_pairCode t hW, ← hlen] + exact List.prefix_iff_eq_take.mp hpre + exact h (symCode_injective this) + · exact hm + +/-- At cell `0` a left move stands still — `Nat` subtraction saturates. -/ +private theorem move_left_of_head_zero {t : Tape} (h : t.head = 0) : + t.move Dir3.left = t := by + obtain ⟨hd, cs⟩ := t + simp only at h + subst h + rfl + +/-- **The rewind step computes a left move.** Away from cell `0` the symbol +written back is the one read, so `tapeStepBlocks_eq` applies with +`Tape.write_read_self`; at cell `0` the head reads `▷` and both sides stand +still. -/ +theorem rewindFn_eq {W : ℕ} (t : Tape) (hinv : t.StartInvariant) (hW : t.head ≤ W) : + rewindFn (blockRuler W) (pairCode W t) = pairCode W (t.move Dir3.left) := by + by_cases h0 : t.head = 0 + · have hread : t.read = Γ.start := by rw [Tape.read, h0]; exact hinv.1 + have hmove : t.move Dir3.left = t := move_left_of_head_zero h0 + rw [rewindFn, matchPrefix_symCode t hW, if_pos hread.symm, caseBit₀_cons, cond_true, + hmove] + · have hread : t.read ≠ Γ.start := hinv.read_ne_start (by omega) + have hstep : ∀ s : Γ, s = t.read → + rewindStep (blockRuler W) s (pairCode W t) = pairCode W (t.move Dir3.left) := by + rintro s rfl + have := tapeStepBlocks_eq (W := W) t t.read Dir3.left (fun _ => rfl) + (fun _ => h0) hW + rw [rewindStep, take_pairCode, drop_pairCode, this, write_read_self, pairCode] + rw [rewindFn, matchPrefix_symCode t hW, matchPrefix_symCode t hW, + matchPrefix_symCode t hW] + cases hr : t.read with + | start => exact absurd hr hread + | blank | zero | one => + simp +decide only [caseBit₀] + exact hstep _ hr.symm + +/-- **A rewound pair stays within its two blocks.** -/ +theorem rewindFn_length_le (R z : List Bool) (hz : z.length ≤ 2 * R.length) : + (rewindFn R z).length ≤ 2 * R.length := by + have hstep : ∀ s : Γ, (rewindStep R s z).length = 2 * R.length := fun s => by + rw [rewindStep, tapeStepBlocks, List.length_append, padTo_length, padTo_length] + omega + rw [rewindFn] + rcases caseBit₀_cases (matchPrefix (symCode Γ.start) (z.drop R.length)) z _ with h | h + · rw [h]; exact hz + · rw [h] + rcases caseBit₀_cases (matchPrefix (symCode Γ.blank) (z.drop R.length)) + (rewindStep R Γ.blank z) _ with h2 | h2 + · rw [h2]; exact (hstep _).le + · rw [h2] + rcases caseBit₀_cases (matchPrefix (symCode Γ.zero) (z.drop R.length)) + (rewindStep R Γ.zero z) _ with h3 | h3 + · rw [h3]; exact (hstep _).le + · rw [h3]; exact (hstep _).le + +/-! ## The initial encoding + +At the start every tape but the input is blank and every head is at cell `0`, so +the encoding is a constant apart from the input tape's right half-block — which +is the input string at two bits per cell. Zero padding *is* blank padding, which +is why `symCode Γ.blank = [0,0]`. -/ + +/-- A bitstring as tape cells, two bits each. -/ +def encodeBits (x : List Bool) : List Bool := x.flatMap fun b => symCode (Γ.ofBool b) + +@[simp] theorem encodeBits_nil : encodeBits [] = [] := rfl + +@[simp] theorem encodeBits_cons (b : Bool) (x : List Bool) : + encodeBits (b :: x) = symCode (Γ.ofBool b) ++ encodeBits x := rfl + +@[simp] theorem encodeBits_length (x : List Bool) : + (encodeBits x).length = 2 * x.length := by + induction x with + | nil => rfl + | cons b x ih => + rw [encodeBits_cons, List.length_append, symCode_length, ih, List.length_cons] + omega + +/-- The step of `encodeBits`: prepend the peeled bit's two-bit code. -/ +private def encStep (b : Bool) (w : Fin 2 → List Bool) : List Bool := + symCode (Γ.ofBool b) ++ w 1 + +private theorem encStep_cons (b : Bool) (x p : List Bool) (v : Fin 0 → List Bool) : + encStep b (Fin.cons x (Fin.cons p v)) = symCode (Γ.ofBool b) ++ p := rfl + +/-- **Coding a string as tape cells is in the algebra.** -/ +theorem encodeBitsFn {n : ℕ} {g : (Fin n → List Bool) → List Bool} (h : Cobham g) : + Cobham fun v : Fin n → List Bool => encodeBits (g v) := by + have hrec : ∀ (x : List Bool) (v : Fin 0 → List Bool), + recNotation (fun _ : Fin 0 → List Bool => ([] : List Bool)) (encStep false) + (encStep true) x v = encodeBits x := by + intro x v + induction x with + | nil => rfl + | cons b x ih => + cases b <;> + · rw [recNotation_cons] + simp only [cond_true, cond_false] + rw [encStep_cons, ih, encodeBits_cons] + have hs : ∀ b : Bool, Cobham (encStep b) := fun b => + (appendFn (Cobham.const (symCode (Γ.ofBool b))) (Cobham.proj 1)).of_eq fun _ => rfl + have hbase : Cobham fun v : Fin 1 → List Bool => encodeBits (v 0) := by + refine (Cobham.boundedRec Cobham.empty (hs false) (hs true) + (appendFn (Cobham.proj 0) (Cobham.proj 0)) ?_).of_eq fun v => ?_ + · intro x v + rw [hrec, encodeBits_length, Fin.cons_zero, List.length_append] + omega + · rw [hrec] + exact (Cobham.comp hbase fun _ : Fin 1 => h).of_eq fun _ => rfl + +/-- **The initial encoding.** Everything but the input tape's right half-block is +a constant of the machine. -/ +noncomputable def initFn {k : ℕ} (tm : TM k) (R x : List Bool) : List Bool := + padTo R (stateCode tm.qstart) ++ + (padTo R [] ++ (padTo R (symCode Γ.start ++ encodeBits x) ++ + (List.replicate (k + 1) (padTo R [] ++ padTo R (symCode Γ.start))).flatten)) + +/-- **The initial encoding is in the algebra.** -/ +theorem initFn_mem {n k : ℕ} (tm : TM k) + {gR gx : (Fin n → List Bool) → List Bool} (hR : Cobham gR) (hx : Cobham gx) : + Cobham fun v : Fin n → List Bool => initFn tm (gR v) (gx v) := + (appendFn (padFn hR (Cobham.const _)) + (appendFn (padFn hR Cobham.empty) + (appendFn (padFn hR (appendFn (Cobham.const _) (encodeBitsFn hx))) + (repeatFn (appendFn (padFn hR Cobham.empty) + (padFn hR (Cobham.const _))) (k + 1))))).of_eq fun _ => rfl + +/-! ### The initial tapes -/ + +private theorem flatten_tapesBlocks (W : ℕ) : ∀ ts : List Tape, + (tapesBlocks W ts).flatten + = (ts.map fun t => padTo (blockRuler W) (leftCode t) + ++ padTo (blockRuler W) (rightCode t W)).flatten := by + intro ts + induction ts with + | nil => rfl + | cons t ts ih => + rw [tapesBlocks, List.flatMap_cons, List.flatten_append, ← tapesBlocks, ih, + List.map_cons, List.flatten_cons, tapeBlocks] + simp + +/-- Windows concatenate. -/ +theorem cellsCode_add (t : Tape) (i a b : ℕ) : + cellsCode t i (a + b) = cellsCode t i a ++ cellsCode t (i + a) b := by + induction a generalizing i with + | zero => simp + | succ a ih => + rw [show a + 1 + b = (a + b) + 1 from by omega, cellsCode_succ_left, + cellsCode_succ_left, ih, List.append_assoc, + show i + 1 + a = i + (a + 1) from by omega] + +private theorem cellsCode_of_bits (x : List Bool) : + ∀ (t : Tape) (i : ℕ), (∀ j, ∀ hj : j < x.length, t.cells (i + j) = Γ.ofBool x[j]) → + cellsCode t i x.length = encodeBits x := by + induction x with + | nil => intro t i _; rfl + | cons b x ih => + intro t i hcells + rw [List.length_cons, cellsCode_succ_left, encodeBits_cons, + show t.cells i = Γ.ofBool b from by simpa using hcells 0 (by simp)] + congr 1 + exact ih t (i + 1) fun j hj => by + have := hcells (j + 1) (by rw [List.length_cons]; omega) + rw [show i + 1 + j = i + (j + 1) from by omega] + simpa using this + +private theorem cellsCode_of_blank (t : Tape) (i w : ℕ) + (h : ∀ j < w, t.cells (i + j) = Γ.blank) : + cellsCode t i w = List.replicate (2 * w) false := by + induction w generalizing i with + | zero => rfl + | succ w ih => + rw [cellsCode_succ_left, show t.cells i = Γ.blank from by simpa using h 0 (by omega), + ih (i + 1) fun j hj => by + rw [show i + 1 + j = i + (j + 1) from by omega]; exact h (j + 1) (by omega), + show 2 * (w + 1) = 2 + 2 * w from by omega, List.replicate_add] + rfl + +/-- **The initial encoding is the initial configuration's.** -/ +theorem initFn_eq {k : ℕ} (tm : TM k) (W : ℕ) (x : List Bool) (hx : x.length ≤ W) : + initFn tm (blockRuler W) x = cfgCode W (tm.initCfg x) := by + set R := blockRuler W with hR + -- The input tape. + have hin : padTo R (rightCode (Tape.init (x.map Γ.ofBool)) W) + = padTo R (symCode Γ.start ++ encodeBits x) := by + have h0 : cellsCode (Tape.init (x.map Γ.ofBool)) 0 1 = symCode Γ.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h1 : cellsCode (Tape.init (x.map Γ.ofBool)) 1 x.length = encodeBits x := + cellsCode_of_bits x _ 1 fun j hj => by + rw [show 1 + j = j + 1 from by omega, Tape.init_cells_succ] + have hjm : j < (x.map Γ.ofBool).length := by simpa using hj + rw [List.getElem?_eq_getElem hjm] + simp + have h2 : cellsCode (Tape.init (x.map Γ.ofBool)) (1 + x.length) (W - x.length) + = List.replicate (2 * (W - x.length)) false := + cellsCode_of_blank _ _ _ fun j _ => by + rw [show 1 + x.length + j = (x.length + j) + 1 from by omega, + Tape.init_cells_succ, List.getElem?_eq_none (by simp)] + rfl + have hcells : cellsCode (Tape.init (x.map Γ.ofBool)) 0 (W + 1) + = symCode Γ.start ++ (encodeBits x + ++ List.replicate (2 * (W - x.length)) false) := by + rw [show W + 1 = 1 + (x.length + (W - x.length)) from by omega, + cellsCode_add _ 0 1 _, cellsCode_add _ (0 + 1) x.length _] + simp only [Nat.zero_add] + rw [h0, h1, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, ← List.append_assoc, + padTo_append_replicate] + have hblank : padTo R (rightCode (Tape.init []) W) = padTo R (symCode Γ.start) := by + have h0 : cellsCode (Tape.init ([] : List Γ)) 0 1 = symCode Γ.start := by + rw [cellsCode_succ_left, cellsCode_zero, List.append_nil, Tape.init_cells_zero] + have h2 : cellsCode (Tape.init ([] : List Γ)) 1 W + = List.replicate (2 * W) false := + cellsCode_of_blank _ _ _ fun j _ => by + rw [show 1 + j = j + 1 from by omega, Tape.init_nil_cells_succ] + have hcells : cellsCode (Tape.init ([] : List Γ)) 0 (W + 1) + = symCode Γ.start ++ List.replicate (2 * W) false := by + rw [show W + 1 = 1 + W from by omega, cellsCode_add _ 0 1 W] + simp only [Nat.zero_add] + rw [h0, h2] + rw [rightCode, Tape.init_head, Nat.sub_zero, hcells, padTo_append_replicate] + have hleft : ∀ contents : List Γ, leftCode (Tape.init contents) = [] := fun _ => rfl + have hct : cfgTapes (tm.initCfg x) + = Tape.init (x.map Γ.ofBool) :: List.replicate (k + 1) (Tape.init []) := by + rw [cfgTapes] + congr 1 + show (Tape.init [] : Tape) :: List.ofFn (fun _ : Fin k => (Tape.init [] : Tape)) + = List.replicate (k + 1) (Tape.init []) + rw [List.replicate_succ, List.ofFn_const] + rw [cfgCode, cfgBlocks_eq, List.flatten_cons, flatten_tapesBlocks, hct, + List.map_cons, List.flatten_cons, List.map_replicate, hleft, hleft, hin, hblank, + initFn, List.append_assoc] + +end Cobham + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean b/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean new file mode 100644 index 00000000..fd4acaec --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/TakeLen.lean @@ -0,0 +1,616 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Encoding.Pairing +public import Complexitylib.Models.TuringMachine.Registers +public import Complexitylib.Models.TuringMachine.Tape.Encoding + +/-! +# Truncating to the length of a leading block — proof internals + +`takeLen (pair c y) = y.take |c|`: the leading self-delimiting block acts as a +*ruler* and the verbatim suffix is truncated to its length. Carrying a width +bound as a string rather than as a number is what keeps an iterated `FP` step +function polynomial-time — each iteration truncates its state to the ruler, so no +intermediate value can grow beyond it. + +The transducer `takeLenTM` has one work tape: *scan* parses the leading block two +symbols at a time, writing one unary mark per payload bit; *rewind* returns the +work head to cell one; *copy* emits one input symbol per remaining mark. +Malformed input halts with empty output, matching `unpair? = none`. + +## Main results + +- `Complexity.takeLen_pair` — the defining equation on genuine pairs +- `Complexity.takeLen_mem_FP` — the truncation is in `FP` +-/ + + +@[expose] public section + +namespace Complexity + +open Complexity.TM + +/-! ## The function computed by the scanner -/ + +/-- The remaining output of the truncation scanner when `k` payload bits of the +leading block have already been counted and `w` is the unread part of the input: +the suffix truncated to the total ruler length, and nothing at all when the block +framing is broken. -/ +def takeLenAux (k : ℕ) (w : List Bool) : List Bool := + match unpair? w with + | some (x, y) => y.take (k + x.length) + | none => [] + +/-- Truncate the verbatim suffix of a pair to the length of its leading block. -/ +def takeLen (p : List Bool) : List Bool := takeLenAux 0 p + +@[simp] theorem takeLenAux_nil (k : ℕ) : takeLenAux k [] = [] := rfl + +@[simp] theorem takeLenAux_singleton (k : ℕ) (b : Bool) : takeLenAux k [b] = [] := by + cases b <;> rfl + +/-- Reaching the separator ends the ruler: the suffix is truncated to `k`. -/ +@[simp] theorem takeLenAux_sep (k : ℕ) (z : List Bool) : + takeLenAux k (false :: true :: z) = z.take k := by + simp [takeLenAux, unpair?] + +/-- A doubled payload bit lengthens the ruler by one. -/ +theorem takeLenAux_double (k : ℕ) (b : Bool) (z : List Bool) : + takeLenAux k (b :: b :: z) = takeLenAux (k + 1) z := by + cases b <;> + · simp only [takeLenAux, unpair?] + cases h : unpair? z with + | none => simp + | some xy => + obtain ⟨x, y⟩ := xy + simp only [Option.map_some, List.length_cons] + rw [show k + (x.length + 1) = k + 1 + x.length from by omega] + +/-- A broken doubling halts the scan with no output. -/ +@[simp] theorem takeLenAux_broken (k : ℕ) (z : List Bool) : + takeLenAux k (true :: false :: z) = [] := rfl + +/-- On a genuine pair the leading block is the ruler. -/ +theorem takeLen_pair (c y : List Bool) : takeLen (pair c y) = y.take c.length := by + simp [takeLen, takeLenAux] + +section TakeLenMachine + +/-- Control states of `takeLenTM`. -/ +inductive TakePhase where + /-- Move every head off the left-end marker. -/ + | skip + /-- Read the first symbol of a doubled payload bit. -/ + | scanA + /-- The first symbol of the pair was `0`. -/ + | scanB0 + /-- The first symbol of the pair was `1`. -/ + | scanB1 + /-- Rewind the work head to cell one. -/ + | rew + /-- Emit one input symbol per remaining mark. -/ + | copy + /-- Halt. -/ + | done + deriving DecidableEq + +instance : Fintype TakePhase where + elems := {.skip, .scanA, .scanB0, .scanB1, .rew, .copy, .done} + complete := fun x => by cases x <;> simp + +/-- **The truncation scanner.** Parses the leading self-delimiting block into +`|c|` unary marks on its work tape, then copies that many input symbols to the +output. Computes `takeLen`. -/ +def takeLenTM : TM 1 where + Q := TakePhase + qstart := .skip + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .skip => + (.scanA, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | .scanA => + match iHead with + | Γ.zero => + (.scanB0, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | Γ.one => + (.scanB1, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB0 => + match iHead with + | Γ.zero => + (.scanA, fun _ => Γw.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | Γ.one => + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + Dir3.right, fun i => idleDir (wHeads i), idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .scanB1 => + match iHead with + | Γ.one => + (.scanA, fun _ => Γw.one, readBackWrite oHead, + Dir3.right, fun _ => Dir3.right, idleDir oHead) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + | .rew => + if wHeads 0 = Γ.start then + (.copy, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun _ => Dir3.right, idleDir oHead) + else + (.rew, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => moveLeftDir (wHeads i), idleDir oHead) + | .copy => + if wHeads 0 = Γ.one then + match iHead with + | Γ.zero => + (.copy, fun i => readBackWrite (wHeads i), Γw.zero, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | Γ.one => + (.copy, fun i => readBackWrite (wHeads i), Γw.one, + Dir3.right, fun _ => Dir3.right, Dir3.right) + | _ => + (.done, fun i => readBackWrite (wHeads i), readBackWrite oHead, + idleDir iHead, fun i => idleDir (wHeads i), idleDir oHead) + else + (.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 + | .skip => exact ⟨fun _ => rfl, fun _ _ => rfl, fun _ => rfl⟩ + | .scanA => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB0 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .scanB1 => + cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + | .rew => + dsimp only [] + split + · exact ⟨idleDir_right_of_start, fun _ _ => rfl, idleDir_right_of_start⟩ + · exact ⟨idleDir_right_of_start, fun _ => moveLeftDir_right_of_start, + idleDir_right_of_start⟩ + | .copy => + dsimp only [] + split + · cases iHead <;> + exact ⟨by first | exact fun _ => rfl | exact idleDir_right_of_start, + by first | exact fun _ _ => rfl | exact fun _ => idleDir_right_of_start, + by first | exact fun _ => rfl | exact idleDir_right_of_start⟩ + · exact ⟨idleDir_right_of_start, fun _ => idleDir_right_of_start, + idleDir_right_of_start⟩ + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-! ## Correctness of the scanner -/ + +/-- A content-preserving idle step on a tape whose head is off the left marker. -/ +private theorem take_idle_eq {t : Tape} (h : t.read ≠ Γ.start) : + t.writeAndMove (readBackWrite t.read) (idleDir t.read) = t := by + rw [writeAndMove_readBack t h, idleDir, if_neg h, Tape.move] + +/-- The copy phase: with `r` marks left under and to the right of the work head, +the machine emits the first `r` symbols of the remaining input. -/ +private theorem takeLenTM_copy_loop : + ∀ (r h m : ℕ), h + r = m + 1 → 1 ≤ h → + ∀ (y acc : List Bool) (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.copy → + (c.work 0).cells = regCells m → + (c.work 0).head = h → + c.input.HasBinarySuffix y → + c.output.HasBinaryPrefix acc → + ∃ c' t, t ≤ r + 1 ∧ takeLenTM.reachesIn t c c' ∧ takeLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (acc ++ y.take r) := by + intro r + induction r with + | zero => + intro h m hsum hh y acc c hstate hcells hhead hsuf hpre + have hwread : (c.work 0).read = Γ.blank := by + rw [Tape.read, hcells, hhead]; exact regCells_blank (by omega) + have hwne : (c.work 0).read ≠ Γ.start := by rw [hwread]; decide + have hwne1 : ¬ (c.work 0).read = Γ.one := by rw [hwread]; decide + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hsuf.read_ne_start, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwne1, hinp_eq, reduceCtorEq, if_false] + rw [hwork, take_idle_eq houtne] + | succ r ih => + intro h m hsum hh y acc c hstate hcells hhead hsuf hpre + have hwread : (c.work 0).read = Γ.one := by + rw [Tape.read, hcells, hhead]; exact regCells_one (by omega) (by omega) + have hwne : (c.work 0).read ≠ Γ.start := by rw [hwread]; decide + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hsuf.read_ne_start, Tape.move] + have hworkIdle : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hworkR : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact writeAndMove_readBack _ hwne _ + have hidleB : ∀ t : Tape, t.move (idleDir Γ.blank) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + match y with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwread, hread, hidleB, reduceCtorEq, + if_false, reduceIte] + rw [hworkIdle, take_idle_eq houtne] + | b :: y => + have hread : c.input.read = Γ.ofBool b := hsuf.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.copy + input := c.input.move Dir3.right + work := fun i => (c.work i).move Dir3.right + output := c.output.writeAndMove (Γ.ofBool b) Dir3.right } with hc1 + have hstep : takeLenTM.step c = some c1 := by + cases b <;> + · simp only [TM.step, hstate, takeLenTM, hwread, hread, hc1, Γ.ofBool, + reduceCtorEq, if_false, reduceIte] + rw [hworkR] + rfl + obtain ⟨c', t, ht, hreach, hhalt, hfin⟩ := + ih (h + 1) m (by omega) (by omega) y (acc ++ [b]) c1 rfl + (by rw [hc1]; simpa using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; exact hsuf.move_right_cons) + (by rw [hc1]; exact Tape.hasBinaryPrefix_write_bit b hpre) + refine ⟨c', t + 1, by omega, .step hstep hreach, hhalt, ?_⟩ + simpa using hfin + +/-- The rewind phase: walk the work head back to the left-end marker and enter +`copy` with the work head at cell one. -/ +private theorem takeLenTM_rew_loop : + ∀ (h m : ℕ) (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.rew → + (c.work 0).cells = regCells m → + (c.work 0).head = h → + c.input.read ≠ Γ.start → + c.output.read ≠ Γ.start → + ∃ c', takeLenTM.reachesIn (h + 1) c c' ∧ + c'.state = TakePhase.copy ∧ + (c'.work 0).cells = regCells m ∧ + (c'.work 0).head = 1 ∧ + c'.input = c.input ∧ + c'.output = c.output := by + intro h + induction h with + | zero => + intro m c hstate hcells hhead hinp hout + have hwread : (c.work 0).read = Γ.start := by + rw [Tape.read, hcells, hhead]; rfl + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + Dir3.right) = fun i => (c.work i).move Dir3.right := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + show ((c.work 0).write _).move Dir3.right = (c.work 0).move Dir3.right + rw [Tape.write, if_pos hhead] + refine ⟨{ state := TakePhase.copy + input := c.input + work := fun i => (c.work i).move Dir3.right + output := c.output }, ?_, rfl, by simp [Tape.move_cells, hcells], + by simp [Tape.move, hhead], rfl, rfl⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hwread, hinp_eq, reduceIte, reduceCtorEq, + if_false] + rw [hwork, take_idle_eq hout] + | succ h ih => + intro m c hstate hcells hhead hinp hout + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have hinp_eq : c.input.move (idleDir c.input.read) = c.input := by + rw [idleDir, if_neg hinp, Tape.move] + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.rew + input := c.input + work := fun i => (c.work i).move Dir3.left + output := c.output } with hc1 + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (moveLeftDir ((c.work i).read))) = fun i => (c.work i).move Dir3.left := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + rw [moveLeftDir, if_neg hwne] + exact writeAndMove_readBack _ hwne _ + have hstep : takeLenTM.step c = some c1 := by + simp only [TM.step, hstate, takeLenTM, hinp_eq, hc1, if_neg hwne, reduceCtorEq, + if_false] + rw [hwork, take_idle_eq hout] + obtain ⟨c', hreach, hst, hcl, hhd, hin, hou⟩ := + ih m c1 rfl (by rw [hc1]; simpa [Tape.move_cells] using hcells) + (by rw [hc1]; simp [Tape.move, hhead]) + (by rw [hc1]; simpa using hinp) (by rw [hc1]; simpa using hout) + exact ⟨c', .step hstep hreach, hst, hcl, hhd, by rw [hin, hc1], by rw [hou, hc1]⟩ + +/-- The scan phase: from `scanA` with `k` ruler bits already counted and `w` +unread, the machine runs to a halt with `takeLenAux k w` on the output tape. -/ +private theorem takeLenTM_scan_loop : + ∀ (N : ℕ) (w : List Bool) (k : ℕ), k + w.length ≤ N → + ∀ (c : Cfg 1 takeLenTM.Q), + c.state = TakePhase.scanA → + (c.work 0).cells = regCells k → + (c.work 0).head = k + 1 → + c.input.HasBinarySuffix w → + c.output.HasBinaryPrefix [] → + ∃ c' t, t ≤ 3 * N + 5 ∧ takeLenTM.reachesIn t c c' ∧ + takeLenTM.halted c' ∧ + c'.output.HasBinaryPrefix (takeLenAux k w) := by + intro N + induction N with + | zero => + intro w k hN c hstate hcells hhead hsuf hpre + have hwnil : w = [] := List.length_eq_zero_iff.mp (by omega) + subst hwnil + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hread : c.input.read = Γ.blank := hsuf.read_nil + have hidleB : ∀ t : Tape, t.move (idleDir Γ.blank) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hread, hidleB, reduceCtorEq, if_false] + rw [hwork, take_idle_eq houtne] + | succ N ih => + intro w k hN c hstate hcells hhead hsuf hpre + have hwne : (c.work 0).read ≠ Γ.start := by + rw [Tape.read, hcells, hhead]; exact regCells_ne_start (by omega) + have houtne : c.output.read ≠ Γ.start := by rw [hpre.read_blank]; decide + have hwork : (fun i => (c.work i).writeAndMove (readBackWrite ((c.work i).read)).toΓ + (idleDir ((c.work i).read))) = c.work := by + funext i + have hi : i = 0 := Subsingleton.elim i 0 + subst hi + exact take_idle_eq hwne + have hidleB : ∀ t : Tape, t.move (idleDir Γ.blank) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + have hidleZ : ∀ t : Tape, t.move (idleDir Γ.zero) = t := by + intro t; rw [idleDir, if_neg (by decide)]; rfl + have hstepA : ∀ b : Bool, + c.input.read = Γ.ofBool b → + takeLenTM.step c = some + { state := (bif b then TakePhase.scanB1 else TakePhase.scanB0) + input := c.input.move Dir3.right + work := c.work + output := c.output } := by + intro b hread + cases b <;> + · simp only [TM.step, hstate, takeLenTM, hread, Γ.ofBool, reduceCtorEq, if_false, + cond_true, cond_false] + rw [hwork, take_idle_eq houtne] + match w with + | [] => + have hread : c.input.read = Γ.blank := hsuf.read_nil + refine ⟨{ state := TakePhase.done + input := c.input + work := c.work + output := c.output }, 1, by omega, ?_, rfl, by simpa using hpre⟩ + refine .step ?_ .zero + simp only [TM.step, hstate, takeLenTM, hread, hidleB, reduceCtorEq, if_false] + rw [hwork, take_idle_eq houtne] + | [b] => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix [] := hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.blank := hsuf1.read_nil + refine ⟨{ state := TakePhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [takeLenAux_singleton] using hpre⟩ + refine .step (hstepA b hsuf.read_cons) (.step ?_ .zero) + cases b <;> + · simp only [TM.step, takeLenTM, hread1, hidleB, reduceCtorEq, if_false, + cond_true, cond_false] + rw [hwork, take_idle_eq houtne] + | true :: false :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.zero := hsuf1.read_cons + refine ⟨{ state := TakePhase.done + input := c.input.move Dir3.right + work := c.work + output := c.output }, 2, by omega, ?_, rfl, by + simpa [takeLenAux_broken] using hpre⟩ + refine .step (hstepA true hsuf.read_cons) (.step ?_ .zero) + simp only [TM.step, takeLenTM, hread1, hidleZ, reduceCtorEq, if_false, cond_true] + rw [hwork, take_idle_eq houtne] + | false :: true :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.one := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.rew + input := (c.input.move Dir3.right).move Dir3.right + work := c.work + output := c.output } with hc2 + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, if_false] + rw [hwork, take_idle_eq houtne] + have hsuf2 : c2.input.HasBinarySuffix z := hsuf1.move_right_cons + obtain ⟨c3, hreach3, hst3, hcl3, hhd3, hin3, hou3⟩ := + takeLenTM_rew_loop (k + 1) k c2 rfl (by rw [hc2]; exact hcells) + (by rw [hc2]; exact hhead) hsuf2.read_ne_start (by rw [hc2]; exact houtne) + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + takeLenTM_copy_loop k 1 k (by omega) (by omega) z [] c3 hst3 hcl3 hhd3 + (by rw [hin3]; exact hsuf2) (by rw [hou3]; exact hpre) + refine ⟨c', (k + 1 + 1 + t) + 1 + 1, ?_, ?_, hhalt', ?_⟩ + · simp only [List.length_cons] at hN + omega + · exact .step hstep1 (.step hstep2 (takeLenTM.reachesIn_trans hreach3 hreach')) + · rw [takeLenAux_sep] + simpa using hout' + | false :: false :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (false :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.zero := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB0 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA false hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Γ.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Γw.one).toΓ Dir3.right) + = fun i => ((c.work i).write Γ.one).move Dir3.right := rfl + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, if_false] + rw [hwmark, take_idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, if_neg (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Γ.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 + hhead2 (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, by omega, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + rwa [takeLenAux_double] + | true :: true :: z => + have hsuf1 : (c.input.move Dir3.right).HasBinarySuffix (true :: z) := + hsuf.move_right_cons + have hread1 : (c.input.move Dir3.right).read = Γ.one := hsuf1.read_cons + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanB1 + input := c.input.move Dir3.right + work := c.work + output := c.output } with hc1 + have hstep1 : takeLenTM.step c = some c1 := hstepA true hsuf.read_cons + set c2 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (c.input.move Dir3.right).move Dir3.right + work := fun i => ((c.work i).write Γ.one).move Dir3.right + output := c.output } with hc2 + have hwmark : (fun i => (c.work i).writeAndMove (Γw.one).toΓ Dir3.right) + = fun i => ((c.work i).write Γ.one).move Dir3.right := rfl + have hstep2 : takeLenTM.step c1 = some c2 := by + simp only [TM.step, hc1, hc2, takeLenTM, hread1, reduceCtorEq, if_false] + rw [hwmark, take_idle_eq houtne] + have hcells2 : (c2.work 0).cells = regCells (k + 1) := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).cells = _ + rw [Tape.move_cells, Tape.write, if_neg (by rw [hhead]; omega)] + show Function.update (c.work 0).cells ((c.work 0).head) Γ.one = _ + rw [hcells, hhead, regCells_update_succ] + have hhead2 : (c2.work 0).head = k + 1 + 1 := by + rw [hc2] + show (((c.work 0).write Γ.one).move Dir3.right).head = _ + rw [Tape.move, Tape.write_head, hhead] + obtain ⟨c', t, ht, hreach', hhalt', hout'⟩ := + ih z (k + 1) (by simp only [List.length_cons] at hN; omega) c2 rfl hcells2 + hhead2 (by rw [hc2]; exact hsuf1.move_right_cons) (by rw [hc2]; exact hpre) + refine ⟨c', t + 1 + 1, by omega, .step hstep1 (.step hstep2 hreach'), hhalt', ?_⟩ + rwa [takeLenAux_double] + +/-- The blank work tape of the initial configuration is the zero register. -/ +private theorem take_init_nil_cells : + (Tape.init ([] : List Γ)).cells = regCells 0 := by + funext j + rcases Nat.eq_zero_or_pos j with rfl | hj + · rfl + · obtain ⟨i, rfl⟩ : ∃ i, j = i + 1 := ⟨j - 1, by omega⟩ + rw [Tape.init_cells_ge _ _ (by simp), regCells_blank (by omega)] + +/-- `takeLenTM` computes `takeLen` in `3 · |p| + 6` steps. -/ +theorem takeLenTM_computesInTime : + takeLenTM.ComputesInTime takeLen (fun n => 3 * n + 6) := by + intro p + set c1 : Cfg 1 takeLenTM.Q := + { state := TakePhase.scanA + input := (Tape.init (p.map Γ.ofBool)).move Dir3.right + work := fun _ => (Tape.init []).move Dir3.right + output := (Tape.init []).move Dir3.right } with hc1 + have hstep1 : takeLenTM.step (takeLenTM.initCfg p) = some c1 := by + simp [TM.step, takeLenTM, hc1, Tape.read, Tape.init, readBackWrite, + Tape.writeAndMove, Tape.write, Tape.move] + obtain ⟨c', t, ht, hreach, hhalt, hout⟩ := + takeLenTM_scan_loop p.length p 0 (by omega) c1 rfl + (by rw [hc1]; show ((Tape.init []).move Dir3.right).cells = _ + rw [Tape.move_cells, take_init_nil_cells]) + (by rw [hc1]; show ((Tape.init []).move Dir3.right).head = _ + simp [Tape.move]) + (by rw [hc1]; exact Tape.init_move_right_hasBinarySuffix p) + (by rw [hc1]; exact Tape.init_nil_move_right_hasBinaryPrefix_nil) + exact ⟨c', t + 1, by simp; omega, .step hstep1 hreach, hhalt, hout.hasOutput⟩ + +end TakeLenMachine + +/-- Internal proof that ruler-truncation is in `FP`. -/ +theorem takeLen_mem_FP : takeLen ∈ FP := by + refine ⟨1, 1, takeLenTM, (fun n => 3 * n + 6), takeLenTM_computesInTime, ?_⟩ + have hn : (fun n : ℕ => 3 * n) =O ((· ^ 1) : ℕ → ℕ) := by + simpa [pow_one] using (BigO.refl (fun n : ℕ => n)).const_mul_left 3 + exact BigO.add hn (BigO.const_le_pow 6 1) + +end Complexity diff --git a/Complexitylib/Classes/P/Cobham/Internal/Vec.lean b/Complexitylib/Classes/P/Cobham/Internal/Vec.lean new file mode 100644 index 00000000..0e95f387 --- /dev/null +++ b/Complexitylib/Classes/P/Cobham/Internal/Vec.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Classes.P.Defs +public import Complexitylib.Classes.P.FinsetDomain +public import Complexitylib.Classes.P.PairWithInput + +/-! +# The multi-arity bridge — proof internals + +`FP` is defined for unary functions only, but Cobham's algebra is inherently +multi-arity. `Cobham.encodeVec` packs an argument vector into one bitstring by +nested pairing and `Cobham.FPn` says a multi-arity function is polynomial-time +*on encoded vectors*; at arity one the encoding is `pair [] x`, so `FPn` +collapses to `FP`. + +## Main definitions + +- `Cobham.encodeVec` — nested-pairing tuple encoding, head component last +- `Cobham.FPn` — polynomial time on encoded argument vectors +- `Cobham.const_nil_mem_FP`, `Cobham.pairLeftNil_mem_FP` — the two `FP` maps the + arity-one glue needs +-/ + + +@[expose] public section + +namespace Complexity + +namespace Cobham + +/-! ## Tuple encoding and the multi-arity FP predicate -/ + +/-- Encode an argument vector as a single bitstring by nested pairing, with the +head component placed in the verbatim suffix: +`encodeVec ![] = []` and `encodeVec (x ::ᵥ v) = pair (encodeVec v) x`. + +Putting the head last (as the `pair` suffix) is what makes the arity-one encoding +`pair [] x`, so the soundness glue only needs `pairLeftNil_mem_FP`, which follows +from the existing `mem_FP_pairWithInput`. Because `pair` is injective with a +verbatim suffix, `encodeVec` is injective and its length is linear in the total +length of the components — exactly what the polynomial-time bookkeeping of `FPn` +needs. -/ +def encodeVec : {n : ℕ} → (Fin n → List Bool) → List Bool + | 0, _ => [] + | _ + 1, v => pair (encodeVec (Fin.tail v)) (v 0) + +@[simp] theorem encodeVec_zero (v : Fin 0 → List Bool) : encodeVec v = [] := rfl + +@[simp] theorem encodeVec_succ {n : ℕ} (v : Fin (n + 1) → List Bool) : + encodeVec v = pair (encodeVec (Fin.tail v)) (v 0) := rfl + +/-- The arity-one encoding is the single component placed in the (verbatim) +suffix of an empty block: `encodeVec ![x] = pair [] x`. -/ +theorem encodeVec_one (v : Fin 1 → List Bool) : encodeVec v = pair [] (v 0) := by + simp [encodeVec] + +/-- **Multi-arity polynomial time.** A function of an argument vector is `FPn` +when some genuine (unary) `FP` function computes it on encoded vectors. This is +the induction motive for `cobham_imp_FPn`; specialized to arity one it collapses +to `FP` (see `CobhamFP_subset_FP_of_FPn`). -/ +def FPn {n : ℕ} (f : (Fin n → List Bool) → List Bool) : Prop := + ∃ g, g ∈ FP ∧ ∀ v, g (encodeVec v) = f v + +/-! ## Foundational FP building blocks -/ + +/-- The constant empty-output function is in `FP` (the empty-support case of +`ite_mem_finset_mem_FP`). -/ +theorem const_nil_mem_FP : (fun _ : List Bool => ([] : List Bool)) ∈ FP := by + have h := ite_mem_finset_mem_FP (fun _ => []) (∅ : Finset (List Bool)) + simpa using h + +/-- The framing map `x ↦ pair [] x` (i.e. `false :: true :: x`) is +polynomial-time. This is the foundational map behind the arity-one encoding +`encodeVec ![x] = pair [] x`, and it is exactly `mem_FP_pairWithInput` applied to +the constant empty function. -/ +theorem pairLeftNil_mem_FP : (fun x : List Bool => pair [] x) ∈ FP := by + have h := mem_FP_pairWithInput const_nil_mem_FP + simpa using h + +end Cobham + +end Complexity diff --git a/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean b/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean index ee7b909b..42140aba 100644 --- a/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean +++ b/Complexitylib/Models/RandomAccessMachine/Simulation/TMConfig/Sparse/Containment/Internal.lean @@ -5,6 +5,7 @@ Authors: Samuel Schlesinger -/ module +public import Complexitylib.Asymptotics.PolyBound public import Complexitylib.Classes.P.NormalForm public import Complexitylib.Models.RandomAccessMachine.Classes.Defs public import Complexitylib.Models.RandomAccessMachine.Simulation.TMConfig.Sparse.ABI @@ -62,47 +63,21 @@ theorem mem_DTIME_of_decidesInTime_internal (fun inputLength => decisionTimeBound tm inputLength (T inputLength)), compiledDecision_decidesInTime_internal hdecides, BigO.refl _⟩ -/-- Pointwise domination by the evaluation of a natural polynomial. -/ -def PolyBound (f : ℕ → ℕ) : Prop := - ∃ p : Polynomial ℕ, ∀ inputLength, f inputLength ≤ p.eval inputLength +end Sparse + +end TMConfig + +end RAM + +/-! ## Polynomial bounds on the sparse simulation's resource functions + +Extensions of the generic `PolyBound` API of `Complexitylib.Asymptotics.PolyBound` +to the register, word, marshalling, and running-time bounds of this simulation. +They live in the root `PolyBound` namespace so that dot notation reaches them. -/ namespace PolyBound -theorem const (value : ℕ) : PolyBound (fun _ => value) := - ⟨Polynomial.C value, fun _ => by simp⟩ - -theorem id : PolyBound (fun inputLength => inputLength) := - ⟨Polynomial.X, fun _ => by simp⟩ - -theorem add {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : - PolyBound (fun inputLength => f inputLength + g inputLength) := by - obtain ⟨p, hp⟩ := hf - obtain ⟨q, hq⟩ := hg - exact ⟨p + q, fun inputLength => by - rw [Polynomial.eval_add] - exact Nat.add_le_add (hp inputLength) (hq inputLength)⟩ - -theorem mul {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : - PolyBound (fun inputLength => f inputLength * g inputLength) := by - obtain ⟨p, hp⟩ := hf - obtain ⟨q, hq⟩ := hg - exact ⟨p * q, fun inputLength => by - rw [Polynomial.eval_mul] - exact Nat.mul_le_mul (hp inputLength) (hq inputLength)⟩ - -theorem mono {f g : ℕ → ℕ} (hg : PolyBound g) - (hle : ∀ inputLength, f inputLength ≤ g inputLength) : PolyBound f := by - obtain ⟨p, hp⟩ := hg - exact ⟨p, fun inputLength => le_trans (hle inputLength) (hp inputLength)⟩ - -theorem max {f g : ℕ → ℕ} (hf : PolyBound f) (hg : PolyBound g) : - PolyBound (fun inputLength => max (f inputLength) (g inputLength)) := - (hf.add hg).mono fun _ => Nat.max_le.mpr - ⟨Nat.le_add_right _ _, Nat.le_add_left _ _⟩ - -theorem eval (p : Polynomial ℕ) : - PolyBound (fun inputLength => p.eval inputLength) := - ⟨p, fun _ => le_rfl⟩ +open RAM RAM.TMConfig.Sparse private theorem size_le_self (value : ℕ) : value.size ≤ value := by rw [Nat.size_le] @@ -202,6 +177,12 @@ theorem decisionTimeBound (tm : TM n) {T : ℕ → ℕ} (hT : PolyBound T) : end PolyBound +namespace RAM + +namespace TMConfig + +namespace Sparse + theorem P_subset_internal : Complexity.P ⊆ RAM.P := by intro L hL obtain ⟨workTapes, tm, p, hdecides⟩ := diff --git a/Complexitylib/Models/TuringMachine/Combinators/Apply.lean b/Complexitylib/Models/TuringMachine/Combinators/Apply.lean new file mode 100644 index 00000000..211e2236 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Combinators/Apply.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import Complexitylib.Models.TuringMachine.Frame +public import Complexitylib.Models.TuringMachine.Hoare.RetargetOutput + +/-! +# Running a machine from a work tape onto a work tape + +A loop body cannot compute into the real output tape — it is one-way, so it +cannot serve as scratch across iterations. `TM.retargetInputStarted` reads a +machine's input off a work tape and `TM.retargetOutput` writes its output onto a +fresh one; composing them gives `TM.applyTM`, a work-to-work evaluator, and +composing their Hoare rules gives its contract. + +## Main results + +- `TM.applyTM` — the work-to-work evaluator for a source machine +- `TM.applyTM_hoareTime` / `TM.applyTM_hoareTime_frame` — its time contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +variable {k : ℕ} + +/-- **Work-tape-to-work-tape evaluation.** `applyTM M : TM (k + 2)` reads the +source machine's input off work tape `k`, runs `M` on it, and leaves the result +on work tape `k + 1`; the real input and output tapes are untouched. + +Work tapes `0, …, k-1` are `M`'s own scratch, so a caller that runs `applyTM M` +more than once has to restore them between calls — that is what the +precondition below demands. -/ +def applyTM (M : TM k) : TM (k + 2) := (retargetInputStarted M).retargetOutput + +/-- The tapes `applyTM M` expects at entry: `M`'s scratch blank, the virtual +input holding `y`, the result tape blank. -/ +def applyPre (M : TM k) (y : List Bool) (realInput : Tape) : + Fin (k + 2) → Tape := + Fin.snoc (retargetInputStartedCfg M y realInput).work parkedBlank + +/-- **The contract of the work-to-work evaluator.** Given `M`'s own time bound, +`applyTM M` halts within that bound with `f y` on its result tape — provided +`M`'s scratch tapes were blank, work tape `k` held `y`, and the result tape was +blank. -/ +theorem applyTM_hoareTime (M : TM k) {f : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime f T) (y : List Bool) : + (applyTM M).HoareTime + (fun inp work out => + ((fun i : Fin (k + 1) => work (Fin.castSucc i)) + = (retargetInputStartedCfg M y inp).work) ∧ + work (Fin.last (k + 1)) = parkedBlank ∧ + out = parkedBlank) + (fun _inp work out => + (work (Fin.last (k + 1))).HasOutput (f y) ∧ out = parkedBlank) + (T y.length) := by + have h := retargetOutput_hoareTime (retargetInputStarted M) + (retargetInputStarted_hoareTime M hcomp y) + intro inp work out hpre + obtain ⟨h1, h2, h3⟩ := hpre + exact h inp work out ⟨⟨h1, h2⟩, h3⟩ + +/-- The entry tapes do satisfy the entry condition. -/ +theorem applyPre_spec (M : TM k) (y : List Bool) (realInput : Tape) : + ((fun i : Fin (k + 1) => applyPre M y realInput (Fin.castSucc i)) + = (retargetInputStartedCfg M y realInput).work) ∧ + applyPre M y realInput (Fin.last (k + 1)) = parkedBlank := by + refine ⟨funext fun i => ?_, ?_⟩ + · rw [applyPre, Fin.snoc_castSucc] + · rw [applyPre, Fin.snoc_last] + +/-- The work-to-work evaluator reads its input from a work tape, so it idles +the real input head. -/ +theorem applyTM_idlesInput (M : TM k) : IdlesInput (applyTM M) := fun _ _ _ _ => rfl + +/-- Every entry tape of the work-to-work evaluator is parked at cell `1`. -/ +theorem applyPre_head (M : TM k) (y : List Bool) (realInput : Tape) (i : Fin (k + 2)) : + (applyPre M y realInput i).head = 1 := by + refine Fin.lastCases ?_ ?_ i + · rw [applyPre, Fin.snoc_last]; rfl + · intro i' + rw [applyPre, Fin.snoc_castSucc] + show ((retargetInputStartedCfg M y realInput).work i').head = 1 + rw [retargetInputStartedCfg] + dsimp only + split <;> rfl + +/-- Every entry tape of the work-to-work evaluator satisfies the left-marker +invariant. -/ +theorem applyPre_startInvariant (M : TM k) (y : List Bool) (realInput : Tape) + (i : Fin (k + 2)) : Tape.StartInvariant (applyPre M y realInput i) := by + refine Fin.lastCases ?_ ?_ i + · rw [applyPre, Fin.snoc_last] + show Tape.StartInvariant ((Tape.init ([] : List Γ)).move Dir3.right) + exact startInvariant_initNil.move Dir3.right + · intro i' + rw [applyPre, Fin.snoc_castSucc] + show Tape.StartInvariant ((retargetInputStartedCfg M y realInput).work i') + rw [retargetInputStartedCfg] + dsimp only + split + · exact startInvariant_initNil.move Dir3.right + · exact (startInvariant_initOfBool y).move Dir3.right + +/-- Every entry tape of the work-to-work evaluator is blank beyond the virtual +input's length. -/ +theorem applyPre_cells_blank (M : TM k) (y : List Bool) (realInput : Tape) + (i : Fin (k + 2)) (j : ℕ) (hj : y.length < j) : + (applyPre M y realInput i).cells j = Γ.blank := by + have hj0 : j = (j - 1) + 1 := by omega + refine Fin.lastCases ?_ ?_ i + · rw [applyPre, Fin.snoc_last] + show ((Tape.init ([] : List Γ)).move Dir3.right).cells j = Γ.blank + rw [Tape.move_cells, hj0, Tape.init_cells_ge [] (j - 1) (by simp)] + · intro i' + rw [applyPre, Fin.snoc_castSucc] + show ((retargetInputStartedCfg M y realInput).work i').cells j = Γ.blank + rw [retargetInputStartedCfg] + dsimp only + split + · show ((Tape.init ([] : List Γ)).move Dir3.right).cells j = Γ.blank + rw [Tape.move_cells, hj0, Tape.init_cells_ge [] (j - 1) (by simp)] + · show ((Tape.init (y.map Γ.ofBool)).move Dir3.right).cells j = Γ.blank + rw [Tape.move_cells, hj0, + Tape.init_cells_ge (y.map Γ.ofBool) (j - 1) (by simp only [List.length_map]; omega)] + +/-- **The work-to-work evaluator, with its disturbance framed.** Beyond +computing `f y` onto the result tape, this records the two facts a caller needs +in order to reset the machine for a second call: every tape's head is still +within `H`, and every cell beyond `H` is still blank. Both follow from the run +being `T |y|`-bounded and every entry tape being parked and blank past `|y|`. -/ +theorem applyTM_hoareTime_frame (M : TM k) {f : List Bool → List Bool} {T : ℕ → ℕ} + (hcomp : M.ComputesInTime f T) (y : List Bool) (inp₀ : Tape) (hinp : Parked inp₀) + (hinpSI : Tape.StartInvariant inp₀) + (H : ℕ) (hHy : y.length ≤ H) (hHT : 1 + T y.length ≤ H) : + (applyTM M).HoareTime + (fun inp work out => inp = inp₀ ∧ work = applyPre M y inp₀ ∧ out = parkedBlank) + (fun inp work out => inp = inp₀ ∧ out = parkedBlank ∧ + (work (Fin.last (k + 1))).HasOutput (f y) ∧ + ∀ i, Tape.StartInvariant (work i) ∧ (work i).head ≤ H ∧ + ∀ j, H < j → (work i).cells j = Γ.blank) + (T y.length) := by + intro inp work out hpre + obtain ⟨hi, hw, ho⟩ := hpre + rw [hi, hw, ho] + obtain ⟨c', t, ht, hreach, hhalt, hOut, hOutEq⟩ := + applyTM_hoareTime M hcomp y inp₀ (applyPre M y inp₀) parkedBlank + ⟨(applyPre_spec M y inp₀).1, (applyPre_spec M y inp₀).2, rfl⟩ + have hinpEq : c'.input = inp₀ := + reachesIn_input_eq_of_idlesInput (applyTM_idlesInput M) hreach hinp + have hSI := reachesIn_startInvariant hreach hinpSI + (fun i => applyPre_startInvariant M y inp₀ i) + (show Tape.StartInvariant parkedBlank from startInvariant_initNil.move Dir3.right) + refine ⟨c', t, ht, hreach, hhalt, hinpEq, hOutEq, hOut, + fun i => ⟨hSI.2.1 i, ?_, fun j hj => ?_⟩⟩ + · have hh := (head_le_start_add_of_reachesIn (applyTM M) hreach).2.2 i + rw [show ((⟨(applyTM M).qstart, inp₀, applyPre M y inp₀, parkedBlank⟩ : + Cfg (k + 2) (applyTM M).Q).work i).head = 1 from applyPre_head M y inp₀ i] at hh + omega + · rw [reachesIn_work_cells_far hreach i j + (by rw [applyPre_head M y inp₀ i]; omega)] + exact applyPre_cells_blank M y inp₀ i j (by omega) + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Frame.lean b/Complexitylib/Models/TuringMachine/Frame.lean new file mode 100644 index 00000000..79416f57 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Frame.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators.Internal +public import Complexitylib.Models.TuringMachine.Hoare +public import Complexitylib.Models.TuringMachine.Internal +public import Complexitylib.Models.TuringMachine.Placement +public import Complexitylib.Models.TuringMachine.Registers + +/-! +# Frame rules for composite machines + +Two things a machine built out of sub-machines needs to know: that a +sub-machine's Hoare triple still holds once its tapes are embedded in a larger +tape space (`TM.placeWorkTM_hoareTime_frame`), and that a run of bounded length +cannot have touched cells far from where its heads started +(`TM.reachesIn_work_cells_far`). The second is what lets a *bounded* wipe reset +an opaque machine's scratch completely. + +## Main results + +- `TM.placeWorkTM_hoareTime_frame` — a Hoare triple survives tape embedding +- `TM.reachesIn_work_cells_far` — a `t`-step run leaves cells beyond `head + t` alone +- `TM.reachesIn_startInvariant` — runs preserve `Tape.StartInvariant` +- `TM.seqTM_det` — sequential composition is deterministic on its components +- `TM.IdlesInput` — machines that never move their input head +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- The parked blank tape every scratch tape starts and ends at. -/ +def parkedBlank : Tape := (Tape.init []).move Dir3.right + +/-! ## Embedding a Hoare triple in a larger tape space + +A composite machine runs sub-machines that each own a fixed number of work +tapes, while carrying persistent state (running values, fuel registers) on tapes +those sub-machines never touch. `TM.placeWorkTM` already gives the exact +frame-preserving simulation +(`placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant`); the lemma below turns +that into a Hoare-triple-level tool, so each embedding is a single lemma +application instead of a fresh `reachesIn` argument. -/ + +/-- **Placing a Hoare triple.** If `tm : TM n` satisfies a Hoare triple, then +`placeWorkTM pre post tm` satisfies the triple obtained by reindexing `tm`'s +work-tape predicate through the middle block, with an arbitrary `Parked`-style +frame (`extras`) held exactly fixed outside it. -/ +theorem placeWorkTM_hoareTime_frame {n pre post : ℕ} (tm : TM n) + {preSmall postSmall : TapePred n} {b : ℕ} + (h : tm.HoareTime preSmall postSmall b) + (extras : Fin (pre + n + post) → Tape) + (hinv : ∀ i, ¬placeWorkInMiddle pre n i → Tape.StartInvariant (extras i)) + (hhead : ∀ i, ¬placeWorkInMiddle pre n i → 1 ≤ (extras i).head) : + (placeWorkTM pre post tm).HoareTime + (fun inp work out => preSmall inp (fun i => work (placeWorkIdx pre post i)) out ∧ + ∀ i, ¬placeWorkInMiddle pre n i → work i = extras i) + (fun inp work out => postSmall inp (fun i => work (placeWorkIdx pre post i)) out ∧ + ∀ i, ¬placeWorkInMiddle pre n i → work i = extras i) + b := by + rintro inp work out ⟨hpre, hextra⟩ + set wSmall : Fin n → Tape := fun i => work (placeWorkIdx pre post i) with hwSmall + obtain ⟨c', t, ht, hreach, hhalt, hpost⟩ := h inp wSmall out hpre + have hweq : work = (placeWorkCfg tm pre post extras + { state := tm.qstart, input := inp, work := wSmall, output := out }).work := by + funext i + by_cases hmid : placeWorkInMiddle pre n i + · rw [show i = placeWorkIdx pre post (placeWorkCoord pre n i hmid) from + (placeWorkIdx_placeWorkCoord i hmid).symm, placeWorkCfg_work_middle] + · rw [placeWorkCfg_work_extra tm pre post extras _ i hmid] + exact hextra i hmid + refine ⟨placeWorkCfg tm pre post extras c', t, ht, ?_, + (placeWorkCfg_halted_iff tm pre post extras c').mpr hhalt, ?_, ?_⟩ + · rw [hweq] + exact placeWorkTM_reachesIn_placeWorkCfg_of_startInvariant tm pre post extras hreach + hinv hhead + · show postSmall c'.input (fun i => (placeWorkCfg tm pre post extras c').work + (placeWorkIdx pre post i)) c'.output + simp only [placeWorkCfg_work_middle] + exact hpost + · intro i hi + exact placeWorkCfg_work_extra tm pre post extras c' i hi + +/-! ## What a bounded run can have disturbed + +Resetting an opaque machine's scratch tapes between calls needs +to know *how far out* the machine could possibly have written. Since each head +moves by at most one cell per step and a machine only ever writes under its +heads, a `t`-step run leaves every cell beyond `head + t` exactly as it found +it. That is what makes the bounded wipe of `TM.resetTapesTM` complete rather +than merely partial. -/ + +/-- One step leaves every work-tape cell other than that tape's own head +unchanged: a machine writes only under its heads. -/ +theorem work_cells_ne_of_step {n : ℕ} {tm : TM n} {c c' : Cfg n tm.Q} + (hstep : tm.step c = some c') (i : Fin n) {j : ℕ} (hj : j ≠ (c.work i).head) : + (c'.work i).cells j = (c.work i).cells j := by + simp only [TM.step] at hstep + split at hstep + · simp at hstep + · simp only [Option.some.injEq] at hstep + rw [← hstep] + simp only [Tape.move_cells, Tape.write] + split + · rfl + · change Function.update (c.work i).cells (c.work i).head _ j = (c.work i).cells j + rw [Function.update_of_ne hj] + +/-- **Cells beyond a work head's maximum reach are never touched.** -/ +theorem reachesIn_work_cells_far {n : ℕ} {tm : TM n} : + ∀ {t : ℕ} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' → + ∀ (i : Fin n) (j : ℕ), (c.work i).head + t < j → + (c'.work i).cells j = (c.work i).cells j := by + intro t + induction t with + | zero => + intro c c' hreach i j _ + cases hreach + rfl + | succ t ih => + intro c c' hreach i j hj + cases hreach with + | step hstep hrest => + next c'' => + have hhead : (c''.work i).head ≤ (c.work i).head + 1 := + (head_le_start_add_of_reachesIn tm (TM.reachesIn.step hstep TM.reachesIn.zero)).2.2 i + have hcell : (c''.work i).cells j = (c.work i).cells j := + work_cells_ne_of_step hstep i (by omega) + rw [ih hrest i j (by omega), hcell] + +/-- The standing left-marker invariant survives an entire run, on every tape. -/ +theorem reachesIn_startInvariant {n : ℕ} {tm : TM n} : + ∀ {t : ℕ} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' → + c.input.StartInvariant → (∀ i, (c.work i).StartInvariant) → c.output.StartInvariant → + c'.input.StartInvariant ∧ (∀ i, (c'.work i).StartInvariant) ∧ + c'.output.StartInvariant := by + intro t c c' hreach + induction hreach with + | zero => exact fun hi hw ho => ⟨hi, hw, ho⟩ + | step hstep _ ih => + intro hi hw ho + obtain ⟨hi', hw', ho'⟩ := Tape.StartInvariant.step _ hstep hi hw ho + exact ih hi' hw' ho' + +/-- A fully parked tape frame passes through a combinator seam unchanged — +the boundary obligation of `TM.seqTM_hoareTime` in the common case where every +tape is parked on both sides of the seam. -/ +theorem parked_transition {n : ℕ} {inp₀ out₀ : Tape} {W : Fin n → Tape} + (hinp : Parked inp₀) (hW : ∀ i, Parked (W i)) (hout : Parked out₀) : + transitionInput inp₀ = inp₀ ∧ + (fun i => transitionTape (W i)) = W ∧ transitionTape out₀ = out₀ := + ⟨transitionInput_eq_self hinp.read_ne_start, + funext fun i => transitionTape_eq_self (hW i).read_ne_start, + transitionTape_eq_self hout.read_ne_start⟩ + +/-- **Chaining two fully-determined phases.** When each phase pins down the +entire tape family and every intermediate tape is parked, sequential +composition needs no boundary reasoning at all. -/ +theorem seqTM_det {n : ℕ} (m₁ m₂ : TM n) {inp₀ out₀ : Tape} {W₀ W₁ W₂ : Fin n → Tape} + {b₁ b₂ : ℕ} (hinp : Parked inp₀) (hout : Parked out₀) (hW₁ : ∀ i, Parked (W₁ i)) + (h₁ : m₁.HoareTime (fun inp work out => inp = inp₀ ∧ work = W₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ work = W₁ ∧ out = out₀) b₁) + (h₂ : m₂.HoareTime (fun inp work out => inp = inp₀ ∧ work = W₁ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ work = W₂ ∧ out = out₀) b₂) : + (seqTM m₁ m₂).HoareTime + (fun inp work out => inp = inp₀ ∧ work = W₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ work = W₂ ∧ out = out₀) + (b₁ + 1 + b₂) := by + refine seqTM_hoareTime m₁ m₂ h₁ ?_ h₂ + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact parked_transition hinp hW₁ hout + +/-- A machine that never moves its real input head off a parked position: its +transition function always returns `idleDir` for the input tape. Machines that +read their input from a work tape instead (`TM.retargetInput` and everything +built on it) satisfy this. -/ +def IdlesInput {n : ℕ} (tm : TM n) : Prop := + ∀ q iHead wHeads oHead, (tm.δ q iHead wHeads oHead).2.2.2.1 = idleDir iHead + +/-- An input-idling machine preserves a parked real input tape exactly, for +any number of steps. -/ +theorem reachesIn_input_eq_of_idlesInput {n : ℕ} {tm : TM n} (hidle : IdlesInput tm) : + ∀ {t : ℕ} {c c' : Cfg n tm.Q}, tm.reachesIn t c c' → Parked c.input → + c'.input = c.input := by + intro t + induction t with + | zero => + intro c c' hreach _ + cases hreach + rfl + | succ t ih => + intro c c' hreach hp + cases hreach with + | step hstep hrest => + next c'' => + have hc'' : c''.input = c.input := by + simp only [TM.step] at hstep + split at hstep + · simp at hstep + · simp only [Option.some.injEq] at hstep + rw [← hstep] + show c.input.move _ = c.input + rw [hidle, hp.move_idle] + rw [ih hrest (by rw [hc'']; exact hp), hc''] + +/-- The blank tape satisfies the left-marker invariant. -/ +theorem startInvariant_initNil : Tape.StartInvariant (Tape.init ([] : List Γ)) := by + refine ⟨Tape.init_cells_zero [], fun j hj => ?_⟩ + rw [show j = (j - 1) + 1 from by omega, Tape.init_cells_ge [] (j - 1) (by simp)] + decide + +/-- A tape initialized with a Boolean string satisfies the left-marker +invariant: `Γ.ofBool` never produces `▷`. -/ +theorem startInvariant_initOfBool (y : List Bool) : + Tape.StartInvariant (Tape.init (y.map Γ.ofBool)) := by + refine ⟨Tape.init_cells_zero _, fun j hj => ?_⟩ + have hj1 : j = (j - 1) + 1 := by omega + by_cases hlt : j - 1 < y.length + · rw [hj1, Tape.init_ofBool_cells_lt y (j - 1) hlt] + cases y[j - 1]'hlt <;> decide + · rw [hj1, Tape.init_ofBool_cells_ge y (j - 1) (by omega)] + decide + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean b/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean new file mode 100644 index 00000000..a776b670 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/CopyToVirtualInput.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Combinators.RetargetCompute +public import Complexitylib.Models.TuringMachine.Subroutines.ClearWork +public import Complexitylib.Models.TuringMachine.Subroutines.CopyWorkOutput +public import Complexitylib.Models.TuringMachine.Subroutines.ResetTapes + +/-! +# Copying a value into virtual-input shape + +`TM.retargetInputStartedCfg` expects the virtual-input work tape in the exact +shape `(Tape.init (y.map Γ.ofBool)).move Dir3.right` — head parked at cell `1`. +A value produced elsewhere lands with its head *past* its content, so one more +rewind closes the gap. + +## Main results + +- `TM.copyToVirtualInputTM` — move a value into virtual-input position +- `TM.copyToVirtualInputTM_hoareTime` — its contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Copy the value held at `src` into `dst`, then rewind `dst` to cell `1` — +the exact shape `retargetInputStartedCfg` expects of a virtual input. Every +tape besides `src`/`dst`, the real input, and the real output are held at +fixed `Parked` values throughout. -/ +theorem copyToVirtualInput_hoareTime {n : ℕ} (src dst : Fin n) (hne : src ≠ dst) + (x : List Bool) (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hsrcHead : (work₀ src).head = 1) (hsrcOut : (work₀ src).HasOutput x) + (hsrcParked : Parked (work₀ src)) + (hdst : work₀ dst = (Tape.init []).move Dir3.right) + (hinp : Parked inp₀) (hout : Parked out₀) + (hother : ∀ i, i ≠ src → i ≠ dst → Parked (work₀ i)) : + (seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + work dst = (Tape.init (x.map Γ.ofBool)).move Dir3.right ∧ + (work src).cells = (work₀ src).cells ∧ + (work src).head = x.length + 1 ∧ + (∀ i, i ≠ src → i ≠ dst → work i = work₀ i)) + (2 * x.length + 5) := by + have hP : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape) + (inp' : Tape) (work' : Fin n → Tape) (out' : Tape), + (inp = inp₀ ∧ out = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work i = work₀ i) → + (work' src).cells = (work₀ src).cells → + (work' src).head = x.length + 1 → + (work' src).HasOutput x → + (work' dst).HasBinaryPrefix x → + (work' dst).cells 0 = Γ.start → + inp' = inp → out' = out → + (∀ i, i ≠ src → i ≠ dst → work' i = work i) → + (inp' = inp₀ ∧ out' = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work' i = work₀ i) := by + rintro inp work out inp' work' out' ⟨rfl, rfl, hrest⟩ _ _ _ _ _ rfl rfl hkeep + exact ⟨rfl, rfl, fun i hisrc hidst => (hkeep i hisrc hidst).trans (hrest i hisrc hidst)⟩ + have hcopy := copyWorkToWorkTM_hoareTime_frame_of_hasOutput src dst hne x (work₀ src) hP + have hpre_imp : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape), + (inp = inp₀ ∧ work = work₀ ∧ out = out₀) → + (work src = work₀ src ∧ (work₀ src).head = 1 ∧ (work₀ src).HasOutput x ∧ + work dst = (Tape.init []).move Dir3.right ∧ + inp.read ≠ Γ.start ∧ out.read ≠ Γ.start ∧ 1 ≤ out.head ∧ + (∀ i, i ≠ src → i ≠ dst → (work i).read ≠ Γ.start ∧ 1 ≤ (work i).head) ∧ + (inp = inp₀ ∧ out = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work i = work₀ i)) := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨rfl, hsrcHead, hsrcOut, hdst, hinp.read_ne_start, hout.read_ne_start, hout.1, + fun i hisrc hidst => ⟨(hother i hisrc hidst).read_ne_start, (hother i hisrc hidst).1⟩, + rfl, rfl, fun i _ _ => rfl⟩ + have h₁ := hcopy.weaken_pre hpre_imp + have hP2 : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape) + (inp' : Tape) (work' : Fin n → Tape) (out' : Tape), + ((work dst).cells = (Tape.init (x.map Γ.ofBool)).cells ∧ + (work src).cells = (work₀ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inp₀ ∧ out = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work i = work₀ i) → + (work' dst).cells = (work dst).cells → + (work' dst).head = 1 → + (∀ i, i ≠ dst → work' i = work i) → + inp' = inp → + out'.cells = out.cells → + out'.head = out.head → + ((work' dst).cells = (Tape.init (x.map Γ.ofBool)).cells ∧ + (work' src).cells = (work₀ src).cells ∧ + (work' src).head = x.length + 1 ∧ + inp' = inp₀ ∧ out' = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work' i = work₀ i) := by + rintro inp work out inp' work' out' ⟨hcellsP, hsc, hsh, rfl, rfl, hrest⟩ hcells' _ hkeep rfl + hout'c hout'h + refine ⟨hcells'.trans hcellsP, ?_, ?_, rfl, Tape.ext hout'h hout'c, + fun i hisrc hidst => (hkeep i hidst).trans (hrest i hisrc hidst)⟩ + · rw [hkeep src hne]; exact hsc + · rw [hkeep src hne]; exact hsh + have h₂ := rewindWorkTM_hoareTime_frame (n := n) dst (x.length + 1) + (P := fun inp work out => + (work dst).cells = (Tape.init (x.map Γ.ofBool)).cells ∧ + (work src).cells = (work₀ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inp₀ ∧ out = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work i = work₀ i) hP2 + have hcomb : (seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => (work dst).head = 1 ∧ + (work dst).cells = (Tape.init (x.map Γ.ofBool)).cells ∧ + (work src).cells = (work₀ src).cells ∧ + (work src).head = x.length + 1 ∧ + inp = inp₀ ∧ out = out₀ ∧ ∀ i, i ≠ src → i ≠ dst → work i = work₀ i) + (2 * x.length + 5) := by + refine (seqTM_hoareTime (copyWorkToWorkTM src dst) (rewindWorkTM dst) h₁ ?_ h₂).mono_bound + (by omega) + rintro inp work out ⟨hcells, hhead, hout_, hprefix, hcell0, hPinp, hPout, hPrest⟩ + have hread_src : (work src).read ≠ Γ.start := by + show (work src).cells (work src).head ≠ Γ.start + rw [hhead, hcells] + exact hsrcParked.2 (x.length + 1) (by omega) + have hread_dst : (work dst).read ≠ Γ.start := by + rw [hprefix.read_blank]; decide + have hread_other : ∀ i, i ≠ dst → (work i).read ≠ Γ.start ∧ (work i).head ≥ 1 := by + intro i hidst + by_cases hisrc : i = src + · subst hisrc; exact ⟨hread_src, by omega⟩ + · rw [hPrest i hisrc hidst] + exact ⟨(hother i hisrc hidst).read_ne_start, (hother i hisrc hidst).1⟩ + have hinp_ns : inp.read ≠ Γ.start := by rw [hPinp]; exact hinp.read_ne_start + have hout_ns : out.read ≠ Γ.start := by rw [hPout]; exact hout.read_ne_start + have ht1 : transitionInput inp = inp := transitionInput_eq_self hinp_ns + have ht2 : (fun i => transitionTape (work i)) = work := + funext fun i => by + by_cases hidst : i = dst + · subst hidst; exact transitionTape_eq_self hread_dst + · exact transitionTape_eq_self (hread_other i hidst).1 + have ht3 : transitionTape out = out := transitionTape_eq_self hout_ns + rw [ht1, ht2, ht3] + have hcellsP : (work dst).cells = (Tape.init (x.map Γ.ofBool)).cells := + hprefix.cells_eq_init hcell0 + refine ⟨hcell0, ?_, le_of_eq hprefix.1, hinp_ns, hout_ns, ?_, + fun i hidst => hread_other i hidst, + hcellsP, hcells, hhead, hPinp, hPout, hPrest⟩ + · intro j hj + have hj1 : j - 1 + 1 = j := by omega + by_cases hle : j ≤ x.length + · rw [← hj1, hprefix.2.1 (j - 1) (by omega)] + cases x[j - 1]'(by omega) <;> decide + · rw [← hj1, hprefix.2.2 (j - 1) (by omega)] + decide + · rw [hPout]; exact hout.1 + exact hcomb.strengthen_post (by + rintro inp work out ⟨hhead1, hcellsP, hsc, hsh, hPinp, hPout, hPrest⟩ + exact ⟨hPinp, hPout, Tape.ext hhead1 hcellsP, hsc, hsh, hPrest⟩) + +/-- Copy a work tape's value into another and park the result at cell `1`. -/ +def copyToVirtualInputTM {n : ℕ} (src dst : Fin n) : TM n := + seqTM (copyWorkToWorkTM src dst) (rewindWorkTM dst) + +/-- **The copy, with the whole tape family pinned down.** The source keeps its +cells but ends with its head past the copied value; the destination holds the +value parked at cell `1`; nothing else moves. This determined form is what +`TM.seqTM_det` chains. -/ +theorem copyToVirtualInputTM_hoareTime {n : ℕ} (src dst : Fin n) (hne : src ≠ dst) + (x : List Bool) (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hsrcHead : (work₀ src).head = 1) (hsrcOut : (work₀ src).HasOutput x) + (hsrcParked : Parked (work₀ src)) + (hdst : work₀ dst = (Tape.init []).move Dir3.right) + (hinp : Parked inp₀) (hout : Parked out₀) + (hother : ∀ i, i ≠ src → i ≠ dst → Parked (work₀ i)) : + (copyToVirtualInputTM src dst).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ + work = Function.update (Function.update work₀ dst + ((Tape.init (x.map Γ.ofBool)).move Dir3.right)) + src (⟨x.length + 1, (work₀ src).cells⟩ : Tape) ∧ + out = out₀) + (2 * x.length + 5) := by + refine (copyToVirtualInput_hoareTime src dst hne x inp₀ work₀ out₀ hsrcHead hsrcOut + hsrcParked hdst hinp hout hother).strengthen_post ?_ + rintro inp work out ⟨hi, ho, hd, hsc, hsh, hrest⟩ + refine ⟨hi, ?_, ho⟩ + funext j + by_cases hjs : j = src + · rw [hjs, Function.update_self] + exact Tape.ext (hjs ▸ hsh) (hjs ▸ hsc) + · rw [Function.update_of_ne hjs] + by_cases hjd : j = dst + · rw [hjd, Function.update_self] + exact hjd ▸ hd + · rw [Function.update_of_ne hjd] + exact hrest j hjs hjd + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean b/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean new file mode 100644 index 00000000..fc4782d4 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/MoveLeftStep.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Subroutines.WipeStep + +/-! +# Moving left unconditionally + +Before scratch tapes can be wiped (`TM.wipeStepTM` scans rightward), every head +needs to be at a *known* position. The `▷` marker at cell `0` is immutable, so +moving left far enough always reaches it whatever the content: +`TM.moveLeftStepTM`, run enough times, is a content-agnostic bulk rewind for a +whole list of tapes, exactly as `TM.wipeStepTM` is a content-agnostic bulk wipe. + +## Main results + +- `TM.moveLeftStepTM` — move every targeted tape one cell left +- `TM.moveLeftStepTM_hoareTime` — its one-step contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Unconditional write-then-move collapses to a pure move whenever the +tape's only possible `▷` is at cell `0` — regardless of whether the head is +currently on it. -/ +theorem writeAndMove_readBack_of_startInvariant (t : Tape) (h : Tape.StartInvariant t) + (d : Dir3) : t.writeAndMove (readBackWrite t.read) d = t.move d := by + by_cases hh : t.head = 0 + · show (t.write _).move d = t.move d + congr 1 + rw [Tape.write, if_pos hh] + · exact writeAndMove_readBack t (h.read_ne_start (by omega)) d + +/-- One unconditional step: every work tape named in `targets` moves left +(bouncing off `▷` via `moveLeftDir`); every other work tape, the input, and +the output are held by `readBackWrite`/`idleDir`. Content is always preserved. -/ +def moveLeftStepTM {n : ℕ} (targets : List (Fin n)) : TM n where + Q := WipeStepPhase + qstart := .running + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .running => + (.done, + fun i => readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i ∈ targets then moveLeftDir (wHeads i) else idleDir (wHeads i), + idleDir oHead) + | .done => allIdle .done iHead wHeads oHead + δ_right_of_start := by + intro state iHead wHeads oHead + match state with + | .running => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + · exact moveLeftDir_right_of_start hi + · exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **`moveLeftStepTM`'s exact one-step Hoare contract.** Targeted tapes need +only `StartInvariant` (their `▷`, if any, is at cell `0` — true regardless of +current head position); every other work tape, the input, and the output +must be `Parked`. -/ +theorem moveLeftStepTM_hoareTime {n : ℕ} (targets : List (Fin n)) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : Parked inp₀) (hout : Parked out₀) + (htarget : ∀ i, i ∈ targets → Tape.StartInvariant (work₀ i)) + (hother : ∀ i, i ∉ targets → Parked (work₀ i)) : + (moveLeftStepTM targets).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + ∀ i, work i = if i ∈ targets then (work₀ i).move (moveLeftDir (work₀ i).read) + else work₀ i) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨(⟨WipeStepPhase.done, + inp.move (idleDir inp.read), + (fun i => if i ∈ targets then (work i).move (moveLeftDir (work i).read) + else (work i).writeAndMove (readBackWrite (work i).read) (idleDir (work i).read)), + out.writeAndMove (readBackWrite out.read) (idleDir out.read)⟩ : + Cfg n (moveLeftStepTM targets).Q), + 1, le_refl 1, ?_, rfl, hinp.move_idle, hout.writeAndMove_readBack_idle, fun i => ?_⟩ + · refine TM.reachesIn.step ?_ .zero + simp only [TM.step, moveLeftStepTM, + if_neg (show WipeStepPhase.running ≠ WipeStepPhase.done by decide)] + congr 1 + congr 1 + funext i + by_cases hi : i ∈ targets + · simp only [if_pos hi] + exact writeAndMove_readBack_of_startInvariant (work i) (htarget i hi) _ + · simp only [if_neg hi] + · dsimp only + split + · rfl + · next hi => exact (hother i hi).writeAndMove_readBack_idle + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean b/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean new file mode 100644 index 00000000..07c30b0f --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/ParkAll.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep + +/-! +# Parking every tape at once + +Rewinding tapes one at a time needs every tape *not* being rewound to be +`Parked` already — a tape still reading `▷` would bounce to cell `1` as a side +effect. One `TM.skipTM` step with no target achieves that uniformly: from +`Tape.StartInvariant` alone, cell-`0` tapes bounce to cell `1` and parked tapes +stay put. + +## Main results + +- `TM.parkAll_hoareTime` — one step parks every tape +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- One idle step on a `StartInvariant` tape is exactly a bounce off `▷` if it +was there, and otherwise a no-op: the resulting head is `max t.head 1`. -/ +theorem move_idleDir_eq_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + t.move (idleDir t.read) = ⟨max t.head 1, t.cells⟩ := by + by_cases hh : t.read = Γ.start + · have hh0 : t.head = 0 := by + by_contra hc + exact (h.2 t.head (by omega)) hh + rw [idleDir, if_pos hh] + refine Tape.ext ?_ (Tape.move_cells t Dir3.right) + show t.head + 1 = max t.head 1 + omega + · have hh0 : t.head ≠ 0 := fun hc => hh (by rw [Tape.read, hc]; exact h.1) + rw [idleDir, if_neg hh] + show t = ⟨max t.head 1, t.cells⟩ + have : max t.head 1 = t.head := by omega + rw [this] + +/-- One idle step parks a `StartInvariant` tape: bounces it off `▷` if it was +there, and otherwise leaves it exactly as it was. -/ +theorem parked_move_idleDir_of_startInvariant {t : Tape} (h : Tape.StartInvariant t) : + Parked (t.move (idleDir t.read)) ∧ (t.move (idleDir t.read)).cells = t.cells := by + rw [move_idleDir_eq_of_startInvariant h] + exact ⟨⟨le_max_right _ _, fun j hj => h.2 j hj⟩, rfl⟩ + +/-- **Parking every tape at once.** From tapes satisfying only +`StartInvariant`, one `skipTM` step brings every one of them to `Parked`, +preserving all cell contents exactly. -/ +theorem parkAll_hoareTime {n : ℕ} (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : Tape.StartInvariant inp₀) (hwork : ∀ i, Tape.StartInvariant (work₀ i)) + (hout : Tape.StartInvariant out₀) : + (skipTM (n := n)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = (⟨max inp₀.head 1, inp₀.cells⟩ : Tape) ∧ + (∀ i, work i = (⟨max (work₀ i).head 1, (work₀ i).cells⟩ : Tape)) ∧ + out = (⟨max out₀.head 1, out₀.cells⟩ : Tape)) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨⟨(skipTM (n := n)).qhalt, + inp.move (idleDir inp.read), + fun i => (work i).move (idleDir (work i).read), + out.move (idleDir out.read)⟩, + 1, le_refl 1, ?_, rfl, ?_, ?_, ?_⟩ + · refine TM.reachesIn.step ?_ .zero + simp only [TM.step, skipTM, + if_neg (show BumpPhase.go ≠ BumpPhase.done by decide), + writeAndMove_readBack_of_startInvariant out hout] + congr 2 + funext i + exact writeAndMove_readBack_of_startInvariant (work i) (hwork i) _ + · exact move_idleDir_eq_of_startInvariant hinp + · exact fun i => move_idleDir_eq_of_startInvariant (hwork i) + · exact move_idleDir_eq_of_startInvariant hout + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean b/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean new file mode 100644 index 00000000..0d19c351 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/ResetTapes.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Subroutines.MoveLeftStep +public import Complexitylib.Models.TuringMachine.Subroutines.RewindList +public import Complexitylib.Models.TuringMachine.Subroutines.WipeLoop + +/-! +# Resetting a list of tapes to blank, content-agnostically + +The full reset an opaque machine's scratch needs between calls: park everything +(`TM.parkAll_hoareTime`), rewind every targeted tape to cell `1` +(`TM.rewindList_hoareTime`), then wipe `H` cells forward from there +(`TM.wipeLoop_hoareTime`). A fuel register disjoint from the targets drives the +wipe and is left exactly as it started. + +## Main results + +- `TM.resetTapesTM` — the composite reset machine +- `TM.resetTapesTM_hoareTime` / `TM.resetTapesTM_hoareTime_of_bounds` — its contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- **Resetting a list of tapes.** Regardless of their current content or head +position (bounded by `H`), every tape in `targets` ends up blanked from cell +`1` through cell `H`, with its tail beyond cell `H` untouched; the fuel +register `r` (disjoint from `targets`) and every other tape are exactly as +they were. -/ +theorem resetTapes_hoareTime {n : ℕ} (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r ∉ targets) (H : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinpSI : Tape.StartInvariant inp₀) (hinpP : Parked inp₀) + (hout0 : out₀ = (Tape.init []).move Dir3.right) + (hworkSI : ∀ j, j ≠ r → Tape.StartInvariant (work₀ j)) + (htargetHead : ∀ j, j ∈ targets → (work₀ j).head ≤ H) + (hworkR : work₀ r = regTape H) + (hother : ∀ j, j ≠ r → j ∉ targets → Parked (work₀ j)) : + (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = wipedTape (⟨1, (work₀ j).cells⟩ : Tape) H) ∧ + work r = regTape H ∧ + (∀ j, j ≠ r → j ∉ targets → work j = work₀ j)) + (targets.length * (H + 4) + H * 4 + 8) := by + have hregParked : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i ≠ Γ.start + simp only [regCells]; split + · omega + · split <;> decide⟩ + have houtSI : Tape.StartInvariant out₀ := by + rw [hout0] + refine ⟨?_, fun j hj => ?_⟩ + · rw [Tape.move_cells]; exact Tape.init_cells_zero [] + · rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + decide + have houtP : Parked out₀ := by rw [hout0]; exact parked_parkedBlank + have hworkSI' : ∀ j, Tape.StartInvariant (work₀ j) := by + intro j + by_cases hjr : j = r + · subst hjr; rw [hworkR]; exact ⟨rfl, hregParked.2⟩ + · exact hworkSI j hjr + set workA : Fin n → Tape := fun j => (⟨max (work₀ j).head 1, (work₀ j).cells⟩ : Tape) + with hworkA + have hAP : ∀ j, Parked (workA j) := fun j => ⟨le_max_right _ _, fun i hi => (hworkSI' j).2 i hi⟩ + have hAtarget : ∀ j, j ∈ targets → (workA j).cells 0 = Γ.start ∧ (workA j).head ≤ H + 1 := by + intro j hj + refine ⟨(hworkSI' j).1, ?_⟩ + show max (work₀ j).head 1 ≤ H + 1 + have := htargetHead j hj + omega + have hA := parkAll_hoareTime inp₀ work₀ out₀ hinpSI hworkSI' houtSI + have hinpAeq : (⟨max inp₀.head 1, inp₀.cells⟩ : Tape) = inp₀ := + Tape.ext (by show max inp₀.head 1 = inp₀.head; have := hinpP.1; omega) rfl + have houtAeq : (⟨max out₀.head 1, out₀.cells⟩ : Tape) = out₀ := + Tape.ext (by show max out₀.head 1 = out₀.head; have := houtP.1; omega) rfl + have hApost_imp : ∀ inp work out, + (inp = (⟨max inp₀.head 1, inp₀.cells⟩ : Tape) ∧ + (∀ i, work i = workA i) ∧ out = (⟨max out₀.head 1, out₀.cells⟩ : Tape)) → + (inp = inp₀ ∧ work = workA ∧ out = out₀) := by + rintro inp work out ⟨hi, hw, ho⟩ + exact ⟨hi.trans hinpAeq, funext hw, ho.trans houtAeq⟩ + have hA' := hA.strengthen_post hApost_imp + have hB0 := rewindList_hoareTime targets hnodup (H + 1) inp₀ workA out₀ hinpP houtP hAP hAtarget + have hB : (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = (⟨1, (work₀ j).cells⟩ : Tape)) ∧ + (∀ j, j ∉ targets → work j = workA j)) + (1 + 1 + targets.length * ((H + 1) + 3) + 1) := by + refine seqTM_hoareTime skipTM (bigSeqTM (targets.map rewindWorkTM)) hA' ?_ hB0 + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨transitionInput_eq_self hinpP.read_ne_start, ?_, + transitionTape_eq_self houtP.read_ne_start⟩ + funext i + exact transitionTape_eq_self (hAP i).read_ne_start + set workC : Fin n → Tape := fun j => if j ∈ targets then (⟨1, (work₀ j).cells⟩ : Tape) + else work₀ j with hworkC + have hCother : ∀ j, j ≠ r → Parked (workC j) := by + intro j hjr + rw [hworkC] + dsimp only + split + · next hjt => exact ⟨le_refl 1, (hworkSI' j).2⟩ + · next hjt => exact hother j hjr hjt + have hC0 := wipeLoop_hoareTime targets r hr H inp₀ workC hinpP hCother + have hworkeq : ∀ (work : Fin n → Tape), + (∀ j, j ∈ targets → work j = (⟨1, (work₀ j).cells⟩ : Tape)) → + (∀ j, j ∉ targets → work j = workA j) → + work = Function.update workC r (regTape H) := by + intro work hts hnts + funext j + by_cases hjr : j = r + · rw [hjr, Function.update_self] + rw [hnts r hr] + show (⟨max (work₀ r).head 1, (work₀ r).cells⟩ : Tape) = regTape H + rw [hworkR] + exact Tape.ext (by show max 1 1 = 1; omega) (by rw [regT_cells]) + · rw [Function.update_of_ne hjr] + by_cases hjt : j ∈ targets + · rw [hts j hjt, hworkC]; simp [hjt] + · rw [hnts j hjt, hworkC] + simp only [hjt, if_false] + exact Tape.ext (by + show max (work₀ j).head 1 = (work₀ j).head + have := (hother j hjr hjt).1 + omega) rfl + have hread : ∀ (work : Fin n → Tape), + (∀ j, j ∈ targets → work j = (⟨1, (work₀ j).cells⟩ : Tape)) → + (∀ j, j ∉ targets → work j = workA j) → + ∀ j, (work j).read ≠ Γ.start := by + intro work hts hnts j + by_cases hjt : j ∈ targets + · rw [hts j hjt] + exact (hworkSI' j).2 1 le_rfl + · rw [hnts j hjt] + exact (hAP j).read_ne_start + have htrans : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape), + (inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = (⟨1, (work₀ j).cells⟩ : Tape)) ∧ + (∀ j, j ∉ targets → work j = workA j)) → + transitionInput inp = inp₀ ∧ + (fun i => transitionTape (work i)) = Function.update workC r (regTape H) ∧ + transitionTape out = (Tape.init []).move Dir3.right := by + rintro inp work out ⟨hi, ho, hts, hnts⟩ + refine ⟨by rw [hi]; exact transitionInput_eq_self hinpP.read_ne_start, + ?_, by rw [ho, transitionTape_eq_self houtP.read_ne_start]; exact hout0⟩ + rw [← hworkeq work hts hnts] + funext j + exact transitionTape_eq_self (hread work hts hnts j) + have hFull := seqTM_hoareTime (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r) hB htrans hC0 + have hpost_imp : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape), + (inp = inp₀ ∧ + work = Function.update (fun j => if j ∈ targets then wipedTape (workC j) H else workC j) + r (regTape H) ∧ + out = (Tape.init []).move Dir3.right) → + (inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = wipedTape (⟨1, (work₀ j).cells⟩ : Tape) H) ∧ + work r = regTape H ∧ + (∀ j, j ≠ r → j ∉ targets → work j = work₀ j)) := by + rintro inp work out ⟨hi, hw, ho⟩ + refine ⟨hi, ho.trans hout0.symm, fun j hjt => ?_, ?_, fun j hjr hjt => ?_⟩ + · rw [hw, Function.update_of_ne (fun h => hr (by rw [h] at hjt; exact hjt)), + if_pos hjt, hworkC] + simp [hjt] + · rw [hw, Function.update_self] + · rw [hw, Function.update_of_ne hjr, hworkC] + simp [hjt] + refine (hFull.strengthen_post hpost_imp).mono_bound ?_ + ring_nf + omega + +/-- The composite reset machine: park everything, rewind the targets, wipe +`H` cells forward, then rewind the targets again. -/ +def resetTapesTM {n : ℕ} (targets : List (Fin n)) (r : Fin n) : TM n := + seqTM (seqTM (seqTM skipTM (bigSeqTM (targets.map rewindWorkTM))) + (forRegTM (wipeStepTM targets) r)) + (bigSeqTM (targets.map rewindWorkTM)) + +/-- **The full reset.** Every tape in `targets` whose content is confined to +cells `1 … H` — no matter *where* in that range, and no matter where its head +currently sits — ends up literally blank and parked at cell `1`. The fuel +register `r` and all other tapes are returned exactly as they were. -/ +theorem resetTapesTM_hoareTime {n : ℕ} (targets : List (Fin n)) (hnodup : targets.Nodup) + (r : Fin n) (hr : r ∉ targets) (H : ℕ) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinpSI : Tape.StartInvariant inp₀) (hinpP : Parked inp₀) + (hout0 : out₀ = (Tape.init []).move Dir3.right) + (hworkSI : ∀ j, j ≠ r → Tape.StartInvariant (work₀ j)) + (htargetHead : ∀ j, j ∈ targets → (work₀ j).head ≤ H) + (htargetFar : ∀ j, j ∈ targets → ∀ i, H < i → (work₀ j).cells i = Γ.blank) + (hworkR : work₀ r = regTape H) + (hother : ∀ j, j ≠ r → j ∉ targets → Parked (work₀ j)) : + (resetTapesTM targets r).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = (Tape.init []).move Dir3.right) ∧ + work r = regTape H ∧ + (∀ j, j ≠ r → j ∉ targets → work j = work₀ j)) + (targets.length * (H + 4) + H * 4 + 8 + 1 + (targets.length * (H + 4) + 1)) := by + have houtP : Parked out₀ := by rw [hout0]; exact parked_parkedBlank + have hregParked : Parked (regTape H) := + ⟨le_refl 1, fun i hi => by + show regCells H i ≠ Γ.start + simp only [regCells]; split + · omega + · split <;> decide⟩ + -- the wipe's exact effect on a targeted tape, spelled out + have hwiped : ∀ j, j ∈ targets → + wipedTape (⟨1, (work₀ j).cells⟩ : Tape) H = (⟨H + 1, (Tape.init []).cells⟩ : Tape) := by + intro j hj + refine wipedTape_eq_blank H rfl ?_ (fun i hi => htargetFar j hj i hi) + exact (hworkSI j (fun h => hr (h ▸ hj))).1 + -- the tape family after the wipe phase + set workD : Fin n → Tape := fun j => + if j ∈ targets then (⟨H + 1, (Tape.init []).cells⟩ : Tape) + else if j = r then regTape H else work₀ j with hworkD + have hDP : ∀ j, Parked (workD j) := by + intro j + rw [hworkD] + dsimp only + split + · exact ⟨show 1 ≤ H + 1 by omega, + fun i hi => by rw [initNil_cells, if_neg (by omega)]; decide⟩ + · split + · exact hregParked + · next hjt hjr => exact hother j hjr hjt + have hDtarget : ∀ j, j ∈ targets → + (workD j).cells 0 = Γ.start ∧ (workD j).head ≤ H + 1 := by + intro j hj + rw [hworkD] + simp only [if_pos hj] + exact ⟨by rw [initNil_cells, if_pos rfl], le_refl _⟩ + have hfirst := resetTapes_hoareTime targets hnodup r hr H inp₀ work₀ out₀ hinpSI hinpP + hout0 hworkSI htargetHead hworkR hother + have hsecond := rewindList_hoareTime targets hnodup (H + 1) inp₀ workD out₀ hinpP houtP + hDP hDtarget + refine seqTM_hoareTime _ _ hfirst ?_ hsecond |>.strengthen_post ?_ + · -- the boundary: everything is parked, so the seam is the identity + rintro inp work out ⟨hi, ho, hts, hR, hrest⟩ + have hworkD_eq : work = workD := by + funext j + by_cases hjt : j ∈ targets + · rw [hts j hjt, hwiped j hjt, hworkD]; simp [hjt] + · by_cases hjr : j = r + · rw [hjr, hR, hworkD]; simp [hr] + · rw [hrest j hjr hjt, hworkD]; simp [hjt, hjr] + subst hworkD_eq + refine ⟨by rw [hi]; exact transitionInput_eq_self hinpP.read_ne_start, ?_, + by rw [ho]; exact transitionTape_eq_self houtP.read_ne_start⟩ + funext j + exact transitionTape_eq_self (hDP j).read_ne_start + · rintro inp work out ⟨hi, ho, hts, hnts⟩ + refine ⟨hi, ho, fun j hj => ?_, ?_, fun j hjr hjt => ?_⟩ + · rw [hts j hj, hworkD] + simp only [if_pos hj] + rfl + · rw [hnts r hr, hworkD] + simp [hr] + · rw [hnts j hjt, hworkD] + simp [hjt, hjr] + +/-- **The reset, keyed on bounds rather than on a named tape family.** The +tapes an opaque machine leaves behind are only known through bounds, never as +a closed form, so this is the shape the loop body actually needs: the exact +starting family is instantiated inside the proof. -/ +theorem resetTapesTM_hoareTime_of_bounds {n : ℕ} (targets : List (Fin n)) + (hnodup : targets.Nodup) (r : Fin n) (hr : r ∉ targets) (H : ℕ) + (inp₀ : Tape) (extras : Fin n → Tape) (out₀ : Tape) + (hinpSI : Tape.StartInvariant inp₀) (hinpP : Parked inp₀) + (hout0 : out₀ = (Tape.init []).move Dir3.right) + (hextraP : ∀ j, j ≠ r → j ∉ targets → Parked (extras j)) : + (resetTapesTM targets r).HoareTime + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ≠ r → Tape.StartInvariant (work j)) ∧ + (∀ j, j ∈ targets → (work j).head ≤ H ∧ ∀ i, H < i → (work j).cells i = Γ.blank) ∧ + work r = regTape H ∧ + (∀ j, j ≠ r → j ∉ targets → work j = extras j)) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = (Tape.init []).move Dir3.right) ∧ + work r = regTape H ∧ + (∀ j, j ≠ r → j ∉ targets → work j = extras j)) + (targets.length * (H + 4) + H * 4 + 8 + 1 + (targets.length * (H + 4) + 1)) := by + intro inp work out hpre + obtain ⟨hi, ho, hSI, hbnd, hR, hext⟩ := hpre + rw [hi, ho] + obtain ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', hrest⟩ := + resetTapesTM_hoareTime targets hnodup r hr H inp₀ work out₀ hinpSI hinpP hout0 hSI + (fun j hj => (hbnd j hj).1) (fun j hj i hii => (hbnd j hj).2 i hii) hR + (fun j hjr hjt => by rw [hext j hjr hjt]; exact hextraP j hjr hjt) + inp₀ work out₀ ⟨rfl, rfl, rfl⟩ + exact ⟨c', t, ht, hreach, hhalt, hi', ho', hts, hR', + fun j hjr hjt => (hrest j hjr hjt).trans (hext j hjr hjt)⟩ + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean b/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean new file mode 100644 index 00000000..2147e196 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/RewindList.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Mathlib.Tactic.Ring +public import Complexitylib.Models.TuringMachine.Registers.EmitSeq +public import Complexitylib.Models.TuringMachine.Subroutines +public import Complexitylib.Models.TuringMachine.Subroutines.ParkAll + +/-! +# Rewinding a list of tapes, one at a time + +Rewinding cannot be done in one uniform pass the way wiping can: +`TM.rewindWorkTM` bounces at `▷` rather than saturating there, so moving +everyone left the same number of times oscillates. Doing it one tape at a time +via `TM.bigSeqTM` works once every tape has been parked once +(`TM.parkAll_hoareTime`). + +## Main results + +- `TM.rewindList_hoareTime` — rewind every targeted tape to cell `1` +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- **Rewinding a list of tapes, one at a time.** Given a uniform head bound +`B` and that *every* tape (not just the targets) is already `Parked` — the +state after `parkAll_hoareTime` — sequentially rewinding each named tape +lands it at cell `1` with its cells unchanged, leaving every other tape +(targeted-but-not-yet-reached, or never targeted) exactly as it was. -/ +theorem rewindList_hoareTime {n : ℕ} : + ∀ (targets : List (Fin n)), targets.Nodup → + ∀ (B : ℕ) (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape), + Parked inp₀ → Parked out₀ → (∀ j, Parked (work₀ j)) → + (∀ j, j ∈ targets → (work₀ j).cells 0 = Γ.start ∧ (work₀ j).head ≤ B) → + (bigSeqTM (targets.map rewindWorkTM)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ targets → work j = ⟨1, (work₀ j).cells⟩) ∧ + (∀ j, j ∉ targets → work j = work₀ j)) + (targets.length * (B + 3) + 1) := by + intro targets + induction targets with + | nil => + intro _ B inp₀ work₀ out₀ hinp hout hwork _ + simp only [List.map_nil, List.length_nil, Nat.zero_mul, Nat.zero_add] + refine (skipTM_hoareTime_frame inp₀ work₀ out₀ hinp hwork hout).strengthen_post ?_ + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨rfl, rfl, nofun, fun j _ => rfl⟩ + | cons t ts ih => + intro hnodup B inp₀ work₀ out₀ hinp hout hwork htarget + have htnts : t ∉ ts := (List.nodup_cons.mp hnodup).1 + have htsnodup : ts.Nodup := (List.nodup_cons.mp hnodup).2 + have hP : ∀ (inp : Tape) (work : Fin n → Tape) (out : Tape) + (inp' : Tape) (work' : Fin n → Tape) (out' : Tape), + ((work t).cells = (work₀ t).cells ∧ + inp = inp₀ ∧ out = out₀ ∧ ∀ j, j ≠ t → work j = work₀ j) → + (work' t).cells = (work t).cells → (work' t).head = 1 → + (∀ j, j ≠ t → work' j = work j) → + inp' = inp → out'.cells = out.cells → out'.head = out.head → + ((work' t).cells = (work₀ t).cells ∧ + inp' = inp₀ ∧ out' = out₀ ∧ ∀ j, j ≠ t → work' j = work₀ j) := by + rintro inp work out inp' work' out' ⟨hcellsP, rfl, rfl, hrest⟩ hcells' _ hkeep rfl + hout'c hout'h + exact ⟨hcells'.trans hcellsP, rfl, Tape.ext hout'h hout'c, + fun j hjt => (hkeep j hjt).trans (hrest j hjt)⟩ + have h1 := rewindWorkTM_hoareTime_frame t B hP + have h1' := h1.weaken_pre + (show (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) ≤ _ by + rintro inp work out ⟨rfl, rfl, rfl⟩ + exact ⟨(htarget t (by simp)).1, fun j hj => (hwork t).2 j hj, (htarget t (by simp)).2, + hinp.read_ne_start, hout.read_ne_start, hout.1, + fun i _ => ⟨(hwork i).read_ne_start, (hwork i).1⟩, rfl, rfl, rfl, fun _ _ => rfl⟩) + set work₁ : Fin n → Tape := Function.update work₀ t (⟨1, (work₀ t).cells⟩ : Tape) with hwork₁ + have hwork₁P : ∀ j, Parked (work₁ j) := by + intro j + by_cases hjt : j = t + · rw [hjt, hwork₁, Function.update_self] + exact ⟨le_refl 1, fun i hi => (hwork t).2 i hi⟩ + · rw [hwork₁, Function.update_of_ne hjt]; exact hwork j + have hwork₁target : ∀ j, j ∈ ts → (work₁ j).cells 0 = Γ.start ∧ (work₁ j).head ≤ B := by + intro j hj + have hjt : j ≠ t := by rintro rfl; exact htnts hj + rw [hwork₁, Function.update_of_ne hjt] + exact htarget j (by simp [hj]) + have ih' := ih htsnodup B inp₀ work₁ out₀ hinp hout hwork₁P hwork₁target + have hread_t : ∀ (work : Fin n → Tape), (work t).cells = (work₀ t).cells → + (work t).head = 1 → (work t).read ≠ Γ.start := by + intro work hcells hhead + show (work t).cells (work t).head ≠ Γ.start + rw [hhead, hcells] + exact (hwork t).2 1 le_rfl + have h2 : (bigSeqTM ((t :: ts).map rewindWorkTM)).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + (∀ j, j ∈ ts → work j = ⟨1, (work₁ j).cells⟩) ∧ + (∀ j, j ∉ ts → work j = work₁ j)) + ((B + 2) + 1 + (ts.length * (B + 3) + 1)) := by + simp only [List.map_cons, bigSeqTM] + refine seqTM_hoareTime (rewindWorkTM t) (bigSeqTM (ts.map rewindWorkTM)) h1' ?_ ih' + rintro inp work out ⟨hhead1, hcellsP, hpinp, hpout, hprest⟩ + have hreadt : (work t).read ≠ Γ.start := hread_t work hcellsP hhead1 + have ht1 : transitionInput inp = inp₀ := by + rw [hpinp]; exact transitionInput_eq_self hinp.read_ne_start + have ht3 : transitionTape out = out₀ := by + rw [hpout]; exact transitionTape_eq_self hout.read_ne_start + have ht2 : (fun i => transitionTape (work i)) = work₁ := by + funext j + by_cases hjt : j = t + · rw [hjt, transitionTape_eq_self hreadt, hwork₁, Function.update_self] + exact Tape.ext hhead1 hcellsP + · rw [hprest j hjt, transitionTape_eq_self (hwork j).read_ne_start, + hwork₁, Function.update_of_ne hjt] + rw [ht1, ht2, ht3] + exact ⟨rfl, rfl, rfl⟩ + refine h2.consequence (fun _ _ _ h => h) + (fun inp work out ⟨hinpeq, houteq, hts, hnts⟩ => ?_) + (by rw [List.length_cons]; ring_nf; omega) + refine ⟨hinpeq, houteq, fun j hj => ?_, fun j hj => ?_⟩ + · rw [List.mem_cons] at hj + rcases hj with hjeqt | hjts + · rw [hnts j (hjeqt ▸ htnts), hjeqt, hwork₁, Function.update_self] + · rw [hts j hjts] + congr 1 + have hjt : j ≠ t := fun h => htnts (h ▸ hjts) + rw [hwork₁, Function.update_of_ne hjt] + · have hjt : j ≠ t := fun h => hj (List.mem_cons.mpr (Or.inl h)) + have hjts : j ∉ ts := fun h => hj (List.mem_cons.mpr (Or.inr h)) + rw [hnts j hjts, hwork₁, Function.update_of_ne hjt] + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean b/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean new file mode 100644 index 00000000..f22ed4e6 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/WipeLoop.lean @@ -0,0 +1,252 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Registers +public import Complexitylib.Models.TuringMachine.Registers.ForReg +public import Complexitylib.Models.TuringMachine.Registers.RegisterOps +public import Complexitylib.Models.TuringMachine.Subroutines.WipeStep + +/-! +# The wipe loop + +`TM.forRegTM` drives a body an exact number of times off a dedicated unary fuel +register. Running `TM.wipeStepTM` through it, fueled by a register holding `v` +marks unrelated to any targeted tape's content, blanks the leading `v` cells of +every target whatever was there. + +## Main results + +- `TM.wipedTape` — the closed form of `v` wipe steps applied to a tape +- `TM.wipeLoop_hoareTime` — the loop's contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Wipe-step applied `i` times to `t`, in closed form. -/ +def wipedTape (t : Tape) (i : ℕ) : Tape := + (fun s : Tape => s.writeAndMove Γw.blank.toΓ Dir3.right)^[i] t + +@[simp] theorem wipedTape_zero (t : Tape) : wipedTape t 0 = t := rfl + +theorem wipedTape_succ (t : Tape) (i : ℕ) : + wipedTape t (i + 1) = (wipedTape t i).writeAndMove Γw.blank.toΓ Dir3.right := + Function.iterate_succ_apply' _ i t + +/-- Wiping advances the head one cell per step. -/ +theorem wipedTape_head (t : Tape) (i : ℕ) : (wipedTape t i).head = t.head + i := by + induction i with + | zero => rfl + | succ i ih => + rw [wipedTape_succ] + show (((wipedTape t i).write Γw.blank.toΓ).move Dir3.right).head = t.head + (i + 1) + rw [show (((wipedTape t i).write Γw.blank.toΓ).move Dir3.right).head + = ((wipedTape t i).write Γw.blank.toΓ).head + 1 from rfl, + Tape.write_head, ih] + omega + +/-- **What wiping does.** From a head parked at cell `1`, wiping `H` times +blanks exactly cells `1 … H` and leaves every other cell alone. -/ +theorem wipedTape_cells_of_head_one {t : Tape} (hh : t.head = 1) (H j : ℕ) : + (wipedTape t H).cells j = if 1 ≤ j ∧ j ≤ H then Γ.blank else t.cells j := by + induction H with + | zero => rw [wipedTape_zero, if_neg (by omega : ¬(1 ≤ j ∧ j ≤ 0))] + | succ H ih => + have hheadH : (wipedTape t H).head = H + 1 := by rw [wipedTape_head, hh]; omega + rw [wipedTape_succ] + show (((wipedTape t H).write Γw.blank.toΓ).move Dir3.right).cells j = _ + rw [Tape.move_cells, Tape.write, if_neg (by rw [hheadH]; omega)] + show Function.update (wipedTape t H).cells (wipedTape t H).head Γw.blank.toΓ j = _ + rw [hheadH] + by_cases hj : j = H + 1 + · rw [hj, Function.update_self, if_pos ⟨by omega, by omega⟩] + rfl + · rw [Function.update_of_ne hj, ih] + by_cases hc : 1 ≤ j ∧ j ≤ H + · rw [if_pos hc, if_pos ⟨hc.1, by omega⟩] + · have hc' : ¬(1 ≤ j ∧ j ≤ H + 1) := by + rintro ⟨h1, h2⟩ + exact hc ⟨h1, by omega⟩ + rw [if_neg hc, if_neg hc'] + +/-- The canonical blank tape's cells, spelled out. -/ +theorem initNil_cells (j : ℕ) : + (Tape.init ([] : List Γ)).cells j = if j = 0 then Γ.start else Γ.blank := by + cases j with + | zero => exact Tape.init_cells_zero [] + | succ i => rw [Tape.init_cells_ge [] i (by simp), if_neg (Nat.succ_ne_zero i)] + +/-- **Wiping really blanks the tape.** A tape parked at cell `1` whose content +is confined to cells `1 … H` becomes literally the blank tape (head at `H + 1`) +after `H` wipe steps — this is where the content-agnostic wipe pays off: no +assumption is made about *where* inside `1 … H` the nonblank cells sit. -/ +theorem wipedTape_eq_blank {t : Tape} (H : ℕ) (hh : t.head = 1) + (h0 : t.cells 0 = Γ.start) (hfar : ∀ j, H < j → t.cells j = Γ.blank) : + wipedTape t H = (⟨H + 1, (Tape.init ([] : List Γ)).cells⟩ : Tape) := by + refine Tape.ext (by rw [wipedTape_head, hh]; show 1 + H = H + 1; omega) (funext fun j => ?_) + rw [wipedTape_cells_of_head_one hh, initNil_cells] + by_cases hj0 : j = 0 + · rw [hj0, if_neg (by omega : ¬(1 ≤ 0 ∧ 0 ≤ H)), if_pos rfl, h0] + · rw [if_neg hj0] + by_cases hc : 1 ≤ j ∧ j ≤ H + · rw [if_pos hc] + · rw [if_neg hc, hfar j (by omega)] + +/-- Wiping preserves `Parked`-ness: the head only advances, and every +written or untouched cell beyond the marker stays off `▷`. -/ +theorem wipedTape_parked {t : Tape} (h : Parked t) (i : ℕ) : Parked (wipedTape t i) := by + induction i with + | zero => exact h + | succ i ih => + rw [wipedTape_succ] + have hheq : (wipedTape t i).writeAndMove Γw.blank.toΓ Dir3.right = + ((wipedTape t i).write Γw.blank.toΓ).move Dir3.right := rfl + have hhead_ne : (wipedTape t i).head ≠ 0 := by + have := ih.1; omega + refine ⟨?_, fun j hj => ?_⟩ + · rw [hheq] + show 1 ≤ ((wipedTape t i).write Γw.blank.toΓ).head + 1 + omega + · rw [hheq, Tape.move_cells] + simp only [Tape.write, if_neg hhead_ne] + show Function.update (wipedTape t i).cells (wipedTape t i).head Γw.blank.toΓ j ≠ Γ.start + by_cases hje : j = (wipedTape t i).head + · rw [hje, Function.update_self]; decide + · rw [Function.update_of_ne hje]; exact ih.2 j hj + +/-- A fresh output tape (`(Tape.init []).move Dir3.right`) is `Parked`. -/ +theorem parked_parkedBlank : Parked ((Tape.init []).move Dir3.right) := by + refine ⟨le_refl 1, fun j hj => ?_⟩ + rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + decide + +/-- A fresh output tape satisfies the empty output accumulator. -/ +theorem outAcc_nil_of_parkedBlank : + OutAcc [] ((Tape.init []).move Dir3.right) := by + refine ⟨rfl, ?_, nofun, fun j hj => ?_⟩ + · rw [Tape.move_cells]; exact Tape.init_cells_zero [] + · rw [Tape.move_cells, show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + +/-- The only tape satisfying the empty output accumulator is the fresh +parked blank tape. -/ +theorem eq_parkedBlank_of_outAcc_nil {t : Tape} (h : OutAcc [] t) : + t = (Tape.init []).move Dir3.right := by + obtain ⟨hhead, hcell0, -, htail⟩ := h + refine Tape.ext ?_ ?_ + · rw [hhead]; rfl + · rw [Tape.move_cells] + funext j + rcases Nat.eq_zero_or_pos j with hj0 | hj1 + · subst hj0; rw [hcell0, Tape.init_cells_zero] + · rw [htail j (by simpa using hj1), show j = (j - 1) + 1 from by omega, + Tape.init_cells_ge [] (j - 1) (by simp)] + +/-- The register-shaped tape at iteration `i` is `Parked`. -/ +theorem regIterCells_parked (v i : ℕ) : Parked (⟨i + 2, regCells v⟩ : Tape) := by + refine ⟨show 1 ≤ i + 2 by omega, fun j _ => ?_⟩ + show regCells v j ≠ Γ.start + simp only [regCells] + split + · omega + · split <;> decide + +/-- **The wipe loop.** Fueled by a register at `r` holding `v` marks (`r` +disjoint from `targets`), `forRegTM (wipeStepTM targets) r` blanks the leading +`v` cells of every tape in `targets`, leaving every other tape — including the +fuel register itself — exactly as it was. -/ +theorem wipeLoop_hoareTime {n : ℕ} (targets : List (Fin n)) (r : Fin n) + (hr : r ∉ targets) (v : ℕ) (inp₀ : Tape) (work₀ : Fin n → Tape) + (hinp₀ : Parked inp₀) + (hother : ∀ j, j ≠ r → Parked (work₀ j)) : + (forRegTM (wipeStepTM targets) r).HoareTime + (fun inp work out => inp = inp₀ ∧ + work = Function.update work₀ r (regTape v) ∧ + out = (Tape.init []).move Dir3.right) + (fun inp work out => inp = inp₀ ∧ + work = Function.update + (fun j => if j ∈ targets then wipedTape (work₀ j) v else work₀ j) r (regTape v) ∧ + out = (Tape.init []).move Dir3.right) + (v * 3 + (v + 2)) := by + set w : ℕ → Fin n → Tape := fun i j => + if j = r then regTape v else if j ∈ targets then wipedTape (work₀ j) i else work₀ j + with hw + have hw0 : w 0 = Function.update work₀ r (regTape v) := by + funext j + by_cases hjr : j = r + · subst hjr; simp [hw, Function.update_self] + · rw [Function.update_of_ne hjr] + simp only [hw, if_neg hjr] + split + · rfl + · rfl + have hwv : w v = Function.update + (fun j => if j ∈ targets then wipedTape (work₀ j) v else work₀ j) r (regTape v) := by + funext j + by_cases hjr : j = r + · subst hjr; simp [hw, Function.update_self] + · rw [Function.update_of_ne hjr]; simp [hw, if_neg hjr] + have hwork_parked : ∀ i j, j ≠ r → Parked (w i j) := by + intro i j hjr + by_cases hjt : j ∈ targets + · simp only [hw, if_neg hjr, if_pos hjt] + exact wipedTape_parked (hother j hjr) i + · simp only [hw, if_neg hjr, if_neg hjt] + exact hother j hjr + have hbody : ∀ i, i < v → (wipeStepTM targets).HoareTime + (fun inp work out => inp = inp₀ ∧ + work = Function.update (w i) r (⟨i + 2, regCells v⟩ : Tape) ∧ OutAcc [] out) + (fun inp work out => inp = inp₀ ∧ + work = Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) ∧ OutAcc [] out) + 1 := by + intro i _ + set W : Fin n → Tape := Function.update (w i) r (⟨i + 2, regCells v⟩ : Tape) with hW + have hcopy := wipeStepTM_hoareTime targets inp₀ W ((Tape.init []).move Dir3.right) + hinp₀ parked_parkedBlank + (fun k _ => by + by_cases hkr : k = r + · subst hkr; rw [hW, Function.update_self]; exact regIterCells_parked v i + · rw [hW, Function.update_of_ne hkr]; exact hwork_parked i k hkr) + refine (hcopy.weaken_pre ?_).strengthen_post ?_ + · rintro inp work out ⟨rfl, rfl, hout⟩ + exact ⟨rfl, rfl, eq_parkedBlank_of_outAcc_nil hout⟩ + · rintro inp work out ⟨rfl, hout, hwork⟩ + refine ⟨rfl, ?_, hout ▸ outAcc_nil_of_parkedBlank⟩ + funext j + rw [hwork j] + by_cases hjr : j = r + · subst hjr + rw [if_neg hr, hW, Function.update_self, Function.update_self] + · by_cases hjt : j ∈ targets + · rw [if_pos hjt] + have hWj : W j = wipedTape (work₀ j) i := by + rw [hW, Function.update_of_ne hjr, hw]; simp [if_neg hjr, if_pos hjt] + have hRj : Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) j = + wipedTape (work₀ j) (i + 1) := by + rw [Function.update_of_ne hjr, hw]; simp [if_neg hjr, if_pos hjt] + rw [hWj, hRj, wipedTape_succ] + · rw [if_neg hjt] + have hWj : W j = work₀ j := by + rw [hW, Function.update_of_ne hjr, hw]; simp [if_neg hjr, if_neg hjt] + have hRj : Function.update (w (i + 1)) r (⟨i + 2, regCells v⟩ : Tape) j = work₀ j := by + rw [Function.update_of_ne hjr, hw]; simp [if_neg hjr, if_neg hjt] + rw [hWj, hRj] + have key := forRegTM_hoareTime (wipeStepTM targets) r v inp₀ w (fun _ => []) 1 hinp₀ + (fun i => by simp [hw]) hwork_parked hbody + refine key.consequence + (fun inp work out ⟨h1, h2, h3⟩ => ⟨h1, by rw [h2, hw0], h3 ▸ outAcc_nil_of_parkedBlank⟩) + (fun inp work out ⟨h1, h2, h3⟩ => ⟨h1, by rw [h2, hwv], (eq_parkedBlank_of_outAcc_nil h3)⟩) + (by omega) + +end TM + +end Complexity diff --git a/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean b/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean new file mode 100644 index 00000000..371edbb5 --- /dev/null +++ b/Complexitylib/Models/TuringMachine/Subroutines/WipeStep.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Bolton Bailey. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bolton Bailey +-/ + +module +public import Complexitylib.Models.TuringMachine.Frame +public import Complexitylib.Models.TuringMachine.Subroutines.Internal + +/-! +# An unconditional, content-agnostic wipe step + +Reusing an opaque machine's scratch tapes across calls needs them genuinely +blank in between, but an arbitrary machine may leave *gaps* — an isolated blank +cell with more content beyond it — and a content-driven scanner +(`TM.blankWorkTM` stops at the first blank) under-wipes there. `TM.wipeStepTM` +writes `Γ.blank` to every targeted tape and advances, unconditionally, never +reading what it overwrites; iterated a known number of times it blanks an exact +number of cells whatever was there. + +## Main results + +- `TM.wipeStepTM` — blank one cell of every targeted tape and advance +- `TM.wipeStepTM_hoareTime` — its one-step contract +-/ + + +@[expose] public section + +namespace Complexity + +namespace TM + +/-- Control states of the unconditional wipe-step machine. -/ +inductive WipeStepPhase where + /-- Write blank to every targeted tape and advance; then halt. -/ + | running + /-- Halted. -/ + | done + deriving DecidableEq + +instance instFintypeWipeStepPhase : Fintype WipeStepPhase where + elems := {.running, .done} + complete := fun p => by cases p <;> simp + +/-- One unconditional step: every work tape named in `targets` is written +`Γ.blank` and its head advances right; every other work tape, the input, and +the output are held by `readBackWrite`/`idleDir`. Does not inspect the +targeted tapes' contents at all. -/ +def wipeStepTM {n : ℕ} (targets : List (Fin n)) : TM n where + Q := WipeStepPhase + qstart := .running + qhalt := .done + δ := fun state iHead wHeads oHead => + match state with + | .running => + (.done, + fun i => if i ∈ targets then Γw.blank else readBackWrite (wHeads i), + readBackWrite oHead, idleDir iHead, + fun i => if i ∈ targets 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 + | .running => + refine ⟨idleDir_right_of_start, fun i hi => ?_, idleDir_right_of_start⟩ + dsimp only + split + · rfl + · exact idleDir_right_of_start hi + | .done => exact rightOfStart_allIdle iHead wHeads oHead + +/-- **`wipeStepTM`'s exact one-step Hoare contract.** From tapes where every +non-targeted work tape, the input, and the output are `Parked`, one step +unconditionally blanks and advances every targeted work tape and preserves +everything else exactly. -/ +theorem wipeStepTM_hoareTime {n : ℕ} (targets : List (Fin n)) + (inp₀ : Tape) (work₀ : Fin n → Tape) (out₀ : Tape) + (hinp : Parked inp₀) (hout : Parked out₀) + (hother : ∀ i, i ∉ targets → Parked (work₀ i)) : + (wipeStepTM targets).HoareTime + (fun inp work out => inp = inp₀ ∧ work = work₀ ∧ out = out₀) + (fun inp work out => inp = inp₀ ∧ out = out₀ ∧ + ∀ i, work i = if i ∈ targets then (work₀ i).writeAndMove Γw.blank.toΓ Dir3.right + else work₀ i) + 1 := by + rintro inp work out ⟨rfl, rfl, rfl⟩ + refine ⟨(⟨WipeStepPhase.done, + inp.move (idleDir inp.read), + (fun i => if i ∈ targets then (work i).writeAndMove Γw.blank.toΓ Dir3.right + else (work i).writeAndMove (readBackWrite (work i).read) (idleDir (work i).read)), + out.writeAndMove (readBackWrite out.read) (idleDir out.read)⟩ : + Cfg n (wipeStepTM targets).Q), + 1, le_refl 1, ?_, rfl, hinp.move_idle, hout.writeAndMove_readBack_idle, fun i => ?_⟩ + · refine TM.reachesIn.step ?_ .zero + simp only [TM.step, wipeStepTM, + if_neg (show WipeStepPhase.running ≠ WipeStepPhase.done by decide)] + congr 1 + congr 1 + funext i + split <;> rfl + · dsimp only + split + · rfl + · next hi => exact (hother i hi).writeAndMove_readBack_idle + +end TM + +end Complexity